]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - News.hs
550f26c44b77b52b61d36528b142d01fea02891e
[dead/htsn-import.git] / News.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE StandaloneDeriving #-}
9 {-# LANGUAGE TemplateHaskell #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
13 -- root element \<message\> that contains an entire news item.
14 --
15 module TSN.XML.News (
16 Message,
17 news_tests )
18 where
19
20 import Control.Monad.IO.Class ( MonadIO, liftIO )
21 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
22 import Data.List.Utils ( join, split )
23 import Data.Tuple.Curry ( uncurryN )
24 import Data.Typeable ( Typeable )
25 import Database.Groundhog (
26 defaultMigrationLogger,
27 insert,
28 migrate,
29 runMigration )
30 import Database.Groundhog.Core ( DefaultKey )
31 import Database.Groundhog.TH (
32 groundhog,
33 mkPersist )
34 import Test.Tasty ( TestTree, testGroup )
35 import Test.Tasty.HUnit ( (@?=), testCase )
36 import Text.XML.HXT.Core (
37 PU,
38 XmlPickler(..),
39 unpickleDoc,
40 xp12Tuple,
41 xpAttr,
42 xpElem,
43 xpList,
44 xpOption,
45 xpPair,
46 xpPrim,
47 xpText,
48 xpTriple,
49 xpWrap )
50
51 import Network.Services.TSN.Report ( report_error )
52 import TSN.Codegen (
53 tsn_codegen_config,
54 tsn_db_field_namer -- Used in a test.
55 )
56 import TSN.DbImport ( DbImport(..) )
57 import Xml ( ToFromXml(..), pickle_unpickle )
58
59
60
61 -- | The database type for teams as they show up in the news. We need
62 -- this separate from its XML representation because of the
63 -- DefaultKey pointing to a message. We don't know how to create one
64 -- of those unless we've just inserted a message into the database,
65 -- so it screws up pickling.
66 data NewsTeam =
67 NewsTeam {
68 nt_news_id :: DefaultKey Message, -- ^ foreign key.
69 db_team_name :: String }
70 deriving instance Eq NewsTeam -- Standalone instances necessary for
71 deriving instance Show NewsTeam -- Groundhog types with DefaultKeys
72
73 -- | The XML type for teams as they show up in the news. See
74 -- 'NewsTeam' for why there are two types.
75 data NewsTeamXml =
76 NewsTeamXml {
77 xml_team_name :: String }
78 deriving (Eq, Show)
79
80 -- | Specify how to convert between the two representations NewsTeam
81 -- (database) and NewsTeamXml (XML).
82 instance ToFromXml NewsTeam where
83 type Xml NewsTeam = NewsTeamXml
84 type Container NewsTeam = Message
85 -- Use a record wildcard here so GHC doesn't complain that we never
86 -- used our named fields.
87 to_xml (NewsTeam {..}) = NewsTeamXml db_team_name
88 -- We can't create a DefaultKey Message...
89 from_xml = error "Called from_xml on a NewsTeam."
90 -- unless we're handed one.
91 from_xml_fk key = (NewsTeam key) . xml_team_name
92
93
94 -- | The database type for locations as they show up in the news. We
95 -- need this separate from its XML representation because of the
96 -- DefaultKey pointing to a message. We don't know how to create one
97 -- of those unless we've just inserted a message into the database,
98 -- so it screws up pickling.
99 data NewsLocation =
100 NewsLocation {
101 loc_news_id :: DefaultKey Message, -- ^ foreign key.
102 db_city ::String,
103 db_state :: String,
104 db_country :: String }
105 deriving instance Eq NewsLocation -- Standalone instances necessary for
106 deriving instance Show NewsLocation -- Groundhog types with DefaultKeys
107
108 -- | The XML type for locations as they show up in the news. See
109 -- 'NewsLocation' for why there are two types.
110 data NewsLocationXml =
111 NewsLocationXml {
112 xml_city :: String,
113 xml_state :: String,
114 xml_country :: String }
115 deriving (Eq, Show)
116
117
118 -- | Specify how to convert between the two representations
119 -- NewsLocation (database) and NewsLocationXml (XML).
120 instance ToFromXml NewsLocation where
121 type Xml NewsLocation = NewsLocationXml
122 type Container NewsLocation = Message
123 -- Use a record wildcard here so GHC doesn't complain that we never
124 -- used our named fields.
125 to_xml (NewsLocation {..}) = NewsLocationXml db_city db_state db_country
126 -- We can't create a DefaultKey Message...
127 from_xml = error "Called from_xml on a NewsLocation."
128 -- unless we're given one.
129 from_xml_fk key (NewsLocationXml x y z) = NewsLocation key x y z
130
131
132 -- | The msg_id child of <message> contains an event_id attribute; we
133 -- embed it into the 'Message' type. We (pointlessly) use the "db_"
134 -- prefix here so that the two names collide on "id" when Groundhog
135 -- is creating its fields using our field namer.
136 data MsgId =
137 MsgId {
138 db_msg_id :: Int,
139 db_event_id :: Maybe Int }
140 deriving (Data, Eq, Show, Typeable)
141
142
143 data MessageXml =
144 MessageXml {
145 xml_xml_file_id :: Int,
146 xml_heading :: String,
147 xml_mid :: MsgId,
148 xml_category :: String,
149 xml_sport :: String,
150 xml_url :: String,
151 xml_teams :: [NewsTeamXml],
152 xml_locations :: [NewsLocationXml],
153 xml_sms :: String,
154 xml_text :: String,
155 xml_continue :: String,
156 xml_time_stamp :: String }
157 deriving (Eq, Show)
158
159 data Message =
160 Message {
161 db_mid :: MsgId,
162 db_sport :: String,
163 db_url :: String,
164 db_sms :: String,
165 db_text :: String,
166 db_continue :: String }
167 deriving (Data, Eq, Show, Typeable)
168
169 instance ToFromXml Message where
170 type Xml Message = MessageXml
171 type Container Message = ()
172
173 -- Use a record wildcard here so GHC doesn't complain that we never
174 -- used our named fields.
175 to_xml (Message {..}) =
176 MessageXml
177 0
178 ""
179 db_mid
180 ""
181 db_sport
182 db_url
183 []
184 []
185 db_sms
186 db_text
187 db_continue
188 ""
189
190 -- We don't need the key argument (from_xml_fk) since the XML type
191 -- contains more information in this case.
192 from_xml (MessageXml _ _ c _ e f _ _ g h i _) =
193 Message c e f g h i
194
195
196 mkPersist tsn_codegen_config [groundhog|
197 - entity: NewsTeam
198 dbName: news_teams
199
200 - entity: NewsLocation
201 dbName: news_locations
202
203 - entity: Message
204 dbName: news
205 constructors:
206 - name: Message
207 fields:
208 - name: db_mid
209 embeddedType:
210 - {name: msg_id, dbName: msg_id}
211 - {name: event_id, dbName: event_id}
212 - embedded: MsgId
213 fields:
214 - name: db_msg_id
215 dbName: msg_id
216 - name: db_event_id
217 dbName: event_id
218 |]
219
220 pickle_news_team :: PU NewsTeamXml
221 pickle_news_team =
222 xpElem "team" $
223 xpWrap (from_string, to_string) xpText
224 where
225 to_string :: NewsTeamXml -> String
226 to_string = xml_team_name
227
228 from_string :: String -> NewsTeamXml
229 from_string = NewsTeamXml
230
231 instance XmlPickler NewsTeamXml where
232 xpickle = pickle_news_team
233
234 pickle_msg_id :: PU MsgId
235 pickle_msg_id =
236 xpElem "msg_id" $
237 xpWrap (from_tuple, to_tuple) $
238 xpPair xpPrim (xpAttr "EventId" (xpOption xpPrim))
239 where
240 from_tuple = uncurryN MsgId
241 to_tuple m = (db_msg_id m, db_event_id m)
242
243 instance XmlPickler MsgId where
244 xpickle = pickle_msg_id
245
246 pickle_location :: PU NewsLocationXml
247 pickle_location =
248 xpElem "location" $
249 xpWrap (from_tuple, to_tuple) $
250 xpTriple (xpElem "city" xpText)
251 (xpElem "state" xpText)
252 (xpElem "country" xpText)
253 where
254 from_tuple =
255 uncurryN NewsLocationXml
256 to_tuple l = (xml_city l, xml_state l, xml_country l)
257
258 instance XmlPickler NewsLocationXml where
259 xpickle = pickle_location
260
261
262 pickle_message :: PU MessageXml
263 pickle_message =
264 xpElem "message" $
265 xpWrap (from_tuple, to_tuple) $
266 xp12Tuple (xpElem "XML_File_ID" xpPrim)
267 (xpElem "heading" xpText)
268 pickle_msg_id
269 (xpElem "category" xpText)
270 (xpElem "sport" xpText)
271 (xpElem "url" xpText)
272 (xpList $ pickle_news_team)
273 (xpList $ pickle_location)
274 (xpElem "SMS" xpText)
275 (xpElem "text" xpText)
276 pickle_continue
277 (xpElem "time_stamp" xpText)
278 where
279 from_tuple = uncurryN MessageXml
280 to_tuple m = (xml_xml_file_id m,
281 xml_heading m,
282 xml_mid m,
283 xml_category m,
284 xml_sport m,
285 xml_url m,
286 xml_teams m,
287 xml_locations m,
288 xml_sms m,
289 xml_text m,
290 xml_continue m,
291 xml_time_stamp m)
292
293 pickle_continue :: PU String
294 pickle_continue =
295 xpWrap (to_string, from_string) $
296 xpElem "continue" $
297 (xpList $ xpElem "P" xpText)
298 where
299 from_string :: String -> [String]
300 from_string = split "\n"
301
302 to_string :: [String] -> String
303 to_string = join "\n"
304
305 instance XmlPickler MessageXml where
306 xpickle = pickle_message
307
308
309
310 instance DbImport Message where
311 dbimport _ xml = do
312 runMigration defaultMigrationLogger $ do
313 migrate (undefined :: Message)
314 migrate (undefined :: NewsTeam)
315 migrate (undefined :: NewsLocation)
316 let root_element = unpickleDoc xpickle xml :: Maybe MessageXml
317 case root_element of
318 Nothing -> do
319 let errmsg = "Could not unpickle News message in dbimport."
320 liftIO $ report_error errmsg
321 return Nothing
322 Just message -> do
323 news_id <- insert (from_xml message :: Message)
324 let nts :: [NewsTeam] = map (from_xml_fk news_id)
325 (xml_teams message)
326 let nlocs :: [NewsLocation] = map (from_xml_fk news_id)
327 (xml_locations message)
328 nt_ids <- mapM insert nts
329 loc_ids <- mapM insert nlocs
330
331 return $ Just (1 + (length nt_ids) + (length loc_ids))
332
333
334 -- * Tasty Tests
335 news_tests :: TestTree
336 news_tests =
337 testGroup
338 "News tests"
339 [ test_news_fields_have_correct_names,
340 test_pickle_of_unpickle_is_identity ]
341
342
343 test_pickle_of_unpickle_is_identity :: TestTree
344 test_pickle_of_unpickle_is_identity =
345 testCase "pickle composed with unpickle is the identity" $ do
346 let path = "test/xml/newsxml.xml"
347 (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
348 actual @?= expected
349
350
351 test_news_fields_have_correct_names :: TestTree
352 test_news_fields_have_correct_names =
353 testCase "news fields get correct database names" $ do
354 mapM_ check (zip actual expected)
355 where
356 -- This is cool, it uses the (derived) Data instance of
357 -- News.Message to get its constructor names.
358 field_names :: [String]
359 field_names =
360 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: Message)
361
362 expected :: [String]
363 expected =
364 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
365
366 actual :: [String]
367 actual = ["mid", "sport", "url", "sms", "text", "continue"]
368
369 check (x,y) = (x @?= y)