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(..), 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 FromXml OddsGameCasinoXml where
106 -- | The database representation of an 'OddsGameCasinoXml' is an
109 type Db OddsGameCasinoXml = OddsCasino
111 -- | We convert from XML to the database by dropping the line field.
112 from_xml OddsGameCasinoXml{..} =
114 casino_client_id = xml_casino_client_id,
115 casino_name = xml_casino_name }
117 -- | This allows us to call 'insert_xml' on an 'OddsGameCasinoXml'
118 -- without first converting it to the database representation.
119 instance XmlImport OddsGameCasinoXml
122 -- | The database representation of teams as they appear in odds
127 db_team_id :: String, -- ^ The home/away team IDs are
128 -- three characters but Postgres
129 -- imposes no performance penalty
130 -- on lengthless text fields, so
131 -- we ignore the probable upper
132 -- bound of three characters.
134 db_team_name :: String }
138 -- | The XML representation of a \<HomeTeam\>, as found in \<Game\>s.
140 data OddsGameHomeTeamXml =
141 OddsGameHomeTeamXml {
142 xml_home_team_id :: String, -- ^ The home/away team IDs
143 -- are three characters but
144 -- Postgres imposes no
145 -- performance penalty on
146 -- lengthless text fields,
147 -- so we ignore the probable
148 -- upper bound of three
150 xml_home_rotation_number :: Int,
151 xml_home_abbr :: String,
152 xml_home_team_name :: String,
153 xml_home_casinos :: [OddsGameCasinoXml] }
156 instance FromXml OddsGameHomeTeamXml where
157 -- | The database representation of an 'OddsGameHomeTeamXml' is an
160 type Db OddsGameHomeTeamXml = OddsGameTeam
162 -- | We convert from XML to the database by dropping the lines and
163 -- rotation number (which are specific to the games, not the teams
166 from_xml OddsGameHomeTeamXml{..} =
168 db_team_id = xml_home_team_id,
169 db_abbr = xml_home_abbr,
170 db_team_name = xml_home_team_name }
172 -- | XmlImport allows us to call 'insert_xml' directly on an
173 -- 'OddsGameHomeTeamXml' without explicitly converting it to the
174 -- associated database type.
176 instance XmlImport OddsGameHomeTeamXml where
179 -- | The XML representation of a \<AwayTeam\>, as found in \<Game\>s.
181 data OddsGameAwayTeamXml =
182 OddsGameAwayTeamXml {
183 xml_away_team_id :: String, -- ^ The home/away team IDs are
184 -- three characters but Postgres
185 -- imposes no performance penalty
186 -- on lengthless text fields, so
187 -- we ignore the probable upper
188 -- bound of three characters
189 xml_away_rotation_number :: Int,
190 xml_away_abbr :: String,
191 xml_away_team_name :: String,
192 xml_away_casinos :: [OddsGameCasinoXml] }
195 instance FromXml OddsGameAwayTeamXml where
196 -- | The database representation of an 'OddsGameAwayTeamXml' is an
199 type Db OddsGameAwayTeamXml = OddsGameTeam
201 -- | We convert from XML to the database by dropping the lines and
202 -- rotation number (which are specific to the games, not the teams
205 from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
210 -- | XmlImport allows us to call 'insert_xml' directly on an
211 -- 'OddsGameAwayTeamXml' without explicitly converting it to the
212 -- associated database type.
214 instance XmlImport OddsGameAwayTeamXml where
217 -- | Database mapping between games and their home/away teams.
218 data OddsGame_OddsGameTeam =
219 OddsGame_OddsGameTeam {
220 ogogt_odds_games_id :: DefaultKey OddsGame,
221 ogogt_away_team_id :: DefaultKey OddsGameTeam,
222 ogogt_home_team_id :: DefaultKey OddsGameTeam }
225 -- | XML representation of the over/under. A wrapper around a bunch of
228 newtype OddsGameOverUnderXml =
229 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
233 -- | This database representation of the casino lines can't be
234 -- constructed from the one in the XML. The casinos within
235 -- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or
236 -- less the same. We don't need a bajillion different tables to
237 -- store that, just one tying the casino/game pair to the three
240 -- The one small difference between the over/under casinos and the
241 -- home/away ones is that the home/away lines are all 'Double's, but
242 -- the over/under lines appear to be textual.
246 ogl_odds_games_id :: DefaultKey OddsGame,
247 ogl_odds_casinos_id :: DefaultKey OddsCasino,
248 ogl_over_under :: Maybe String,
249 ogl_away_line :: Maybe Double,
250 ogl_home_line :: Maybe Double }
253 -- | Database representation of a game. We retain the rotation number
254 -- of the home/away teams, since those are specific to the game and
260 db_game_time :: UTCTime, -- ^ Contains both the date and time.
261 db_game_away_team_rotation_number :: Int,
262 db_game_home_team_rotation_number :: Int }
265 -- | XML representation of a game.
270 xml_game_date :: UTCTime, -- ^ Contains only the date
271 xml_game_time :: UTCTime, -- ^ Contains only the time
272 xml_game_away_team :: OddsGameAwayTeamXml,
273 xml_game_home_team :: OddsGameHomeTeamXml,
274 xml_game_over_under :: OddsGameOverUnderXml }
277 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
278 -- xml_game_over_under.
280 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
281 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
284 instance FromXml OddsGameXml where
285 -- | The database representation of an 'OddsGameXml' is an
288 type Db OddsGameXml = OddsGame
290 -- | To convert from the XML representation to the database one, we
291 -- drop the home/away teams and the casino lines, but retain the
292 -- home/away rotation numbers.
294 from_xml OddsGameXml{..} =
296 db_game_id = xml_game_id,
298 db_game_time = UTCTime
299 (utctDay xml_game_date) -- Take the day part from one,
300 (utctDayTime xml_game_time), -- the time from the other.
302 db_game_away_team_rotation_number =
303 (xml_away_rotation_number xml_game_away_team),
305 db_game_home_team_rotation_number =
306 (xml_home_rotation_number xml_game_home_team) }
308 -- | This lets us call 'insert_xml' directly on an 'OddsGameXml'
309 -- without converting it to the database representation explicitly.
311 instance XmlImport OddsGameXml
314 -- | Database and representation of the top-level Odds object (a
320 db_line_time :: String -- ^ We don't parse these as a 'UTCTime'
321 -- because their timezones are ambiguous
322 -- (and the date is less than useful when
323 -- it might be off by an hour).
327 -- | Map 'Odds' to their children 'OddsGame's.
329 data Odds_OddsGame = Odds_OddsGame
331 (DefaultKey OddsGame)
334 -- | This is our best guess at what occurs in the Odds_XML
335 -- documents. It looks like each consecutive set of games can
336 -- optionally have some notes appear before it. Each "note" comes as
337 -- its own <Notes>...</Notes> element.
339 -- The notes are ignored completely in the database; we only bother
340 -- with them to ensure that we're (un)pickling correctly.
342 -- We can't group the notes with a "set" of 'OddsGame's, because that
343 -- leads to ambiguity in parsing. Since we're going to ignore the
344 -- notes anyway, we just stick them with an arbitrary game. C'est la
347 data OddsGameWithNotes =
350 game :: OddsGameXml }
353 -- | The XML representation of 'Odds'.
356 xml_xml_file_id :: Int,
357 xml_heading :: String,
358 xml_category :: String,
361 xml_line_time :: String,
362 xml_games_with_notes :: [OddsGameWithNotes],
363 xml_time_stamp :: String }
366 -- | Pseudo-field that lets us get the 'OddsGame's out of
367 -- 'xml_games_with_notes'.
369 xml_games :: Message -> [OddsGameXml]
370 xml_games m = map game (xml_games_with_notes m)
373 instance FromXml Message where
374 -- | The database representation of a 'Message' is 'Odds'.
376 type Db Message = Odds
378 -- | To convert from the XML representation to the database one, we
379 -- just drop a bunch of fields.
381 from_xml Message{..} =
383 db_sport = xml_sport,
384 db_title = xml_title,
385 db_line_time = xml_line_time }
387 -- | This lets us call 'insert_xml' on a Message directly, without
388 -- having to convert it to its database representation explicitly.
390 instance XmlImport Message
394 -- Groundhog database schema. This must come before the DbImport
395 -- instance definition.
396 mkPersist tsn_codegen_config [groundhog|
404 - name: unique_odds_casino
406 fields: [casino_client_id]
408 - entity: OddsGameTeam
409 dbName: odds_games_teams
413 - name: unique_odds_games_team
423 - name: unique_odds_game
427 - entity: OddsGameLine
428 dbName: odds_games_lines
430 - entity: Odds_OddsGame
431 dbName: odds__odds_games
433 - name: Odds_OddsGame
435 - name: odds_OddsGame0 # Default created by mkNormalFieldName
439 - name: odds_OddsGame1 # Default created by mkNormalFieldName
440 dbName: odds_games_id
444 - entity: OddsGame_OddsGameTeam
445 dbName: odds_games__odds_games_teams
447 - name: OddsGame_OddsGameTeam
449 - name: ogogt_odds_games_id
452 - name: ogogt_away_team_id
455 - name: ogogt_home_team_id
460 instance DbImport Message where
463 migrate (undefined :: Odds)
464 migrate (undefined :: OddsCasino)
465 migrate (undefined :: OddsGameTeam)
466 migrate (undefined :: OddsGame)
467 migrate (undefined :: Odds_OddsGame)
468 migrate (undefined :: OddsGame_OddsGameTeam)
469 migrate (undefined :: OddsGameLine)
472 -- Insert the root "odds" element and acquire its primary key (id).
473 odds_id <- insert_xml m
475 -- Next, we insert the home and away teams. We do this before
476 -- inserting the game itself because the game has two foreign keys
477 -- pointing to odds_games_teams.
478 forM_ (xml_games m) $ \g -> do
479 game_id <- insert_xml_or_select g
480 -- Insert a record into odds__odds_game mapping this game
481 -- to its parent in the odds table.
482 insert_ (Odds_OddsGame odds_id game_id)
484 -- Next to insert the home and away teams.
485 away_team_id <- insert_xml_or_select (xml_game_away_team g)
486 home_team_id <- insert_xml_or_select (xml_game_home_team g)
488 -- Insert a record into odds_games__odds_games_teams mapping the
489 -- home/away teams to this game. Use the full record syntax
490 -- because the types would let us mix up the home/away teams.
491 insert_ OddsGame_OddsGameTeam {
492 ogogt_odds_games_id = game_id,
493 ogogt_away_team_id = away_team_id,
494 ogogt_home_team_id = home_team_id }
496 -- Finaly, we insert the lines. The over/under entries for this
497 -- game and the lines for the casinos all wind up in the same
498 -- table, odds_games_lines. We can insert the over/under entries
499 -- freely with empty away/home lines:
500 forM_ (xml_game_over_under_casinos g) $ \c -> do
501 -- Start by inderting the casino.
502 ou_casino_id <- insert_xml_or_select c
504 -- Now add the over/under entry with the casino's id.
505 let ogl = OddsGameLine {
506 ogl_odds_games_id = game_id,
507 ogl_odds_casinos_id = ou_casino_id,
508 ogl_over_under = (xml_casino_line c),
509 ogl_away_line = Nothing,
510 ogl_home_line = Nothing }
514 -- ...but then when we insert the home/away team lines, we
515 -- prefer to update the existing entry rather than overwrite it
516 -- or add a new record.
517 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do
518 -- insert, or more likely retrieve the existing, casino
519 a_casino_id <- insert_xml_or_select c
521 -- Get a Maybe Double instead of the Maybe String that's in there.
522 let away_line = home_away_line c
524 -- Unconditionally update that casino's away team line with ours.
525 update [Ogl_Away_Line =. away_line] $ -- WHERE
526 Ogl_Odds_Casinos_Id ==. a_casino_id
528 -- Repeat all that for the home team.
529 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
530 h_casino_id <- insert_xml_or_select c
531 let home_line = home_away_line c
532 update [Ogl_Home_Line =. home_line] $ -- WHERE
533 Ogl_Odds_Casinos_Id ==. h_casino_id
537 return ImportSucceeded
539 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
541 pickle_game_with_notes :: PU OddsGameWithNotes
542 pickle_game_with_notes =
543 xpWrap (from_pair, to_pair) $
545 (xpList $ xpElem "Notes" xpText)
548 from_pair = uncurry OddsGameWithNotes
549 to_pair OddsGameWithNotes{..} = (notes, game)
552 -- | Pickler for an 'OddsGameCasinoXml'.
554 pickle_casino :: PU OddsGameCasinoXml
557 xpWrap (from_tuple, to_tuple) $
559 (xpAttr "ClientID" xpInt)
560 (xpAttr "Name" xpText)
563 from_tuple = uncurryN OddsGameCasinoXml
564 -- Use record wildcards to avoid unused field warnings.
565 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
570 -- | Pickler for an 'OddsGameHomeTeamXml'.
572 pickle_home_team :: PU OddsGameHomeTeamXml
575 xpWrap (from_tuple, to_tuple) $
577 (xpElem "HomeTeamID" xpText)
578 (xpElem "HomeRotationNumber" xpInt)
579 (xpElem "HomeAbbr" xpText)
580 (xpElem "HomeTeamName" xpText)
581 (xpList pickle_casino)
583 from_tuple = uncurryN OddsGameHomeTeamXml
584 -- Use record wildcards to avoid unused field warnings.
585 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
586 xml_home_rotation_number,
592 -- | Pickler for an 'OddsGameAwayTeamXml'.
594 pickle_away_team :: PU OddsGameAwayTeamXml
597 xpWrap (from_tuple, to_tuple) $
599 (xpElem "AwayTeamID" xpText)
600 (xpElem "AwayRotationNumber" xpInt)
601 (xpElem "AwayAbbr" xpText)
602 (xpElem "AwayTeamName" xpText)
603 (xpList pickle_casino)
605 from_tuple = uncurryN OddsGameAwayTeamXml
606 -- Use record wildcards to avoid unused field warnings.
607 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
608 xml_away_rotation_number,
615 -- | Pickler for an 'OddsGameOverUnderXml'.
617 pickle_over_under :: PU OddsGameOverUnderXml
619 xpElem "Over_Under" $
620 xpWrap (to_newtype, from_newtype) $
623 from_newtype (OddsGameOverUnderXml cs) = cs
624 to_newtype = OddsGameOverUnderXml
627 -- | Pickler for an 'OddsGameXml'.
629 pickle_game :: PU OddsGameXml
632 xpWrap (from_tuple, to_tuple) $
634 (xpElem "GameID" xpInt)
635 (xpElem "Game_Date" xp_date)
636 (xpElem "Game_Time" xp_time)
641 from_tuple = uncurryN OddsGameXml
642 -- Use record wildcards to avoid unused field warnings.
643 to_tuple OddsGameXml{..} = (xml_game_id,
651 -- | Pickler for the top-level 'Message'.
653 pickle_message :: PU Message
656 xpWrap (from_tuple, to_tuple) $
657 xp8Tuple (xpElem "XML_File_ID" xpInt)
658 (xpElem "heading" xpText)
659 (xpElem "category" xpText)
660 (xpElem "sport" xpText)
661 (xpElem "Title" xpText)
662 (xpElem "Line_Time" xpText)
663 (xpList pickle_game_with_notes)
664 (xpElem "time_stamp" xpText)
666 from_tuple = uncurryN Message
667 to_tuple m = (xml_xml_file_id m,
673 xml_games_with_notes m,
681 -- | A list of all tests for this module.
683 odds_tests :: TestTree
687 [ test_pickle_of_unpickle_is_identity,
688 test_unpickle_succeeds ]
691 -- | If we unpickle something and then pickle it, we should wind up
692 -- with the same thing we started with. WARNING: success of this
693 -- test does not mean that unpickling succeeded.
695 test_pickle_of_unpickle_is_identity :: TestTree
696 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
697 [ check "pickle composed with unpickle is the identity"
698 "test/xml/Odds_XML.xml",
700 check "pickle composed with unpickle is the identity (non-int team_id)"
701 "test/xml/Odds_XML-noninteger-team-id.xml",
703 check "pickle composed with unpickle is the identity (positive(+) line)"
704 "test/xml/Odds_XML-positive-line.xml",
706 check "pickle composed with unpickle is the identity (large file)"
707 "test/xml/Odds_XML-largefile.xml" ]
709 check desc path = testCase desc $ do
710 (expected, actual) <- pickle_unpickle pickle_message path
714 -- | Make sure we can actually unpickle these things.
716 test_unpickle_succeeds :: TestTree
717 test_unpickle_succeeds = testGroup "unpickle tests"
718 [ check "unpickling succeeds"
719 "test/xml/Odds_XML.xml",
721 check "unpickling succeeds (non-int team_id)"
722 "test/xml/Odds_XML-noninteger-team-id.xml",
724 check "unpickling succeeds (positive(+) line)"
725 "test/xml/Odds_XML-positive-line.xml",
727 check "unpickling succeeds (large file)"
728 "test/xml/Odds_XML-largefile.xml" ]
730 check desc path = testCase desc $ do
731 actual <- unpickleable path pickle_message