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_time, xp_time_stamp )
68 import TSN.Team ( Team(..) )
69 import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
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
152 -- | The XML representation of a \<HomeTeam\> or \<AwayTeam\>, as
153 -- found in \<Game\>s. We can't use the 'Team' representation
154 -- directly because there are some other fields we need to parse.
156 -- The starter id/name could perhaps be combined into an embedded
157 -- type, but can you make an entire embedded type optional with
158 -- Maybe? I doubt it works.
160 data OddsGameTeamXml =
162 xml_team_id :: String, -- ^ The home/away team IDs
163 -- are three characters but
164 -- Postgres imposes no
165 -- performance penalty on
166 -- lengthless text fields,
167 -- so we ignore the probable
168 -- upper bound of three
170 xml_team_rotation_number :: Maybe Int,
171 xml_team_abbr :: String,
172 xml_team_name :: String,
173 xml_team_starter :: Maybe (Int, String), -- ^ (id, name)
174 xml_team_casinos :: [OddsGameCasinoXml] }
177 instance ToDb OddsGameTeamXml where
178 -- | The database representation of an 'OddsGameTeamXml' is an
181 type Db OddsGameTeamXml = Team
183 instance FromXml OddsGameTeamXml where
184 -- | We convert from XML to the database by dropping the lines and
185 -- rotation number (which are specific to the games, not the teams
188 from_xml OddsGameTeamXml{..} =
190 team_id = xml_team_id,
191 abbreviation = Just xml_team_abbr,
192 name = Just xml_team_name }
194 -- | This allows us to insert the XML representation
195 -- 'OddsGameTeamXml' directly.
197 instance XmlImport OddsGameTeamXml where
202 -- * OddsGameOverUnderXml
204 -- | XML representation of the over/under. A wrapper around a bunch of
207 newtype OddsGameOverUnderXml =
208 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
214 -- | This database representation of the casino lines can't be
215 -- constructed from the one in the XML. The casinos within
216 -- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or
217 -- less the same. We don't need a bajillion different tables to
218 -- store that, just one tying the casino/game pair to the three
221 -- The one small difference between the over/under casinos and the
222 -- home/away ones is that the home/away lines are all 'Double's, but
223 -- the over/under lines appear to be textual.
227 ogl_odds_games_id :: DefaultKey OddsGame,
228 ogl_odds_casinos_id :: DefaultKey OddsCasino,
229 ogl_over_under :: Maybe String,
230 ogl_away_line :: Maybe Double,
231 ogl_home_line :: Maybe Double }
234 -- * OddsGame/OddsGameXml
236 -- | Database representation of a game. We retain the rotation number
237 -- of the home/away teams, since those are specific to the game and
242 db_odds_id :: DefaultKey Odds,
243 db_away_team_id :: DefaultKey Team,
244 db_home_team_id :: DefaultKey Team,
246 db_game_time :: UTCTime, -- ^ Contains both the date and time.
247 db_away_team_rotation_number :: Maybe Int,
248 db_home_team_rotation_number :: Maybe Int,
249 db_away_team_starter_id :: Maybe Int,
250 db_away_team_starter_name :: Maybe String,
251 db_home_team_starter_id :: Maybe Int,
252 db_home_team_starter_name :: Maybe String }
255 -- | XML representation of an 'OddsGame'.
260 xml_game_date :: UTCTime, -- ^ Contains only the date
261 xml_game_time :: UTCTime, -- ^ Contains only the time
262 xml_away_team :: OddsGameTeamXml,
263 xml_home_team :: OddsGameTeamXml,
264 xml_over_under :: OddsGameOverUnderXml }
267 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
270 xml_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
271 xml_over_under_casinos = xml_casinos . xml_over_under
274 instance ToDb OddsGameXml where
275 -- | The database representation of an 'OddsGameXml' is an
278 type Db OddsGameXml = OddsGame
281 instance Child OddsGameXml where
282 -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words
283 -- the foreign key for 'OddsGame' points to an 'Odds'.
285 type Parent OddsGameXml = Odds
288 instance FromXmlFkTeams OddsGameXml where
289 -- | To convert from the XML representation to the database one, we
290 -- drop the casino lines, but retain the home/away rotation
291 -- numbers and the starters. The foreign keys to 'Odds' and the
292 -- home/away teams are passed in.
294 from_xml_fk_teams fk fk_away fk_home OddsGameXml{..} =
297 db_away_team_id = fk_away,
298 db_home_team_id = fk_home,
299 db_game_id = xml_game_id,
301 db_game_time = UTCTime
302 (utctDay xml_game_date) -- Take the day part from one,
303 (utctDayTime xml_game_time), -- the time from the other.
305 db_away_team_rotation_number =
306 (xml_team_rotation_number xml_away_team),
308 db_home_team_rotation_number =
309 (xml_team_rotation_number xml_home_team),
311 db_away_team_starter_id =
312 (fst <$> xml_team_starter xml_away_team),
314 db_away_team_starter_name =
315 (snd <$> xml_team_starter xml_away_team),
317 db_home_team_starter_id =
318 (fst <$> xml_team_starter xml_home_team),
320 db_home_team_starter_name =
321 (snd <$> xml_team_starter xml_home_team) }
324 -- | This lets us insert the XML representation 'OddsGameXml' directly.
326 instance XmlImportFkTeams OddsGameXml
329 -- * OddsGameWithNotes
331 -- | This is our best guess at what occurs in the Odds_XML
332 -- documents. It looks like each consecutive set of games can
333 -- optionally have some notes appear before it. Each \"note\" comes
334 -- as its own \<Notes\>...\</Notes\> element.
336 -- The notes are ignored completely in the database; we only bother
337 -- with them to ensure that we're (un)pickling correctly.
339 -- We can't group the notes with a \"set\" of 'OddsGame's, because
340 -- that leads to ambiguity in parsing. Since we're going to ignore
341 -- the notes anyway, we just stick them with an arbitrary
342 -- game. C'est la vie.
344 -- We have to take the same approach with the league. The
345 -- \<League_Name\> elements are sitting outside of the games, and
346 -- are presumably supposed to be interpreted in \"chronological\"
347 -- order; i.e. the current league stays the same until we see
348 -- another \<League_Name\> element. Unfortunately, that's not how
349 -- XML works. So we're forced to ignore the league in the database
350 -- and pull the same trick, pairing them with games.
352 data OddsGameWithNotes =
354 league :: Maybe String,
356 game :: OddsGameXml }
362 -- | Database representation of a 'Message'.
366 db_xml_file_id :: Int,
369 db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
370 -- because their timezones are ambiguous
371 -- (and the date is less than useful when
372 -- it might be off by an hour).
373 db_time_stamp :: UTCTime }
376 -- | The XML representation of 'Odds'.
380 xml_xml_file_id :: Int,
381 xml_heading :: String,
382 xml_category :: String,
385 xml_line_time :: String,
386 xml_games_with_notes :: [OddsGameWithNotes],
387 xml_time_stamp :: UTCTime }
390 -- | Pseudo-field that lets us get the 'OddsGame's out of
391 -- 'xml_games_with_notes'.
393 xml_games :: Message -> [OddsGameXml]
394 xml_games m = map game (xml_games_with_notes m)
397 instance ToDb Message where
398 -- | The database representation of a 'Message' is 'Odds'.
400 type Db Message = Odds
402 instance FromXml Message where
403 -- | To convert from the XML representation to the database one, we
404 -- just drop a bunch of fields.
406 from_xml Message{..} =
408 db_xml_file_id = xml_xml_file_id,
409 db_sport = xml_sport,
410 db_title = xml_title,
411 db_line_time = xml_line_time,
412 db_time_stamp = xml_time_stamp }
414 -- | This lets us insert the XML representation 'Message' directly.
416 instance XmlImport Message
423 -- Groundhog database schema. This must come before the DbImport
424 -- instance definition. Don't know why.
425 mkPersist tsn_codegen_config [groundhog|
432 # Prevent multiple imports of the same message.
433 fields: [db_xml_file_id]
440 - name: unique_odds_casino
442 fields: [casino_client_id]
452 - name: db_away_team_id
455 - name: db_home_team_id
459 - entity: OddsGameLine
460 dbName: odds_games_lines
464 - name: ogl_odds_games_id
467 - name: ogl_odds_casinos_id
473 instance DbImport Message where
476 migrate (undefined :: Team)
477 migrate (undefined :: Odds)
478 migrate (undefined :: OddsCasino)
479 migrate (undefined :: OddsGame)
480 migrate (undefined :: OddsGameLine)
483 -- Insert the root "odds" element and acquire its primary key (id).
484 odds_id <- insert_xml m
486 forM_ (xml_games m) $ \game -> do
487 -- First we insert the home and away teams.
488 away_team_id <- insert_xml_or_select (xml_away_team game)
489 home_team_id <- insert_xml_or_select (xml_home_team game)
491 -- Now insert the game, keyed to the "odds" and its teams.
492 game_id <- insert_xml_fk_teams odds_id away_team_id home_team_id game
494 -- Finally, we insert the lines. The over/under entries for this
495 -- game and the lines for the casinos all wind up in the same
496 -- table, odds_games_lines. We can insert the over/under entries
497 -- freely with empty away/home lines:
498 forM_ (xml_over_under_casinos game) $ \c -> do
499 -- Start by inderting the casino.
500 ou_casino_id <- insert_xml_or_select c
502 -- Now add the over/under entry with the casino's id.
503 let ogl = OddsGameLine {
504 ogl_odds_games_id = game_id,
505 ogl_odds_casinos_id = ou_casino_id,
506 ogl_over_under = (xml_casino_line c),
507 ogl_away_line = Nothing,
508 ogl_home_line = Nothing }
512 -- ...but then when we insert the home/away team lines, we
513 -- prefer to update the existing entry rather than overwrite it
514 -- or add a new record.
515 forM_ (xml_team_casinos $ xml_away_team game) $ \c -> do
516 -- insert, or more likely retrieve the existing, casino
517 a_casino_id <- insert_xml_or_select c
519 -- Get a Maybe Double instead of the Maybe String that's in there.
520 let away_line = home_away_line c
522 -- Unconditionally update that casino's away team line with ours.
523 update [Ogl_Away_Line =. away_line] $ -- WHERE
524 Ogl_Odds_Casinos_Id ==. a_casino_id
526 -- Repeat all that for the home team.
527 forM_ (xml_team_casinos $ xml_home_team game) $ \c ->do
528 h_casino_id <- insert_xml_or_select c
529 let home_line = home_away_line c
530 update [Ogl_Home_Line =. home_line] $ -- WHERE
531 Ogl_Odds_Casinos_Id ==. h_casino_id
535 return ImportSucceeded
542 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
544 pickle_game_with_notes :: PU OddsGameWithNotes
545 pickle_game_with_notes =
546 xpWrap (from_pair, to_pair) $
548 (xpOption $ xpElem "League_Name" xpText)
549 (xpList $ xpElem "Notes" xpText)
552 from_pair = uncurryN OddsGameWithNotes
553 to_pair OddsGameWithNotes{..} = (league, notes, game)
556 -- | Pickler for an 'OddsGameCasinoXml'.
558 pickle_casino :: PU OddsGameCasinoXml
561 xpWrap (from_tuple, to_tuple) $
563 (xpAttr "ClientID" xpInt)
564 (xpAttr "Name" xpText)
567 from_tuple = uncurryN OddsGameCasinoXml
568 -- Use record wildcards to avoid unused field warnings.
569 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
574 -- | Pickler for an 'OddsGameTeamXml'.
576 pickle_home_team :: PU OddsGameTeamXml
579 xpWrap (from_tuple, to_tuple) $
581 (xpElem "HomeTeamID" xpText)
582 (xpElem "HomeRotationNumber" (xpOption xpInt))
583 (xpElem "HomeAbbr" xpText)
584 (xpElem "HomeTeamName" xpText)
585 (-- This is an ugly way to get both the HStarter ID attribute
587 xpOption (xpElem "HStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
588 (xpList pickle_casino)
590 from_tuple = uncurryN OddsGameTeamXml
592 -- Use record wildcards to avoid unused field warnings.
593 to_tuple OddsGameTeamXml{..} = (xml_team_id,
594 xml_team_rotation_number,
600 -- | Pickler for an 'OddsGameTeamXml'.
602 pickle_away_team :: PU OddsGameTeamXml
605 xpWrap (from_tuple, to_tuple) $
607 (xpElem "AwayTeamID" xpText)
608 (xpElem "AwayRotationNumber" (xpOption xpInt))
609 (xpElem "AwayAbbr" xpText)
610 (xpElem "AwayTeamName" xpText)
611 (-- This is an ugly way to get both the AStarter ID attribute
613 xpOption (xpElem "AStarter" $ xpPair (xpAttr "ID" xpInt) xpText))
614 (xpList pickle_casino)
616 from_tuple = uncurryN OddsGameTeamXml
618 -- Use record wildcards to avoid unused field warnings.
619 to_tuple OddsGameTeamXml{..} = (xml_team_id,
620 xml_team_rotation_number,
628 -- | Pickler for an 'OddsGameOverUnderXml'.
630 pickle_over_under :: PU OddsGameOverUnderXml
632 xpElem "Over_Under" $
633 xpWrap (to_newtype, from_newtype) $
636 from_newtype (OddsGameOverUnderXml cs) = cs
637 to_newtype = OddsGameOverUnderXml
640 -- | Pickler for an 'OddsGameXml'.
642 pickle_game :: PU OddsGameXml
645 xpWrap (from_tuple, to_tuple) $
647 (xpElem "GameID" xpInt)
648 (xpElem "Game_Date" xp_date_padded)
649 (xpElem "Game_Time" xp_time)
654 from_tuple = uncurryN OddsGameXml
655 -- Use record wildcards to avoid unused field warnings.
656 to_tuple OddsGameXml{..} = (xml_game_id,
664 -- | Pickler for the top-level 'Message'.
666 pickle_message :: PU Message
669 xpWrap (from_tuple, to_tuple) $
670 xp8Tuple (xpElem "XML_File_ID" xpInt)
671 (xpElem "heading" xpText)
672 (xpElem "category" xpText)
673 (xpElem "sport" xpText)
674 (xpElem "Title" xpText)
675 (xpElem "Line_Time" xpText)
676 (xpList pickle_game_with_notes)
677 (xpElem "time_stamp" xp_time_stamp)
679 from_tuple = uncurryN Message
680 to_tuple m = (xml_xml_file_id m,
686 xml_games_with_notes m,
694 -- | A list of all tests for this module.
696 odds_tests :: TestTree
700 [ test_on_delete_cascade,
701 test_pickle_of_unpickle_is_identity,
702 test_unpickle_succeeds ]
705 -- | If we unpickle something and then pickle it, we should wind up
706 -- with the same thing we started with. WARNING: success of this
707 -- test does not mean that unpickling succeeded.
709 test_pickle_of_unpickle_is_identity :: TestTree
710 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
711 [ check "pickle composed with unpickle is the identity"
712 "test/xml/Odds_XML.xml",
714 check "pickle composed with unpickle is the identity (non-int team_id)"
715 "test/xml/Odds_XML-noninteger-team-id.xml",
717 check "pickle composed with unpickle is the identity (positive(+) line)"
718 "test/xml/Odds_XML-positive-line.xml",
720 check "pickle composed with unpickle is the identity (large file)"
721 "test/xml/Odds_XML-largefile.xml",
723 check "pickle composed with unpickle is the identity (league name)"
724 "test/xml/Odds_XML-league-name.xml" ]
726 check desc path = testCase desc $ do
727 (expected, actual) <- pickle_unpickle pickle_message path
731 -- | Make sure we can actually unpickle these things.
733 test_unpickle_succeeds :: TestTree
734 test_unpickle_succeeds = testGroup "unpickle tests"
735 [ check "unpickling succeeds"
736 "test/xml/Odds_XML.xml",
738 check "unpickling succeeds (non-int team_id)"
739 "test/xml/Odds_XML-noninteger-team-id.xml",
741 check "unpickling succeeds (positive(+) line)"
742 "test/xml/Odds_XML-positive-line.xml",
744 check "unpickling succeeds (large file)"
745 "test/xml/Odds_XML-largefile.xml",
747 check "unpickling succeeds (league name)"
748 "test/xml/Odds_XML-league-name.xml" ]
750 check desc path = testCase desc $ do
751 actual <- unpickleable path pickle_message
756 -- | Make sure everything gets deleted when we delete the top-level
757 -- record. The casinos and teams should be left behind.
759 test_on_delete_cascade :: TestTree
760 test_on_delete_cascade = testGroup "cascading delete tests"
761 [ check "deleting odds deletes its children"
762 "test/xml/Odds_XML.xml"
763 13 -- 5 casinos, 8 teams
766 check "deleting odds deletes its children (non-int team_id)"
767 "test/xml/Odds_XML-noninteger-team-id.xml"
768 51 -- 5 casinos, 46 teams
771 check "deleting odds deleted its children (positive(+) line)"
772 "test/xml/Odds_XML-positive-line.xml"
773 17 -- 5 casinos, 12 teams
776 check "deleting odds deleted its children (large file)"
777 "test/xml/Odds_XML-largefile.xml"
778 189 -- 5 casinos, 184 teams
780 check "deleting odds deleted its children (league name)"
781 "test/xml/Odds_XML-league-name.xml"
782 35 -- 5 casinos, 30 teams
785 check desc path expected = testCase desc $ do
786 odds <- unsafe_unpickle path pickle_message
787 let a = undefined :: Team
788 let b = undefined :: Odds
789 let c = undefined :: OddsCasino
790 let d = undefined :: OddsGame
791 let e = undefined :: OddsGameLine
792 actual <- withSqliteConn ":memory:" $ runDbConn $ do
793 runMigration silentMigrationLogger $ do
801 count_a <- countAll a
802 count_b <- countAll b
803 count_c <- countAll c
804 count_d <- countAll d
805 count_e <- countAll e
806 return $ sum [count_a, count_b, count_c,