src/TSN/XML/Scores.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD \"scoresxml.dtd\". Each document
  10 --   contains a single \<game\> and some \<location\>s.
  11 --
  12 module TSN.XML.Scores (
  13   dtd,
  14   pickle_message,
  15   -- * Tests
  16   scores_tests,
  17   -- * WARNING: these are private but exported to silence warnings
  18   Score_ScoreLocationConstructor(..),
  19   ScoreConstructor(..),
  20   ScoreGameConstructor(..),
  21   ScoreGameTeamConstructor(..),
  22   ScoreLocationConstructor(..),
  23   ScoreGame_ScoreGameTeamConstructor(..) )
  24 where
  25
  26 -- System imports.
  27 import Data.Data ( Data )
  28 import Data.Time ( UTCTime )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Data.Typeable ( Typeable )
  31 import Database.Groundhog (
  32   countAll,
  33   deleteAll,
  34   insert,
  35   insert_,
  36   migrate,
  37   runMigration,
  38   silentMigrationLogger )
  39 import Database.Groundhog.Core ( DefaultKey )
  40 import Database.Groundhog.Generic ( runDbConn )
  41 import Database.Groundhog.Sqlite ( withSqliteConn )
  42 import Database.Groundhog.TH (
  43   defaultCodegenConfig,
  44   groundhog,
  45   mkPersist )
  46 import Test.Tasty ( TestTree, testGroup )
  47 import Test.Tasty.HUnit ( (@?=), testCase )
  48 import Text.XML.HXT.Core (
  49   PU,
  50   xp7Tuple,
  51   xp11Tuple,
  52   xpAttr,
  53   xpElem,
  54   xpInt,
  55   xpList,
  56   xpOption,
  57   xpPair,
  58   xpPrim,
  59   xpText,
  60   xpTriple,
  61   xpWrap )
  62
  63 -- Local imports.
  64 import TSN.Codegen (
  65   tsn_codegen_config )
  66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  67 import TSN.Picklers ( xp_time_stamp )
  68 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  69 import Xml (
  70   Child(..),
  71   FromXml(..),
  72   FromXmlFk(..),
  73   ToDb(..),
  74   pickle_unpickle,
  75   unpickleable,
  76   unsafe_unpickle )
  77
  78
  79 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  80 --
  81 dtd :: String
  82 dtd = "scoresxml.dtd"
  83
  84
  85 ---
  86 --- DB/XML Data types
  87 ---
  88
  89
  90 -- * Score / Message
  91
  92 -- | Database representation of a 'Message'. It lacks the
  93 --   'xml_locations' and 'xml_game' which are related via foreign keys
  94 --   instead.
  95 --
  96 data Score =
  97   Score {
  98     db_xml_file_id :: Int,
  99     db_heading :: String,
 100     db_game_id :: Int,
 101     db_schedule_id :: Int,
 102     db_tsnupdate :: Maybe Bool,
 103     db_category :: String,
 104     db_sport :: String,
 105     db_season_type :: String,
 106     db_time_stamp :: UTCTime }
 107
 108
 109 -- | XML representation of the top level \<message\> element (i.e. a
 110 --   'Score').
 111 --
 112 data Message =
 113   Message {
 114     xml_xml_file_id :: Int,
 115     xml_heading :: String,
 116     xml_game_id :: Int,
 117     xml_schedule_id :: Int,
 118     xml_tsnupdate :: Maybe Bool,
 119     xml_category :: String,
 120     xml_sport :: String,
 121     xml_locations :: [ScoreLocation],
 122     xml_season_type :: String,
 123     xml_game :: ScoreGameXml,
 124     xml_time_stamp :: UTCTime }
 125   deriving (Eq, Show)
 126
 127 instance ToDb Message where
 128   -- | The database representation of a 'Message' is a 'Score'.
 129   type Db Message = Score
 130
 131 instance FromXml Message where
 132   from_xml Message{..} =
 133     Score {
 134       db_xml_file_id = xml_xml_file_id,
 135       db_heading = xml_heading,
 136       db_game_id = xml_game_id,
 137       db_schedule_id = xml_schedule_id,
 138       db_tsnupdate = xml_tsnupdate,
 139       db_category = xml_category,
 140       db_sport = xml_sport,
 141       db_season_type = xml_season_type,
 142       db_time_stamp = xml_time_stamp }
 143
 144
 145 -- | This lets us insert the XML representation 'Message' directly.
 146 --
 147 instance XmlImport Message
 148
 149
 150 -- * ScoreGame / ScoreGameXml
 151
 152 -- | This is an embedded field within 'SportsGame'. Each \<status\>
 153 --   element has two attributes, a numeral and a type. It also
 154 --   contains some text. Rather than put these in their own table, we
 155 --   include them in the parent 'SportsGame'.
 156 --
 157 data ScoreGameStatus =
 158   ScoreGameStatus {
 159     db_status_numeral :: Int,
 160     db_status_type :: String, -- ^ These are probably only one-character long,
 161                               --   but they all take the same amount of space
 162                               --   in Postgres.
 163     db_status_text :: String }
 164   deriving (Data, Eq, Show, Typeable)
 165
 166
 167 -- | Database representation of a game.
 168 --
 169 data ScoreGame =
 170   ScoreGame {
 171     db_scores_id :: DefaultKey Score,
 172     db_vscore :: Int,
 173     db_hscore :: Int,
 174     db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
 175     db_status :: ScoreGameStatus,
 176     db_notes  :: Maybe String }
 177
 178
 179 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
 180 --
 181 data ScoreGameXml =
 182   ScoreGameXml {
 183     xml_vteam  :: ScoreGameVTeam,
 184     xml_hteam  :: ScoreGameHTeam,
 185     xml_vscore :: Int,
 186     xml_hscore :: Int,
 187     xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
 188     xml_status :: ScoreGameStatus,
 189     xml_notes  :: Maybe String }
 190   deriving (Eq, Show)
 191
 192 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
 193 vteam :: ScoreGameXml -> ScoreGameTeam
 194 vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
 195
 196 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
 197 hteam :: ScoreGameXml -> ScoreGameTeam
 198 hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
 199
 200 instance ToDb ScoreGameXml where
 201   -- | The database representation of a 'ScoreGameXml' is a
 202   --   'ScoreGame'.
 203   --
 204   type Db ScoreGameXml = ScoreGame
 205
 206
 207 instance Child ScoreGameXml where
 208   -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
 209   --   a 'Score'.
 210   --
 211   type Parent ScoreGameXml = Score
 212
 213
 214 instance FromXmlFk ScoreGameXml where
 215   from_xml_fk fk ScoreGameXml{..} =
 216     ScoreGame {
 217       db_scores_id = fk,
 218       db_vscore = xml_vscore,
 219       db_hscore = xml_hscore,
 220       db_time_r = xml_time_r,
 221       db_status = xml_status,
 222       db_notes = xml_notes }
 223
 224 -- | This lets us import the database representation 'ScoreGameXml'
 225 --   directly.
 226 --
 227 instance XmlImportFk ScoreGameXml
 228
 229
 230 -- * ScoreGameTeam
 231
 232 -- | A team that appears in a 'ScoreGame'. This is meant to represent
 233 --   both home and away teams.
 234 --
 235 data ScoreGameTeam =
 236   ScoreGameTeam {
 237     team_id :: String,
 238     team_name :: String }
 239   deriving (Eq, Show)
 240
 241 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
 242 --   home and away teams. See also 'ScoreGameHTeam'.
 243 --
 244 newtype ScoreGameVTeam =
 245   ScoreGameVTeam ScoreGameTeam
 246   deriving (Eq, Show)
 247
 248
 249 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
 250 --   home and away teams. See also 'ScoreGameVTeam'.
 251 --
 252 newtype ScoreGameHTeam =
 253   ScoreGameHTeam ScoreGameTeam
 254   deriving (Eq, Show)
 255
 256
 257 -- * ScoreGame_ScoreGameTeam
 258
 259 -- | Join a 'ScoreGame' with its home/away teams. Database-only. We
 260 --   use a join table because the teams are kept unique. The first
 261 --   argument is the game id, the second argument is the visiting team
 262 --   (vteam) id, and the last argument is the home team (hteam) id.
 263 --
 264 data ScoreGame_ScoreGameTeam =
 265   ScoreGame_ScoreGameTeam
 266     (DefaultKey ScoreGame) -- game id
 267     (DefaultKey ScoreGameTeam) -- vteam id
 268     (DefaultKey ScoreGameTeam) -- hteam id
 269
 270
 271 -- * ScoreLocation
 272
 273 -- | Database and XML representation of a \<location\>. This is almost
 274 --   identical to 'TSN.XML.NewsLocation', but the city/state have not
 275 --   appeared optional here so far.
 276 --
 277 data ScoreLocation =
 278   ScoreLocation {
 279     city :: String,
 280     state :: String,
 281     country :: String }
 282   deriving (Eq, Show)
 283
 284
 285 -- * Score_ScoreLocation
 286
 287 -- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
 288 --   use a join table because the locations are kept unique.
 289 --
 290 data Score_ScoreLocation =
 291   Score_ScoreLocation
 292     (DefaultKey Score)
 293     (DefaultKey ScoreLocation)
 294
 295
 296
 297 instance DbImport Message where
 298   dbmigrate _ =
 299     run_dbmigrate $ do
 300       migrate (undefined :: Score)
 301       migrate (undefined :: ScoreGame)
 302       migrate (undefined :: ScoreGameTeam)
 303       migrate (undefined :: ScoreGame_ScoreGameTeam)
 304       migrate (undefined :: ScoreLocation)
 305       migrate (undefined :: Score_ScoreLocation)
 306
 307   dbimport m = do
 308     -- Insert the message and get its ID.
 309     msg_id <- insert_xml m
 310
 311     -- Insert all of the locations contained within this message and
 312     -- collect their IDs in a list.
 313     location_ids <- mapM insert (xml_locations m)
 314
 315     -- Now use that list to construct 'Score_ScoreLocation' objects,
 316     -- and insert them.
 317     mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
 318
 319     -- Insert the game and its hteam/vteam, noting the IDs.
 320     game_id <- insert_xml_fk msg_id (xml_game m)
 321     vteam_id <- insert (vteam $ xml_game m)
 322     hteam_id <- insert (hteam $ xml_game m)
 323
 324     -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
 325     -- aforementioned game to its hteam/vteam.
 326     insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
 327
 328     return ImportSucceeded
 329
 330
 331 -- These types don't have special XML representations or field name
 332 -- collisions so we use the defaultCodegenConfig and give their
 333 -- fields nice simple names.
 334 mkPersist defaultCodegenConfig [groundhog|
 335 - entity: ScoreGameTeam
 336   dbName: scores_games_teams
 337   constructors:
 338     - name: ScoreGameTeam
 339       uniques:
 340         - name: unique_scores_games_team
 341           type: constraint
 342           fields: [team_id]
 343
 344 - entity: ScoreLocation
 345   dbName: scores_locations
 346   constructors:
 347     - name: ScoreLocation
 348       uniques:
 349         - name: unique_scores_location
 350           type: constraint
 351           fields: [city, state, country]
 352
 353 |]
 354
 355
 356
 357 -- These types have fields with e.g. db_ and xml_ prefixes, so we
 358 -- use our own codegen to peel those off before naming the columns.
 359 mkPersist tsn_codegen_config [groundhog|
 360 - entity: Score
 361   dbName: scores
 362   constructors:
 363     - name: Score
 364       uniques:
 365         - name: unique_scores
 366           type: constraint
 367           # Prevent multiple imports of the same message.
 368           fields: [db_xml_file_id]
 369
 370 - embedded: ScoreGameStatus
 371   fields:
 372     - name: db_status_numeral
 373       dbName: status_numeral
 374     - name: db_status_type
 375       dbName: status_type
 376     - name: db_status_text
 377       dbName: status_text
 378
 379 - entity: ScoreGame
 380   dbName: scores_games
 381   constructors:
 382     - name: ScoreGame
 383       fields:
 384         - name: db_scores_id
 385           reference:
 386             onDelete: cascade
 387         - name: db_status
 388           embeddedType:
 389             - { name: status_numeral, dbName: status_numeral }
 390             - { name: status_type, dbName: status_type }
 391             - { name: status_text, dbName: status_text }
 392
 393 - entity: ScoreGame_ScoreGameTeam
 394   dbName: scores_games__scores_games_teams
 395   constructors:
 396     - name: ScoreGame_ScoreGameTeam
 397       fields:
 398         - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
 399           dbName: scores_games_id
 400           reference:
 401             onDelete: cascade
 402         - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
 403           dbName: scores_games_teams_vteam_id
 404           reference:
 405             onDelete: cascade
 406         - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
 407           dbName: scores_games_teams_hteam_id
 408           reference:
 409             onDelete: cascade
 410
 411 - entity: Score_ScoreLocation
 412   dbName: scores__scores_locations
 413   constructors:
 414     - name: Score_ScoreLocation
 415       fields:
 416         - name: score_ScoreLocation0 # Default created by mkNormalFieldName
 417           dbName: scores_id
 418           reference:
 419             onDelete: cascade
 420         - name: score_ScoreLocation1 # Default created by mkNormalFieldName
 421           dbName: scores_locations_id
 422           reference:
 423             onDelete: cascade
 424 |]
 425
 426
 427 --
 428 -- Pickling
 429 --
 430
 431 -- | Convert a 'Message' to/from \<message\>.
 432 --
 433 pickle_message :: PU Message
 434 pickle_message =
 435   xpElem "message" $
 436     xpWrap (from_tuple, to_tuple) $
 437     xp11Tuple (xpElem "XML_File_ID" xpInt)
 438               (xpElem "heading" xpText)
 439               (xpElem "game_id" xpInt)
 440               (xpElem "schedule_id" xpInt)
 441               (xpOption $ xpElem "tsnupdate" xpPrim)
 442               (xpElem "category" xpText)
 443               (xpElem "sport" xpText)
 444               (xpList pickle_location)
 445               (xpElem "seasontype" xpText)
 446               pickle_game
 447               (xpElem "time_stamp" xp_time_stamp)
 448   where
 449     from_tuple = uncurryN Message
 450     to_tuple m = (xml_xml_file_id m,
 451                   xml_heading m,
 452                   xml_game_id m,
 453                   xml_schedule_id m,
 454                   xml_tsnupdate m,
 455                   xml_category m,
 456                   xml_sport m,
 457                   xml_locations m,
 458                   xml_season_type m,
 459                   xml_game m,
 460                   xml_time_stamp m)
 461
 462
 463
 464 -- | Convert a 'ScoreLocation' to/from \<location\>.
 465 --
 466 pickle_location :: PU ScoreLocation
 467 pickle_location =
 468   xpElem "location" $
 469     xpWrap (from_tuple, to_tuple) $
 470     xpTriple (xpElem "city" xpText)
 471              (xpElem "state" xpText)
 472              (xpElem "country" xpText)
 473   where
 474     from_tuple =
 475       uncurryN ScoreLocation
 476     to_tuple l = (city l, state l, country l)
 477
 478
 479 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
 480 --
 481 pickle_status :: PU ScoreGameStatus
 482 pickle_status =
 483   xpElem "status" $
 484     xpWrap (from_tuple, to_tuple) $
 485       xpTriple (xpAttr "numeral" xpInt)
 486                (xpAttr "type" xpText)
 487                xpText
 488   where
 489     from_tuple = uncurryN ScoreGameStatus
 490     to_tuple ScoreGameStatus{..} = (db_status_numeral,
 491                                     db_status_type,
 492                                     db_status_text)
 493
 494
 495 -- | Convert a 'ScoreGameXml' to/from \<game\>.
 496 --
 497 pickle_game :: PU ScoreGameXml
 498 pickle_game =
 499   xpElem "game" $
 500     xpWrap (from_tuple, to_tuple) $
 501       xp7Tuple pickle_vteam
 502                pickle_hteam
 503                (xpElem "vscore" xpInt)
 504                (xpElem "hscore" xpInt)
 505                (xpOption $ xpElem "time_r" xpText)
 506                pickle_status
 507                (xpOption $ xpElem "notes" xpText)
 508   where
 509     from_tuple = uncurryN ScoreGameXml
 510     to_tuple ScoreGameXml{..} = (xml_vteam,
 511                                  xml_hteam,
 512                                  xml_vscore,
 513                                  xml_hscore,
 514                                  xml_time_r,
 515                                  xml_status,
 516                                  xml_notes)
 517
 518
 519 -- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
 520 --
 521 pickle_vteam :: PU ScoreGameVTeam
 522 pickle_vteam =
 523   xpElem "vteam" $
 524     xpWrap (from_tuple, to_tuple) $
 525       xpPair (xpAttr "id" xpText)
 526              xpText
 527   where
 528     from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
 529     to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
 530
 531
 532 -- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
 533 --   'pickle_vteam' modulo the \"h\" and \"v\".
 534 --
 535 pickle_hteam :: PU ScoreGameHTeam
 536 pickle_hteam =
 537   xpElem "hteam" $
 538     xpWrap (from_tuple, to_tuple) $
 539       xpPair (xpAttr "id" xpText)
 540              xpText
 541   where
 542     from_tuple = ScoreGameHTeam  . uncurry ScoreGameTeam
 543     to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
 544
 545
 546
 547 ---
 548 --- Tasty tests
 549 ---
 550
 551 -- | A list of all tests for this module.
 552 --
 553 scores_tests :: TestTree
 554 scores_tests =
 555   testGroup
 556     "Scores tests"
 557     [ test_on_delete_cascade,
 558       test_pickle_of_unpickle_is_identity,
 559       test_unpickle_succeeds ]
 560
 561
 562 -- | If we unpickle something and then pickle it, we should wind up
 563 --   with the same thing we started with. WARNING: success of this
 564 --   test does not mean that unpickling succeeded.
 565 --
 566 test_pickle_of_unpickle_is_identity :: TestTree
 567 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 568   [ check "pickle composed with unpickle is the identity"
 569           "test/xml/scoresxml.xml",
 570
 571     check "pickle composed with unpickle is the identity (no locations)"
 572           "test/xml/scoresxml-no-locations.xml" ]
 573   where
 574     check desc path = testCase desc $ do
 575       (expected, actual) <- pickle_unpickle pickle_message path
 576       actual @?= expected
 577
 578
 579 -- | Make sure we can actually unpickle these things.
 580 --
 581 test_unpickle_succeeds :: TestTree
 582 test_unpickle_succeeds = testGroup "unpickle tests"
 583   [ check "unpickling succeeds"
 584           "test/xml/scoresxml.xml",
 585
 586     check "unpickling succeeds (no locations)"
 587           "test/xml/scoresxml-no-locations.xml" ]
 588   where
 589     check desc path = testCase desc $ do
 590       actual <- unpickleable path pickle_message
 591       let expected = True
 592       actual @?= expected
 593
 594
 595 -- | Make sure everything gets deleted when we delete the top-level
 596 --   record.
 597 --
 598 test_on_delete_cascade :: TestTree
 599 test_on_delete_cascade = testGroup "cascading delete tests"
 600   [ check "unpickling succeeds"
 601           "test/xml/scoresxml.xml"
 602           4, -- 2 teams, 2 locations
 603
 604     check "unpickling succeeds (no locations)"
 605           "test/xml/scoresxml-no-locations.xml"
 606           2 -- 2 teams, 0 locations
 607   ]
 608   where
 609     check desc path expected = testCase desc $ do
 610       score <- unsafe_unpickle path pickle_message
 611       let a = undefined :: Score
 612       let b = undefined :: ScoreGame
 613       let c = undefined :: ScoreGameTeam
 614       let d = undefined :: ScoreGame_ScoreGameTeam
 615       let e = undefined :: ScoreLocation
 616       let f = undefined :: Score_ScoreLocation
 617       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 618                   runMigration silentMigrationLogger $ do
 619                     migrate a
 620                     migrate b
 621                     migrate c
 622                     migrate d
 623                     migrate e
 624                     migrate f
 625                   _ <- dbimport score
 626                   -- No idea how 'delete' works, so do this instead.
 627                   deleteAll a
 628                   count_a <- countAll a
 629                   count_b <- countAll b
 630                   count_c <- countAll c
 631                   count_d <- countAll d
 632                   count_e <- countAll e
 633                   count_f <- countAll f
 634                   return $ sum [count_a, count_b, count_c,
 635                                 count_d, count_e, count_f ]
 636       actual @?= expected