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