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