data JFileGameAwayTeamXml =
JFileGameAwayTeamXml {
away_team_id :: String,
- away_team_abbreviation :: String,
- away_team_name :: String }
+ away_team_abbreviation :: Maybe String,
+ away_team_name :: Maybe String }
deriving (Eq, Show)
instance ToDb JFileGameAwayTeamXml where
from_xml JFileGameAwayTeamXml{..} =
Team {
team_id = away_team_id,
- team_abbreviation = away_team_abbreviation,
- team_name = away_team_name }
+ abbreviation = away_team_abbreviation,
+ name = away_team_name }
-- | Allow us to import JFileGameAwayTeamXml directly.
instance XmlImport JFileGameAwayTeamXml
data JFileGameHomeTeamXml =
JFileGameHomeTeamXml {
home_team_id :: String,
- home_team_abbreviation :: String,
- home_team_name :: String }
+ home_team_abbreviation :: Maybe String,
+ home_team_name :: Maybe String }
deriving (Eq, Show)
instance ToDb JFileGameHomeTeamXml where
from_xml JFileGameHomeTeamXml{..} =
Team {
team_id = home_team_id,
- team_abbreviation = home_team_abbreviation,
- team_name = home_team_name }
+ abbreviation = home_team_abbreviation,
+ name = home_team_name }
-- | Allow us to import JFileGameHomeTeamXml directly.
instance XmlImport JFileGameHomeTeamXml
-- Now loop through the message's games
forM_ (xml_games $ xml_gamelist m) $ \game -> do
+ -- First insert the game, keyed to the "jfile",
+ game_id <- insert_xml_fk msg_id 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".
+ -- Next, we insert the home and away 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.
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,
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,
-- 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
+ 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]
+ actual @?= expected