-- 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(..),
+ 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 ( migrate )
+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,
- 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.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_time,
+ xp_time_dots,
+ xp_time_stamp )
+import TSN.Team ( Team(..) )
import TSN.XmlImport (
XmlImport(..),
XmlImportFk(..) )
-
import Xml (
FromXml(..),
FromXmlFk(..),
- ToDb(..) )
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
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, \<Odds_Info\>, but there's only one of them per game. So
-- essentially all of these fields belong to a 'JFileGame'. Aaaannnd
-- 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.
+--
+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,
+-- \<status numeral=\"4\"\>FINAL\</status\> 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 \<game\> contained within a
-- \<message\>, and, implicitly, a \<gamelist\>.
db_jfile_id :: DefaultKey JFile,
db_game_id :: Int,
db_schedule_id :: Int,
- db_odds_info :: OddsInfo,
- db_season_type :: String,
+ 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_status :: String }
+ db_game_status :: JFileGameStatus }
-- | XML representation of a \<game\> contained within a \<message\>,
--- and a \<gamelist\>. 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 \<gamelist\>. 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_vteam :: JFileGameAwayTeamXml,
xml_vleague :: Maybe String,
- xml_hteam :: OddsGameHomeTeamXml,
+ xml_hteam :: JFileGameHomeTeamXml,
xml_hleague :: Maybe String,
xml_vscore :: Int,
xml_hscore :: Int,
xml_time_remaining :: Maybe String,
- xml_status :: String }
+ xml_game_status :: JFileGameStatus }
deriving (Eq, Show)
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)
+ make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
-- | This allows us to insert the XML representation
instance XmlImportFk JFileGameXml
--- * JFileGame_OddsGameTeam
+-- * JFileGame_Team
-- | 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 }
+data JFileGame_Team =
+ JFileGame_Team {
+ jgt_jfile_games_id :: DefaultKey JFileGame,
+ jgt_away_team_id :: DefaultKey Team,
+ jgt_home_team_id :: DefaultKey Team }
---
instance DbImport Message where
dbmigrate _ =
run_dbmigrate $ do
+ migrate (undefined :: Team)
migrate (undefined :: JFile)
migrate (undefined :: JFileGame)
- migrate (undefined :: OddsGameTeam)
- migrate (undefined :: JFileGame_OddsGameTeam)
+ 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)
- dbimport m = return ImportSucceeded
+ 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|
# 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
- {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
+- entity: JFileGame_Team
+ dbName: jfile_games__teams
constructors:
- - name: JFileGame_OddsGameTeam
+ - name: JFileGame_Team
fields:
- - name: jgogt_jfile_games_id
+ - name: jgt_jfile_games_id
reference:
onDelete: cascade
- - name: jgogt_away_team_id
+ - name: jgt_away_team_id
reference:
onDelete: cascade
- - name: jgogt_home_team_id
+ - name: jgt_home_team_id
reference:
onDelete: cascade
|]
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)
pickle_away_team
xml_vscore m,
xml_hscore m,
xml_time_remaining m,
- xml_status m)
+ xml_game_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_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
projects / dead / htsn-import.git / blobdiff