From 44e32bf7b5aa2d0b98b40f25ec650d9b3e0f01ca Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Thu, 9 Jan 2014 23:15:45 -0500 Subject: [PATCH] Make NewsTeams and NewsLocations unique. Create join tables between "news", "news_locations", and "news_teams". Rename the non-XML version of News.Message to "News". --- src/Main.hs | 4 +- src/TSN/XML/News.hs | 245 +++++++++++++++++++++++--------------------- 2 files changed, 129 insertions(+), 120 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0a41318..74f5259 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -45,7 +45,7 @@ import TSN.DbImport ( DbImport(..), ImportResult(..) ) import qualified TSN.XML.Heartbeat as Heartbeat ( verify ) import qualified TSN.XML.Injuries as Injuries ( Listing ) import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( PlayerListing ) -import qualified TSN.XML.News as News ( Message ) +import qualified TSN.XML.News as News ( News ) import qualified TSN.XML.Odds as Odds ( Message ) import Xml ( DtdName(..), parse_opts ) @@ -153,7 +153,7 @@ import_file cfg path = do dbimport (undefined :: InjuriesDetail.PlayerListing) | dtd == "newsxml.dtd" = - dbimport (undefined :: News.Message) + dbimport (undefined :: News.News) | dtd == "Odds_XML.dtd" = undefined diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index 565c7a5..2d081aa 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -13,7 +13,7 @@ -- root element \ that contains an entire news item. -- module TSN.XML.News ( - Message, + News, news_tests ) where @@ -24,10 +24,12 @@ import Data.Typeable ( Typeable ) import Database.Groundhog ( defaultMigrationLogger, insert, + insertByAll, migrate, runMigration ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.TH ( + defaultCodegenConfig, groundhog, mkPersist ) import System.Console.CmdArgs.Default ( Default(..) ) @@ -56,79 +58,38 @@ import Xml ( ToFromXml(..), pickle_unpickle, unpickleable ) --- | 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. +-- | The database type for teams as they show up in the news. 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 } + NewsTeam { 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. +-- | Mapping between News records and NewsTeam records in the +-- database. We name the fields (even though they're never used) for +-- Groundhog's benefit. +data News_NewsTeam = + News_NewsTeam { + nnt_news_id :: DefaultKey News, + nnt_news_team_id :: DefaultKey NewsTeam } + +-- | The database type for locations as they show up in the news. 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 } + city :: Maybe String, + state :: Maybe String, + 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 +-- | Mapping between News records and NewsLocation records in the +-- database. We name the fields (even though they're never used) for +-- Groundhog's benefit. +data News_NewsLocation = + News_NewsLocation { + nnl_news_id :: DefaultKey News, + nnl_news_location_id :: DefaultKey NewsLocation } -- | The msg_id child of contains an event_id attribute; we --- embed it into the 'Message' type. We (pointlessly) use the "db_" +-- embed it into the 'News' 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. data MsgId = @@ -138,42 +99,42 @@ data MsgId = deriving (Data, Eq, Show, Typeable) -data MessageXml = - MessageXml { +data Message = + Message { xml_xml_file_id :: Int, xml_heading :: String, xml_mid :: MsgId, xml_category :: String, xml_sport :: String, xml_url :: String, - xml_teams :: [NewsTeamXml], - xml_locations :: [NewsLocationXml], + xml_teams :: [NewsTeam], + xml_locations :: [NewsLocation], xml_sms :: String, xml_editor :: Maybe String, - xml_text :: String, - xml_continue :: 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 } deriving (Eq, Show) -data Message = - Message { +data News = + News { db_mid :: MsgId, db_sport :: String, db_url :: String, db_sms :: String, db_editor :: Maybe String, - db_text :: String, - db_continue :: String } + db_text :: Maybe String, + db_continue :: Maybe String } deriving (Data, Eq, Show, Typeable) -instance ToFromXml Message where - type Xml Message = MessageXml - type Container Message = () +instance ToFromXml News where + type Xml News = Message + type Container News = () -- Use a record wildcard here so GHC doesn't complain that we never -- used our named fields. - to_xml (Message {..}) = - MessageXml + to_xml (News {..}) = + Message def def db_mid @@ -190,21 +151,39 @@ instance ToFromXml Message where -- 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 _ _ i j k l _) = - Message c e f i j k l + from_xml (Message _ _ c _ e f _ _ i j k l _) = + News c e f i j k l -mkPersist tsn_codegen_config [groundhog| +-- 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] + +|] -- entity: Message +mkPersist tsn_codegen_config [groundhog| +- entity: News dbName: news constructors: - - name: Message + - name: News fields: - name: db_mid embeddedType: @@ -216,20 +195,27 @@ mkPersist tsn_codegen_config [groundhog| dbName: msg_id - name: db_event_id dbName: event_id + + +- entity: News_NewsTeam + dbName: news__news_teams + +- entity: News_NewsLocation + dbName: news__news_locations |] -pickle_news_team :: PU NewsTeamXml +pickle_news_team :: PU NewsTeam pickle_news_team = xpElem "team" $ xpWrap (from_string, to_string) xpText where - to_string :: NewsTeamXml -> String - to_string = xml_team_name + to_string :: NewsTeam -> String + to_string = team_name - from_string :: String -> NewsTeamXml - from_string = NewsTeamXml + from_string :: String -> NewsTeam + from_string = NewsTeam -instance XmlPickler NewsTeamXml where +instance XmlPickler NewsTeam where xpickle = pickle_news_team pickle_msg_id :: PU MsgId @@ -244,23 +230,23 @@ pickle_msg_id = instance XmlPickler MsgId where xpickle = pickle_msg_id -pickle_location :: PU NewsLocationXml +pickle_location :: PU NewsLocation pickle_location = xpElem "location" $ xpWrap (from_tuple, to_tuple) $ - xpTriple (xpElem "city" xpText) - (xpElem "state" xpText) + xpTriple (xpOption (xpElem "city" xpText)) + (xpOption (xpElem "state" xpText)) (xpElem "country" xpText) where from_tuple = - uncurryN NewsLocationXml - to_tuple l = (xml_city l, xml_state l, xml_country l) + uncurryN NewsLocation + to_tuple l = (city l, state l, country l) -instance XmlPickler NewsLocationXml where +instance XmlPickler NewsLocation where xpickle = pickle_location -pickle_message :: PU MessageXml +pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ @@ -274,11 +260,11 @@ pickle_message = (xpList pickle_location) (xpElem "SMS" xpText) (xpOption (xpElem "Editor" xpText)) - (xpElem "text" xpText) + (xpOption (xpElem "text" xpText)) pickle_continue (xpElem "time_stamp" xpText) where - from_tuple = uncurryN MessageXml + from_tuple = uncurryN Message to_tuple m = (xml_xml_file_id m, xml_heading m, xml_mid m, @@ -293,11 +279,12 @@ pickle_message = xml_continue m, xml_time_stamp m) - pickle_continue :: PU String + 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" @@ -305,32 +292,54 @@ pickle_message = to_string :: [String] -> String to_string = join "\n" -instance XmlPickler MessageXml where +instance XmlPickler Message where xpickle = pickle_message -instance DbImport Message where +instance DbImport News where dbimport _ xml = do runMigration defaultMigrationLogger $ do - migrate (undefined :: Message) + migrate (undefined :: News) migrate (undefined :: NewsTeam) migrate (undefined :: NewsLocation) - let root_element = unpickleDoc xpickle xml :: Maybe MessageXml + migrate (undefined :: News_NewsTeam) + migrate (undefined :: News_NewsLocation) + let root_element = unpickleDoc xpickle xml :: Maybe Message case root_element of Nothing -> do let errmsg = "Could not unpickle News message in dbimport." return $ ImportFailed errmsg 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 + -- Insert the message and acquire its primary key (unique ID) + news_id <- insert (from_xml message :: News) + + -- And insert each one into its own table. We use insertByAll + -- because we know that most teams will already exist, and we + -- want to get back a Left (id) for the existing team when + -- there's a collision. In fact, if the insert succeeds, we'll + -- get a Right (id) back, so we can disregard the Either + -- constructor entirely. That's what the (either id id) does. + either_nt_ids <- mapM insertByAll (xml_teams message) + let nt_ids = map (either id id) either_nt_ids + + -- 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 + nnt_ids <- mapM insert news_news_teams + + + -- Do all of that over again for the NewsLocations. + either_loc_ids <- mapM insertByAll (xml_locations message) + let loc_ids = map (either id id) either_loc_ids + let news_news_locations = map (News_NewsLocation news_id) loc_ids + nnl_ids <- mapM insertByAll news_news_locations - return $ ImportSucceeded (1 + (length nt_ids) + (length loc_ids)) + return $ ImportSucceeded (1 + -- for the News + (length nt_ids) + + (length loc_ids) + + (length nnt_ids) + + (length nnl_ids)) -- * Tasty Tests @@ -349,10 +358,10 @@ test_news_fields_have_correct_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 = @@ -375,7 +384,7 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" "test/xml/newsxml-with-editor.xml" ] where check desc path = testCase desc $ do - (expected :: [MessageXml], actual) <- pickle_unpickle "message" path + (expected :: [Message], actual) <- pickle_unpickle "message" path actual @?= expected -- 2.43.2