From 629f04d64544bf942d9ee3283b9f99fa7e5c9d57 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Tue, 31 Dec 2013 16:31:17 -0500 Subject: [PATCH] Get the news import working more or less how it's supposed to. --- src/TSN/News.hs | 261 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 176 insertions(+), 85 deletions(-) diff --git a/src/TSN/News.hs b/src/TSN/News.hs index 1796963..2366819 100644 --- a/src/TSN/News.hs +++ b/src/TSN/News.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -16,7 +17,6 @@ module TSN.News ( where import Control.Monad.IO.Class ( MonadIO, liftIO ) -import Data.Int ( Int64 ) import Data.List.Utils ( join, split ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( @@ -24,9 +24,8 @@ import Database.Groundhog ( insert, migrate, runMigration ) -import Database.Groundhog.Core ( DefaultKey, PersistBackend ) +import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.TH ( - defaultCodegenConfig, groundhog, mkPersist ) import Test.Tasty ( TestTree, testGroup ) @@ -34,75 +33,167 @@ import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, XmlPickler(..), - XmlTree, unpickleDoc, xp12Tuple, xpAttr, xpElem, xpList, + xpOption, xpPair, xpPrim, xpText, - xpText0, xpTriple, xpWrap ) -import Unsafe.Coerce ( unsafeCoerce ) import Network.Services.TSN.Report ( report_error ) +import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..) ) -import Xml ( pickle_unpickle ) +import Xml ( ToFromXml(..), pickle_unpickle ) --- Can't use a newtype with Groundhog. + +-- | 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 :: Int64, -- Foreign key. - team_name :: String } -deriving instance Eq NewsTeam -deriving instance Show 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. data MsgId = MsgId { - msg_id :: Int, - event_id :: String } -- TODO: make optional + db_msg_id :: Int, + db_event_id :: Maybe Int } deriving (Eq, Show) -data NewsLocation = - NewsLocation { - loc_news_id :: Int64, -- Foreign key. - city :: String, - state :: String, - country :: String } -deriving instance Eq NewsLocation -deriving instance Show NewsLocation + +data MessageXml = + MessageXml { + 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_sms :: String, + xml_text :: String, + xml_continue :: String, + xml_time_stamp :: String } + deriving (Eq, Show) data Message = Message { - xml_file_id :: Int, - heading :: String, - mid :: MsgId, - category :: String, - sport :: String, - url :: String, - teams :: [NewsTeam], - locations :: [NewsLocation], - sms :: String, - text :: String, - continue :: String, - time_stamp :: String } + db_xml_file_id :: Int, + db_heading :: String, + db_mid :: MsgId, + db_category :: String, + db_sport :: String, + db_url :: String, + db_sms :: String, + db_text :: String, + db_continue :: String, + db_time_stamp :: String } deriving (Eq, Show) - -mkPersist defaultCodegenConfig [groundhog| +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 + db_xml_file_id + db_heading + db_mid + db_category + db_sport + db_url + [] + [] + db_sms + db_text + db_continue + db_time_stamp + + -- We don't need the key argument (from_xml_fk) since the XML type + -- contains more information in this case. + from_xml (MessageXml a b c d e f _ _ g h i j) = + Message a b c d e f g h i j + + +mkPersist tsn_codegen_config [groundhog| - entity: NewsTeam dbName: news_teams - constructors: - - name: NewsTeam - fields: - - name: nt_news_id - reference: - - table: news - - columns: [id] - entity: NewsLocation dbName: news_locations @@ -112,45 +203,45 @@ mkPersist defaultCodegenConfig [groundhog| constructors: - name: Message fields: - - name: mid + - name: db_mid embeddedType: - {name: msg_id, dbName: msg_id} - {name: event_id, dbName: event_id} - - embedded: MsgId fields: - - name: msg_id - - name: event_id + - name: db_msg_id + dbName: msg_id + - name: db_event_id + dbName: event_id |] - -pickle_news_team :: PU NewsTeam +pickle_news_team :: PU NewsTeamXml pickle_news_team = xpElem "team" $ xpWrap (from_string, to_string) xpText where - to_string :: NewsTeam -> String - to_string = team_name + to_string :: NewsTeamXml -> String + to_string = xml_team_name - from_string :: String -> NewsTeam - from_string = NewsTeam 0 + from_string :: String -> NewsTeamXml + from_string = NewsTeamXml -instance XmlPickler NewsTeam where +instance XmlPickler NewsTeamXml where xpickle = pickle_news_team pickle_msg_id :: PU MsgId pickle_msg_id = xpElem "msg_id" $ xpWrap (from_tuple, to_tuple) $ - xpPair xpPrim (xpAttr "EventId" xpText0) + xpPair xpPrim (xpAttr "EventId" (xpOption xpPrim)) where from_tuple = uncurryN MsgId - to_tuple m = (msg_id m, event_id m) + to_tuple m = (db_msg_id m, db_event_id m) instance XmlPickler MsgId where xpickle = pickle_msg_id -pickle_location :: PU NewsLocation +pickle_location :: PU NewsLocationXml pickle_location = xpElem "location" $ xpWrap (from_tuple, to_tuple) $ @@ -159,14 +250,14 @@ pickle_location = (xpElem "country" xpText) where from_tuple = - uncurryN (NewsLocation 0) - to_tuple l = (city l, state l, country l) -- Don't pickle the PK + uncurryN NewsLocationXml + to_tuple l = (xml_city l, xml_state l, xml_country l) -instance XmlPickler NewsLocation where +instance XmlPickler NewsLocationXml where xpickle = pickle_location -pickle_message :: PU Message +pickle_message :: PU MessageXml pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ @@ -183,19 +274,19 @@ pickle_message = pickle_continue (xpElem "time_stamp" xpText) where - from_tuple = uncurryN Message - to_tuple m = (xml_file_id m, - heading m, - mid m, - category m, - sport m, - url m, - teams m, - locations m, - sms m, - text m, - continue m, - time_stamp m) + 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 pickle_continue = @@ -209,7 +300,7 @@ pickle_message = to_string :: [String] -> String to_string = join "\n" -instance XmlPickler Message where +instance XmlPickler MessageXml where xpickle = pickle_message @@ -220,20 +311,20 @@ instance DbImport Message where migrate (undefined :: Message) migrate (undefined :: NewsTeam) migrate (undefined :: NewsLocation) - let root_element = unpickleDoc xpickle xml + let root_element = unpickleDoc xpickle xml :: Maybe MessageXml case root_element of Nothing -> do - let errmsg = "Could not unpickle document in import_news." + let errmsg = "Could not unpickle News message in dbimport." liftIO $ report_error errmsg return Nothing Just message -> do - news_id <- insert message - - let insert_news_team nt = insert (nt { nt_news_id = unsafeCoerce news_id }) - nt_ids <- mapM insert_news_team (teams message) - - let insert_news_location loc = insert (loc { loc_news_id = unsafeCoerce news_id }) - loc_ids <- mapM insert_news_location (locations message) + 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)) @@ -250,5 +341,5 @@ 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 :: [Message], actual) <- pickle_unpickle "message" path + (expected :: [MessageXml], actual) <- pickle_unpickle "message" path actual @?= expected -- 2.44.2