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
19 import Control.Monad ( forM_ )
20 import Data.Tuple.Curry ( uncurryN )
21 import Database.Groundhog (
28 import Database.Groundhog.Core ( DefaultKey )
29 import Database.Groundhog.TH (
32 import Test.Tasty ( TestTree, testGroup )
33 import Test.Tasty.HUnit ( (@?=), testCase )
34 import Text.XML.HXT.Core (
53 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
54 import TSN.XmlImport ( XmlImport(..) )
55 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
59 data OddsGameCasinoXml =
61 xml_casino_client_id :: Int,
62 xml_casino_name :: String,
63 xml_casino_line :: Maybe Double }
67 -- | The casinos should have their own table, but the lines don't
68 -- belong in that table. (There should be another table joining the
69 -- casinos and the thing the lines are for together.)
71 -- We drop the 'Game' prefix because the Casinos really aren't
72 -- children of the games; the XML just makes it seem that way.
76 casino_client_id :: Int,
77 casino_name :: String }
80 instance FromXml OddsGameCasinoXml where
81 type Db OddsGameCasinoXml = OddsCasino
83 -- We don't need the key argument (from_xml_fk) since the XML type
84 -- contains more information in this case.
85 from_xml OddsGameCasinoXml{..} = OddsCasino
89 instance XmlImport OddsGameCasinoXml
92 data OddsGameHomeTeamXml =
94 xml_home_team_id :: Int,
95 xml_home_rotation_number :: Int,
96 xml_home_abbr :: String,
97 xml_home_team_name :: String,
98 xml_home_casinos :: [OddsGameCasinoXml] }
101 instance FromXml OddsGameHomeTeamXml where
102 type Db OddsGameHomeTeamXml = OddsGameTeam
103 from_xml OddsGameHomeTeamXml{..} = OddsGameTeam
108 instance XmlImport OddsGameHomeTeamXml where
115 db_team_name :: String }
119 -- | Database mapping between games and their home/away teams.
120 data OddsGame_OddsGameTeam =
121 OddsGame_OddsGameTeam {
122 ogogt_odds_games_id :: DefaultKey OddsGame,
123 ogogt_away_team_id :: DefaultKey OddsGameTeam,
124 ogogt_home_team_id :: DefaultKey OddsGameTeam }
126 data OddsGameAwayTeamXml =
127 OddsGameAwayTeamXml {
128 xml_away_team_id :: Int,
129 xml_away_rotation_number :: Int,
130 xml_away_abbr :: String,
131 xml_away_team_name :: String,
132 xml_away_casinos :: [OddsGameCasinoXml] }
135 instance FromXml OddsGameAwayTeamXml where
136 type Db OddsGameAwayTeamXml = OddsGameTeam
137 from_xml OddsGameAwayTeamXml{..} = OddsGameTeam
142 instance XmlImport OddsGameAwayTeamXml where
144 -- | Can't use a newtype with Groundhog.
145 newtype OddsGameOverUnderXml =
146 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
149 -- | This database representation of the casino lines can't be
150 -- constructed from the one in the XML. The casinos within
151 -- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all the
152 -- same. We don't need a bajillion different tables to store that --
153 -- just one tying the casino/game pair to the three lines.
156 ogl_odds_games_id :: DefaultKey OddsGame,
157 ogl_odds_casinos_id :: DefaultKey OddsCasino,
158 ogl_over_under :: Maybe Double,
159 ogl_away_line :: Maybe Double,
160 ogl_home_line :: Maybe Double }
165 db_game_date :: String, -- TODO
166 db_game_time :: String, -- TODO
167 db_game_away_team_rotation_number :: Int,
168 db_game_home_team_rotation_number :: Int }
169 deriving instance Eq OddsGame
170 deriving instance Show OddsGame
175 xml_game_date :: String, -- TODO
176 xml_game_time :: String, -- TODO
177 xml_game_away_team :: OddsGameAwayTeamXml,
178 xml_game_home_team :: OddsGameHomeTeamXml,
179 xml_game_over_under :: OddsGameOverUnderXml }
182 -- | Pseudo-field that lets us get the 'OddsCasino's out of
183 -- xml_game_over_under.
184 xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
185 xml_game_over_under_casinos = xml_casinos . xml_game_over_under
188 instance FromXml OddsGameXml where
189 type Db OddsGameXml = OddsGame
190 from_xml OddsGameXml{..} = OddsGame
194 (xml_away_rotation_number xml_game_away_team)
195 (xml_home_rotation_number xml_game_home_team)
197 instance XmlImport OddsGameXml
205 db_line_time :: String }
208 -- | Map 'Odds' to their children 'OddsGame's.
211 oog_odds_id :: DefaultKey Odds,
212 oog_odds_games_id :: DefaultKey OddsGame }
214 -- | This is our best guess at what occurs in the Odds_XML
215 -- documents. It looks like each consecutive set of games can
216 -- optionally have some notes appear before it. Each "note" comes as
217 -- its own <Notes>...</Notes> element.
219 -- The notes are ignored completely in the database; we only bother
220 -- with them to ensure that we're (un)pickling correctly.
222 -- We can't group the notes with a "set" of 'OddsGame's, because that
223 -- leads to ambiguity in parsing. Since we're going to ignore the
224 -- notes anyway, we just stick them with an arbitrary game. C'est la
227 data OddsGameWithNotes =
230 game :: OddsGameXml }
233 -- | The XML representation of Odds.
236 xml_xml_file_id :: Int,
237 xml_heading :: String,
238 xml_category :: String,
241 xml_line_time :: String,
242 xml_games_with_notes :: [OddsGameWithNotes],
243 xml_time_stamp :: String }
246 -- | Pseudo-field that lets us get the 'OddsGame's out of
247 -- 'xml_games_with_notes'.
248 xml_games :: Message -> [OddsGameXml]
249 xml_games m = map game (xml_games_with_notes m)
252 instance FromXml Message where
253 type Db Message = Odds
255 -- We don't need the key argument (from_xml_fk) since the XML type
256 -- contains more information in this case.
257 from_xml (Message _ _ _ d e f _ _) =
260 instance XmlImport Message
264 -- * Groundhog database schema.
265 -- | This must come before the dbimport code.
267 mkPersist tsn_codegen_config [groundhog|
275 - name: unique_odds_casino
277 fields: [casino_client_id]
279 - entity: OddsGameTeam
280 dbName: odds_games_teams
284 - name: unique_odds_games_team
294 - name: unique_odds_game
298 - entity: OddsGameLine
299 dbName: odds_games_lines
301 - entity: Odds_OddsGame
302 dbName: odds__odds_games
304 - entity: OddsGame_OddsGameTeam
305 dbName: odds_games__odds_games_teams
308 instance DbImport Message where
311 migrate (undefined :: Odds)
312 migrate (undefined :: OddsCasino)
313 migrate (undefined :: OddsGameTeam)
314 migrate (undefined :: OddsGame)
315 migrate (undefined :: Odds_OddsGame)
316 migrate (undefined :: OddsGame_OddsGameTeam)
317 migrate (undefined :: OddsGameLine)
320 -- Insert the root "odds" element and acquire its primary key (id).
321 odds_id <- insert_xml m
323 -- Next, we insert the home and away teams. We do this before
324 -- inserting the game itself because the game has two foreign keys
325 -- pointing to odds_games_teams.
326 forM_ (xml_games m) $ \g -> do
327 game_id <- insert_xml_or_select g
328 -- Insert a record into odds__odds_game mapping this game
329 -- to its parent in the odds table.
330 insert_ (Odds_OddsGame odds_id game_id)
332 -- Next to insert the home and away teams.
333 away_team_id <- insert_xml_or_select (xml_game_away_team g)
334 home_team_id <- insert_xml_or_select (xml_game_home_team g)
336 -- Insert a record into odds_games__odds_games_teams
337 -- mapping the home/away teams to this game.
338 insert_ (OddsGame_OddsGameTeam game_id away_team_id home_team_id)
340 -- Finaly, we insert the lines. The over/under entries for this
341 -- game and the lines for the casinos all wind up in the same
342 -- table, odds_games_lines. We can insert the over/under entries
343 -- freely with empty away/home lines:
344 forM_ (xml_game_over_under_casinos g) $ \c -> do
345 -- Start by inderting the casino.
346 ou_casino_id <- insert_xml_or_select c
348 -- Now add the over/under entry with the casino's id.
349 let ogl = OddsGameLine
358 -- ...but then when we insert the home/away team lines, we
359 -- prefer to update the existing entry rather than overwrite it
360 -- or add a new record.
361 forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do
362 -- insert, or more likely retrieve the existing, casino
363 a_casino_id <- insert_xml_or_select c
365 -- Unconditionally update that casino's away team line with ours.
366 update [Ogl_Away_Line =. (xml_casino_line c)] $ -- WHERE
367 Ogl_Odds_Casinos_Id ==. a_casino_id
369 -- Repeat all that for the home team.
370 forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do
371 h_casino_id <- insert_xml_or_select c
372 update [Ogl_Home_Line =. (xml_casino_line c)] $ -- WHERE
373 Ogl_Odds_Casinos_Id ==. h_casino_id
377 return ImportSucceeded
379 pickle_game_with_notes :: PU OddsGameWithNotes
380 pickle_game_with_notes =
381 xpWrap (from_pair, to_pair) $
383 (xpList $ xpElem "Notes" xpText)
386 from_pair = uncurry OddsGameWithNotes
387 to_pair OddsGameWithNotes{..} = (notes, game)
391 pickle_casino :: PU OddsGameCasinoXml
394 xpWrap (from_tuple, to_tuple) $
396 (xpAttr "ClientID" xpInt)
397 (xpAttr "Name" xpText)
398 (xpOption xpPrim) -- Double
400 from_tuple = uncurryN OddsGameCasinoXml
401 -- Use record wildcards to avoid unused field warnings.
402 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
407 pickle_home_team :: PU OddsGameHomeTeamXml
410 xpWrap (from_tuple, to_tuple) $
412 (xpElem "HomeTeamID" xpInt)
413 (xpElem "HomeRotationNumber" xpInt)
414 (xpElem "HomeAbbr" xpText)
415 (xpElem "HomeTeamName" xpText)
416 (xpList pickle_casino)
418 from_tuple = uncurryN OddsGameHomeTeamXml
419 -- Use record wildcards to avoid unused field warnings.
420 to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id,
421 xml_home_rotation_number,
428 pickle_away_team :: PU OddsGameAwayTeamXml
431 xpWrap (from_tuple, to_tuple) $
433 (xpElem "AwayTeamID" xpInt)
434 (xpElem "AwayRotationNumber" xpInt)
435 (xpElem "AwayAbbr" xpText)
436 (xpElem "AwayTeamName" xpText)
437 (xpList pickle_casino)
439 from_tuple = uncurryN OddsGameAwayTeamXml
440 -- Use record wildcards to avoid unused field warnings.
441 to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id,
442 xml_away_rotation_number,
449 pickle_over_under :: PU OddsGameOverUnderXml
451 xpElem "Over_Under" $
452 xpWrap (to_newtype, from_newtype) $
455 from_newtype (OddsGameOverUnderXml cs) = cs
456 to_newtype = OddsGameOverUnderXml
460 pickle_game :: PU OddsGameXml
463 xpWrap (from_tuple, to_tuple) $
465 (xpElem "GameID" xpInt)
466 (xpElem "Game_Date" xpText)
467 (xpElem "Game_Time" xpText)
472 from_tuple = uncurryN OddsGameXml
473 -- Use record wildcards to avoid unused field warnings.
474 to_tuple OddsGameXml{..} = (xml_game_id,
482 pickle_message :: PU Message
485 xpWrap (from_tuple, to_tuple) $
486 xp8Tuple (xpElem "XML_File_ID" xpInt)
487 (xpElem "heading" xpText)
488 (xpElem "category" xpText)
489 (xpElem "sport" xpText)
490 (xpElem "Title" xpText)
491 (xpElem "Line_Time" xpText)
492 (xpList pickle_game_with_notes)
493 (xpElem "time_stamp" xpText)
495 from_tuple = uncurryN Message
496 to_tuple m = (xml_xml_file_id m,
502 xml_games_with_notes m,
508 odds_tests :: TestTree
512 [ test_pickle_of_unpickle_is_identity,
513 test_unpickle_succeeds ]
516 -- | Warning, succeess of this test does not mean that unpickling
518 test_pickle_of_unpickle_is_identity :: TestTree
519 test_pickle_of_unpickle_is_identity =
520 testCase "pickle composed with unpickle is the identity" $ do
521 let path = "test/xml/Odds_XML.xml"
522 (expected, actual) <- pickle_unpickle pickle_message path
526 test_unpickle_succeeds :: TestTree
527 test_unpickle_succeeds =
528 testCase "unpickling succeeds" $ do
529 let path = "test/xml/Odds_XML.xml"
530 actual <- unpickleable path pickle_message