X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=blobdiff_plain;f=src%2FTSN%2FXML%2FJFile.hs;h=f570784083f22ef662e451ba42bb8a25055c5d90;hp=d2ac6f4db7b35f5793f0c3f946622cee5785d824;hb=fdd85d5ed7944e6a6373c99c2e341f370cd931f8;hpb=9f8805d6aa95283e9e2d99259a17cb8c72f6ca62 diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs index d2ac6f4..f570784 100644 --- a/src/TSN/XML/JFile.hs +++ b/src/TSN/XML/JFile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -18,29 +19,27 @@ module TSN.XML.JFile ( jfile_tests, -- * WARNING: these are private but exported to silence warnings JFileConstructor(..), - JFileGameConstructor(..), - JFileGame_TeamConstructor(..) ) + JFileGameConstructor(..) ) where -- System imports -import Control.Monad ( forM_ ) +import Control.Monad ( forM_, join ) import Data.List ( intercalate ) import Data.String.Utils ( split ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, - insert_, - migrate, - runMigration, - silentMigrationLogger ) + migrate ) import Database.Groundhog.Core ( DefaultKey ) -import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( @@ -62,22 +61,28 @@ import Text.XML.HXT.Core ( -- Local imports +import Misc ( double_just ) import TSN.Codegen ( tsn_codegen_config ) +import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date, xp_date_padded, xp_datetime, - xp_time, + xp_tba_time, xp_time_dots, xp_time_stamp ) -import TSN.Team ( Team(..) ) +import TSN.Team ( + FromXmlFkTeams(..), + HTeam(..), + Team(..), + VTeam(..) ) import TSN.XmlImport ( XmlImport(..), - XmlImportFk(..) ) + XmlImportFkTeams(..) ) import Xml ( + Child(..), FromXml(..), - FromXmlFk(..), ToDb(..), pickle_unpickle, unpickleable, @@ -118,7 +123,12 @@ data Message = xml_sport :: String, xml_gamelist :: JFileGameListXml, xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector Message instance ToDb Message where @@ -149,67 +159,6 @@ instance FromXml Message where instance XmlImport Message --- * JFileGameAwayTeamXml / JFileGameHomeTeamXml - --- | The XML representation of a JFile away team. Its corresponding --- database representation (along with that of the home team) is a --- TSN.Team, but their XML representations are different. -data JFileGameAwayTeamXml = - JFileGameAwayTeamXml { - away_team_id :: String, - away_team_abbreviation :: Maybe String, - away_team_name :: Maybe String } - deriving (Eq, Show) - -instance ToDb JFileGameAwayTeamXml where - -- | The database analogue of an 'JFileGameAwayTeamXml' is - -- a 'Team'. - -- - type Db JFileGameAwayTeamXml = Team - -instance FromXml JFileGameAwayTeamXml where - -- | To convert a 'JFileGameAwayTeamXml' to a 'Team', we do just - -- about nothing. - -- - from_xml JFileGameAwayTeamXml{..} = - Team { - team_id = away_team_id, - team_abbreviation = away_team_abbreviation, - team_name = away_team_name } - --- | Allow us to import JFileGameAwayTeamXml directly. -instance XmlImport JFileGameAwayTeamXml - - --- | The XML representation of a JFile home team. Its corresponding --- database representation (along with that of the away team) is a --- TSN.Team, but their XML representations are different. -data JFileGameHomeTeamXml = - JFileGameHomeTeamXml { - home_team_id :: String, - home_team_abbreviation :: Maybe String, - home_team_name :: Maybe String } - deriving (Eq, Show) - -instance ToDb JFileGameHomeTeamXml where - -- | The database analogue of an 'JFileGameHomeTeamXml' is - -- a 'Team'. - -- - type Db JFileGameHomeTeamXml = Team - -instance FromXml JFileGameHomeTeamXml where - -- | To convert a 'JFileGameHomeTeamXml' to a 'Team', we do just - -- about nothing. - -- - from_xml JFileGameHomeTeamXml{..} = - Team { - team_id = home_team_id, - team_abbreviation = home_team_abbreviation, - team_name = home_team_name } - --- | Allow us to import JFileGameHomeTeamXml directly. -instance XmlImport JFileGameHomeTeamXml - -- * JFileGame/JFileGameXml @@ -223,11 +172,14 @@ instance XmlImport JFileGameHomeTeamXml -- All of these are optional because TSN does actually leave the -- whole thing empty from time to time. -- +-- We stick \"info\" on the home/away team ids to avoid a name clash +-- with the game itself. +-- data JFileGameOddsInfo = JFileGameOddsInfo { db_list_date :: Maybe UTCTime, - db_home_team_id :: Maybe String, -- redundant (Team) - db_away_team_id :: Maybe String, -- redundant (Team) + db_info_home_team_id :: Maybe String, -- redundant (Team) + db_info_away_team_id :: Maybe String, -- redundant (Team) db_home_abbr :: Maybe String, -- redundant (Team) db_away_abbr :: Maybe String, -- redundant (Team) db_home_team_name :: Maybe String, -- redundant (Team) @@ -254,6 +206,7 @@ data JFileGameStatus = deriving (Eq, Show) + -- | Database representation of a \ contained within a -- \, and, implicitly, a \. -- @@ -263,11 +216,13 @@ data JFileGameStatus = data JFileGame = JFileGame { db_jfile_id :: DefaultKey JFile, + db_away_team_id :: DefaultKey Team, + db_home_team_id :: DefaultKey Team, db_game_id :: Int, db_schedule_id :: Int, db_odds_info :: JFileGameOddsInfo, db_season_type :: Maybe String, - db_game_time :: UTCTime, + db_game_time :: Maybe UTCTime, db_vleague :: Maybe String, db_hleague :: Maybe String, db_vscore :: Int, @@ -289,16 +244,21 @@ data JFileGameXml = xml_odds_info :: JFileGameOddsInfo, xml_season_type :: Maybe String, xml_game_date :: UTCTime, - xml_game_time :: UTCTime, - xml_vteam :: JFileGameAwayTeamXml, + xml_game_time :: Maybe UTCTime, + xml_vteam :: VTeam, xml_vleague :: Maybe String, - xml_hteam :: JFileGameHomeTeamXml, + xml_hteam :: HTeam, xml_hleague :: Maybe String, xml_vscore :: Int, xml_hscore :: Int, xml_time_remaining :: Maybe String, xml_game_status :: JFileGameStatus } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector JFileGameXml -- * JFileGameListXml @@ -320,19 +280,24 @@ instance ToDb JFileGameXml where -- type Db JFileGameXml = JFileGame -instance FromXmlFk JFileGameXml where + +instance Child JFileGameXml where -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to) -- a 'JFile'. -- type Parent JFileGameXml = JFile + +instance FromXmlFkTeams JFileGameXml where -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the - -- foreign key and drop the 'xml_vteam'/'xml_hteam'. We also mash + -- foreign keys for JFile and the home/away teams. We also mash -- the date/time together into one field. -- - from_xml_fk fk JFileGameXml{..} = + from_xml_fk_teams fk fk_away fk_home JFileGameXml{..} = JFileGame { db_jfile_id = fk, + db_away_team_id = fk_away, + db_home_team_id = fk_home, db_game_id = xml_game_id, db_schedule_id = xml_schedule_id, db_odds_info = xml_odds_info, @@ -345,28 +310,21 @@ instance FromXmlFk JFileGameXml where db_time_remaining = xml_time_remaining, db_game_status = xml_game_status } where - -- | Make the database \"game time\" from the XML - -- date/time. Simply take the day part from one and the time - -- from the other. - -- - make_game_time d t = UTCTime (utctDay d) (utctDayTime t) + -- | 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 allows us to insert the XML representation -- 'JFileGameXml' directly. -- -instance XmlImportFk JFileGameXml - - --- * JFileGame_Team - --- | Database mapping between games and their home/away teams. --- -data JFileGame_Team = - JFileGame_Team { - jgt_jfile_games_id :: DefaultKey JFileGame, - jgt_away_team_id :: DefaultKey Team, - jgt_home_team_id :: DefaultKey Team } +instance XmlImportFkTeams JFileGameXml --- @@ -379,7 +337,6 @@ instance DbImport Message where migrate (undefined :: Team) migrate (undefined :: JFile) migrate (undefined :: JFileGame) - migrate (undefined :: JFileGame_Team) dbimport m = do -- Insert the top-level message @@ -387,20 +344,12 @@ instance DbImport Message where -- Now loop through the message's games forM_ (xml_games $ xml_gamelist m) $ \game -> do - -- First insert the game, keyed to the "jfile", - game_id <- insert_xml_fk msg_id game - - -- Next, we insert the home and away teams. - away_team_id <- insert_xml_or_select (xml_vteam game) - home_team_id <- insert_xml_or_select (xml_hteam game) + -- First we insert the home and away teams. + away_team_id <- insert_or_select (vteam $ xml_vteam game) + home_team_id <- insert_or_select (hteam $ xml_hteam game) - -- Insert a record into jfile_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_ JFileGame_Team { - jgt_jfile_games_id = game_id, - jgt_away_team_id = away_team_id, - jgt_home_team_id = home_team_id } + -- Now insert the game keyed to the "jfile" and its teams. + insert_xml_fk_teams_ msg_id away_team_id home_team_id game return ImportSucceeded @@ -424,8 +373,8 @@ mkPersist tsn_codegen_config [groundhog| - name: db_status dbName: status -# Many of the JFileGameOddsInfo fields are redundant and have -# been left out. + # Many of the JFileGameOddsInfo fields are redundant and have + # been left out. - embedded: JFileGameOddsInfo fields: - name: db_list_date @@ -451,6 +400,12 @@ mkPersist tsn_codegen_config [groundhog| - name: db_jfile_id reference: onDelete: cascade + - name: db_away_team_id + reference: + onDelete: cascade + - name: db_home_team_id + reference: + onDelete: cascade - name: db_odds_info embeddedType: - {name: list_date, dbName: list_date} @@ -466,20 +421,6 @@ mkPersist tsn_codegen_config [groundhog| - {name: status_numeral, dbName: status_numeral} - {name: status, dbName: status} -- entity: JFileGame_Team - dbName: jfile_games__teams - constructors: - - name: JFileGame_Team - fields: - - name: jgt_jfile_games_id - reference: - onDelete: cascade - - name: jgt_away_team_id - reference: - onDelete: cascade - - name: jgt_home_team_id - reference: - onDelete: cascade |] @@ -493,7 +434,7 @@ mkPersist tsn_codegen_config [groundhog| pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) @@ -502,12 +443,7 @@ pickle_message = (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, - xml_heading m, - xml_category m, - xml_sport m, - xml_gamelist m, - xml_time_stamp m) + pickle_gamelist :: PU JFileGameListXml pickle_gamelist = @@ -523,15 +459,15 @@ pickle_gamelist = pickle_game :: PU JFileGameXml pickle_game = xpElem "game" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xp14Tuple (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) pickle_odds_info (xpElem "seasontype" (xpOption xpText)) (xpElem "Game_Date" xp_date_padded) - (xpElem "Game_Time" xp_time) + (xpElem "Game_Time" xp_tba_time) pickle_away_team - (xpOption $ xpElem "vleague" xpText) + (xpOption $ xpElem "vleague" (xpOption xpText)) pickle_home_team (xpOption $ xpElem "hleague" xpText) (xpElem "vscore" xpInt) @@ -539,26 +475,17 @@ pickle_game = (xpOption $ xpElem "time_r" xpText) pickle_status where - from_tuple = uncurryN JFileGameXml - to_tuple m = (xml_game_id m, - xml_schedule_id m, - xml_odds_info m, - xml_season_type m, - xml_game_date m, - xml_game_time m, - xml_vteam m, - xml_vleague m, - xml_hteam m, - xml_hleague m, - xml_vscore m, - xml_hscore m, - xml_time_remaining m, - xml_game_status m) + from_tuple (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = + JFileGameXml a b c d e f g (join h) i j k l m n + + to_tuple' (JFileGameXml a b c d e f g h i j k l m n) = + (a, b, c, d, e, f, g, double_just h, i, j, k, l, m, n) + pickle_odds_info :: PU JFileGameOddsInfo pickle_odds_info = xpElem "Odds_Info" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xp19Tuple (xpElem "ListDate" (xpOption xp_date)) (xpElem "HomeTeamID" (xpOption xpText)) (xpElem "AwayTeamID" (xpOption xpText)) @@ -584,21 +511,21 @@ pickle_odds_info = where notes = intercalate "\n" [n1,n2,n3,n4,n5] - to_tuple o = (db_list_date o, - db_home_team_id o, - db_away_team_id o, - db_home_abbr o, - db_away_abbr o, - db_home_team_name o, - db_away_team_name o, - db_home_starter o, - db_away_starter o, - db_game_date o, - db_home_game_key o, - db_away_game_key o, - db_current_timestamp o, - db_live o, - n1,n2,n3,n4,n5) + to_tuple' o = (db_list_date o, + db_info_home_team_id o, + db_info_away_team_id o, + db_home_abbr o, + db_away_abbr o, + db_home_team_name o, + db_away_team_name o, + db_home_starter o, + db_away_starter o, + db_game_date o, + db_home_game_key o, + db_away_game_key o, + db_current_timestamp o, + db_live o, + n1,n2,n3,n4,n5) where note_lines = split "\n" (db_notes o) n1 = case note_lines of @@ -617,45 +544,47 @@ pickle_odds_info = (_:_:_:_:notes5:_) -> notes5 _ -> "" -pickle_home_team :: PU JFileGameHomeTeamXml +-- | (Un)pickle a home team to/from the dual XML/DB representation +-- 'Team'. +-- +pickle_home_team :: PU HTeam pickle_home_team = xpElem "hteam" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. (xpAttr "abbr" (xpOption xpText)) -- Some are blank (xpOption xpText) -- Yup, some are nameless where - from_tuple = uncurryN JFileGameHomeTeamXml - to_tuple t = (home_team_id t, - home_team_abbreviation t, - home_team_name t) + from_tuple = HTeam . (uncurryN Team) + to_tuple' (HTeam t) = H.convert t -pickle_away_team :: PU JFileGameAwayTeamXml +-- | (Un)pickle an away team to/from the dual XML/DB representation +-- 'Team'. +-- +pickle_away_team :: PU VTeam pickle_away_team = xpElem "vteam" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. (xpAttr "abbr" (xpOption xpText)) -- Some are blank (xpOption xpText) -- Yup, some are nameless where - from_tuple = uncurryN JFileGameAwayTeamXml - to_tuple t = (away_team_id t, - away_team_abbreviation t, - away_team_name t) + from_tuple = VTeam . (uncurryN Team) + to_tuple' (VTeam t) = H.convert t pickle_status :: PU JFileGameStatus pickle_status = xpElem "status" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, to_tuple') $ xpPair (xpAttr "numeral" xpInt) (xpOption xpText) where from_tuple = uncurry JFileGameStatus - to_tuple s = (db_status_numeral s, - db_status s) + -- Avoid unused field warnings. + to_tuple' JFileGameStatus{..} = (db_status_numeral, db_status) -- @@ -682,7 +611,10 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" "test/xml/jfilexml.xml", check "pickle composed with unpickle is the identity (missing fields)" - "test/xml/jfilexml-missing-fields.xml" ] + "test/xml/jfilexml-missing-fields.xml", + + check "pickle composed with unpickle is the identity (TBA game time)" + "test/xml/jfilexml-tba-game-time.xml"] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path @@ -695,8 +627,12 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" "test/xml/jfilexml.xml", + check "unpickling succeeds (missing fields)" - "test/xml/jfilexml-missing-fields.xml" ] + "test/xml/jfilexml-missing-fields.xml", + + check "unpickling succeeds (TBA game time)" + "test/xml/jfilexml-tba-game-time.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -713,29 +649,31 @@ test_on_delete_cascade :: TestTree test_on_delete_cascade = testGroup "cascading delete tests" [ check "deleting auto_racing_results deletes its children" "test/xml/jfilexml.xml" - 20, + 20, -- teams + check "deleting auto_racing_results deletes its children (missing fields)" "test/xml/jfilexml-missing-fields.xml" - 44 ] + 44, + + check "deleting auto_racing_results deletes its children (TBA game time)" + "test/xml/jfilexml-tba-game-time.xml" + 8 ] where check desc path expected = testCase desc $ do results <- unsafe_unpickle path pickle_message let a = undefined :: Team let b = undefined :: JFile let c = undefined :: JFileGame - let d = undefined :: JFileGame_Team actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do + runMigrationSilent $ do migrate a migrate b migrate c - migrate d _ <- dbimport results deleteAll b count_a <- countAll a count_b <- countAll b count_c <- countAll c - count_d <- countAll d - return $ sum [count_a, count_b, count_c, count_d] + return $ sum [count_a, count_b, count_c] actual @?= expected