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
19 import Control.Monad ( forM_, join )
20 import Data.Tuple.Curry ( uncurryN )
21 import Database.Groundhog (
28 import Database.Groundhog.Core ( DefaultKey )
29 import Database.Groundhog.TH (
32 import Test.Tasty ( TestTree, testGroup )
33 import Test.Tasty.HUnit ( (@?=), testCase )
34 import Text.Read ( readMaybe )
35 import Text.XML.HXT.Core (
53 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
54 import TSN.Picklers ( xp_team_id )
55 import TSN.XmlImport ( XmlImport(..) )
56 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
60 -- | The home/away lines are 'Double's, but the over/under lines are
61 -- textual. If we want to use one data type for both, we have to go
62 -- with a String and then attempt to 'read' a 'Double' later when we
63 -- go to insert the thing.
65 data OddsGameCasinoXml =
67 xml_casino_client_id :: Int,
68 xml_casino_name :: String,
69 xml_casino_line :: Maybe String }
73 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
74 -- priori textual (because it might be an over/under line).
76 home_away_line :: OddsGameCasinoXml -> Maybe Double
77 home_away_line = join . (fmap readMaybe) . xml_casino_line
79 -- | The casinos should have their own table, but the lines don't
80 -- belong in that table. (There should be another table joining the
81 -- casinos and the thing the lines are for together.)
83 -- We drop the 'Game' prefix because the Casinos really aren't
84 -- children of the games; the XML just makes it seem that way.
88 casino_client_id :: Int,
89 casino_name :: String }
92 instance FromXml OddsGameCasinoXml where
93 type Db OddsGameCasinoXml = OddsCasino
95 -- We don't need the key argument (from_xml_fk) since the XML type
96 -- contains more information in this case.
97 from_xml OddsGameCasinoXml{..} = OddsCasino
101 instance XmlImport OddsGameCasinoXml
104 data OddsGameHomeTeamXml =
105 OddsGameHomeTeamXml {
106 xml_home_team_id :: String, -- ^ These are three-character IDs.
107 xml_home_rotation_number :: Int,
108 xml_home_abbr :: String,
109 xml_home_team_name :: String,
110 xml_home_casinos :: [OddsGameCasinoXml] }
113 instance FromXml OddsGameHomeTeamXml where
114 type Db OddsGameHomeTeamXml = OddsGameTeam
115 from_xml OddsGameHomeTeamXml{..} = OddsGameTeam
120 instance XmlImport OddsGameHomeTeamXml where
125 db_team_id :: String, -- ^ The home/away team IDs are 3 characters
127 db_team_name :: String }
131 -- | Database mapping between games and their home/away teams.
132 data OddsGame_OddsGameTeam =
133 OddsGame_OddsGameTeam {
134 ogogt_odds_games_id :: DefaultKey OddsGame,
135 ogogt_away_team_id :: DefaultKey OddsGameTeam,
136 ogogt_home_team_id :: DefaultKey OddsGameTeam }
138 data OddsGameAwayTeamXml =
139 OddsGameAwayTeamXml {
140 xml_away_team_id :: String, -- ^ These are 3 character IDs.
141 xml_away_rotation_number :: Int,
142 xml_away_abbr :: String,
143 xml_away_team_name :: String,
144 xml_away_casinos :: [OddsGameCasinoXml] }
147 instance FromXml OddsGameAwayTeamXml where
148 type Db OddsGameAwayTeamXml = OddsGameTeam
149 from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
154 instance XmlImport OddsGameAwayTeamXml where
156 -- | Can't use a newtype with Groundhog.
157 newtype OddsGameOverUnderXml =
158 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
161 -- | This database representation of the casino lines can't be
162 -- constructed from the one in the XML. The casinos within
163 -- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or
164 -- less the same. We don't need a bajillion different tables to
165 -- store that, just one tying the casino/game pair to the three
168 -- The one small difference between the over/under casinos and the
169 -- home/away ones is that the home/away lines are all 'Double's, but
170 -- the over/under lines appear to be textual.
174 ogl_odds_games_id :: DefaultKey OddsGame,
175 ogl_odds_casinos_id :: DefaultKey OddsCasino,
176 ogl_over_under :: Maybe String,
177 ogl_away_line :: Maybe Double,
178 ogl_home_line :: Maybe Double }
183 db_game_date :: String, -- TODO
184 db_game_time :: String, -- TODO
185 db_game_away_team_rotation_number :: Int,
186 db_game_home_team_rotation_number :: Int }
187 deriving instance Eq OddsGame
188 deriving instance Show OddsGame
193 xml_game_date :: String, -- TODO
194 xml_game_time :: String, -- TODO
195 xml_game_away_team :: OddsGameAwayTeamXml,
196 xml_game_home_team :: OddsGameHomeTeamXml,
197 xml_game_over_under :: OddsGameOverUnderXml }
200 -- | Pseudo-field that lets us get the 'OddsCasino's out of
201 -- xml_game_over_under.
202 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
203 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
206 instance FromXml OddsGameXml where
207 type Db OddsGameXml = OddsGame
208 from_xml OddsGameXml{..} = OddsGame
212 (xml_away_rotation_number xml_game_away_team)
213 (xml_home_rotation_number xml_game_home_team)
215 instance XmlImport OddsGameXml
223 db_line_time :: String }
226 -- | Map 'Odds' to their children 'OddsGame's.
229 oog_odds_id :: DefaultKey Odds,
230 oog_odds_games_id :: DefaultKey OddsGame }
232 -- | This is our best guess at what occurs in the Odds_XML
233 -- documents. It looks like each consecutive set of games can
234 -- optionally have some notes appear before it. Each "note" comes as
235 -- its own <Notes>...</Notes> element.
237 -- The notes are ignored completely in the database; we only bother
238 -- with them to ensure that we're (un)pickling correctly.
240 -- We can't group the notes with a "set" of 'OddsGame's, because that
241 -- leads to ambiguity in parsing. Since we're going to ignore the
242 -- notes anyway, we just stick them with an arbitrary game. C'est la
245 data OddsGameWithNotes =
248 game :: OddsGameXml }
251 -- | The XML representation of Odds.
254 xml_xml_file_id :: Int,
255 xml_heading :: String,
256 xml_category :: String,
259 xml_line_time :: String,
260 xml_games_with_notes :: [OddsGameWithNotes],
261 xml_time_stamp :: String }
264 -- | Pseudo-field that lets us get the 'OddsGame's out of
265 -- 'xml_games_with_notes'.
266 xml_games :: Message -> [OddsGameXml]
267 xml_games m = map game (xml_games_with_notes m)
270 instance FromXml Message where
271 type Db Message = Odds
273 -- We don't need the key argument (from_xml_fk) since the XML type
274 -- contains more information in this case.
275 from_xml (Message _ _ _ d e f _ _) =
278 instance XmlImport Message
282 -- * Groundhog database schema.
283 -- | This must come before the dbimport code.
285 mkPersist tsn_codegen_config [groundhog|
293 - name: unique_odds_casino
295 fields: [casino_client_id]
297 - entity: OddsGameTeam
298 dbName: odds_games_teams
305 - name: unique_odds_games_team
315 - name: unique_odds_game
319 - entity: OddsGameLine
320 dbName: odds_games_lines
322 - entity: Odds_OddsGame
323 dbName: odds__odds_games
325 - entity: OddsGame_OddsGameTeam
326 dbName: odds_games__odds_games_teams
329 instance DbImport Message where
332 migrate (undefined :: Odds)
333 migrate (undefined :: OddsCasino)
334 migrate (undefined :: OddsGameTeam)
335 migrate (undefined :: OddsGame)
336 migrate (undefined :: Odds_OddsGame)
337 migrate (undefined :: OddsGame_OddsGameTeam)
338 migrate (undefined :: OddsGameLine)
341 -- Insert the root "odds" element and acquire its primary key (id).
342 odds_id <- insert_xml m
344 -- Next, we insert the home and away teams. We do this before
345 -- inserting the game itself because the game has two foreign keys
346 -- pointing to odds_games_teams.
347 forM_ (xml_games m) $ \g -> do
348 game_id <- insert_xml_or_select g
349 -- Insert a record into odds__odds_game mapping this game
350 -- to its parent in the odds table.
351 insert_ (Odds_OddsGame odds_id game_id)
353 -- Next to insert the home and away teams.
354 away_team_id <- insert_xml_or_select (xml_game_away_team g)
355 home_team_id <- insert_xml_or_select (xml_game_home_team g)
357 -- Insert a record into odds_games__odds_games_teams
358 -- mapping the home/away teams to this game.
359 insert_ (OddsGame_OddsGameTeam game_id away_team_id home_team_id)
361 -- Finaly, we insert the lines. The over/under entries for this
362 -- game and the lines for the casinos all wind up in the same
363 -- table, odds_games_lines. We can insert the over/under entries
364 -- freely with empty away/home lines:
365 forM_ (xml_game_over_under_casinos g) $ \c -> do
366 -- Start by inderting the casino.
367 ou_casino_id <- insert_xml_or_select c
369 -- Now add the over/under entry with the casino's id.
370 let ogl = OddsGameLine
379 -- ...but then when we insert the home/away team lines, we
380 -- prefer to update the existing entry rather than overwrite it
381 -- or add a new record.
382 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do
383 -- insert, or more likely retrieve the existing, casino
384 a_casino_id <- insert_xml_or_select c
386 -- Get a Maybe Double instead of the Maybe String that's in there.
387 let away_line = home_away_line c
389 -- Unconditionally update that casino's away team line with ours.
390 update [Ogl_Away_Line =. away_line] $ -- WHERE
391 Ogl_Odds_Casinos_Id ==. a_casino_id
393 -- Repeat all that for the home team.
394 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
395 h_casino_id <- insert_xml_or_select c
396 let home_line = home_away_line c
397 update [Ogl_Home_Line =. home_line] $ -- WHERE
398 Ogl_Odds_Casinos_Id ==. h_casino_id
402 return ImportSucceeded
404 pickle_game_with_notes :: PU OddsGameWithNotes
405 pickle_game_with_notes =
406 xpWrap (from_pair, to_pair) $
408 (xpList $ xpElem "Notes" xpText)
411 from_pair = uncurry OddsGameWithNotes
412 to_pair OddsGameWithNotes{..} = (notes, game)
416 pickle_casino :: PU OddsGameCasinoXml
419 xpWrap (from_tuple, to_tuple) $
421 (xpAttr "ClientID" xpInt)
422 (xpAttr "Name" xpText)
425 from_tuple = uncurryN OddsGameCasinoXml
426 -- Use record wildcards to avoid unused field warnings.
427 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
432 pickle_home_team :: PU OddsGameHomeTeamXml
435 xpWrap (from_tuple, to_tuple) $
437 (xpElem "HomeTeamID" xp_team_id)
438 (xpElem "HomeRotationNumber" xpInt)
439 (xpElem "HomeAbbr" xpText)
440 (xpElem "HomeTeamName" xpText)
441 (xpList pickle_casino)
443 from_tuple = uncurryN OddsGameHomeTeamXml
444 -- Use record wildcards to avoid unused field warnings.
445 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
446 xml_home_rotation_number,
453 pickle_away_team :: PU OddsGameAwayTeamXml
456 xpWrap (from_tuple, to_tuple) $
458 (xpElem "AwayTeamID" xp_team_id)
459 (xpElem "AwayRotationNumber" xpInt)
460 (xpElem "AwayAbbr" xpText)
461 (xpElem "AwayTeamName" xpText)
462 (xpList pickle_casino)
464 from_tuple = uncurryN OddsGameAwayTeamXml
465 -- Use record wildcards to avoid unused field warnings.
466 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
467 xml_away_rotation_number,
474 pickle_over_under :: PU OddsGameOverUnderXml
476 xpElem "Over_Under" $
477 xpWrap (to_newtype, from_newtype) $
480 from_newtype (OddsGameOverUnderXml cs) = cs
481 to_newtype = OddsGameOverUnderXml
485 pickle_game :: PU OddsGameXml
488 xpWrap (from_tuple, to_tuple) $
490 (xpElem "GameID" xpInt)
491 (xpElem "Game_Date" xpText)
492 (xpElem "Game_Time" xpText)
497 from_tuple = uncurryN OddsGameXml
498 -- Use record wildcards to avoid unused field warnings.
499 to_tuple OddsGameXml{..} = (xml_game_id,
507 pickle_message :: PU Message
510 xpWrap (from_tuple, to_tuple) $
511 xp8Tuple (xpElem "XML_File_ID" xpInt)
512 (xpElem "heading" xpText)
513 (xpElem "category" xpText)
514 (xpElem "sport" xpText)
515 (xpElem "Title" xpText)
516 (xpElem "Line_Time" xpText)
517 (xpList pickle_game_with_notes)
518 (xpElem "time_stamp" xpText)
520 from_tuple = uncurryN Message
521 to_tuple m = (xml_xml_file_id m,
527 xml_games_with_notes m,
533 odds_tests :: TestTree
537 [ test_pickle_of_unpickle_is_identity,
538 test_unpickle_succeeds ]
541 -- | Warning, succeess of this test does not mean that unpickling
543 test_pickle_of_unpickle_is_identity :: TestTree
544 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
545 [ check "pickle composed with unpickle is the identity"
546 "test/xml/Odds_XML.xml",
548 check "pickle composed with unpickle is the identity (non-int team_id)"
549 "test/xml/Odds_XML-noninteger-team-id.xml",
551 check "pickle composed with unpickle is the identity (positive(+) line)"
552 "test/xml/Odds_XML-positive-line.xml" ]
554 check desc path = testCase desc $ do
555 (expected, actual) <- pickle_unpickle pickle_message path
559 test_unpickle_succeeds :: TestTree
560 test_unpickle_succeeds = testGroup "unpickle tests"
561 [ check "unpickling succeeds"
562 "test/xml/Odds_XML.xml",
564 check "unpickling succeeds (non-int team_id)"
565 "test/xml/Odds_XML-noninteger-team-id.xml",
567 check "unpickling succeeds (positive(+) line)"
568 "test/xml/Odds_XML-positive-line.xml" ]
570 check desc path = testCase desc $ do
571 actual <- unpickleable path pickle_message