src/TSN/XML/JFile.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | Parse TSN XML for the DTD \"jfilexml.dtd\". There's a top-level
   9 --   \<message\>, containing a \<gamelist\>, containing
  10 --   \<game\>s. Those games contain a bunch of other stuff. The
  11 --   \<gamelist\> is pretty irrelevant; we ignore it and pretend that
  12 --   a message contains a bunch of games.
  13 --
  14 module TSN.XML.JFile (
  15   dtd,
  16   pickle_message,
  17   -- * Tests
  18   jfile_tests,
  19   -- * WARNING: these are private but exported to silence warnings
  20   JFileConstructor(..),
  21   JFileGameConstructor(..) )
  22 where
  23
  24 -- System imports
  25 import Control.Monad ( forM_ )
  26 import Data.List ( intercalate )
  27 import Data.String.Utils ( split )
  28 import Data.Time ( UTCTime(..) )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Database.Groundhog (
  31   countAll,
  32   deleteAll,
  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   xpTriple,
  47   xp6Tuple,
  48   xp14Tuple,
  49   xp19Tuple,
  50   xpAttr,
  51   xpElem,
  52   xpInt,
  53   xpList,
  54   xpOption,
  55   xpPair,
  56   xpPrim,
  57   xpText,
  58   xpText0,
  59   xpWrap )
  60
  61
  62 -- Local imports
  63 import TSN.Codegen ( tsn_codegen_config )
  64 import TSN.Database ( insert_or_select )
  65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  66 import TSN.Picklers (
  67   xp_date,
  68   xp_date_padded,
  69   xp_datetime,
  70   xp_time,
  71   xp_time_dots,
  72   xp_time_stamp )
  73 import TSN.Team (
  74   FromXmlFkTeams(..),
  75   HTeam(..),
  76   Team(..),
  77   VTeam(..) )
  78 import TSN.XmlImport (
  79   XmlImport(..),
  80   XmlImportFkTeams(..) )
  81 import Xml (
  82   Child(..),
  83   FromXml(..),
  84   ToDb(..),
  85   pickle_unpickle,
  86   unpickleable,
  87   unsafe_unpickle )
  88
  89
  90
  91 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  92 --
  93 dtd :: String
  94 dtd = "jfilexml.dtd"
  95
  96 --
  97 -- DB/XML data types
  98 --
  99
 100 -- * JFile/Message
 101
 102 -- | Database representation of a 'Message'.
 103 --
 104 data JFile =
 105   JFile {
 106     db_xml_file_id :: Int,
 107     db_heading :: String,
 108     db_category :: String,
 109     db_sport :: String,
 110     db_time_stamp :: UTCTime }
 111
 112
 113
 114 -- | XML Representation of an 'JFile'.
 115 --
 116 data Message =
 117   Message {
 118     xml_xml_file_id :: Int,
 119     xml_heading :: String,
 120     xml_category :: String,
 121     xml_sport :: String,
 122     xml_gamelist :: JFileGameListXml,
 123     xml_time_stamp :: UTCTime }
 124   deriving (Eq, Show)
 125
 126
 127 instance ToDb Message where
 128   -- | The database analogue of a 'Message' is a 'JFile'.
 129   --
 130   type Db Message = JFile
 131
 132
 133 -- | The 'FromXml' instance for 'Message' is required for the
 134 --   'XmlImport' instance.
 135 --
 136 instance FromXml Message where
 137   -- | To convert a 'Message' to an 'JFile', we just drop
 138   --   the 'xml_gamelist'.
 139   --
 140   from_xml Message{..} =
 141     JFile {
 142       db_xml_file_id = xml_xml_file_id,
 143       db_heading = xml_heading,
 144       db_category = xml_category,
 145       db_sport = xml_sport,
 146       db_time_stamp = xml_time_stamp }
 147
 148
 149 -- | This allows us to insert the XML representation 'Message'
 150 --   directly.
 151 --
 152 instance XmlImport Message
 153
 154
 155
 156 -- * JFileGame/JFileGameXml
 157
 158 -- | This is an embedded type within each JFileGame. It has its own
 159 --   element, \<Odds_Info\>, but there's only one of them per game. So
 160 --   essentially all of these fields belong to a 'JFileGame'. Aaaannnd
 161 --   most of them are redundant. We'll (un)pickle them for good
 162 --   measure, but in the conversion to the database type, we can drop
 163 --   all of the redundant information.
 164 --
 165 --   All of these are optional because TSN does actually leave the
 166 --   whole thing empty from time to time.
 167 --
 168 --   We stick \"info\" on the home/away team ids to avoid a name clash
 169 --   with the game itself.
 170 --
 171 data JFileGameOddsInfo =
 172   JFileGameOddsInfo {
 173     db_list_date :: Maybe UTCTime,
 174     db_info_home_team_id :: Maybe String, -- redundant (Team)
 175     db_info_away_team_id :: Maybe String, -- redundant (Team)
 176     db_home_abbr :: Maybe String, -- redundant (Team)
 177     db_away_abbr :: Maybe String, -- redundant (Team)
 178     db_home_team_name :: Maybe String, -- redundant (Team)
 179     db_away_team_name :: Maybe String, -- redundant (Team)
 180     db_home_starter :: Maybe String,
 181     db_away_starter :: Maybe String,
 182     db_game_date :: Maybe UTCTime, -- redundant (JFileGame)
 183     db_home_game_key :: Maybe Int,
 184     db_away_game_key :: Maybe Int,
 185     db_current_timestamp :: Maybe UTCTime,
 186     db_live :: Maybe Bool,
 187     db_notes :: String }
 188   deriving (Eq, Show)
 189
 190
 191 -- | Another embedded type within 'JFileGame'. These look like,
 192 --   \<status numeral=\"4\"\>FINAL\</status\> within the XML, but
 193 --   they're in one-to-one correspondence with the games.
 194 --
 195 data JFileGameStatus =
 196   JFileGameStatus {
 197     db_status_numeral :: Int,
 198     db_status  :: Maybe String }
 199   deriving (Eq, Show)
 200
 201
 202 -- | Database representation of a \<game\> contained within a
 203 --   \<message\>, and, implicitly, a \<gamelist\>.
 204 --
 205 --   We've left out the game date, opting instead to combine the
 206 --   date/time into the 'db_game_time' field.
 207 --
 208 data JFileGame =
 209   JFileGame {
 210     db_jfile_id :: DefaultKey JFile,
 211     db_away_team_id :: DefaultKey Team,
 212     db_home_team_id :: DefaultKey Team,
 213     db_game_id :: Int,
 214     db_schedule_id :: Int,
 215     db_odds_info :: JFileGameOddsInfo,
 216     db_season_type :: Maybe String,
 217     db_game_time :: UTCTime,
 218     db_vleague :: Maybe String,
 219     db_hleague :: Maybe String,
 220     db_vscore :: Int,
 221     db_hscore :: Int,
 222     db_time_remaining :: Maybe String,
 223     db_game_status :: JFileGameStatus }
 224
 225
 226 -- | XML representation of a \<game\> contained within a \<message\>,
 227 --   and a \<gamelist\>. The Away/Home teams seem to coincide with
 228 --   those of 'OddsGame', so we're reusing the DB type via the common
 229 --   'TSN.Team' structure. But the XML types are different, because
 230 --   they have different picklers!
 231 --
 232 data JFileGameXml =
 233   JFileGameXml {
 234     xml_game_id :: Int,
 235     xml_schedule_id :: Int,
 236     xml_odds_info :: JFileGameOddsInfo,
 237     xml_season_type :: Maybe String,
 238     xml_game_date :: UTCTime,
 239     xml_game_time :: UTCTime,
 240     xml_vteam :: VTeam,
 241     xml_vleague :: Maybe String,
 242     xml_hteam :: HTeam,
 243     xml_hleague :: Maybe String,
 244     xml_vscore :: Int,
 245     xml_hscore :: Int,
 246     xml_time_remaining :: Maybe String,
 247     xml_game_status :: JFileGameStatus }
 248   deriving (Eq, Show)
 249
 250
 251 -- * JFileGameListXml
 252
 253 -- | The XML representation of \<message\> -> \<gamelist\>. This
 254 --   element serves only to contain \<game\>s, so we don't store the
 255 --   intermediate table in the database.
 256 --
 257 newtype JFileGameListXml =
 258   JFileGameListXml {
 259     xml_games ::
 260       [JFileGameXml] }
 261   deriving (Eq, Show)
 262
 263
 264 instance ToDb JFileGameXml where
 265   -- | The database analogue of an 'JFileGameXml' is
 266   --   an 'JFileGame'.
 267   --
 268   type Db JFileGameXml = JFileGame
 269
 270
 271 instance Child JFileGameXml where
 272   -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
 273   --   a 'JFile'.
 274   --
 275   type Parent JFileGameXml = JFile
 276
 277
 278 instance FromXmlFkTeams JFileGameXml where
 279   -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the
 280   --   foreign keys for JFile and the home/away teams. We also mash
 281   --   the date/time together into one field.
 282   --
 283   from_xml_fk_teams fk fk_away fk_home JFileGameXml{..} =
 284     JFileGame {
 285       db_jfile_id = fk,
 286       db_away_team_id = fk_away,
 287       db_home_team_id = fk_home,
 288       db_game_id = xml_game_id,
 289       db_schedule_id = xml_schedule_id,
 290       db_odds_info = xml_odds_info,
 291       db_season_type = xml_season_type,
 292       db_game_time = make_game_time xml_game_date xml_game_time,
 293       db_vleague = xml_vleague,
 294       db_hleague = xml_hleague,
 295       db_vscore = xml_vscore,
 296       db_hscore = xml_hscore,
 297       db_time_remaining = xml_time_remaining,
 298       db_game_status = xml_game_status }
 299     where
 300       -- | Make the database \"game time\" from the XML
 301       --   date/time. Simply take the day part from one and the time
 302       --   from the other.
 303       --
 304       make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
 305
 306
 307 -- | This allows us to insert the XML representation
 308 --   'JFileGameXml' directly.
 309 --
 310 instance XmlImportFkTeams JFileGameXml
 311
 312
 313 ---
 314 --- Database stuff.
 315 ---
 316
 317 instance DbImport Message where
 318   dbmigrate _ =
 319     run_dbmigrate $ do
 320       migrate (undefined :: Team)
 321       migrate (undefined :: JFile)
 322       migrate (undefined :: JFileGame)
 323
 324   dbimport m = do
 325     -- Insert the top-level message
 326     msg_id <- insert_xml m
 327
 328     -- Now loop through the message's games
 329     forM_ (xml_games $ xml_gamelist m) $ \game -> do
 330       -- First we insert the home and away teams.
 331       away_team_id <- insert_or_select (vteam $ xml_vteam game)
 332       home_team_id <- insert_or_select (hteam $ xml_hteam game)
 333
 334       -- Now insert the game keyed to the "jfile" and its teams.
 335       insert_xml_fk_teams_ msg_id away_team_id home_team_id game
 336
 337
 338     return ImportSucceeded
 339
 340
 341 mkPersist tsn_codegen_config [groundhog|
 342 - entity: JFile
 343   dbName: jfile
 344   constructors:
 345     - name: JFile
 346       uniques:
 347         - name: unique_jfile
 348           type: constraint
 349           # Prevent multiple imports of the same message.
 350           fields: [db_xml_file_id]
 351
 352 - embedded: JFileGameStatus
 353   fields:
 354     - name: db_status_numeral
 355       dbName: status_numeral
 356     - name: db_status
 357       dbName: status
 358
 359   # Many of the JFileGameOddsInfo fields are redundant and have
 360   # been left out.
 361 - embedded: JFileGameOddsInfo
 362   fields:
 363     - name: db_list_date
 364       dbName: list_date
 365     - name: db_home_starter
 366       dbName: home_starter
 367     - name: db_home_game_key
 368       dbName: home_game_key
 369     - name: db_away_game_key
 370       dbName: away_game_key
 371     - name: db_current_timestamp
 372       dbName: current_timestamp
 373     - name: db_live
 374       dbName: live
 375     - name: db_notes
 376       dbName: notes
 377
 378 - entity: JFileGame
 379   dbName: jfile_games
 380   constructors:
 381     - name: JFileGame
 382       fields:
 383         - name: db_jfile_id
 384           reference:
 385             onDelete: cascade
 386         - name: db_away_team_id
 387           reference:
 388             onDelete: cascade
 389         - name: db_home_team_id
 390           reference:
 391             onDelete: cascade
 392         - name: db_odds_info
 393           embeddedType:
 394             - {name: list_date, dbName: list_date}
 395             - {name: home_starter, dbName: home_starter}
 396             - {name: away_starter, dbName: away_starter}
 397             - {name: home_game_key, dbName: home_game_key}
 398             - {name: away_game_key, dbName: away_game_key}
 399             - {name: current_timestamp, dbName: current_timestamp}
 400             - {name: live, dbName: live}
 401             - {name: notes, dbName: notes}
 402         - name: db_game_status
 403           embeddedType:
 404             - {name: status_numeral, dbName: status_numeral}
 405             - {name: status, dbName: status}
 406
 407 |]
 408
 409
 410
 411 ---
 412 --- Pickling
 413 ---
 414
 415 -- | Pickler for the top-level 'Message'.
 416 --
 417 pickle_message :: PU Message
 418 pickle_message =
 419   xpElem "message" $
 420     xpWrap (from_tuple, to_tuple) $
 421     xp6Tuple (xpElem "XML_File_ID" xpInt)
 422              (xpElem "heading" xpText)
 423              (xpElem "category" xpText)
 424              (xpElem "sport" xpText)
 425              pickle_gamelist
 426              (xpElem "time_stamp" xp_time_stamp)
 427   where
 428     from_tuple = uncurryN Message
 429     to_tuple m = (xml_xml_file_id m,
 430                   xml_heading m,
 431                   xml_category m,
 432                   xml_sport m,
 433                   xml_gamelist m,
 434                   xml_time_stamp m)
 435
 436 pickle_gamelist :: PU JFileGameListXml
 437 pickle_gamelist =
 438   xpElem "gamelist" $
 439     xpWrap (to_result, from_result) $ xpList pickle_game
 440   where
 441     to_result = JFileGameListXml
 442     from_result = xml_games
 443
 444
 445
 446
 447 pickle_game :: PU JFileGameXml
 448 pickle_game =
 449   xpElem "game" $
 450     xpWrap (from_tuple, to_tuple) $
 451     xp14Tuple (xpElem "game_id" xpInt)
 452               (xpElem "schedule_id" xpInt)
 453               pickle_odds_info
 454               (xpElem "seasontype" (xpOption xpText))
 455               (xpElem "Game_Date" xp_date_padded)
 456               (xpElem "Game_Time" xp_time)
 457               pickle_away_team
 458               (xpOption $ xpElem "vleague" xpText)
 459               pickle_home_team
 460               (xpOption $ xpElem "hleague" xpText)
 461               (xpElem "vscore" xpInt)
 462               (xpElem "hscore" xpInt)
 463               (xpOption $ xpElem "time_r" xpText)
 464               pickle_status
 465   where
 466     from_tuple = uncurryN JFileGameXml
 467     to_tuple m = (xml_game_id m,
 468                   xml_schedule_id m,
 469                   xml_odds_info m,
 470                   xml_season_type m,
 471                   xml_game_date m,
 472                   xml_game_time m,
 473                   xml_vteam m,
 474                   xml_vleague m,
 475                   xml_hteam m,
 476                   xml_hleague m,
 477                   xml_vscore m,
 478                   xml_hscore m,
 479                   xml_time_remaining m,
 480                   xml_game_status m)
 481
 482 pickle_odds_info :: PU JFileGameOddsInfo
 483 pickle_odds_info =
 484   xpElem "Odds_Info" $
 485     xpWrap (from_tuple, to_tuple) $
 486     xp19Tuple (xpElem "ListDate" (xpOption xp_date))
 487               (xpElem "HomeTeamID" (xpOption xpText))
 488               (xpElem "AwayTeamID" (xpOption xpText))
 489               (xpElem "HomeAbbr" (xpOption xpText))
 490               (xpElem "AwayAbbr" (xpOption xpText))
 491               (xpElem "HomeTeamName" (xpOption xpText))
 492               (xpElem "AwayTeamName" (xpOption xpText))
 493               (xpElem "HStarter" (xpOption xpText))
 494               (xpElem "AStarter" (xpOption xpText))
 495               (xpElem "GameDate" (xpOption xp_datetime))
 496               (xpElem "HGameKey" (xpOption xpInt))
 497               (xpElem "AGameKey" (xpOption xpInt))
 498               (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
 499               (xpElem "Live" (xpOption xpPrim))
 500               (xpElem "Notes1" xpText0)
 501               (xpElem "Notes2" xpText0)
 502               (xpElem "Notes3" xpText0)
 503               (xpElem "Notes4" xpText0)
 504               (xpElem "Notes5" xpText0)
 505   where
 506     from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
 507       JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
 508       where
 509         notes = intercalate "\n" [n1,n2,n3,n4,n5]
 510
 511     to_tuple o = (db_list_date o,
 512                   db_info_home_team_id o,
 513                   db_info_away_team_id o,
 514                   db_home_abbr o,
 515                   db_away_abbr o,
 516                   db_home_team_name o,
 517                   db_away_team_name o,
 518                   db_home_starter o,
 519                   db_away_starter o,
 520                   db_game_date o,
 521                   db_home_game_key o,
 522                   db_away_game_key o,
 523                   db_current_timestamp o,
 524                   db_live o,
 525                   n1,n2,n3,n4,n5)
 526       where
 527         note_lines = split "\n" (db_notes o)
 528         n1 = case note_lines of
 529                (notes1:_) -> notes1
 530                _          -> ""
 531         n2 = case note_lines of
 532                (_:notes2:_) -> notes2
 533                _            -> ""
 534         n3 = case note_lines of
 535                (_:_:notes3:_) -> notes3
 536                _              -> ""
 537         n4 = case note_lines of
 538                (_:_:_:notes4:_) -> notes4
 539                _                -> ""
 540         n5 = case note_lines of
 541                (_:_:_:_:notes5:_) -> notes5
 542                _                  -> ""
 543
 544 -- | (Un)pickle a home team to/from the dual XML/DB representation
 545 --   'Team'.
 546 --
 547 pickle_home_team :: PU HTeam
 548 pickle_home_team =
 549   xpElem "hteam" $
 550     xpWrap (from_tuple, to_tuple) $
 551     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 552              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
 553              (xpOption xpText) -- Yup, some are nameless
 554   where
 555     from_tuple = HTeam . (uncurryN Team)
 556     to_tuple (HTeam t) = (team_id t,
 557                           abbreviation t,
 558                           name t)
 559
 560
 561 -- | (Un)pickle an away team to/from the dual XML/DB representation
 562 --   'Team'.
 563 --
 564 pickle_away_team :: PU VTeam
 565 pickle_away_team =
 566   xpElem "vteam" $
 567     xpWrap (from_tuple, to_tuple) $
 568     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 569              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
 570              (xpOption xpText) -- Yup, some are nameless
 571   where
 572     from_tuple = VTeam . (uncurryN Team)
 573     to_tuple (VTeam t) = (team_id t,
 574                           abbreviation t,
 575                           name t)
 576
 577
 578 pickle_status :: PU JFileGameStatus
 579 pickle_status =
 580   xpElem "status" $
 581     xpWrap (from_tuple, to_tuple) $
 582     xpPair (xpAttr "numeral" xpInt)
 583            (xpOption xpText)
 584   where
 585     from_tuple = uncurry JFileGameStatus
 586     to_tuple s = (db_status_numeral s,
 587                   db_status s)
 588
 589
 590
 591 --
 592 -- Tasty Tests
 593 --
 594
 595 -- | A list of all tests for this module.
 596 --
 597 jfile_tests :: TestTree
 598 jfile_tests =
 599   testGroup
 600     "JFile tests"
 601     [ test_on_delete_cascade,
 602       test_pickle_of_unpickle_is_identity,
 603       test_unpickle_succeeds ]
 604
 605
 606 -- | If we unpickle something and then pickle it, we should wind up
 607 --   with the same thing we started with. WARNING: success of this
 608 --   test does not mean that unpickling succeeded.
 609 --
 610 test_pickle_of_unpickle_is_identity :: TestTree
 611 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 612   [ check "pickle composed with unpickle is the identity"
 613           "test/xml/jfilexml.xml",
 614     check "pickle composed with unpickle is the identity (missing fields)"
 615           "test/xml/jfilexml-missing-fields.xml" ]
 616   where
 617     check desc path = testCase desc $ do
 618       (expected, actual) <- pickle_unpickle pickle_message path
 619       actual @?= expected
 620
 621
 622
 623 -- | Make sure we can actually unpickle these things.
 624 --
 625 test_unpickle_succeeds :: TestTree
 626 test_unpickle_succeeds = testGroup "unpickle tests"
 627   [ check "unpickling succeeds" "test/xml/jfilexml.xml",
 628     check "unpickling succeeds (missing fields)"
 629           "test/xml/jfilexml-missing-fields.xml" ]
 630   where
 631     check desc path = testCase desc $ do
 632     actual <- unpickleable path pickle_message
 633
 634     let expected = True
 635     actual @?= expected
 636
 637
 638
 639 -- | Make sure everything gets deleted when we delete the top-level
 640 --   record.
 641 --
 642 test_on_delete_cascade :: TestTree
 643 test_on_delete_cascade = testGroup "cascading delete tests"
 644   [ check "deleting auto_racing_results deletes its children"
 645           "test/xml/jfilexml.xml"
 646           20,
 647     check "deleting auto_racing_results deletes its children (missing fields)"
 648           "test/xml/jfilexml-missing-fields.xml"
 649           44 ]
 650   where
 651     check desc path expected = testCase desc $ do
 652       results <- unsafe_unpickle path pickle_message
 653       let a = undefined :: Team
 654       let b = undefined :: JFile
 655       let c = undefined :: JFileGame
 656
 657       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 658                   runMigration silentMigrationLogger $ do
 659                     migrate a
 660                     migrate b
 661                     migrate c
 662                   _ <- dbimport results
 663                   deleteAll b
 664                   count_a <- countAll a
 665                   count_b <- countAll b
 666                   count_c <- countAll c
 667                   return $ sum [count_a, count_b, count_c]
 668       actual @?= expected