From f2c3c36ec22bbf8d56a9a2cfdfc49276facc349b Mon Sep 17 00:00:00 2001
From: Michael Orlitzky <michael@orlitzky.com>
Date: Fri, 13 Jun 2014 11:06:22 -0400
Subject: [PATCH] Implement dbimport for AutoRacingResults and add its test
 suite.

---
 src/TSN/XML/AutoRacingResults.hs | 86 ++++++++++++++++++++++++++++++--
 test/TestSuite.hs                |  4 +-
 2 files changed, 85 insertions(+), 5 deletions(-)

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
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,
-- 
2.43.2