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_OddsGameTeamConstructor(..),
22 OddsGameConstructor(..),
23 OddsGameLineConstructor(..),
24 OddsGameTeamConstructor(..) )
28 import Control.Monad ( forM_, join )
29 import Data.Time ( UTCTime(..) )
30 import Data.Tuple.Curry ( uncurryN )
31 import Database.Groundhog (
39 silentMigrationLogger,
41 import Database.Groundhog.Core ( DefaultKey )
42 import Database.Groundhog.Generic ( runDbConn )
43 import Database.Groundhog.Sqlite ( withSqliteConn )
44 import Database.Groundhog.TH (
47 import Test.Tasty ( TestTree, testGroup )
48 import Test.Tasty.HUnit ( (@?=), testCase )
49 import Text.Read ( readMaybe )
50 import Text.XML.HXT.Core (
68 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
69 import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
70 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
80 -- | The DTD to which this module corresponds. Used to invoke dbimport.
90 -- * OddsGameCasino/OddsGameCasinoXml
93 -- | The casinos should have their own table, but the lines don't
94 -- belong in that table (there is a separate table for
95 -- 'OddsGameLine' which associates the two).
97 -- We drop the \"Game\" prefix because the casinos really aren't
98 -- children of the games; the XML just makes it seem that way.
102 casino_client_id :: Int,
103 casino_name :: String }
107 -- | The home/away lines are 'Double's, but the over/under lines are
108 -- textual. If we want to use one data type for both, we have to go
109 -- with a 'String' and then attempt to 'read' a 'Double' later when we
110 -- go to insert the thing.
112 data OddsGameCasinoXml =
114 xml_casino_client_id :: Int,
115 xml_casino_name :: String,
116 xml_casino_line :: Maybe String }
120 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
121 -- priori textual (because it might be an over/under line).
123 home_away_line :: OddsGameCasinoXml -> Maybe Double
124 home_away_line = join . (fmap readMaybe) . xml_casino_line
128 instance ToDb OddsGameCasinoXml where
129 -- | The database representation of an 'OddsGameCasinoXml' is an
132 type Db OddsGameCasinoXml = OddsCasino
135 instance FromXml OddsGameCasinoXml where
136 -- | We convert from XML to the database by dropping the line field.
138 from_xml OddsGameCasinoXml{..} =
140 casino_client_id = xml_casino_client_id,
141 casino_name = xml_casino_name }
144 -- | This allows us to insert the XML representation 'OddsGameCasinoXml'
147 instance XmlImport OddsGameCasinoXml
153 -- | The database representation of teams as they appear in odds
158 db_team_id :: String, -- ^ The home/away team IDs are
159 -- three characters but Postgres
160 -- imposes no performance penalty
161 -- on lengthless text fields, so
162 -- we ignore the probable upper
163 -- bound of three characters.
165 db_team_name :: String }
169 -- * OddsGameHomeTeam/OddsGameHomeTeamXml
171 -- | The XML representation of a \<HomeTeam\>, as found in \<Game\>s.
173 data OddsGameHomeTeamXml =
174 OddsGameHomeTeamXml {
175 xml_home_team_id :: String, -- ^ The home/away team IDs
176 -- are three characters but
177 -- Postgres imposes no
178 -- performance penalty on
179 -- lengthless text fields,
180 -- so we ignore the probable
181 -- upper bound of three
183 xml_home_rotation_number :: Int,
184 xml_home_abbr :: String,
185 xml_home_team_name :: String,
186 xml_home_casinos :: [OddsGameCasinoXml] }
189 instance ToDb OddsGameHomeTeamXml where
190 -- | The database representation of an 'OddsGameHomeTeamXml' is an
193 type Db OddsGameHomeTeamXml = OddsGameTeam
195 instance FromXml OddsGameHomeTeamXml where
196 -- | We convert from XML to the database by dropping the lines and
197 -- rotation number (which are specific to the games, not the teams
200 from_xml OddsGameHomeTeamXml{..} =
202 db_team_id = xml_home_team_id,
203 db_abbr = xml_home_abbr,
204 db_team_name = xml_home_team_name }
206 -- | This allows us to insert the XML representation
207 -- 'OddsGameHomeTeamXml' directly.
209 instance XmlImport OddsGameHomeTeamXml where
212 -- * OddsGameAwayTeam/OddsGameAwayTeamXml
214 -- | The XML representation of a \<AwayTeam\>, as found in \<Game\>s.
216 data OddsGameAwayTeamXml =
217 OddsGameAwayTeamXml {
218 xml_away_team_id :: String, -- ^ The home/away team IDs are
219 -- three characters but Postgres
220 -- imposes no performance penalty
221 -- on lengthless text fields, so
222 -- we ignore the probable upper
223 -- bound of three characters
224 xml_away_rotation_number :: Int,
225 xml_away_abbr :: String,
226 xml_away_team_name :: String,
227 xml_away_casinos :: [OddsGameCasinoXml] }
230 instance ToDb OddsGameAwayTeamXml where
231 -- | The database representation of an 'OddsGameAwayTeamXml' is an
234 type Db OddsGameAwayTeamXml = OddsGameTeam
236 instance FromXml OddsGameAwayTeamXml where
237 -- | We convert from XML to the database by dropping the lines and
238 -- rotation number (which are specific to the games, not the teams
241 from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
246 -- | This allows us to insert the XML representation
247 -- 'OddsGameAwayTeamXml' directly.
249 instance XmlImport OddsGameAwayTeamXml where
252 -- * OddsGame_OddsGameTeam
254 -- | Database mapping between games and their home/away teams.
256 data OddsGame_OddsGameTeam =
257 OddsGame_OddsGameTeam {
258 ogogt_odds_games_id :: DefaultKey OddsGame,
259 ogogt_away_team_id :: DefaultKey OddsGameTeam,
260 ogogt_home_team_id :: DefaultKey OddsGameTeam }
263 -- * OddsGameOverUnderXml
265 -- | XML representation of the over/under. A wrapper around a bunch of
268 newtype OddsGameOverUnderXml =
269 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
275 -- | This database representation of the casino lines can't be
276 -- constructed from the one in the XML. The casinos within
277 -- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or
278 -- less the same. We don't need a bajillion different tables to
279 -- store that, just one tying the casino/game pair to the three
282 -- The one small difference between the over/under casinos and the
283 -- home/away ones is that the home/away lines are all 'Double's, but
284 -- the over/under lines appear to be textual.
288 ogl_odds_games_id :: DefaultKey OddsGame,
289 ogl_odds_casinos_id :: DefaultKey OddsCasino,
290 ogl_over_under :: Maybe String,
291 ogl_away_line :: Maybe Double,
292 ogl_home_line :: Maybe Double }
295 -- * OddsGame/OddsGameXml
297 -- | Database representation of a game. We retain the rotation number
298 -- of the home/away teams, since those are specific to the game and
303 db_odds_id :: DefaultKey Odds,
305 db_game_time :: UTCTime, -- ^ Contains both the date and time.
306 db_game_away_team_rotation_number :: Int,
307 db_game_home_team_rotation_number :: Int }
310 -- | XML representation of an 'OddsGame'.
315 xml_game_date :: UTCTime, -- ^ Contains only the date
316 xml_game_time :: UTCTime, -- ^ Contains only the time
317 xml_game_away_team :: OddsGameAwayTeamXml,
318 xml_game_home_team :: OddsGameHomeTeamXml,
319 xml_game_over_under :: OddsGameOverUnderXml }
322 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
323 -- xml_game_over_under.
325 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
326 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
329 instance ToDb OddsGameXml where
330 -- | The database representation of an 'OddsGameXml' is an
333 type Db OddsGameXml = OddsGame
335 instance FromXmlFk OddsGameXml where
336 -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words
337 -- the foreign key for 'OddsGame' points to an 'Odds'.
339 type Parent OddsGameXml = Odds
341 -- | To convert from the XML representation to the database one, we
342 -- drop the home/away teams and the casino lines, but retain the
343 -- home/away rotation numbers.
345 from_xml_fk fk OddsGameXml{..} =
348 db_game_id = xml_game_id,
350 db_game_time = UTCTime
351 (utctDay xml_game_date) -- Take the day part from one,
352 (utctDayTime xml_game_time), -- the time from the other.
354 db_game_away_team_rotation_number =
355 (xml_away_rotation_number xml_game_away_team),
357 db_game_home_team_rotation_number =
358 (xml_home_rotation_number xml_game_home_team) }
360 -- | This lets us insert the XML representation 'OddsGameXml' directly.
362 instance XmlImportFk OddsGameXml
365 -- * OddsGameWithNotes
367 -- | This is our best guess at what occurs in the Odds_XML
368 -- documents. It looks like each consecutive set of games can
369 -- optionally have some notes appear before it. Each \"note\" comes
370 -- as its own \<Notes\>...\</Notes\> element.
372 -- The notes are ignored completely in the database; we only bother
373 -- with them to ensure that we're (un)pickling correctly.
375 -- We can't group the notes with a \"set\" of 'OddsGame's, because
376 -- that leads to ambiguity in parsing. Since we're going to ignore
377 -- the notes anyway, we just stick them with an arbitrary
378 -- game. C'est la vie.
380 data OddsGameWithNotes =
383 game :: OddsGameXml }
389 -- | Database representation of a 'Message'.
393 db_xml_file_id :: Int,
396 db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
397 -- because their timezones are ambiguous
398 -- (and the date is less than useful when
399 -- it might be off by an hour).
400 db_time_stamp :: UTCTime }
403 -- | The XML representation of 'Odds'.
407 xml_xml_file_id :: Int,
408 xml_heading :: String,
409 xml_category :: String,
412 xml_line_time :: String,
413 xml_games_with_notes :: [OddsGameWithNotes],
414 xml_time_stamp :: UTCTime }
417 -- | Pseudo-field that lets us get the 'OddsGame's out of
418 -- 'xml_games_with_notes'.
420 xml_games :: Message -> [OddsGameXml]
421 xml_games m = map game (xml_games_with_notes m)
424 instance ToDb Message where
425 -- | The database representation of a 'Message' is 'Odds'.
427 type Db Message = Odds
429 instance FromXml Message where
430 -- | To convert from the XML representation to the database one, we
431 -- just drop a bunch of fields.
433 from_xml Message{..} =
435 db_xml_file_id = xml_xml_file_id,
436 db_sport = xml_sport,
437 db_title = xml_title,
438 db_line_time = xml_line_time,
439 db_time_stamp = xml_time_stamp }
441 -- | This lets us insert the XML representation 'Message' directly.
443 instance XmlImport Message
450 -- Groundhog database schema. This must come before the DbImport
451 -- instance definition. Don't know why.
452 mkPersist tsn_codegen_config [groundhog|
459 # Prevent multiple imports of the same message.
460 fields: [db_xml_file_id]
467 - name: unique_odds_casino
469 fields: [casino_client_id]
471 - entity: OddsGameTeam
472 dbName: odds_games_teams
476 - name: unique_odds_games_team
490 - entity: OddsGameLine
491 dbName: odds_games_lines
495 - name: ogl_odds_games_id
498 - name: ogl_odds_casinos_id
502 - entity: OddsGame_OddsGameTeam
503 dbName: odds_games__odds_games_teams
505 - name: OddsGame_OddsGameTeam
507 - name: ogogt_odds_games_id
510 - name: ogogt_away_team_id
513 - name: ogogt_home_team_id
518 instance DbImport Message where
521 migrate (undefined :: Odds)
522 migrate (undefined :: OddsCasino)
523 migrate (undefined :: OddsGameTeam)
524 migrate (undefined :: OddsGame)
525 migrate (undefined :: OddsGame_OddsGameTeam)
526 migrate (undefined :: OddsGameLine)
529 -- Insert the root "odds" element and acquire its primary key (id).
530 odds_id <- insert_xml m
532 forM_ (xml_games m) $ \g -> do
533 -- Next, we insert the home and away teams. We do this before
534 -- inserting the game itself because the game has two foreign keys
535 -- pointing to odds_games_teams.
536 -- Next to insert the home and away teams.
537 away_team_id <- insert_xml_or_select (xml_game_away_team g)
538 home_team_id <- insert_xml_or_select (xml_game_home_team g)
540 -- Now insert the game, keyed to the "odds",
541 game_id <- insert_xml_fk odds_id g
543 -- Insert a record into odds_games__odds_games_teams mapping the
544 -- home/away teams to this game. Use the full record syntax
545 -- because the types would let us mix up the home/away teams.
546 insert_ OddsGame_OddsGameTeam {
547 ogogt_odds_games_id = game_id,
548 ogogt_away_team_id = away_team_id,
549 ogogt_home_team_id = home_team_id }
551 -- Finaly, we insert the lines. The over/under entries for this
552 -- game and the lines for the casinos all wind up in the same
553 -- table, odds_games_lines. We can insert the over/under entries
554 -- freely with empty away/home lines:
555 forM_ (xml_game_over_under_casinos g) $ \c -> do
556 -- Start by inderting the casino.
557 ou_casino_id <- insert_xml_or_select c
559 -- Now add the over/under entry with the casino's id.
560 let ogl = OddsGameLine {
561 ogl_odds_games_id = game_id,
562 ogl_odds_casinos_id = ou_casino_id,
563 ogl_over_under = (xml_casino_line c),
564 ogl_away_line = Nothing,
565 ogl_home_line = Nothing }
569 -- ...but then when we insert the home/away team lines, we
570 -- prefer to update the existing entry rather than overwrite it
571 -- or add a new record.
572 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c -> do
573 -- insert, or more likely retrieve the existing, casino
574 a_casino_id <- insert_xml_or_select c
576 -- Get a Maybe Double instead of the Maybe String that's in there.
577 let away_line = home_away_line c
579 -- Unconditionally update that casino's away team line with ours.
580 update [Ogl_Away_Line =. away_line] $ -- WHERE
581 Ogl_Odds_Casinos_Id ==. a_casino_id
583 -- Repeat all that for the home team.
584 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
585 h_casino_id <- insert_xml_or_select c
586 let home_line = home_away_line c
587 update [Ogl_Home_Line =. home_line] $ -- WHERE
588 Ogl_Odds_Casinos_Id ==. h_casino_id
592 return ImportSucceeded
599 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
601 pickle_game_with_notes :: PU OddsGameWithNotes
602 pickle_game_with_notes =
603 xpWrap (from_pair, to_pair) $
605 (xpList $ xpElem "Notes" xpText)
608 from_pair = uncurry OddsGameWithNotes
609 to_pair OddsGameWithNotes{..} = (notes, game)
612 -- | Pickler for an 'OddsGameCasinoXml'.
614 pickle_casino :: PU OddsGameCasinoXml
617 xpWrap (from_tuple, to_tuple) $
619 (xpAttr "ClientID" xpInt)
620 (xpAttr "Name" xpText)
623 from_tuple = uncurryN OddsGameCasinoXml
624 -- Use record wildcards to avoid unused field warnings.
625 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
630 -- | Pickler for an 'OddsGameHomeTeamXml'.
632 pickle_home_team :: PU OddsGameHomeTeamXml
635 xpWrap (from_tuple, to_tuple) $
637 (xpElem "HomeTeamID" xpText)
638 (xpElem "HomeRotationNumber" xpInt)
639 (xpElem "HomeAbbr" xpText)
640 (xpElem "HomeTeamName" xpText)
641 (xpList pickle_casino)
643 from_tuple = uncurryN OddsGameHomeTeamXml
644 -- Use record wildcards to avoid unused field warnings.
645 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
646 xml_home_rotation_number,
652 -- | Pickler for an 'OddsGameAwayTeamXml'.
654 pickle_away_team :: PU OddsGameAwayTeamXml
657 xpWrap (from_tuple, to_tuple) $
659 (xpElem "AwayTeamID" xpText)
660 (xpElem "AwayRotationNumber" xpInt)
661 (xpElem "AwayAbbr" xpText)
662 (xpElem "AwayTeamName" xpText)
663 (xpList pickle_casino)
665 from_tuple = uncurryN OddsGameAwayTeamXml
666 -- Use record wildcards to avoid unused field warnings.
667 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
668 xml_away_rotation_number,
675 -- | Pickler for an 'OddsGameOverUnderXml'.
677 pickle_over_under :: PU OddsGameOverUnderXml
679 xpElem "Over_Under" $
680 xpWrap (to_newtype, from_newtype) $
683 from_newtype (OddsGameOverUnderXml cs) = cs
684 to_newtype = OddsGameOverUnderXml
687 -- | Pickler for an 'OddsGameXml'.
689 pickle_game :: PU OddsGameXml
692 xpWrap (from_tuple, to_tuple) $
694 (xpElem "GameID" xpInt)
695 (xpElem "Game_Date" xp_date_padded)
696 (xpElem "Game_Time" xp_time)
701 from_tuple = uncurryN OddsGameXml
702 -- Use record wildcards to avoid unused field warnings.
703 to_tuple OddsGameXml{..} = (xml_game_id,
711 -- | Pickler for the top-level 'Message'.
713 pickle_message :: PU Message
716 xpWrap (from_tuple, to_tuple) $
717 xp8Tuple (xpElem "XML_File_ID" xpInt)
718 (xpElem "heading" xpText)
719 (xpElem "category" xpText)
720 (xpElem "sport" xpText)
721 (xpElem "Title" xpText)
722 (xpElem "Line_Time" xpText)
723 (xpList pickle_game_with_notes)
724 (xpElem "time_stamp" xp_time_stamp)
726 from_tuple = uncurryN Message
727 to_tuple m = (xml_xml_file_id m,
733 xml_games_with_notes m,
741 -- | A list of all tests for this module.
743 odds_tests :: TestTree
747 [ test_on_delete_cascade,
748 test_pickle_of_unpickle_is_identity,
749 test_unpickle_succeeds ]
752 -- | If we unpickle something and then pickle it, we should wind up
753 -- with the same thing we started with. WARNING: success of this
754 -- test does not mean that unpickling succeeded.
756 test_pickle_of_unpickle_is_identity :: TestTree
757 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
758 [ check "pickle composed with unpickle is the identity"
759 "test/xml/Odds_XML.xml",
761 check "pickle composed with unpickle is the identity (non-int team_id)"
762 "test/xml/Odds_XML-noninteger-team-id.xml",
764 check "pickle composed with unpickle is the identity (positive(+) line)"
765 "test/xml/Odds_XML-positive-line.xml",
767 check "pickle composed with unpickle is the identity (large file)"
768 "test/xml/Odds_XML-largefile.xml" ]
770 check desc path = testCase desc $ do
771 (expected, actual) <- pickle_unpickle pickle_message path
775 -- | Make sure we can actually unpickle these things.
777 test_unpickle_succeeds :: TestTree
778 test_unpickle_succeeds = testGroup "unpickle tests"
779 [ check "unpickling succeeds"
780 "test/xml/Odds_XML.xml",
782 check "unpickling succeeds (non-int team_id)"
783 "test/xml/Odds_XML-noninteger-team-id.xml",
785 check "unpickling succeeds (positive(+) line)"
786 "test/xml/Odds_XML-positive-line.xml",
788 check "unpickling succeeds (large file)"
789 "test/xml/Odds_XML-largefile.xml" ]
791 check desc path = testCase desc $ do
792 actual <- unpickleable path pickle_message
797 -- | Make sure everything gets deleted when we delete the top-level
800 test_on_delete_cascade :: TestTree
801 test_on_delete_cascade = testGroup "cascading delete tests"
802 [ check "deleting odds deletes its children"
803 "test/xml/Odds_XML.xml"
804 13 -- 5 casinos, 8 teams
807 check "deleting odds deletes its children (non-int team_id)"
808 "test/xml/Odds_XML-noninteger-team-id.xml"
809 51 -- 5 casinos, 46 teams
812 check "deleting odds deleted its children (positive(+) line)"
813 "test/xml/Odds_XML-positive-line.xml"
814 17 -- 5 casinos, 12 teams
817 check "deleting odds deleted its children (large file)"
818 "test/xml/Odds_XML-largefile.xml"
819 189 -- 5 casinos, 184 teams
822 check desc path expected = testCase desc $ do
823 odds <- unsafe_unpickle path pickle_message
824 let a = undefined :: Odds
825 let b = undefined :: OddsCasino
826 let c = undefined :: OddsGameTeam
827 let d = undefined :: OddsGame
828 let e = undefined :: OddsGame_OddsGameTeam
829 let f = undefined :: OddsGameLine
830 actual <- withSqliteConn ":memory:" $ runDbConn $ do
831 runMigration silentMigrationLogger $ do
840 count_a <- countAll a
841 count_b <- countAll b
842 count_c <- countAll c
843 count_d <- countAll d
844 count_e <- countAll e
845 count_f <- countAll f
846 return $ sum [count_a, count_b, count_c,
847 count_d, count_e, count_f ]