X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FOdds.hs;h=509b436d05760022d636e42a51a53e3249920087;hb=1f260c118e8da5679820c8cfa489d8fe4a521140;hp=7a2a6cc368d0f470dcfa5879638bf703af2f8e17;hpb=9d2fd74804d0b7720fd8d0b68beafc6c2777c5d1;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index 7a2a6cc..509b436 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -12,8 +12,9 @@ -- unorganized crap. -- module TSN.XML.Odds ( - odds_tests, pickle_message, + -- * Tests + odds_tests, -- * WARNING: these are private but exported to silence warnings Odds_OddsGameConstructor(..), OddsCasinoConstructor(..), @@ -24,7 +25,9 @@ module TSN.XML.Odds ( OddsGameTeamConstructor(..) ) where +-- System imports. import Control.Monad ( forM_, join ) +import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( (=.), @@ -55,10 +58,11 @@ import Text.XML.HXT.Core ( xpTriple, xpWrap ) +-- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_team_id ) +import TSN.Picklers ( xp_date, xp_team_id, xp_time ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), pickle_unpickle, unpickleable ) @@ -66,7 +70,7 @@ import Xml ( FromXml(..), pickle_unpickle, unpickleable ) -- | 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 --- with a String and then attempt to 'read' a 'Double' later when we +-- with a 'String' and then attempt to 'read' a 'Double' later when we -- go to insert the thing. -- data OddsGameCasinoXml = @@ -83,8 +87,9 @@ data OddsGameCasinoXml = 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 +-- 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 @@ -96,20 +101,37 @@ data OddsCasino = casino_name :: String } deriving (Eq, Show) + instance FromXml OddsGameCasinoXml where + -- | The database representation of an 'OddsGameCasinoXml' is an + -- 'OddsCasino'. + -- type Db OddsGameCasinoXml = OddsCasino - -- We don't need the key argument (from_xml_fk) since the XML type - -- contains more information in this case. + -- | 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. +-- +data OddsGameTeam = + OddsGameTeam { + db_team_id :: String, -- ^ The home/away team IDs are 3 characters + db_abbr :: String, + db_team_name :: String } + deriving (Eq, Show) + + +-- | The XML representation of a \, as found in \s. +-- data OddsGameHomeTeamXml = OddsGameHomeTeamXml { xml_home_team_id :: String, -- ^ These are three-character IDs. @@ -120,31 +142,30 @@ data OddsGameHomeTeamXml = 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 -data OddsGameTeam = - OddsGameTeam { - db_team_id :: String, -- ^ The home/away team IDs are 3 characters - db_abbr :: String, - db_team_name :: String } - deriving (Eq, Show) - - --- | 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 } - +-- | -- | The XML representation of a \, as found in \s. +-- data OddsGameAwayTeamXml = OddsGameAwayTeamXml { xml_away_team_id :: String, -- ^ These are 3 character IDs. @@ -155,19 +176,43 @@ data OddsGameAwayTeamXml = deriving (Eq, Show) instance FromXml OddsGameAwayTeamXml where + -- | The database representation of an 'OddsGameAwayTeamXml' is an + -- 'OddsGameTeam'. + -- type Db OddsGameAwayTeamXml = 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 OddsGameAwayTeamXml{..} = OddsGameTeam 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. +-- instance XmlImport OddsGameAwayTeamXml where --- | Can't use a newtype with Groundhog. + +-- | 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 } + + +-- | XML representation of the over/under. A wrapper around a bunch of +-- casino elements. +-- newtype OddsGameOverUnderXml = OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] } deriving (Eq, Show) + -- | 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 @@ -187,34 +232,49 @@ data OddsGameLine = ogl_away_line :: Maybe Double, ogl_home_line :: Maybe Double } + +-- | 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_game_id :: Int, - db_game_date :: String, -- TODO - db_game_time :: String, -- TODO + db_game_date :: UTCTime, + db_game_time :: UTCTime, db_game_away_team_rotation_number :: Int, db_game_home_team_rotation_number :: Int } -deriving instance Eq OddsGame -deriving instance Show OddsGame + deriving (Eq, Show) +-- | XML representation of a game. +-- data OddsGameXml = OddsGameXml { xml_game_id :: Int, - xml_game_date :: String, -- TODO - xml_game_time :: String, -- TODO + xml_game_date :: UTCTime, + xml_game_time :: UTCTime, xml_game_away_team :: OddsGameAwayTeamXml, xml_game_home_team :: OddsGameHomeTeamXml, xml_game_over_under :: OddsGameOverUnderXml } deriving (Eq, Show) --- | Pseudo-field that lets us get the 'OddsCasino's out of +-- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of -- xml_game_over_under. +-- xml_game_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml] xml_game_over_under_casinos = xml_casinos . xml_game_over_under instance FromXml OddsGameXml where + -- | The database representation of an 'OddsGameXml' is an + -- 'OddsGame'. + -- type Db OddsGameXml = OddsGame + + -- | 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. + -- from_xml OddsGameXml{..} = OddsGame { db_game_id = xml_game_id, @@ -225,10 +285,14 @@ instance FromXml OddsGameXml where db_game_home_team_rotation_number = (xml_home_rotation_number xml_game_home_team) } +-- | This lets us call 'insert_xml' directly on an 'OddsGameXml' +-- without converting it to the database representation explicitly. +-- instance XmlImport OddsGameXml - +-- | Database and representation of the top-level Odds object (a +-- 'Message'). data Odds = Odds { db_sport :: String, @@ -262,7 +326,7 @@ data OddsGameWithNotes = game :: OddsGameXml } deriving (Eq, Show) --- | The XML representation of Odds. +-- | The XML representation of 'Odds'. data Message = Message { xml_xml_file_id :: Int, @@ -277,27 +341,34 @@ data Message = -- | Pseudo-field that lets us get the 'OddsGame's out of -- 'xml_games_with_notes'. +-- xml_games :: Message -> [OddsGameXml] xml_games m = map game (xml_games_with_notes m) instance FromXml Message where + -- | The database representation of a 'Message' is 'Odds'. + -- type Db Message = Odds - -- We don't need the key argument (from_xml_fk) since the XML type - -- contains more information in this case. + -- | To convert from the XML representation to the database one, we + -- just drop a bunch of fields. + -- from_xml Message{..} = Odds { db_sport = xml_sport, db_title = xml_title, db_line_time = xml_line_time } +-- | This lets us call 'insert_xml' on a Message directly, without +-- having to convert it to its database representation explicitly. +-- instance XmlImport Message --- * Groundhog database schema. --- | This must come before the dbimport code. +-- | Groundhog database schema. This must come before the DbImport +-- instance definition. -- mkPersist tsn_codegen_config [groundhog| - entity: Odds @@ -317,7 +388,7 @@ mkPersist tsn_codegen_config [groundhog| - name: OddsGameTeam fields: - name: db_team_id - type: varchar(3) + type: varchar(3) # We've only seen 3, so far... uniques: - name: unique_odds_games_team type: constraint @@ -341,9 +412,9 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: Odds_OddsGame fields: - - name: odds_OddsGame0 + - name: odds_OddsGame0 # Default created by mkNormalFieldName dbName: odds_id - - name: odds_OddsGame1 + - name: odds_OddsGame1 # Default created by mkNormalFieldName dbName: odds_games_id - entity: OddsGame_OddsGameTeam @@ -429,6 +500,8 @@ instance DbImport Message where return ImportSucceeded +-- | Pickler for an 'OddsGame' optionally preceded by some notes. +-- pickle_game_with_notes :: PU OddsGameWithNotes pickle_game_with_notes = xpWrap (from_pair, to_pair) $ @@ -440,7 +513,8 @@ pickle_game_with_notes = to_pair OddsGameWithNotes{..} = (notes, game) - +-- | Pickler for an 'OddsGameCasinoXml'. +-- pickle_casino :: PU OddsGameCasinoXml pickle_casino = xpElem "Casino" $ @@ -457,6 +531,8 @@ pickle_casino = xml_casino_line) +-- | Pickler for an 'OddsGameHomeTeamXml'. +-- pickle_home_team :: PU OddsGameHomeTeamXml pickle_home_team = xpElem "HomeTeam" $ @@ -477,7 +553,8 @@ pickle_home_team = xml_home_casinos) - +-- | Pickler for an 'OddsGameAwayTeamXml'. +-- pickle_away_team :: PU OddsGameAwayTeamXml pickle_away_team = xpElem "AwayTeam" $ @@ -499,6 +576,8 @@ pickle_away_team = +-- | Pickler for an 'OddsGameOverUnderXml'. +-- pickle_over_under :: PU OddsGameOverUnderXml pickle_over_under = xpElem "Over_Under" $ @@ -509,15 +588,16 @@ pickle_over_under = to_newtype = OddsGameOverUnderXml - +-- | Pickler for an 'OddsGameXml'. +-- pickle_game :: PU OddsGameXml pickle_game = xpElem "Game" $ xpWrap (from_tuple, to_tuple) $ xp6Tuple (xpElem "GameID" xpInt) - (xpElem "Game_Date" xpText) - (xpElem "Game_Time" xpText) + (xpElem "Game_Date" xp_date) + (xpElem "Game_Time" xp_time) pickle_away_team pickle_home_team pickle_over_under @@ -532,6 +612,8 @@ pickle_game = xml_game_over_under) +-- | Pickler for the top-level 'Message'. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -556,8 +638,12 @@ pickle_message = xml_time_stamp m) +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- odds_tests :: TestTree odds_tests = testGroup @@ -566,8 +652,10 @@ odds_tests = test_unpickle_succeeds ] --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: succeess of this +-- test does not mean that unpickling succeeded. +-- 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" @@ -587,6 +675,8 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds"