X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=913477168540ea47e178adca60e0d1b21bd2165e;hb=4d6a41c7a9594e10ae004bb2c0ee72bde26ebcda;hp=ea1378725e82e1cce381c83a9c8ea4b8c477ca4a;hpb=0ddc996d5622f138953ad027cc425713a276b46a;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index ea13787..9134771 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -3,14 +3,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a --- root element \ that contains an entire news item. +-- | Parse TSN XML for the DTD \"newsxml.dtd\". Each document contains +-- a root element \ that contains an entire news item. -- module TSN.XML.News ( + dtd, pickle_message, -- * Tests news_tests, @@ -29,9 +29,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, @@ -55,10 +61,22 @@ import Text.XML.HXT.Core ( 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" -- @@ -67,10 +85,11 @@ import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable ) -- * News/Message --- | The msg_id child of contains an event_id attribute; we --- embed it into the 'News' type. We (pointlessly) use the "db_" --- prefix here so that the two names don't collide on "id" when +-- | The msg_id child of \ contains an event_id attribute; we +-- 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, @@ -78,7 +97,7 @@ data MsgId = deriving (Data, Eq, Show, Typeable) --- | The XML representation of a news item (message). +-- | The XML representation of a news item (\). -- data Message = Message { @@ -118,6 +137,7 @@ data News = instance ToDb Message where + -- | The database representation of 'Message' is 'News'. type Db Message = News -- | Convert the XML representation 'Message' to the database @@ -137,7 +157,7 @@ instance FromXml Message where 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 @@ -151,22 +171,6 @@ data NewsTeam = 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 @@ -191,21 +195,6 @@ data NewsLocation = 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 @@ -231,10 +220,10 @@ data News_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 @@ -245,7 +234,7 @@ instance DbImport Message where -- 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. @@ -253,7 +242,7 @@ instance DbImport Message where 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 @@ -289,7 +278,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: @@ -339,6 +327,7 @@ mkPersist tsn_codegen_config [groundhog| onDelete: cascade |] + -- -- XML Picklers -- @@ -447,6 +436,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 ] @@ -469,7 +459,14 @@ test_news_fields_have_correct_names = map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names actual :: [String] - actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"] + actual = ["xml_file_id", + "mid", + "sport", + "url", + "sms", + "editor", + "text", + "continue"] check (x,y) = (x @?= y) @@ -505,3 +502,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