1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains
11 -- a root element \<message\> that contains a bunch of other
17 -- * WARNING: these are private but exported to silence warnings
18 Odds_OddsGameConstructor(..),
19 OddsCasinoConstructor(..),
21 OddsGame_OddsGameTeamConstructor(..),
22 OddsGameConstructor(..),
23 OddsGameLineConstructor(..),
24 OddsGameTeamConstructor(..) )
27 import Control.Monad ( forM_, join )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog (
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.TH (
40 import Test.Tasty ( TestTree, testGroup )
41 import Test.Tasty.HUnit ( (@?=), testCase )
42 import Text.Read ( readMaybe )
43 import Text.XML.HXT.Core (
60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
61 import TSN.Picklers ( xp_team_id )
62 import TSN.XmlImport ( XmlImport(..) )
63 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
67 -- | The home/away lines are 'Double's, but the over/under lines are
68 -- textual. If we want to use one data type for both, we have to go
69 -- with a String and then attempt to 'read' a 'Double' later when we
70 -- go to insert the thing.
72 data OddsGameCasinoXml =
74 xml_casino_client_id :: Int,
75 xml_casino_name :: String,
76 xml_casino_line :: Maybe String }
80 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
81 -- priori textual (because it might be an over/under line).
83 home_away_line :: OddsGameCasinoXml -> Maybe Double
84 home_away_line = join . (fmap readMaybe) . xml_casino_line
86 -- | The casinos should have their own table, but the lines don't
87 -- belong in that table. (There should be another table joining the
88 -- casinos and the thing the lines are for together.)
90 -- We drop the 'Game' prefix because the Casinos really aren't
91 -- children of the games; the XML just makes it seem that way.
95 casino_client_id :: Int,
96 casino_name :: String }
99 instance FromXml OddsGameCasinoXml where
100 type Db OddsGameCasinoXml = OddsCasino
102 -- We don't need the key argument (from_xml_fk) since the XML type
103 -- contains more information in this case.
104 from_xml OddsGameCasinoXml{..} =
106 casino_client_id = xml_casino_client_id,
107 casino_name = xml_casino_name }
110 instance XmlImport OddsGameCasinoXml
113 data OddsGameHomeTeamXml =
114 OddsGameHomeTeamXml {
115 xml_home_team_id :: String, -- ^ These are three-character IDs.
116 xml_home_rotation_number :: Int,
117 xml_home_abbr :: String,
118 xml_home_team_name :: String,
119 xml_home_casinos :: [OddsGameCasinoXml] }
122 instance FromXml OddsGameHomeTeamXml where
123 type Db OddsGameHomeTeamXml = OddsGameTeam
124 from_xml OddsGameHomeTeamXml{..} =
126 db_team_id = xml_home_team_id,
127 db_abbr = xml_home_abbr,
128 db_team_name = xml_home_team_name }
130 instance XmlImport OddsGameHomeTeamXml where
135 db_team_id :: String, -- ^ The home/away team IDs are 3 characters
137 db_team_name :: String }
141 -- | Database mapping between games and their home/away teams.
142 data OddsGame_OddsGameTeam =
143 OddsGame_OddsGameTeam {
144 ogogt_odds_games_id :: DefaultKey OddsGame,
145 ogogt_away_team_id :: DefaultKey OddsGameTeam,
146 ogogt_home_team_id :: DefaultKey OddsGameTeam }
148 data OddsGameAwayTeamXml =
149 OddsGameAwayTeamXml {
150 xml_away_team_id :: String, -- ^ These are 3 character IDs.
151 xml_away_rotation_number :: Int,
152 xml_away_abbr :: String,
153 xml_away_team_name :: String,
154 xml_away_casinos :: [OddsGameCasinoXml] }
157 instance FromXml OddsGameAwayTeamXml where
158 type Db OddsGameAwayTeamXml = OddsGameTeam
159 from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
164 instance XmlImport OddsGameAwayTeamXml where
166 -- | Can't use a newtype with Groundhog.
167 newtype OddsGameOverUnderXml =
168 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
171 -- | This database representation of the casino lines can't be
172 -- constructed from the one in the XML. The casinos within
173 -- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or
174 -- less the same. We don't need a bajillion different tables to
175 -- store that, just one tying the casino/game pair to the three
178 -- The one small difference between the over/under casinos and the
179 -- home/away ones is that the home/away lines are all 'Double's, but
180 -- the over/under lines appear to be textual.
184 ogl_odds_games_id :: DefaultKey OddsGame,
185 ogl_odds_casinos_id :: DefaultKey OddsCasino,
186 ogl_over_under :: Maybe String,
187 ogl_away_line :: Maybe Double,
188 ogl_home_line :: Maybe Double }
193 db_game_date :: String, -- TODO
194 db_game_time :: String, -- TODO
195 db_game_away_team_rotation_number :: Int,
196 db_game_home_team_rotation_number :: Int }
197 deriving instance Eq OddsGame
198 deriving instance Show OddsGame
203 xml_game_date :: String, -- TODO
204 xml_game_time :: String, -- TODO
205 xml_game_away_team :: OddsGameAwayTeamXml,
206 xml_game_home_team :: OddsGameHomeTeamXml,
207 xml_game_over_under :: OddsGameOverUnderXml }
210 -- | Pseudo-field that lets us get the 'OddsCasino's out of
211 -- xml_game_over_under.
212 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
213 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
216 instance FromXml OddsGameXml where
217 type Db OddsGameXml = OddsGame
218 from_xml OddsGameXml{..} =
220 db_game_id = xml_game_id,
221 db_game_date = xml_game_date,
222 db_game_time = xml_game_time,
223 db_game_away_team_rotation_number =
224 (xml_away_rotation_number xml_game_away_team),
225 db_game_home_team_rotation_number =
226 (xml_home_rotation_number xml_game_home_team) }
228 instance XmlImport OddsGameXml
236 db_line_time :: String }
239 -- | Map 'Odds' to their children 'OddsGame's.
241 data Odds_OddsGame = Odds_OddsGame
243 (DefaultKey OddsGame)
246 -- | This is our best guess at what occurs in the Odds_XML
247 -- documents. It looks like each consecutive set of games can
248 -- optionally have some notes appear before it. Each "note" comes as
249 -- its own <Notes>...</Notes> element.
251 -- The notes are ignored completely in the database; we only bother
252 -- with them to ensure that we're (un)pickling correctly.
254 -- We can't group the notes with a "set" of 'OddsGame's, because that
255 -- leads to ambiguity in parsing. Since we're going to ignore the
256 -- notes anyway, we just stick them with an arbitrary game. C'est la
259 data OddsGameWithNotes =
262 game :: OddsGameXml }
265 -- | The XML representation of Odds.
268 xml_xml_file_id :: Int,
269 xml_heading :: String,
270 xml_category :: String,
273 xml_line_time :: String,
274 xml_games_with_notes :: [OddsGameWithNotes],
275 xml_time_stamp :: String }
278 -- | Pseudo-field that lets us get the 'OddsGame's out of
279 -- 'xml_games_with_notes'.
280 xml_games :: Message -> [OddsGameXml]
281 xml_games m = map game (xml_games_with_notes m)
284 instance FromXml Message where
285 type Db Message = Odds
287 -- We don't need the key argument (from_xml_fk) since the XML type
288 -- contains more information in this case.
289 from_xml Message{..} =
291 db_sport = xml_sport,
292 db_title = xml_title,
293 db_line_time = xml_line_time }
295 instance XmlImport Message
299 -- * Groundhog database schema.
300 -- | This must come before the dbimport code.
302 mkPersist tsn_codegen_config [groundhog|
310 - name: unique_odds_casino
312 fields: [casino_client_id]
314 - entity: OddsGameTeam
315 dbName: odds_games_teams
322 - name: unique_odds_games_team
332 - name: unique_odds_game
336 - entity: OddsGameLine
337 dbName: odds_games_lines
339 - entity: Odds_OddsGame
340 dbName: odds__odds_games
342 - name: Odds_OddsGame
344 - name: odds_OddsGame0
346 - name: odds_OddsGame1
347 dbName: odds_games_id
349 - entity: OddsGame_OddsGameTeam
350 dbName: odds_games__odds_games_teams
353 instance DbImport Message where
356 migrate (undefined :: Odds)
357 migrate (undefined :: OddsCasino)
358 migrate (undefined :: OddsGameTeam)
359 migrate (undefined :: OddsGame)
360 migrate (undefined :: Odds_OddsGame)
361 migrate (undefined :: OddsGame_OddsGameTeam)
362 migrate (undefined :: OddsGameLine)
365 -- Insert the root "odds" element and acquire its primary key (id).
366 odds_id <- insert_xml m
368 -- Next, we insert the home and away teams. We do this before
369 -- inserting the game itself because the game has two foreign keys
370 -- pointing to odds_games_teams.
371 forM_ (xml_games m) $ \g -> do
372 game_id <- insert_xml_or_select g
373 -- Insert a record into odds__odds_game mapping this game
374 -- to its parent in the odds table.
375 insert_ (Odds_OddsGame odds_id game_id)
377 -- Next to insert the home and away teams.
378 away_team_id <- insert_xml_or_select (xml_game_away_team g)
379 home_team_id <- insert_xml_or_select (xml_game_home_team g)
381 -- Insert a record into odds_games__odds_games_teams mapping the
382 -- home/away teams to this game. Use the full record syntax
383 -- because the types would let us mix up the home/away teams.
384 insert_ OddsGame_OddsGameTeam {
385 ogogt_odds_games_id = game_id,
386 ogogt_away_team_id = away_team_id,
387 ogogt_home_team_id = home_team_id }
389 -- Finaly, we insert the lines. The over/under entries for this
390 -- game and the lines for the casinos all wind up in the same
391 -- table, odds_games_lines. We can insert the over/under entries
392 -- freely with empty away/home lines:
393 forM_ (xml_game_over_under_casinos g) $ \c -> do
394 -- Start by inderting the casino.
395 ou_casino_id <- insert_xml_or_select c
397 -- Now add the over/under entry with the casino's id.
398 let ogl = OddsGameLine {
399 ogl_odds_games_id = game_id,
400 ogl_odds_casinos_id = ou_casino_id,
401 ogl_over_under = (xml_casino_line c),
402 ogl_away_line = Nothing,
403 ogl_home_line = Nothing }
407 -- ...but then when we insert the home/away team lines, we
408 -- prefer to update the existing entry rather than overwrite it
409 -- or add a new record.
410 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do
411 -- insert, or more likely retrieve the existing, casino
412 a_casino_id <- insert_xml_or_select c
414 -- Get a Maybe Double instead of the Maybe String that's in there.
415 let away_line = home_away_line c
417 -- Unconditionally update that casino's away team line with ours.
418 update [Ogl_Away_Line =. away_line] $ -- WHERE
419 Ogl_Odds_Casinos_Id ==. a_casino_id
421 -- Repeat all that for the home team.
422 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
423 h_casino_id <- insert_xml_or_select c
424 let home_line = home_away_line c
425 update [Ogl_Home_Line =. home_line] $ -- WHERE
426 Ogl_Odds_Casinos_Id ==. h_casino_id
430 return ImportSucceeded
432 pickle_game_with_notes :: PU OddsGameWithNotes
433 pickle_game_with_notes =
434 xpWrap (from_pair, to_pair) $
436 (xpList $ xpElem "Notes" xpText)
439 from_pair = uncurry OddsGameWithNotes
440 to_pair OddsGameWithNotes{..} = (notes, game)
444 pickle_casino :: PU OddsGameCasinoXml
447 xpWrap (from_tuple, to_tuple) $
449 (xpAttr "ClientID" xpInt)
450 (xpAttr "Name" xpText)
453 from_tuple = uncurryN OddsGameCasinoXml
454 -- Use record wildcards to avoid unused field warnings.
455 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
460 pickle_home_team :: PU OddsGameHomeTeamXml
463 xpWrap (from_tuple, to_tuple) $
465 (xpElem "HomeTeamID" xp_team_id)
466 (xpElem "HomeRotationNumber" xpInt)
467 (xpElem "HomeAbbr" xpText)
468 (xpElem "HomeTeamName" xpText)
469 (xpList pickle_casino)
471 from_tuple = uncurryN OddsGameHomeTeamXml
472 -- Use record wildcards to avoid unused field warnings.
473 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
474 xml_home_rotation_number,
481 pickle_away_team :: PU OddsGameAwayTeamXml
484 xpWrap (from_tuple, to_tuple) $
486 (xpElem "AwayTeamID" xp_team_id)
487 (xpElem "AwayRotationNumber" xpInt)
488 (xpElem "AwayAbbr" xpText)
489 (xpElem "AwayTeamName" xpText)
490 (xpList pickle_casino)
492 from_tuple = uncurryN OddsGameAwayTeamXml
493 -- Use record wildcards to avoid unused field warnings.
494 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
495 xml_away_rotation_number,
502 pickle_over_under :: PU OddsGameOverUnderXml
504 xpElem "Over_Under" $
505 xpWrap (to_newtype, from_newtype) $
508 from_newtype (OddsGameOverUnderXml cs) = cs
509 to_newtype = OddsGameOverUnderXml
513 pickle_game :: PU OddsGameXml
516 xpWrap (from_tuple, to_tuple) $
518 (xpElem "GameID" xpInt)
519 (xpElem "Game_Date" xpText)
520 (xpElem "Game_Time" xpText)
525 from_tuple = uncurryN OddsGameXml
526 -- Use record wildcards to avoid unused field warnings.
527 to_tuple OddsGameXml{..} = (xml_game_id,
535 pickle_message :: PU Message
538 xpWrap (from_tuple, to_tuple) $
539 xp8Tuple (xpElem "XML_File_ID" xpInt)
540 (xpElem "heading" xpText)
541 (xpElem "category" xpText)
542 (xpElem "sport" xpText)
543 (xpElem "Title" xpText)
544 (xpElem "Line_Time" xpText)
545 (xpList pickle_game_with_notes)
546 (xpElem "time_stamp" xpText)
548 from_tuple = uncurryN Message
549 to_tuple m = (xml_xml_file_id m,
555 xml_games_with_notes m,
561 odds_tests :: TestTree
565 [ test_pickle_of_unpickle_is_identity,
566 test_unpickle_succeeds ]
569 -- | Warning, succeess of this test does not mean that unpickling
571 test_pickle_of_unpickle_is_identity :: TestTree
572 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
573 [ check "pickle composed with unpickle is the identity"
574 "test/xml/Odds_XML.xml",
576 check "pickle composed with unpickle is the identity (non-int team_id)"
577 "test/xml/Odds_XML-noninteger-team-id.xml",
579 check "pickle composed with unpickle is the identity (positive(+) line)"
580 "test/xml/Odds_XML-positive-line.xml",
582 check "pickle composed with unpickle is the identity (large file)"
583 "test/xml/Odds_XML-largefile.xml" ]
585 check desc path = testCase desc $ do
586 (expected, actual) <- pickle_unpickle pickle_message path
590 test_unpickle_succeeds :: TestTree
591 test_unpickle_succeeds = testGroup "unpickle tests"
592 [ check "unpickling succeeds"
593 "test/xml/Odds_XML.xml",
595 check "unpickling succeeds (non-int team_id)"
596 "test/xml/Odds_XML-noninteger-team-id.xml",
598 check "unpickling succeeds (positive(+) line)"
599 "test/xml/Odds_XML-positive-line.xml",
601 check "unpickling succeeds (large file)"
602 "test/xml/Odds_XML-largefile.xml" ]
604 check desc path = testCase desc $ do
605 actual <- unpickleable path pickle_message