src/TSN/XML/Odds.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
  11 --   a root element \<message\> that contains a bunch of other
  12 --   unorganized crap.
  13 --
  14 module TSN.XML.Odds (
  15   Odds,
  16   Message,
  17   odds_tests )
  18 where
  19
  20 import Control.Monad ( forM_ )
  21 import Data.Tuple.Curry ( uncurryN )
  22 import Database.Groundhog (
  23   (=.),
  24   (==.),
  25   insert_,
  26   insertByAll,
  27   migrate,
  28   update )
  29 import Database.Groundhog.Core ( DefaultKey )
  30 import Database.Groundhog.TH (
  31   groundhog,
  32   mkPersist )
  33 import Test.Tasty ( TestTree, testGroup )
  34 import Test.Tasty.HUnit ( (@?=), testCase )
  35 import Text.XML.HXT.Core (
  36   PU,
  37   XmlPickler(..),
  38   xp5Tuple,
  39   xp6Tuple,
  40   xp8Tuple,
  41   xpAttr,
  42   xpElem,
  43   xpInt,
  44   xpList,
  45   xpOption,
  46   xpPair,
  47   xpPrim,
  48   xpText,
  49   xpTriple,
  50   xpWrap )
  51
  52 import TSN.Codegen (
  53   tsn_codegen_config )
  54 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  55 import TSN.XmlImport ( XmlImport(..) )
  56 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  57
  58
  59
  60 data OddsGameCasinoXml =
  61   OddsGameCasinoXml {
  62     xml_casino_client_id :: Int,
  63     xml_casino_name      :: String,
  64     xml_casino_line      :: Maybe Double }
  65   deriving (Eq, Show)
  66
  67
  68 -- | The casinos should have their own table, but the lines don't
  69 --   belong in that table. (There should be another table joining the
  70 --   casinos and the thing the lines are for together.)
  71 --
  72 --   We drop the 'Game' prefix because the Casinos really aren't
  73 --   children of the games; the XML just makes it seem that way.
  74 --
  75 data OddsCasino =
  76   OddsCasino {
  77     casino_client_id :: Int,
  78     casino_name :: String }
  79   deriving (Eq, Show)
  80
  81 instance FromXml OddsGameCasinoXml where
  82   type Db OddsGameCasinoXml = OddsCasino
  83
  84   -- We don't need the key argument (from_xml_fk) since the XML type
  85   -- contains more information in this case.
  86   from_xml OddsGameCasinoXml{..} = OddsCasino
  87                                      xml_casino_client_id
  88                                      xml_casino_name
  89
  90 instance XmlImport OddsGameCasinoXml
  91
  92
  93 data OddsGameHomeTeamXml =
  94   OddsGameHomeTeamXml {
  95     xml_home_team_id         :: Int,
  96     xml_home_rotation_number :: Int,
  97     xml_home_abbr            :: String,
  98     xml_home_team_name       :: String,
  99     xml_home_casinos         :: [OddsGameCasinoXml] }
 100   deriving (Eq, Show)
 101
 102 instance FromXml OddsGameHomeTeamXml where
 103   type Db OddsGameHomeTeamXml = OddsGameTeam
 104   from_xml OddsGameHomeTeamXml{..} = OddsGameTeam
 105                                        xml_home_team_id
 106                                        xml_home_abbr
 107                                        xml_home_team_name
 108
 109 instance XmlImport OddsGameHomeTeamXml where
 110
 111
 112 data OddsGameTeam =
 113   OddsGameTeam {
 114     db_team_id         :: Int,
 115     db_abbr            :: String,
 116     db_team_name       :: String }
 117   deriving (Eq, Show)
 118
 119
 120 -- | Database mapping between games and their home/away teams.
 121 data OddsGame_OddsGameTeam =
 122   OddsGame_OddsGameTeam {
 123     ogogt_odds_games_id :: DefaultKey OddsGame,
 124     ogogt_away_team_id  :: DefaultKey OddsGameTeam,
 125     ogogt_home_team_id  :: DefaultKey OddsGameTeam }
 126
 127 data OddsGameAwayTeamXml =
 128   OddsGameAwayTeamXml {
 129     xml_away_team_id         :: Int,
 130     xml_away_rotation_number :: Int,
 131     xml_away_abbr            :: String,
 132     xml_away_team_name       :: String,
 133     xml_away_casinos         :: [OddsGameCasinoXml] }
 134   deriving (Eq, Show)
 135
 136 instance FromXml OddsGameAwayTeamXml where
 137   type Db OddsGameAwayTeamXml = OddsGameTeam
 138   from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
 139                                        xml_away_team_id
 140                                        xml_away_abbr
 141                                        xml_away_team_name
 142
 143 instance XmlImport OddsGameAwayTeamXml where
 144
 145 -- | Can't use a newtype with Groundhog.
 146 newtype OddsGameOverUnderXml =
 147   OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
 148   deriving (Eq, Show)
 149
 150 -- | This database representation of the casino lines can't be
 151 --   constructed from the one in the XML. The casinos within
 152 --   Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all the
 153 --   same. We don't need a bajillion different tables to store that --
 154 --   just one tying the casino/game pair to the three lines.
 155 data OddsGameLine =
 156   OddsGameLine {
 157     ogl_odds_games_id   :: DefaultKey OddsGame,
 158     ogl_odds_casinos_id :: DefaultKey OddsCasino,
 159     ogl_over_under      :: Maybe Double,
 160     ogl_away_line       :: Maybe Double,
 161     ogl_home_line       :: Maybe Double }
 162
 163 data OddsGame =
 164   OddsGame {
 165     db_game_id           :: Int,
 166     db_game_date         :: String, -- TODO
 167     db_game_time         :: String, -- TODO
 168     db_game_away_team_rotation_number :: Int,
 169     db_game_home_team_rotation_number :: Int }
 170 deriving instance Eq OddsGame
 171 deriving instance Show OddsGame
 172
 173 data OddsGameXml =
 174   OddsGameXml {
 175     xml_game_id         :: Int,
 176     xml_game_date       :: String, -- TODO
 177     xml_game_time       :: String, -- TODO
 178     xml_game_away_team  :: OddsGameAwayTeamXml,
 179     xml_game_home_team  :: OddsGameHomeTeamXml,
 180     xml_game_over_under :: OddsGameOverUnderXml }
 181   deriving (Eq, Show)
 182
 183 -- | Pseudo-field that lets us get the 'OddsCasino's out of
 184 --   xml_game_over_under.
 185 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
 186 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
 187
 188
 189 instance FromXml OddsGameXml where
 190   type Db OddsGameXml = OddsGame
 191   from_xml OddsGameXml{..} = OddsGame
 192                                xml_game_id
 193                                xml_game_date
 194                                xml_game_time
 195                                (xml_away_rotation_number xml_game_away_team)
 196                                (xml_home_rotation_number xml_game_home_team)
 197
 198 instance XmlImport OddsGameXml
 199
 200
 201
 202 data Odds =
 203   Odds {
 204     db_sport :: String,
 205     db_title :: String,
 206     db_line_time :: String }
 207
 208
 209 -- | Map 'Odds' to their children 'OddsGame's.
 210 data Odds_OddsGame =
 211   Odds_OddsGame {
 212     oog_odds_id       :: DefaultKey Odds,
 213     oog_odds_games_id :: DefaultKey OddsGame }
 214
 215 -- | This is our best guess at what occurs in the Odds_XML
 216 --   documents. It looks like each consecutive set of games can
 217 --   optionally have some notes appear before it. Each "note" comes as
 218 --   its own <Notes>...</Notes> element.
 219 --
 220 --   The notes are ignored completely in the database; we only bother
 221 --   with them to ensure that we're (un)pickling correctly.
 222 --
 223 --   We can't group the notes with a "set" of 'OddsGame's, because that
 224 --   leads to ambiguity in parsing. Since we're going to ignore the
 225 --   notes anyway, we just stick them with an arbitrary game. C'est la
 226 --   vie.
 227 --
 228 data OddsGameWithNotes =
 229   OddsGameWithNotes {
 230     notes :: [String],
 231     game :: OddsGameXml }
 232   deriving (Eq, Show)
 233
 234 -- | The XML representation of Odds.
 235 data Message =
 236   Message {
 237     xml_xml_file_id :: Int,
 238     xml_heading :: String,
 239     xml_category :: String,
 240     xml_sport :: String,
 241     xml_title :: String,
 242     xml_line_time :: String,
 243     xml_games_with_notes :: [OddsGameWithNotes],
 244     xml_time_stamp :: String }
 245   deriving (Eq, Show)
 246
 247 -- | Pseudo-field that lets us get the 'OddsGame's out of
 248 --   'xml_games_with_notes'.
 249 xml_games :: Message -> [OddsGameXml]
 250 xml_games m = map game (xml_games_with_notes m)
 251
 252
 253 instance FromXml Message where
 254   type Db Message = Odds
 255
 256   -- We don't need the key argument (from_xml_fk) since the XML type
 257   -- contains more information in this case.
 258   from_xml (Message _ _ _ d e f _ _) =
 259     Odds d e f
 260
 261 instance XmlImport Message
 262
 263
 264
 265 -- * Groundhog database schema.
 266 -- | This must come before the dbimport code.
 267 --
 268 mkPersist tsn_codegen_config [groundhog|
 269 - entity: Odds
 270
 271 - entity: OddsCasino
 272   dbName: odds_casinos
 273   constructors:
 274     - name: OddsCasino
 275       uniques:
 276         - name: unique_odds_casino
 277           type: constraint
 278           fields: [casino_client_id]
 279
 280 - entity: OddsGameTeam
 281   dbName: odds_games_teams
 282   constructors:
 283     - name: OddsGameTeam
 284       uniques:
 285         - name: unique_odds_games_team
 286           type: constraint
 287           fields: [db_team_id]
 288
 289
 290 - entity: OddsGame
 291   dbName: odds_games
 292   constructors:
 293     - name: OddsGame
 294       uniques:
 295         - name: unique_odds_game
 296           type: constraint
 297           fields: [db_game_id]
 298
 299 - entity: OddsGameLine
 300   dbName: odds_games_lines
 301
 302 - entity: Odds_OddsGame
 303   dbName: odds__odds_games
 304
 305 - entity: OddsGame_OddsGameTeam
 306   dbName: odds_games__odds_games_teams
 307 |]
 308
 309 instance DbImport Message where
 310   dbmigrate _=
 311     run_dbmigrate $ do
 312       migrate (undefined :: Odds)
 313       migrate (undefined :: OddsCasino)
 314       migrate (undefined :: OddsGameTeam)
 315       migrate (undefined :: OddsGame)
 316       migrate (undefined :: Odds_OddsGame)
 317       migrate (undefined :: OddsGame_OddsGameTeam)
 318       migrate (undefined :: OddsGameLine)
 319
 320   dbimport m = do
 321     -- Insert the root "odds" element and acquire its primary key (id).
 322     odds_id <- insert_xml m
 323
 324     -- Next, we insert the home and away teams. We do this before
 325     -- inserting the game itself because the game has two foreign keys
 326     -- pointing to odds_games_teams.
 327     forM_ (xml_games m) $ \g -> do
 328       game_id <- insert_xml_or_select g
 329       -- Insert a record into odds__odds_game mapping this game
 330       -- to its parent in the odds table.
 331       insert_ (Odds_OddsGame odds_id game_id)
 332
 333       -- Next to insert the home and away teams.
 334       away_team_id <- insert_xml_or_select (xml_game_away_team g)
 335       home_team_id <- insert_xml_or_select (xml_game_home_team g)
 336
 337       -- Insert a record into odds_games__odds_games_teams
 338       -- mapping the home/away teams to this game.
 339       insert_ (OddsGame_OddsGameTeam game_id away_team_id home_team_id)
 340
 341       -- Finaly, we insert the lines. The over/under entries for this
 342       -- game and the lines for the casinos all wind up in the same
 343       -- table, odds_games_lines. We can insert the over/under entries
 344       -- freely with empty away/home lines:
 345       forM_ (xml_game_over_under_casinos g) $ \c -> do
 346         -- Start by inderting the casino.
 347         ou_casino_id <- insert_xml_or_select c
 348
 349         -- Now add the over/under entry with the casino's id.
 350         let ogl = OddsGameLine
 351                     game_id
 352                     ou_casino_id
 353                     (xml_casino_line c)
 354                     Nothing
 355                     Nothing
 356
 357         insertByAll ogl
 358
 359       -- ...but then when we insert the home/away team lines, we
 360       -- prefer to update the existing entry rather than overwrite it
 361       -- or add a new record.
 362       forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do
 363         -- insert, or more likely retrieve the existing, casino
 364         a_casino_id <- insert_xml_or_select c
 365
 366         -- Unconditionally update that casino's away team line with ours.
 367         update [Ogl_Away_Line =. (xml_casino_line c)] $ -- WHERE
 368           Ogl_Odds_Casinos_Id ==. a_casino_id
 369
 370       -- Repeat all that for the home team.
 371       forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
 372         h_casino_id <- insert_xml_or_select c
 373         update [Ogl_Home_Line =. (xml_casino_line c)] $ -- WHERE
 374           Ogl_Odds_Casinos_Id ==. h_casino_id
 375
 376       return game_id
 377
 378     return ImportSucceeded
 379
 380 pickle_game_with_notes :: PU OddsGameWithNotes
 381 pickle_game_with_notes =
 382   xpWrap (from_pair, to_pair) $
 383     xpPair
 384       (xpList $ xpElem "Notes" xpText)
 385       pickle_game
 386   where
 387     from_pair = uncurry OddsGameWithNotes
 388     to_pair OddsGameWithNotes{..} = (notes, game)
 389
 390
 391
 392 pickle_casino :: PU OddsGameCasinoXml
 393 pickle_casino =
 394   xpElem "Casino" $
 395   xpWrap (from_tuple, to_tuple) $
 396   xpTriple
 397     (xpAttr "ClientID" xpInt)
 398     (xpAttr "Name" xpText)
 399     (xpOption xpPrim) -- Double
 400   where
 401     from_tuple = uncurryN OddsGameCasinoXml
 402     -- Use record wildcards to avoid unused field warnings.
 403     to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
 404                                       xml_casino_name,
 405                                       xml_casino_line)
 406
 407 instance XmlPickler OddsGameCasinoXml where
 408   xpickle = pickle_casino
 409
 410
 411 pickle_home_team :: PU OddsGameHomeTeamXml
 412 pickle_home_team =
 413   xpElem "HomeTeam" $
 414     xpWrap (from_tuple, to_tuple) $
 415       xp5Tuple
 416         (xpElem "HomeTeamID" xpInt)
 417         (xpElem "HomeRotationNumber" xpInt)
 418         (xpElem "HomeAbbr" xpText)
 419         (xpElem "HomeTeamName" xpText)
 420         (xpList pickle_casino)
 421   where
 422     from_tuple = uncurryN OddsGameHomeTeamXml
 423     -- Use record wildcards to avoid unused field warnings.
 424     to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
 425                                         xml_home_rotation_number,
 426                                         xml_home_abbr,
 427                                         xml_home_team_name,
 428                                         xml_home_casinos)
 429
 430 instance XmlPickler OddsGameHomeTeamXml where
 431   xpickle = pickle_home_team
 432
 433
 434 pickle_away_team :: PU OddsGameAwayTeamXml
 435 pickle_away_team =
 436   xpElem "AwayTeam" $
 437     xpWrap (from_tuple, to_tuple) $
 438       xp5Tuple
 439         (xpElem "AwayTeamID" xpInt)
 440         (xpElem "AwayRotationNumber" xpInt)
 441         (xpElem "AwayAbbr" xpText)
 442         (xpElem "AwayTeamName" xpText)
 443         (xpList pickle_casino)
 444   where
 445     from_tuple = uncurryN OddsGameAwayTeamXml
 446     -- Use record wildcards to avoid unused field warnings.
 447     to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
 448                                  xml_away_rotation_number,
 449                                  xml_away_abbr,
 450                                  xml_away_team_name,
 451                                  xml_away_casinos)
 452
 453
 454 instance XmlPickler OddsGameAwayTeamXml where
 455   xpickle = pickle_away_team
 456
 457
 458 pickle_over_under :: PU OddsGameOverUnderXml
 459 pickle_over_under =
 460   xpElem "Over_Under" $
 461   xpWrap (to_newtype, from_newtype) $
 462     xpList pickle_casino
 463   where
 464     from_newtype (OddsGameOverUnderXml cs) = cs
 465     to_newtype = OddsGameOverUnderXml
 466
 467 instance XmlPickler OddsGameOverUnderXml where
 468   xpickle = pickle_over_under
 469
 470
 471 pickle_game :: PU OddsGameXml
 472 pickle_game =
 473   xpElem "Game" $
 474   xpWrap (from_tuple, to_tuple) $
 475   xp6Tuple
 476     (xpElem "GameID" xpInt)
 477     (xpElem "Game_Date" xpText)
 478     (xpElem "Game_Time" xpText)
 479     pickle_away_team
 480     pickle_home_team
 481     pickle_over_under
 482   where
 483     from_tuple = uncurryN OddsGameXml
 484     -- Use record wildcards to avoid unused field warnings.
 485     to_tuple OddsGameXml{..} = (xml_game_id,
 486                                 xml_game_date,
 487                                 xml_game_time,
 488                                 xml_game_away_team,
 489                                 xml_game_home_team,
 490                                 xml_game_over_under)
 491
 492 instance XmlPickler OddsGameXml where
 493   xpickle = pickle_game
 494
 495
 496 pickle_message :: PU Message
 497 pickle_message =
 498   xpElem "message" $
 499     xpWrap (from_tuple, to_tuple) $
 500     xp8Tuple (xpElem "XML_File_ID" xpInt)
 501              (xpElem "heading" xpText)
 502              (xpElem "category" xpText)
 503              (xpElem "sport" xpText)
 504              (xpElem "Title" xpText)
 505              (xpElem "Line_Time" xpText)
 506              (xpList pickle_game_with_notes)
 507              (xpElem "time_stamp" xpText)
 508   where
 509     from_tuple = uncurryN Message
 510     to_tuple m = (xml_xml_file_id m,
 511                   xml_heading m,
 512                   xml_category m,
 513                   xml_sport m,
 514                   xml_title m,
 515                   xml_line_time m,
 516                   xml_games_with_notes m,
 517                   xml_time_stamp m)
 518
 519
 520 instance XmlPickler Message where
 521   xpickle = pickle_message
 522
 523
 524
 525
 526 -- * Tasty Tests
 527 odds_tests :: TestTree
 528 odds_tests =
 529   testGroup
 530     "Odds tests"
 531     [ test_pickle_of_unpickle_is_identity,
 532       test_unpickle_succeeds ]
 533
 534
 535 -- | Warning, succeess of this test does not mean that unpickling
 536 --   succeeded.
 537 test_pickle_of_unpickle_is_identity :: TestTree
 538 test_pickle_of_unpickle_is_identity =
 539   testCase "pickle composed with unpickle is the identity" $ do
 540     let path = "test/xml/Odds_XML.xml"
 541     (expected, actual) <- pickle_unpickle pickle_message path
 542     actual @?= expected
 543
 544
 545 test_unpickle_succeeds :: TestTree
 546 test_unpickle_succeeds =
 547   testCase "unpickling succeeds" $ do
 548   let path = "test/xml/Odds_XML.xml"
 549   actual <- unpickleable path pickle_message
 550   let expected = True
 551   actual @?= expected