htsn-import-0.2.2: src/TSN/XML/JFile.hs
{-# 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
-- \<message\>, containing a \<gamelist\>, containing
-- \<game\>s. Those games contain a bunch of other stuff. The
-- \<gamelist\> 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, \<Odds_Info\>, 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,
-- \<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)
-- | Database representation of a \<game\> contained within a
-- \<message\>, and, implicitly, a \<gamelist\>.
--
-- 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 \<game\> contained within a \<message\>,
-- 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 :: 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 \<message\> -> \<gamelist\>. This
-- element serves only to contain \<game\>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 \<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 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