X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=54169b982b00d278717d89e2a1042bde14cc6faf;hb=f0425854304197ab5ad47293b27b2e0b188cb844;hp=550f26c44b77b52b61d36528b142d01fea02891e;hpb=0e37f70a58d512858b38e1458c6d83bc1727269c;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index 550f26c..54169b9 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -1,300 +1,432 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# 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 ( - Message, - news_tests ) + dtd, + has_only_single_sms, + pickle_message, + -- * Tests + news_tests, + -- * WARNING: these are private but exported to silence warnings + News_LocationConstructor(..), + News_TeamConstructor(..), + NewsConstructor(..) ) where -import Control.Monad.IO.Class ( MonadIO, liftIO ) +-- 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 qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( - defaultMigrationLogger, - insert, - migrate, - runMigration ) + countAll, + deleteAll, + insert_, + migrate ) import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, - XmlPickler(..), - unpickleDoc, - xp12Tuple, + XmlTree, + (/>), + (>>>), + addNav, + descendantAxis, + filterAxis, + followingSiblingAxis, + hasName, + remNav, + runLA, + xp13Tuple, xpAttr, xpElem, + xpInt, xpList, xpOption, xpPair, - xpPrim, xpText, - xpTriple, xpWrap ) -import Network.Services.TSN.Report ( report_error ) +-- Local imports. import TSN.Codegen ( tsn_codegen_config, - tsn_db_field_namer -- Used in a test. - ) -import TSN.DbImport ( DbImport(..) ) -import Xml ( ToFromXml(..), pickle_unpickle ) - - - --- | The database type for teams as they show up in the news. We need --- this separate from its XML representation because of the --- DefaultKey pointing to a message. We don't know how to create one --- of those unless we've just inserted a message into the database, --- so it screws up pickling. -data NewsTeam = - NewsTeam { - nt_news_id :: DefaultKey Message, -- ^ foreign key. - db_team_name :: String } -deriving instance Eq NewsTeam -- Standalone instances necessary for -deriving instance Show NewsTeam -- Groundhog types with DefaultKeys - --- | The XML type for teams as they show up in the news. See --- 'NewsTeam' for why there are two types. -data NewsTeamXml = - NewsTeamXml { - xml_team_name :: String } - deriving (Eq, Show) - --- | Specify how to convert between the two representations NewsTeam --- (database) and NewsTeamXml (XML). -instance ToFromXml NewsTeam where - type Xml NewsTeam = NewsTeamXml - type Container NewsTeam = Message - -- Use a record wildcard here so GHC doesn't complain that we never - -- used our named fields. - to_xml (NewsTeam {..}) = NewsTeamXml db_team_name - -- We can't create a DefaultKey Message... - from_xml = error "Called from_xml on a NewsTeam." - -- unless we're handed one. - from_xml_fk key = (NewsTeam key) . xml_team_name - - --- | The database type for locations as they show up in the news. We --- need this separate from its XML representation because of the --- DefaultKey pointing to a message. We don't know how to create one --- of those unless we've just inserted a message into the database, --- so it screws up pickling. -data NewsLocation = - NewsLocation { - loc_news_id :: DefaultKey Message, -- ^ foreign key. - db_city ::String, - db_state :: String, - db_country :: String } -deriving instance Eq NewsLocation -- Standalone instances necessary for -deriving instance Show NewsLocation -- Groundhog types with DefaultKeys - --- | The XML type for locations as they show up in the news. See --- 'NewsLocation' for why there are two types. -data NewsLocationXml = - NewsLocationXml { - xml_city :: String, - xml_state :: String, - xml_country :: String } - deriving (Eq, Show) - - --- | Specify how to convert between the two representations --- NewsLocation (database) and NewsLocationXml (XML). -instance ToFromXml NewsLocation where - type Xml NewsLocation = NewsLocationXml - type Container NewsLocation = Message - -- Use a record wildcard here so GHC doesn't complain that we never - -- used our named fields. - to_xml (NewsLocation {..}) = NewsLocationXml db_city db_state db_country - -- We can't create a DefaultKey Message... - from_xml = error "Called from_xml on a NewsLocation." - -- unless we're given one. - from_xml_fk key (NewsLocationXml x y z) = NewsLocation key x y z - - --- | The msg_id child of contains an event_id attribute; we --- embed it into the 'Message' type. We (pointlessly) use the "db_" --- prefix here so that the two names collide on "id" when Groundhog --- is creating its fields using our field namer. + tsn_db_field_namer ) -- Used in a test +import TSN.Database ( insert_or_select ) +import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) +import TSN.Location ( Location(..), pickle_location ) +import TSN.Picklers ( xp_attr_option, xp_time_stamp ) +import TSN.Team ( Team(..) ) +import TSN.XmlImport ( XmlImport(..) ) +import Xml ( + FromXml(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_read_invalid_document, + unsafe_unpickle ) + + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "newsxml.dtd" + + +-- +-- DB/XML Data types +-- + +-- * 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. +-- +-- The leading underscores prevent unused field warnings. +-- data MsgId = MsgId { - db_msg_id :: Int, - db_event_id :: Maybe Int } - deriving (Data, Eq, Show, Typeable) + _db_msg_id :: Int, + _db_event_id :: Maybe Int } + deriving (Data, Eq, GHC.Generic, Show, Typeable) +-- | For 'H.convert'. +-- +instance H.HVector MsgId -data MessageXml = - MessageXml { + +-- | The XML representation of a news item (\). +-- +data Message = + Message { xml_xml_file_id :: Int, xml_heading :: String, xml_mid :: MsgId, xml_category :: String, xml_sport :: String, - xml_url :: String, + xml_url :: Maybe String, xml_teams :: [NewsTeamXml], - xml_locations :: [NewsLocationXml], - xml_sms :: String, - xml_text :: String, - xml_continue :: String, - xml_time_stamp :: String } - deriving (Eq, Show) + xml_locations :: [Location], + xml_sms :: Maybe String, + 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 :: UTCTime } + deriving (Eq, GHC.Generic, Show) -data Message = - Message { + +-- | For 'H.convert'. +-- +instance H.HVector Message + + +-- | The database representation of a news item. We drop several +-- uninteresting fields from 'Message', and omit the list fields which +-- will be represented as join tables. +-- +data News = + News { + db_xml_file_id :: Int, db_mid :: MsgId, db_sport :: String, - db_url :: String, - db_sms :: String, - db_text :: String, - db_continue :: String } + db_url :: Maybe String, + db_sms :: Maybe String, + db_editor :: Maybe String, + db_text :: Maybe String, + db_continue :: Maybe String, + db_time_stamp :: UTCTime } deriving (Data, Eq, Show, Typeable) -instance ToFromXml Message where - type Xml Message = MessageXml - type Container Message = () - - -- Use a record wildcard here so GHC doesn't complain that we never - -- used our named fields. - to_xml (Message {..}) = - MessageXml - 0 - "" - db_mid - "" - db_sport - db_url - [] - [] - db_sms - db_text - db_continue - "" - - -- We don't need the key argument (from_xml_fk) since the XML type - -- contains more information in this case. - from_xml (MessageXml _ _ c _ e f _ _ g h i _) = - Message c e f g h i -mkPersist tsn_codegen_config [groundhog| -- entity: NewsTeam - dbName: news_teams +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 + -- | We use a record wildcard so GHC doesn't complain that we never + -- used the field names. + -- + -- To convert, we drop some fields. + -- + 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_time_stamp = xml_time_stamp } + +-- | This lets us insert the XML representation 'Message' directly. +-- +instance XmlImport Message + + +-- * NewsTeamXml + +-- | The XML type for teams as they show up in the news. We can't +-- reuse the representation from "TSN.Team" because our name doesn't +-- appear optional and we have no abbreviation. +-- +data NewsTeamXml = + NewsTeamXml { xml_team_id :: String, + xml_team_name :: String } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector NewsTeamXml + + +instance ToDb NewsTeamXml where + -- | The database representation of 'NewsTeamXml' is 'Team'. + type Db NewsTeamXml = Team + +-- | Convert the XML representation 'NewsTeamXml' to the database +-- representation 'Team'. +-- +instance FromXml NewsTeamXml where + from_xml NewsTeamXml{..} = + Team { team_id = xml_team_id, + abbreviation = Nothing, + name = Just xml_team_name } + +-- | Allow us to import 'NewsTeamXml' directly. +-- +instance XmlImport NewsTeamXml + + +-- * News_Team + +-- | Mapping between News records and Team 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_Team = News_Team (DefaultKey News) (DefaultKey Team) + + +-- * News_Location + +-- | Mapping between 'News' records and 'Location' 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_Location = News_Location + (DefaultKey News) + (DefaultKey Location) + + + + +-- | Some newsxml documents contain two \ elements in a row, +-- violating the DTD. The second one has always been empty, but it's +-- irrelevant: we can't parse these, and would like to detect them +-- in order to report the fact that the busted document is +-- unsupported. +-- +-- This function detects whether two \ elements appear in a +-- row, as siblings. +-- +has_only_single_sms :: XmlTree -> Bool +has_only_single_sms xmltree = + case elements of + [] -> True + _ -> False + where + parse :: XmlTree -> [XmlTree] + parse = runLA $ hasName "/" + /> hasName "message" + >>> addNav + >>> descendantAxis + >>> filterAxis (hasName "SMS") + >>> followingSiblingAxis + >>> remNav + >>> hasName "SMS" + + elements = parse xmltree + -- entity: NewsLocation - dbName: news_locations +-- +-- * Database code +-- + +-- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is +-- slightly non-generic because of our 'News_Team' and +-- 'News_Location' join tables. +-- +instance DbImport Message where + dbmigrate _ = + run_dbmigrate $ do + migrate (undefined :: Location) + migrate (undefined :: News) + migrate (undefined :: Team) + migrate (undefined :: News_Team) + migrate (undefined :: News_Location) + + dbimport message = do + -- Insert the message and acquire its primary key (unique ID) + news_id <- insert_xml message + + -- Now insert the teams. We use insert_xml_or_select 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. + team_ids <- mapM insert_xml_or_select (xml_teams message) + + -- Now that the teams have been inserted, create + -- news__team records mapping beween the two. + let news_teams = map (News_Team news_id) team_ids + mapM_ insert_ news_teams -- entity: Message - dbName: news + -- Do all of that over again for the Locations. + loc_ids <- mapM insert_or_select (xml_locations message) + let news_news_locations = map (News_Location news_id) loc_ids + mapM_ insert_ news_news_locations + + return ImportSucceeded + + + +-- 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 constructors: - - name: Message + - 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 + - name: _db_msg_id dbName: msg_id - - name: db_event_id + - name: _db_event_id dbName: event_id + +- entity: News_Team + dbName: news__teams + constructors: + - name: News_Team + fields: + - name: news_Team0 # Default created by mkNormalFieldName + dbName: news_id + reference: + onDelete: cascade + - name: news_Team1 # Default created by mkNormalFieldName + dbName: teams_id + reference: + onDelete: cascade + +- entity: News_Location + dbName: news__locations + constructors: + - name: News_Location + fields: + - name: news_Location0 # Default created by mkNormalFieldName + dbName: news_id + reference: + onDelete: cascade + - name: news_Location1 # Default created by mkNormalFieldName + dbName: locations_id + reference: + onDelete: cascade |] + +-- +-- XML Picklers +-- + +-- | Convert a 'NewsTeamXml' to/from XML. +-- pickle_news_team :: PU NewsTeamXml pickle_news_team = xpElem "team" $ - xpWrap (from_string, to_string) xpText + xpWrap (from_tuple, H.convert) $ + xpPair (xpAttr "id" xpText) + xpText -- team name where - to_string :: NewsTeamXml -> String - to_string = xml_team_name + from_tuple = uncurry NewsTeamXml - from_string :: String -> NewsTeamXml - from_string = NewsTeamXml - -instance XmlPickler NewsTeamXml where - xpickle = pickle_news_team +-- | Convert a 'MsgId' to/from XML. +-- pickle_msg_id :: PU MsgId pickle_msg_id = xpElem "msg_id" $ - xpWrap (from_tuple, to_tuple) $ - xpPair xpPrim (xpAttr "EventId" (xpOption xpPrim)) + xpWrap (from_tuple, H.convert) $ + xpPair xpInt (xpAttr "EventId" xp_attr_option) where from_tuple = uncurryN MsgId - to_tuple m = (db_msg_id m, db_event_id m) - -instance XmlPickler MsgId where - xpickle = pickle_msg_id - -pickle_location :: PU NewsLocationXml -pickle_location = - xpElem "location" $ - xpWrap (from_tuple, to_tuple) $ - xpTriple (xpElem "city" xpText) - (xpElem "state" xpText) - (xpElem "country" xpText) - where - from_tuple = - uncurryN NewsLocationXml - to_tuple l = (xml_city l, xml_state l, xml_country l) -instance XmlPickler NewsLocationXml where - xpickle = pickle_location -pickle_message :: PU MessageXml +-- | Convert a 'Message' to/from XML. +-- +pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ - xp12Tuple (xpElem "XML_File_ID" xpPrim) + xpWrap (from_tuple, H.convert) $ + xp13Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) pickle_msg_id (xpElem "category" xpText) (xpElem "sport" xpText) - (xpElem "url" xpText) - (xpList $ pickle_news_team) - (xpList $ pickle_location) - (xpElem "SMS" xpText) - (xpElem "text" xpText) + (xpElem "url" $ xpOption xpText) + (xpList pickle_news_team) + (xpList pickle_location) + (xpElem "SMS" $ xpOption xpText) + (xpOption (xpElem "Editor" xpText)) + (xpOption (xpElem "text" xpText)) pickle_continue - (xpElem "time_stamp" xpText) + (xpElem "time_stamp" xp_time_stamp) where - from_tuple = uncurryN MessageXml - to_tuple m = (xml_xml_file_id m, - xml_heading m, - xml_mid m, - xml_category m, - xml_sport m, - xml_url m, - xml_teams m, - xml_locations m, - xml_sms m, - xml_text m, - xml_continue m, - xml_time_stamp m) - - pickle_continue :: PU String + from_tuple = uncurryN Message + + + -- | We combine all of the \ elements into one 'String' + -- while unpickling and do the reverse while pickling. + -- + pickle_continue :: PU (Maybe String) pickle_continue = - xpWrap (to_string, from_string) $ - xpElem "continue" $ - (xpList $ xpElem "P" xpText) + xpOption $ + xpWrap (to_string, from_string) $ + xpElem "continue" $ + xpList (xpElem "P" xpText) where from_string :: String -> [String] from_string = split "\n" @@ -302,68 +434,146 @@ pickle_message = to_string :: [String] -> String to_string = join "\n" -instance XmlPickler MessageXml where - xpickle = pickle_message - +-- +-- Tasty Tests +-- -instance DbImport Message where - dbimport _ xml = do - runMigration defaultMigrationLogger $ do - migrate (undefined :: Message) - migrate (undefined :: NewsTeam) - migrate (undefined :: NewsLocation) - let root_element = unpickleDoc xpickle xml :: Maybe MessageXml - case root_element of - Nothing -> do - let errmsg = "Could not unpickle News message in dbimport." - liftIO $ report_error errmsg - return Nothing - Just message -> do - news_id <- insert (from_xml message :: Message) - let nts :: [NewsTeam] = map (from_xml_fk news_id) - (xml_teams message) - let nlocs :: [NewsLocation] = map (from_xml_fk news_id) - (xml_locations message) - nt_ids <- mapM insert nts - loc_ids <- mapM insert nlocs - - return $ Just (1 + (length nt_ids) + (length loc_ids)) - - --- * 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_pickle_of_unpickle_is_identity ] - - -test_pickle_of_unpickle_is_identity :: TestTree -test_pickle_of_unpickle_is_identity = - testCase "pickle composed with unpickle is the identity" $ do - let path = "test/xml/newsxml.xml" - (expected :: [MessageXml], actual) <- pickle_unpickle "message" path - actual @?= expected + test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, + test_unpickle_succeeds, + test_sms_detected_correctly ] +-- | 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" $ do + testCase "news fields get correct database names" $ mapM_ check (zip actual expected) where -- This is cool, it uses the (derived) Data instance of - -- News.Message to get its constructor names. + -- News.News to get its constructor names. field_names :: [String] field_names = - constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: Message) + constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News) expected :: [String] expected = map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names actual :: [String] - actual = ["mid", "sport", "url", "sms", "text", "continue"] + actual = ["xml_file_id", + "mid", + "sport", + "url", + "sms", + "editor", + "text", + "continue"] check (x,y) = (x @?= y) + + +-- | 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" + "test/xml/newsxml.xml", + + check "pickle composed with unpickle is the identity (with Editor)" + "test/xml/newsxml-with-editor.xml", + + check "pickle composed with unpickle is the identity (empty SMS)" + "test/xml/newsxml-empty-sms.xml" ] + where + check desc path = testCase desc $ do + (expected, actual) <- pickle_unpickle pickle_message path + actual @?= expected + + +-- | Make sure we can actually unpickle these things. +-- +test_unpickle_succeeds :: TestTree +test_unpickle_succeeds = testGroup "unpickle tests" + [ check "unpickling succeeds" + "test/xml/newsxml.xml", + + check "unpickling succeeds (with Editor)" + "test/xml/newsxml-with-editor.xml", + + check "unpickling succeeds (empty SMS)" + "test/xml/newsxml-empty-sms.xml" ] + where + check desc path = testCase desc $ do + 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. + , + check "deleting news deletes its children (empty SMS)" + "test/xml/newsxml-empty-sms.xml" + 4 -- 2 news_teams and 2 news_locations + ] + where + check desc path expected = testCase desc $ do + news <- unsafe_unpickle path pickle_message + let a = undefined :: Location + let b = undefined :: News + let c = undefined :: Team + let d = undefined :: News_Team + let e = undefined :: News_Location + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigrationSilent $ do + migrate a + migrate b + migrate c + migrate d + migrate e + _ <- dbimport news + deleteAll b + 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 + + +-- | We want to make sure the single-SMS documents and the multi-SMS +-- documents are identified correctly. +-- +test_sms_detected_correctly :: TestTree +test_sms_detected_correctly = + testGroup "newsxml SMS count determined correctly" + [ check "test/xml/newsxml.xml" + "single SMS detected correctly" + True, + check "test/xml/newsxml-multiple-sms.xml" + "multiple SMS detected correctly" + False ] + where + check path desc expected = testCase desc $ do + xmltree <- unsafe_read_invalid_document path + let actual = has_only_single_sms xmltree + actual @?= expected