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.Monad ( forM_, join )
27 import Data.Time ( UTCTime(..) )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog (
37 silentMigrationLogger,
39 import Database.Groundhog.Core ( DefaultKey )
40 import Database.Groundhog.Generic ( runDbConn )
41 import Database.Groundhog.Sqlite ( withSqliteConn )
42 import Database.Groundhog.TH (
45 import Test.Tasty ( TestTree, testGroup )
46 import Test.Tasty.HUnit ( (@?=), testCase )
47 import Text.Read ( readMaybe )
48 import Text.XML.HXT.Core (
65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
66 import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
67 import TSN.Team ( Team(..) )
68 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
151 -- | The XML representation of a \<HomeTeam\> or \<AwayTeam\>, as
152 -- found in \<Game\>s. We can't use the 'Team' representation
153 -- directly because there are some other fields we need to parse.
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 OddsGameTeamXml =
161 xml_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_team_rotation_number :: Maybe Int,
170 xml_team_abbr :: String,
171 xml_team_name :: String,
172 xml_team_starter :: Maybe (Int, String), -- ^ (id, name)
173 xml_team_casinos :: [OddsGameCasinoXml] }
176 instance ToDb OddsGameTeamXml where
177 -- | The database representation of an 'OddsGameTeamXml' is an
180 type Db OddsGameTeamXml = Team
182 instance FromXml OddsGameTeamXml 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 OddsGameTeamXml{..} =
189 team_id = xml_team_id,
190 abbreviation = Just xml_team_abbr,
191 name = Just xml_team_name }
193 -- | This allows us to insert the XML representation
194 -- 'OddsGameTeamXml' directly.
196 instance XmlImport OddsGameTeamXml where
201 -- * OddsGameOverUnderXml
203 -- | XML representation of the over/under. A wrapper around a bunch of
206 newtype OddsGameOverUnderXml =
207 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
213 -- | This database representation of the casino lines can't be
214 -- constructed from the one in the XML. The casinos within
215 -- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or
216 -- less the same. We don't need a bajillion different tables to
217 -- store that, just one tying the casino/game pair to the three
220 -- The one small difference between the over/under casinos and the
221 -- home/away ones is that the home/away lines are all 'Double's, but
222 -- the over/under lines appear to be textual.
226 ogl_odds_games_id :: DefaultKey OddsGame,
227 ogl_odds_casinos_id :: DefaultKey OddsCasino,
228 ogl_over_under :: Maybe String,
229 ogl_away_line :: Maybe Double,
230 ogl_home_line :: Maybe Double }
233 -- * OddsGame/OddsGameXml
235 -- | Database representation of a game. We retain the rotation number
236 -- of the home/away teams, since those are specific to the game and
241 db_odds_id :: DefaultKey Odds,
242 db_away_team_id :: DefaultKey Team,
243 db_home_team_id :: DefaultKey Team,
245 db_game_time :: UTCTime, -- ^ Contains both the date and time.
246 db_away_team_rotation_number :: Maybe Int,
247 db_home_team_rotation_number :: Maybe Int,
248 db_away_team_starter_id :: Maybe Int,
249 db_away_team_starter_name :: Maybe String,
250 db_home_team_starter_id :: Maybe Int,
251 db_home_team_starter_name :: Maybe String }
254 -- | XML representation of an 'OddsGame'.
259 xml_game_date :: UTCTime, -- ^ Contains only the date
260 xml_game_time :: UTCTime, -- ^ Contains only the time
261 xml_away_team :: OddsGameTeamXml,
262 xml_home_team :: OddsGameTeamXml,
263 xml_over_under :: OddsGameOverUnderXml }
266 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
269 xml_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
270 xml_over_under_casinos = xml_casinos . xml_over_under
273 instance ToDb OddsGameXml where
274 -- | The database representation of an 'OddsGameXml' is an
277 type Db OddsGameXml = OddsGame
280 instance Child OddsGameXml where
281 -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words
282 -- the foreign key for 'OddsGame' points to an 'Odds'.
284 type Parent OddsGameXml = Odds
287 instance FromXmlFkTeams OddsGameXml where
288 -- | To convert from the XML representation to the database one, we
289 -- drop the casino lines, but retain the home/away rotation
290 -- numbers and the starters. The foreign keys to 'Odds' and the
291 -- home/away teams are passed in.
293 from_xml_fk_teams fk fk_away fk_home OddsGameXml{..} =
296 db_away_team_id = fk_away,
297 db_home_team_id = fk_home,
298 db_game_id = xml_game_id,
300 db_game_time = UTCTime
301 (utctDay xml_game_date) -- Take the day part from one,
302 (utctDayTime xml_game_time), -- the time from the other.
304 db_away_team_rotation_number =
305 (xml_team_rotation_number xml_away_team),
307 db_home_team_rotation_number =
308 (xml_team_rotation_number xml_home_team),
310 db_away_team_starter_id =
311 (fmap fst $ xml_team_starter xml_away_team),
313 db_away_team_starter_name =
314 (fmap snd $ xml_team_starter xml_away_team),
316 db_home_team_starter_id =
317 (fmap fst $ xml_team_starter xml_home_team),
319 db_home_team_starter_name =
320 (fmap snd $ xml_team_starter xml_home_team) }
323 -- | This lets us insert the XML representation 'OddsGameXml' directly.
325 instance XmlImportFkTeams OddsGameXml
328 -- * OddsGameWithNotes
330 -- | This is our best guess at what occurs in the Odds_XML
331 -- documents. It looks like each consecutive set of games can
332 -- optionally have some notes appear before it. Each \"note\" comes
333 -- as its own \<Notes\>...\</Notes\> element.
335 -- The notes are ignored completely in the database; we only bother
336 -- with them to ensure that we're (un)pickling correctly.
338 -- We can't group the notes with a \"set\" of 'OddsGame's, because
339 -- that leads to ambiguity in parsing. Since we're going to ignore
340 -- the notes anyway, we just stick them with an arbitrary
341 -- game. C'est la vie.
343 -- We have to take the same approach with the league. The
344 -- \<League_Name\> elements are sitting outside of the games, and
345 -- are presumably supposed to be interpreted in \"chronological\"
346 -- order; i.e. the current league stays the same until we see
347 -- another \<League_Name\> element. Unfortunately, that's not how
348 -- XML works. So we're forced to ignore the league in the database
349 -- and pull the same trick, pairing them with games.
351 data OddsGameWithNotes =
353 league :: Maybe String,
355 game :: OddsGameXml }
361 -- | Database representation of a 'Message'.
365 db_xml_file_id :: Int,
368 db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
369 -- because their timezones are ambiguous
370 -- (and the date is less than useful when
371 -- it might be off by an hour).
372 db_time_stamp :: UTCTime }
375 -- | The XML representation of 'Odds'.
379 xml_xml_file_id :: Int,
380 xml_heading :: String,
381 xml_category :: String,
384 xml_line_time :: String,
385 xml_games_with_notes :: [OddsGameWithNotes],
386 xml_time_stamp :: UTCTime }
389 -- | Pseudo-field that lets us get the 'OddsGame's out of
390 -- 'xml_games_with_notes'.
392 xml_games :: Message -> [OddsGameXml]
393 xml_games m = map game (xml_games_with_notes m)
396 instance ToDb Message where
397 -- | The database representation of a 'Message' is 'Odds'.
399 type Db Message = Odds
401 instance FromXml Message where
402 -- | To convert from the XML representation to the database one, we
403 -- just drop a bunch of fields.
405 from_xml Message{..} =
407 db_xml_file_id = xml_xml_file_id,
408 db_sport = xml_sport,
409 db_title = xml_title,
410 db_line_time = xml_line_time,
411 db_time_stamp = xml_time_stamp }
413 -- | This lets us insert the XML representation 'Message' directly.
415 instance XmlImport Message
422 -- Groundhog database schema. This must come before the DbImport
423 -- instance definition. Don't know why.
424 mkPersist tsn_codegen_config [groundhog|
431 # Prevent multiple imports of the same message.
432 fields: [db_xml_file_id]
439 - name: unique_odds_casino
441 fields: [casino_client_id]
451 - name: db_away_team_id
454 - name: db_home_team_id
458 - entity: OddsGameLine
459 dbName: odds_games_lines
463 - name: ogl_odds_games_id
466 - name: ogl_odds_casinos_id
472 instance DbImport Message where
475 migrate (undefined :: Team)
476 migrate (undefined :: Odds)
477 migrate (undefined :: OddsCasino)
478 migrate (undefined :: OddsGame)
479 migrate (undefined :: OddsGameLine)
482 -- Insert the root "odds" element and acquire its primary key (id).
483 odds_id <- insert_xml m
485 forM_ (xml_games m) $ \game -> do
486 -- First we insert the home and away teams.
487 away_team_id <- insert_xml_or_select (xml_away_team game)
488 home_team_id <- insert_xml_or_select (xml_home_team game)
490 -- Now insert the game, keyed to the "odds" and its teams.
491 game_id <- insert_xml_fk_teams odds_id away_team_id home_team_id game
493 -- Finally, we insert the lines. The over/under entries for this
494 -- game and the lines for the casinos all wind up in the same
495 -- table, odds_games_lines. We can insert the over/under entries
496 -- freely with empty away/home lines:
497 forM_ (xml_over_under_casinos game) $ \c -> do
498 -- Start by inderting the casino.
499 ou_casino_id <- insert_xml_or_select c
501 -- Now add the over/under entry with the casino's id.
502 let ogl = OddsGameLine {
503 ogl_odds_games_id = game_id,
504 ogl_odds_casinos_id = ou_casino_id,
505 ogl_over_under = (xml_casino_line c),
506 ogl_away_line = Nothing,
507 ogl_home_line = Nothing }
511 -- ...but then when we insert the home/away team lines, we
512 -- prefer to update the existing entry rather than overwrite it
513 -- or add a new record.
514 forM_ (xml_team_casinos $ xml_away_team game) $ \c -> do
515 -- insert, or more likely retrieve the existing, casino
516 a_casino_id <- insert_xml_or_select c
518 -- Get a Maybe Double instead of the Maybe String that's in there.
519 let away_line = home_away_line c
521 -- Unconditionally update that casino's away team line with ours.
522 update [Ogl_Away_Line =. away_line] $ -- WHERE
523 Ogl_Odds_Casinos_Id ==. a_casino_id
525 -- Repeat all that for the home team.
526 forM_ (xml_team_casinos $ xml_home_team game) $ \c ->do
527 h_casino_id <- insert_xml_or_select c
528 let home_line = home_away_line c
529 update [Ogl_Home_Line =. home_line] $ -- WHERE
530 Ogl_Odds_Casinos_Id ==. h_casino_id
534 return ImportSucceeded
541 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
543 pickle_game_with_notes :: PU OddsGameWithNotes
544 pickle_game_with_notes =
545 xpWrap (from_pair, to_pair) $
547 (xpOption $ xpElem "League_Name" xpText)
548 (xpList $ xpElem "Notes" xpText)
551 from_pair = uncurryN OddsGameWithNotes
552 to_pair OddsGameWithNotes{..} = (league, notes, game)
555 -- | Pickler for an 'OddsGameCasinoXml'.
557 pickle_casino :: PU OddsGameCasinoXml
560 xpWrap (from_tuple, to_tuple) $
562 (xpAttr "ClientID" xpInt)
563 (xpAttr "Name" xpText)
566 from_tuple = uncurryN OddsGameCasinoXml
567 -- Use record wildcards to avoid unused field warnings.
568 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
573 -- | Pickler for an 'OddsGameTeamXml'.
575 pickle_home_team :: PU OddsGameTeamXml
578 xpWrap (from_tuple, to_tuple) $
580 (xpElem "HomeTeamID" xpText)
581 (xpElem "HomeRotationNumber" (xpOption xpInt))
582 (xpElem "HomeAbbr" xpText)
583 (xpElem "HomeTeamName" xpText)
584 (-- This is an ugly way to get both the HStarter ID attribute
586 xpOption (xpElem "HStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
587 (xpList pickle_casino)
589 from_tuple = uncurryN OddsGameTeamXml
591 -- Use record wildcards to avoid unused field warnings.
592 to_tuple OddsGameTeamXml{..} = (xml_team_id,
593 xml_team_rotation_number,
599 -- | Pickler for an 'OddsGameTeamXml'.
601 pickle_away_team :: PU OddsGameTeamXml
604 xpWrap (from_tuple, to_tuple) $
606 (xpElem "AwayTeamID" xpText)
607 (xpElem "AwayRotationNumber" (xpOption xpInt))
608 (xpElem "AwayAbbr" xpText)
609 (xpElem "AwayTeamName" xpText)
610 (-- This is an ugly way to get both the AStarter ID attribute
612 xpOption (xpElem "AStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
613 (xpList pickle_casino)
615 from_tuple = uncurryN OddsGameTeamXml
617 -- Use record wildcards to avoid unused field warnings.
618 to_tuple OddsGameTeamXml{..} = (xml_team_id,
619 xml_team_rotation_number,
627 -- | Pickler for an 'OddsGameOverUnderXml'.
629 pickle_over_under :: PU OddsGameOverUnderXml
631 xpElem "Over_Under" $
632 xpWrap (to_newtype, from_newtype) $
635 from_newtype (OddsGameOverUnderXml cs) = cs
636 to_newtype = OddsGameOverUnderXml
639 -- | Pickler for an 'OddsGameXml'.
641 pickle_game :: PU OddsGameXml
644 xpWrap (from_tuple, to_tuple) $
646 (xpElem "GameID" xpInt)
647 (xpElem "Game_Date" xp_date_padded)
648 (xpElem "Game_Time" xp_time)
653 from_tuple = uncurryN OddsGameXml
654 -- Use record wildcards to avoid unused field warnings.
655 to_tuple OddsGameXml{..} = (xml_game_id,
663 -- | Pickler for the top-level 'Message'.
665 pickle_message :: PU Message
668 xpWrap (from_tuple, to_tuple) $
669 xp8Tuple (xpElem "XML_File_ID" xpInt)
670 (xpElem "heading" xpText)
671 (xpElem "category" xpText)
672 (xpElem "sport" xpText)
673 (xpElem "Title" xpText)
674 (xpElem "Line_Time" xpText)
675 (xpList pickle_game_with_notes)
676 (xpElem "time_stamp" xp_time_stamp)
678 from_tuple = uncurryN Message
679 to_tuple m = (xml_xml_file_id m,
685 xml_games_with_notes m,
693 -- | A list of all tests for this module.
695 odds_tests :: TestTree
699 [ test_on_delete_cascade,
700 test_pickle_of_unpickle_is_identity,
701 test_unpickle_succeeds ]
704 -- | If we unpickle something and then pickle it, we should wind up
705 -- with the same thing we started with. WARNING: success of this
706 -- test does not mean that unpickling succeeded.
708 test_pickle_of_unpickle_is_identity :: TestTree
709 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
710 [ check "pickle composed with unpickle is the identity"
711 "test/xml/Odds_XML.xml",
713 check "pickle composed with unpickle is the identity (non-int team_id)"
714 "test/xml/Odds_XML-noninteger-team-id.xml",
716 check "pickle composed with unpickle is the identity (positive(+) line)"
717 "test/xml/Odds_XML-positive-line.xml",
719 check "pickle composed with unpickle is the identity (large file)"
720 "test/xml/Odds_XML-largefile.xml",
722 check "pickle composed with unpickle is the identity (league name)"
723 "test/xml/Odds_XML-league-name.xml" ]
725 check desc path = testCase desc $ do
726 (expected, actual) <- pickle_unpickle pickle_message path
730 -- | Make sure we can actually unpickle these things.
732 test_unpickle_succeeds :: TestTree
733 test_unpickle_succeeds = testGroup "unpickle tests"
734 [ check "unpickling succeeds"
735 "test/xml/Odds_XML.xml",
737 check "unpickling succeeds (non-int team_id)"
738 "test/xml/Odds_XML-noninteger-team-id.xml",
740 check "unpickling succeeds (positive(+) line)"
741 "test/xml/Odds_XML-positive-line.xml",
743 check "unpickling succeeds (large file)"
744 "test/xml/Odds_XML-largefile.xml",
746 check "unpickling succeeds (league name)"
747 "test/xml/Odds_XML-league-name.xml" ]
749 check desc path = testCase desc $ do
750 actual <- unpickleable path pickle_message
755 -- | Make sure everything gets deleted when we delete the top-level
756 -- record. The casinos and teams should be left behind.
758 test_on_delete_cascade :: TestTree
759 test_on_delete_cascade = testGroup "cascading delete tests"
760 [ check "deleting odds deletes its children"
761 "test/xml/Odds_XML.xml"
762 13 -- 5 casinos, 8 teams
765 check "deleting odds deletes its children (non-int team_id)"
766 "test/xml/Odds_XML-noninteger-team-id.xml"
767 51 -- 5 casinos, 46 teams
770 check "deleting odds deleted its children (positive(+) line)"
771 "test/xml/Odds_XML-positive-line.xml"
772 17 -- 5 casinos, 12 teams
775 check "deleting odds deleted its children (large file)"
776 "test/xml/Odds_XML-largefile.xml"
777 189 -- 5 casinos, 184 teams
779 check "deleting odds deleted its children (league name)"
780 "test/xml/Odds_XML-league-name.xml"
781 35 -- 5 casinos, 30 teams
784 check desc path expected = testCase desc $ do
785 odds <- unsafe_unpickle path pickle_message
786 let a = undefined :: Team
787 let b = undefined :: Odds
788 let c = undefined :: OddsCasino
789 let d = undefined :: OddsGame
790 let e = undefined :: OddsGameLine
791 actual <- withSqliteConn ":memory:" $ runDbConn $ do
792 runMigration silentMigrationLogger $ do
800 count_a <- countAll a
801 count_b <- countAll b
802 count_c <- countAll c
803 count_d <- countAll d
804 count_e <- countAll e
805 return $ sum [count_a, count_b, count_c,