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