X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FJFile.hs;h=d434220a6ee8788e1b3c4a49249c8587b2e463c9;hb=f64dd9351c77beb0333bef5c38058194439a0254;hp=a327460a0a235cc641a4476a53a346bb37d927dc;hpb=4e8ac732bb83c50951d0c007f49333392397f277;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs index a327460..d434220 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 #-} @@ -12,48 +13,81 @@ -- a message contains a bunch of games. -- module TSN.XML.JFile ( - dtd ) + dtd, + pickle_message, + -- * Tests + jfile_tests, + -- * WARNING: these are private but exported to silence warnings + JFileConstructor(..), + JFileGameConstructor(..) ) where -- System imports +import Control.Monad ( forM_ ) +import Data.List ( intercalate ) +import Data.String.Utils ( split ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) -import Database.Groundhog ( migrate ) +import qualified Data.Vector.HFixed as H ( HVector, convert ) +import Database.Groundhog ( + countAll, + deleteAll, + migrate, + runMigration, + silentMigrationLogger ) import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn ) +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 ( PU, + xpTriple, xp6Tuple, - xp7Tuple, - xp8Tuple, - xp10Tuple, xp14Tuple, + xp19Tuple, + xpAttr, xpElem, xpInt, xpList, xpOption, + xpPair, + xpPrim, xpText, + xpText0, xpWrap ) -- Local imports import TSN.Codegen ( tsn_codegen_config ) +import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) -import TSN.XML.Odds ( - OddsGameAwayTeamXml(..), - OddsGameHomeTeamXml(..), - OddsGameTeam(..) ) +import TSN.Picklers ( + xp_date, + xp_date_padded, + xp_datetime, + xp_tba_time, + xp_time_dots, + xp_time_stamp ) +import TSN.Team ( + FromXmlFkTeams(..), + HTeam(..), + Team(..), + VTeam(..) ) import TSN.XmlImport ( XmlImport(..), - XmlImportFk(..) ) - + XmlImportFkTeams(..) ) import Xml ( + Child(..), FromXml(..), - FromXmlFk(..), - ToDb(..) ) + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) @@ -90,7 +124,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 @@ -121,6 +160,9 @@ instance FromXml Message where instance XmlImport Message + +-- * JFileGame/JFileGameXml + -- | This is an embedded type within each JFileGame. It has its own -- element, \, but there's only one of them per game. So -- essentially all of these fields belong to a 'JFileGame'. Aaaannnd @@ -128,28 +170,43 @@ instance XmlImport Message -- measure, but in the conversion to the database type, we can drop -- all of the redundant information. -- -data OddsInfo = - OddsInfo { - db_list_date :: UTCTime, - db_home_team_id :: Int, -- redundant (OddsGameTeam) - db_away_team_id :: Int, -- redundant (OddsGameTeam) - db_home_abbr :: String, -- redundant (OddsGameTeam) - db_away_abbr :: String, -- redundant (OddsGameTeam) - db_home_team_name :: String, -- redundant (OddsGameTeam) - db_away_team_name :: String, -- redundant (OddsGameTeam) - db_home_starter :: String, - db_away_starter :: String, - db_game_date :: UTCTime, -- redundant (JFileGame) - db_home_game_key :: Int, - db_away_game_key :: Int, - db_current_timestamp :: UTCTime, - db_live :: Bool, +-- 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_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) + db_away_team_name :: Maybe String, -- redundant (Team) + db_home_starter :: Maybe String, + db_away_starter :: Maybe String, + db_game_date :: Maybe UTCTime, -- redundant (JFileGame) + db_home_game_key :: Maybe Int, + db_away_game_key :: Maybe Int, + db_current_timestamp :: Maybe UTCTime, + db_live :: Maybe Bool, db_notes :: String } deriving (Eq, Show) +-- | Another embedded type within 'JFileGame'. These look like, +-- \FINAL\ within the XML, but +-- they're in one-to-one correspondence with the games. +-- +data JFileGameStatus = + JFileGameStatus { + db_status_numeral :: Int, + db_status :: Maybe String } + deriving (Eq, Show) + --- * JFileGame/JFileGameXml -- | Database representation of a \ contained within a -- \, and, implicitly, a \. @@ -160,42 +217,49 @@ data OddsInfo = 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 :: OddsInfo, - db_season_type :: String, - db_game_time :: UTCTime, + db_odds_info :: JFileGameOddsInfo, + db_season_type :: Maybe String, + db_game_time :: Maybe UTCTime, db_vleague :: Maybe String, db_hleague :: Maybe String, db_vscore :: Int, db_hscore :: Int, db_time_remaining :: Maybe String, - db_status :: String } + db_game_status :: JFileGameStatus } -- | XML representation of a \ contained within a \, --- and a \. The Away/Home teams seem to --- coincide with those of 'OddsGame', so we're reusing those for --- now. In the future it may make sense to separate them out into --- just \"Teams\". Note however that they require different picklers! +-- and a \. The Away/Home teams seem to coincide with +-- those of 'OddsGame', so we're reusing the DB type via the common +-- 'TSN.Team' structure. But the XML types are different, because +-- they have different picklers! -- data JFileGameXml = JFileGameXml { xml_game_id :: Int, xml_schedule_id :: Int, - xml_odds_info :: OddsInfo, - xml_season_type :: String, + xml_odds_info :: JFileGameOddsInfo, + xml_season_type :: Maybe String, xml_game_date :: UTCTime, - xml_game_time :: UTCTime, - xml_vteam :: OddsGameAwayTeamXml, + xml_game_time :: Maybe UTCTime, + xml_vteam :: VTeam, xml_vleague :: Maybe String, - xml_hteam :: OddsGameHomeTeamXml, + xml_hteam :: HTeam, xml_hleague :: Maybe String, xml_vscore :: Int, xml_hscore :: Int, xml_time_remaining :: Maybe String, - xml_status :: String } - deriving (Eq, Show) + xml_game_status :: JFileGameStatus } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector JFileGameXml -- * JFileGameListXml @@ -217,54 +281,51 @@ 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, db_season_type = xml_season_type, - db_game_time = xml_game_time, + db_game_time = make_game_time xml_game_date xml_game_time, db_vleague = xml_vleague, db_hleague = xml_hleague, db_vscore = xml_vscore, db_hscore = xml_hscore, db_time_remaining = xml_time_remaining, - db_status = xml_status } + 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 Nothing = d - make_game_time d (Just 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_OddsGameTeam - --- | Database mapping between games and their home/away teams. --- -data JFileGame_OddsGameTeam = - JFileGame_OddsGameTeam { - jgogt_jfile_games_id :: DefaultKey JFileGame, - jgogt_away_team_id :: DefaultKey OddsGameTeam, - jgogt_home_team_id :: DefaultKey OddsGameTeam } +instance XmlImportFkTeams JFileGameXml --- @@ -274,12 +335,25 @@ data JFileGame_OddsGameTeam = instance DbImport Message where dbmigrate _ = run_dbmigrate $ do + migrate (undefined :: Team) migrate (undefined :: JFile) migrate (undefined :: JFileGame) - migrate (undefined :: OddsGameTeam) - migrate (undefined :: JFileGame_OddsGameTeam) - dbimport m = return ImportSucceeded + dbimport m = do + -- Insert the top-level message + msg_id <- insert_xml m + + -- Now loop through the message's games + forM_ (xml_games $ xml_gamelist m) $ \game -> do + -- 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) + + -- 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 mkPersist tsn_codegen_config [groundhog| @@ -293,8 +367,16 @@ mkPersist tsn_codegen_config [groundhog| # Prevent multiple imports of the same message. fields: [db_xml_file_id] -# Many of the OddsInfo fields are redundant and have been left out. -- embedded: OddsInfo +- embedded: JFileGameStatus + fields: + - name: db_status_numeral + dbName: status_numeral + - name: db_status + dbName: status + + # Many of the JFileGameOddsInfo fields are redundant and have + # been left out. +- embedded: JFileGameOddsInfo fields: - name: db_list_date dbName: list_date @@ -319,31 +401,27 @@ 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} - {name: home_starter, dbName: home_starter} - {name: away_starter, dbName: away_starter} - {name: home_game_key, dbName: home_game_key} - - {name: away_game_key, dbName: home_game_key} + - {name: away_game_key, dbName: away_game_key} - {name: current_timestamp, dbName: current_timestamp} - {name: live, dbName: live} - {name: notes, dbName: notes} + - name: db_game_status + embeddedType: + - {name: status_numeral, dbName: status_numeral} + - {name: status, dbName: status} -- entity: JFileGame_OddsGameTeam - dbName: jfile_games__odds_games_teams - constructors: - - name: JFileGame_OddsGameTeam - fields: - - name: jgogt_jfile_games_id - reference: - onDelete: cascade - - name: jgogt_away_team_id - reference: - onDelete: cascade - - name: jgogt_home_team_id - reference: - onDelete: cascade |] @@ -357,7 +435,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) @@ -366,12 +444,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 = @@ -387,13 +460,13 @@ pickle_gamelist = pickle_game :: PU JFileGameXml pickle_game = xpElem "game" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp14Tuple (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) pickle_odds_info - (xpElem "seasontype" xpText) + (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) pickle_home_team @@ -404,22 +477,200 @@ pickle_game = 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_status m) - -pickle_odds_info = undefined -pickle_home_team = undefined -pickle_away_team = undefined -pickle_status = undefined + + +pickle_odds_info :: PU JFileGameOddsInfo +pickle_odds_info = + xpElem "Odds_Info" $ + xpWrap (from_tuple, to_tuple') $ + xp19Tuple (xpElem "ListDate" (xpOption xp_date)) + (xpElem "HomeTeamID" (xpOption xpText)) + (xpElem "AwayTeamID" (xpOption xpText)) + (xpElem "HomeAbbr" (xpOption xpText)) + (xpElem "AwayAbbr" (xpOption xpText)) + (xpElem "HomeTeamName" (xpOption xpText)) + (xpElem "AwayTeamName" (xpOption xpText)) + (xpElem "HStarter" (xpOption xpText)) + (xpElem "AStarter" (xpOption xpText)) + (xpElem "GameDate" (xpOption xp_datetime)) + (xpElem "HGameKey" (xpOption xpInt)) + (xpElem "AGameKey" (xpOption xpInt)) + (xpElem "CurrentTimeStamp" (xpOption xp_time_dots)) + (xpElem "Live" (xpOption xpPrim)) + (xpElem "Notes1" xpText0) + (xpElem "Notes2" xpText0) + (xpElem "Notes3" xpText0) + (xpElem "Notes4" xpText0) + (xpElem "Notes5" xpText0) + where + from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) = + JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes + where + notes = intercalate "\n" [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 + (notes1:_) -> notes1 + _ -> "" + n2 = case note_lines of + (_:notes2:_) -> notes2 + _ -> "" + n3 = case note_lines of + (_:_:notes3:_) -> notes3 + _ -> "" + n4 = case note_lines of + (_:_:_:notes4:_) -> notes4 + _ -> "" + n5 = case note_lines of + (_:_:_:_:notes5:_) -> notes5 + _ -> "" + +-- | (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') $ + xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. + (xpAttr "abbr" (xpOption xpText)) -- Some are blank + (xpOption xpText) -- Yup, some are nameless + where + from_tuple = HTeam . (uncurryN Team) + to_tuple' (HTeam t) = H.convert t + + +-- | (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') $ + xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text. + (xpAttr "abbr" (xpOption xpText)) -- Some are blank + (xpOption xpText) -- Yup, some are nameless + where + 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') $ + xpPair (xpAttr "numeral" xpInt) + (xpOption xpText) + where + from_tuple = uncurry JFileGameStatus + + -- Avoid unused field warnings. + to_tuple' JFileGameStatus{..} = (db_status_numeral, db_status) + + +-- +-- Tasty Tests +-- + +-- | A list of all tests for this module. +-- +jfile_tests :: TestTree +jfile_tests = + testGroup + "JFile tests" + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, + test_unpickle_succeeds ] + + +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: success 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" + "test/xml/jfilexml.xml", + check "pickle composed with unpickle is the identity (missing fields)" + "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 + actual @?= expected + + + +-- | Make sure we can actually unpickle these things. +-- +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", + + 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 + + let expected = True + actual @?= expected + + + +-- | Make sure everything gets deleted when we delete the top-level +-- record. +-- +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, -- teams + + check "deleting auto_racing_results deletes its children (missing fields)" + "test/xml/jfilexml-missing-fields.xml" + 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 + + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + _ <- dbimport results + deleteAll b + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + return $ sum [count_a, count_b, count_c] + actual @?= expected