From 019325f22e80859ba68a1e4b9985d00031430387 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 11 Jan 2014 03:37:44 -0500 Subject: [PATCH] Get the Odds module to compile and pass tests under the new regime. --- src/Main.hs | 13 ++- src/TSN/XML/Odds.hs | 224 ++++++++++++++++++++++++++++---------------- 2 files changed, 149 insertions(+), 88 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 6a03800..27ddb66 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -48,7 +48,7 @@ import qualified TSN.XML.Heartbeat as Heartbeat ( verify ) import qualified TSN.XML.Injuries as Injuries ( Message ) import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( Message ) import qualified TSN.XML.News as News ( Message ) ---import qualified TSN.XML.Odds as Odds ( Odds ) +import qualified TSN.XML.Odds as Odds ( Message ) import Xml ( DtdName(..), parse_opts ) @@ -135,11 +135,11 @@ import_file cfg path = do -- We special-case the heartbeat so it doesn't have to run in -- the database monad. | dtd == "Heartbeat.dtd" = Heartbeat.verify xml - | otherwise = do + | otherwise = -- We need NoMonomorphismRestriction here. if backend cfg == Postgres - then withPostgresqlConn cs $ runDbConn $ importer - else withSqliteConn cs $ runDbConn $ importer + then withPostgresqlConn cs $ runDbConn importer + else withSqliteConn cs $ runDbConn importer where -- | Pull the real connection String out of the configuration. cs :: String @@ -165,7 +165,10 @@ import_file cfg path = do let errmsg = "Could not unpickle newsxml." maybe (return $ ImportFailed errmsg) migrate_and_import m - -- | dtd == "Odds_XML.dtd" = undefined + | dtd == "Odds_XML.dtd" = do + let m = unpickleDoc xpickle xml :: Maybe Odds.Message + let errmsg = "Could not unpickle Odds_XML." + maybe (return $ ImportFailed errmsg) migrate_and_import m | otherwise = do let infomsg = diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index b053850..a4fddb9 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -59,7 +59,8 @@ import TSN.Codegen ( tsn_codegen_config, tsn_db_field_namer ) import TSN.DbImport ( DbImport(..), ImportResult(..) ) -import Xml ( ToFromXml(..), pickle_unpickle, unpickleable ) +import TSN.XmlImport ( XmlImport(..) ) +import Xml ( FromXml(..), pickle_unpickle, unpickleable ) @@ -70,52 +71,72 @@ data OddsCasinoXml = xml_casino_line :: Maybe Float } deriving (Eq, Show) + -- | 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.) data OddsCasino = OddsCasino { - db_casino_client_id :: Int, - db_casino_name :: String } + casino_client_id :: Int, + casino_name :: String } deriving (Eq, Show) -instance ToFromXml OddsCasino where - type Xml OddsCasino = OddsCasinoXml - type Container OddsCasino = () -- It has one, but we don't use it. - - -- Use a record wildcard here so GHC doesn't complain that we never - -- used our named fields. - to_xml (OddsCasino {..}) = - OddsCasinoXml - db_casino_client_id - db_casino_name - def +instance FromXml OddsCasinoXml where + type Db OddsCasinoXml = OddsCasino -- We don't need the key argument (from_xml_fk) since the XML type -- contains more information in this case. - from_xml OddsCasinoXml{..} = - OddsCasino - xml_casino_client_id - xml_casino_name - -data OddsHomeTeam = - OddsHomeTeam { - home_team_id :: Int, - home_rotation_number :: Int, - home_abbr :: String, - home_team_name :: String, - home_casinos :: [OddsCasinoXml] } + from_xml OddsCasinoXml{..} = OddsCasino + xml_casino_client_id + xml_casino_name + +instance XmlImport OddsCasinoXml + + +data OddsHomeTeamXml = + OddsHomeTeamXml { + xml_home_team_id :: Int, + xml_home_rotation_number :: Int, + xml_home_abbr :: String, + xml_home_team_name :: String, + xml_home_casinos :: [OddsCasinoXml] } + deriving (Eq, Show) + +instance FromXml OddsHomeTeamXml where + type Db OddsHomeTeamXml = OddsTeam + from_xml OddsHomeTeamXml{..} = OddsTeam + xml_home_team_id + xml_home_abbr + xml_home_team_name + +instance XmlImport OddsHomeTeamXml where + + +data OddsTeam = + OddsTeam { + db_team_id :: Int, + db_abbr :: String, + db_team_name :: String } deriving (Eq, Show) -data OddsAwayTeam = - OddsAwayTeam { - away_team_id :: Int, - away_rotation_number :: Int, - away_abbr :: String, - away_team_name :: String, - away_casinos :: [OddsCasinoXml] } +data OddsAwayTeamXml = + OddsAwayTeamXml { + xml_away_team_id :: Int, + xml_away_rotation_number :: Int, + xml_away_abbr :: String, + xml_away_team_name :: String, + xml_away_casinos :: [OddsCasinoXml] } deriving (Eq, Show) +instance FromXml OddsAwayTeamXml where + type Db OddsAwayTeamXml = OddsTeam + from_xml OddsAwayTeamXml{..} = OddsTeam + xml_away_team_id + xml_away_abbr + xml_away_team_name + +instance XmlImport OddsAwayTeamXml where + -- | Can't use a newtype with Groundhog. data OddsOverUnder = OddsOverUnder [OddsCasinoXml] @@ -123,12 +144,24 @@ data OddsOverUnder = data OddsGame = OddsGame { - game_id :: Int, - game_date :: String, -- TODO - game_time :: String, -- TODO - game_away_team :: OddsAwayTeam, - game_home_team :: OddsHomeTeam, - game_over_under :: OddsOverUnder } + db_game_id :: Int, + db_game_date :: String, -- TODO + db_game_time :: String, -- TODO + db_game_away_team_id :: DefaultKey OddsTeam, + db_game_away_team_rotation_number :: Int, + db_game_home_team_id :: DefaultKey OddsTeam, + db_game_home_team_rotation_number :: Int } +deriving instance Eq OddsGame +deriving instance Show OddsGame + +data OddsGameXml = + OddsGameXml { + xml_game_id :: Int, + xml_game_date :: String, -- TODO + xml_game_time :: String, -- TODO + xml_game_away_team :: OddsAwayTeamXml, + xml_game_home_team :: OddsHomeTeamXml, + xml_game_over_under :: OddsOverUnder } deriving (Eq, Show) data Odds = @@ -153,7 +186,7 @@ data Odds = data OddsGameWithNotes = OddsGameWithNotes { notes :: [String], - game :: OddsGame } + game :: OddsGameXml } deriving (Eq, Show) -- | The XML representation of Odds. @@ -171,30 +204,22 @@ data Message = -- | Pseudo-field that lets us get the 'OddsGame's out of -- 'xml_games_with_notes'. -xml_games :: Message -> [OddsGame] +xml_games :: Message -> [OddsGameXml] xml_games m = map game (xml_games_with_notes m) -instance ToFromXml Odds where - type Xml Odds = Message - type Container Odds = () - - -- Use record wildcards to avoid unused field warnings. - to_xml (Odds {..}) = - Message - def - def - def - db_sport - db_title - db_line_time - def - def +instance FromXml Message where + type Db Message = Odds -- We don't need the key argument (from_xml_fk) since the XML type -- contains more information in this case. from_xml (Message _ _ _ d e f _ _) = Odds d e f +instance XmlImport Message + +instance DbImport Message where + dbmigrate _= undefined + dbimport = undefined pickle_game_with_notes :: PU OddsGameWithNotes pickle_game_with_notes = @@ -227,7 +252,7 @@ instance XmlPickler OddsCasinoXml where xpickle = pickle_casino -pickle_home_team :: PU OddsHomeTeam +pickle_home_team :: PU OddsHomeTeamXml pickle_home_team = xpElem "HomeTeam" $ xpWrap (from_tuple, to_tuple) $ @@ -238,19 +263,19 @@ pickle_home_team = (xpElem "HomeTeamName" xpText) (xpList pickle_casino) where - from_tuple = uncurryN OddsHomeTeam + from_tuple = uncurryN OddsHomeTeamXml -- Use record wildcards to avoid unused field warnings. - to_tuple OddsHomeTeam{..} = (home_team_id, - home_rotation_number, - home_abbr, - home_team_name, - home_casinos) + to_tuple OddsHomeTeamXml{..} = (xml_home_team_id, + xml_home_rotation_number, + xml_home_abbr, + xml_home_team_name, + xml_home_casinos) -instance XmlPickler OddsHomeTeam where +instance XmlPickler OddsHomeTeamXml where xpickle = pickle_home_team -pickle_away_team :: PU OddsAwayTeam +pickle_away_team :: PU OddsAwayTeamXml pickle_away_team = xpElem "AwayTeam" $ xpWrap (from_tuple, to_tuple) $ @@ -261,16 +286,16 @@ pickle_away_team = (xpElem "AwayTeamName" xpText) (xpList pickle_casino) where - from_tuple = uncurryN OddsAwayTeam + from_tuple = uncurryN OddsAwayTeamXml -- Use record wildcards to avoid unused field warnings. - to_tuple OddsAwayTeam{..} = (away_team_id, - away_rotation_number, - away_abbr, - away_team_name, - away_casinos) + to_tuple OddsAwayTeamXml{..} = (xml_away_team_id, + xml_away_rotation_number, + xml_away_abbr, + xml_away_team_name, + xml_away_casinos) -instance XmlPickler OddsAwayTeam where +instance XmlPickler OddsAwayTeamXml where xpickle = pickle_away_team @@ -287,7 +312,7 @@ instance XmlPickler OddsOverUnder where xpickle = pickle_over_under -pickle_game :: PU OddsGame +pickle_game :: PU OddsGameXml pickle_game = xpElem "Game" $ xpWrap (from_tuple, to_tuple) $ @@ -299,16 +324,16 @@ pickle_game = pickle_home_team pickle_over_under where - from_tuple = uncurryN OddsGame + from_tuple = uncurryN OddsGameXml -- Use record wildcards to avoid unused field warnings. - to_tuple OddsGame{..} = (game_id, - game_date, - game_time, - game_away_team, - game_home_team, - game_over_under) - -instance XmlPickler OddsGame where + to_tuple OddsGameXml{..} = (xml_game_id, + xml_game_date, + xml_game_time, + xml_game_away_team, + xml_game_home_team, + xml_game_over_under) + +instance XmlPickler OddsGameXml where xpickle = pickle_game @@ -322,7 +347,7 @@ pickle_message = (xpElem "sport" xpText) (xpElem "Title" xpText) (xpElem "Line_Time" xpText) - (xpList $ pickle_game_with_notes) + (xpList pickle_game_with_notes) (xpElem "time_stamp" xpText) where from_tuple = uncurryN Message @@ -343,6 +368,39 @@ instance XmlPickler Message where +-- * Groundhog database schema. +mkPersist tsn_codegen_config [groundhog| +- entity: Odds + +- entity: OddsCasino + dbName: odds_casinos + constructors: + - name: OddsCasino + uniques: + - name: unique_odds_casino + type: constraint + fields: [casino_client_id] + +- entity: OddsTeam + dbName: odds_teams + constructors: + - name: OddsTeam + uniques: + - name: unique_odds_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] +|] + -- * Tasty Tests odds_tests :: TestTree -- 2.43.2