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 Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
  24 import Data.List.Utils ( join, split )
  25 import Data.Tuple.Curry ( uncurryN )
  26 import Data.Typeable ( Typeable )
  27 import Database.Groundhog (
  28   defaultMigrationLogger,
  29   insert,
  30   migrate,
  31   runMigration )
  32 import Database.Groundhog.Core ( DefaultKey )
  33 import Database.Groundhog.TH (
  34   groundhog,
  35   mkPersist )
  36 import System.Console.CmdArgs.Default ( Default(..) )
  37 import Test.Tasty ( TestTree, testGroup )
  38 import Test.Tasty.HUnit ( (@?=), testCase )
  39 import Text.XML.HXT.Core (
  40   PU,
  41   XmlPickler(..),
  42   unpickleDoc,
  43   xp5Tuple,
  44   xp6Tuple,
  45   xp8Tuple,
  46   xpAttr,
  47   xpElem,
  48   xpInt,
  49   xpList,
  50   xpOption,
  51   xpPair,
  52   xpPrim,
  53   xpText,
  54   xpText0,
  55   xpTriple,
  56   xpWrap )
  57
  58 import TSN.Codegen (
  59   tsn_codegen_config,
  60   tsn_db_field_namer )
  61 import TSN.DbImport ( DbImport(..), ImportResult(..) )
  62 import TSN.XmlImport ( XmlImport(..) )
  63 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  64
  65
  66
  67 data OddsCasinoXml =
  68   OddsCasinoXml {
  69     xml_casino_client_id :: Int,
  70     xml_casino_name      :: String,
  71     xml_casino_line      :: Maybe Float }
  72   deriving (Eq, Show)
  73
  74
  75 -- | The casinos should have their own table, but the lines don't
  76 --   belong in that table. (There should be another table joining the
  77 --   casinos and the thing the lines are for together.)
  78 data OddsCasino =
  79   OddsCasino {
  80     casino_client_id :: Int,
  81     casino_name :: String }
  82   deriving (Eq, Show)
  83
  84 instance FromXml OddsCasinoXml where
  85   type Db OddsCasinoXml = 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 OddsCasinoXml{..} = OddsCasino
  90                                  xml_casino_client_id
  91                                  xml_casino_name
  92
  93 instance XmlImport OddsCasinoXml
  94
  95
  96 data OddsHomeTeamXml =
  97   OddsHomeTeamXml {
  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         :: [OddsCasinoXml] }
 103   deriving (Eq, Show)
 104
 105 instance FromXml OddsHomeTeamXml where
 106   type Db OddsHomeTeamXml = OddsTeam
 107   from_xml OddsHomeTeamXml{..} = OddsTeam
 108                                    xml_home_team_id
 109                                    xml_home_abbr
 110                                    xml_home_team_name
 111
 112 instance XmlImport OddsHomeTeamXml where
 113
 114
 115 data OddsTeam =
 116   OddsTeam {
 117     db_team_id         :: Int,
 118     db_abbr            :: String,
 119     db_team_name       :: String }
 120   deriving (Eq, Show)
 121
 122 data OddsAwayTeamXml =
 123   OddsAwayTeamXml {
 124     xml_away_team_id         :: Int,
 125     xml_away_rotation_number :: Int,
 126     xml_away_abbr            :: String,
 127     xml_away_team_name       :: String,
 128     xml_away_casinos         :: [OddsCasinoXml] }
 129   deriving (Eq, Show)
 130
 131 instance FromXml OddsAwayTeamXml where
 132   type Db OddsAwayTeamXml = OddsTeam
 133   from_xml OddsAwayTeamXml{..} = OddsTeam
 134                                    xml_away_team_id
 135                                    xml_away_abbr
 136                                    xml_away_team_name
 137
 138 instance XmlImport OddsAwayTeamXml where
 139
 140 -- | Can't use a newtype with Groundhog.
 141 data OddsOverUnder =
 142   OddsOverUnder [OddsCasinoXml]
 143   deriving (Eq, Show)
 144
 145 data OddsGame =
 146   OddsGame {
 147     db_game_id           :: Int,
 148     db_game_date         :: String, -- TODO
 149     db_game_time         :: String, -- TODO
 150     db_game_away_team_id :: DefaultKey OddsTeam,
 151     db_game_away_team_rotation_number :: Int,
 152     db_game_home_team_id    :: DefaultKey OddsTeam,
 153     db_game_home_team_rotation_number :: Int }
 154 deriving instance Eq OddsGame
 155 deriving instance Show OddsGame
 156
 157 data OddsGameXml =
 158   OddsGameXml {
 159     xml_game_id         :: Int,
 160     xml_game_date       :: String, -- TODO
 161     xml_game_time       :: String, -- TODO
 162     xml_game_away_team  :: OddsAwayTeamXml,
 163     xml_game_home_team  :: OddsHomeTeamXml,
 164     xml_game_over_under :: OddsOverUnder }
 165   deriving (Eq, Show)
 166
 167 data Odds =
 168   Odds {
 169     db_sport :: String,
 170     db_title :: String,
 171     db_line_time :: String }
 172
 173 -- | This is our best guess at what occurs in the Odds_XML
 174 --   documents. It looks like each consecutive set of games can
 175 --   optionally have some notes appear before it. Each "note" comes as
 176 --   its own <Notes>...</Notes> element.
 177 --
 178 --   The notes are ignored completely in the database; we only bother
 179 --   with them to ensure that we're (un)pickling correctly.
 180 --
 181 --   We can't group the notes with a "set" of 'OddsGame's, because that
 182 --   leads to ambiguity in parsing. Since we're going to ignore the
 183 --   notes anyway, we just stick them with an arbitrary game. C'est la
 184 --   vie.
 185 --
 186 data OddsGameWithNotes =
 187   OddsGameWithNotes {
 188     notes :: [String],
 189     game :: OddsGameXml }
 190   deriving (Eq, Show)
 191
 192 -- | The XML representation of Odds.
 193 data Message =
 194   Message {
 195     xml_xml_file_id :: Int,
 196     xml_heading :: String,
 197     xml_category :: String,
 198     xml_sport :: String,
 199     xml_title :: String,
 200     xml_line_time :: String,
 201     xml_games_with_notes :: [OddsGameWithNotes],
 202     xml_time_stamp :: String }
 203   deriving (Eq, Show)
 204
 205 -- | Pseudo-field that lets us get the 'OddsGame's out of
 206 --   'xml_games_with_notes'.
 207 xml_games :: Message -> [OddsGameXml]
 208 xml_games m = map game (xml_games_with_notes m)
 209
 210 instance FromXml Message where
 211   type Db Message = Odds
 212
 213   -- We don't need the key argument (from_xml_fk) since the XML type
 214   -- contains more information in this case.
 215   from_xml (Message _ _ _ d e f _ _) =
 216     Odds d e f
 217
 218 instance XmlImport Message
 219
 220 instance DbImport Message where
 221   dbmigrate _= undefined
 222   dbimport = undefined
 223
 224 pickle_game_with_notes :: PU OddsGameWithNotes
 225 pickle_game_with_notes =
 226   xpWrap (from_pair, to_pair) $
 227     xpPair
 228       (xpList $ xpElem "Notes" xpText)
 229       pickle_game
 230   where
 231     from_pair = uncurry OddsGameWithNotes
 232     to_pair OddsGameWithNotes{..} = (notes, game)
 233
 234
 235
 236 pickle_casino :: PU OddsCasinoXml
 237 pickle_casino =
 238   xpElem "Casino" $
 239   xpWrap (from_tuple, to_tuple) $
 240   xpTriple
 241     (xpAttr "ClientID" xpInt)
 242     (xpAttr "Name" xpText)
 243     (xpOption xpPrim) -- Float
 244   where
 245     from_tuple = uncurryN OddsCasinoXml
 246     -- Use record wildcards to avoid unused field warnings.
 247     to_tuple OddsCasinoXml{..} = (xml_casino_client_id,
 248                                   xml_casino_name,
 249                                   xml_casino_line)
 250
 251 instance XmlPickler OddsCasinoXml where
 252   xpickle = pickle_casino
 253
 254
 255 pickle_home_team :: PU OddsHomeTeamXml
 256 pickle_home_team =
 257   xpElem "HomeTeam" $
 258     xpWrap (from_tuple, to_tuple) $
 259       xp5Tuple
 260         (xpElem "HomeTeamID" xpInt)
 261         (xpElem "HomeRotationNumber" xpInt)
 262         (xpElem "HomeAbbr" xpText)
 263         (xpElem "HomeTeamName" xpText)
 264         (xpList pickle_casino)
 265   where
 266     from_tuple = uncurryN OddsHomeTeamXml
 267     -- Use record wildcards to avoid unused field warnings.
 268     to_tuple OddsHomeTeamXml{..} = (xml_home_team_id,
 269                                  xml_home_rotation_number,
 270                                  xml_home_abbr,
 271                                  xml_home_team_name,
 272                                  xml_home_casinos)
 273
 274 instance XmlPickler OddsHomeTeamXml where
 275   xpickle = pickle_home_team
 276
 277
 278 pickle_away_team :: PU OddsAwayTeamXml
 279 pickle_away_team =
 280   xpElem "AwayTeam" $
 281     xpWrap (from_tuple, to_tuple) $
 282       xp5Tuple
 283         (xpElem "AwayTeamID" xpInt)
 284         (xpElem "AwayRotationNumber" xpInt)
 285         (xpElem "AwayAbbr" xpText)
 286         (xpElem "AwayTeamName" xpText)
 287         (xpList pickle_casino)
 288   where
 289     from_tuple = uncurryN OddsAwayTeamXml
 290     -- Use record wildcards to avoid unused field warnings.
 291     to_tuple OddsAwayTeamXml{..} = (xml_away_team_id,
 292                                  xml_away_rotation_number,
 293                                  xml_away_abbr,
 294                                  xml_away_team_name,
 295                                  xml_away_casinos)
 296
 297
 298 instance XmlPickler OddsAwayTeamXml where
 299   xpickle = pickle_away_team
 300
 301
 302 pickle_over_under :: PU OddsOverUnder
 303 pickle_over_under =
 304   xpElem "Over_Under" $
 305   xpWrap (to_newtype, from_newtype) $
 306     xpList pickle_casino
 307   where
 308     from_newtype (OddsOverUnder cs) = cs
 309     to_newtype = OddsOverUnder
 310
 311 instance XmlPickler OddsOverUnder where
 312   xpickle = pickle_over_under
 313
 314
 315 pickle_game :: PU OddsGameXml
 316 pickle_game =
 317   xpElem "Game" $
 318   xpWrap (from_tuple, to_tuple) $
 319   xp6Tuple
 320     (xpElem "GameID" xpInt)
 321     (xpElem "Game_Date" xpText)
 322     (xpElem "Game_Time" xpText)
 323     pickle_away_team
 324     pickle_home_team
 325     pickle_over_under
 326   where
 327     from_tuple = uncurryN OddsGameXml
 328     -- Use record wildcards to avoid unused field warnings.
 329     to_tuple OddsGameXml{..} = (xml_game_id,
 330                                 xml_game_date,
 331                                 xml_game_time,
 332                                 xml_game_away_team,
 333                                 xml_game_home_team,
 334                                 xml_game_over_under)
 335
 336 instance XmlPickler OddsGameXml where
 337   xpickle = pickle_game
 338
 339
 340 pickle_message :: PU Message
 341 pickle_message =
 342   xpElem "message" $
 343     xpWrap (from_tuple, to_tuple) $
 344     xp8Tuple (xpElem "XML_File_ID" xpInt)
 345              (xpElem "heading" xpText)
 346              (xpElem "category" xpText)
 347              (xpElem "sport" xpText)
 348              (xpElem "Title" xpText)
 349              (xpElem "Line_Time" xpText)
 350              (xpList pickle_game_with_notes)
 351              (xpElem "time_stamp" xpText)
 352   where
 353     from_tuple = uncurryN Message
 354     to_tuple m = (xml_xml_file_id m,
 355                   xml_heading m,
 356                   xml_category m,
 357                   xml_sport m,
 358                   xml_title m,
 359                   xml_line_time m,
 360                   xml_games_with_notes m,
 361                   xml_time_stamp m)
 362
 363
 364 instance XmlPickler Message where
 365   xpickle = pickle_message
 366
 367
 368
 369
 370
 371 -- * Groundhog database schema.
 372 mkPersist tsn_codegen_config [groundhog|
 373 - entity: Odds
 374
 375 - entity: OddsCasino
 376   dbName: odds_casinos
 377   constructors:
 378     - name: OddsCasino
 379       uniques:
 380         - name: unique_odds_casino
 381           type: constraint
 382           fields: [casino_client_id]
 383
 384 - entity: OddsTeam
 385   dbName: odds_teams
 386   constructors:
 387     - name: OddsTeam
 388       uniques:
 389         - name: unique_odds_team
 390           type: constraint
 391           fields: [db_team_id]
 392
 393
 394 - entity: OddsGame
 395   dbName: odds_games
 396   constructors:
 397     - name: OddsGame
 398       uniques:
 399         - name: unique_odds_game
 400           type: constraint
 401           fields: [db_game_id]
 402 |]
 403
 404
 405 -- * Tasty Tests
 406 odds_tests :: TestTree
 407 odds_tests =
 408   testGroup
 409     "Odds tests"
 410     [ test_pickle_of_unpickle_is_identity,
 411       test_unpickle_succeeds ]
 412
 413
 414 -- | Warning, succeess of this test does not mean that unpickling
 415 --   succeeded.
 416 test_pickle_of_unpickle_is_identity :: TestTree
 417 test_pickle_of_unpickle_is_identity =
 418   testCase "pickle composed with unpickle is the identity" $ do
 419     let path = "test/xml/Odds_XML.xml"
 420     (expected :: [Message], actual) <- pickle_unpickle "message" path
 421     actual @?= expected
 422
 423
 424 test_unpickle_succeeds :: TestTree
 425 test_unpickle_succeeds =
 426   testCase "unpickling succeeds" $ do
 427   let path = "test/xml/Odds_XML.xml"
 428   actual <- unpickleable path pickle_message
 429   let expected = True
 430   actual @?= expected