1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
11 -- root element \<message\> that contains an entire news item.
18 import Control.Monad.IO.Class ( MonadIO, liftIO )
19 import Data.Int ( Int64 )
20 import Data.List.Utils ( join, split )
21 import Data.Tuple.Curry ( uncurryN )
22 import Database.Groundhog (
23 defaultMigrationLogger,
27 import Database.Groundhog.Core ( DefaultKey, PersistBackend )
28 import Database.Groundhog.TH (
32 import Test.Tasty ( TestTree, testGroup )
33 import Test.Tasty.HUnit ( (@?=), testCase )
34 import Text.XML.HXT.Core (
49 import Unsafe.Coerce ( unsafeCoerce )
51 import Network.Services.TSN.Report ( report_error )
52 import TSN.DbImport ( DbImport(..) )
53 import Xml ( pickle_unpickle )
56 -- Can't use a newtype with Groundhog.
59 nt_news_id :: Int64, -- Foreign key.
61 deriving instance Eq NewsTeam
62 deriving instance Show NewsTeam
67 event_id :: String } -- TODO: make optional
72 loc_news_id :: Int64, -- Foreign key.
76 deriving instance Eq NewsLocation
77 deriving instance Show NewsLocation
88 locations :: [NewsLocation],
92 time_stamp :: String }
96 mkPersist defaultCodegenConfig [groundhog|
107 - entity: NewsLocation
108 dbName: news_locations
117 - {name: msg_id, dbName: msg_id}
118 - {name: event_id, dbName: event_id}
127 pickle_news_team :: PU NewsTeam
130 xpWrap (from_string, to_string) xpText
132 to_string :: NewsTeam -> String
133 to_string = team_name
135 from_string :: String -> NewsTeam
136 from_string = NewsTeam 0
138 instance XmlPickler NewsTeam where
139 xpickle = pickle_news_team
141 pickle_msg_id :: PU MsgId
144 xpWrap (from_tuple, to_tuple) $
145 xpPair xpPrim (xpAttr "EventId" xpText0)
147 from_tuple = uncurryN MsgId
148 to_tuple m = (msg_id m, event_id m)
150 instance XmlPickler MsgId where
151 xpickle = pickle_msg_id
153 pickle_location :: PU NewsLocation
156 xpWrap (from_tuple, to_tuple) $
157 xpTriple (xpElem "city" xpText)
158 (xpElem "state" xpText)
159 (xpElem "country" xpText)
162 uncurryN (NewsLocation 0)
163 to_tuple l = (city l, state l, country l) -- Don't pickle the PK
165 instance XmlPickler NewsLocation where
166 xpickle = pickle_location
169 pickle_message :: PU Message
172 xpWrap (from_tuple, to_tuple) $
173 xp12Tuple (xpElem "XML_File_ID" xpPrim)
174 (xpElem "heading" xpText)
176 (xpElem "category" xpText)
177 (xpElem "sport" xpText)
178 (xpElem "url" xpText)
179 (xpList $ pickle_news_team)
180 (xpList $ pickle_location)
181 (xpElem "SMS" xpText)
182 (xpElem "text" xpText)
184 (xpElem "time_stamp" xpText)
186 from_tuple = uncurryN Message
187 to_tuple m = (xml_file_id m,
200 pickle_continue :: PU String
202 xpWrap (to_string, from_string) $
204 (xpList $ xpElem "P" xpText)
206 from_string :: String -> [String]
207 from_string = split "\n"
209 to_string :: [String] -> String
210 to_string = join "\n"
212 instance XmlPickler Message where
213 xpickle = pickle_message
217 instance DbImport Message where
219 runMigration defaultMigrationLogger $ do
220 migrate (undefined :: Message)
221 migrate (undefined :: NewsTeam)
222 migrate (undefined :: NewsLocation)
223 let root_element = unpickleDoc xpickle xml
226 let errmsg = "Could not unpickle document in import_news."
227 liftIO $ report_error errmsg
230 news_id <- insert message
232 let insert_news_team nt = insert (nt { nt_news_id = unsafeCoerce news_id })
233 nt_ids <- mapM insert_news_team (teams message)
235 let insert_news_location loc = insert (loc { loc_news_id = unsafeCoerce news_id })
236 loc_ids <- mapM insert_news_location (locations message)
238 return $ Just (1 + (length nt_ids) + (length loc_ids))
242 news_tests :: TestTree
246 [ test_pickle_of_unpickle_is_identity ]
249 test_pickle_of_unpickle_is_identity :: TestTree
250 test_pickle_of_unpickle_is_identity =
251 testCase "pickle composed with unpickle is the identity" $ do
252 let path = "test/xml/newsxml.xml"
253 (expected :: [Message], actual) <- pickle_unpickle "message" path