From: Michael Orlitzky Date: Wed, 22 Jan 2014 04:48:46 +0000 (-0500) Subject: Add some tests for the ON DELETE CASCADE behavior. X-Git-Tag: 0.0.2~7 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=4595387816651b26e4c163e5c416c5caa01d17cf;p=dead%2Fhtsn-import.git Add some tests for the ON DELETE CASCADE behavior. --- diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs index eb369e0..81243e4 100644 --- a/src/TSN/XML/Injuries.hs +++ b/src/TSN/XML/Injuries.hs @@ -29,11 +29,18 @@ where import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Typeable ( Typeable ) -import Database.Groundhog ( migrate ) +import Database.Groundhog ( + countAll, + executeRaw, + migrate, + runMigration, + silentMigrationLogger ) import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Data.Tuple.Curry ( uncurryN ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) @@ -61,7 +68,8 @@ import Xml ( FromXmlFk(..), ToDb(..), pickle_unpickle, - unpickleable ) + unpickleable, + unsafe_unpickle ) -- @@ -288,7 +296,8 @@ injuries_tests :: TestTree injuries_tests = testGroup "Injuries tests" - [ test_pickle_of_unpickle_is_identity, + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] @@ -309,7 +318,31 @@ test_pickle_of_unpickle_is_identity = test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testCase "unpickling succeeds" $ do - let path = "test/xml/injuriesxml.xml" - actual <- unpickleable path pickle_message - let expected = True - actual @?= expected + let path = "test/xml/injuriesxml.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 an injuries deletes its children" $ do + let path = "test/xml/injuriesxml.xml" + inj <- unsafe_unpickle path pickle_message + let a = undefined :: Injuries + let b = undefined :: InjuriesListing + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + _ <- dbimport inj + -- No idea how 'delete' works, so do this instead. + executeRaw False "DELETE FROM injuries;" [] + count_a <- countAll a + count_b <- countAll b + return $ count_a + count_b + let expected = 0 + actual @?= expected diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index 995101d..e5d572e 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -28,7 +28,13 @@ import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( DefaultKey, - migrate ) + countAll, + executeRaw, + migrate, + runMigration, + silentMigrationLogger ) +import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) @@ -57,7 +63,8 @@ import Xml ( FromXmlFk(..), ToDb(..), pickle_unpickle, - unpickleable ) + unpickleable, + unsafe_unpickle ) -- @@ -388,7 +395,8 @@ injuries_detail_tests :: TestTree injuries_detail_tests = testGroup "InjuriesDetail tests" - [ test_pickle_of_unpickle_is_identity, + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] @@ -423,3 +431,35 @@ 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 "delete of injuries_detail deletes its children" + "test/xml/Injuries_Detail_XML.xml", + + check "delete of injuries_detail deletes its children (non-int team_id)" + "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ] + where + check desc path = testCase desc $ do + inj <- unsafe_unpickle path pickle_message + let a = undefined :: InjuriesDetail + let b = undefined :: InjuriesDetailListing + let c = undefined :: InjuriesDetailListingPlayerListing + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + _ <- dbimport inj + -- No idea how 'delete' works, so do this instead. + executeRaw False "DELETE FROM injuries_detail;" [] + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + return $ count_a + count_b + count_c + let expected = 0 + actual @?= expected diff --git a/src/Xml.hs b/src/Xml.hs index 3f7bb62..780a64e 100644 --- a/src/Xml.hs +++ b/src/Xml.hs @@ -10,7 +10,8 @@ module Xml ( ToDb(..), parse_opts, pickle_unpickle, - unpickleable ) + unpickleable, + unsafe_unpickle ) where -- System imports. @@ -29,6 +30,7 @@ import Text.XML.HXT.Core ( withSubstDTDEntities, withValidate, xpickleVal, + xunpickleDocument, xunpickleVal, yes ) @@ -143,3 +145,11 @@ unpickleable filepath unpickler = do try_unpickle = runX $ readDocument parse_opts filepath >>> xunpickleVal unpickler + + +-- | Unpickle from a 'FilePath' using the given pickler. Explode if it +-- doesn't work. +-- +unsafe_unpickle :: FilePath -> PU a -> IO a +unsafe_unpickle filepath unpickler = + fmap head $ runX $ xunpickleDocument unpickler parse_opts filepath