-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- root element \<message\> that contains an entire news item.
--
module TSN.XML.News (
- News,
- news_tests )
+ news_tests,
+ pickle_message )
where
import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
import Data.Tuple.Curry ( uncurryN )
import Data.Typeable ( Typeable )
import Database.Groundhog (
- defaultMigrationLogger,
- insert,
- insertByAll,
- migrate,
- runMigration )
+ insert_,
+ migrate )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.TH (
defaultCodegenConfig,
groundhog,
mkPersist )
-import System.Console.CmdArgs.Default ( Default(..) )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
PU,
- XmlPickler(..),
- unpickleDoc,
xp13Tuple,
xpAttr,
xpElem,
import TSN.Codegen (
tsn_codegen_config,
tsn_db_field_namer ) -- Used in a test
-import TSN.DbImport ( DbImport(..), ImportResult(..) )
-import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.XmlImport ( XmlImport(..) )
+import Xml ( FromXml(..), pickle_unpickle, unpickleable )
NewsTeam { team_name :: String }
deriving (Eq, Show)
+instance FromXml NewsTeam where
+ type Db NewsTeam = NewsTeam
+ from_xml = id
+
+instance XmlImport NewsTeam
+
+
-- | Mapping between News records and NewsTeam records in the
-- database. We name the fields (even though they're never used) for
-- Groundhog's benefit.
country :: String }
deriving (Eq, Show)
+instance FromXml NewsLocation where
+ type Db NewsLocation = NewsLocation
+ from_xml = id
+
+instance XmlImport NewsLocation
+
+
-- | Mapping between News records and NewsLocation records in the
-- database. We name the fields (even though they're never used) for
-- Groundhog's benefit.
xml_mid :: MsgId,
xml_category :: String,
xml_sport :: String,
- xml_url :: String,
+ xml_url :: Maybe String,
xml_teams :: [NewsTeam],
xml_locations :: [NewsLocation],
xml_sms :: String,
News {
db_mid :: MsgId,
db_sport :: String,
- db_url :: String,
+ db_url :: Maybe String,
db_sms :: String,
db_editor :: Maybe String,
db_text :: Maybe String,
db_continue :: Maybe String }
deriving (Data, Eq, Show, Typeable)
-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 (News {..}) =
- Message
- def
- def
- db_mid
- def
- db_sport
- db_url
- def
- def
- db_sms
- db_editor
- db_text
- db_continue
- def
+instance FromXml Message where
+ type Db Message = News
-- We don't need the key argument (from_xml_fk) since the XML type
-- contains more information in this case.
from_xml (Message _ _ c _ e f _ _ i j k l _) =
News c e f i j k l
+instance XmlImport Message
+
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: NewsTeam)
+ migrate (undefined :: NewsLocation)
+ migrate (undefined :: News)
+ migrate (undefined :: News_NewsTeam)
+ migrate (undefined :: News_NewsLocation)
+
+ 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_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
+
+ -- Do all of that over again for the NewsLocations.
+ loc_ids <- mapM insert_xml_or_select (xml_locations message)
+ let news_news_locations = map (News_NewsLocation 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
from_string :: String -> NewsTeam
from_string = NewsTeam
-instance XmlPickler NewsTeam where
- xpickle = pickle_news_team
pickle_msg_id :: PU MsgId
pickle_msg_id =
from_tuple = uncurryN MsgId
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 =
uncurryN NewsLocation
to_tuple l = (city l, state l, country l)
-instance XmlPickler NewsLocation where
- xpickle = pickle_location
pickle_message :: PU Message
pickle_msg_id
(xpElem "category" xpText)
(xpElem "sport" xpText)
- (xpElem "url" xpText)
+ (xpElem "url" $ xpOption xpText)
(xpList pickle_news_team)
(xpList pickle_location)
(xpElem "SMS" xpText)
to_string :: [String] -> String
to_string = join "\n"
-instance XmlPickler Message where
- xpickle = pickle_message
-
-
-
-instance DbImport News where
- dbimport _ xml = do
- runMigration defaultMigrationLogger $ do
- migrate (undefined :: News)
- migrate (undefined :: NewsTeam)
- migrate (undefined :: NewsLocation)
- 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
- -- 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 + -- for the News
- (length nt_ids) +
- (length loc_ids) +
- (length nnt_ids) +
- (length nnl_ids))
-- * Tasty Tests
"test/xml/newsxml-with-editor.xml" ]
where
check desc path = testCase desc $ do
- (expected :: [Message], actual) <- pickle_unpickle "message" path
+ (expected, actual) <- pickle_unpickle pickle_message path
actual @?= expected
projects / dead / htsn-import.git / blobdiff