X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FOdds.hs;h=619debca3e9079e809ed53400fa30f932a68019d;hb=693c0f45aff513b42d6d612c0a93fddc8f5c3cca;hp=5174ddb927462266e80af42eb45171bb49975f41;hpb=14dc52a2e7d7712281aee2332f7342f67abe4306;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs index 5174ddb..619debc 100644 --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -64,13 +64,12 @@ import Text.XML.HXT.Core ( import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) -import TSN.Team ( Team(..) ) +import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp ) +import TSN.Team ( FromXmlFkTeams(..), Team(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), - FromXmlFkTeams(..), ToDb(..), pickle_unpickle, unpickleable, @@ -147,16 +146,25 @@ instance FromXml OddsGameCasinoXml where instance XmlImport OddsGameCasinoXml --- * OddsGameTeamXml +-- * OddsGameTeamXml / OddsGameTeamStarterXml + +-- | 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) + -- | 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. -- --- The starter id/name could perhaps be combined into an embedded --- type, but can you make an entire embedded type optional with --- Maybe? I doubt it works. --- data OddsGameTeamXml = OddsGameTeamXml { xml_team_id :: String, -- ^ The home/away team IDs @@ -170,7 +178,7 @@ data OddsGameTeamXml = xml_team_rotation_number :: Maybe Int, xml_team_abbr :: String, xml_team_name :: String, - xml_team_starter :: Maybe (Int, String), -- ^ (id, name) + xml_team_starter :: Maybe OddsGameTeamStarterXml, xml_team_casinos :: [OddsGameCasinoXml] } deriving (Eq, Show) @@ -243,7 +251,7 @@ data OddsGame = 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_time :: Maybe UTCTime, -- ^ Contains both the date and time. db_away_team_rotation_number :: Maybe Int, db_home_team_rotation_number :: Maybe Int, db_away_team_starter_id :: Maybe Int, @@ -258,7 +266,7 @@ 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_time :: Maybe UTCTime, -- ^ Contains only the time xml_away_team :: OddsGameTeamXml, xml_home_team :: OddsGameTeamXml, xml_over_under :: OddsGameOverUnderXml } @@ -298,9 +306,7 @@ instance FromXmlFkTeams OddsGameXml where 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_time = make_game_time xml_game_date xml_game_time, db_away_team_rotation_number = (xml_team_rotation_number xml_away_team), @@ -309,16 +315,30 @@ instance FromXmlFkTeams OddsGameXml where (xml_team_rotation_number xml_home_team), db_away_team_starter_id = - (fst <$> xml_team_starter xml_away_team), + (xml_starter_id <$> xml_team_starter xml_away_team), - db_away_team_starter_name = - (snd <$> 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), db_home_team_starter_id = - (fst <$> xml_team_starter xml_home_team), - - db_home_team_starter_name = - (snd <$> xml_team_starter xml_home_team) } + (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) } + where + -- | Construct the database game time from the XML \ + -- and \ elements. The \ elements + -- sometimes have a value of \"TBA\"; in that case, we don't + -- want to pretend that we know the time by setting it to + -- e.g. midnight, so instead we make the entire date/time + -- Nothing. + make_game_time :: UTCTime -> Maybe UTCTime -> Maybe UTCTime + make_game_time _ Nothing = Nothing + make_game_time d (Just t) = Just $ UTCTime (utctDay d) (utctDayTime t) -- | This lets us insert the XML representation 'OddsGameXml' directly. @@ -437,7 +457,7 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: OddsCasino uniques: - - name: unique_odds_casino + - name: unique_odds_casinos type: constraint fields: [casino_client_id] @@ -582,9 +602,7 @@ pickle_home_team = (xpElem "HomeRotationNumber" (xpOption xpInt)) (xpElem "HomeAbbr" xpText) (xpElem "HomeTeamName" xpText) - (-- This is an ugly way to get both the HStarter ID attribute - -- and contents. - xpOption (xpElem "HStarter" $ xpPair (xpAttr "ID" xpInt) xpText)) + (xpOption pickle_home_starter) (xpList pickle_casino) where from_tuple = uncurryN OddsGameTeamXml @@ -597,6 +615,32 @@ pickle_home_team = 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 away team 'OddsGameTeamStarterXml' +-- +pickle_away_starter :: PU OddsGameTeamStarterXml +pickle_away_starter = xpElem "AStarter" pickle_starter + + + -- | Pickler for an 'OddsGameTeamXml'. -- pickle_away_team :: PU OddsGameTeamXml @@ -608,9 +652,7 @@ pickle_away_team = (xpElem "AwayRotationNumber" (xpOption xpInt)) (xpElem "AwayAbbr" xpText) (xpElem "AwayTeamName" xpText) - (-- This is an ugly way to get both the AStarter ID attribute - -- and contents. - xpOption (xpElem "AStarter" $ xpPair (xpAttr "ID" xpInt) xpText)) + (xpOption pickle_away_starter) (xpList pickle_casino) where from_tuple = uncurryN OddsGameTeamXml @@ -646,7 +688,7 @@ pickle_game = xp6Tuple (xpElem "GameID" xpInt) (xpElem "Game_Date" xp_date_padded) - (xpElem "Game_Time" xp_time) + (xpElem "Game_Time" xp_tba_time) pickle_away_team pickle_home_team pickle_over_under @@ -721,7 +763,13 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" "test/xml/Odds_XML-largefile.xml", check "pickle composed with unpickle is the identity (league name)" - "test/xml/Odds_XML-league-name.xml" ] + "test/xml/Odds_XML-league-name.xml", + + check "pickle composed with unpickle is the identity (missing starters)" + "test/xml/Odds_XML-missing-starters.xml", + + check "pickle composed with unpickle is the identity (TBA game time)" + "test/xml/Odds_XML-tba-game-time.xml"] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path @@ -745,7 +793,13 @@ test_unpickle_succeeds = testGroup "unpickle tests" "test/xml/Odds_XML-largefile.xml", check "unpickling succeeds (league name)" - "test/xml/Odds_XML-league-name.xml" ] + "test/xml/Odds_XML-league-name.xml", + + check "unpickling succeeds (missing starters)" + "test/xml/Odds_XML-missing-starters.xml", + + check "unpickling succeeds (TBA game time)" + "test/xml/Odds_XML-tba-game-time.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -780,6 +834,14 @@ test_on_delete_cascade = testGroup "cascading delete tests" 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 + , + check "deleting odds deleted its children (TBA game time)" + "test/xml/Odds_XML-tba-game-time.xml" + 119 -- 5 casinos, 114 teams ] where check desc path expected = testCase desc $ do