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