From: Michael Orlitzky Date: Sat, 25 Jan 2014 02:10:10 +0000 (-0500) Subject: Add database support and tests for TSN.XML.Scores. X-Git-Tag: 0.0.4~6 X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=commitdiff_plain;h=8c7f33d76981a27a4fde6271dc71105b23adc5a1 Add database support and tests for TSN.XML.Scores. --- diff --git a/doc/TODO b/doc/TODO index 6d95985..347b785 100644 --- a/doc/TODO +++ b/doc/TODO @@ -6,7 +6,9 @@ 3. Add support the the second type of weatherxml (see man page). -4. There are a few remaining document types that we need to parse +4. Add schema diagram for scores. + +5. There are a few remaining document types that we need to parse before "version one point oh." This list refers to an old proprietary implementation, sorry: diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs index 8660b1f..403727e 100644 --- a/src/TSN/XML/Scores.hs +++ b/src/TSN/XML/Scores.hs @@ -10,6 +10,7 @@ -- contains a single \ and some \s. -- module TSN.XML.Scores ( + dtd, pickle_message, -- * Tests scores_tests, @@ -23,7 +24,6 @@ module TSN.XML.Scores ( where -- System imports. -import Control.Monad ( forM_ ) import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) @@ -31,6 +31,8 @@ import Data.Typeable ( Typeable ) import Database.Groundhog ( countAll, executeRaw, + insert, + insert_, migrate, runMigration, silentMigrationLogger ) @@ -47,7 +49,6 @@ import Text.XML.HXT.Core ( PU, xp7Tuple, xp11Tuple, - xp12Tuple, xpAttr, xpElem, xpInt, @@ -63,7 +64,7 @@ import Text.XML.HXT.Core ( 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(..), @@ -74,13 +75,23 @@ import Xml ( 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, @@ -93,6 +104,10 @@ data Score = db_season_type :: String, db_time_stamp :: UTCTime } + +-- | XML representation of the top level \ element (i.e. a +-- 'Score'). +-- data Message = Message { xml_xml_file_id :: Int, @@ -108,9 +123,36 @@ data Message = 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 \ +-- 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, @@ -120,6 +162,9 @@ data ScoreGameStatus = db_status_text :: String } deriving (Data, Eq, Show, Typeable) + +-- | Database representation of a game. +-- data ScoreGame = ScoreGame { db_scores_id :: DefaultKey Score, @@ -130,6 +175,8 @@ data ScoreGame = db_notes :: Maybe String } +-- | XML representation of a \ element (i.e. a 'ScoreGame'). +-- data ScoreGameXml = ScoreGameXml { xml_vteam :: ScoreGameVTeam, @@ -141,25 +188,72 @@ data ScoreGameXml = 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 @@ -170,16 +264,23 @@ data ScoreGame_ScoreGameTeam = -- * ScoreLocation +-- | Database and XML representation of a \. 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) @@ -187,6 +288,38 @@ data Score_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 @@ -219,6 +352,7 @@ mkPersist defaultCodegenConfig [groundhog| -- 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: @@ -288,7 +422,7 @@ mkPersist tsn_codegen_config [groundhog| -- Pickling -- --- | Convert a 'Message' to/from XML. +-- | Convert a 'Message' to/from \. -- pickle_message :: PU Message pickle_message = @@ -321,14 +455,14 @@ pickle_message = --- | Convert a 'ScoreLocation' to/from XML. +-- | Convert a 'ScoreLocation' to/from \. -- 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 = @@ -336,6 +470,8 @@ pickle_location = to_tuple l = (city l, state l, country l) +-- | Convert a 'ScoreGameStatus' to/from \. +-- pickle_status :: PU ScoreGameStatus pickle_status = xpElem "status" $ @@ -345,8 +481,13 @@ pickle_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 \. +-- pickle_game :: PU ScoreGameXml pickle_game = xpElem "game" $ @@ -369,6 +510,8 @@ pickle_game = xml_notes) +-- | Convert a 'ScoreGameVTeam' to/from \. +-- pickle_vteam :: PU ScoreGameVTeam pickle_vteam = xpElem "vteam" $ @@ -377,9 +520,12 @@ pickle_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 \. Identical to +-- 'pickle_vteam' modulo the \"h\" and \"v\". +-- pickle_hteam :: PU ScoreGameHTeam pickle_hteam = xpElem "hteam" $ @@ -388,7 +534,8 @@ pickle_hteam = xpText where from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam - to_tuple (ScoreGameHTeam (ScoreGameTeam x y)) = (x,y) + to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name) + --- @@ -401,7 +548,8 @@ scores_tests :: TestTree scores_tests = testGroup "Scores tests" - [ test_pickle_of_unpickle_is_identity, + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] @@ -436,3 +584,47 @@ test_unpickle_succeeds = testGroup "unpickle tests" 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 diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test index b4c3fa5..039ebad 100644 --- a/test/shell/import-duplicates.test +++ b/test/shell/import-duplicates.test @@ -19,11 +19,11 @@ find ./test/xml -name '*.xml' | wc -l >>>= 0 # Run the imports again; we should get complaints about the duplicate -# xml_file_ids. There are 2 errors for each violation, so we expect 2*13 +# xml_file_ids. There are 2 errors for each violation, so we expect 2*15 # occurrences of the string 'ERROR'. ./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l >>> -26 +30 >>>= 0 # Finally, clean up after ourselves.