X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=54169b982b00d278717d89e2a1042bde14cc6faf;hb=f0425854304197ab5ad47293b27b2e0b188cb844;hp=913477168540ea47e178adca60e0d1b21bd2165e;hpb=0fa2d93c7fe436038e0f2b14d68b9e3cc3e165f7;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index 9134771..54169b9 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -11,15 +12,14 @@ -- 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_NewsTeamConstructor(..), - NewsConstructor(..), - NewsLocationConstructor(..), - NewsTeamConstructor(..) ) + News_LocationConstructor(..), + News_TeamConstructor(..), + NewsConstructor(..) ) where -- System imports. @@ -28,24 +28,33 @@ 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 ( countAll, deleteAll, insert_, - migrate, - runMigration, - silentMigrationLogger ) + migrate ) import Database.Groundhog.Core ( DefaultKey ) -import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( - defaultCodegenConfig, 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, + XmlTree, + (/>), + (>>>), + addNav, + descendantAxis, + filterAxis, + followingSiblingAxis, + hasName, + remNav, + runLA, xp13Tuple, xpAttr, xpElem, @@ -54,7 +63,6 @@ import Text.XML.HXT.Core ( xpOption, xpPair, xpText, - xpTriple, xpWrap ) -- Local imports. @@ -63,13 +71,16 @@ import TSN.Codegen ( 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.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 ) @@ -90,11 +101,17 @@ dtd = "newsxml.dtd" -- 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 -- | The XML representation of a news item (\). @@ -107,14 +124,19 @@ data Message = xml_category :: String, xml_sport :: String, xml_url :: Maybe String, - xml_teams :: [NewsTeam], - xml_locations :: [NewsLocation], - xml_sms :: String, + xml_teams :: [NewsTeamXml], + 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, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector Message -- | The database representation of a news item. We drop several @@ -127,7 +149,7 @@ data News = db_mid :: MsgId, db_sport :: String, db_url :: Maybe String, - db_sms :: String, + db_sms :: Maybe String, db_editor :: Maybe String, db_text :: Maybe String, db_continue :: Maybe String, @@ -147,6 +169,8 @@ 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, @@ -162,117 +186,132 @@ instance FromXml Message where instance XmlImport Message --- * NewsTeam +-- * NewsTeamXml --- | The database type for teams as they show up in the news. +-- | 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 NewsTeam = - NewsTeam { team_name :: String } - deriving (Eq, Show) +data NewsTeamXml = + NewsTeamXml { xml_team_id :: String, + xml_team_name :: String } + deriving (Eq, GHC.Generic, Show) +-- | For 'H.convert'. +-- +instance H.HVector NewsTeamXml --- * 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. +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'. -- -data News_NewsTeam = News_NewsTeam - (DefaultKey News) - (DefaultKey NewsTeam) +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 --- * NewsLocation +-- * News_Team --- | The database type for locations as they show up in the news. +-- | 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 NewsLocation = - NewsLocation { - city :: Maybe String, - state :: Maybe String, - country :: String } - deriving (Eq, Show) +data News_Team = News_Team (DefaultKey News) (DefaultKey Team) --- * News_NewsLocation +-- * News_Location --- | Mapping between News records and NewsLocation records in the +-- | 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_NewsLocation = News_NewsLocation - (DefaultKey News) - (DefaultKey NewsLocation) +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 -- --- 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. +-- 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 :: NewsTeam) - migrate (undefined :: News_NewsTeam) - migrate (undefined :: NewsLocation) - migrate (undefined :: News_NewsLocation) + 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 - -- 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. - nt_ids <- mapM insert_or_select (xml_teams 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__news_team records mapping beween the two. - let news_news_teams = map (News_NewsTeam news_id) nt_ids - mapM_ insert_ news_news_teams + -- news__team records mapping beween the two. + let news_teams = map (News_Team news_id) team_ids + mapM_ insert_ 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 --- 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 - constructors: - - name: NewsTeam - uniques: - - name: unique_news_team - type: constraint - fields: [team_name] - -- entity: NewsLocation - dbName: news_locations - constructors: - - name: NewsLocation - uniques: - - name: unique_news_location - type: constraint - fields: [city, state, country] - -|] - -- 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. @@ -293,36 +332,36 @@ mkPersist tsn_codegen_config [groundhog| - 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_NewsTeam - dbName: news__news_teams +- entity: News_Team + dbName: news__teams constructors: - - name: News_NewsTeam + - name: News_Team fields: - - name: news_NewsTeam0 # Default created by mkNormalFieldName + - name: news_Team0 # Default created by mkNormalFieldName dbName: news_id reference: onDelete: cascade - - name: news_NewsTeam1 # Default created by mkNormalFieldName - dbName: news_teams_id + - name: news_Team1 # Default created by mkNormalFieldName + dbName: teams_id 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 |] @@ -332,18 +371,16 @@ mkPersist tsn_codegen_config [groundhog| -- XML Picklers -- --- | Convert a 'NewsTeam' to/from XML. +-- | Convert a 'NewsTeamXml' to/from XML. -- -pickle_news_team :: PU NewsTeam +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 :: NewsTeam -> String - to_string = team_name - - from_string :: String -> NewsTeam - from_string = NewsTeam + from_tuple = uncurry NewsTeamXml -- | Convert a 'MsgId' to/from XML. @@ -351,34 +388,19 @@ pickle_news_team = pickle_msg_id :: PU MsgId pickle_msg_id = xpElem "msg_id" $ - xpWrap (from_tuple, to_tuple) $ - xpPair xpInt (xpAttr "EventId" (xpOption xpInt)) + 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) --- | 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. -- pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp13Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) pickle_msg_id @@ -387,26 +409,14 @@ pickle_message = (xpElem "url" $ xpOption xpText) (xpList pickle_news_team) (xpList pickle_location) - (xpElem "SMS" xpText) + (xpElem "SMS" $ xpOption xpText) (xpOption (xpElem "Editor" xpText)) (xpOption (xpElem "text" xpText)) pickle_continue (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, -- Verbose, - xml_heading m, -- but - xml_mid m, -- eliminates - xml_category m, -- GHC - xml_sport m, -- warnings - xml_url m, -- . - xml_teams m, -- . - xml_locations m, -- . - xml_sms m, - xml_editor m, - xml_text m, - xml_continue m, - xml_time_stamp m) + -- | We combine all of the \ elements into one 'String' -- while unpickling and do the reverse while pickling. @@ -438,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. @@ -481,7 +492,10 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" "test/xml/newsxml.xml", check "pickle composed with unpickle is the identity (with Editor)" - "test/xml/newsxml-with-editor.xml" ] + "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 @@ -496,7 +510,10 @@ test_unpickle_succeeds = testGroup "unpickle tests" "test/xml/newsxml.xml", check "unpickling succeeds (with Editor)" - "test/xml/newsxml-with-editor.xml" ] + "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 @@ -512,24 +529,28 @@ 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 :: 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 :: Team + let d = undefined :: News_Team + let e = undefined :: News_Location actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do + runMigrationSilent $ do migrate a migrate b migrate c migrate d migrate e _ <- dbimport news - deleteAll a + deleteAll b count_a <- countAll a count_b <- countAll b count_c <- countAll c @@ -537,3 +558,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_invalid_document path + let actual = has_only_single_sms xmltree + actual @?= expected