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 Database.Groundhog (
  31   countAll,
  32   deleteAll,
  33   insert_,
  34   migrate,
  35   runMigration,
  36   silentMigrationLogger )
  37 import Database.Groundhog.Core ( DefaultKey )
  38 import Database.Groundhog.Generic ( runDbConn )
  39 import Database.Groundhog.Sqlite ( withSqliteConn )
  40 import Database.Groundhog.TH (
  41   groundhog,
  42   mkPersist )
  43 import qualified GHC.Generics as GHC ( Generic )
  44 import Test.Tasty ( TestTree, testGroup )
  45 import Test.Tasty.HUnit ( (@?=), testCase )
  46 import Text.XML.HXT.Core (
  47   PU,
  48   xp7Tuple,
  49   xp11Tuple,
  50   xpAttr,
  51   xpElem,
  52   xpInt,
  53   xpList,
  54   xpOption,
  55   xpPrim,
  56   xpText,
  57   xpTriple,
  58   xpWrap )
  59
  60 -- Local imports.
  61 import Generics ( Generic(..), to_tuple )
  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 'Generics.to_tuple'.
 132 --
 133 instance Generic 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 'Generics.to_tuple'.
 210 --
 211 instance Generic 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   from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} =
 233     ScoreGame {
 234       db_scores_id = fk,
 235       db_away_team_id = fk_away,
 236       db_home_team_id = fk_home,
 237       db_away_team_score = xml_away_team_score,
 238       db_home_team_score = xml_home_team_score,
 239       db_away_team_pitcher = xml_vpitcher xml_vteam,
 240       db_home_team_pitcher = xml_hpitcher xml_hteam,
 241       db_time_r = xml_time_r,
 242       db_status = xml_status,
 243       db_notes = xml_notes }
 244
 245 -- | This lets us import the database representation 'ScoreGameXml'
 246 --   directly.
 247 --
 248 instance XmlImportFkTeams ScoreGameXml
 249
 250
 251
 252 -- * Score_Location
 253
 254 -- | Join each 'Score' with its 'Location's. Database-only. We use a
 255 --   join table because the locations are kept unique but there are
 256 --   multiple locations per 'Score'.
 257 --
 258 data Score_Location =
 259   Score_Location
 260     (DefaultKey Score)
 261     (DefaultKey Location)
 262
 263
 264 -- * HTeamXml / VTeamXml
 265
 266 -- | XML Representation of a home team. This document type is unusual
 267 --   in that the \<hteam\> elements can have a pitcher attribute
 268 --   attached to them. We still want to maintain the underlying 'Team'
 269 --   representation, so we say that a home team is a 'Team' and
 270 --   (maybe) a pitcher.
 271 --
 272 data HTeamXml =
 273   HTeamXml {
 274     xml_ht :: HTeam,
 275     xml_hpitcher :: Maybe String }
 276   deriving (Eq, Show)
 277
 278 instance ToDb HTeamXml where
 279   -- | The database analogue of a 'HTeamXml' is its 'Team'.
 280   type Db HTeamXml = Team
 281
 282 instance FromXml HTeamXml where
 283   -- | The conversion from XML to database is simply the 'Team' accessor.
 284   --
 285   from_xml = hteam . xml_ht
 286
 287 -- | Allow import of the XML representation directly, without
 288 --   requiring a manual conversion to the database type first.
 289 --
 290 instance XmlImport HTeamXml
 291
 292
 293
 294 -- | XML Representation of an away team. This document type is unusual
 295 --   in that the \<hteam\> elements can have a pitcher attribute
 296 --   attached to them. We still want to maintain the underlying 'Team'
 297 --   representation, so we say that an away team is a 'Team' and
 298 --   (maybe) a pitcher.
 299 --
 300 data VTeamXml =
 301   VTeamXml {
 302     xml_vt :: VTeam,
 303     xml_vpitcher :: Maybe String }
 304   deriving (Eq, Show)
 305
 306 instance ToDb VTeamXml where
 307   -- | The database analogue of a 'VTeamXml' is its 'Team'.
 308   type Db VTeamXml = Team
 309
 310 instance FromXml VTeamXml where
 311   -- | The conversion from XML to database is simply the 'Team' accessor.
 312   --
 313   from_xml = vteam . xml_vt
 314
 315 -- | Allow import of the XML representation directly, without
 316 --   requiring a manual conversion to the database type first.
 317 --
 318 instance XmlImport VTeamXml
 319
 320
 321
 322 instance DbImport Message where
 323   dbmigrate _ =
 324     run_dbmigrate $ do
 325       migrate (undefined :: Location)
 326       migrate (undefined :: Team)
 327       migrate (undefined :: Score)
 328       migrate (undefined :: ScoreGame)
 329       migrate (undefined :: Score_Location)
 330
 331   dbimport m = do
 332     -- Insert the message and get its ID.
 333     msg_id <- insert_xml m
 334
 335     -- Insert all of the locations contained within this message and
 336     -- collect their IDs in a list. We use insert_or_select because
 337     -- most of the locations will already exist, and we just want to
 338     -- get the ID of the existing location when there's a collision.
 339     location_ids <- mapM insert_or_select (xml_locations m)
 340
 341     -- Now use that list to construct 'Score_ScoreLocation' objects,
 342     -- and insert them.
 343     mapM_ (insert_ . Score_Location msg_id) location_ids
 344
 345     -- Insert the hteam/vteams, noting the IDs.
 346     vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m)
 347     hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m)
 348
 349     -- Now use those along with the msg_id to construct the game.
 350     insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m)
 351
 352     return ImportSucceeded
 353
 354
 355
 356 -- These types have fields with e.g. db_ and xml_ prefixes, so we
 357 -- use our own codegen to peel those off before naming the columns.
 358 mkPersist tsn_codegen_config [groundhog|
 359 - entity: Score
 360   dbName: scores
 361   constructors:
 362     - name: Score
 363       uniques:
 364         - name: unique_scores
 365           type: constraint
 366           # Prevent multiple imports of the same message.
 367           fields: [db_xml_file_id]
 368
 369 - embedded: ScoreGameStatus
 370   fields:
 371     - name: db_status_numeral
 372       dbName: status_numeral
 373     - name: db_status_type
 374       dbName: status_type
 375     - name: db_status_text
 376       dbName: status_text
 377
 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
 394 - entity: Score_Location
 395   dbName: scores__locations
 396   constructors:
 397     - name: Score_Location
 398       fields:
 399         - name: score_Location0 # Default created by mkNormalFieldName
 400           dbName: scores_id
 401           reference:
 402             onDelete: cascade
 403         - name: score_Location1 # Default created by mkNormalFieldName
 404           dbName: locations_id
 405           reference:
 406             onDelete: cascade
 407 |]
 408
 409
 410 --
 411 -- Pickling
 412 --
 413
 414 -- | Convert a 'Message' to/from \<message\>.
 415 --
 416 pickle_message :: PU Message
 417 pickle_message =
 418   xpElem "message" $
 419     xpWrap (from_tuple, to_tuple) $
 420     xp11Tuple (xpElem "XML_File_ID" xpInt)
 421               (xpElem "heading" xpText)
 422               (xpElem "game_id" (xpOption xpInt))
 423               (xpElem "schedule_id" (xpOption xpInt))
 424               (xpOption $ xpElem "tsnupdate" xpPrim)
 425               (xpElem "category" xpText)
 426               (xpElem "sport" xpText)
 427               (xpList pickle_location)
 428               (xpElem "seasontype" (xpOption xpText))
 429               pickle_game
 430               (xpElem "time_stamp" xp_time_stamp)
 431   where
 432     from_tuple = uncurryN Message
 433
 434
 435
 436 -- | Convert a 'ScoreGameStatus' to/from \<status\>. The \"type\"
 437 --   attribute can be either missing or empty, so we're really parsing
 438 --   a double-Maybe here. We use the monad join to collapse it into
 439 --   one. See also: the hteam/vteam picklers.
 440 --
 441 pickle_status :: PU ScoreGameStatus
 442 pickle_status =
 443   xpElem "status" $
 444     xpWrap (from_tuple, to_tuple') $
 445       xpTriple (xpAttr "numeral" $ xpOption xpInt)
 446                (xpOption $ xpAttr "type" $ xpOption xpText)
 447                xpText
 448   where
 449     from_tuple (x,y,z) = ScoreGameStatus x (join y) z
 450     to_tuple' ScoreGameStatus{..} =
 451       (db_status_numeral, s, db_status_text)
 452       where
 453         s = case db_status_type of
 454               Nothing -> Nothing
 455               Just _  -> Just db_status_type
 456
 457
 458 -- | Convert a 'ScoreGameXml' to/from \<game\>.
 459 --
 460 pickle_game :: PU ScoreGameXml
 461 pickle_game =
 462   xpElem "game" $
 463     xpWrap (from_tuple, to_tuple) $
 464       xp7Tuple pickle_vteam
 465                pickle_hteam
 466                (xpElem "vscore" xpInt)
 467                (xpElem "hscore" xpInt)
 468                (xpOption $ xpElem "time_r" xpText)
 469                pickle_status
 470                (xpOption $ xpElem "notes" xpText)
 471   where
 472     from_tuple = uncurryN ScoreGameXml
 473
 474
 475 -- | Convert a 'VTeamXml' to/from \<vteam\>. The team names
 476 --   always seem to be present here, but in the shared representation,
 477 --   they're optional (because they show up blank elsewhere). So, we
 478 --   pretend they're optional.
 479 --
 480 --   The \"pitcher\" attribute is a little bit funny. Usually, when
 481 --   there's no pitcher, the attribute itself is missing. But once in
 482 --   a blue moon, it will be present with no text. We want to treat
 483 --   both cases the same, so what we really parse is a Maybe (Maybe
 484 --   String), and then use the monad 'join' to collapse it into a single
 485 --   Maybe.
 486 --
 487 pickle_vteam :: PU VTeamXml
 488 pickle_vteam =
 489   xpElem "vteam" $
 490     xpWrap (from_tuple, to_tuple') $
 491       xpTriple (xpAttr "id" xpText)
 492                (xpOption $ xpAttr "pitcher" (xpOption xpText))
 493                (xpOption xpText) -- Team name
 494   where
 495     from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y)
 496
 497     to_tuple' (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t)
 498     to_tuple' (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t)
 499
 500
 501 -- | Convert a 'HTeamXml' to/from \<hteam\>. Identical to 'pickle_vteam'
 502 --   modulo the \"h\" and \"v\". The team names always seem to be
 503 --   present here, but in the shared representation, they're optional
 504 --   (because they show up blank elsewhere). So, we pretend they're
 505 --   optional.
 506 --
 507 --   The \"pitcher\" attribute is a little bit funny. Usually, when
 508 --   there's no pitcher, the attribute itself is missing. But once in
 509 --   a blue moon, it will be present with no text. We want to treat
 510 --   both cases the same, so what we really parse is a Maybe (Maybe
 511 --   String), and then use the monad 'join' to collapse it into a single
 512 --   Maybe.
 513 --
 514 pickle_hteam :: PU HTeamXml
 515 pickle_hteam =
 516   xpElem "hteam" $
 517     xpWrap (from_tuple, to_tuple') $
 518       xpTriple (xpAttr "id" xpText)
 519                (xpOption $ xpAttr "pitcher" (xpOption xpText))
 520                (xpOption xpText) -- Team name
 521   where
 522     from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y)
 523     to_tuple' (HTeamXml (HTeam t) Nothing) = (team_id t, Nothing, name t)
 524     to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, Just jhp, name t)
 525
 526
 527
 528 --
 529 -- * Tasty tests
 530 --
 531
 532 -- | A list of all tests for this module.
 533 --
 534 scores_tests :: TestTree
 535 scores_tests =
 536   testGroup
 537     "Scores tests"
 538     [ test_on_delete_cascade,
 539       test_pickle_of_unpickle_is_identity,
 540       test_unpickle_succeeds ]
 541
 542
 543 -- | If we unpickle something and then pickle it, we should wind up
 544 --   with the same thing we started with. WARNING: success of this
 545 --   test does not mean that unpickling succeeded.
 546 --
 547 test_pickle_of_unpickle_is_identity :: TestTree
 548 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 549   [ check "pickle composed with unpickle is the identity"
 550           "test/xml/scoresxml.xml",
 551
 552     check "pickle composed with unpickle is the identity (no locations)"
 553           "test/xml/scoresxml-no-locations.xml",
 554
 555     check "pickle composed with unpickle is the identity (pitcher, no type)"
 556           "test/xml/scoresxml-pitcher-no-type.xml",
 557
 558     check "pickle composed with unpickle is the identity (empty numeral)"
 559           "test/xml/scoresxml-empty-numeral.xml",
 560
 561     check "pickle composed with unpickle is the identity (empty type)"
 562           "test/xml/scoresxml-empty-type.xml" ]
 563   where
 564     check desc path = testCase desc $ do
 565       (expected, actual) <- pickle_unpickle pickle_message path
 566       actual @?= expected
 567
 568
 569 -- | Make sure we can actually unpickle these things.
 570 --
 571 test_unpickle_succeeds :: TestTree
 572 test_unpickle_succeeds = testGroup "unpickle tests"
 573   [ check "unpickling succeeds"
 574           "test/xml/scoresxml.xml",
 575
 576     check "unpickling succeeds (no locations)"
 577           "test/xml/scoresxml-no-locations.xml",
 578
 579     check "unpickling succeeds (pitcher, no type)"
 580           "test/xml/scoresxml-pitcher-no-type.xml",
 581
 582     check "unpickling succeeds (empty numeral)"
 583           "test/xml/scoresxml-empty-numeral.xml",
 584
 585     check "unpickling succeeds (empty type)"
 586           "test/xml/scoresxml-empty-type.xml" ]
 587   where
 588     check desc path = testCase desc $ do
 589       actual <- unpickleable path pickle_message
 590       let expected = True
 591       actual @?= expected
 592
 593
 594 -- | Make sure everything gets deleted when we delete the top-level
 595 --   record.
 596 --
 597 test_on_delete_cascade :: TestTree
 598 test_on_delete_cascade = testGroup "cascading delete tests"
 599   [ check "unpickling succeeds"
 600           "test/xml/scoresxml.xml"
 601           4, -- 2 teams, 2 locations
 602
 603     check "unpickling succeeds (no locations)"
 604           "test/xml/scoresxml-no-locations.xml"
 605           2, -- 2 teams, 0 locations
 606
 607     check "unpickling succeeds (pitcher, no type)"
 608           "test/xml/scoresxml-pitcher-no-type.xml"
 609           3, -- 2 teams, 1 location
 610
 611     check "unpickling succeeds (empty numeral)"
 612           "test/xml/scoresxml-empty-numeral.xml"
 613           3, -- 2 teams, 1 location
 614
 615     check "unpickling succeeds (empty type)"
 616           "test/xml/scoresxml-empty-type.xml"
 617           4 -- 2 teams, 2 locations
 618   ]
 619   where
 620     check desc path expected = testCase desc $ do
 621       score <- unsafe_unpickle path pickle_message
 622       let a = undefined :: Location
 623       let b = undefined :: Team
 624       let c = undefined :: Score
 625       let d = undefined :: ScoreGame
 626       let e = undefined :: Score_Location
 627       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 628                   runMigration silentMigrationLogger $ do
 629                     migrate a
 630                     migrate b
 631                     migrate c
 632                     migrate d
 633                     migrate e
 634                   _ <- dbimport score
 635                   -- No idea how 'delete' works, so do this instead.
 636                   deleteAll c
 637                   count_a <- countAll a
 638                   count_b <- countAll b
 639                   count_c <- countAll c
 640                   count_d <- countAll d
 641                   count_e <- countAll e
 642                   return $ sum [count_a, count_b, count_c,
 643                                 count_d, count_e ]
 644       actual @?= expected