{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"jfilexml.dtd\". There's a top-level -- \, containing a \, containing -- \s. Those games contain a bunch of other stuff. The -- \ is pretty irrelevant; we ignore it and pretend that -- a message contains a bunch of games. -- module TSN.XML.JFile ( dtd, pickle_message, -- * Tests jfile_tests, -- * WARNING: these are private but exported to silence warnings JFileConstructor(..), JFileGameConstructor(..) ) where -- System imports 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, migrate ) import Database.Groundhog.Core ( DefaultKey ) 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 ( PU, xpTriple, xp6Tuple, xp14Tuple, xp19Tuple, xpAttr, xpElem, xpInt, xpList, xpOption, xpPair, xpPrim, xpText, xpText0, xpWrap ) -- 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_tba_time, xp_time_dots, xp_time_stamp ) import TSN.Team ( FromXmlFkTeams(..), HTeam(..), Team(..), VTeam(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), ToDb(..), pickle_unpickle, unpickleable, unsafe_unpickle ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "jfilexml.dtd" -- -- DB/XML data types -- -- * JFile/Message -- | Database representation of a 'Message'. -- data JFile = JFile { db_xml_file_id :: Int, db_heading :: String, db_category :: String, db_sport :: String, db_time_stamp :: UTCTime } -- | XML Representation of an 'JFile'. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_gamelist :: JFileGameListXml, xml_time_stamp :: UTCTime } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector Message instance ToDb Message where -- | The database analogue of a 'Message' is a 'JFile'. -- type Db Message = JFile -- | The 'FromXml' instance for 'Message' is required for the -- 'XmlImport' instance. -- instance FromXml Message where -- | To convert a 'Message' to an 'JFile', we just drop -- the 'xml_gamelist'. -- from_xml Message{..} = JFile { db_xml_file_id = xml_xml_file_id, db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, db_time_stamp = xml_time_stamp } -- | This allows us to insert the XML representation 'Message' -- directly. -- 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 -- most of them are redundant. We'll (un)pickle them for good -- measure, but in the conversion to the database type, we can drop -- all of the redundant information. -- -- 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) -- | Database representation of a \ contained within a -- \, and, implicitly, a \. -- -- We've left out the game date, opting instead to combine the -- date/time into the 'db_game_time' field. -- 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 :: Maybe UTCTime, db_vleague :: Maybe String, db_hleague :: Maybe String, db_vscore :: Int, db_hscore :: Int, db_time_remaining :: Maybe 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 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 :: JFileGameOddsInfo, xml_season_type :: Maybe String, xml_game_date :: UTCTime, xml_game_time :: Maybe UTCTime, xml_vteam :: VTeam, xml_vleague :: Maybe String, xml_hteam :: HTeam, xml_hleague :: Maybe String, xml_vscore :: Int, xml_hscore :: Int, xml_time_remaining :: Maybe String, xml_game_status :: JFileGameStatus } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector JFileGameXml -- * JFileGameListXml -- | The XML representation of \ -> \. This -- element serves only to contain \s, so we don't store the -- intermediate table in the database. -- newtype JFileGameListXml = JFileGameListXml { xml_games :: [JFileGameXml] } deriving (Eq, Show) instance ToDb JFileGameXml where -- | The database analogue of an 'JFileGameXml' is -- an 'JFileGame'. -- type Db JFileGameXml = JFileGame 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 keys for JFile and the home/away teams. We also mash -- the date/time together into one field. -- 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 = 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_game_status = xml_game_status } 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 allows us to insert the XML representation -- 'JFileGameXml' directly. -- instance XmlImportFkTeams JFileGameXml --- --- Database stuff. --- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: Team) migrate (undefined :: JFile) migrate (undefined :: JFileGame) 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| - entity: JFile dbName: jfile constructors: - name: JFile uniques: - name: unique_jfile type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] - 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 - name: db_home_starter dbName: home_starter - name: db_home_game_key dbName: home_game_key - name: db_away_game_key dbName: away_game_key - name: db_current_timestamp dbName: current_timestamp - name: db_live dbName: live - name: db_notes dbName: notes - entity: JFileGame dbName: jfile_games constructors: - name: JFileGame fields: - 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: 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} |] --- --- Pickling --- -- | Pickler for the top-level 'Message'. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) pickle_gamelist (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message pickle_gamelist :: PU JFileGameListXml pickle_gamelist = xpElem "gamelist" $ xpWrap (to_result, from_result) $ xpList pickle_game where to_result = JFileGameListXml from_result = xml_games pickle_game :: PU JFileGameXml pickle_game = xpElem "game" $ 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_tba_time) pickle_away_team (xpOption $ xpElem "vleague" (xpOption xpText)) pickle_home_team (xpOption $ xpElem "hleague" xpText) (xpElem "vscore" xpInt) (xpElem "hscore" xpInt) (xpOption $ xpElem "time_r" xpText) pickle_status where 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') $ 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 runMigrationSilent $ 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