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
18 -- * WARNING: these are private but exported to silence warnings
19 Odds_OddsGameConstructor(..),
20 OddsCasinoConstructor(..),
22 OddsGame_OddsGameTeamConstructor(..),
23 OddsGameConstructor(..),
24 OddsGameLineConstructor(..),
25 OddsGameTeamConstructor(..) )
29 import Control.Monad ( forM_, join )
30 import Data.Time ( UTCTime(..) )
31 import Data.Tuple.Curry ( uncurryN )
32 import Database.Groundhog (
39 import Database.Groundhog.Core ( DefaultKey )
40 import Database.Groundhog.TH (
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.Read ( readMaybe )
46 import Text.XML.HXT.Core (
64 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
65 import TSN.Picklers ( xp_date, xp_time )
66 import TSN.XmlImport ( XmlImport(..) )
67 import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
71 -- | The home/away lines are 'Double's, but the over/under lines are
72 -- textual. If we want to use one data type for both, we have to go
73 -- with a 'String' and then attempt to 'read' a 'Double' later when we
74 -- go to insert the thing.
76 data OddsGameCasinoXml =
78 xml_casino_client_id :: Int,
79 xml_casino_name :: String,
80 xml_casino_line :: Maybe String }
84 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
85 -- priori textual (because it might be an over/under line).
87 home_away_line :: OddsGameCasinoXml -> Maybe Double
88 home_away_line = join . (fmap readMaybe) . xml_casino_line
91 -- | The casinos should have their own table, but the lines don't
92 -- belong in that table (there should be another table joining the
93 -- casinos and the thing the lines are for together.)
95 -- We drop the 'Game' prefix because the Casinos really aren't
96 -- children of the games; the XML just makes it seem that way.
100 casino_client_id :: Int,
101 casino_name :: String }
105 instance ToDb OddsGameCasinoXml where
106 -- | The database representation of an 'OddsGameCasinoXml' is an
109 type Db OddsGameCasinoXml = OddsCasino
111 instance FromXml OddsGameCasinoXml where
112 -- | We convert from XML to the database by dropping the line field.
113 from_xml OddsGameCasinoXml{..} =
115 casino_client_id = xml_casino_client_id,
116 casino_name = xml_casino_name }
118 -- | This allows us to call 'insert_xml' on an 'OddsGameCasinoXml'
119 -- without first converting it to the database representation.
120 instance XmlImport OddsGameCasinoXml
123 -- | The database representation of teams as they appear in odds
128 db_team_id :: String, -- ^ The home/away team IDs are
129 -- three characters but Postgres
130 -- imposes no performance penalty
131 -- on lengthless text fields, so
132 -- we ignore the probable upper
133 -- bound of three characters.
135 db_team_name :: String }
139 -- | The XML representation of a \<HomeTeam\>, as found in \<Game\>s.
141 data OddsGameHomeTeamXml =
142 OddsGameHomeTeamXml {
143 xml_home_team_id :: String, -- ^ The home/away team IDs
144 -- are three characters but
145 -- Postgres imposes no
146 -- performance penalty on
147 -- lengthless text fields,
148 -- so we ignore the probable
149 -- upper bound of three
151 xml_home_rotation_number :: Int,
152 xml_home_abbr :: String,
153 xml_home_team_name :: String,
154 xml_home_casinos :: [OddsGameCasinoXml] }
157 instance ToDb OddsGameHomeTeamXml where
158 -- | The database representation of an 'OddsGameHomeTeamXml' is an
161 type Db OddsGameHomeTeamXml = OddsGameTeam
163 instance FromXml OddsGameHomeTeamXml where
164 -- | We convert from XML to the database by dropping the lines and
165 -- rotation number (which are specific to the games, not the teams
168 from_xml OddsGameHomeTeamXml{..} =
170 db_team_id = xml_home_team_id,
171 db_abbr = xml_home_abbr,
172 db_team_name = xml_home_team_name }
174 -- | XmlImport allows us to call 'insert_xml' directly on an
175 -- 'OddsGameHomeTeamXml' without explicitly converting it to the
176 -- associated database type.
178 instance XmlImport OddsGameHomeTeamXml where
181 -- | The XML representation of a \<AwayTeam\>, as found in \<Game\>s.
183 data OddsGameAwayTeamXml =
184 OddsGameAwayTeamXml {
185 xml_away_team_id :: String, -- ^ The home/away team IDs are
186 -- three characters but Postgres
187 -- imposes no performance penalty
188 -- on lengthless text fields, so
189 -- we ignore the probable upper
190 -- bound of three characters
191 xml_away_rotation_number :: Int,
192 xml_away_abbr :: String,
193 xml_away_team_name :: String,
194 xml_away_casinos :: [OddsGameCasinoXml] }
197 instance ToDb OddsGameAwayTeamXml where
198 -- | The database representation of an 'OddsGameAwayTeamXml' is an
201 type Db OddsGameAwayTeamXml = OddsGameTeam
203 instance FromXml OddsGameAwayTeamXml where
204 -- | We convert from XML to the database by dropping the lines and
205 -- rotation number (which are specific to the games, not the teams
208 from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
213 -- | XmlImport allows us to call 'insert_xml' directly on an
214 -- 'OddsGameAwayTeamXml' without explicitly converting it to the
215 -- associated database type.
217 instance XmlImport OddsGameAwayTeamXml where
220 -- | Database mapping between games and their home/away teams.
221 data OddsGame_OddsGameTeam =
222 OddsGame_OddsGameTeam {
223 ogogt_odds_games_id :: DefaultKey OddsGame,
224 ogogt_away_team_id :: DefaultKey OddsGameTeam,
225 ogogt_home_team_id :: DefaultKey OddsGameTeam }
228 -- | XML representation of the over/under. A wrapper around a bunch of
231 newtype OddsGameOverUnderXml =
232 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
236 -- | This database representation of the casino lines can't be
237 -- constructed from the one in the XML. The casinos within
238 -- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or
239 -- less the same. We don't need a bajillion different tables to
240 -- store that, just one tying the casino/game pair to the three
243 -- The one small difference between the over/under casinos and the
244 -- home/away ones is that the home/away lines are all 'Double's, but
245 -- the over/under lines appear to be textual.
249 ogl_odds_games_id :: DefaultKey OddsGame,
250 ogl_odds_casinos_id :: DefaultKey OddsCasino,
251 ogl_over_under :: Maybe String,
252 ogl_away_line :: Maybe Double,
253 ogl_home_line :: Maybe Double }
256 -- | Database representation of a game. We retain the rotation number
257 -- of the home/away teams, since those are specific to the game and
263 db_game_time :: UTCTime, -- ^ Contains both the date and time.
264 db_game_away_team_rotation_number :: Int,
265 db_game_home_team_rotation_number :: Int }
268 -- | XML representation of a game.
273 xml_game_date :: UTCTime, -- ^ Contains only the date
274 xml_game_time :: UTCTime, -- ^ Contains only the time
275 xml_game_away_team :: OddsGameAwayTeamXml,
276 xml_game_home_team :: OddsGameHomeTeamXml,
277 xml_game_over_under :: OddsGameOverUnderXml }
280 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
281 -- xml_game_over_under.
283 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
284 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
287 instance ToDb OddsGameXml where
288 -- | The database representation of an 'OddsGameXml' is an
291 type Db OddsGameXml = OddsGame
293 instance FromXml OddsGameXml where
294 -- | To convert from the XML representation to the database one, we
295 -- drop the home/away teams and the casino lines, but retain the
296 -- home/away rotation numbers.
298 from_xml OddsGameXml{..} =
300 db_game_id = xml_game_id,
302 db_game_time = UTCTime
303 (utctDay xml_game_date) -- Take the day part from one,
304 (utctDayTime xml_game_time), -- the time from the other.
306 db_game_away_team_rotation_number =
307 (xml_away_rotation_number xml_game_away_team),
309 db_game_home_team_rotation_number =
310 (xml_home_rotation_number xml_game_home_team) }
312 -- | This lets us call 'insert_xml' directly on an 'OddsGameXml'
313 -- without converting it to the database representation explicitly.
315 instance XmlImport OddsGameXml
318 -- | Database and representation of the top-level Odds object (a
324 db_line_time :: String -- ^ We don't parse these as a 'UTCTime'
325 -- because their timezones are ambiguous
326 -- (and the date is less than useful when
327 -- it might be off by an hour).
331 -- | Map 'Odds' to their children 'OddsGame's.
333 data Odds_OddsGame = Odds_OddsGame
335 (DefaultKey OddsGame)
338 -- | This is our best guess at what occurs in the Odds_XML
339 -- documents. It looks like each consecutive set of games can
340 -- optionally have some notes appear before it. Each "note" comes as
341 -- its own <Notes>...</Notes> element.
343 -- The notes are ignored completely in the database; we only bother
344 -- with them to ensure that we're (un)pickling correctly.
346 -- We can't group the notes with a "set" of 'OddsGame's, because that
347 -- leads to ambiguity in parsing. Since we're going to ignore the
348 -- notes anyway, we just stick them with an arbitrary game. C'est la
351 data OddsGameWithNotes =
354 game :: OddsGameXml }
357 -- | The XML representation of 'Odds'.
360 xml_xml_file_id :: Int,
361 xml_heading :: String,
362 xml_category :: String,
365 xml_line_time :: String,
366 xml_games_with_notes :: [OddsGameWithNotes],
367 xml_time_stamp :: String }
370 -- | Pseudo-field that lets us get the 'OddsGame's out of
371 -- 'xml_games_with_notes'.
373 xml_games :: Message -> [OddsGameXml]
374 xml_games m = map game (xml_games_with_notes m)
377 instance ToDb Message where
378 -- | The database representation of a 'Message' is 'Odds'.
380 type Db Message = Odds
382 instance FromXml Message where
383 -- | To convert from the XML representation to the database one, we
384 -- just drop a bunch of fields.
386 from_xml Message{..} =
388 db_sport = xml_sport,
389 db_title = xml_title,
390 db_line_time = xml_line_time }
392 -- | This lets us call 'insert_xml' on a Message directly, without
393 -- having to convert it to its database representation explicitly.
395 instance XmlImport Message
399 -- Groundhog database schema. This must come before the DbImport
400 -- instance definition.
401 mkPersist tsn_codegen_config [groundhog|
409 - name: unique_odds_casino
411 fields: [casino_client_id]
413 - entity: OddsGameTeam
414 dbName: odds_games_teams
418 - name: unique_odds_games_team
428 - name: unique_odds_game
432 - entity: OddsGameLine
433 dbName: odds_games_lines
435 - entity: Odds_OddsGame
436 dbName: odds__odds_games
438 - name: Odds_OddsGame
440 - name: odds_OddsGame0 # Default created by mkNormalFieldName
444 - name: odds_OddsGame1 # Default created by mkNormalFieldName
445 dbName: odds_games_id
449 - entity: OddsGame_OddsGameTeam
450 dbName: odds_games__odds_games_teams
452 - name: OddsGame_OddsGameTeam
454 - name: ogogt_odds_games_id
457 - name: ogogt_away_team_id
460 - name: ogogt_home_team_id
465 instance DbImport Message where
468 migrate (undefined :: Odds)
469 migrate (undefined :: OddsCasino)
470 migrate (undefined :: OddsGameTeam)
471 migrate (undefined :: OddsGame)
472 migrate (undefined :: Odds_OddsGame)
473 migrate (undefined :: OddsGame_OddsGameTeam)
474 migrate (undefined :: OddsGameLine)
477 -- Insert the root "odds" element and acquire its primary key (id).
478 odds_id <- insert_xml m
480 -- Next, we insert the home and away teams. We do this before
481 -- inserting the game itself because the game has two foreign keys
482 -- pointing to odds_games_teams.
483 forM_ (xml_games m) $ \g -> do
484 game_id <- insert_xml_or_select g
485 -- Insert a record into odds__odds_game mapping this game
486 -- to its parent in the odds table.
487 insert_ (Odds_OddsGame odds_id game_id)
489 -- Next to insert the home and away teams.
490 away_team_id <- insert_xml_or_select (xml_game_away_team g)
491 home_team_id <- insert_xml_or_select (xml_game_home_team g)
493 -- Insert a record into odds_games__odds_games_teams mapping the
494 -- home/away teams to this game. Use the full record syntax
495 -- because the types would let us mix up the home/away teams.
496 insert_ OddsGame_OddsGameTeam {
497 ogogt_odds_games_id = game_id,
498 ogogt_away_team_id = away_team_id,
499 ogogt_home_team_id = home_team_id }
501 -- Finaly, we insert the lines. The over/under entries for this
502 -- game and the lines for the casinos all wind up in the same
503 -- table, odds_games_lines. We can insert the over/under entries
504 -- freely with empty away/home lines:
505 forM_ (xml_game_over_under_casinos g) $ \c -> do
506 -- Start by inderting the casino.
507 ou_casino_id <- insert_xml_or_select c
509 -- Now add the over/under entry with the casino's id.
510 let ogl = OddsGameLine {
511 ogl_odds_games_id = game_id,
512 ogl_odds_casinos_id = ou_casino_id,
513 ogl_over_under = (xml_casino_line c),
514 ogl_away_line = Nothing,
515 ogl_home_line = Nothing }
519 -- ...but then when we insert the home/away team lines, we
520 -- prefer to update the existing entry rather than overwrite it
521 -- or add a new record.
522 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do
523 -- insert, or more likely retrieve the existing, casino
524 a_casino_id <- insert_xml_or_select c
526 -- Get a Maybe Double instead of the Maybe String that's in there.
527 let away_line = home_away_line c
529 -- Unconditionally update that casino's away team line with ours.
530 update [Ogl_Away_Line =. away_line] $ -- WHERE
531 Ogl_Odds_Casinos_Id ==. a_casino_id
533 -- Repeat all that for the home team.
534 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
535 h_casino_id <- insert_xml_or_select c
536 let home_line = home_away_line c
537 update [Ogl_Home_Line =. home_line] $ -- WHERE
538 Ogl_Odds_Casinos_Id ==. h_casino_id
542 return ImportSucceeded
544 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
546 pickle_game_with_notes :: PU OddsGameWithNotes
547 pickle_game_with_notes =
548 xpWrap (from_pair, to_pair) $
550 (xpList $ xpElem "Notes" xpText)
553 from_pair = uncurry OddsGameWithNotes
554 to_pair OddsGameWithNotes{..} = (notes, game)
557 -- | Pickler for an 'OddsGameCasinoXml'.
559 pickle_casino :: PU OddsGameCasinoXml
562 xpWrap (from_tuple, to_tuple) $
564 (xpAttr "ClientID" xpInt)
565 (xpAttr "Name" xpText)
568 from_tuple = uncurryN OddsGameCasinoXml
569 -- Use record wildcards to avoid unused field warnings.
570 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
575 -- | Pickler for an 'OddsGameHomeTeamXml'.
577 pickle_home_team :: PU OddsGameHomeTeamXml
580 xpWrap (from_tuple, to_tuple) $
582 (xpElem "HomeTeamID" xpText)
583 (xpElem "HomeRotationNumber" xpInt)
584 (xpElem "HomeAbbr" xpText)
585 (xpElem "HomeTeamName" xpText)
586 (xpList pickle_casino)
588 from_tuple = uncurryN OddsGameHomeTeamXml
589 -- Use record wildcards to avoid unused field warnings.
590 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
591 xml_home_rotation_number,
597 -- | Pickler for an 'OddsGameAwayTeamXml'.
599 pickle_away_team :: PU OddsGameAwayTeamXml
602 xpWrap (from_tuple, to_tuple) $
604 (xpElem "AwayTeamID" xpText)
605 (xpElem "AwayRotationNumber" xpInt)
606 (xpElem "AwayAbbr" xpText)
607 (xpElem "AwayTeamName" xpText)
608 (xpList pickle_casino)
610 from_tuple = uncurryN OddsGameAwayTeamXml
611 -- Use record wildcards to avoid unused field warnings.
612 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
613 xml_away_rotation_number,
620 -- | Pickler for an 'OddsGameOverUnderXml'.
622 pickle_over_under :: PU OddsGameOverUnderXml
624 xpElem "Over_Under" $
625 xpWrap (to_newtype, from_newtype) $
628 from_newtype (OddsGameOverUnderXml cs) = cs
629 to_newtype = OddsGameOverUnderXml
632 -- | Pickler for an 'OddsGameXml'.
634 pickle_game :: PU OddsGameXml
637 xpWrap (from_tuple, to_tuple) $
639 (xpElem "GameID" xpInt)
640 (xpElem "Game_Date" xp_date)
641 (xpElem "Game_Time" xp_time)
646 from_tuple = uncurryN OddsGameXml
647 -- Use record wildcards to avoid unused field warnings.
648 to_tuple OddsGameXml{..} = (xml_game_id,
656 -- | Pickler for the top-level 'Message'.
658 pickle_message :: PU Message
661 xpWrap (from_tuple, to_tuple) $
662 xp8Tuple (xpElem "XML_File_ID" xpInt)
663 (xpElem "heading" xpText)
664 (xpElem "category" xpText)
665 (xpElem "sport" xpText)
666 (xpElem "Title" xpText)
667 (xpElem "Line_Time" xpText)
668 (xpList pickle_game_with_notes)
669 (xpElem "time_stamp" xpText)
671 from_tuple = uncurryN Message
672 to_tuple m = (xml_xml_file_id m,
678 xml_games_with_notes m,
686 -- | A list of all tests for this module.
688 odds_tests :: TestTree
692 [ test_pickle_of_unpickle_is_identity,
693 test_unpickle_succeeds ]
696 -- | If we unpickle something and then pickle it, we should wind up
697 -- with the same thing we started with. WARNING: success of this
698 -- test does not mean that unpickling succeeded.
700 test_pickle_of_unpickle_is_identity :: TestTree
701 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
702 [ check "pickle composed with unpickle is the identity"
703 "test/xml/Odds_XML.xml",
705 check "pickle composed with unpickle is the identity (non-int team_id)"
706 "test/xml/Odds_XML-noninteger-team-id.xml",
708 check "pickle composed with unpickle is the identity (positive(+) line)"
709 "test/xml/Odds_XML-positive-line.xml",
711 check "pickle composed with unpickle is the identity (large file)"
712 "test/xml/Odds_XML-largefile.xml" ]
714 check desc path = testCase desc $ do
715 (expected, actual) <- pickle_unpickle pickle_message path
719 -- | Make sure we can actually unpickle these things.
721 test_unpickle_succeeds :: TestTree
722 test_unpickle_succeeds = testGroup "unpickle tests"
723 [ check "unpickling succeeds"
724 "test/xml/Odds_XML.xml",
726 check "unpickling succeeds (non-int team_id)"
727 "test/xml/Odds_XML-noninteger-team-id.xml",
729 check "unpickling succeeds (positive(+) line)"
730 "test/xml/Odds_XML-positive-line.xml",
732 check "unpickling succeeds (large file)"
733 "test/xml/Odds_XML-largefile.xml" ]
735 check desc path = testCase desc $ do
736 actual <- unpickleable path pickle_message