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