X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=2cc9698fb2d2e212fd9d45da74f71d938eca3c90;hb=b8d151d034a338242ee1193638ff077614d10580;hp=b9bc3df4f84b98c58f369085868987d9cbecdbe3;hpb=71e4436c45b1694fbc550d5cfc2a0cde216610f6;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index b9bc3df..2cc9698 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -7,12 +7,13 @@ {-# 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 ( - news_tests, pickle_message, + -- * Tests + news_tests, -- * WARNING: these are private but exported to silence warnings News_NewsLocationConstructor(..), News_NewsTeamConstructor(..), @@ -23,13 +24,20 @@ where -- System imports. import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf ) +import Data.Time.Clock ( UTCTime ) import Data.List.Utils ( join, split ) 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, @@ -53,79 +61,29 @@ 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(..), pickle_unpickle, unpickleable ) - - +import Xml ( + FromXml(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) --- | The database type for teams as they show up in the news. --- -data NewsTeam = - NewsTeam { team_name :: String } - deriving (Eq, Show) --- | This is needed to define the XmlImport instance for NewsTeam; it --- basically says that the DB representation is the same as the XML --- representation. -- -instance FromXml NewsTeam where - type Db NewsTeam = NewsTeam - from_xml = id - --- | Allow us to call 'insert_xml' on the XML representation of --- NewsTeams. +-- DB/XML Data types -- -instance XmlImport NewsTeam - - --- | Mapping between News records and NewsTeam records in the --- database. We don't name the fields because we don't use the names --- explicitly; that means we have to give them nice database names --- via groundhog. --- -data News_NewsTeam = News_NewsTeam - (DefaultKey News) - (DefaultKey NewsTeam) - - --- | The database type for locations as they show up in the news. --- -data NewsLocation = - NewsLocation { - city :: Maybe String, - state :: Maybe String, - country :: String } - deriving (Eq, Show) - --- | This is needed to define the XmlImport instance for NewsLocation; it --- basically says that the DB representation is the same as the XML --- representation. --- -instance FromXml NewsLocation where - type Db NewsLocation = NewsLocation - from_xml = id - --- | Allow us to call 'insert_xml' on the XML representation of --- NewsLocations. --- -instance XmlImport NewsLocation - - --- | Mapping between News records and NewsLocation records in the --- database. We don't name the fields because we don't use the names --- explicitly; that means we have to give them nice database names --- via groundhog. --- -data News_NewsLocation = News_NewsLocation - (DefaultKey News) - (DefaultKey NewsLocation) +-- * 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 -- Groundhog is creating its fields using our field namer. +-- data MsgId = MsgId { db_msg_id :: Int, @@ -133,7 +91,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 { @@ -149,7 +107,7 @@ data Message = xml_editor :: Maybe String, xml_text :: Maybe String, -- Text and continue seem to show up in pairs, xml_continue :: Maybe String, -- either both present or both missing. - xml_time_stamp :: String } + xml_time_stamp :: UTCTime } deriving (Eq, Show) @@ -159,37 +117,96 @@ data Message = -- data News = News { + db_xml_file_id :: Int, db_mid :: MsgId, db_sport :: String, db_url :: Maybe String, db_sms :: String, db_editor :: Maybe String, db_text :: Maybe String, - db_continue :: Maybe String } + db_continue :: Maybe String, + db_time_stamp :: UTCTime } deriving (Data, Eq, Show, Typeable) + +instance ToDb Message where + -- | The database representation of 'Message' is 'News'. + type Db Message = News + -- | Convert the XML representation 'Message' to the database -- representation 'News'. -- instance FromXml Message where - type Db Message = News - -- | We use a record wildcard so GHC doesn't complain that we never -- used the field names. -- - from_xml Message{..} = News { db_mid = xml_mid, + from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id, + db_mid = xml_mid, db_sport = xml_sport, db_url = xml_url, db_sms = xml_sms, db_editor = xml_editor, db_text = xml_text, - db_continue = xml_continue } + 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 + +-- * NewsTeam + +-- | The database type for teams as they show up in the news. +-- +data NewsTeam = + NewsTeam { team_name :: String } + deriving (Eq, Show) + + + +-- * News_NewsTeam + +-- | Mapping between News records and NewsTeam records in the +-- database. We don't name the fields because we don't use the names +-- explicitly; that means we have to give them nice database names +-- via groundhog. +-- +data News_NewsTeam = News_NewsTeam + (DefaultKey News) + (DefaultKey NewsTeam) + + +-- * NewsLocation + +-- | The database type for locations as they show up in the news. +-- +data NewsLocation = + NewsLocation { + city :: Maybe String, + state :: Maybe String, + country :: String } + deriving (Eq, Show) + + +-- * News_NewsLocation + +-- | Mapping between News records and NewsLocation records in the +-- database. We don't name the fields because we don't use the names +-- explicitly; that means we have to give them nice database names +-- via groundhog. +-- +data News_NewsLocation = News_NewsLocation + (DefaultKey News) + (DefaultKey NewsLocation) + + + +-- +-- Database code +-- + -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is -- slightly non-generic because of our 'News_NewsTeam' and -- 'News_NewsLocation' join tables. @@ -197,10 +214,10 @@ instance XmlImport Message 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 @@ -211,7 +228,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. @@ -219,16 +236,16 @@ 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 return ImportSucceeded --- | These types don't have special XML representations or field name --- collisions so we use the defaultCodegenConfig and give their --- fields nice simple names. +-- These types don't have special XML representations or field name +-- collisions so we use the defaultCodegenConfig and give their +-- fields nice simple names. mkPersist defaultCodegenConfig [groundhog| - entity: NewsTeam dbName: news_teams @@ -251,19 +268,24 @@ mkPersist defaultCodegenConfig [groundhog| |] --- | These types have fields with e.g. db_ and xml_ prefixes, so we --- use our own codegen to peel those off before naming the columns. --- +-- These types have fields with e.g. db_ and xml_ prefixes, so we +-- 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: + - name: unique_news + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] fields: - name: db_mid embeddedType: - {name: msg_id, dbName: msg_id} - {name: event_id, dbName: event_id} + - embedded: MsgId fields: - name: db_msg_id @@ -271,7 +293,6 @@ mkPersist tsn_codegen_config [groundhog| - name: db_event_id dbName: event_id - - entity: News_NewsTeam dbName: news__news_teams constructors: @@ -279,8 +300,12 @@ mkPersist tsn_codegen_config [groundhog| fields: - name: news_NewsTeam0 # Default created by mkNormalFieldName dbName: news_id + reference: + onDelete: cascade - name: news_NewsTeam1 # Default created by mkNormalFieldName dbName: news_teams_id + reference: + onDelete: cascade - entity: News_NewsLocation dbName: news__news_locations @@ -289,11 +314,19 @@ mkPersist tsn_codegen_config [groundhog| fields: - name: news_NewsLocation0 # Default created by mkNormalFieldName dbName: news_id + reference: + onDelete: cascade - name: news_NewsLocation1 # Default created by mkNormalFieldName dbName: news_locations_id + reference: + onDelete: cascade |] +-- +-- XML Picklers +-- + -- | Convert a 'NewsTeam' to/from XML. -- pickle_news_team :: PU NewsTeam @@ -353,7 +386,7 @@ pickle_message = (xpOption (xpElem "Editor" xpText)) (xpOption (xpElem "text" xpText)) pickle_continue - (xpElem "time_stamp" xpText) + (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message to_tuple m = (xml_xml_file_id m, -- Verbose, @@ -387,17 +420,24 @@ pickle_message = to_string = join "\n" +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- news_tests :: TestTree news_tests = testGroup "News tests" [ test_news_fields_have_correct_names, + test_on_delete_cascade, test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] +-- | Make sure our codegen is producing the correct database names. +-- test_news_fields_have_correct_names :: TestTree test_news_fields_have_correct_names = testCase "news fields get correct database names" $ @@ -414,13 +454,22 @@ 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) --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: success of this +-- test does not mean that unpickling succeeded. +-- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" @@ -434,6 +483,8 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" @@ -446,3 +497,39 @@ 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" ] + where + check desc path = 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 + -- There are 2 news_teams and 2 news_locations that should remain. + let expected = 4 + actual @?= expected