X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FOdds.hs;h=7af360cfb53f6adb3fa421ef18f07e0214fc5134;hb=5a8806defa5e0fb3a99ae5316d6eeceb74dda3a3;hp=bab8c28ee8e66a30ab05ac87a6c6bf5d26337ebf;hpb=d038063dd4118229da68fa91cc51c44c9cd743af;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index bab8c28..7af360c 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -3,25 +3,24 @@ {-# 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 OddsCasinoConstructor(..), OddsConstructor(..), - OddsGame_OddsGameTeamConstructor(..), + OddsGame_TeamConstructor(..), OddsGameConstructor(..), - OddsGameLineConstructor(..), - OddsGameTeamConstructor(..) ) + OddsGameLineConstructor(..) ) where -- System imports. @@ -31,10 +30,16 @@ import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( (=.), (==.), + countAll, + deleteAll, insert_, 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 ) @@ -60,14 +65,22 @@ 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, xp_time_stamp ) +import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) +import TSN.Team ( Team(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( FromXml(..), FromXmlFk(..), ToDb(..), pickle_unpickle, - unpickleable ) + unpickleable, + unsafe_unpickle ) + + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "Odds_XML.dtd" -- @@ -78,10 +91,10 @@ import Xml ( -- | 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.) +-- 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 +-- 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 = @@ -121,39 +134,24 @@ instance ToDb OddsGameCasinoXml where 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 - - --- * OddsGameTeam - - --- | 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 --- * OddsGameHomeTeam/OddsGameHomeTeamXml +-- * OddsGameHomeTeamXml / OddsGameAwayTeamXml -- | The XML representation of a \, as found in \s. +-- This is basically the same as 'OddsGameAwayTeamXml', but the two +-- types have different picklers. -- data OddsGameHomeTeamXml = OddsGameHomeTeamXml { @@ -175,7 +173,7 @@ instance ToDb OddsGameHomeTeamXml where -- | The database representation of an 'OddsGameHomeTeamXml' is an -- 'OddsGameTeam'. -- - type Db OddsGameHomeTeamXml = OddsGameTeam + type Db OddsGameHomeTeamXml = Team instance FromXml OddsGameHomeTeamXml where -- | We convert from XML to the database by dropping the lines and @@ -183,21 +181,21 @@ instance FromXml OddsGameHomeTeamXml where -- themselves). -- from_xml OddsGameHomeTeamXml{..} = - OddsGameTeam { - db_team_id = xml_home_team_id, - db_abbr = xml_home_abbr, - db_team_name = xml_home_team_name } + Team { + team_id = xml_home_team_id, + team_abbreviation = xml_home_abbr, + 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. +-- | This allows us to insert the XML representation +-- 'OddsGameHomeTeamXml' directly. -- instance XmlImport OddsGameHomeTeamXml where --- * OddsGameAwayTeam/OddsGameAwayTeamXml -- | The XML representation of a \, as found in \s. +-- This is basically the same as 'OddsGameHomeTeamXml', but the two +-- types have different picklers. -- data OddsGameAwayTeamXml = OddsGameAwayTeamXml { @@ -214,24 +212,23 @@ data OddsGameAwayTeamXml = deriving (Eq, Show) instance ToDb OddsGameAwayTeamXml where - -- | The database representation of an 'OddsGameAwayTeamXml' is an - -- 'OddsGameTeam'. + -- | The database representation of an 'OddsGameAwayTeamXml' is a + -- 'Team'. -- - type Db OddsGameAwayTeamXml = OddsGameTeam + type Db OddsGameAwayTeamXml = Team instance FromXml OddsGameAwayTeamXml 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 + from_xml OddsGameAwayTeamXml{..} = Team xml_away_team_id xml_away_abbr xml_away_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 +-- 'OddsGameAwayTeamXml' directly. -- instance XmlImport OddsGameAwayTeamXml where @@ -239,11 +236,12 @@ instance XmlImport OddsGameAwayTeamXml where -- * OddsGame_OddsGameTeam -- | 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 } +-- +data OddsGame_Team = + OddsGame_Team { + ogt_odds_games_id :: DefaultKey OddsGame, + ogt_away_team_id :: DefaultKey Team, + ogt_home_team_id :: DefaultKey Team } -- * OddsGameOverUnderXml @@ -260,7 +258,7 @@ newtype OddsGameOverUnderXml = -- | 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. @@ -293,7 +291,7 @@ data OddsGame = db_game_home_team_rotation_number :: Int } --- | XML representation of a game. +-- | XML representation of an 'OddsGame'. -- data OddsGameXml = OddsGameXml { @@ -319,6 +317,9 @@ instance ToDb OddsGameXml where type Db OddsGameXml = OddsGame instance FromXmlFk 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 -- | To convert from the XML representation to the database one, we @@ -340,8 +341,7 @@ instance FromXmlFk OddsGameXml where db_game_home_team_rotation_number = (xml_home_rotation_number xml_game_home_team) } --- | This lets us call 'insert_xml_fk' directly on an 'OddsGameXml' --- without converting it to the database representation explicitly. +-- | This lets us insert the XML representation 'OddsGameXml' directly. -- instance XmlImportFk OddsGameXml @@ -350,16 +350,16 @@ instance XmlImportFk OddsGameXml -- | 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. -- data OddsGameWithNotes = OddsGameWithNotes { @@ -370,8 +370,8 @@ data OddsGameWithNotes = -- * Odds/Message --- | Database and representation of the top-level Odds object (a --- 'Message'). +-- | Database representation of a 'Message'. +-- data Odds = Odds { db_xml_file_id :: Int, @@ -385,6 +385,7 @@ data Odds = -- | The XML representation of 'Odds'. +-- data Message = Message { xml_xml_file_id :: Int, @@ -421,8 +422,7 @@ instance FromXml Message where 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 @@ -452,16 +452,6 @@ mkPersist tsn_codegen_config [groundhog| 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: @@ -477,24 +467,24 @@ mkPersist tsn_codegen_config [groundhog| - name: OddsGameLine fields: - name: ogl_odds_games_id - references: + reference: onDelete: cascade - name: ogl_odds_casinos_id - references: + reference: onDelete: cascade -- entity: OddsGame_OddsGameTeam - dbName: odds_games__odds_games_teams +- entity: OddsGame_Team + dbName: odds_games__teams constructors: - - name: OddsGame_OddsGameTeam + - name: OddsGame_Team fields: - - name: ogogt_odds_games_id + - name: ogt_odds_games_id reference: onDelete: cascade - - name: ogogt_away_team_id + - name: ogt_away_team_id reference: onDelete: cascade - - name: ogogt_home_team_id + - name: ogt_home_team_id reference: onDelete: cascade |] @@ -502,11 +492,11 @@ mkPersist tsn_codegen_config [groundhog| 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 :: OddsGame_OddsGameTeam) + migrate (undefined :: OddsGame_Team) migrate (undefined :: OddsGameLine) dbimport m = do @@ -516,21 +506,20 @@ instance DbImport Message where forM_ (xml_games m) $ \g -> do -- 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. - -- Next to insert the home and away teams. + -- pointing to "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) -- Now insert the game, keyed to the "odds", game_id <- insert_xml_fk odds_id g - -- Insert a record into odds_games__odds_games_teams mapping the + -- Insert a record into 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 } + insert_ OddsGame_Team { + ogt_odds_games_id = game_id, + ogt_away_team_id = away_team_id, + ogt_home_team_id = home_team_id } -- Finaly, we insert the lines. The over/under entries for this -- game and the lines for the casinos all wind up in the same @@ -676,7 +665,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 @@ -728,7 +717,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 ] @@ -775,3 +765,57 @@ test_unpickle_succeeds = testGroup "unpickle tests" 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 + ] + 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 :: OddsGame_Team + let f = undefined :: OddsGameLine + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + migrate d + migrate e + migrate f + _ <- dbimport odds + deleteAll b + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + count_d <- countAll d + count_e <- countAll e + count_f <- countAll f + return $ sum [count_a, count_b, count_c, + count_d, count_e, count_f ] + actual @?= expected