{-# 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(..), JFileGame_TeamConstructor(..) ) 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 ( countAll, deleteAll, insert_, 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 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 TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date, xp_date_padded, xp_datetime, xp_time, xp_time_dots, xp_time_stamp ) import TSN.Team ( Team(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( FromXml(..), FromXmlFk(..), 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, Show) 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 -- * 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 -- | 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. -- 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_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_game_id :: Int, db_schedule_id :: Int, db_odds_info :: JFileGameOddsInfo, db_season_type :: Maybe String, db_game_time :: 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 :: UTCTime, xml_vteam :: JFileGameAwayTeamXml, xml_vleague :: Maybe String, xml_hteam :: JFileGameHomeTeamXml, xml_hleague :: Maybe String, xml_vscore :: Int, xml_hscore :: Int, xml_time_remaining :: Maybe String, xml_game_status :: JFileGameStatus } deriving (Eq, Show) -- * 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 FromXmlFk JFileGameXml where -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to) -- a 'JFile'. -- type Parent JFileGameXml = JFile -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the -- foreign key and drop the 'xml_vteam'/'xml_hteam'. We also mash -- the date/time together into one field. -- from_xml_fk fk JFileGameXml{..} = JFileGame { db_jfile_id = fk, 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 -- | 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) -- | 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 } --- --- Database stuff. --- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: Team) migrate (undefined :: JFile) migrate (undefined :: JFileGame) migrate (undefined :: JFileGame_Team) 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 -- Next, we insert the home and away teams. We do this before -- inserting the game itself because the game has two foreign keys -- pointing to "teams". away_team_id <- insert_xml_or_select (xml_vteam game) home_team_id <- insert_xml_or_select (xml_hteam game) game_id <- insert_xml_fk msg_id 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 } 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_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} - 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 |] --- --- Pickling --- -- | Pickler for the top-level 'Message'. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ 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 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 = 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_time) pickle_away_team (xpOption $ xpElem "vleague" xpText) pickle_home_team (xpOption $ xpElem "hleague" xpText) (xpElem "vscore" xpInt) (xpElem "hscore" xpInt) (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) 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_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) 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 _ -> "" pickle_home_team :: PU JFileGameHomeTeamXml 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 = uncurryN JFileGameHomeTeamXml to_tuple t = (home_team_id t, home_team_abbreviation t, home_team_name t) pickle_away_team :: PU JFileGameAwayTeamXml 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 = uncurryN JFileGameAwayTeamXml to_tuple t = (away_team_id t, away_team_abbreviation t, away_team_name 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 to_tuple s = (db_status_numeral s, db_status s) -- -- 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" ] 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" ] 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, check "deleting auto_racing_results deletes its children (missing fields)" "test/xml/jfilexml-missing-fields.xml" 44 ] 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 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] actual @?= expected