X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=10c51956fa20c23a16ff45b3469bc477aac078a7;hb=9b28d5ed0e1570f0890eae1ee01721688c20e266;hp=86eed4a8682679abe61c5cc1751375fba1bc3316;hpb=b830faafac5d720a8eecae369806d9142a186485;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index 86eed4a..10c5195 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -11,14 +10,15 @@ -- a root element \ that contains an entire news item. -- module TSN.XML.News ( + dtd, + has_only_single_sms, pickle_message, -- * Tests news_tests, -- * WARNING: these are private but exported to silence warnings - News_NewsLocationConstructor(..), + News_LocationConstructor(..), News_NewsTeamConstructor(..), NewsConstructor(..), - NewsLocationConstructor(..), NewsTeamConstructor(..) ) where @@ -30,7 +30,7 @@ import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) import Database.Groundhog ( countAll, - executeRaw, + deleteAll, insert_, migrate, runMigration, @@ -46,6 +46,16 @@ import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, + XmlTree, + (/>), + (>>>), + addNav, + descendantAxis, + filterAxis, + followingSiblingAxis, + hasName, + remNav, + runLA, xp13Tuple, xpAttr, xpElem, @@ -54,7 +64,6 @@ import Text.XML.HXT.Core ( xpOption, xpPair, xpText, - xpTriple, xpWrap ) -- Local imports. @@ -64,24 +73,32 @@ import TSN.Codegen ( import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_time_stamp ) +import TSN.Location ( Location(..), pickle_location ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable, + unsafe_read_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 +-- | 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 = @@ -102,7 +119,7 @@ data Message = xml_sport :: String, xml_url :: Maybe String, xml_teams :: [NewsTeam], - xml_locations :: [NewsLocation], + xml_locations :: [Location], xml_sms :: String, xml_editor :: Maybe String, xml_text :: Maybe String, -- Text and continue seem to show up in pairs, @@ -158,7 +175,13 @@ instance XmlImport Message -- * NewsTeam --- | The database type for teams as they show up in the news. +-- | The database/XML type for teams as they show up in the news. We +-- can't reuse the representation from "TSN.Team" because they +-- require a team id. We wouldn't want to make the team ID optional +-- and then insert a team with no id, only to find the same team +-- later with an id and be unable to update the record. (We could +-- add the update logic, but it would be more trouble than it's +-- worth.) -- data NewsTeam = NewsTeam { team_name :: String } @@ -178,56 +201,72 @@ data News_NewsTeam = News_NewsTeam (DefaultKey NewsTeam) --- * NewsLocation +-- * News_Location --- | The database type for locations as they show up in the news. +-- | 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 NewsLocation = - NewsLocation { - city :: Maybe String, - state :: Maybe String, - country :: String } - deriving (Eq, Show) +data News_Location = News_Location + (DefaultKey News) + (DefaultKey Location) --- * 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. + +-- | 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. -- -data News_NewsLocation = News_NewsLocation - (DefaultKey News) - (DefaultKey NewsLocation) +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 -- --- Database code +-- * 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. +-- 'News_Location' join tables. -- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do + migrate (undefined :: Location) migrate (undefined :: News) migrate (undefined :: NewsTeam) migrate (undefined :: News_NewsTeam) - migrate (undefined :: NewsLocation) - migrate (undefined :: News_NewsLocation) + migrate (undefined :: News_Location) dbimport message = do -- Insert the message and acquire its primary key (unique ID) news_id <- insert_xml message - -- And insert each one into its own table. 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. + -- Now insert the teams. We use insert_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. nt_ids <- mapM insert_or_select (xml_teams message) -- Now that the teams have been inserted, create @@ -235,9 +274,9 @@ instance DbImport Message where let news_news_teams = map (News_NewsTeam news_id) nt_ids mapM_ insert_ news_news_teams - -- Do all of that over again for the NewsLocations. + -- Do all of that over again for the Locations. loc_ids <- mapM insert_or_select (xml_locations message) - let news_news_locations = map (News_NewsLocation news_id) loc_ids + let news_news_locations = map (News_Location news_id) loc_ids mapM_ insert_ news_news_locations return ImportSucceeded @@ -256,15 +295,6 @@ mkPersist defaultCodegenConfig [groundhog| type: constraint fields: [team_name] -- entity: NewsLocation - dbName: news_locations - constructors: - - name: NewsLocation - uniques: - - name: unique_news_location - type: constraint - fields: [city, state, country] - |] @@ -306,17 +336,17 @@ mkPersist tsn_codegen_config [groundhog| reference: onDelete: cascade -- entity: News_NewsLocation - dbName: news__news_locations +- entity: News_Location + dbName: news__locations constructors: - - name: News_NewsLocation + - name: News_Location fields: - - name: news_NewsLocation0 # Default created by mkNormalFieldName + - name: news_Location0 # Default created by mkNormalFieldName dbName: news_id reference: onDelete: cascade - - name: news_NewsLocation1 # Default created by mkNormalFieldName - dbName: news_locations_id + - name: news_Location1 # Default created by mkNormalFieldName + dbName: locations_id reference: onDelete: cascade |] @@ -352,20 +382,6 @@ pickle_msg_id = to_tuple m = (db_msg_id m, db_event_id m) --- | Convert a 'NewsLocation' to/from XML. --- -pickle_location :: PU NewsLocation -pickle_location = - xpElem "location" $ - xpWrap (from_tuple, to_tuple) $ - xpTriple (xpOption (xpElem "city" xpText)) - (xpOption (xpElem "state" xpText)) - (xpElem "country" xpText) - where - from_tuple = - uncurryN NewsLocation - to_tuple l = (city l, state l, country l) - -- | Convert a 'Message' to/from XML. -- @@ -432,7 +448,8 @@ news_tests = [ test_news_fields_have_correct_names, test_on_delete_cascade, test_pickle_of_unpickle_is_identity, - test_unpickle_succeeds ] + test_unpickle_succeeds, + test_sms_detected_correctly ] -- | Make sure our codegen is producing the correct database names. @@ -510,11 +527,11 @@ test_on_delete_cascade = testGroup "cascading delete tests" 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 + let a = undefined :: Location + let b = undefined :: News + let c = undefined :: NewsTeam + let d = undefined :: News_NewsTeam + let e = undefined :: News_Location actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigration silentMigrationLogger $ do migrate a @@ -523,8 +540,7 @@ test_on_delete_cascade = testGroup "cascading delete tests" migrate d migrate e _ <- dbimport news - -- No idea how 'delete' works, so do this instead. - executeRaw False "DELETE FROM news;" [] + deleteAll b count_a <- countAll a count_b <- countAll b count_c <- countAll c @@ -532,3 +548,22 @@ test_on_delete_cascade = testGroup "cascading delete tests" 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_document path + let actual = has_only_single_sms xmltree + actual @?= expected