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