X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingResults.hs;h=817bf15cd0c10212697b8067ee4711e3951de15a;hb=6ff7eea94fdd25ee6ee60136c749a57ac3b665f8;hp=fc19656ea40c7615806e22e20546f33cacf3061c;hpb=3a2418d302ee14b9605ebe3013cf417ea5cf0057;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs index fc19656..817bf15 100644 --- a/src/TSN/XML/AutoRacingResults.hs +++ b/src/TSN/XML/AutoRacingResults.hs @@ -6,13 +6,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". +-- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". Each +-- \ element contains a \ and a bunch of +-- \s. -- module TSN.XML.AutoRacingResults ( dtd, pickle_message, -- * Tests --- auto_racing_results_tests, + auto_racing_results_tests, -- * WARNING: these are private but exported to silence warnings AutoRacingResultsConstructor(..), AutoRacingResultsListingConstructor(..), @@ -42,7 +44,6 @@ import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, xp11Tuple, - xp12Tuple, xp13Tuple, xpAttr, xpElem, @@ -59,7 +60,7 @@ import Text.XML.HXT.Core ( import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_earnings, xp_racedate, xp_time_stamp ) +import TSN.Picklers ( xp_earnings, xp_datetime, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( FromXml(..), @@ -81,7 +82,9 @@ dtd = "AutoRacingResultsXML.dtd" -- * AutoRacingResults/Message --- | Database representation of a 'Message'. +-- | Database representation of a 'Message'. Comparatively, it lacks +-- the listings and race information since they are linked via a +-- foreign key. -- data AutoRacingResults = AutoRacingResults { @@ -100,7 +103,9 @@ data AutoRacingResults = --- | XML Representation of an 'AutoRacingResults'. +-- | XML Representation of an 'AutoRacingResults'. It has the same +-- fields, but in addition contains the 'xml_listings' and +-- 'xml_race_information'. -- data Message = Message { @@ -157,7 +162,7 @@ instance XmlImport Message -- * AutoRacingResultsListing/AutoRacingResultsListingXml -- | Database representation of a \ contained within a --- \. +-- \. -- data AutoRacingResultsListing = AutoRacingResultsListing { @@ -176,6 +181,7 @@ data AutoRacingResultsListing = db_nc :: Maybe Bool, db_earnings :: Maybe Int } + -- | XML representation of a \ contained within a -- \. -- @@ -203,6 +209,7 @@ instance ToDb AutoRacingResultsListingXml where -- type Db AutoRacingResultsListingXml = AutoRacingResultsListing + instance FromXmlFk AutoRacingResultsListingXml where -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a -- foreign key to) a 'AutoRacingResults'. @@ -254,13 +261,13 @@ data MostLapsLeading = deriving (Data, Eq, Show, Typeable) --- | Database representation of a \ contained within a --- \. +-- | Database representation of a \ contained +-- within a \. -- data AutoRacingResultsRaceInformation = AutoRacingResultsRaceInformation { -- Note the apostrophe to disambiguate it from the - -- AutoRacingResultsListing filed. + -- AutoRacingResultsListing field. db_auto_racing_results_id' :: DefaultKey AutoRacingResults, db_track_length :: Double, db_track_length_kph :: Double, @@ -349,7 +356,18 @@ instance DbImport Message where migrate (undefined :: AutoRacingResultsListing) migrate (undefined :: AutoRacingResultsRaceInformation) - dbimport = undefined + -- | We insert the message, then use its ID to insert the listings + -- and race information. + dbimport m = do + msg_id <- insert_xml m + + insert_xml_fk_ msg_id (xml_race_information m) + + forM_ (xml_listings m) $ \listing -> do + insert_xml_fk_ msg_id listing + + return ImportSucceeded + mkPersist tsn_codegen_config [groundhog| @@ -373,19 +391,24 @@ mkPersist tsn_codegen_config [groundhog| reference: onDelete: cascade - +# Note the apostrophe in the foreign key. This is to disambiguate +# it from the AutoRacingResultsListing foreign key of the same name. +# We strip it out of the dbName. - entity: AutoRacingResultsRaceInformation dbName: auto_racing_results_race_information constructors: - name: AutoRacingResultsRaceInformation fields: - name: db_auto_racing_results_id' + dbName: auto_racing_results_id reference: onDelete: cascade - name: db_most_laps_leading embeddedType: - - {name: most_laps_leading_driver_id, dbName: most_laps_leading_driver_id} - - {name: most_laps_leading_driver, dbName: most_laps_leading_driver} + - {name: most_laps_leading_driver_id, + dbName: most_laps_leading_driver_id} + - {name: most_laps_leading_driver, + dbName: most_laps_leading_driver} - embedded: MostLapsLeading fields: @@ -402,6 +425,8 @@ mkPersist tsn_codegen_config [groundhog| --- Pickling --- +-- | Pickler for the \s contained within \s. +-- pickle_listing :: PU AutoRacingResultsListingXml pickle_listing = xpElem "Listing" $ @@ -437,6 +462,7 @@ pickle_listing = -- | Pickler for the top-level 'Message'. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -446,7 +472,7 @@ pickle_message = (xpElem "category" xpText) (xpElem "sport" xpText) (xpElem "RaceID" xpInt) - (xpElem "RaceDate" xp_racedate) + (xpElem "RaceDate" xp_datetime) (xpElem "Title" xpText) (xpElem "Track_Location" xpText) (xpElem "Laps_Remaining" xpInt) @@ -471,6 +497,9 @@ pickle_message = xml_time_stamp m) +-- | Pickler for the \ child of a +-- \. +-- pickle_most_laps_leading :: PU MostLapsLeading pickle_most_laps_leading = xpElem "Most_Laps_Leading" $ @@ -484,13 +513,16 @@ pickle_most_laps_leading = db_most_laps_leading_driver m, db_most_laps_leading_number_of_laps m) + +-- | Pickler for the \ child of \. +-- pickle_race_information :: PU AutoRacingResultsRaceInformationXml pickle_race_information = xpElem "Race_Information" $ xpWrap (from_tuple, to_tuple) $ xp11Tuple (-- I can't think of another way to get both the -- TrackLength and its KPH attribute. So we shove them - -- both in a 2-tuple. + -- both in a 2-tuple. This should probably be an embedded type! xpElem "TrackLength" $ xpPair xpPrim (xpAttr "KPH" xpPrim) ) (xpElem "Laps" xpInt) (xpOption $ xpElem "AverageSpeedMPH" xpPrim) @@ -521,3 +553,69 @@ pickle_race_information = xml_lead_changes m, xml_lap_leaders m, xml_most_laps_leading m) + +-- +-- Tasty Tests +-- + +-- | A list of all tests for this module. +-- +auto_racing_results_tests :: TestTree +auto_racing_results_tests = + testGroup + "AutoRacingResults tests" + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, + test_unpickle_succeeds ] + +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: success of this +-- 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/AutoRacingResultsXML.xml" + (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/AutoRacingResultsXML.xml" + 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 = + testCase "deleting auto_racing_results deletes its children" $ do + let path = "test/xml/AutoRacingResultsXML.xml" + results <- unsafe_unpickle path pickle_message + let a = undefined :: AutoRacingResults + let b = undefined :: AutoRacingResultsListing + let c = undefined :: AutoRacingResultsRaceInformation + + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + _ <- dbimport results + deleteAll a + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + return $ sum [count_a, count_b, count_c] + let expected = 0 + actual @?= expected