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 where
  17
  18 -- System imports
  19 import Data.Time ( UTCTime(..) )
  20 import Data.Tuple.Curry ( uncurryN )
  21 import Database.Groundhog ( migrate )
  22 import Database.Groundhog.Core ( DefaultKey )
  23 import Database.Groundhog.TH (
  24   groundhog,
  25   mkPersist )
  26 import Text.XML.HXT.Core (
  27   PU,
  28   xpTriple,
  29   xp6Tuple,
  30   xp7Tuple,
  31   xp8Tuple,
  32   xp10Tuple,
  33   xp14Tuple,
  34   xpAttr,
  35   xpElem,
  36   xpInt,
  37   xpList,
  38   xpOption,
  39   xpPair,
  40   xpText,
  41   xpWrap )
  42
  43
  44 -- Local imports
  45 import TSN.Codegen ( tsn_codegen_config )
  46 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  47 import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
  48 import TSN.Team ( Team(..) )
  49 import TSN.XmlImport (
  50   XmlImport(..),
  51   XmlImportFk(..) )
  52
  53 import Xml (
  54   FromXml(..),
  55   FromXmlFk(..),
  56   ToDb(..) )
  57
  58
  59
  60 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  61 --
  62 dtd :: String
  63 dtd = "jfilexml.dtd"
  64
  65 --
  66 -- DB/XML data types
  67 --
  68
  69 -- * JFile/Message
  70
  71 -- | Database representation of a 'Message'.
  72 --
  73 data JFile =
  74   JFile {
  75     db_xml_file_id :: Int,
  76     db_heading :: String,
  77     db_category :: String,
  78     db_sport :: String,
  79     db_time_stamp :: UTCTime }
  80
  81
  82
  83 -- | XML Representation of an 'JFile'.
  84 --
  85 data Message =
  86   Message {
  87     xml_xml_file_id :: Int,
  88     xml_heading :: String,
  89     xml_category :: String,
  90     xml_sport :: String,
  91     xml_gamelist :: JFileGameListXml,
  92     xml_time_stamp :: UTCTime }
  93   deriving (Eq, Show)
  94
  95
  96 instance ToDb Message where
  97   -- | The database analogue of a 'Message' is a 'JFile'.
  98   --
  99   type Db Message = JFile
 100
 101
 102 -- | The 'FromXml' instance for 'Message' is required for the
 103 --   'XmlImport' instance.
 104 --
 105 instance FromXml Message where
 106   -- | To convert a 'Message' to an 'JFile', we just drop
 107   --   the 'xml_gamelist'.
 108   --
 109   from_xml Message{..} =
 110     JFile {
 111       db_xml_file_id = xml_xml_file_id,
 112       db_heading = xml_heading,
 113       db_category = xml_category,
 114       db_sport = xml_sport,
 115       db_time_stamp = xml_time_stamp }
 116
 117
 118 -- | This allows us to insert the XML representation 'Message'
 119 --   directly.
 120 --
 121 instance XmlImport Message
 122
 123
 124 -- * JFileGameAwayTeamXml / JFileGameHomeTeamXml
 125
 126 -- | The XML representation of a JFile away team. Its corresponding
 127 --   database representation (along with that of the home team) is a
 128 --   TSN.Team, but their XML representations are different.
 129 data JFileGameAwayTeamXml =
 130   JFileGameAwayTeamXml {
 131     away_team_id :: String,
 132     away_team_abbreviation :: String,
 133     away_team_name :: String }
 134   deriving (Eq, Show)
 135
 136 instance ToDb JFileGameAwayTeamXml where
 137   -- | The database analogue of an 'JFileGameAwayTeamXml' is
 138   --   a 'Team'.
 139   --
 140   type Db JFileGameAwayTeamXml = Team
 141
 142 instance FromXml JFileGameAwayTeamXml where
 143   -- | To convert a 'JFileGameAwayTeamXml' to a 'Team', we do just
 144   --   about nothing.
 145   --
 146   from_xml JFileGameAwayTeamXml{..} =
 147     Team {
 148       team_id = away_team_id,
 149       team_abbreviation = away_team_abbreviation,
 150       team_name  = away_team_name }
 151
 152 -- | Allow us to import JFileGameAwayTeamXml directly.
 153 instance XmlImport JFileGameAwayTeamXml
 154
 155
 156 -- | The XML representation of a JFile home team. Its corresponding
 157 --   database representation (along with that of the away team) is a
 158 --   TSN.Team, but their XML representations are different.
 159 data JFileGameHomeTeamXml =
 160   JFileGameHomeTeamXml {
 161     home_team_id :: String,
 162     home_team_abbreviation :: String,
 163     home_team_name :: String }
 164   deriving (Eq, Show)
 165
 166 instance ToDb JFileGameHomeTeamXml where
 167   -- | The database analogue of an 'JFileGameHomeTeamXml' is
 168   --   a 'Team'.
 169   --
 170   type Db JFileGameHomeTeamXml = Team
 171
 172 instance FromXml JFileGameHomeTeamXml where
 173   -- | To convert a 'JFileGameHomeTeamXml' to a 'Team', we do just
 174   --   about nothing.
 175   --
 176   from_xml JFileGameHomeTeamXml{..} =
 177     Team {
 178       team_id = home_team_id,
 179       team_abbreviation = home_team_abbreviation,
 180       team_name  = home_team_name }
 181
 182 -- | Allow us to import JFileGameHomeTeamXml directly.
 183 instance XmlImport JFileGameHomeTeamXml
 184
 185
 186 -- * JFileGame/JFileGameXml
 187
 188 -- | This is an embedded type within each JFileGame. It has its own
 189 --   element, \<Odds_Info\>, but there's only one of them per game. So
 190 --   essentially all of these fields belong to a 'JFileGame'. Aaaannnd
 191 --   most of them are redundant. We'll (un)pickle them for good
 192 --   measure, but in the conversion to the database type, we can drop
 193 --   all of the redundant information.
 194 --
 195 data JFileGameOddsInfo =
 196   JFileGameOddsInfo {
 197     db_list_date :: UTCTime,
 198     db_home_team_id :: String, -- redundant (Team)
 199     db_away_team_id :: String, -- redundant (Team)
 200     db_home_abbr :: String, -- redundant (Team)
 201     db_away_abbr :: String, -- redundant (Team)
 202     db_home_team_name :: String, -- redundant (Team)
 203     db_away_team_name :: String, -- redundant (Team)
 204     db_home_starter :: String,
 205     db_away_starter :: String,
 206     db_game_date :: UTCTime, -- redundant (JFileGame)
 207     db_home_game_key :: Int,
 208     db_away_game_key :: Int,
 209     db_current_timestamp :: UTCTime,
 210     db_live :: Bool,
 211     db_notes :: String }
 212   deriving (Eq, Show)
 213
 214
 215 -- | Another embedded type within 'JFileGame'. These look like,
 216 --   \<status numeral=\"4\"\>FINAL\</status\> within the XML, but
 217 --   they're in one-to-one correspondence with the games.
 218 --
 219 data JFileGameStatus =
 220   JFileGameStatus {
 221     db_status_numeral :: Int,
 222     db_status  :: String }
 223   deriving (Eq, Show)
 224
 225
 226 -- | Database representation of a \<game\> contained within a
 227 --   \<message\>, and, implicitly, a \<gamelist\>.
 228 --
 229 --   We've left out the game date, opting instead to combine the
 230 --   date/time into the 'db_game_time' field.
 231 --
 232 data JFileGame =
 233   JFileGame {
 234     db_jfile_id :: DefaultKey JFile,
 235     db_game_id :: Int,
 236     db_schedule_id :: Int,
 237     db_odds_info :: JFileGameOddsInfo,
 238     db_season_type :: String,
 239     db_game_time :: UTCTime,
 240     db_vleague :: Maybe String,
 241     db_hleague :: Maybe String,
 242     db_vscore :: Int,
 243     db_hscore :: Int,
 244     db_time_remaining :: Maybe String,
 245     db_game_status :: JFileGameStatus }
 246
 247
 248 -- | XML representation of a \<game\> contained within a \<message\>,
 249 --   and a \<gamelist\>. The Away/Home teams seem to coincide with
 250 --   those of 'OddsGame', so we're reusing the DB type via the common
 251 --   'TSN.Team' structure. But the XML types are different, because
 252 --   they have different picklers!
 253 --
 254 data JFileGameXml =
 255   JFileGameXml {
 256     xml_game_id :: Int,
 257     xml_schedule_id :: Int,
 258     xml_odds_info :: JFileGameOddsInfo,
 259     xml_season_type :: String,
 260     xml_game_date :: UTCTime,
 261     xml_game_time :: UTCTime,
 262     xml_vteam :: JFileGameAwayTeamXml,
 263     xml_vleague :: Maybe String,
 264     xml_hteam :: JFileGameHomeTeamXml,
 265     xml_hleague :: Maybe String,
 266     xml_vscore :: Int,
 267     xml_hscore :: Int,
 268     xml_time_remaining :: Maybe String,
 269     xml_game_status :: JFileGameStatus }
 270   deriving (Eq, Show)
 271
 272
 273 -- * JFileGameListXml
 274
 275 -- | The XML representation of \<message\> -> \<gamelist\>. This
 276 --   element serves only to contain \<game\>s, so we don't store the
 277 --   intermediate table in the database.
 278 --
 279 newtype JFileGameListXml =
 280   JFileGameListXml {
 281     xml_games ::
 282       [JFileGameXml] }
 283   deriving (Eq, Show)
 284
 285
 286 instance ToDb JFileGameXml where
 287   -- | The database analogue of an 'JFileGameXml' is
 288   --   an 'JFileGame'.
 289   --
 290   type Db JFileGameXml = JFileGame
 291
 292 instance FromXmlFk JFileGameXml where
 293   -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
 294   --   a 'JFile'.
 295   --
 296   type Parent JFileGameXml = JFile
 297
 298   -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the
 299   --   foreign key and drop the 'xml_vteam'/'xml_hteam'. We also mash
 300   --   the date/time together into one field.
 301   --
 302   from_xml_fk fk JFileGameXml{..} =
 303     JFileGame {
 304       db_jfile_id = fk,
 305       db_game_id = xml_game_id,
 306       db_schedule_id = xml_schedule_id,
 307       db_odds_info = xml_odds_info,
 308       db_season_type = xml_season_type,
 309       db_game_time = xml_game_time,
 310       db_vleague = xml_vleague,
 311       db_hleague = xml_hleague,
 312       db_vscore = xml_vscore,
 313       db_hscore = xml_hscore,
 314       db_time_remaining = xml_time_remaining,
 315       db_game_status = xml_game_status }
 316     where
 317       -- | Make the database \"game time\" from the XML
 318       --   date/time. Simply take the day part from one and the time
 319       --   from the other.
 320       --
 321       make_game_time d Nothing = d
 322       make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
 323
 324
 325 -- | This allows us to insert the XML representation
 326 --   'JFileGameXml' directly.
 327 --
 328 instance XmlImportFk JFileGameXml
 329
 330
 331 -- * JFileGame_Team
 332
 333 -- | Database mapping between games and their home/away teams.
 334 --
 335 data JFileGame_Team =
 336   JFileGame_Team {
 337     jgt_jfile_games_id :: DefaultKey JFileGame,
 338     jgt_away_team_id  :: DefaultKey Team,
 339     jgt_home_team_id  :: DefaultKey Team }
 340
 341
 342 ---
 343 --- Database stuff.
 344 ---
 345
 346 instance DbImport Message where
 347   dbmigrate _ =
 348     run_dbmigrate $ do
 349       migrate (undefined :: Team)
 350       migrate (undefined :: JFile)
 351       migrate (undefined :: JFileGame)
 352       migrate (undefined :: JFileGame_Team)
 353
 354   dbimport m = 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_odds_info
 403           embeddedType:
 404             - {name: list_date, dbName: list_date}
 405             - {name: home_starter, dbName: home_starter}
 406             - {name: away_starter, dbName: away_starter}
 407             - {name: home_game_key, dbName: home_game_key}
 408             - {name: away_game_key, dbName: home_game_key}
 409             - {name: current_timestamp, dbName: current_timestamp}
 410             - {name: live, dbName: live}
 411             - {name: notes, dbName: notes}
 412         - name: db_game_status
 413           embeddedType:
 414             - {name: status_numeral, dbName: status_numeral}
 415             - {name: status, dbName: status}
 416
 417 - entity: JFileGame_Team
 418   dbName: jfile_games__teams
 419   constructors:
 420     - name: JFileGame_Team
 421       fields:
 422         - name: jgt_jfile_games_id
 423           reference:
 424             onDelete: cascade
 425         - name: jgt_away_team_id
 426           reference:
 427             onDelete: cascade
 428         - name: jgt_home_team_id
 429           reference:
 430             onDelete: cascade
 431 |]
 432
 433
 434
 435 ---
 436 --- Pickling
 437 ---
 438
 439 -- | Pickler for the top-level 'Message'.
 440 --
 441 pickle_message :: PU Message
 442 pickle_message =
 443   xpElem "message" $
 444     xpWrap (from_tuple, to_tuple) $
 445     xp6Tuple (xpElem "XML_File_ID" xpInt)
 446              (xpElem "heading" xpText)
 447              (xpElem "category" xpText)
 448              (xpElem "sport" xpText)
 449              pickle_gamelist
 450              (xpElem "time_stamp" xp_time_stamp)
 451   where
 452     from_tuple = uncurryN Message
 453     to_tuple m = (xml_xml_file_id m,
 454                   xml_heading m,
 455                   xml_category m,
 456                   xml_sport m,
 457                   xml_gamelist m,
 458                   xml_time_stamp m)
 459
 460 pickle_gamelist :: PU JFileGameListXml
 461 pickle_gamelist =
 462   xpElem "gamelist" $
 463     xpWrap (to_result, from_result) $ xpList pickle_game
 464   where
 465     to_result = JFileGameListXml
 466     from_result = xml_games
 467
 468
 469
 470
 471 pickle_game :: PU JFileGameXml
 472 pickle_game =
 473   xpElem "game" $
 474     xpWrap (from_tuple, to_tuple) $
 475     xp14Tuple (xpElem "game_id" xpInt)
 476               (xpElem "schedule_id" xpInt)
 477               pickle_odds_info
 478               (xpElem "seasontype" xpText)
 479               (xpElem "Game_Date" xp_date_padded)
 480               (xpElem "Game_Time" xp_time)
 481               pickle_away_team
 482               (xpOption $ xpElem "vleague" xpText)
 483               pickle_home_team
 484               (xpOption $ xpElem "hleague" xpText)
 485               (xpElem "vscore" xpInt)
 486               (xpElem "hscore" xpInt)
 487               (xpOption $ xpElem "time_r" xpText)
 488               pickle_status
 489   where
 490     from_tuple = uncurryN JFileGameXml
 491     to_tuple m = (xml_game_id m,
 492                   xml_schedule_id m,
 493                   xml_odds_info m,
 494                   xml_season_type m,
 495                   xml_game_date m,
 496                   xml_game_time m,
 497                   xml_vteam m,
 498                   xml_vleague m,
 499                   xml_hteam m,
 500                   xml_hleague m,
 501                   xml_vscore m,
 502                   xml_hscore m,
 503                   xml_time_remaining m,
 504                   xml_game_status m)
 505
 506 pickle_odds_info = undefined
 507
 508
 509 pickle_home_team :: PU JFileGameHomeTeamXml
 510 pickle_home_team =
 511   xpElem "hteam" $
 512     xpWrap (from_tuple, to_tuple) $
 513     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 514              (xpAttr "abbr" xpText)
 515              xpText
 516   where
 517     from_tuple = uncurryN JFileGameHomeTeamXml
 518     to_tuple t = (home_team_id t,
 519                   home_team_abbreviation t,
 520                   home_team_name t)
 521
 522
 523 pickle_away_team :: PU JFileGameAwayTeamXml
 524 pickle_away_team =
 525   xpElem "vteam" $
 526     xpWrap (from_tuple, to_tuple) $
 527     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 528              (xpAttr "abbr" xpText)
 529              xpText
 530   where
 531     from_tuple = uncurryN JFileGameAwayTeamXml
 532     to_tuple t = (away_team_id t,
 533                   away_team_abbreviation t,
 534                   away_team_name t)
 535
 536
 537 pickle_status :: PU JFileGameStatus
 538 pickle_status =
 539   xpElem "status" $
 540     xpWrap (from_tuple, to_tuple) $
 541     xpPair (xpAttr "numeral" xpInt)
 542            xpText
 543   where
 544     from_tuple = uncurry JFileGameStatus
 545     to_tuple s = (db_status_numeral s,
 546                   db_status s)