-- contains a single \<game\> and some \<location\>s.
--
module TSN.XML.Scores (
+ dtd,
pickle_message,
-- * Tests
scores_tests,
where
-- System imports.
-import Control.Monad ( forM_ )
import Data.Data ( Data )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog (
countAll,
executeRaw,
+ insert,
+ insert_,
migrate,
runMigration,
silentMigrationLogger )
PU,
xp7Tuple,
xp11Tuple,
- xp12Tuple,
xpAttr,
xpElem,
xpInt,
import TSN.Codegen (
tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_gamedate, xp_time_stamp )
+import TSN.Picklers ( xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
FromXml(..),
unsafe_unpickle )
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
--- DB/XML Data types
---
+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_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_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_text :: String }
deriving (Data, Eq, Show, Typeable)
+
+-- | Database representation of a game.
+--
data ScoreGame =
ScoreGame {
db_scores_id :: DefaultKey Score,
db_notes :: Maybe String }
+-- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
+--
data ScoreGameXml =
ScoreGameXml {
xml_vteam :: ScoreGameVTeam,
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.
+-- | 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
-- * 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 :: Maybe String,
- state :: Maybe String,
+ 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)
+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
-- 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:
-- Pickling
--
--- | Convert a 'Message' to/from XML.
+-- | Convert a 'Message' to/from \<message\>.
--
pickle_message :: PU Message
pickle_message =
--- | Convert a 'ScoreLocation' to/from XML.
+-- | Convert a 'ScoreLocation' to/from \<location\>.
--
pickle_location :: PU ScoreLocation
pickle_location =
xpElem "location" $
xpWrap (from_tuple, to_tuple) $
- xpTriple (xpOption (xpElem "city" xpText))
- (xpOption (xpElem "state" xpText))
+ xpTriple (xpElem "city" xpText)
+ (xpElem "state" xpText)
(xpElem "country" xpText)
where
from_tuple =
to_tuple l = (city l, state l, country l)
+-- | Convert a 'ScoreGameStatus' to/from \<status\>.
+--
pickle_status :: PU ScoreGameStatus
pickle_status =
xpElem "status" $
xpText
where
from_tuple = uncurryN ScoreGameStatus
- to_tuple (ScoreGameStatus x y z) = (x,y,z)
+ 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" $
xml_notes)
+-- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
+--
pickle_vteam :: PU ScoreGameVTeam
pickle_vteam =
xpElem "vteam" $
xpText
where
from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
- to_tuple (ScoreGameVTeam (ScoreGameTeam x y)) = (x,y)
+ 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" $
xpText
where
from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
- to_tuple (ScoreGameHTeam (ScoreGameTeam x y)) = (x,y)
+ to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
+
---
scores_tests =
testGroup
"Scores tests"
- [ test_pickle_of_unpickle_is_identity,
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
test_unpickle_succeeds ]
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
projects / dead / htsn-import.git / commitdiff