From: Michael Orlitzky Date: Fri, 13 Jun 2014 15:06:22 +0000 (-0400) Subject: Implement dbimport for AutoRacingResults and add its test suite. X-Git-Tag: 0.0.6~210 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=f2c3c36ec22bbf8d56a9a2cfdfc49276facc349b;p=dead%2Fhtsn-import.git Implement dbimport for AutoRacingResults and add its test suite. --- diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs index fc19656..596b0bd 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, @@ -349,7 +350,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| @@ -521,3 +533,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 diff --git a/test/TestSuite.hs b/test/TestSuite.hs index baf5f5d..20df089 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,5 +1,6 @@ import Test.Tasty ( TestTree, defaultMain, testGroup ) +import TSN.XML.AutoRacingResults ( auto_racing_results_tests ) import TSN.XML.AutoRacingSchedule ( auto_racing_schedule_tests ) import TSN.XML.GameInfo ( gameinfo_tests ) import TSN.XML.Heartbeat ( heartbeat_tests ) @@ -13,7 +14,8 @@ import TSN.XML.Weather ( weather_tests ) tests :: TestTree tests = testGroup "All tests" - [ auto_racing_schedule_tests, + [ auto_racing_results_tests, + auto_racing_schedule_tests, gameinfo_tests, heartbeat_tests, injuries_tests,