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