1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD \"Odds_XML.dtd\". Each document
10 -- contains a root element \<message\> that contains a bunch of
11 -- other... disorganized... information.
18 -- * WARNING: these are private but exported to silence warnings
19 OddsCasinoConstructor(..),
21 OddsGameConstructor(..),
22 OddsGameLineConstructor(..) )
26 import Control.Applicative ( (<$>) )
27 import Control.Monad ( forM_, join )
28 import Data.Time ( UTCTime(..) )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
38 silentMigrationLogger,
40 import Database.Groundhog.Core ( DefaultKey )
41 import Database.Groundhog.Generic ( runDbConn )
42 import Database.Groundhog.Sqlite ( withSqliteConn )
43 import Database.Groundhog.TH (
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.Read ( readMaybe )
49 import Text.XML.HXT.Core (
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
67 import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
68 import TSN.Team ( FromXmlFkTeams(..), Team(..) )
69 import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
79 -- | The DTD to which this module corresponds. Used to invoke dbimport.
89 -- * OddsGameCasino/OddsGameCasinoXml
92 -- | The casinos should have their own table, but the lines don't
93 -- belong in that table (there is a separate table for
94 -- 'OddsGameLine' which associates the two).
96 -- We drop the \"Game\" prefix because the casinos really aren't
97 -- children of the games; the XML just makes it seem that way.
101 casino_client_id :: Int,
102 casino_name :: String }
106 -- | The home/away lines are 'Double's, but the over/under lines are
107 -- textual. If we want to use one data type for both, we have to go
108 -- with a 'String' and then attempt to 'read' a 'Double' later when we
109 -- go to insert the thing.
111 data OddsGameCasinoXml =
113 xml_casino_client_id :: Int,
114 xml_casino_name :: String,
115 xml_casino_line :: Maybe String }
119 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
120 -- priori textual (because it might be an over/under line).
122 home_away_line :: OddsGameCasinoXml -> Maybe Double
123 home_away_line = join . (fmap readMaybe) . xml_casino_line
127 instance ToDb OddsGameCasinoXml where
128 -- | The database representation of an 'OddsGameCasinoXml' is an
131 type Db OddsGameCasinoXml = OddsCasino
134 instance FromXml OddsGameCasinoXml where
135 -- | We convert from XML to the database by dropping the line field.
137 from_xml OddsGameCasinoXml{..} =
139 casino_client_id = xml_casino_client_id,
140 casino_name = xml_casino_name }
143 -- | This allows us to insert the XML representation 'OddsGameCasinoXml'
146 instance XmlImport OddsGameCasinoXml
149 -- * OddsGameTeamXml / OddsGameTeamStarterXml
151 -- | The XML representation of a \"starter\". It contains both an ID
152 -- and a name. The ID does not appear to be optional, but the name
153 -- can be absent. When the name is absent, the ID has always been
154 -- set to \"0\". This occurs even though the entire starter element
155 -- is optional (see 'OddsGameTeamXml' below).
157 data OddsGameTeamStarterXml =
158 OddsGameTeamStarterXml {
159 xml_starter_id :: Int,
160 xml_starter_name :: Maybe String }
164 -- | The XML representation of a \<HomeTeam\> or \<AwayTeam\>, as
165 -- found in \<Game\>s. We can't use the 'Team' representation
166 -- directly because there are some other fields we need to parse.
168 data OddsGameTeamXml =
170 xml_team_id :: String, -- ^ The home/away team IDs
171 -- are three characters but
172 -- Postgres imposes no
173 -- performance penalty on
174 -- lengthless text fields,
175 -- so we ignore the probable
176 -- upper bound of three
178 xml_team_rotation_number :: Maybe Int,
179 xml_team_abbr :: String,
180 xml_team_name :: String,
181 xml_team_starter :: Maybe OddsGameTeamStarterXml,
182 xml_team_casinos :: [OddsGameCasinoXml] }
185 instance ToDb OddsGameTeamXml where
186 -- | The database representation of an 'OddsGameTeamXml' is an
189 type Db OddsGameTeamXml = Team
191 instance FromXml OddsGameTeamXml where
192 -- | We convert from XML to the database by dropping the lines and
193 -- rotation number (which are specific to the games, not the teams
196 from_xml OddsGameTeamXml{..} =
198 team_id = xml_team_id,
199 abbreviation = Just xml_team_abbr,
200 name = Just xml_team_name }
202 -- | This allows us to insert the XML representation
203 -- 'OddsGameTeamXml' directly.
205 instance XmlImport OddsGameTeamXml where
210 -- * OddsGameOverUnderXml
212 -- | XML representation of the over/under. A wrapper around a bunch of
215 newtype OddsGameOverUnderXml =
216 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
222 -- | This database representation of the casino lines can't be
223 -- constructed from the one in the XML. The casinos within
224 -- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or
225 -- less the same. We don't need a bajillion different tables to
226 -- store that, just one tying the casino/game pair to the three
229 -- The one small difference between the over/under casinos and the
230 -- home/away ones is that the home/away lines are all 'Double's, but
231 -- the over/under lines appear to be textual.
235 ogl_odds_games_id :: DefaultKey OddsGame,
236 ogl_odds_casinos_id :: DefaultKey OddsCasino,
237 ogl_over_under :: Maybe String,
238 ogl_away_line :: Maybe Double,
239 ogl_home_line :: Maybe Double }
242 -- * OddsGame/OddsGameXml
244 -- | Database representation of a game. We retain the rotation number
245 -- of the home/away teams, since those are specific to the game and
250 db_odds_id :: DefaultKey Odds,
251 db_away_team_id :: DefaultKey Team,
252 db_home_team_id :: DefaultKey Team,
254 db_game_time :: Maybe UTCTime, -- ^ Contains both the date and time.
255 db_away_team_rotation_number :: Maybe Int,
256 db_home_team_rotation_number :: Maybe Int,
257 db_away_team_starter_id :: Maybe Int,
258 db_away_team_starter_name :: Maybe String,
259 db_home_team_starter_id :: Maybe Int,
260 db_home_team_starter_name :: Maybe String }
263 -- | XML representation of an 'OddsGame'.
268 xml_game_date :: UTCTime, -- ^ Contains only the date
269 xml_game_time :: Maybe UTCTime, -- ^ Contains only the time
270 xml_away_team :: OddsGameTeamXml,
271 xml_home_team :: OddsGameTeamXml,
272 xml_over_under :: OddsGameOverUnderXml }
275 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
278 xml_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
279 xml_over_under_casinos = xml_casinos . xml_over_under
282 instance ToDb OddsGameXml where
283 -- | The database representation of an 'OddsGameXml' is an
286 type Db OddsGameXml = OddsGame
289 instance Child OddsGameXml where
290 -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words
291 -- the foreign key for 'OddsGame' points to an 'Odds'.
293 type Parent OddsGameXml = Odds
296 instance FromXmlFkTeams OddsGameXml where
297 -- | To convert from the XML representation to the database one, we
298 -- drop the casino lines, but retain the home/away rotation
299 -- numbers and the starters. The foreign keys to 'Odds' and the
300 -- home/away teams are passed in.
302 from_xml_fk_teams fk fk_away fk_home OddsGameXml{..} =
305 db_away_team_id = fk_away,
306 db_home_team_id = fk_home,
307 db_game_id = xml_game_id,
309 db_game_time = make_game_time xml_game_date xml_game_time,
311 db_away_team_rotation_number =
312 (xml_team_rotation_number xml_away_team),
314 db_home_team_rotation_number =
315 (xml_team_rotation_number xml_home_team),
317 db_away_team_starter_id =
318 (xml_starter_id <$> xml_team_starter xml_away_team),
320 -- Sometimes the starter element is present but the name isn't,
321 -- so we combine the two maybes with join.
322 db_away_team_starter_name = join
323 (xml_starter_name <$> xml_team_starter xml_away_team),
325 db_home_team_starter_id =
326 (xml_starter_id <$> xml_team_starter xml_home_team),
328 -- Sometimes the starter element is present but the name isn't,
329 -- so we combine the two maybes with join.
330 db_home_team_starter_name = join
331 (xml_starter_name <$> xml_team_starter xml_home_team) }
333 -- | Construct the database game time from the XML \<Game_Date\>
334 -- and \<Game_Time\> elements. The \<Game_Time\> elements
335 -- sometimes have a value of \"TBA\"; in that case, we don't
336 -- want to pretend that we know the time by setting it to
337 -- e.g. midnight, so instead we make the entire date/time
339 make_game_time :: UTCTime -> Maybe UTCTime -> Maybe UTCTime
340 make_game_time _ Nothing = Nothing
341 make_game_time d (Just t) = Just $ UTCTime (utctDay d) (utctDayTime t)
344 -- | This lets us insert the XML representation 'OddsGameXml' directly.
346 instance XmlImportFkTeams OddsGameXml
349 -- * OddsGameWithNotes
351 -- | This is our best guess at what occurs in the Odds_XML
352 -- documents. It looks like each consecutive set of games can
353 -- optionally have some notes appear before it. Each \"note\" comes
354 -- as its own \<Notes\>...\</Notes\> element.
356 -- The notes are ignored completely in the database; we only bother
357 -- with them to ensure that we're (un)pickling correctly.
359 -- We can't group the notes with a \"set\" of 'OddsGame's, because
360 -- that leads to ambiguity in parsing. Since we're going to ignore
361 -- the notes anyway, we just stick them with an arbitrary
362 -- game. C'est la vie.
364 -- We have to take the same approach with the league. The
365 -- \<League_Name\> elements are sitting outside of the games, and
366 -- are presumably supposed to be interpreted in \"chronological\"
367 -- order; i.e. the current league stays the same until we see
368 -- another \<League_Name\> element. Unfortunately, that's not how
369 -- XML works. So we're forced to ignore the league in the database
370 -- and pull the same trick, pairing them with games.
372 data OddsGameWithNotes =
374 league :: Maybe String,
376 game :: OddsGameXml }
382 -- | Database representation of a 'Message'.
386 db_xml_file_id :: Int,
389 db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
390 -- because their timezones are ambiguous
391 -- (and the date is less than useful when
392 -- it might be off by an hour).
393 db_time_stamp :: UTCTime }
396 -- | The XML representation of 'Odds'.
400 xml_xml_file_id :: Int,
401 xml_heading :: String,
402 xml_category :: String,
405 xml_line_time :: String,
406 xml_games_with_notes :: [OddsGameWithNotes],
407 xml_time_stamp :: UTCTime }
410 -- | Pseudo-field that lets us get the 'OddsGame's out of
411 -- 'xml_games_with_notes'.
413 xml_games :: Message -> [OddsGameXml]
414 xml_games m = map game (xml_games_with_notes m)
417 instance ToDb Message where
418 -- | The database representation of a 'Message' is 'Odds'.
420 type Db Message = Odds
422 instance FromXml Message where
423 -- | To convert from the XML representation to the database one, we
424 -- just drop a bunch of fields.
426 from_xml Message{..} =
428 db_xml_file_id = xml_xml_file_id,
429 db_sport = xml_sport,
430 db_title = xml_title,
431 db_line_time = xml_line_time,
432 db_time_stamp = xml_time_stamp }
434 -- | This lets us insert the XML representation 'Message' directly.
436 instance XmlImport Message
443 -- Groundhog database schema. This must come before the DbImport
444 -- instance definition. Don't know why.
445 mkPersist tsn_codegen_config [groundhog|
452 # Prevent multiple imports of the same message.
453 fields: [db_xml_file_id]
460 - name: unique_odds_casinos
462 fields: [casino_client_id]
472 - name: db_away_team_id
475 - name: db_home_team_id
479 - entity: OddsGameLine
480 dbName: odds_games_lines
484 - name: ogl_odds_games_id
487 - name: ogl_odds_casinos_id
493 instance DbImport Message where
496 migrate (undefined :: Team)
497 migrate (undefined :: Odds)
498 migrate (undefined :: OddsCasino)
499 migrate (undefined :: OddsGame)
500 migrate (undefined :: OddsGameLine)
503 -- Insert the root "odds" element and acquire its primary key (id).
504 odds_id <- insert_xml m
506 forM_ (xml_games m) $ \game -> do
507 -- First we insert the home and away teams.
508 away_team_id <- insert_xml_or_select (xml_away_team game)
509 home_team_id <- insert_xml_or_select (xml_home_team game)
511 -- Now insert the game, keyed to the "odds" and its teams.
512 game_id <- insert_xml_fk_teams odds_id away_team_id home_team_id game
514 -- Finally, we insert the lines. The over/under entries for this
515 -- game and the lines for the casinos all wind up in the same
516 -- table, odds_games_lines. We can insert the over/under entries
517 -- freely with empty away/home lines:
518 forM_ (xml_over_under_casinos game) $ \c -> do
519 -- Start by inderting the casino.
520 ou_casino_id <- insert_xml_or_select c
522 -- Now add the over/under entry with the casino's id.
523 let ogl = OddsGameLine {
524 ogl_odds_games_id = game_id,
525 ogl_odds_casinos_id = ou_casino_id,
526 ogl_over_under = (xml_casino_line c),
527 ogl_away_line = Nothing,
528 ogl_home_line = Nothing }
532 -- ...but then when we insert the home/away team lines, we
533 -- prefer to update the existing entry rather than overwrite it
534 -- or add a new record.
535 forM_ (xml_team_casinos $ xml_away_team game) $ \c -> do
536 -- insert, or more likely retrieve the existing, casino
537 a_casino_id <- insert_xml_or_select c
539 -- Get a Maybe Double instead of the Maybe String that's in there.
540 let away_line = home_away_line c
542 -- Unconditionally update that casino's away team line with ours.
543 update [Ogl_Away_Line =. away_line] $ -- WHERE
544 Ogl_Odds_Casinos_Id ==. a_casino_id
546 -- Repeat all that for the home team.
547 forM_ (xml_team_casinos $ xml_home_team game) $ \c ->do
548 h_casino_id <- insert_xml_or_select c
549 let home_line = home_away_line c
550 update [Ogl_Home_Line =. home_line] $ -- WHERE
551 Ogl_Odds_Casinos_Id ==. h_casino_id
555 return ImportSucceeded
562 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
564 pickle_game_with_notes :: PU OddsGameWithNotes
565 pickle_game_with_notes =
566 xpWrap (from_pair, to_pair) $
568 (xpOption $ xpElem "League_Name" xpText)
569 (xpList $ xpElem "Notes" xpText)
572 from_pair = uncurryN OddsGameWithNotes
573 to_pair OddsGameWithNotes{..} = (league, notes, game)
576 -- | Pickler for an 'OddsGameCasinoXml'.
578 pickle_casino :: PU OddsGameCasinoXml
581 xpWrap (from_tuple, to_tuple) $
583 (xpAttr "ClientID" xpInt)
584 (xpAttr "Name" xpText)
587 from_tuple = uncurryN OddsGameCasinoXml
588 -- Use record wildcards to avoid unused field warnings.
589 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
594 -- | Pickler for an 'OddsGameTeamXml'.
596 pickle_home_team :: PU OddsGameTeamXml
599 xpWrap (from_tuple, to_tuple) $
601 (xpElem "HomeTeamID" xpText)
602 (xpElem "HomeRotationNumber" (xpOption xpInt))
603 (xpElem "HomeAbbr" xpText)
604 (xpElem "HomeTeamName" xpText)
605 (xpOption pickle_home_starter)
606 (xpList pickle_casino)
608 from_tuple = uncurryN OddsGameTeamXml
610 -- Use record wildcards to avoid unused field warnings.
611 to_tuple OddsGameTeamXml{..} = (xml_team_id,
612 xml_team_rotation_number,
619 -- | Portion of the 'OddsGameTeamStarterXml' pickler that is not
620 -- specific to the home/away teams.
622 pickle_starter :: PU OddsGameTeamStarterXml
624 xpWrap (from_tuple, to_tuple) $
625 xpPair (xpAttr "ID" xpInt) (xpOption xpText)
627 from_tuple = uncurry OddsGameTeamStarterXml
628 to_tuple OddsGameTeamStarterXml{..} = (xml_starter_id,
631 -- | Pickler for an home team 'OddsGameTeamStarterXml'
633 pickle_home_starter :: PU OddsGameTeamStarterXml
634 pickle_home_starter = xpElem "HStarter" pickle_starter
637 -- | Pickler for an away team 'OddsGameTeamStarterXml'
639 pickle_away_starter :: PU OddsGameTeamStarterXml
640 pickle_away_starter = xpElem "AStarter" pickle_starter
644 -- | Pickler for an 'OddsGameTeamXml'.
646 pickle_away_team :: PU OddsGameTeamXml
649 xpWrap (from_tuple, to_tuple) $
651 (xpElem "AwayTeamID" xpText)
652 (xpElem "AwayRotationNumber" (xpOption xpInt))
653 (xpElem "AwayAbbr" xpText)
654 (xpElem "AwayTeamName" xpText)
655 (xpOption pickle_away_starter)
656 (xpList pickle_casino)
658 from_tuple = uncurryN OddsGameTeamXml
660 -- Use record wildcards to avoid unused field warnings.
661 to_tuple OddsGameTeamXml{..} = (xml_team_id,
662 xml_team_rotation_number,
670 -- | Pickler for an 'OddsGameOverUnderXml'.
672 pickle_over_under :: PU OddsGameOverUnderXml
674 xpElem "Over_Under" $
675 xpWrap (to_newtype, from_newtype) $
678 from_newtype (OddsGameOverUnderXml cs) = cs
679 to_newtype = OddsGameOverUnderXml
682 -- | Pickler for an 'OddsGameXml'.
684 pickle_game :: PU OddsGameXml
687 xpWrap (from_tuple, to_tuple) $
689 (xpElem "GameID" xpInt)
690 (xpElem "Game_Date" xp_date_padded)
691 (xpElem "Game_Time" xp_tba_time)
696 from_tuple = uncurryN OddsGameXml
697 -- Use record wildcards to avoid unused field warnings.
698 to_tuple OddsGameXml{..} = (xml_game_id,
706 -- | Pickler for the top-level 'Message'.
708 pickle_message :: PU Message
711 xpWrap (from_tuple, to_tuple) $
712 xp8Tuple (xpElem "XML_File_ID" xpInt)
713 (xpElem "heading" xpText)
714 (xpElem "category" xpText)
715 (xpElem "sport" xpText)
716 (xpElem "Title" xpText)
717 (xpElem "Line_Time" xpText)
718 (xpList pickle_game_with_notes)
719 (xpElem "time_stamp" xp_time_stamp)
721 from_tuple = uncurryN Message
722 to_tuple m = (xml_xml_file_id m,
728 xml_games_with_notes m,
736 -- | A list of all tests for this module.
738 odds_tests :: TestTree
742 [ test_on_delete_cascade,
743 test_pickle_of_unpickle_is_identity,
744 test_unpickle_succeeds ]
747 -- | If we unpickle something and then pickle it, we should wind up
748 -- with the same thing we started with. WARNING: success of this
749 -- test does not mean that unpickling succeeded.
751 test_pickle_of_unpickle_is_identity :: TestTree
752 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
753 [ check "pickle composed with unpickle is the identity"
754 "test/xml/Odds_XML.xml",
756 check "pickle composed with unpickle is the identity (non-int team_id)"
757 "test/xml/Odds_XML-noninteger-team-id.xml",
759 check "pickle composed with unpickle is the identity (positive(+) line)"
760 "test/xml/Odds_XML-positive-line.xml",
762 check "pickle composed with unpickle is the identity (large file)"
763 "test/xml/Odds_XML-largefile.xml",
765 check "pickle composed with unpickle is the identity (league name)"
766 "test/xml/Odds_XML-league-name.xml",
768 check "pickle composed with unpickle is the identity (missing starters)"
769 "test/xml/Odds_XML-missing-starters.xml",
771 check "pickle composed with unpickle is the identity (TBA game time)"
772 "test/xml/Odds_XML-tba-game-time.xml"]
774 check desc path = testCase desc $ do
775 (expected, actual) <- pickle_unpickle pickle_message path
779 -- | Make sure we can actually unpickle these things.
781 test_unpickle_succeeds :: TestTree
782 test_unpickle_succeeds = testGroup "unpickle tests"
783 [ check "unpickling succeeds"
784 "test/xml/Odds_XML.xml",
786 check "unpickling succeeds (non-int team_id)"
787 "test/xml/Odds_XML-noninteger-team-id.xml",
789 check "unpickling succeeds (positive(+) line)"
790 "test/xml/Odds_XML-positive-line.xml",
792 check "unpickling succeeds (large file)"
793 "test/xml/Odds_XML-largefile.xml",
795 check "unpickling succeeds (league name)"
796 "test/xml/Odds_XML-league-name.xml",
798 check "unpickling succeeds (missing starters)"
799 "test/xml/Odds_XML-missing-starters.xml",
801 check "unpickling succeeds (TBA game time)"
802 "test/xml/Odds_XML-tba-game-time.xml" ]
804 check desc path = testCase desc $ do
805 actual <- unpickleable path pickle_message
810 -- | Make sure everything gets deleted when we delete the top-level
811 -- record. The casinos and teams should be left behind.
813 test_on_delete_cascade :: TestTree
814 test_on_delete_cascade = testGroup "cascading delete tests"
815 [ check "deleting odds deletes its children"
816 "test/xml/Odds_XML.xml"
817 13 -- 5 casinos, 8 teams
820 check "deleting odds deletes its children (non-int team_id)"
821 "test/xml/Odds_XML-noninteger-team-id.xml"
822 51 -- 5 casinos, 46 teams
825 check "deleting odds deleted its children (positive(+) line)"
826 "test/xml/Odds_XML-positive-line.xml"
827 17 -- 5 casinos, 12 teams
830 check "deleting odds deleted its children (large file)"
831 "test/xml/Odds_XML-largefile.xml"
832 189 -- 5 casinos, 184 teams
834 check "deleting odds deleted its children (league name)"
835 "test/xml/Odds_XML-league-name.xml"
836 35 -- 5 casinos, 30 teams
838 check "deleting odds deleted its children (missing starters)"
839 "test/xml/Odds_XML-missing-starters.xml"
840 7 -- 5 casinos, 2 teams
842 check "deleting odds deleted its children (TBA game time)"
843 "test/xml/Odds_XML-tba-game-time.xml"
844 119 -- 5 casinos, 114 teams
847 check desc path expected = testCase desc $ do
848 odds <- unsafe_unpickle path pickle_message
849 let a = undefined :: Team
850 let b = undefined :: Odds
851 let c = undefined :: OddsCasino
852 let d = undefined :: OddsGame
853 let e = undefined :: OddsGameLine
854 actual <- withSqliteConn ":memory:" $ runDbConn $ do
855 runMigration silentMigrationLogger $ do
863 count_a <- countAll a
864 count_b <- countAll b
865 count_c <- countAll c
866 count_d <- countAll d
867 count_e <- countAll e
868 return $ sum [count_a, count_b, count_c,