-- root element \<message\> that contains an entire news item.
--
module TSN.XML.News (
- Message,
+ News,
news_tests )
where
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(..) )
--- | 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 <message> 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 =
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
-- 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:
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
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) $
(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,
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"
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
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 =
"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
projects / dead / htsn-import.git / commitdiff