X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FOdds.hs;h=444371ad1e055a2b723f08071a6dc15e7785b882;hb=b6ba5347fa75f33f63b2eb358d5ab421392dd52e;hp=10d34a46cffcc4ba5c0edd1ccc53fe3209a3f9d3;hpb=610f18c6810edc6bb5dee5cad8bff9e8e59b408a;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index 10d34a4..444371a 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -3,40 +3,43 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | Parse TSN XML for the DTD "Odds_XML.dtd". Each document contains --- a root element \ that contains a bunch of other --- unorganized crap. +-- | Parse TSN XML for the DTD \"Odds_XML.dtd\". Each document +-- contains a root element \ that contains a bunch of +-- other... disorganized... information. -- module TSN.XML.Odds ( + dtd, pickle_message, -- * Tests odds_tests, -- * WARNING: these are private but exported to silence warnings - Odds_OddsGameConstructor(..), OddsCasinoConstructor(..), OddsConstructor(..), - OddsGame_OddsGameTeamConstructor(..), OddsGameConstructor(..), - OddsGameLineConstructor(..), - OddsGameTeamConstructor(..) ) + OddsGameLineConstructor(..) ) where -- System imports. +import Control.Applicative ( (<$>) ) import Control.Monad ( forM_, join ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( (=.), (==.), + countAll, + deleteAll, insert_, - insertByAll, migrate, + runMigration, + silentMigrationLogger, update ) import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) @@ -45,7 +48,6 @@ import Test.Tasty.HUnit ( (@?=), testCase ) import Text.Read ( readMaybe ) import Text.XML.HXT.Core ( PU, - xp5Tuple, xp6Tuple, xp8Tuple, xpAttr, @@ -62,11 +64,45 @@ import Text.XML.HXT.Core ( import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_date, xp_time ) -import TSN.XmlImport ( XmlImport(..) ) -import Xml ( FromXml(..), pickle_unpickle, unpickleable ) +import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) +import TSN.Team ( Team(..) ) +import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) +import Xml ( + Child(..), + FromXml(..), + FromXmlFkTeams(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "Odds_XML.dtd" + + +-- +-- DB/XML data types +-- + +-- * OddsGameCasino/OddsGameCasinoXml + + +-- | The casinos should have their own table, but the lines don't +-- belong in that table (there is a separate table for +-- 'OddsGameLine' which associates the two). +-- +-- We drop the \"Game\" prefix because the casinos really aren't +-- children of the games; the XML just makes it seem that way. +-- +data OddsCasino = + OddsCasino { + casino_client_id :: Int, + casino_name :: String } + deriving (Eq, Show) + -- | The home/away lines are 'Double's, but the over/under lines are -- textual. If we want to use one data type for both, we have to go @@ -88,140 +124,92 @@ home_away_line :: OddsGameCasinoXml -> Maybe Double home_away_line = join . (fmap readMaybe) . xml_casino_line --- | The casinos should have their own table, but the lines don't --- belong in that table (there should be another table joining the --- casinos and the thing the lines are for together.) --- --- We drop the 'Game' prefix because the Casinos really aren't --- children of the games; the XML just makes it seem that way. --- -data OddsCasino = - OddsCasino { - casino_client_id :: Int, - casino_name :: String } - deriving (Eq, Show) - -instance FromXml OddsGameCasinoXml where +instance ToDb OddsGameCasinoXml where -- | The database representation of an 'OddsGameCasinoXml' is an -- 'OddsCasino'. -- type Db OddsGameCasinoXml = OddsCasino + +instance FromXml OddsGameCasinoXml where -- | We convert from XML to the database by dropping the line field. + -- from_xml OddsGameCasinoXml{..} = OddsCasino { casino_client_id = xml_casino_client_id, casino_name = xml_casino_name } --- | This allows us to call 'insert_xml' on an 'OddsGameCasinoXml' --- without first converting it to the database representation. -instance XmlImport OddsGameCasinoXml - --- | The database representation of teams as they appear in odds --- games. +-- | This allows us to insert the XML representation 'OddsGameCasinoXml' +-- directly. -- -data OddsGameTeam = - OddsGameTeam { - db_team_id :: String, -- ^ The home/away team IDs are - -- three characters but Postgres - -- imposes no performance penalty - -- on lengthless text fields, so - -- we ignore the probable upper - -- bound of three characters. - db_abbr :: String, - db_team_name :: String } - deriving (Eq, Show) +instance XmlImport OddsGameCasinoXml + +-- * OddsGameTeamXml / OddsGameTeamStarterXml --- | The XML representation of a \, as found in \s. --- -data OddsGameHomeTeamXml = - OddsGameHomeTeamXml { - xml_home_team_id :: String, -- ^ The home/away team IDs - -- are three characters but - -- Postgres imposes no - -- performance penalty on - -- lengthless text fields, - -- so we ignore the probable - -- upper bound of three - -- characters. - xml_home_rotation_number :: Int, - xml_home_abbr :: String, - xml_home_team_name :: String, - xml_home_casinos :: [OddsGameCasinoXml] } +-- | The XML representation of a \"starter\". It contains both an ID +-- and a name. The ID does not appear to be optional, but the name +-- can be absent. When the name is absent, the ID has always been +-- set to \"0\". This occurs even though the entire starter element +-- is optional (see 'OddsGameTeamXml' below). +-- +data OddsGameTeamStarterXml = + OddsGameTeamStarterXml { + xml_starter_id :: Int, + xml_starter_name :: Maybe String } deriving (Eq, Show) -instance FromXml OddsGameHomeTeamXml where - -- | The database representation of an 'OddsGameHomeTeamXml' is an - -- 'OddsGameTeam'. - -- - type Db OddsGameHomeTeamXml = OddsGameTeam - -- | We convert from XML to the database by dropping the lines and - -- rotation number (which are specific to the games, not the teams - -- themselves). - -- - from_xml OddsGameHomeTeamXml{..} = - OddsGameTeam { - db_team_id = xml_home_team_id, - db_abbr = xml_home_abbr, - db_team_name = xml_home_team_name } - --- | XmlImport allows us to call 'insert_xml' directly on an --- 'OddsGameHomeTeamXml' without explicitly converting it to the --- associated database type. --- -instance XmlImport OddsGameHomeTeamXml where - - --- | The XML representation of a \, as found in \s. --- -data OddsGameAwayTeamXml = - OddsGameAwayTeamXml { - xml_away_team_id :: String, -- ^ The home/away team IDs are - -- three characters but Postgres - -- imposes no performance penalty - -- on lengthless text fields, so - -- we ignore the probable upper - -- bound of three characters - xml_away_rotation_number :: Int, - xml_away_abbr :: String, - xml_away_team_name :: String, - xml_away_casinos :: [OddsGameCasinoXml] } +-- | The XML representation of a \ or \, as +-- found in \s. We can't use the 'Team' representation +-- directly because there are some other fields we need to parse. +-- +data OddsGameTeamXml = + OddsGameTeamXml { + xml_team_id :: String, -- ^ The home/away team IDs + -- are three characters but + -- Postgres imposes no + -- performance penalty on + -- lengthless text fields, + -- so we ignore the probable + -- upper bound of three + -- characters. + xml_team_rotation_number :: Maybe Int, + xml_team_abbr :: String, + xml_team_name :: String, + xml_team_starter :: Maybe OddsGameTeamStarterXml, + xml_team_casinos :: [OddsGameCasinoXml] } deriving (Eq, Show) -instance FromXml OddsGameAwayTeamXml where - -- | The database representation of an 'OddsGameAwayTeamXml' is an +instance ToDb OddsGameTeamXml where + -- | The database representation of an 'OddsGameTeamXml' is an -- 'OddsGameTeam'. -- - type Db OddsGameAwayTeamXml = OddsGameTeam + type Db OddsGameTeamXml = Team +instance FromXml OddsGameTeamXml where -- | We convert from XML to the database by dropping the lines and -- rotation number (which are specific to the games, not the teams -- themselves). -- - from_xml OddsGameAwayTeamXml{..} = OddsGameTeam - xml_away_team_id - xml_away_abbr - xml_away_team_name + from_xml OddsGameTeamXml{..} = + Team { + team_id = xml_team_id, + abbreviation = Just xml_team_abbr, + name = Just xml_team_name } --- | XmlImport allows us to call 'insert_xml' directly on an --- 'OddsGameAwayTeamXml' without explicitly converting it to the --- associated database type. +-- | This allows us to insert the XML representation +-- 'OddsGameTeamXml' directly. -- -instance XmlImport OddsGameAwayTeamXml where +instance XmlImport OddsGameTeamXml where --- | Database mapping between games and their home/away teams. -data OddsGame_OddsGameTeam = - OddsGame_OddsGameTeam { - ogogt_odds_games_id :: DefaultKey OddsGame, - ogogt_away_team_id :: DefaultKey OddsGameTeam, - ogogt_home_team_id :: DefaultKey OddsGameTeam } +-- * OddsGameOverUnderXml + -- | XML representation of the over/under. A wrapper around a bunch of -- casino elements. -- @@ -230,9 +218,11 @@ newtype OddsGameOverUnderXml = deriving (Eq, Show) +-- * OddsGameLine + -- | This database representation of the casino lines can't be -- constructed from the one in the XML. The casinos within --- Game>HomeTeam, Game>AwayTeam, and Game>Over_Under are all more or +-- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or -- less the same. We don't need a bajillion different tables to -- store that, just one tying the casino/game pair to the three -- lines. @@ -250,107 +240,154 @@ data OddsGameLine = ogl_home_line :: Maybe Double } +-- * OddsGame/OddsGameXml + -- | Database representation of a game. We retain the rotation number -- of the home/away teams, since those are specific to the game and -- not the teams. -- data OddsGame = OddsGame { + db_odds_id :: DefaultKey Odds, + db_away_team_id :: DefaultKey Team, + db_home_team_id :: DefaultKey Team, db_game_id :: Int, db_game_time :: UTCTime, -- ^ Contains both the date and time. - db_game_away_team_rotation_number :: Int, - db_game_home_team_rotation_number :: Int } - deriving (Eq, Show) + db_away_team_rotation_number :: Maybe Int, + db_home_team_rotation_number :: Maybe Int, + db_away_team_starter_id :: Maybe Int, + db_away_team_starter_name :: Maybe String, + db_home_team_starter_id :: Maybe Int, + db_home_team_starter_name :: Maybe String } --- | XML representation of a game. + +-- | XML representation of an 'OddsGame'. -- data OddsGameXml = OddsGameXml { xml_game_id :: Int, xml_game_date :: UTCTime, -- ^ Contains only the date xml_game_time :: UTCTime, -- ^ Contains only the time - xml_game_away_team :: OddsGameAwayTeamXml, - xml_game_home_team :: OddsGameHomeTeamXml, - xml_game_over_under :: OddsGameOverUnderXml } + xml_away_team :: OddsGameTeamXml, + xml_home_team :: OddsGameTeamXml, + xml_over_under :: OddsGameOverUnderXml } deriving (Eq, Show) -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of --- xml_game_over_under. +-- xml_over_under. -- -xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml] -xml_game_over_under_casinos = xml_casinos . xml_game_over_under +xml_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml] +xml_over_under_casinos = xml_casinos . xml_over_under -instance FromXml OddsGameXml where +instance ToDb OddsGameXml where -- | The database representation of an 'OddsGameXml' is an -- 'OddsGame'. -- type Db OddsGameXml = OddsGame + +instance Child OddsGameXml where + -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words + -- the foreign key for 'OddsGame' points to an 'Odds'. + -- + type Parent OddsGameXml = Odds + + +instance FromXmlFkTeams OddsGameXml where -- | To convert from the XML representation to the database one, we - -- drop the home/away teams and the casino lines, but retain the - -- home/away rotation numbers. + -- drop the casino lines, but retain the home/away rotation + -- numbers and the starters. The foreign keys to 'Odds' and the + -- home/away teams are passed in. -- - from_xml OddsGameXml{..} = + from_xml_fk_teams fk fk_away fk_home OddsGameXml{..} = OddsGame { + db_odds_id = fk, + db_away_team_id = fk_away, + db_home_team_id = fk_home, db_game_id = xml_game_id, db_game_time = UTCTime (utctDay xml_game_date) -- Take the day part from one, (utctDayTime xml_game_time), -- the time from the other. - db_game_away_team_rotation_number = - (xml_away_rotation_number xml_game_away_team), + db_away_team_rotation_number = + (xml_team_rotation_number xml_away_team), - db_game_home_team_rotation_number = - (xml_home_rotation_number xml_game_home_team) } + db_home_team_rotation_number = + (xml_team_rotation_number xml_home_team), --- | This lets us call 'insert_xml' directly on an 'OddsGameXml' --- without converting it to the database representation explicitly. --- -instance XmlImport OddsGameXml + db_away_team_starter_id = + (xml_starter_id <$> xml_team_starter xml_away_team), + -- Sometimes the starter element is present but the name isn't, + -- so we combine the two maybes with join. + db_away_team_starter_name = join + (xml_starter_name <$> xml_team_starter xml_away_team), --- | Database and representation of the top-level Odds object (a --- 'Message'). -data Odds = - Odds { - db_sport :: String, - db_title :: String, - db_line_time :: String -- ^ We don't parse these as a 'UTCTime' - -- because their timezones are ambiguous - -- (and the date is less than useful when - -- it might be off by an hour). - } + db_home_team_starter_id = + (xml_starter_id <$> xml_team_starter xml_home_team), + -- Sometimes the starter element is present but the name isn't, + -- so we combine the two maybes with join. + db_home_team_starter_name = join + (xml_starter_name <$> xml_team_starter xml_home_team) } --- | Map 'Odds' to their children 'OddsGame's. + +-- | This lets us insert the XML representation 'OddsGameXml' directly. -- -data Odds_OddsGame = Odds_OddsGame - (DefaultKey Odds) - (DefaultKey OddsGame) +instance XmlImportFkTeams OddsGameXml + +-- * OddsGameWithNotes -- | This is our best guess at what occurs in the Odds_XML -- documents. It looks like each consecutive set of games can --- optionally have some notes appear before it. Each "note" comes as --- its own ... element. +-- optionally have some notes appear before it. Each \"note\" comes +-- as its own \...\ element. -- -- The notes are ignored completely in the database; we only bother -- with them to ensure that we're (un)pickling correctly. -- --- We can't group the notes with a "set" of 'OddsGame's, because that --- leads to ambiguity in parsing. Since we're going to ignore the --- notes anyway, we just stick them with an arbitrary game. C'est la --- vie. +-- We can't group the notes with a \"set\" of 'OddsGame's, because +-- that leads to ambiguity in parsing. Since we're going to ignore +-- the notes anyway, we just stick them with an arbitrary +-- game. C'est la vie. +-- +-- We have to take the same approach with the league. The +-- \ elements are sitting outside of the games, and +-- are presumably supposed to be interpreted in \"chronological\" +-- order; i.e. the current league stays the same until we see +-- another \ element. Unfortunately, that's not how +-- XML works. So we're forced to ignore the league in the database +-- and pull the same trick, pairing them with games. -- data OddsGameWithNotes = OddsGameWithNotes { + league :: Maybe String, notes :: [String], game :: OddsGameXml } deriving (Eq, Show) + +-- * Odds/Message + +-- | Database representation of a 'Message'. +-- +data Odds = + Odds { + db_xml_file_id :: Int, + db_sport :: String, + db_title :: String, + db_line_time :: String, -- ^ We don't parse these as a 'UTCTime' + -- because their timezones are ambiguous + -- (and the date is less than useful when + -- it might be off by an hour). + db_time_stamp :: UTCTime } + + -- | The XML representation of 'Odds'. +-- data Message = Message { xml_xml_file_id :: Int, @@ -360,7 +397,7 @@ data Message = xml_title :: String, xml_line_time :: String, xml_games_with_notes :: [OddsGameWithNotes], - xml_time_stamp :: String } + xml_time_stamp :: UTCTime } deriving (Eq, Show) -- | Pseudo-field that lets us get the 'OddsGame's out of @@ -370,118 +407,108 @@ xml_games :: Message -> [OddsGameXml] xml_games m = map game (xml_games_with_notes m) -instance FromXml Message where +instance ToDb Message where -- | The database representation of a 'Message' is 'Odds'. -- type Db Message = Odds +instance FromXml Message where -- | To convert from the XML representation to the database one, we -- just drop a bunch of fields. -- from_xml Message{..} = Odds { + db_xml_file_id = xml_xml_file_id, db_sport = xml_sport, db_title = xml_title, - db_line_time = xml_line_time } + db_line_time = xml_line_time, + db_time_stamp = xml_time_stamp } --- | This lets us call 'insert_xml' on a Message directly, without --- having to convert it to its database representation explicitly. +-- | This lets us insert the XML representation 'Message' directly. -- instance XmlImport Message +-- +-- Database code +-- -- Groundhog database schema. This must come before the DbImport --- instance definition. +-- instance definition. Don't know why. mkPersist tsn_codegen_config [groundhog| - entity: Odds + constructors: + - name: Odds + uniques: + - name: unique_odds + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] - entity: OddsCasino dbName: odds_casinos constructors: - name: OddsCasino uniques: - - name: unique_odds_casino + - name: unique_odds_casinos type: constraint fields: [casino_client_id] -- entity: OddsGameTeam - dbName: odds_games_teams - constructors: - - name: OddsGameTeam - uniques: - - name: unique_odds_games_team - type: constraint - fields: [db_team_id] - - - entity: OddsGame dbName: odds_games constructors: - name: OddsGame - uniques: - - name: unique_odds_game - type: constraint - fields: [db_game_id] + fields: + - name: db_odds_id + reference: + onDelete: cascade + - name: db_away_team_id + reference: + onDelete: cascade + - name: db_home_team_id + reference: + onDelete: cascade - entity: OddsGameLine dbName: odds_games_lines - -- entity: Odds_OddsGame - dbName: odds__odds_games constructors: - - name: Odds_OddsGame + - name: OddsGameLine fields: - - name: odds_OddsGame0 # Default created by mkNormalFieldName - dbName: odds_id - - name: odds_OddsGame1 # Default created by mkNormalFieldName - dbName: odds_games_id + - name: ogl_odds_games_id + reference: + onDelete: cascade + - name: ogl_odds_casinos_id + reference: + onDelete: cascade -- entity: OddsGame_OddsGameTeam - dbName: odds_games__odds_games_teams |] instance DbImport Message where dbmigrate _= run_dbmigrate $ do + migrate (undefined :: Team) migrate (undefined :: Odds) migrate (undefined :: OddsCasino) - migrate (undefined :: OddsGameTeam) migrate (undefined :: OddsGame) - migrate (undefined :: Odds_OddsGame) - migrate (undefined :: OddsGame_OddsGameTeam) migrate (undefined :: OddsGameLine) dbimport m = do -- Insert the root "odds" element and acquire its primary key (id). odds_id <- insert_xml m - -- Next, we insert the home and away teams. We do this before - -- inserting the game itself because the game has two foreign keys - -- pointing to odds_games_teams. - forM_ (xml_games m) $ \g -> do - game_id <- insert_xml_or_select g - -- Insert a record into odds__odds_game mapping this game - -- to its parent in the odds table. - insert_ (Odds_OddsGame odds_id game_id) - - -- Next to insert the home and away teams. - away_team_id <- insert_xml_or_select (xml_game_away_team g) - home_team_id <- insert_xml_or_select (xml_game_home_team g) - - -- Insert a record into odds_games__odds_games_teams mapping the - -- home/away teams to this game. Use the full record syntax - -- because the types would let us mix up the home/away teams. - insert_ OddsGame_OddsGameTeam { - ogogt_odds_games_id = game_id, - ogogt_away_team_id = away_team_id, - ogogt_home_team_id = home_team_id } - - -- Finaly, we insert the lines. The over/under entries for this + forM_ (xml_games m) $ \game -> do + -- First we insert the home and away teams. + away_team_id <- insert_xml_or_select (xml_away_team game) + home_team_id <- insert_xml_or_select (xml_home_team game) + + -- Now insert the game, keyed to the "odds" and its teams. + game_id <- insert_xml_fk_teams odds_id away_team_id home_team_id game + + -- Finally, we insert the lines. The over/under entries for this -- game and the lines for the casinos all wind up in the same -- table, odds_games_lines. We can insert the over/under entries -- freely with empty away/home lines: - forM_ (xml_game_over_under_casinos g) $ \c -> do + forM_ (xml_over_under_casinos game) $ \c -> do -- Start by inderting the casino. ou_casino_id <- insert_xml_or_select c @@ -493,12 +520,12 @@ instance DbImport Message where ogl_away_line = Nothing, ogl_home_line = Nothing } - insertByAll ogl + insert_ ogl -- ...but then when we insert the home/away team lines, we -- prefer to update the existing entry rather than overwrite it -- or add a new record. - forM_ (xml_away_casinos $ xml_game_away_team g) $ \c ->do + forM_ (xml_team_casinos $ xml_away_team game) $ \c -> do -- insert, or more likely retrieve the existing, casino a_casino_id <- insert_xml_or_select c @@ -510,7 +537,7 @@ instance DbImport Message where Ogl_Odds_Casinos_Id ==. a_casino_id -- Repeat all that for the home team. - forM_ (xml_home_casinos $ xml_game_home_team g) $ \c ->do + forM_ (xml_team_casinos $ xml_home_team game) $ \c ->do h_casino_id <- insert_xml_or_select c let home_line = home_away_line c update [Ogl_Home_Line =. home_line] $ -- WHERE @@ -520,17 +547,23 @@ instance DbImport Message where return ImportSucceeded + +-- +-- Pickling +-- + -- | Pickler for an 'OddsGame' optionally preceded by some notes. -- pickle_game_with_notes :: PU OddsGameWithNotes pickle_game_with_notes = xpWrap (from_pair, to_pair) $ - xpPair + xpTriple + (xpOption $ xpElem "League_Name" xpText) (xpList $ xpElem "Notes" xpText) pickle_game where - from_pair = uncurry OddsGameWithNotes - to_pair OddsGameWithNotes{..} = (notes, game) + from_pair = uncurryN OddsGameWithNotes + to_pair OddsGameWithNotes{..} = (league, notes, game) -- | Pickler for an 'OddsGameCasinoXml'. @@ -551,48 +584,79 @@ pickle_casino = xml_casino_line) --- | Pickler for an 'OddsGameHomeTeamXml'. +-- | Pickler for an 'OddsGameTeamXml'. -- -pickle_home_team :: PU OddsGameHomeTeamXml +pickle_home_team :: PU OddsGameTeamXml pickle_home_team = xpElem "HomeTeam" $ xpWrap (from_tuple, to_tuple) $ - xp5Tuple + xp6Tuple (xpElem "HomeTeamID" xpText) - (xpElem "HomeRotationNumber" xpInt) + (xpElem "HomeRotationNumber" (xpOption xpInt)) (xpElem "HomeAbbr" xpText) (xpElem "HomeTeamName" xpText) + (xpOption pickle_home_starter) (xpList pickle_casino) where - from_tuple = uncurryN OddsGameHomeTeamXml + from_tuple = uncurryN OddsGameTeamXml + -- Use record wildcards to avoid unused field warnings. - to_tuple OddsGameHomeTeamXml{..} = (xml_home_team_id, - xml_home_rotation_number, - xml_home_abbr, - xml_home_team_name, - xml_home_casinos) + to_tuple OddsGameTeamXml{..} = (xml_team_id, + xml_team_rotation_number, + xml_team_abbr, + xml_team_name, + xml_team_starter, + xml_team_casinos) + + +-- | Portion of the 'OddsGameTeamStarterXml' pickler that is not +-- specific to the home/away teams. +-- +pickle_starter :: PU OddsGameTeamStarterXml +pickle_starter = + xpWrap (from_tuple, to_tuple) $ + xpPair (xpAttr "ID" xpInt) (xpOption xpText) + where + from_tuple = uncurry OddsGameTeamStarterXml + to_tuple OddsGameTeamStarterXml{..} = (xml_starter_id, + xml_starter_name) + +-- | Pickler for an home team 'OddsGameTeamStarterXml' +-- +pickle_home_starter :: PU OddsGameTeamStarterXml +pickle_home_starter = xpElem "HStarter" pickle_starter --- | Pickler for an 'OddsGameAwayTeamXml'. +-- | Pickler for an away team 'OddsGameTeamStarterXml' -- -pickle_away_team :: PU OddsGameAwayTeamXml +pickle_away_starter :: PU OddsGameTeamStarterXml +pickle_away_starter = xpElem "AStarter" pickle_starter + + + +-- | Pickler for an 'OddsGameTeamXml'. +-- +pickle_away_team :: PU OddsGameTeamXml pickle_away_team = xpElem "AwayTeam" $ xpWrap (from_tuple, to_tuple) $ - xp5Tuple + xp6Tuple (xpElem "AwayTeamID" xpText) - (xpElem "AwayRotationNumber" xpInt) + (xpElem "AwayRotationNumber" (xpOption xpInt)) (xpElem "AwayAbbr" xpText) (xpElem "AwayTeamName" xpText) + (xpOption pickle_away_starter) (xpList pickle_casino) where - from_tuple = uncurryN OddsGameAwayTeamXml + from_tuple = uncurryN OddsGameTeamXml + -- Use record wildcards to avoid unused field warnings. - to_tuple OddsGameAwayTeamXml{..} = (xml_away_team_id, - xml_away_rotation_number, - xml_away_abbr, - xml_away_team_name, - xml_away_casinos) + to_tuple OddsGameTeamXml{..} = (xml_team_id, + xml_team_rotation_number, + xml_team_abbr, + xml_team_name, + xml_team_starter, + xml_team_casinos) @@ -616,7 +680,7 @@ pickle_game = xpWrap (from_tuple, to_tuple) $ xp6Tuple (xpElem "GameID" xpInt) - (xpElem "Game_Date" xp_date) + (xpElem "Game_Date" xp_date_padded) (xpElem "Game_Time" xp_time) pickle_away_team pickle_home_team @@ -627,9 +691,9 @@ pickle_game = to_tuple OddsGameXml{..} = (xml_game_id, xml_game_date, xml_game_time, - xml_game_away_team, - xml_game_home_team, - xml_game_over_under) + xml_away_team, + xml_home_team, + xml_over_under) -- | Pickler for the top-level 'Message'. @@ -645,7 +709,7 @@ pickle_message = (xpElem "Title" xpText) (xpElem "Line_Time" xpText) (xpList pickle_game_with_notes) - (xpElem "time_stamp" xpText) + (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message to_tuple m = (xml_xml_file_id m, @@ -668,7 +732,8 @@ odds_tests :: TestTree odds_tests = testGroup "Odds tests" - [ test_pickle_of_unpickle_is_identity, + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] @@ -679,7 +744,7 @@ odds_tests = test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" - "test/xml/Odds_XML.xml", + "test/xml/Odds_XML.xml", check "pickle composed with unpickle is the identity (non-int team_id)" "test/xml/Odds_XML-noninteger-team-id.xml", @@ -688,7 +753,13 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" "test/xml/Odds_XML-positive-line.xml", check "pickle composed with unpickle is the identity (large file)" - "test/xml/Odds_XML-largefile.xml" ] + "test/xml/Odds_XML-largefile.xml", + + check "pickle composed with unpickle is the identity (league name)" + "test/xml/Odds_XML-league-name.xml", + + check "pickle composed with unpickle is the identity (missing starters)" + "test/xml/Odds_XML-missing-starters.xml" ] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path @@ -709,9 +780,74 @@ test_unpickle_succeeds = testGroup "unpickle tests" "test/xml/Odds_XML-positive-line.xml", check "unpickling succeeds (large file)" - "test/xml/Odds_XML-largefile.xml" ] + "test/xml/Odds_XML-largefile.xml", + + check "unpickling succeeds (league name)" + "test/xml/Odds_XML-league-name.xml", + + check "unpickling succeeds (missing starters)" + "test/xml/Odds_XML-missing-starters.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message let expected = True actual @?= expected + + +-- | Make sure everything gets deleted when we delete the top-level +-- record. The casinos and teams should be left behind. +-- +test_on_delete_cascade :: TestTree +test_on_delete_cascade = testGroup "cascading delete tests" + [ check "deleting odds deletes its children" + "test/xml/Odds_XML.xml" + 13 -- 5 casinos, 8 teams + , + + check "deleting odds deletes its children (non-int team_id)" + "test/xml/Odds_XML-noninteger-team-id.xml" + 51 -- 5 casinos, 46 teams + , + + check "deleting odds deleted its children (positive(+) line)" + "test/xml/Odds_XML-positive-line.xml" + 17 -- 5 casinos, 12 teams + , + + check "deleting odds deleted its children (large file)" + "test/xml/Odds_XML-largefile.xml" + 189 -- 5 casinos, 184 teams + , + check "deleting odds deleted its children (league name)" + "test/xml/Odds_XML-league-name.xml" + 35 -- 5 casinos, 30 teams + , + check "deleting odds deleted its children (missing starters)" + "test/xml/Odds_XML-missing-starters.xml" + 7 -- 5 casinos, 2 teams + ] + where + check desc path expected = testCase desc $ do + odds <- unsafe_unpickle path pickle_message + let a = undefined :: Team + let b = undefined :: Odds + let c = undefined :: OddsCasino + let d = undefined :: OddsGame + let e = undefined :: OddsGameLine + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + migrate d + migrate e + _ <- dbimport odds + deleteAll b + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + count_d <- countAll d + count_e <- countAll e + return $ sum [count_a, count_b, count_c, + count_d, count_e ] + actual @?= expected