htsn-import-0.0.4: src/TSN/XML/Scores.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- | Parse TSN XML for the DTD \"scoresxml.dtd\". Each document
-- contains a single \<game\> and some \<location\>s.
--
module TSN.XML.Scores (
dtd,
pickle_message,
-- * Tests
scores_tests,
-- * WARNING: these are private but exported to silence warnings
Score_ScoreLocationConstructor(..),
ScoreConstructor(..),
ScoreGameConstructor(..),
ScoreGameTeamConstructor(..),
ScoreLocationConstructor(..),
ScoreGame_ScoreGameTeamConstructor(..) )
where
-- System imports.
import Data.Data ( Data )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
import Database.Groundhog (
countAll,
executeRaw,
insert,
insert_,
migrate,
runMigration,
silentMigrationLogger )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.Generic ( runDbConn )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
defaultCodegenConfig,
groundhog,
mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
PU,
xp7Tuple,
xp11Tuple,
xpAttr,
xpElem,
xpInt,
xpList,
xpOption,
xpPair,
xpPrim,
xpText,
xpTriple,
xpWrap )
-- Local imports.
import TSN.Codegen (
tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_time_stamp )
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 = "scoresxml.dtd"
---
--- DB/XML Data types
---
-- * Score / Message
-- | Database representation of a 'Message'. It lacks the
-- 'xml_locations' and 'xml_game' which are related via foreign keys
-- instead.
--
data Score =
Score {
db_xml_file_id :: Int,
db_heading :: String,
db_game_id :: Int,
db_schedule_id :: Int,
db_tsnupdate :: Maybe Bool,
db_category :: String,
db_sport :: String,
db_season_type :: String,
db_time_stamp :: UTCTime }
-- | XML representation of the top level \<message\> element (i.e. a
-- 'Score').
--
data Message =
Message {
xml_xml_file_id :: Int,
xml_heading :: String,
xml_game_id :: Int,
xml_schedule_id :: Int,
xml_tsnupdate :: Maybe Bool,
xml_category :: String,
xml_sport :: String,
xml_locations :: [ScoreLocation],
xml_season_type :: String,
xml_game :: ScoreGameXml,
xml_time_stamp :: UTCTime }
deriving (Eq, Show)
instance ToDb Message where
-- | The database representation of a 'Message' is a 'Score'.
type Db Message = Score
instance FromXml Message where
from_xml Message{..} =
Score {
db_xml_file_id = xml_xml_file_id,
db_heading = xml_heading,
db_game_id = xml_game_id,
db_schedule_id = xml_schedule_id,
db_tsnupdate = xml_tsnupdate,
db_category = xml_category,
db_sport = xml_sport,
db_season_type = xml_season_type,
db_time_stamp = xml_time_stamp }
-- | This lets us insert the XML representation 'Message' directly.
--
instance XmlImport Message
-- * ScoreGame / ScoreGameXml
-- | This is an embedded field within 'SportsGame'. Each \<status\>
-- element has two attributes, a numeral and a type. It also
-- contains some text. Rather than put these in their own table, we
-- include them in the parent 'SportsGame'.
--
data ScoreGameStatus =
ScoreGameStatus {
db_status_numeral :: Int,
db_status_type :: String, -- ^ These are probably only one-character long,
-- but they all take the same amount of space
-- in Postgres.
db_status_text :: String }
deriving (Data, Eq, Show, Typeable)
-- | Database representation of a game.
--
data ScoreGame =
ScoreGame {
db_scores_id :: DefaultKey Score,
db_vscore :: Int,
db_hscore :: Int,
db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
db_status :: ScoreGameStatus,
db_notes :: Maybe String }
-- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
--
data ScoreGameXml =
ScoreGameXml {
xml_vteam :: ScoreGameVTeam,
xml_hteam :: ScoreGameHTeam,
xml_vscore :: Int,
xml_hscore :: Int,
xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
xml_status :: ScoreGameStatus,
xml_notes :: Maybe String }
deriving (Eq, Show)
-- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
vteam :: ScoreGameXml -> ScoreGameTeam
vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
-- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
hteam :: ScoreGameXml -> ScoreGameTeam
hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
instance ToDb ScoreGameXml where
-- | The database representation of a 'ScoreGameXml' is a
-- 'ScoreGame'.
--
type Db ScoreGameXml = ScoreGame
instance FromXmlFk ScoreGameXml where
-- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
-- a 'Score'.
--
type Parent ScoreGameXml = Score
from_xml_fk fk ScoreGameXml{..} =
ScoreGame {
db_scores_id = fk,
db_vscore = xml_vscore,
db_hscore = xml_hscore,
db_time_r = xml_time_r,
db_status = xml_status,
db_notes = xml_notes }
-- | This lets us import the database representation 'ScoreGameXml'
-- directly.
--
instance XmlImportFk ScoreGameXml
-- * ScoreGameTeam
-- | A team that appears in a 'ScoreGame'. This is meant to represent
-- both home and away teams.
--
data ScoreGameTeam =
ScoreGameTeam {
team_id :: String,
team_name :: String }
deriving (Eq, Show)
-- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
-- home and away teams. See also 'ScoreGameHTeam'.
--
newtype ScoreGameVTeam =
ScoreGameVTeam ScoreGameTeam
deriving (Eq, Show)
-- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
-- home and away teams. See also 'ScoreGameVTeam'.
--
newtype ScoreGameHTeam =
ScoreGameHTeam ScoreGameTeam
deriving (Eq, Show)
-- * ScoreGame_ScoreGameTeam
-- | Join a 'ScoreGame' with its home/away teams. Database-only. We
-- use a join table because the teams are kept unique.
--
data ScoreGame_ScoreGameTeam =
ScoreGame_ScoreGameTeam
(DefaultKey ScoreGame) -- ^ game id
(DefaultKey ScoreGameTeam) -- ^ vteam id
(DefaultKey ScoreGameTeam) -- ^ hteam id
-- * ScoreLocation
-- | Database and XML representation of a \<location\>. This is almost
-- identical to 'TSN.XML.NewsLocation', but the city/state have not
-- appeared optional here so far.
--
data ScoreLocation =
ScoreLocation {
city :: String,
state :: String,
country :: String }
deriving (Eq, Show)
-- * Score_ScoreLocation
-- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
-- use a join table because the locations are kept unique.
--
data Score_ScoreLocation =
Score_ScoreLocation
(DefaultKey Score)
(DefaultKey ScoreLocation)
instance DbImport Message where
dbmigrate _ =
run_dbmigrate $ do
migrate (undefined :: Score)
migrate (undefined :: ScoreGame)
migrate (undefined :: ScoreGameTeam)
migrate (undefined :: ScoreGame_ScoreGameTeam)
migrate (undefined :: ScoreLocation)
migrate (undefined :: Score_ScoreLocation)
dbimport m = do
-- Insert the message and get its ID.
msg_id <- insert_xml m
-- Insert all of the locations contained within this message and
-- collect their IDs in a list.
location_ids <- mapM insert (xml_locations m)
-- Now use that list to construct 'Score_ScoreLocation' objects,
-- and insert them.
mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
-- Insert the game and its hteam/vteam, noting the IDs.
game_id <- insert_xml_fk msg_id (xml_game m)
vteam_id <- insert (vteam $ xml_game m)
hteam_id <- insert (hteam $ xml_game m)
-- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
-- aforementioned game to its hteam/vteam.
insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
return ImportSucceeded
-- These types don't have special XML representations or field name
-- collisions so we use the defaultCodegenConfig and give their
-- fields nice simple names.
mkPersist defaultCodegenConfig [groundhog|
- entity: ScoreGameTeam
dbName: scores_games_teams
constructors:
- name: ScoreGameTeam
uniques:
- name: unique_scores_games_team
type: constraint
fields: [team_id]
- entity: ScoreLocation
dbName: scores_locations
constructors:
- name: ScoreLocation
uniques:
- name: unique_scores_location
type: constraint
fields: [city, state, country]
|]
-- These types have fields with e.g. db_ and xml_ prefixes, so we
-- use our own codegen to peel those off before naming the columns.
mkPersist tsn_codegen_config [groundhog|
- entity: Score
dbName: scores
constructors:
- name: Score
uniques:
- name: unique_scores
type: constraint
# Prevent multiple imports of the same message.
fields: [db_xml_file_id]
- embedded: ScoreGameStatus
fields:
- name: db_status_numeral
dbName: status_numeral
- name: db_status_type
dbName: status_type
- name: db_status_text
dbName: status_text
- entity: ScoreGame
dbName: scores_games
constructors:
- name: ScoreGame
fields:
- name: db_scores_id
reference:
onDelete: cascade
- name: db_status
embeddedType:
- { name: status_numeral, dbName: status_numeral }
- { name: status_type, dbName: status_type }
- { name: status_text, dbName: status_text }
- entity: ScoreGame_ScoreGameTeam
dbName: scores_games__scores_games_teams
constructors:
- name: ScoreGame_ScoreGameTeam
fields:
- name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
dbName: scores_games_id
reference:
onDelete: cascade
- name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
dbName: scores_games_teams_vteam_id
reference:
onDelete: cascade
- name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
dbName: scores_games_teams_hteam_id
reference:
onDelete: cascade
- entity: Score_ScoreLocation
dbName: scores__scores_locations
constructors:
- name: Score_ScoreLocation
fields:
- name: score_ScoreLocation0 # Default created by mkNormalFieldName
dbName: scores_id
reference:
onDelete: cascade
- name: score_ScoreLocation1 # Default created by mkNormalFieldName
dbName: scores_locations_id
reference:
onDelete: cascade
|]
--
-- Pickling
--
-- | Convert a 'Message' to/from \<message\>.
--
pickle_message :: PU Message
pickle_message =
xpElem "message" $
xpWrap (from_tuple, to_tuple) $
xp11Tuple (xpElem "XML_File_ID" xpInt)
(xpElem "heading" xpText)
(xpElem "game_id" xpInt)
(xpElem "schedule_id" xpInt)
(xpOption $ xpElem "tsnupdate" xpPrim)
(xpElem "category" xpText)
(xpElem "sport" xpText)
(xpList pickle_location)
(xpElem "seasontype" xpText)
pickle_game
(xpElem "time_stamp" xp_time_stamp)
where
from_tuple = uncurryN Message
to_tuple m = (xml_xml_file_id m,
xml_heading m,
xml_game_id m,
xml_schedule_id m,
xml_tsnupdate m,
xml_category m,
xml_sport m,
xml_locations m,
xml_season_type m,
xml_game m,
xml_time_stamp m)
-- | Convert a 'ScoreLocation' to/from \<location\>.
--
pickle_location :: PU ScoreLocation
pickle_location =
xpElem "location" $
xpWrap (from_tuple, to_tuple) $
xpTriple (xpElem "city" xpText)
(xpElem "state" xpText)
(xpElem "country" xpText)
where
from_tuple =
uncurryN ScoreLocation
to_tuple l = (city l, state l, country l)
-- | Convert a 'ScoreGameStatus' to/from \<status\>.
--
pickle_status :: PU ScoreGameStatus
pickle_status =
xpElem "status" $
xpWrap (from_tuple, to_tuple) $
xpTriple (xpAttr "numeral" xpInt)
(xpAttr "type" xpText)
xpText
where
from_tuple = uncurryN ScoreGameStatus
to_tuple ScoreGameStatus{..} = (db_status_numeral,
db_status_type,
db_status_text)
-- | Convert a 'ScoreGameXml' to/from \<game\>.
--
pickle_game :: PU ScoreGameXml
pickle_game =
xpElem "game" $
xpWrap (from_tuple, to_tuple) $
xp7Tuple pickle_vteam
pickle_hteam
(xpElem "vscore" xpInt)
(xpElem "hscore" xpInt)
(xpOption $ xpElem "time_r" xpText)
pickle_status
(xpOption $ xpElem "notes" xpText)
where
from_tuple = uncurryN ScoreGameXml
to_tuple ScoreGameXml{..} = (xml_vteam,
xml_hteam,
xml_vscore,
xml_hscore,
xml_time_r,
xml_status,
xml_notes)
-- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
--
pickle_vteam :: PU ScoreGameVTeam
pickle_vteam =
xpElem "vteam" $
xpWrap (from_tuple, to_tuple) $
xpPair (xpAttr "id" xpText)
xpText
where
from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
-- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
-- 'pickle_vteam' modulo the \"h\" and \"v\".
--
pickle_hteam :: PU ScoreGameHTeam
pickle_hteam =
xpElem "hteam" $
xpWrap (from_tuple, to_tuple) $
xpPair (xpAttr "id" xpText)
xpText
where
from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
---
--- Tasty tests
---
-- | A list of all tests for this module.
--
scores_tests :: TestTree
scores_tests =
testGroup
"Scores 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/scoresxml.xml",
check "pickle composed with unpickle is the identity (no locations)"
"test/xml/scoresxml-no-locations.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/scoresxml.xml",
check "unpickling succeeds (no locations)"
"test/xml/scoresxml-no-locations.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 "unpickling succeeds"
"test/xml/scoresxml.xml"
4, -- 2 teams, 2 locations
check "unpickling succeeds (no locations)"
"test/xml/scoresxml-no-locations.xml"
2 -- 2 teams, 0 locations
]
where
check desc path expected = testCase desc $ do
score <- unsafe_unpickle path pickle_message
let a = undefined :: Score
let b = undefined :: ScoreGame
let c = undefined :: ScoreGameTeam
let d = undefined :: ScoreGame_ScoreGameTeam
let e = undefined :: ScoreLocation
let f = undefined :: Score_ScoreLocation
actual <- withSqliteConn ":memory:" $ runDbConn $ do
runMigration silentMigrationLogger $ do
migrate a
migrate b
migrate c
migrate d
migrate e
migrate f
_ <- dbimport score
-- No idea how 'delete' works, so do this instead.
executeRaw False "DELETE FROM scores;" []
count_a <- countAll a
count_b <- countAll b
count_c <- countAll c
count_d <- countAll d
count_e <- countAll e
count_f <- countAll f
return $ sum [count_a, count_b, count_c,
count_d, count_e, count_f ]
actual @?= expected