jfile_tests,
-- * WARNING: these are private but exported to silence warnings
JFileConstructor(..),
- JFileGameConstructor(..),
- JFileGame_TeamConstructor(..) )
+ JFileGameConstructor(..) )
where
-- System imports
import Database.Groundhog (
countAll,
deleteAll,
- insert_,
migrate,
runMigration,
silentMigrationLogger )
-- Local imports
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_time,
xp_time_dots,
xp_time_stamp )
-import TSN.Team ( Team(..) )
+import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
import TSN.XmlImport (
XmlImport(..),
- XmlImportFk(..) )
+ XmlImportFkTeams(..) )
import Xml (
+ Child(..),
FromXml(..),
- FromXmlFk(..),
+ FromXmlFkTeams(..),
ToDb(..),
pickle_unpickle,
unpickleable,
instance XmlImport Message
--- * JFileGameAwayTeamXml / JFileGameHomeTeamXml
-
--- | The XML representation of a JFile away team. Its corresponding
--- database representation (along with that of the home team) is a
--- TSN.Team, but their XML representations are different.
-data JFileGameAwayTeamXml =
- JFileGameAwayTeamXml {
- away_team_id :: String,
- away_team_abbreviation :: String,
- away_team_name :: String }
- deriving (Eq, Show)
-
-instance ToDb JFileGameAwayTeamXml where
- -- | The database analogue of an 'JFileGameAwayTeamXml' is
- -- a 'Team'.
- --
- type Db JFileGameAwayTeamXml = Team
-
-instance FromXml JFileGameAwayTeamXml where
- -- | To convert a 'JFileGameAwayTeamXml' to a 'Team', we do just
- -- about nothing.
- --
- from_xml JFileGameAwayTeamXml{..} =
- Team {
- team_id = away_team_id,
- team_abbreviation = away_team_abbreviation,
- team_name = away_team_name }
-
--- | Allow us to import JFileGameAwayTeamXml directly.
-instance XmlImport JFileGameAwayTeamXml
-
-
--- | The XML representation of a JFile home team. Its corresponding
--- database representation (along with that of the away team) is a
--- TSN.Team, but their XML representations are different.
-data JFileGameHomeTeamXml =
- JFileGameHomeTeamXml {
- home_team_id :: String,
- home_team_abbreviation :: String,
- home_team_name :: String }
- deriving (Eq, Show)
-
-instance ToDb JFileGameHomeTeamXml where
- -- | The database analogue of an 'JFileGameHomeTeamXml' is
- -- a 'Team'.
- --
- type Db JFileGameHomeTeamXml = Team
-
-instance FromXml JFileGameHomeTeamXml where
- -- | To convert a 'JFileGameHomeTeamXml' to a 'Team', we do just
- -- about nothing.
- --
- from_xml JFileGameHomeTeamXml{..} =
- Team {
- team_id = home_team_id,
- team_abbreviation = home_team_abbreviation,
- team_name = home_team_name }
-
--- | Allow us to import JFileGameHomeTeamXml directly.
-instance XmlImport JFileGameHomeTeamXml
-
-- * JFileGame/JFileGameXml
-- 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_home_team_id :: Maybe String, -- redundant (Team)
- db_away_team_id :: Maybe String, -- redundant (Team)
+ 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)
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,
xml_season_type :: Maybe String,
xml_game_date :: UTCTime,
xml_game_time :: UTCTime,
- xml_vteam :: JFileGameAwayTeamXml,
+ xml_vteam :: VTeam,
xml_vleague :: Maybe String,
- xml_hteam :: JFileGameHomeTeamXml,
+ xml_hteam :: HTeam,
xml_hleague :: Maybe String,
xml_vscore :: Int,
xml_hscore :: Int,
--
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,
-- | This allows us to insert the XML representation
-- 'JFileGameXml' directly.
--
-instance XmlImportFk JFileGameXml
-
-
--- * JFileGame_Team
-
--- | Database mapping between games and their home/away teams.
---
-data JFileGame_Team =
- JFileGame_Team {
- jgt_jfile_games_id :: DefaultKey JFileGame,
- jgt_away_team_id :: DefaultKey Team,
- jgt_home_team_id :: DefaultKey Team }
+instance XmlImportFkTeams JFileGameXml
---
migrate (undefined :: Team)
migrate (undefined :: JFile)
migrate (undefined :: JFileGame)
- migrate (undefined :: JFileGame_Team)
dbimport m = do
-- Insert the top-level message
-- 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)
- -- Next, we insert the home and away teams. We do this before
- -- inserting the game itself because the game has two foreign keys
- -- pointing to "teams".
- away_team_id <- insert_xml_or_select (xml_vteam game)
- home_team_id <- insert_xml_or_select (xml_hteam game)
-
- game_id <- insert_xml_fk msg_id game
-
- -- Insert a record into jfile_games__teams mapping the
- -- home/away teams to this game. Use the full record syntax
- -- because the types would let us mix up the home/away teams.
- insert_ JFileGame_Team {
- jgt_jfile_games_id = game_id,
- jgt_away_team_id = away_team_id,
- jgt_home_team_id = home_team_id }
+ -- 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
- name: db_status
dbName: status
-# Many of the JFileGameOddsInfo fields are redundant and have
-# been left out.
+ # Many of the JFileGameOddsInfo fields are redundant and have
+ # been left out.
- embedded: JFileGameOddsInfo
fields:
- name: db_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: status_numeral, dbName: status_numeral}
- {name: status, dbName: status}
-- entity: JFileGame_Team
- dbName: jfile_games__teams
- constructors:
- - name: JFileGame_Team
- fields:
- - name: jgt_jfile_games_id
- reference:
- onDelete: cascade
- - name: jgt_away_team_id
- reference:
- onDelete: cascade
- - name: jgt_home_team_id
- reference:
- onDelete: cascade
|]
notes = intercalate "\n" [n1,n2,n3,n4,n5]
to_tuple o = (db_list_date o,
- db_home_team_id o,
- db_away_team_id 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,
(_:_:_:_:notes5:_) -> notes5
_ -> ""
-pickle_home_team :: PU JFileGameHomeTeamXml
+-- | (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" xpText)
- xpText
+ (xpAttr "abbr" (xpOption xpText)) -- Some are blank
+ (xpOption xpText) -- Yup, some are nameless
where
- from_tuple = uncurryN JFileGameHomeTeamXml
- to_tuple t = (home_team_id t,
- home_team_abbreviation t,
- home_team_name t)
+ from_tuple = HTeam . (uncurryN Team)
+ to_tuple (HTeam t) = (team_id t,
+ abbreviation t,
+ name t)
-pickle_away_team :: PU JFileGameAwayTeamXml
+-- | (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" xpText)
- xpText
+ (xpAttr "abbr" (xpOption xpText)) -- Some are blank
+ (xpOption xpText) -- Yup, some are nameless
where
- from_tuple = uncurryN JFileGameAwayTeamXml
- to_tuple t = (away_team_id t,
- away_team_abbreviation t,
- away_team_name t)
+ from_tuple = VTeam . (uncurryN Team)
+ to_tuple (VTeam t) = (team_id t,
+ abbreviation t,
+ name t)
pickle_status :: PU JFileGameStatus
-- test does not mean that unpickling succeeded.
--
test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
- testCase "pickle composed with unpickle is the identity" $ do
- let path = "test/xml/jfilexml.xml"
- (expected, actual) <- pickle_unpickle pickle_message path
- actual @?= expected
+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" ]
+ 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 =
- testCase "unpickling succeeds" $ do
- let path = "test/xml/jfilexml.xml"
+test_unpickle_succeeds = testGroup "unpickle tests"
+ [ check "unpickling succeeds" "test/xml/jfilexml.xml",
+ check "unpickling succeeds (missing fields)"
+ "test/xml/jfilexml-missing-fields.xml" ]
+ where
+ check desc path = testCase desc $ do
actual <- unpickleable path pickle_message
let expected = True
-- record.
--
test_on_delete_cascade :: TestTree
-test_on_delete_cascade =
- testCase "deleting auto_racing_results deletes its children" $ do
- let path = "test/xml/jfilexml.xml"
- results <- unsafe_unpickle path pickle_message
- let a = undefined :: Team
- let b = undefined :: JFile
- let c = undefined :: JFileGame
- let d = undefined :: JFileGame_Team
-
- actual <- withSqliteConn ":memory:" $ runDbConn $ do
- runMigration silentMigrationLogger $ do
- migrate a
- migrate b
- migrate c
- migrate d
- _ <- dbimport results
- deleteAll b
- count_a <- countAll a
- count_b <- countAll b
- count_c <- countAll c
- count_d <- countAll d
- return $ sum [count_a, count_b, count_c, count_d]
- let expected = 20 -- Twenty teams should be left over
- actual @?= expected
+test_on_delete_cascade = testGroup "cascading delete tests"
+ [ check "deleting auto_racing_results deletes its children"
+ "test/xml/jfilexml.xml"
+ 20,
+ check "deleting auto_racing_results deletes its children (missing fields)"
+ "test/xml/jfilexml-missing-fields.xml"
+ 44 ]
+ 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
+ runMigration silentMigrationLogger $ 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