{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
--- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
--- root element \<message\> that contains an entire news item.
+-- | Parse TSN XML for the DTD \"newsxml.dtd\". Each document contains
+-- a root element \<message\> that contains an entire news item.
--
module TSN.XML.News (
+ dtd,
pickle_message,
-- * Tests
news_tests,
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,
import TSN.Codegen (
tsn_codegen_config,
tsn_db_field_namer ) -- Used in a test
+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"
--
-- embed it into the 'News' type. We (pointlessly) use the "db_"
-- prefix here so that the two names don't collide on "id" when
-- Groundhog is creating its fields using our field namer.
+--
data MsgId =
MsgId {
db_msg_id :: Int,
deriving (Data, Eq, Show, Typeable)
--- | The XML representation of a news item (message).
+-- | The XML representation of a news item (\<message\>).
--
data Message =
Message {
instance ToDb Message where
+ -- | The database representation of 'Message' is 'News'.
type Db Message = News
-- | Convert the XML representation 'Message' to the database
db_continue = xml_continue,
db_time_stamp = xml_time_stamp }
--- | This lets us call 'insert_xml' on a 'Message'.
+-- | This lets us insert the XML representation 'Message' directly.
--
instance XmlImport Message
deriving (Eq, Show)
-instance ToDb NewsTeam where
- -- | The database representaion of a 'NewsTeam' is itself.
- type Db NewsTeam = NewsTeam
-
--- | This is needed to define the XmlImport instance for NewsTeam.
---
-instance FromXml NewsTeam where
- -- | How to we get a 'NewsTeam' from itself?
- from_xml = id
-
--- | Allow us to call 'insert_xml' on the XML representation of
--- NewsTeams.
---
-instance XmlImport NewsTeam
-
-
-- * News_NewsTeam
country :: String }
deriving (Eq, Show)
-instance ToDb NewsLocation where
- -- | The database representation of a 'NewsLocation' is itself.
- type Db NewsLocation = NewsLocation
-
--- | This is needed to define the XmlImport instance for NewsLocation.
---
-instance FromXml NewsLocation where
- -- | How to we get a 'NewsLocation' from itself?
- from_xml = id
-
--- | Allow us to call 'insert_xml' on the XML representation of
--- NewsLocations.
---
-instance XmlImport NewsLocation
-
-- * News_NewsLocation
instance DbImport Message where
dbmigrate _ =
run_dbmigrate $ do
- migrate (undefined :: NewsTeam)
- migrate (undefined :: NewsLocation)
migrate (undefined :: News)
+ migrate (undefined :: NewsTeam)
migrate (undefined :: News_NewsTeam)
+ migrate (undefined :: NewsLocation)
migrate (undefined :: News_NewsLocation)
dbimport message = do
-- because we know that most teams will already exist, and we
-- want to get back the id for the existing team when
-- there's a collision.
- nt_ids <- mapM insert_xml_or_select (xml_teams message)
+ nt_ids <- mapM insert_or_select (xml_teams message)
-- Now that the teams have been inserted, create
-- news__news_team records mapping beween the two.
mapM_ insert_ news_news_teams
-- Do all of that over again for the NewsLocations.
- loc_ids <- mapM insert_xml_or_select (xml_locations message)
+ loc_ids <- mapM insert_or_select (xml_locations message)
let news_news_locations = map (News_NewsLocation news_id) loc_ids
mapM_ insert_ news_news_locations
-- 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:
onDelete: cascade
|]
+
--
-- XML Picklers
--
testGroup
"News tests"
[ test_news_fields_have_correct_names,
+ test_on_delete_cascade,
test_pickle_of_unpickle_is_identity,
test_unpickle_succeeds ]
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
projects / dead / htsn-import.git / blobdiff