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