+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
-- 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 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 Generics ( Generic(..), to_tuple )
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.Team ( Team(..) )
+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 )
xml_sport :: String,
xml_gamelist :: JFileGameListXml,
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic Message
instance ToDb 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 :: String,
- away_team_name :: 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 :: String,
- home_team_name :: 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
-- 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 :: UTCTime,
- db_home_team_id :: String, -- redundant (Team)
- db_away_team_id :: String, -- redundant (Team)
- db_home_abbr :: String, -- redundant (Team)
- db_away_abbr :: String, -- redundant (Team)
- db_home_team_name :: String, -- redundant (Team)
- db_away_team_name :: String, -- redundant (Team)
- 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,
+ 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)
data JFileGameStatus =
JFileGameStatus {
db_status_numeral :: Int,
- db_status :: String }
+ db_status :: Maybe String }
deriving (Eq, Show)
+
-- | Database representation of a \<game\> contained within a
-- \<message\>, and, implicitly, a \<gamelist\>.
--
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 :: String,
- db_game_time :: UTCTime,
+ db_season_type :: Maybe String,
+ db_game_time :: Maybe UTCTime,
db_vleague :: Maybe String,
db_hleague :: Maybe String,
db_vscore :: Int,
xml_game_id :: Int,
xml_schedule_id :: Int,
xml_odds_info :: JFileGameOddsInfo,
- xml_season_type :: String,
+ 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 'Generics.to_tuple'.
+--
+instance Generic JFileGameXml
-- * JFileGameListXml
--
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_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 Nothing = d
- make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
+ -- | Construct the database game time from the XML \<Game_Date\>
+ -- and \<Game_Time\> elements. The \<Game_Time\> 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
---
migrate (undefined :: Team)
migrate (undefined :: JFile)
migrate (undefined :: JFileGame)
- migrate (undefined :: JFileGame_Team)
- 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|
- 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
- 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: 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
|]
(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 =
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
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 = undefined
-
-
-pickle_home_team :: PU JFileGameHomeTeamXml
+
+
+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) $
+ xpWrap (from_tuple, to_tuple') $
xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
- (xpAttr "abbr" xpText)
- xpText
+ (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) = to_tuple 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" xpText)
- xpText
+ (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) = to_tuple t
pickle_status :: PU JFileGameStatus
pickle_status =
xpElem "status" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
xpPair (xpAttr "numeral" xpInt)
- xpText
+ (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)
+
+
+--
+-- 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