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 (
67 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
68 import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
69 import TSN.Team ( Team(..) )
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
150 -- * OddsGameHomeTeamXml / OddsGameAwayTeamXml
152 -- | The XML representation of a \<HomeTeam\>, as found in \<Game\>s.
153 -- This is basically the same as 'OddsGameAwayTeamXml', but the two
154 -- types have different picklers.
156 data OddsGameHomeTeamXml =
157 OddsGameHomeTeamXml {
158 xml_home_team_id :: String, -- ^ The home/away team IDs
159 -- are three characters but
160 -- Postgres imposes no
161 -- performance penalty on
162 -- lengthless text fields,
163 -- so we ignore the probable
164 -- upper bound of three
166 xml_home_rotation_number :: Int,
167 xml_home_abbr :: String,
168 xml_home_team_name :: String,
169 xml_home_casinos :: [OddsGameCasinoXml] }
172 instance ToDb OddsGameHomeTeamXml where
173 -- | The database representation of an 'OddsGameHomeTeamXml' is an
176 type Db OddsGameHomeTeamXml = Team
178 instance FromXml OddsGameHomeTeamXml where
179 -- | We convert from XML to the database by dropping the lines and
180 -- rotation number (which are specific to the games, not the teams
183 from_xml OddsGameHomeTeamXml{..} =
185 team_id = xml_home_team_id,
186 team_abbreviation = xml_home_abbr,
187 team_name = xml_home_team_name }
189 -- | This allows us to insert the XML representation
190 -- 'OddsGameHomeTeamXml' directly.
192 instance XmlImport OddsGameHomeTeamXml where
196 -- | The XML representation of a \<AwayTeam\>, as found in \<Game\>s.
197 -- This is basically the same as 'OddsGameHomeTeamXml', but the two
198 -- types have different picklers.
200 data OddsGameAwayTeamXml =
201 OddsGameAwayTeamXml {
202 xml_away_team_id :: String, -- ^ The home/away team IDs are
203 -- three characters but Postgres
204 -- imposes no performance penalty
205 -- on lengthless text fields, so
206 -- we ignore the probable upper
207 -- bound of three characters
208 xml_away_rotation_number :: Int,
209 xml_away_abbr :: String,
210 xml_away_team_name :: String,
211 xml_away_casinos :: [OddsGameCasinoXml] }
214 instance ToDb OddsGameAwayTeamXml where
215 -- | The database representation of an 'OddsGameAwayTeamXml' is a
218 type Db OddsGameAwayTeamXml = Team
220 instance FromXml OddsGameAwayTeamXml where
221 -- | We convert from XML to the database by dropping the lines and
222 -- rotation number (which are specific to the games, not the teams
225 from_xml OddsGameAwayTeamXml{..} = Team
230 -- | This allows us to insert the XML representation
231 -- 'OddsGameAwayTeamXml' directly.
233 instance XmlImport OddsGameAwayTeamXml where
236 -- * OddsGame_OddsGameTeam
238 -- | Database mapping between games and their home/away teams.
242 ogt_odds_games_id :: DefaultKey OddsGame,
243 ogt_away_team_id :: DefaultKey Team,
244 ogt_home_team_id :: DefaultKey Team }
247 -- * OddsGameOverUnderXml
249 -- | XML representation of the over/under. A wrapper around a bunch of
252 newtype OddsGameOverUnderXml =
253 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
259 -- | This database representation of the casino lines can't be
260 -- constructed from the one in the XML. The casinos within
261 -- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or
262 -- less the same. We don't need a bajillion different tables to
263 -- store that, just one tying the casino/game pair to the three
266 -- The one small difference between the over/under casinos and the
267 -- home/away ones is that the home/away lines are all 'Double's, but
268 -- the over/under lines appear to be textual.
272 ogl_odds_games_id :: DefaultKey OddsGame,
273 ogl_odds_casinos_id :: DefaultKey OddsCasino,
274 ogl_over_under :: Maybe String,
275 ogl_away_line :: Maybe Double,
276 ogl_home_line :: Maybe Double }
279 -- * OddsGame/OddsGameXml
281 -- | Database representation of a game. We retain the rotation number
282 -- of the home/away teams, since those are specific to the game and
287 db_odds_id :: DefaultKey Odds,
289 db_game_time :: UTCTime, -- ^ Contains both the date and time.
290 db_game_away_team_rotation_number :: Int,
291 db_game_home_team_rotation_number :: Int }
294 -- | XML representation of an 'OddsGame'.
299 xml_game_date :: UTCTime, -- ^ Contains only the date
300 xml_game_time :: UTCTime, -- ^ Contains only the time
301 xml_game_away_team :: OddsGameAwayTeamXml,
302 xml_game_home_team :: OddsGameHomeTeamXml,
303 xml_game_over_under :: OddsGameOverUnderXml }
306 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
307 -- xml_game_over_under.
309 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
310 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
313 instance ToDb OddsGameXml where
314 -- | The database representation of an 'OddsGameXml' is an
317 type Db OddsGameXml = OddsGame
319 instance FromXmlFk OddsGameXml where
320 -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words
321 -- the foreign key for 'OddsGame' points to an 'Odds'.
323 type Parent OddsGameXml = Odds
325 -- | To convert from the XML representation to the database one, we
326 -- drop the home/away teams and the casino lines, but retain the
327 -- home/away rotation numbers.
329 from_xml_fk fk OddsGameXml{..} =
332 db_game_id = xml_game_id,
334 db_game_time = UTCTime
335 (utctDay xml_game_date) -- Take the day part from one,
336 (utctDayTime xml_game_time), -- the time from the other.
338 db_game_away_team_rotation_number =
339 (xml_away_rotation_number xml_game_away_team),
341 db_game_home_team_rotation_number =
342 (xml_home_rotation_number xml_game_home_team) }
344 -- | This lets us insert the XML representation 'OddsGameXml' directly.
346 instance XmlImportFk 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 data OddsGameWithNotes =
367 game :: OddsGameXml }
373 -- | Database representation of a 'Message'.
377 db_xml_file_id :: Int,
380 db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
381 -- because their timezones are ambiguous
382 -- (and the date is less than useful when
383 -- it might be off by an hour).
384 db_time_stamp :: UTCTime }
387 -- | The XML representation of 'Odds'.
391 xml_xml_file_id :: Int,
392 xml_heading :: String,
393 xml_category :: String,
396 xml_line_time :: String,
397 xml_games_with_notes :: [OddsGameWithNotes],
398 xml_time_stamp :: UTCTime }
401 -- | Pseudo-field that lets us get the 'OddsGame's out of
402 -- 'xml_games_with_notes'.
404 xml_games :: Message -> [OddsGameXml]
405 xml_games m = map game (xml_games_with_notes m)
408 instance ToDb Message where
409 -- | The database representation of a 'Message' is 'Odds'.
411 type Db Message = Odds
413 instance FromXml Message where
414 -- | To convert from the XML representation to the database one, we
415 -- just drop a bunch of fields.
417 from_xml Message{..} =
419 db_xml_file_id = xml_xml_file_id,
420 db_sport = xml_sport,
421 db_title = xml_title,
422 db_line_time = xml_line_time,
423 db_time_stamp = xml_time_stamp }
425 -- | This lets us insert the XML representation 'Message' directly.
427 instance XmlImport Message
434 -- Groundhog database schema. This must come before the DbImport
435 -- instance definition. Don't know why.
436 mkPersist tsn_codegen_config [groundhog|
443 # Prevent multiple imports of the same message.
444 fields: [db_xml_file_id]
451 - name: unique_odds_casino
453 fields: [casino_client_id]
464 - entity: OddsGameLine
465 dbName: odds_games_lines
469 - name: ogl_odds_games_id
472 - name: ogl_odds_casinos_id
476 - entity: OddsGame_Team
477 dbName: odds_games__teams
479 - name: OddsGame_Team
481 - name: ogt_odds_games_id
484 - name: ogt_away_team_id
487 - name: ogt_home_team_id
492 instance DbImport Message where
495 migrate (undefined :: Team)
496 migrate (undefined :: Odds)
497 migrate (undefined :: OddsCasino)
498 migrate (undefined :: OddsGame)
499 migrate (undefined :: OddsGame_Team)
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) $ \g -> do
507 -- Next, we insert the home and away teams. We do this before
508 -- inserting the game itself because the game has two foreign keys
509 -- pointing to "teams".
510 away_team_id <- insert_xml_or_select (xml_game_away_team g)
511 home_team_id <- insert_xml_or_select (xml_game_home_team g)
513 -- Now insert the game, keyed to the "odds",
514 game_id <- insert_xml_fk odds_id g
516 -- Insert a record into odds_games__teams mapping the
517 -- home/away teams to this game. Use the full record syntax
518 -- because the types would let us mix up the home/away teams.
519 insert_ OddsGame_Team {
520 ogt_odds_games_id = game_id,
521 ogt_away_team_id = away_team_id,
522 ogt_home_team_id = home_team_id }
524 -- Finaly, we insert the lines. The over/under entries for this
525 -- game and the lines for the casinos all wind up in the same
526 -- table, odds_games_lines. We can insert the over/under entries
527 -- freely with empty away/home lines:
528 forM_ (xml_game_over_under_casinos g) $ \c -> do
529 -- Start by inderting the casino.
530 ou_casino_id <- insert_xml_or_select c
532 -- Now add the over/under entry with the casino's id.
533 let ogl = OddsGameLine {
534 ogl_odds_games_id = game_id,
535 ogl_odds_casinos_id = ou_casino_id,
536 ogl_over_under = (xml_casino_line c),
537 ogl_away_line = Nothing,
538 ogl_home_line = Nothing }
542 -- ...but then when we insert the home/away team lines, we
543 -- prefer to update the existing entry rather than overwrite it
544 -- or add a new record.
545 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c -> do
546 -- insert, or more likely retrieve the existing, casino
547 a_casino_id <- insert_xml_or_select c
549 -- Get a Maybe Double instead of the Maybe String that's in there.
550 let away_line = home_away_line c
552 -- Unconditionally update that casino's away team line with ours.
553 update [Ogl_Away_Line =. away_line] $ -- WHERE
554 Ogl_Odds_Casinos_Id ==. a_casino_id
556 -- Repeat all that for the home team.
557 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
558 h_casino_id <- insert_xml_or_select c
559 let home_line = home_away_line c
560 update [Ogl_Home_Line =. home_line] $ -- WHERE
561 Ogl_Odds_Casinos_Id ==. h_casino_id
565 return ImportSucceeded
572 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
574 pickle_game_with_notes :: PU OddsGameWithNotes
575 pickle_game_with_notes =
576 xpWrap (from_pair, to_pair) $
578 (xpList $ xpElem "Notes" xpText)
581 from_pair = uncurry OddsGameWithNotes
582 to_pair OddsGameWithNotes{..} = (notes, game)
585 -- | Pickler for an 'OddsGameCasinoXml'.
587 pickle_casino :: PU OddsGameCasinoXml
590 xpWrap (from_tuple, to_tuple) $
592 (xpAttr "ClientID" xpInt)
593 (xpAttr "Name" xpText)
596 from_tuple = uncurryN OddsGameCasinoXml
597 -- Use record wildcards to avoid unused field warnings.
598 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
603 -- | Pickler for an 'OddsGameHomeTeamXml'.
605 pickle_home_team :: PU OddsGameHomeTeamXml
608 xpWrap (from_tuple, to_tuple) $
610 (xpElem "HomeTeamID" xpText)
611 (xpElem "HomeRotationNumber" xpInt)
612 (xpElem "HomeAbbr" xpText)
613 (xpElem "HomeTeamName" xpText)
614 (xpList pickle_casino)
616 from_tuple = uncurryN OddsGameHomeTeamXml
617 -- Use record wildcards to avoid unused field warnings.
618 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
619 xml_home_rotation_number,
625 -- | Pickler for an 'OddsGameAwayTeamXml'.
627 pickle_away_team :: PU OddsGameAwayTeamXml
630 xpWrap (from_tuple, to_tuple) $
632 (xpElem "AwayTeamID" xpText)
633 (xpElem "AwayRotationNumber" xpInt)
634 (xpElem "AwayAbbr" xpText)
635 (xpElem "AwayTeamName" xpText)
636 (xpList pickle_casino)
638 from_tuple = uncurryN OddsGameAwayTeamXml
639 -- Use record wildcards to avoid unused field warnings.
640 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
641 xml_away_rotation_number,
648 -- | Pickler for an 'OddsGameOverUnderXml'.
650 pickle_over_under :: PU OddsGameOverUnderXml
652 xpElem "Over_Under" $
653 xpWrap (to_newtype, from_newtype) $
656 from_newtype (OddsGameOverUnderXml cs) = cs
657 to_newtype = OddsGameOverUnderXml
660 -- | Pickler for an 'OddsGameXml'.
662 pickle_game :: PU OddsGameXml
665 xpWrap (from_tuple, to_tuple) $
667 (xpElem "GameID" xpInt)
668 (xpElem "Game_Date" xp_date_padded)
669 (xpElem "Game_Time" xp_time)
674 from_tuple = uncurryN OddsGameXml
675 -- Use record wildcards to avoid unused field warnings.
676 to_tuple OddsGameXml{..} = (xml_game_id,
684 -- | Pickler for the top-level 'Message'.
686 pickle_message :: PU Message
689 xpWrap (from_tuple, to_tuple) $
690 xp8Tuple (xpElem "XML_File_ID" xpInt)
691 (xpElem "heading" xpText)
692 (xpElem "category" xpText)
693 (xpElem "sport" xpText)
694 (xpElem "Title" xpText)
695 (xpElem "Line_Time" xpText)
696 (xpList pickle_game_with_notes)
697 (xpElem "time_stamp" xp_time_stamp)
699 from_tuple = uncurryN Message
700 to_tuple m = (xml_xml_file_id m,
706 xml_games_with_notes m,
714 -- | A list of all tests for this module.
716 odds_tests :: TestTree
720 [ test_on_delete_cascade,
721 test_pickle_of_unpickle_is_identity,
722 test_unpickle_succeeds ]
725 -- | If we unpickle something and then pickle it, we should wind up
726 -- with the same thing we started with. WARNING: success of this
727 -- test does not mean that unpickling succeeded.
729 test_pickle_of_unpickle_is_identity :: TestTree
730 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
731 [ check "pickle composed with unpickle is the identity"
732 "test/xml/Odds_XML.xml",
734 check "pickle composed with unpickle is the identity (non-int team_id)"
735 "test/xml/Odds_XML-noninteger-team-id.xml",
737 check "pickle composed with unpickle is the identity (positive(+) line)"
738 "test/xml/Odds_XML-positive-line.xml",
740 check "pickle composed with unpickle is the identity (large file)"
741 "test/xml/Odds_XML-largefile.xml" ]
743 check desc path = testCase desc $ do
744 (expected, actual) <- pickle_unpickle pickle_message path
748 -- | Make sure we can actually unpickle these things.
750 test_unpickle_succeeds :: TestTree
751 test_unpickle_succeeds = testGroup "unpickle tests"
752 [ check "unpickling succeeds"
753 "test/xml/Odds_XML.xml",
755 check "unpickling succeeds (non-int team_id)"
756 "test/xml/Odds_XML-noninteger-team-id.xml",
758 check "unpickling succeeds (positive(+) line)"
759 "test/xml/Odds_XML-positive-line.xml",
761 check "unpickling succeeds (large file)"
762 "test/xml/Odds_XML-largefile.xml" ]
764 check desc path = testCase desc $ do
765 actual <- unpickleable path pickle_message
770 -- | Make sure everything gets deleted when we delete the top-level
771 -- record. The casinos and teams should be left behind.
773 test_on_delete_cascade :: TestTree
774 test_on_delete_cascade = testGroup "cascading delete tests"
775 [ check "deleting odds deletes its children"
776 "test/xml/Odds_XML.xml"
777 13 -- 5 casinos, 8 teams
780 check "deleting odds deletes its children (non-int team_id)"
781 "test/xml/Odds_XML-noninteger-team-id.xml"
782 51 -- 5 casinos, 46 teams
785 check "deleting odds deleted its children (positive(+) line)"
786 "test/xml/Odds_XML-positive-line.xml"
787 17 -- 5 casinos, 12 teams
790 check "deleting odds deleted its children (large file)"
791 "test/xml/Odds_XML-largefile.xml"
792 189 -- 5 casinos, 184 teams
795 check desc path expected = testCase desc $ do
796 odds <- unsafe_unpickle path pickle_message
797 let a = undefined :: Team
798 let b = undefined :: Odds
799 let c = undefined :: OddsCasino
800 let d = undefined :: OddsGame
801 let e = undefined :: OddsGame_Team
802 let f = undefined :: OddsGameLine
803 actual <- withSqliteConn ":memory:" $ runDbConn $ do
804 runMigration silentMigrationLogger $ do
813 count_a <- countAll a
814 count_b <- countAll b
815 count_c <- countAll c
816 count_d <- countAll d
817 count_e <- countAll e
818 count_f <- countAll f
819 return $ sum [count_a, count_b, count_c,
820 count_d, count_e, count_f ]