X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuriesDetail.hs;h=e5d572e7a504f37f0ed994d1c495bfd55bc41407;hb=4595387816651b26e4c163e5c416c5caa01d17cf;hp=f14b0f153d3c473c9a192f785a8b0856730379ef;hpb=bc54be6029dafbb7121eaeb1a2190ed1b5d87a00;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs
index f14b0f1..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 )
 
 
 --
@@ -93,6 +100,7 @@ data InjuriesDetail =
 instance ToDb Message where
   -- | The database representation of a 'Message' is an
   --   'InjuriesDetail'.
+  --
   type Db Message = InjuriesDetail
 
 instance FromXml Message where
@@ -106,15 +114,16 @@ instance FromXml Message where
       db_time_stamp = xml_time_stamp }
 
 
--- | This allows us to call 'insert_xml' directly on the XML
---   representation.
+-- | This allows us to insert the XML representation 'Message'
+--   directly.
+--
 instance XmlImport Message
 
 
 
 -- * InjuriesDetailListing/InjuriesDetailListingXml
 
--- | Database representation of an InjuriesDetailListing. It has a
+-- | Database representation of a \<Listing\> element. It has a
 --   foreign key pointing to its parent 'InjuriesDetail', and does not
 --   contain the list of 'xml_player_listings' (which get their own
 --   table).
@@ -145,6 +154,8 @@ instance ToDb InjuriesDetailListingXml where
   type Db InjuriesDetailListingXml = InjuriesDetailListing
 
 instance FromXmlFk InjuriesDetailListingXml where
+  -- | Each 'InjuriesDetailListingXml' is contained in an
+  --   'InjuriesDetail'.
   type Parent InjuriesDetailListingXml = InjuriesDetail
 
   -- | Construct a 'InjuriesDetailListing' from a
@@ -157,6 +168,9 @@ instance FromXmlFk InjuriesDetailListingXml where
       db_team_id = xml_team_id,
       db_full_name = xml_full_name }
 
+-- | This allows us to insert the XML representation
+--   'InjuriesDetailListingXml' directly.
+--
 instance XmlImportFk InjuriesDetailListingXml
 
 
@@ -214,10 +228,15 @@ instance ToDb InjuriesDetailListingPlayerListingXml where
     InjuriesDetailListingPlayerListing
 
 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
+  -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
+  --   'InjuriesDetailListing'.
+  --
   type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
 
-  -- | To convert between a 'InjuriesDetailListingPlayerListingXml'
-  --   and a 'InjuriesDetailListingPlayerListingXml', we do nothing.
+  -- | To construct a 'InjuriesDetailListingPlayerListing' from a
+  --   'InjuriesDetailListingPlayerListingXml' we need to supply a
+  --   foreign key to an 'InjuriesDetailListing'.
+  --
   from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
     InjuriesDetailListingPlayerListing {
       db_injuries_detail_listings_id = fk,
@@ -231,9 +250,8 @@ instance FromXmlFk InjuriesDetailListingPlayerListingXml where
       db_injured = xml_injured,
       db_type = xml_type }
 
--- | This lets us call 'insert_xml' on a
---   'InjuriesDetailListingPlayerListingXml' without having to
---   explicitly convert it to its database analogue first.
+-- | This lets us insert the XML representation
+--   'InjuriesDetailListingPlayerListingXml' directly.
 --
 instance XmlImportFk InjuriesDetailListingPlayerListingXml
 
@@ -243,9 +261,16 @@ instance XmlImportFk InjuriesDetailListingPlayerListingXml
 --
 
 instance DbImport Message where
+  dbmigrate _ =
+    run_dbmigrate $ do
+      migrate (undefined :: InjuriesDetail)
+      migrate (undefined :: InjuriesDetailListing)
+      migrate (undefined :: InjuriesDetailListingPlayerListing)
+
   -- | To import a 'Message', we import all of its
-  --   'InjuriesDetailListingPlayerListingXml's, which we have to dig out of its
-  --   'Listing's.
+  --   'InjuriesDetailListingPlayerListingXml's, which we have to dig
+  --   out of its 'Listing's.
+  --
   dbimport msg = do
     msg_id <- insert_xml msg
 
@@ -255,12 +280,6 @@ instance DbImport Message where
 
     return ImportSucceeded
 
-  dbmigrate _ =
-    run_dbmigrate $ do
-      migrate (undefined :: InjuriesDetail)
-      migrate (undefined :: InjuriesDetailListing)
-      migrate (undefined :: InjuriesDetailListingPlayerListing)
-
 
 mkPersist tsn_codegen_config [groundhog|
 - entity: InjuriesDetail
@@ -376,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 ]
 
 
@@ -411,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