-- that league contains a bunch of listings.
--
module TSN.XML.Weather (
+ dtd,
pickle_message,
-- * Tests
weather_tests,
import Control.Monad ( forM_ )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
-import Database.Groundhog ( migrate )
+import Database.Groundhog (
+ countAll,
+ deleteAll,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
groundhog,
mkPersist )
import TSN.Picklers ( xp_gamedate, xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
+ Child(..),
FromXml(..),
FromXmlFk(..),
ToDb(..),
pickle_unpickle,
- unpickleable )
+ unpickleable,
+ unsafe_unpickle )
+
+
+
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "weatherxml.dtd"
--
instance ToDb WeatherForecastListingXml where
type Db WeatherForecastListingXml = WeatherForecastListing
--- | This is needed to define the 'XmlImportFk' instance for
--- 'WeatherForecastListing'.
---
-instance FromXmlFk WeatherForecastListingXml where
+
+instance Child WeatherForecastListingXml where
-- | Each 'WeatherForecastListingXml' is contained in a
-- 'WeatherForecast'.
--
type Parent WeatherForecastListingXml = WeatherForecast
+
+-- | This is needed to define the 'XmlImportFk' instance for
+-- 'WeatherForecastListing'.
+--
+instance FromXmlFk WeatherForecastListingXml where
from_xml_fk fk WeatherForecastListingXml{..} =
WeatherForecastListing {
db_weather_forecasts_id = fk,
--
type Db WeatherForecastXml = WeatherForecast
-instance FromXmlFk WeatherForecastXml where
+
+instance Child WeatherForecastXml where
+ -- | The database type containing a 'WeatherForecastXml' is
+ -- 'Weather'.
type Parent WeatherForecastXml = Weather
+
+instance FromXmlFk WeatherForecastXml where
+
-- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
-- replace the 'WeatherLeague' with its name.
--
weather_tests =
testGroup
"Weather tests"
- [ test_pickle_of_unpickle_is_identity,
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
test_unpickle_succeeds ]
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds =
testCase "unpickling succeeds" $ do
- let path = "test/xml/weatherxml.xml"
- actual <- unpickleable path pickle_message
- let expected = True
- actual @?= expected
+ let path = "test/xml/weatherxml.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 weather deletes its children" $ do
+ let path = "test/xml/weatherxml.xml"
+ weather <- unsafe_unpickle path pickle_message
+ let a = undefined :: Weather
+ let b = undefined :: WeatherForecast
+ let c = undefined :: WeatherForecastListing
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ migrate c
+ _ <- dbimport weather
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ count_c <- countAll c
+ return $ count_a + count_b + count_c
+ let expected = 0
+ actual @?= expected