-- 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(..),
+ Score_LocationConstructor(..),
ScoreConstructor(..),
ScoreGameConstructor(..),
ScoreGameTeamConstructor(..),
- ScoreLocationConstructor(..),
ScoreGame_ScoreGameTeamConstructor(..) )
where
-- System imports.
-import Control.Monad ( forM_ )
import Data.Data ( Data )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
import Database.Groundhog (
countAll,
- executeRaw,
+ deleteAll,
+ insert,
+ insert_,
migrate,
runMigration,
silentMigrationLogger )
PU,
xp7Tuple,
xp11Tuple,
- xp12Tuple,
xpAttr,
xpElem,
xpInt,
xpWrap )
-- Local imports.
-import TSN.Codegen (
- tsn_codegen_config )
+import TSN.Codegen ( tsn_codegen_config )
+import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_gamedate, xp_time_stamp )
+import TSN.Location ( Location(..), pickle_location )
+import TSN.Picklers ( xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
+ Child(..),
FromXml(..),
FromXmlFk(..),
ToDb(..),
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_tsnupdate :: Maybe Bool,
xml_category :: String,
xml_sport :: String,
- xml_locations :: [ScoreLocation],
+ xml_locations :: [Location],
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
+ -- | When converting from the XML representation to the database
+ -- one, we drop the list of locations which will be foreign-keyed to
+ -- us instead.
+ 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 Child ScoreGameXml where
+ -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
+ -- a 'Score'.
+ --
+ type Parent ScoreGameXml = Score
+
+
+instance FromXmlFk ScoreGameXml where
+ 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. The first
+-- argument is the game id, the second argument is the visiting team
+-- (vteam) id, and the last argument is the home team (hteam) id.
--
data ScoreGame_ScoreGameTeam =
ScoreGame_ScoreGameTeam
- (DefaultKey ScoreGame) -- ^ game id
- (DefaultKey ScoreGameTeam) -- ^ vteam id
- (DefaultKey ScoreGameTeam) -- ^ hteam id
+ (DefaultKey ScoreGame) -- game id
+ (DefaultKey ScoreGameTeam) -- vteam id
+ (DefaultKey ScoreGameTeam) -- hteam id
--- * ScoreLocation
+-- * Score_Location
-data ScoreLocation =
- ScoreLocation {
- city :: Maybe String,
- state :: Maybe String,
- country :: String }
- deriving (Eq, Show)
+-- | Join each 'Score' with its 'Location's. Database-only. We
+-- use a join table because the locations are kept unique.
+--
+data Score_Location =
+ Score_Location
+ (DefaultKey Score)
+ (DefaultKey Location)
--- * Score_ScoreLocation
-data Score_ScoreLocation =
- Score_ScoreLocation
- (DefaultKey Score)
- (DefaultKey ScoreLocation)
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: Location)
+ migrate (undefined :: Score)
+ migrate (undefined :: ScoreGame)
+ migrate (undefined :: ScoreGameTeam)
+ migrate (undefined :: ScoreGame_ScoreGameTeam)
+ migrate (undefined :: Score_Location)
+ 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. We use insert_or_select because
+ -- most of the locations will already exist, and we just want to
+ -- get the ID of the existing location when there's a collision.
+ location_ids <- mapM insert_or_select (xml_locations m)
+ -- Now use that list to construct 'Score_ScoreLocation' objects,
+ -- and insert them.
+ mapM_ (insert_ . Score_Location 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
type: constraint
fields: [team_id]
-- entity: ScoreLocation
- dbName: scores_locations
- constructors:
- - name: ScoreLocation
- uniques:
- - name: unique_scores_location
- type: constraint
- fields: [city, state, country]
-
|]
-- 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: status_text, dbName: status_text }
- entity: ScoreGame_ScoreGameTeam
- dbName: scores__scores_games_teams
+ dbName: scores_games__scores_games_teams
constructors:
- name: ScoreGame_ScoreGameTeam
fields:
reference:
onDelete: cascade
-- entity: Score_ScoreLocation
- dbName: scores__scores_locations
+- entity: Score_Location
+ dbName: scores__locations
constructors:
- - name: Score_ScoreLocation
+ - name: Score_Location
fields:
- - name: score_ScoreLocation0 # Default created by mkNormalFieldName
+ - name: score_Location0 # Default created by mkNormalFieldName
dbName: scores_id
reference:
onDelete: cascade
- - name: score_ScoreLocation1 # Default created by mkNormalFieldName
- dbName: scores_locations_id
+ - name: score_Location1 # Default created by mkNormalFieldName
+ dbName: locations_id
reference:
onDelete: cascade
|]
-- 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.
---
-pickle_location :: PU ScoreLocation
-pickle_location =
- xpElem "location" $
- xpWrap (from_tuple, to_tuple) $
- xpTriple (xpOption (xpElem "city" xpText))
- (xpOption (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" $
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 :: Location
+ let b = undefined :: Score
+ let c = undefined :: ScoreGame
+ let d = undefined :: ScoreGameTeam
+ let e = undefined :: ScoreGame_ScoreGameTeam
+ let f = undefined :: Score_Location
+ 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.
+ deleteAll b
+ 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 / blobdiff