X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingResults.hs;h=596b0bd46c4d7fff742a444f304ef3a7ec462360;hb=f2c3c36ec22bbf8d56a9a2cfdfc49276facc349b;hp=fc19656ea40c7615806e22e20546f33cacf3061c;hpb=e53fc614221083bc059a6eebfab91172db0a0723;p=dead%2Fhtsn-import.git

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
+--   \<message\> element contains a \<Race_Information\> and a bunch of
+--   \<Listing\>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