+{-# 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_, join )
+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 )
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,
- xp7Tuple,
- xp8Tuple,
- xp10Tuple,
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_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 )
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
instance XmlImport Message
+
+-- * 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.
+--
+-- 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,
+-- \<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\>.
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 \<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_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
--
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 \<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_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
---
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|
# 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: 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
|]
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)
(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 =
pickle_game :: PU JFileGameXml
pickle_game =
xpElem "game" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, to_tuple') $
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)
+ (xpOption $ xpElem "vleague" (xpOption xpText))
pickle_home_team
(xpOption $ xpElem "hleague" xpText)
(xpElem "vscore" 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_status m)
-
-pickle_odds_info = undefined
-pickle_home_team = undefined
-pickle_away_team = undefined
-pickle_status = undefined
+ 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
projects / dead / htsn-import.git / blobdiff