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_ScoreLocationConstructor(..),
  19   ScoreConstructor(..),
  20   ScoreGameConstructor(..),
  21   ScoreGameTeamConstructor(..),
  22   ScoreLocationConstructor(..),
  23   ScoreGame_ScoreGameTeamConstructor(..) )
  24 where
  25
  26 -- System imports.
  27 import Data.Data ( Data )
  28 import Data.Time ( UTCTime )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Data.Typeable ( Typeable )
  31 import Database.Groundhog (
  32   countAll,
  33   executeRaw,
  34   insert,
  35   insert_,
  36   migrate,
  37   runMigration,
  38   silentMigrationLogger )
  39 import Database.Groundhog.Core ( DefaultKey )
  40 import Database.Groundhog.Generic ( runDbConn )
  41 import Database.Groundhog.Sqlite ( withSqliteConn )
  42 import Database.Groundhog.TH (
  43   defaultCodegenConfig,
  44   groundhog,
  45   mkPersist )
  46 import Test.Tasty ( TestTree, testGroup )
  47 import Test.Tasty.HUnit ( (@?=), testCase )
  48 import Text.XML.HXT.Core (
  49   PU,
  50   xp7Tuple,
  51   xp11Tuple,
  52   xpAttr,
  53   xpElem,
  54   xpInt,
  55   xpList,
  56   xpOption,
  57   xpPair,
  58   xpPrim,
  59   xpText,
  60   xpTriple,
  61   xpWrap )
  62
  63 -- Local imports.
  64 import TSN.Codegen (
  65   tsn_codegen_config )
  66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  67 import TSN.Picklers ( xp_time_stamp )
  68 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  69 import Xml (
  70   FromXml(..),
  71   FromXmlFk(..),
  72   ToDb(..),
  73   pickle_unpickle,
  74   unpickleable,
  75   unsafe_unpickle )
  76
  77
  78 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  79 --
  80 dtd :: String
  81 dtd = "scoresxml.dtd"
  82
  83
  84 ---
  85 --- DB/XML Data types
  86 ---
  87
  88
  89 -- * Score / Message
  90
  91 -- | Database representation of a 'Message'. It lacks the
  92 --   'xml_locations' and 'xml_game' which are related via foreign keys
  93 --   instead.
  94 --
  95 data Score =
  96   Score {
  97     db_xml_file_id :: Int,
  98     db_heading :: String,
  99     db_game_id :: Int,
 100     db_schedule_id :: Int,
 101     db_tsnupdate :: Maybe Bool,
 102     db_category :: String,
 103     db_sport :: String,
 104     db_season_type :: String,
 105     db_time_stamp :: UTCTime }
 106
 107
 108 -- | XML representation of the top level \<message\> element (i.e. a
 109 --   'Score').
 110 --
 111 data Message =
 112   Message {
 113     xml_xml_file_id :: Int,
 114     xml_heading :: String,
 115     xml_game_id :: Int,
 116     xml_schedule_id :: Int,
 117     xml_tsnupdate :: Maybe Bool,
 118     xml_category :: String,
 119     xml_sport :: String,
 120     xml_locations :: [ScoreLocation],
 121     xml_season_type :: String,
 122     xml_game :: ScoreGameXml,
 123     xml_time_stamp :: UTCTime }
 124   deriving (Eq, Show)
 125
 126 instance ToDb Message where
 127   -- | The database representation of a 'Message' is a 'Score'.
 128   type Db Message = Score
 129
 130 instance FromXml Message where
 131   from_xml Message{..} =
 132     Score {
 133       db_xml_file_id = xml_xml_file_id,
 134       db_heading = xml_heading,
 135       db_game_id = xml_game_id,
 136       db_schedule_id = xml_schedule_id,
 137       db_tsnupdate = xml_tsnupdate,
 138       db_category = xml_category,
 139       db_sport = xml_sport,
 140       db_season_type = xml_season_type,
 141       db_time_stamp = xml_time_stamp }
 142
 143
 144 -- | This lets us insert the XML representation 'Message' directly.
 145 --
 146 instance XmlImport Message
 147
 148
 149 -- * ScoreGame / ScoreGameXml
 150
 151 -- | This is an embedded field within 'SportsGame'. Each \<status\>
 152 --   element has two attributes, a numeral and a type. It also
 153 --   contains some text. Rather than put these in their own table, we
 154 --   include them in the parent 'SportsGame'.
 155 --
 156 data ScoreGameStatus =
 157   ScoreGameStatus {
 158     db_status_numeral :: Int,
 159     db_status_type :: String, -- ^ These are probably only one-character long,
 160                               --   but they all take the same amount of space
 161                               --   in Postgres.
 162     db_status_text :: String }
 163   deriving (Data, Eq, Show, Typeable)
 164
 165
 166 -- | Database representation of a game.
 167 --
 168 data ScoreGame =
 169   ScoreGame {
 170     db_scores_id :: DefaultKey Score,
 171     db_vscore :: Int,
 172     db_hscore :: Int,
 173     db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
 174     db_status :: ScoreGameStatus,
 175     db_notes  :: Maybe String }
 176
 177
 178 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
 179 --
 180 data ScoreGameXml =
 181   ScoreGameXml {
 182     xml_vteam  :: ScoreGameVTeam,
 183     xml_hteam  :: ScoreGameHTeam,
 184     xml_vscore :: Int,
 185     xml_hscore :: Int,
 186     xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
 187     xml_status :: ScoreGameStatus,
 188     xml_notes  :: Maybe String }
 189   deriving (Eq, Show)
 190
 191 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
 192 vteam :: ScoreGameXml -> ScoreGameTeam
 193 vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
 194
 195 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
 196 hteam :: ScoreGameXml -> ScoreGameTeam
 197 hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
 198
 199 instance ToDb ScoreGameXml where
 200   -- | The database representation of a 'ScoreGameXml' is a
 201   --   'ScoreGame'.
 202   --
 203   type Db ScoreGameXml = ScoreGame
 204
 205 instance FromXmlFk ScoreGameXml where
 206   -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
 207   --   a 'Score'.
 208   --
 209   type Parent ScoreGameXml = Score
 210
 211   from_xml_fk fk ScoreGameXml{..} =
 212     ScoreGame {
 213       db_scores_id = fk,
 214       db_vscore = xml_vscore,
 215       db_hscore = xml_hscore,
 216       db_time_r = xml_time_r,
 217       db_status = xml_status,
 218       db_notes = xml_notes }
 219
 220 -- | This lets us import the database representation 'ScoreGameXml'
 221 --   directly.
 222 --
 223 instance XmlImportFk ScoreGameXml
 224
 225
 226 -- * ScoreGameTeam
 227
 228 -- | A team that appears in a 'ScoreGame'. This is meant to represent
 229 --   both home and away teams.
 230 --
 231 data ScoreGameTeam =
 232   ScoreGameTeam {
 233     team_id :: String,
 234     team_name :: String }
 235   deriving (Eq, Show)
 236
 237 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
 238 --   home and away teams. See also 'ScoreGameHTeam'.
 239 --
 240 newtype ScoreGameVTeam =
 241   ScoreGameVTeam ScoreGameTeam
 242   deriving (Eq, Show)
 243
 244
 245 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
 246 --   home and away teams. See also 'ScoreGameVTeam'.
 247 --
 248 newtype ScoreGameHTeam =
 249   ScoreGameHTeam ScoreGameTeam
 250   deriving (Eq, Show)
 251
 252
 253 -- * ScoreGame_ScoreGameTeam
 254
 255 -- | Join a 'ScoreGame' with its home/away teams. Database-only. We
 256 --   use a join table because the teams are kept unique.
 257 --
 258 data ScoreGame_ScoreGameTeam =
 259   ScoreGame_ScoreGameTeam
 260     (DefaultKey ScoreGame) -- ^ game id
 261     (DefaultKey ScoreGameTeam) -- ^ vteam id
 262     (DefaultKey ScoreGameTeam) -- ^ hteam id
 263
 264
 265 -- * ScoreLocation
 266
 267 -- | Database and XML representation of a \<location\>. This is almost
 268 --   identical to 'TSN.XML.NewsLocation', but the city/state have not
 269 --   appeared optional here so far.
 270 --
 271 data ScoreLocation =
 272   ScoreLocation {
 273     city :: String,
 274     state :: String,
 275     country :: String }
 276   deriving (Eq, Show)
 277
 278
 279 -- * Score_ScoreLocation
 280
 281 -- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
 282 --   use a join table because the locations are kept unique.
 283 --
 284 data Score_ScoreLocation =
 285   Score_ScoreLocation
 286     (DefaultKey Score)
 287     (DefaultKey ScoreLocation)
 288
 289
 290
 291 instance DbImport Message where
 292   dbmigrate _ =
 293     run_dbmigrate $ do
 294       migrate (undefined :: Score)
 295       migrate (undefined :: ScoreGame)
 296       migrate (undefined :: ScoreGameTeam)
 297       migrate (undefined :: ScoreGame_ScoreGameTeam)
 298       migrate (undefined :: ScoreLocation)
 299       migrate (undefined :: Score_ScoreLocation)
 300
 301   dbimport m = do
 302     -- Insert the message and get its ID.
 303     msg_id <- insert_xml m
 304
 305     -- Insert all of the locations contained within this message and
 306     -- collect their IDs in a list.
 307     location_ids <- mapM insert (xml_locations m)
 308
 309     -- Now use that list to construct 'Score_ScoreLocation' objects,
 310     -- and insert them.
 311     mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
 312
 313     -- Insert the game and its hteam/vteam, noting the IDs.
 314     game_id <- insert_xml_fk msg_id (xml_game m)
 315     vteam_id <- insert (vteam $ xml_game m)
 316     hteam_id <- insert (hteam $ xml_game m)
 317
 318     -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
 319     -- aforementioned game to its hteam/vteam.
 320     insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
 321
 322     return ImportSucceeded
 323
 324
 325 -- These types don't have special XML representations or field name
 326 -- collisions so we use the defaultCodegenConfig and give their
 327 -- fields nice simple names.
 328 mkPersist defaultCodegenConfig [groundhog|
 329 - entity: ScoreGameTeam
 330   dbName: scores_games_teams
 331   constructors:
 332     - name: ScoreGameTeam
 333       uniques:
 334         - name: unique_scores_games_team
 335           type: constraint
 336           fields: [team_id]
 337
 338 - entity: ScoreLocation
 339   dbName: scores_locations
 340   constructors:
 341     - name: ScoreLocation
 342       uniques:
 343         - name: unique_scores_location
 344           type: constraint
 345           fields: [city, state, country]
 346
 347 |]
 348
 349
 350
 351 -- These types have fields with e.g. db_ and xml_ prefixes, so we
 352 -- use our own codegen to peel those off before naming the columns.
 353 mkPersist tsn_codegen_config [groundhog|
 354 - entity: Score
 355   dbName: scores
 356   constructors:
 357     - name: Score
 358       uniques:
 359         - name: unique_scores
 360           type: constraint
 361           # Prevent multiple imports of the same message.
 362           fields: [db_xml_file_id]
 363
 364 - embedded: ScoreGameStatus
 365   fields:
 366     - name: db_status_numeral
 367       dbName: status_numeral
 368     - name: db_status_type
 369       dbName: status_type
 370     - name: db_status_text
 371       dbName: status_text
 372
 373 - entity: ScoreGame
 374   dbName: scores_games
 375   constructors:
 376     - name: ScoreGame
 377       fields:
 378         - name: db_scores_id
 379           reference:
 380             onDelete: cascade
 381         - name: db_status
 382           embeddedType:
 383             - { name: status_numeral, dbName: status_numeral }
 384             - { name: status_type, dbName: status_type }
 385             - { name: status_text, dbName: status_text }
 386
 387 - entity: ScoreGame_ScoreGameTeam
 388   dbName: scores_games__scores_games_teams
 389   constructors:
 390     - name: ScoreGame_ScoreGameTeam
 391       fields:
 392         - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
 393           dbName: scores_games_id
 394           reference:
 395             onDelete: cascade
 396         - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
 397           dbName: scores_games_teams_vteam_id
 398           reference:
 399             onDelete: cascade
 400         - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
 401           dbName: scores_games_teams_hteam_id
 402           reference:
 403             onDelete: cascade
 404
 405 - entity: Score_ScoreLocation
 406   dbName: scores__scores_locations
 407   constructors:
 408     - name: Score_ScoreLocation
 409       fields:
 410         - name: score_ScoreLocation0 # Default created by mkNormalFieldName
 411           dbName: scores_id
 412           reference:
 413             onDelete: cascade
 414         - name: score_ScoreLocation1 # Default created by mkNormalFieldName
 415           dbName: scores_locations_id
 416           reference:
 417             onDelete: cascade
 418 |]
 419
 420
 421 --
 422 -- Pickling
 423 --
 424
 425 -- | Convert a 'Message' to/from \<message\>.
 426 --
 427 pickle_message :: PU Message
 428 pickle_message =
 429   xpElem "message" $
 430     xpWrap (from_tuple, to_tuple) $
 431     xp11Tuple (xpElem "XML_File_ID" xpInt)
 432               (xpElem "heading" xpText)
 433               (xpElem "game_id" xpInt)
 434               (xpElem "schedule_id" xpInt)
 435               (xpOption $ xpElem "tsnupdate" xpPrim)
 436               (xpElem "category" xpText)
 437               (xpElem "sport" xpText)
 438               (xpList pickle_location)
 439               (xpElem "seasontype" xpText)
 440               pickle_game
 441               (xpElem "time_stamp" xp_time_stamp)
 442   where
 443     from_tuple = uncurryN Message
 444     to_tuple m = (xml_xml_file_id m,
 445                   xml_heading m,
 446                   xml_game_id m,
 447                   xml_schedule_id m,
 448                   xml_tsnupdate m,
 449                   xml_category m,
 450                   xml_sport m,
 451                   xml_locations m,
 452                   xml_season_type m,
 453                   xml_game m,
 454                   xml_time_stamp m)
 455
 456
 457
 458 -- | Convert a 'ScoreLocation' to/from \<location\>.
 459 --
 460 pickle_location :: PU ScoreLocation
 461 pickle_location =
 462   xpElem "location" $
 463     xpWrap (from_tuple, to_tuple) $
 464     xpTriple (xpElem "city" xpText)
 465              (xpElem "state" xpText)
 466              (xpElem "country" xpText)
 467   where
 468     from_tuple =
 469       uncurryN ScoreLocation
 470     to_tuple l = (city l, state l, country l)
 471
 472
 473 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
 474 --
 475 pickle_status :: PU ScoreGameStatus
 476 pickle_status =
 477   xpElem "status" $
 478     xpWrap (from_tuple, to_tuple) $
 479       xpTriple (xpAttr "numeral" xpInt)
 480                (xpAttr "type" xpText)
 481                xpText
 482   where
 483     from_tuple = uncurryN ScoreGameStatus
 484     to_tuple ScoreGameStatus{..} = (db_status_numeral,
 485                                     db_status_type,
 486                                     db_status_text)
 487
 488
 489 -- | Convert a 'ScoreGameXml' to/from \<game\>.
 490 --
 491 pickle_game :: PU ScoreGameXml
 492 pickle_game =
 493   xpElem "game" $
 494     xpWrap (from_tuple, to_tuple) $
 495       xp7Tuple pickle_vteam
 496                pickle_hteam
 497                (xpElem "vscore" xpInt)
 498                (xpElem "hscore" xpInt)
 499                (xpOption $ xpElem "time_r" xpText)
 500                pickle_status
 501                (xpOption $ xpElem "notes" xpText)
 502   where
 503     from_tuple = uncurryN ScoreGameXml
 504     to_tuple ScoreGameXml{..} = (xml_vteam,
 505                                  xml_hteam,
 506                                  xml_vscore,
 507                                  xml_hscore,
 508                                  xml_time_r,
 509                                  xml_status,
 510                                  xml_notes)
 511
 512
 513 -- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
 514 --
 515 pickle_vteam :: PU ScoreGameVTeam
 516 pickle_vteam =
 517   xpElem "vteam" $
 518     xpWrap (from_tuple, to_tuple) $
 519       xpPair (xpAttr "id" xpText)
 520              xpText
 521   where
 522     from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
 523     to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
 524
 525
 526 -- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
 527 --   'pickle_vteam' modulo the \"h\" and \"v\".
 528 --
 529 pickle_hteam :: PU ScoreGameHTeam
 530 pickle_hteam =
 531   xpElem "hteam" $
 532     xpWrap (from_tuple, to_tuple) $
 533       xpPair (xpAttr "id" xpText)
 534              xpText
 535   where
 536     from_tuple = ScoreGameHTeam  . uncurry ScoreGameTeam
 537     to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
 538
 539
 540
 541 ---
 542 --- Tasty tests
 543 ---
 544
 545 -- | A list of all tests for this module.
 546 --
 547 scores_tests :: TestTree
 548 scores_tests =
 549   testGroup
 550     "Scores tests"
 551     [ test_on_delete_cascade,
 552       test_pickle_of_unpickle_is_identity,
 553       test_unpickle_succeeds ]
 554
 555
 556 -- | If we unpickle something and then pickle it, we should wind up
 557 --   with the same thing we started with. WARNING: success of this
 558 --   test does not mean that unpickling succeeded.
 559 --
 560 test_pickle_of_unpickle_is_identity :: TestTree
 561 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 562   [ check "pickle composed with unpickle is the identity"
 563           "test/xml/scoresxml.xml",
 564
 565     check "pickle composed with unpickle is the identity (no locations)"
 566           "test/xml/scoresxml-no-locations.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   where
 583     check desc path = testCase desc $ do
 584       actual <- unpickleable path pickle_message
 585       let expected = True
 586       actual @?= expected
 587
 588
 589 -- | Make sure everything gets deleted when we delete the top-level
 590 --   record.
 591 --
 592 test_on_delete_cascade :: TestTree
 593 test_on_delete_cascade = testGroup "cascading delete tests"
 594   [ check "unpickling succeeds"
 595           "test/xml/scoresxml.xml"
 596           4, -- 2 teams, 2 locations
 597
 598     check "unpickling succeeds (no locations)"
 599           "test/xml/scoresxml-no-locations.xml"
 600           2 -- 2 teams, 0 locations
 601   ]
 602   where
 603     check desc path expected = testCase desc $ do
 604       score <- unsafe_unpickle path pickle_message
 605       let a = undefined :: Score
 606       let b = undefined :: ScoreGame
 607       let c = undefined :: ScoreGameTeam
 608       let d = undefined :: ScoreGame_ScoreGameTeam
 609       let e = undefined :: ScoreLocation
 610       let f = undefined :: Score_ScoreLocation
 611       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 612                   runMigration silentMigrationLogger $ do
 613                     migrate a
 614                     migrate b
 615                     migrate c
 616                     migrate d
 617                     migrate e
 618                     migrate f
 619                   _ <- dbimport score
 620                   -- No idea how 'delete' works, so do this instead.
 621                   executeRaw False "DELETE FROM scores;" []
 622                   count_a <- countAll a
 623                   count_b <- countAll b
 624                   count_c <- countAll c
 625                   count_d <- countAll d
 626                   count_e <- countAll e
 627                   count_f <- countAll f
 628                   return $ sum [count_a, count_b, count_c,
 629                                 count_d, count_e, count_f ]
 630       actual @?= expected