Replace all raw DELETE queries with deleteAll.

[dead/htsn-import.git] / src / TSN / XML / News.hs

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 20316343f8afccfe360280e6871fa003bcfea46d..c42b931cf88e8df1fed92f46c10d6597cad4ef6b 100644 (file)
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -11,6 +11,7 @@
 --   a root element \<message\> that contains an entire news item.
 --
 module TSN.XML.News (
+  dtd,
   pickle_message,
   -- * Tests
   news_tests,
@@ -29,9 +30,15 @@ import Data.List.Utils ( join, split )
 import Data.Tuple.Curry ( uncurryN )
 import Data.Typeable ( Typeable )
 import Database.Groundhog (
+  countAll,
+  deleteAll,
   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 +66,18 @@ 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 )
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "newsxml.dtd"
 
 
 --
@@ -261,7 +279,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 +437,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 +503,38 @@ 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
+                  deleteAll a
+                  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