src/TSN/XML/JFile.hs

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