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 OddsGame_TeamConstructor(..),
22 OddsGameConstructor(..),
23 OddsGameLineConstructor(..) )
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_time, xp_time_stamp )
68 import TSN.Team ( Team(..) )
69 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
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 -- * OddsGameHomeTeamXml / OddsGameAwayTeamXml
151 -- | The XML representation of a \<HomeTeam\>, as found in \<Game\>s.
152 -- This is basically the same as 'OddsGameAwayTeamXml', but the two
153 -- types have different picklers.
155 -- The starter id/name could perhaps be combined into an embedded
156 -- type, but can you make an entire embedded type optional with
157 -- Maybe? I doubt it works.
159 data OddsGameHomeTeamXml =
160 OddsGameHomeTeamXml {
161 xml_home_team_id :: String, -- ^ The home/away team IDs
162 -- are three characters but
163 -- Postgres imposes no
164 -- performance penalty on
165 -- lengthless text fields,
166 -- so we ignore the probable
167 -- upper bound of three
169 xml_home_team_rotation_number :: Int,
170 xml_home_team_abbr :: String,
171 xml_home_team_name :: String,
172 xml_home_team_starter :: Maybe (Int, String), -- ^ (id, name)
173 xml_home_team_casinos :: [OddsGameCasinoXml] }
176 instance ToDb OddsGameHomeTeamXml where
177 -- | The database representation of an 'OddsGameHomeTeamXml' is an
180 type Db OddsGameHomeTeamXml = Team
182 instance FromXml OddsGameHomeTeamXml where
183 -- | We convert from XML to the database by dropping the lines and
184 -- rotation number (which are specific to the games, not the teams
187 from_xml OddsGameHomeTeamXml{..} =
189 team_id = xml_home_team_id,
190 abbreviation = Just xml_home_team_abbr,
191 name = Just xml_home_team_name }
193 -- | This allows us to insert the XML representation
194 -- 'OddsGameHomeTeamXml' directly.
196 instance XmlImport OddsGameHomeTeamXml where
200 -- | The XML representation of a \<AwayTeam\>, as found in \<Game\>s.
201 -- This is basically the same as 'OddsGameHomeTeamXml', but the two
202 -- types have different picklers.
204 data OddsGameAwayTeamXml =
205 OddsGameAwayTeamXml {
206 xml_away_team_id :: String, -- ^ The home/away team IDs are
207 -- three characters but Postgres
208 -- imposes no performance penalty
209 -- on lengthless text fields, so
210 -- we ignore the probable upper
211 -- bound of three characters
212 xml_away_team_rotation_number :: Int,
213 xml_away_team_abbr :: String,
214 xml_away_team_name :: String,
215 xml_away_team_starter :: Maybe (Int, String), -- ^ (id, name)
216 xml_away_team_casinos :: [OddsGameCasinoXml] }
219 instance ToDb OddsGameAwayTeamXml where
220 -- | The database representation of an 'OddsGameAwayTeamXml' is a
223 type Db OddsGameAwayTeamXml = Team
225 instance FromXml OddsGameAwayTeamXml where
226 -- | We convert from XML to the database by dropping the lines and
227 -- rotation number (which are specific to the games, not the teams
230 from_xml OddsGameAwayTeamXml{..} = Team
232 (Just xml_away_team_abbr)
233 (Just xml_away_team_name)
235 -- | This allows us to insert the XML representation
236 -- 'OddsGameAwayTeamXml' directly.
238 instance XmlImport OddsGameAwayTeamXml where
241 -- * OddsGame_OddsGameTeam
243 -- | Database mapping between games and their home/away teams.
247 ogt_odds_games_id :: DefaultKey OddsGame,
248 ogt_away_team_id :: DefaultKey Team,
249 ogt_home_team_id :: DefaultKey Team }
252 -- * OddsGameOverUnderXml
254 -- | XML representation of the over/under. A wrapper around a bunch of
257 newtype OddsGameOverUnderXml =
258 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
264 -- | This database representation of the casino lines can't be
265 -- constructed from the one in the XML. The casinos within
266 -- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or
267 -- less the same. We don't need a bajillion different tables to
268 -- store that, just one tying the casino/game pair to the three
271 -- The one small difference between the over/under casinos and the
272 -- home/away ones is that the home/away lines are all 'Double's, but
273 -- the over/under lines appear to be textual.
277 ogl_odds_games_id :: DefaultKey OddsGame,
278 ogl_odds_casinos_id :: DefaultKey OddsCasino,
279 ogl_over_under :: Maybe String,
280 ogl_away_line :: Maybe Double,
281 ogl_home_line :: Maybe Double }
284 -- * OddsGame/OddsGameXml
286 -- | Database representation of a game. We retain the rotation number
287 -- of the home/away teams, since those are specific to the game and
292 db_odds_id :: DefaultKey Odds,
294 db_game_time :: UTCTime, -- ^ Contains both the date and time.
295 db_away_team_rotation_number :: Int,
296 db_home_team_rotation_number :: Int,
297 db_away_team_starter_id :: Maybe Int,
298 db_away_team_starter_name :: Maybe String,
299 db_home_team_starter_id :: Maybe Int,
300 db_home_team_starter_name :: Maybe String }
303 -- | XML representation of an 'OddsGame'.
308 xml_game_date :: UTCTime, -- ^ Contains only the date
309 xml_game_time :: UTCTime, -- ^ Contains only the time
310 xml_away_team :: OddsGameAwayTeamXml,
311 xml_home_team :: OddsGameHomeTeamXml,
312 xml_over_under :: OddsGameOverUnderXml }
315 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
318 xml_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
319 xml_over_under_casinos = xml_casinos . xml_over_under
322 instance ToDb OddsGameXml where
323 -- | The database representation of an 'OddsGameXml' is an
326 type Db OddsGameXml = OddsGame
328 instance FromXmlFk OddsGameXml where
329 -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words
330 -- the foreign key for 'OddsGame' points to an 'Odds'.
332 type Parent OddsGameXml = Odds
334 -- | To convert from the XML representation to the database one, we
335 -- drop the home/away teams and the casino lines, but retain the
336 -- home/away rotation numbers and the starters.
338 from_xml_fk fk OddsGameXml{..} =
341 db_game_id = xml_game_id,
343 db_game_time = UTCTime
344 (utctDay xml_game_date) -- Take the day part from one,
345 (utctDayTime xml_game_time), -- the time from the other.
347 db_away_team_rotation_number =
348 (xml_away_team_rotation_number xml_away_team),
350 db_home_team_rotation_number =
351 (xml_home_team_rotation_number xml_home_team),
353 db_away_team_starter_id =
354 (fmap fst $ xml_away_team_starter xml_away_team),
356 db_away_team_starter_name =
357 (fmap snd $ xml_away_team_starter xml_away_team),
359 db_home_team_starter_id =
360 (fmap fst $ xml_home_team_starter xml_home_team),
362 db_home_team_starter_name =
363 (fmap snd $ xml_home_team_starter xml_home_team) }
366 -- | This lets us insert the XML representation 'OddsGameXml' directly.
368 instance XmlImportFk OddsGameXml
371 -- * OddsGameWithNotes
373 -- | This is our best guess at what occurs in the Odds_XML
374 -- documents. It looks like each consecutive set of games can
375 -- optionally have some notes appear before it. Each \"note\" comes
376 -- as its own \<Notes\>...\</Notes\> element.
378 -- The notes are ignored completely in the database; we only bother
379 -- with them to ensure that we're (un)pickling correctly.
381 -- We can't group the notes with a \"set\" of 'OddsGame's, because
382 -- that leads to ambiguity in parsing. Since we're going to ignore
383 -- the notes anyway, we just stick them with an arbitrary
384 -- game. C'est la vie.
386 -- We have to take the same approach with the league. The
387 -- \<League_Name\> elements are sitting outside of the games, and
388 -- are presumably supposed to be interpreted in \"chronological\"
389 -- order; i.e. the current league stays the same until we see
390 -- another \<League_Name\> element. Unfortunately, that's not how
391 -- XML works. So we're forced to ignore the league in the database
392 -- and pull the same trick, pairing them with games.
394 data OddsGameWithNotes =
396 league :: Maybe String,
398 game :: OddsGameXml }
404 -- | Database representation of a 'Message'.
408 db_xml_file_id :: Int,
411 db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
412 -- because their timezones are ambiguous
413 -- (and the date is less than useful when
414 -- it might be off by an hour).
415 db_time_stamp :: UTCTime }
418 -- | The XML representation of 'Odds'.
422 xml_xml_file_id :: Int,
423 xml_heading :: String,
424 xml_category :: String,
427 xml_line_time :: String,
428 xml_games_with_notes :: [OddsGameWithNotes],
429 xml_time_stamp :: UTCTime }
432 -- | Pseudo-field that lets us get the 'OddsGame's out of
433 -- 'xml_games_with_notes'.
435 xml_games :: Message -> [OddsGameXml]
436 xml_games m = map game (xml_games_with_notes m)
439 instance ToDb Message where
440 -- | The database representation of a 'Message' is 'Odds'.
442 type Db Message = Odds
444 instance FromXml Message where
445 -- | To convert from the XML representation to the database one, we
446 -- just drop a bunch of fields.
448 from_xml Message{..} =
450 db_xml_file_id = xml_xml_file_id,
451 db_sport = xml_sport,
452 db_title = xml_title,
453 db_line_time = xml_line_time,
454 db_time_stamp = xml_time_stamp }
456 -- | This lets us insert the XML representation 'Message' directly.
458 instance XmlImport Message
465 -- Groundhog database schema. This must come before the DbImport
466 -- instance definition. Don't know why.
467 mkPersist tsn_codegen_config [groundhog|
474 # Prevent multiple imports of the same message.
475 fields: [db_xml_file_id]
482 - name: unique_odds_casino
484 fields: [casino_client_id]
495 - entity: OddsGameLine
496 dbName: odds_games_lines
500 - name: ogl_odds_games_id
503 - name: ogl_odds_casinos_id
507 - entity: OddsGame_Team
508 dbName: odds_games__teams
510 - name: OddsGame_Team
512 - name: ogt_odds_games_id
515 - name: ogt_away_team_id
518 - name: ogt_home_team_id
523 instance DbImport Message where
526 migrate (undefined :: Team)
527 migrate (undefined :: Odds)
528 migrate (undefined :: OddsCasino)
529 migrate (undefined :: OddsGame)
530 migrate (undefined :: OddsGame_Team)
531 migrate (undefined :: OddsGameLine)
534 -- Insert the root "odds" element and acquire its primary key (id).
535 odds_id <- insert_xml m
537 forM_ (xml_games m) $ \g -> do
538 -- First insert the game, keyed to the "odds",
539 game_id <- insert_xml_fk odds_id g
541 -- Next, we insert the home and away teams.
542 away_team_id <- insert_xml_or_select (xml_away_team g)
543 home_team_id <- insert_xml_or_select (xml_home_team g)
545 -- Insert a record into odds_games__teams mapping the
546 -- home/away teams to this game. Use the full record syntax
547 -- because the types would let us mix up the home/away teams.
548 insert_ OddsGame_Team {
549 ogt_odds_games_id = game_id,
550 ogt_away_team_id = away_team_id,
551 ogt_home_team_id = home_team_id }
553 -- Finaly, we insert the lines. The over/under entries for this
554 -- game and the lines for the casinos all wind up in the same
555 -- table, odds_games_lines. We can insert the over/under entries
556 -- freely with empty away/home lines:
557 forM_ (xml_over_under_casinos g) $ \c -> do
558 -- Start by inderting the casino.
559 ou_casino_id <- insert_xml_or_select c
561 -- Now add the over/under entry with the casino's id.
562 let ogl = OddsGameLine {
563 ogl_odds_games_id = game_id,
564 ogl_odds_casinos_id = ou_casino_id,
565 ogl_over_under = (xml_casino_line c),
566 ogl_away_line = Nothing,
567 ogl_home_line = Nothing }
571 -- ...but then when we insert the home/away team lines, we
572 -- prefer to update the existing entry rather than overwrite it
573 -- or add a new record.
574 forM_ (xml_away_team_casinos $ xml_away_team g) $ \c -> do
575 -- insert, or more likely retrieve the existing, casino
576 a_casino_id <- insert_xml_or_select c
578 -- Get a Maybe Double instead of the Maybe String that's in there.
579 let away_line = home_away_line c
581 -- Unconditionally update that casino's away team line with ours.
582 update [Ogl_Away_Line =. away_line] $ -- WHERE
583 Ogl_Odds_Casinos_Id ==. a_casino_id
585 -- Repeat all that for the home team.
586 forM_ (xml_home_team_casinos $ xml_home_team g) $ \c ->do
587 h_casino_id <- insert_xml_or_select c
588 let home_line = home_away_line c
589 update [Ogl_Home_Line =. home_line] $ -- WHERE
590 Ogl_Odds_Casinos_Id ==. h_casino_id
594 return ImportSucceeded
601 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
603 pickle_game_with_notes :: PU OddsGameWithNotes
604 pickle_game_with_notes =
605 xpWrap (from_pair, to_pair) $
607 (xpOption $ xpElem "League_Name" xpText)
608 (xpList $ xpElem "Notes" xpText)
611 from_pair = uncurryN OddsGameWithNotes
612 to_pair OddsGameWithNotes{..} = (league, notes, game)
615 -- | Pickler for an 'OddsGameCasinoXml'.
617 pickle_casino :: PU OddsGameCasinoXml
620 xpWrap (from_tuple, to_tuple) $
622 (xpAttr "ClientID" xpInt)
623 (xpAttr "Name" xpText)
626 from_tuple = uncurryN OddsGameCasinoXml
627 -- Use record wildcards to avoid unused field warnings.
628 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
633 -- | Pickler for an 'OddsGameHomeTeamXml'.
635 pickle_home_team :: PU OddsGameHomeTeamXml
638 xpWrap (from_tuple, to_tuple) $
640 (xpElem "HomeTeamID" xpText)
641 (xpElem "HomeRotationNumber" xpInt)
642 (xpElem "HomeAbbr" xpText)
643 (xpElem "HomeTeamName" xpText)
644 (-- This is an ugly way to get both the HStarter ID attribute
646 xpOption (xpElem "HStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
647 (xpList pickle_casino)
649 from_tuple = uncurryN OddsGameHomeTeamXml
651 -- Use record wildcards to avoid unused field warnings.
652 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
653 xml_home_team_rotation_number,
656 xml_home_team_starter,
657 xml_home_team_casinos)
659 -- | Pickler for an 'OddsGameAwayTeamXml'.
661 pickle_away_team :: PU OddsGameAwayTeamXml
664 xpWrap (from_tuple, to_tuple) $
666 (xpElem "AwayTeamID" xpText)
667 (xpElem "AwayRotationNumber" xpInt)
668 (xpElem "AwayAbbr" xpText)
669 (xpElem "AwayTeamName" xpText)
670 (-- This is an ugly way to get both the AStarter ID attribute
672 xpOption (xpElem "AStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
673 (xpList pickle_casino)
675 from_tuple = uncurryN OddsGameAwayTeamXml
677 -- Use record wildcards to avoid unused field warnings.
678 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
679 xml_away_team_rotation_number,
682 xml_away_team_starter,
683 xml_away_team_casinos)
687 -- | Pickler for an 'OddsGameOverUnderXml'.
689 pickle_over_under :: PU OddsGameOverUnderXml
691 xpElem "Over_Under" $
692 xpWrap (to_newtype, from_newtype) $
695 from_newtype (OddsGameOverUnderXml cs) = cs
696 to_newtype = OddsGameOverUnderXml
699 -- | Pickler for an 'OddsGameXml'.
701 pickle_game :: PU OddsGameXml
704 xpWrap (from_tuple, to_tuple) $
706 (xpElem "GameID" xpInt)
707 (xpElem "Game_Date" xp_date_padded)
708 (xpElem "Game_Time" xp_time)
713 from_tuple = uncurryN OddsGameXml
714 -- Use record wildcards to avoid unused field warnings.
715 to_tuple OddsGameXml{..} = (xml_game_id,
723 -- | Pickler for the top-level 'Message'.
725 pickle_message :: PU Message
728 xpWrap (from_tuple, to_tuple) $
729 xp8Tuple (xpElem "XML_File_ID" xpInt)
730 (xpElem "heading" xpText)
731 (xpElem "category" xpText)
732 (xpElem "sport" xpText)
733 (xpElem "Title" xpText)
734 (xpElem "Line_Time" xpText)
735 (xpList pickle_game_with_notes)
736 (xpElem "time_stamp" xp_time_stamp)
738 from_tuple = uncurryN Message
739 to_tuple m = (xml_xml_file_id m,
745 xml_games_with_notes m,
753 -- | A list of all tests for this module.
755 odds_tests :: TestTree
759 [ test_on_delete_cascade,
760 test_pickle_of_unpickle_is_identity,
761 test_unpickle_succeeds ]
764 -- | If we unpickle something and then pickle it, we should wind up
765 -- with the same thing we started with. WARNING: success of this
766 -- test does not mean that unpickling succeeded.
768 test_pickle_of_unpickle_is_identity :: TestTree
769 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
770 [ check "pickle composed with unpickle is the identity"
771 "test/xml/Odds_XML.xml",
773 check "pickle composed with unpickle is the identity (non-int team_id)"
774 "test/xml/Odds_XML-noninteger-team-id.xml",
776 check "pickle composed with unpickle is the identity (positive(+) line)"
777 "test/xml/Odds_XML-positive-line.xml",
779 check "pickle composed with unpickle is the identity (large file)"
780 "test/xml/Odds_XML-largefile.xml",
782 check "pickle composed with unpickle is the identity (league name)"
783 "test/xml/Odds_XML-league-name.xml" ]
785 check desc path = testCase desc $ do
786 (expected, actual) <- pickle_unpickle pickle_message path
790 -- | Make sure we can actually unpickle these things.
792 test_unpickle_succeeds :: TestTree
793 test_unpickle_succeeds = testGroup "unpickle tests"
794 [ check "unpickling succeeds"
795 "test/xml/Odds_XML.xml",
797 check "unpickling succeeds (non-int team_id)"
798 "test/xml/Odds_XML-noninteger-team-id.xml",
800 check "unpickling succeeds (positive(+) line)"
801 "test/xml/Odds_XML-positive-line.xml",
803 check "unpickling succeeds (large file)"
804 "test/xml/Odds_XML-largefile.xml",
806 check "unpickling succeeds (league name)"
807 "test/xml/Odds_XML-league-name.xml" ]
809 check desc path = testCase desc $ do
810 actual <- unpickleable path pickle_message
815 -- | Make sure everything gets deleted when we delete the top-level
816 -- record. The casinos and teams should be left behind.
818 test_on_delete_cascade :: TestTree
819 test_on_delete_cascade = testGroup "cascading delete tests"
820 [ check "deleting odds deletes its children"
821 "test/xml/Odds_XML.xml"
822 13 -- 5 casinos, 8 teams
825 check "deleting odds deletes its children (non-int team_id)"
826 "test/xml/Odds_XML-noninteger-team-id.xml"
827 51 -- 5 casinos, 46 teams
830 check "deleting odds deleted its children (positive(+) line)"
831 "test/xml/Odds_XML-positive-line.xml"
832 17 -- 5 casinos, 12 teams
835 check "deleting odds deleted its children (large file)"
836 "test/xml/Odds_XML-largefile.xml"
837 189 -- 5 casinos, 184 teams
839 check "deleting odds deleted its children (league name)"
840 "test/xml/Odds_XML-league-name.xml"
841 35 -- 5 casinos, 30 teams
844 check desc path expected = testCase desc $ do
845 odds <- unsafe_unpickle path pickle_message
846 let a = undefined :: Team
847 let b = undefined :: Odds
848 let c = undefined :: OddsCasino
849 let d = undefined :: OddsGame
850 let e = undefined :: OddsGame_Team
851 let f = undefined :: OddsGameLine
852 actual <- withSqliteConn ":memory:" $ runDbConn $ do
853 runMigration silentMigrationLogger $ do
862 count_a <- countAll a
863 count_b <- countAll b
864 count_c <- countAll c
865 count_d <- countAll d
866 count_e <- countAll e
867 count_f <- countAll f
868 return $ sum [count_a, count_b, count_c,
869 count_d, count_e, count_f ]