1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
11 -- a root element \<message\> that contains a bunch of other
20 import Control.Monad ( forM_ )
21 import Data.Tuple.Curry ( uncurryN )
22 import Database.Groundhog (
29 import Database.Groundhog.Core ( DefaultKey )
30 import Database.Groundhog.TH (
33 import Test.Tasty ( TestTree, testGroup )
34 import Test.Tasty.HUnit ( (@?=), testCase )
35 import Text.XML.HXT.Core (
54 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
55 import TSN.XmlImport ( XmlImport(..) )
56 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
60 data OddsGameCasinoXml =
62 xml_casino_client_id :: Int,
63 xml_casino_name :: String,
64 xml_casino_line :: Maybe Double }
68 -- | The casinos should have their own table, but the lines don't
69 -- belong in that table. (There should be another table joining the
70 -- casinos and the thing the lines are for together.)
72 -- We drop the 'Game' prefix because the Casinos really aren't
73 -- children of the games; the XML just makes it seem that way.
77 casino_client_id :: Int,
78 casino_name :: String }
81 instance FromXml OddsGameCasinoXml where
82 type Db OddsGameCasinoXml = OddsCasino
84 -- We don't need the key argument (from_xml_fk) since the XML type
85 -- contains more information in this case.
86 from_xml OddsGameCasinoXml{..} = OddsCasino
90 instance XmlImport OddsGameCasinoXml
93 data OddsGameHomeTeamXml =
95 xml_home_team_id :: Int,
96 xml_home_rotation_number :: Int,
97 xml_home_abbr :: String,
98 xml_home_team_name :: String,
99 xml_home_casinos :: [OddsGameCasinoXml] }
102 instance FromXml OddsGameHomeTeamXml where
103 type Db OddsGameHomeTeamXml = OddsGameTeam
104 from_xml OddsGameHomeTeamXml{..} = OddsGameTeam
109 instance XmlImport OddsGameHomeTeamXml where
116 db_team_name :: String }
120 -- | Database mapping between games and their home/away teams.
121 data OddsGame_OddsGameTeam =
122 OddsGame_OddsGameTeam {
123 ogogt_odds_games_id :: DefaultKey OddsGame,
124 ogogt_away_team_id :: DefaultKey OddsGameTeam,
125 ogogt_home_team_id :: DefaultKey OddsGameTeam }
127 data OddsGameAwayTeamXml =
128 OddsGameAwayTeamXml {
129 xml_away_team_id :: Int,
130 xml_away_rotation_number :: Int,
131 xml_away_abbr :: String,
132 xml_away_team_name :: String,
133 xml_away_casinos :: [OddsGameCasinoXml] }
136 instance FromXml OddsGameAwayTeamXml where
137 type Db OddsGameAwayTeamXml = OddsGameTeam
138 from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
143 instance XmlImport OddsGameAwayTeamXml where
145 -- | Can't use a newtype with Groundhog.
146 newtype OddsGameOverUnderXml =
147 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
150 -- | This database representation of the casino lines can't be
151 -- constructed from the one in the XML. The casinos within
152 -- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all the
153 -- same. We don't need a bajillion different tables to store that --
154 -- just one tying the casino/game pair to the three lines.
157 ogl_odds_games_id :: DefaultKey OddsGame,
158 ogl_odds_casinos_id :: DefaultKey OddsCasino,
159 ogl_over_under :: Maybe Double,
160 ogl_away_line :: Maybe Double,
161 ogl_home_line :: Maybe Double }
166 db_game_date :: String, -- TODO
167 db_game_time :: String, -- TODO
168 db_game_away_team_rotation_number :: Int,
169 db_game_home_team_rotation_number :: Int }
170 deriving instance Eq OddsGame
171 deriving instance Show OddsGame
176 xml_game_date :: String, -- TODO
177 xml_game_time :: String, -- TODO
178 xml_game_away_team :: OddsGameAwayTeamXml,
179 xml_game_home_team :: OddsGameHomeTeamXml,
180 xml_game_over_under :: OddsGameOverUnderXml }
183 -- | Pseudo-field that lets us get the 'OddsCasino's out of
184 -- xml_game_over_under.
185 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
186 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
189 instance FromXml OddsGameXml where
190 type Db OddsGameXml = OddsGame
191 from_xml OddsGameXml{..} = OddsGame
195 (xml_away_rotation_number xml_game_away_team)
196 (xml_home_rotation_number xml_game_home_team)
198 instance XmlImport OddsGameXml
206 db_line_time :: String }
209 -- | Map 'Odds' to their children 'OddsGame's.
212 oog_odds_id :: DefaultKey Odds,
213 oog_odds_games_id :: DefaultKey OddsGame }
215 -- | This is our best guess at what occurs in the Odds_XML
216 -- documents. It looks like each consecutive set of games can
217 -- optionally have some notes appear before it. Each "note" comes as
218 -- its own <Notes>...</Notes> element.
220 -- The notes are ignored completely in the database; we only bother
221 -- with them to ensure that we're (un)pickling correctly.
223 -- We can't group the notes with a "set" of 'OddsGame's, because that
224 -- leads to ambiguity in parsing. Since we're going to ignore the
225 -- notes anyway, we just stick them with an arbitrary game. C'est la
228 data OddsGameWithNotes =
231 game :: OddsGameXml }
234 -- | The XML representation of Odds.
237 xml_xml_file_id :: Int,
238 xml_heading :: String,
239 xml_category :: String,
242 xml_line_time :: String,
243 xml_games_with_notes :: [OddsGameWithNotes],
244 xml_time_stamp :: String }
247 -- | Pseudo-field that lets us get the 'OddsGame's out of
248 -- 'xml_games_with_notes'.
249 xml_games :: Message -> [OddsGameXml]
250 xml_games m = map game (xml_games_with_notes m)
253 instance FromXml Message where
254 type Db Message = Odds
256 -- We don't need the key argument (from_xml_fk) since the XML type
257 -- contains more information in this case.
258 from_xml (Message _ _ _ d e f _ _) =
261 instance XmlImport Message
265 -- * Groundhog database schema.
266 -- | This must come before the dbimport code.
268 mkPersist tsn_codegen_config [groundhog|
276 - name: unique_odds_casino
278 fields: [casino_client_id]
280 - entity: OddsGameTeam
281 dbName: odds_games_teams
285 - name: unique_odds_games_team
295 - name: unique_odds_game
299 - entity: OddsGameLine
300 dbName: odds_games_lines
302 - entity: Odds_OddsGame
303 dbName: odds__odds_games
305 - entity: OddsGame_OddsGameTeam
306 dbName: odds_games__odds_games_teams
309 instance DbImport Message where
312 migrate (undefined :: Odds)
313 migrate (undefined :: OddsCasino)
314 migrate (undefined :: OddsGameTeam)
315 migrate (undefined :: OddsGame)
316 migrate (undefined :: Odds_OddsGame)
317 migrate (undefined :: OddsGame_OddsGameTeam)
318 migrate (undefined :: OddsGameLine)
321 -- Insert the root "odds" element and acquire its primary key (id).
322 odds_id <- insert_xml m
324 -- Next, we insert the home and away teams. We do this before
325 -- inserting the game itself because the game has two foreign keys
326 -- pointing to odds_games_teams.
327 forM_ (xml_games m) $ \g -> do
328 game_id <- insert_xml_or_select g
329 -- Insert a record into odds__odds_game mapping this game
330 -- to its parent in the odds table.
331 insert_ (Odds_OddsGame odds_id game_id)
333 -- Next to insert the home and away teams.
334 away_team_id <- insert_xml_or_select (xml_game_away_team g)
335 home_team_id <- insert_xml_or_select (xml_game_home_team g)
337 -- Insert a record into odds_games__odds_games_teams
338 -- mapping the home/away teams to this game.
339 insert_ (OddsGame_OddsGameTeam game_id away_team_id home_team_id)
341 -- Finaly, we insert the lines. The over/under entries for this
342 -- game and the lines for the casinos all wind up in the same
343 -- table, odds_games_lines. We can insert the over/under entries
344 -- freely with empty away/home lines:
345 forM_ (xml_game_over_under_casinos g) $ \c -> do
346 -- Start by inderting the casino.
347 ou_casino_id <- insert_xml_or_select c
349 -- Now add the over/under entry with the casino's id.
350 let ogl = OddsGameLine
359 -- ...but then when we insert the home/away team lines, we
360 -- prefer to update the existing entry rather than overwrite it
361 -- or add a new record.
362 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do
363 -- insert, or more likely retrieve the existing, casino
364 a_casino_id <- insert_xml_or_select c
366 -- Unconditionally update that casino's away team line with ours.
367 update [Ogl_Away_Line =. (xml_casino_line c)] $ -- WHERE
368 Ogl_Odds_Casinos_Id ==. a_casino_id
370 -- Repeat all that for the home team.
371 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
372 h_casino_id <- insert_xml_or_select c
373 update [Ogl_Home_Line =. (xml_casino_line c)] $ -- WHERE
374 Ogl_Odds_Casinos_Id ==. h_casino_id
378 return ImportSucceeded
380 pickle_game_with_notes :: PU OddsGameWithNotes
381 pickle_game_with_notes =
382 xpWrap (from_pair, to_pair) $
384 (xpList $ xpElem "Notes" xpText)
387 from_pair = uncurry OddsGameWithNotes
388 to_pair OddsGameWithNotes{..} = (notes, game)
392 pickle_casino :: PU OddsGameCasinoXml
395 xpWrap (from_tuple, to_tuple) $
397 (xpAttr "ClientID" xpInt)
398 (xpAttr "Name" xpText)
399 (xpOption xpPrim) -- Double
401 from_tuple = uncurryN OddsGameCasinoXml
402 -- Use record wildcards to avoid unused field warnings.
403 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
407 instance XmlPickler OddsGameCasinoXml where
408 xpickle = pickle_casino
411 pickle_home_team :: PU OddsGameHomeTeamXml
414 xpWrap (from_tuple, to_tuple) $
416 (xpElem "HomeTeamID" xpInt)
417 (xpElem "HomeRotationNumber" xpInt)
418 (xpElem "HomeAbbr" xpText)
419 (xpElem "HomeTeamName" xpText)
420 (xpList pickle_casino)
422 from_tuple = uncurryN OddsGameHomeTeamXml
423 -- Use record wildcards to avoid unused field warnings.
424 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
425 xml_home_rotation_number,
430 instance XmlPickler OddsGameHomeTeamXml where
431 xpickle = pickle_home_team
434 pickle_away_team :: PU OddsGameAwayTeamXml
437 xpWrap (from_tuple, to_tuple) $
439 (xpElem "AwayTeamID" xpInt)
440 (xpElem "AwayRotationNumber" xpInt)
441 (xpElem "AwayAbbr" xpText)
442 (xpElem "AwayTeamName" xpText)
443 (xpList pickle_casino)
445 from_tuple = uncurryN OddsGameAwayTeamXml
446 -- Use record wildcards to avoid unused field warnings.
447 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
448 xml_away_rotation_number,
454 instance XmlPickler OddsGameAwayTeamXml where
455 xpickle = pickle_away_team
458 pickle_over_under :: PU OddsGameOverUnderXml
460 xpElem "Over_Under" $
461 xpWrap (to_newtype, from_newtype) $
464 from_newtype (OddsGameOverUnderXml cs) = cs
465 to_newtype = OddsGameOverUnderXml
467 instance XmlPickler OddsGameOverUnderXml where
468 xpickle = pickle_over_under
471 pickle_game :: PU OddsGameXml
474 xpWrap (from_tuple, to_tuple) $
476 (xpElem "GameID" xpInt)
477 (xpElem "Game_Date" xpText)
478 (xpElem "Game_Time" xpText)
483 from_tuple = uncurryN OddsGameXml
484 -- Use record wildcards to avoid unused field warnings.
485 to_tuple OddsGameXml{..} = (xml_game_id,
492 instance XmlPickler OddsGameXml where
493 xpickle = pickle_game
496 pickle_message :: PU Message
499 xpWrap (from_tuple, to_tuple) $
500 xp8Tuple (xpElem "XML_File_ID" xpInt)
501 (xpElem "heading" xpText)
502 (xpElem "category" xpText)
503 (xpElem "sport" xpText)
504 (xpElem "Title" xpText)
505 (xpElem "Line_Time" xpText)
506 (xpList pickle_game_with_notes)
507 (xpElem "time_stamp" xpText)
509 from_tuple = uncurryN Message
510 to_tuple m = (xml_xml_file_id m,
516 xml_games_with_notes m,
520 instance XmlPickler Message where
521 xpickle = pickle_message
527 odds_tests :: TestTree
531 [ test_pickle_of_unpickle_is_identity,
532 test_unpickle_succeeds ]
535 -- | Warning, succeess of this test does not mean that unpickling
537 test_pickle_of_unpickle_is_identity :: TestTree
538 test_pickle_of_unpickle_is_identity =
539 testCase "pickle composed with unpickle is the identity" $ do
540 let path = "test/xml/Odds_XML.xml"
541 (expected, actual) <- pickle_unpickle pickle_message path
545 test_unpickle_succeeds :: TestTree
546 test_unpickle_succeeds =
547 testCase "unpickling succeeds" $ do
548 let path = "test/xml/Odds_XML.xml"
549 actual <- unpickleable path pickle_message