src/TSN/XML/Scores.hs

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