{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
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 (
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 )
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 <message> 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
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) $
(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) $
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 =
to_string :: [String] -> String
to_string = join "\n"
-instance XmlPickler Message where
+instance XmlPickler MessageXml where
xpickle = pickle_message
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))
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
projects / dead / htsn-import.git / commitdiff