src/TSN/XML/Odds.hs

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