src/TSN/XML/News.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
  11 --   root element \<message\> that contains an entire news item.
  12 --
  13 module TSN.XML.News (
  14   pickle_message,
  15   -- * Tests
  16   news_tests,
  17   -- * WARNING: these are private but exported to silence warnings
  18   News_NewsLocationConstructor(..),
  19   News_NewsTeamConstructor(..),
  20   NewsConstructor(..),
  21   NewsLocationConstructor(..),
  22   NewsTeamConstructor(..) )
  23 where
  24
  25 -- System imports.
  26 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
  27 import Data.Time.Clock ( UTCTime )
  28 import Data.List.Utils ( join, split )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Data.Typeable ( Typeable )
  31 import Database.Groundhog (
  32   insert_,
  33   migrate )
  34 import Database.Groundhog.Core ( DefaultKey )
  35 import Database.Groundhog.TH (
  36   defaultCodegenConfig,
  37   groundhog,
  38   mkPersist )
  39 import Test.Tasty ( TestTree, testGroup )
  40 import Test.Tasty.HUnit ( (@?=), testCase )
  41 import Text.XML.HXT.Core (
  42   PU,
  43   xp13Tuple,
  44   xpAttr,
  45   xpElem,
  46   xpInt,
  47   xpList,
  48   xpOption,
  49   xpPair,
  50   xpText,
  51   xpTriple,
  52   xpWrap )
  53
  54 -- Local imports.
  55 import TSN.Codegen (
  56   tsn_codegen_config,
  57   tsn_db_field_namer ) -- Used in a test
  58 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  59 import TSN.Picklers ( xp_time_stamp )
  60 import TSN.XmlImport ( XmlImport(..) )
  61 import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
  62
  63
  64
  65 -- | The database type for teams as they show up in the news.
  66 --
  67 data NewsTeam =
  68   NewsTeam { team_name :: String }
  69   deriving (Eq, Show)
  70
  71
  72 instance ToDb NewsTeam where
  73   -- | The database representaion of a 'NewsTeam' is itself.
  74   type Db NewsTeam = NewsTeam
  75
  76 -- | This is needed to define the XmlImport instance for NewsTeam.
  77 --
  78 instance FromXml NewsTeam where
  79   -- | How to we get a 'NewsTeam' from itself?
  80   from_xml = id
  81
  82 -- | Allow us to call 'insert_xml' on the XML representation of
  83 --   NewsTeams.
  84 --
  85 instance XmlImport NewsTeam
  86
  87
  88 -- | Mapping between News records and NewsTeam records in the
  89 --   database. We don't name the fields because we don't use the names
  90 --   explicitly; that means we have to give them nice database names
  91 --   via groundhog.
  92 --
  93 data News_NewsTeam = News_NewsTeam
  94                        (DefaultKey News)
  95                        (DefaultKey NewsTeam)
  96
  97
  98 -- | The database type for locations as they show up in the news.
  99 --
 100 data NewsLocation =
 101   NewsLocation {
 102     city :: Maybe String,
 103     state :: Maybe String,
 104     country :: String }
 105   deriving (Eq, Show)
 106
 107 instance ToDb NewsLocation where
 108   -- | The database representation of a 'NewsLocation' is itself.
 109   type Db NewsLocation = NewsLocation
 110
 111 -- | This is needed to define the XmlImport instance for NewsLocation.
 112 --
 113 instance FromXml NewsLocation where
 114   -- | How to we get a 'NewsLocation' from itself?
 115   from_xml = id
 116
 117 -- | Allow us to call 'insert_xml' on the XML representation of
 118 --   NewsLocations.
 119 --
 120 instance XmlImport NewsLocation
 121
 122
 123 -- | Mapping between News records and NewsLocation records in the
 124 --   database. We don't name the fields because we don't use the names
 125 --   explicitly; that means we have to give them nice database names
 126 --   via groundhog.
 127 --
 128 data News_NewsLocation = News_NewsLocation
 129                            (DefaultKey News)
 130                            (DefaultKey NewsLocation)
 131
 132
 133 -- | The msg_id child of <message> contains an event_id attribute; we
 134 --   embed it into the 'News' type. We (pointlessly) use the "db_"
 135 --   prefix here so that the two names don't collide on "id" when
 136 --   Groundhog is creating its fields using our field namer.
 137 data MsgId =
 138   MsgId {
 139     db_msg_id       :: Int,
 140     db_event_id     :: Maybe Int }
 141   deriving (Data, Eq, Show, Typeable)
 142
 143
 144 -- | The XML representation of a news item (message).
 145 --
 146 data Message =
 147   Message {
 148     xml_xml_file_id :: Int,
 149     xml_heading :: String,
 150     xml_mid :: MsgId,
 151     xml_category :: String,
 152     xml_sport :: String,
 153     xml_url :: Maybe String,
 154     xml_teams :: [NewsTeam],
 155     xml_locations :: [NewsLocation],
 156     xml_sms :: String,
 157     xml_editor :: Maybe String,
 158     xml_text :: Maybe String,     -- Text and continue seem to show up in pairs,
 159     xml_continue :: Maybe String, -- either both present or both missing.
 160     xml_time_stamp :: UTCTime }
 161   deriving (Eq, Show)
 162
 163
 164 -- | The database representation of a news item. We drop several
 165 --   uninteresting fields from 'Message', and omit the list fields which
 166 --   will be represented as join tables.
 167 --
 168 data News =
 169   News {
 170     db_mid :: MsgId,
 171     db_sport :: String,
 172     db_url :: Maybe String,
 173     db_sms :: String,
 174     db_editor :: Maybe String,
 175     db_text :: Maybe String,
 176     db_continue :: Maybe String,
 177     db_time_stamp :: UTCTime }
 178   deriving (Data, Eq, Show, Typeable)
 179
 180
 181
 182 instance ToDb Message where
 183   type Db Message = News
 184
 185 -- | Convert the XML representation 'Message' to the database
 186 --   representation 'News'.
 187 --
 188 instance FromXml Message where
 189   -- | We use a record wildcard so GHC doesn't complain that we never
 190   --   used the field names.
 191   --
 192   from_xml Message{..} = News { db_mid = xml_mid,
 193                                 db_sport = xml_sport,
 194                                 db_url = xml_url,
 195                                 db_sms = xml_sms,
 196                                 db_editor = xml_editor,
 197                                 db_text = xml_text,
 198                                 db_continue = xml_continue,
 199                                 db_time_stamp = xml_time_stamp }
 200
 201 -- | This lets us call 'insert_xml' on a 'Message'.
 202 --
 203 instance XmlImport Message
 204
 205 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
 206 --   slightly non-generic because of our 'News_NewsTeam' and
 207 --   'News_NewsLocation' join tables.
 208 --
 209 instance DbImport Message where
 210   dbmigrate _ =
 211     run_dbmigrate $ do
 212       migrate (undefined :: NewsTeam)
 213       migrate (undefined :: NewsLocation)
 214       migrate (undefined :: News)
 215       migrate (undefined :: News_NewsTeam)
 216       migrate (undefined :: News_NewsLocation)
 217
 218   dbimport message = do
 219     -- Insert the message and acquire its primary key (unique ID)
 220     news_id <- insert_xml message
 221
 222     -- And insert each one into its own table. We use insert_xml_or_select
 223     -- because we know that most teams will already exist, and we
 224     -- want to get back the id for the existing team when
 225     -- there's a collision.
 226     nt_ids <- mapM insert_xml_or_select (xml_teams message)
 227
 228     -- Now that the teams have been inserted, create
 229     -- news__news_team records mapping beween the two.
 230     let news_news_teams = map (News_NewsTeam news_id) nt_ids
 231     mapM_ insert_ news_news_teams
 232
 233     -- Do all of that over again for the NewsLocations.
 234     loc_ids <- mapM insert_xml_or_select (xml_locations message)
 235     let news_news_locations = map (News_NewsLocation news_id) loc_ids
 236     mapM_ insert_ news_news_locations
 237
 238     return ImportSucceeded
 239
 240
 241 -- These types don't have special XML representations or field name
 242 -- collisions so we use the defaultCodegenConfig and give their
 243 -- fields nice simple names.
 244 mkPersist defaultCodegenConfig [groundhog|
 245 - entity: NewsTeam
 246   dbName: news_teams
 247   constructors:
 248     - name: NewsTeam
 249       uniques:
 250         - name: unique_news_team
 251           type: constraint
 252           fields: [team_name]
 253
 254 - entity: NewsLocation
 255   dbName: news_locations
 256   constructors:
 257     - name: NewsLocation
 258       uniques:
 259         - name: unique_news_location
 260           type: constraint
 261           fields: [city, state, country]
 262
 263 |]
 264
 265
 266 -- These types have fields with e.g. db_ and xml_ prefixes, so we
 267 -- use our own codegen to peel those off before naming the columns.
 268 mkPersist tsn_codegen_config [groundhog|
 269 - entity: News
 270   dbName: news
 271   constructors:
 272     - name: News
 273       fields:
 274         - name: db_mid
 275           embeddedType:
 276             - {name: msg_id, dbName: msg_id}
 277             - {name: event_id, dbName: event_id}
 278 - embedded: MsgId
 279   fields:
 280     - name: db_msg_id
 281       dbName: msg_id
 282     - name: db_event_id
 283       dbName: event_id
 284
 285
 286 - entity: News_NewsTeam
 287   dbName: news__news_teams
 288   constructors:
 289     - name: News_NewsTeam
 290       fields:
 291         - name: news_NewsTeam0 # Default created by mkNormalFieldName
 292           dbName: news_id
 293           reference:
 294             onDelete: cascade
 295         - name: news_NewsTeam1 # Default created by mkNormalFieldName
 296           dbName: news_teams_id
 297           reference:
 298             onDelete: cascade
 299
 300 - entity: News_NewsLocation
 301   dbName: news__news_locations
 302   constructors:
 303     - name: News_NewsLocation
 304       fields:
 305         - name: news_NewsLocation0 # Default created by mkNormalFieldName
 306           dbName: news_id
 307           reference:
 308             onDelete: cascade
 309         - name: news_NewsLocation1 # Default created by mkNormalFieldName
 310           dbName: news_locations_id
 311           reference:
 312             onDelete: cascade
 313 |]
 314
 315
 316 -- | Convert a 'NewsTeam' to/from XML.
 317 --
 318 pickle_news_team :: PU NewsTeam
 319 pickle_news_team =
 320   xpElem "team" $
 321     xpWrap (from_string, to_string) xpText
 322   where
 323     to_string :: NewsTeam -> String
 324     to_string = team_name
 325
 326     from_string :: String -> NewsTeam
 327     from_string = NewsTeam
 328
 329
 330 -- | Convert a 'MsgId' to/from XML.
 331 --
 332 pickle_msg_id :: PU MsgId
 333 pickle_msg_id =
 334   xpElem "msg_id" $
 335     xpWrap (from_tuple, to_tuple) $
 336     xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
 337   where
 338     from_tuple = uncurryN MsgId
 339     to_tuple m = (db_msg_id m, db_event_id m)
 340
 341
 342 -- | Convert a 'NewsLocation' to/from XML.
 343 --
 344 pickle_location :: PU NewsLocation
 345 pickle_location =
 346   xpElem "location" $
 347     xpWrap (from_tuple, to_tuple) $
 348     xpTriple (xpOption (xpElem "city" xpText))
 349              (xpOption (xpElem "state" xpText))
 350              (xpElem "country" xpText)
 351   where
 352     from_tuple =
 353       uncurryN NewsLocation
 354     to_tuple l = (city l, state l, country l)
 355
 356
 357 -- | Convert a 'Message' to/from XML.
 358 --
 359 pickle_message :: PU Message
 360 pickle_message =
 361   xpElem "message" $
 362     xpWrap (from_tuple, to_tuple) $
 363     xp13Tuple (xpElem "XML_File_ID" xpInt)
 364               (xpElem "heading" xpText)
 365               pickle_msg_id
 366               (xpElem "category" xpText)
 367               (xpElem "sport" xpText)
 368               (xpElem "url" $ xpOption xpText)
 369               (xpList pickle_news_team)
 370               (xpList pickle_location)
 371               (xpElem "SMS" xpText)
 372               (xpOption (xpElem "Editor" xpText))
 373               (xpOption (xpElem "text" xpText))
 374               pickle_continue
 375               (xpElem "time_stamp" xp_time_stamp)
 376   where
 377     from_tuple = uncurryN Message
 378     to_tuple m = (xml_xml_file_id m, -- Verbose,
 379                   xml_heading m,     -- but
 380                   xml_mid m,         -- eliminates
 381                   xml_category m,    -- GHC
 382                   xml_sport m,       -- warnings
 383                   xml_url m,         -- .
 384                   xml_teams m,       -- .
 385                   xml_locations m,   -- .
 386                   xml_sms m,
 387                   xml_editor m,
 388                   xml_text m,
 389                   xml_continue m,
 390                   xml_time_stamp m)
 391
 392     -- | We combine all of the \<continue\> elements into one 'String'
 393     --   while unpickling and do the reverse while pickling.
 394     --
 395     pickle_continue :: PU (Maybe String)
 396     pickle_continue =
 397       xpOption $
 398         xpWrap (to_string, from_string) $
 399           xpElem "continue" $
 400             xpList (xpElem "P" xpText)
 401       where
 402         from_string :: String -> [String]
 403         from_string = split "\n"
 404
 405         to_string :: [String] -> String
 406         to_string = join "\n"
 407
 408
 409 --
 410 -- Tasty Tests
 411 --
 412
 413 -- | A list of all tests for this module.
 414 --
 415 news_tests :: TestTree
 416 news_tests =
 417   testGroup
 418     "News tests"
 419     [ test_news_fields_have_correct_names,
 420       test_pickle_of_unpickle_is_identity,
 421       test_unpickle_succeeds ]
 422
 423
 424 -- | Make sure our codegen is producing the correct database names.
 425 --
 426 test_news_fields_have_correct_names :: TestTree
 427 test_news_fields_have_correct_names =
 428   testCase "news fields get correct database names" $
 429     mapM_ check (zip actual expected)
 430   where
 431     -- This is cool, it uses the (derived) Data instance of
 432     -- News.News to get its constructor names.
 433     field_names :: [String]
 434     field_names =
 435       constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
 436
 437     expected :: [String]
 438     expected =
 439       map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
 440
 441     actual :: [String]
 442     actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
 443
 444     check (x,y) = (x @?= y)
 445
 446
 447 -- | If we unpickle something and then pickle it, we should wind up
 448 --   with the same thing we started with. WARNING: success of this
 449 --   test does not mean that unpickling succeeded.
 450 --
 451 test_pickle_of_unpickle_is_identity :: TestTree
 452 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 453   [ check "pickle composed with unpickle is the identity"
 454           "test/xml/newsxml.xml",
 455
 456     check "pickle composed with unpickle is the identity (with Editor)"
 457           "test/xml/newsxml-with-editor.xml" ]
 458   where
 459     check desc path = testCase desc $ do
 460       (expected, actual) <- pickle_unpickle pickle_message path
 461       actual @?= expected
 462
 463
 464 -- | Make sure we can actually unpickle these things.
 465 --
 466 test_unpickle_succeeds :: TestTree
 467 test_unpickle_succeeds = testGroup "unpickle tests"
 468   [ check "unpickling succeeds"
 469           "test/xml/newsxml.xml",
 470
 471     check "unpickling succeeds (with Editor)"
 472           "test/xml/newsxml-with-editor.xml" ]
 473   where
 474     check desc path = testCase desc $ do
 475       actual <- unpickleable path pickle_message
 476       let expected = True
 477       actual @?= expected