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