X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=86eed4a8682679abe61c5cc1751375fba1bc3316;hb=b830faafac5d720a8eecae369806d9142a186485;hp=20316343f8afccfe360280e6871fa003bcfea46d;hpb=c5d61081ad0d95950ca06761978d240632c44510;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 2031634..86eed4a 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -29,9 +29,15 @@ import Data.List.Utils ( join, split )
 import Data.Tuple.Curry ( uncurryN )
 import Data.Typeable ( Typeable )
 import Database.Groundhog (
+  countAll,
+  executeRaw,
   insert_,
-  migrate )
+  migrate,
+  runMigration,
+  silentMigrationLogger )
 import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
 import Database.Groundhog.TH (
   defaultCodegenConfig,
   groundhog,
@@ -59,7 +65,12 @@ import TSN.Database ( insert_or_select )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers ( xp_time_stamp )
 import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
+import Xml (
+  FromXml(..),
+  ToDb(..),
+  pickle_unpickle,
+  unpickleable,
+  unsafe_unpickle )
 
 
 --
@@ -261,7 +272,6 @@ mkPersist defaultCodegenConfig [groundhog|
 -- use our own codegen to peel those off before naming the columns.
 mkPersist tsn_codegen_config [groundhog|
 - entity: News
-  dbName: news
   constructors:
     - name: News
       uniques:
@@ -420,6 +430,7 @@ news_tests =
   testGroup
     "News tests"
     [ test_news_fields_have_correct_names,
+      test_on_delete_cascade,
       test_pickle_of_unpickle_is_identity,
       test_unpickle_succeeds ]
 
@@ -485,3 +496,39 @@ 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 "deleting news deletes its children"
+          "test/xml/newsxml.xml"
+          4 -- 2 news_teams and 2 news_locations that should remain.
+  ]
+  where
+    check desc path expected = testCase desc $ do
+      news <- unsafe_unpickle path pickle_message
+      let a = undefined :: News
+      let b = undefined :: NewsTeam
+      let c = undefined :: News_NewsTeam
+      let d = undefined :: NewsLocation
+      let e = undefined :: News_NewsLocation
+      actual <- withSqliteConn ":memory:" $ runDbConn $ do
+                  runMigration silentMigrationLogger $ do
+                    migrate a
+                    migrate b
+                    migrate c
+                    migrate d
+                    migrate e
+                  _ <- dbimport news
+                  -- No idea how 'delete' works, so do this instead.
+                  executeRaw False "DELETE FROM news;" []
+                  count_a <- countAll a
+                  count_b <- countAll b
+                  count_c <- countAll c
+                  count_d <- countAll d
+                  count_e <- countAll e
+                  return $ count_a + count_b + count_c + count_d + count_e
+      actual @?= expected