]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - News.hs
2d081aac7cc935e0833b2552347768779746434c
[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 News,
17 news_tests )
18 where
19
20 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
21 import Data.List.Utils ( join, split )
22 import Data.Tuple.Curry ( uncurryN )
23 import Data.Typeable ( Typeable )
24 import Database.Groundhog (
25 defaultMigrationLogger,
26 insert,
27 insertByAll,
28 migrate,
29 runMigration )
30 import Database.Groundhog.Core ( DefaultKey )
31 import Database.Groundhog.TH (
32 defaultCodegenConfig,
33 groundhog,
34 mkPersist )
35 import System.Console.CmdArgs.Default ( Default(..) )
36 import Test.Tasty ( TestTree, testGroup )
37 import Test.Tasty.HUnit ( (@?=), testCase )
38 import Text.XML.HXT.Core (
39 PU,
40 XmlPickler(..),
41 unpickleDoc,
42 xp13Tuple,
43 xpAttr,
44 xpElem,
45 xpInt,
46 xpList,
47 xpOption,
48 xpPair,
49 xpText,
50 xpTriple,
51 xpWrap )
52
53 import TSN.Codegen (
54 tsn_codegen_config,
55 tsn_db_field_namer ) -- Used in a test
56 import TSN.DbImport ( DbImport(..), ImportResult(..) )
57 import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
58
59
60
61 -- | The database type for teams as they show up in the news.
62 data NewsTeam =
63 NewsTeam { team_name :: String }
64 deriving (Eq, Show)
65
66 -- | Mapping between News records and NewsTeam records in the
67 -- database. We name the fields (even though they're never used) for
68 -- Groundhog's benefit.
69 data News_NewsTeam =
70 News_NewsTeam {
71 nnt_news_id :: DefaultKey News,
72 nnt_news_team_id :: DefaultKey NewsTeam }
73
74 -- | The database type for locations as they show up in the news.
75 data NewsLocation =
76 NewsLocation {
77 city :: Maybe String,
78 state :: Maybe String,
79 country :: String }
80 deriving (Eq, Show)
81
82 -- | Mapping between News records and NewsLocation records in the
83 -- database. We name the fields (even though they're never used) for
84 -- Groundhog's benefit.
85 data News_NewsLocation =
86 News_NewsLocation {
87 nnl_news_id :: DefaultKey News,
88 nnl_news_location_id :: DefaultKey NewsLocation }
89
90
91 -- | The msg_id child of <message> contains an event_id attribute; we
92 -- embed it into the 'News' type. We (pointlessly) use the "db_"
93 -- prefix here so that the two names collide on "id" when Groundhog
94 -- is creating its fields using our field namer.
95 data MsgId =
96 MsgId {
97 db_msg_id :: Int,
98 db_event_id :: Maybe Int }
99 deriving (Data, Eq, Show, Typeable)
100
101
102 data Message =
103 Message {
104 xml_xml_file_id :: Int,
105 xml_heading :: String,
106 xml_mid :: MsgId,
107 xml_category :: String,
108 xml_sport :: String,
109 xml_url :: String,
110 xml_teams :: [NewsTeam],
111 xml_locations :: [NewsLocation],
112 xml_sms :: String,
113 xml_editor :: Maybe String,
114 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
115 xml_continue :: Maybe String, -- either both present or both missing.
116 xml_time_stamp :: String }
117 deriving (Eq, Show)
118
119 data News =
120 News {
121 db_mid :: MsgId,
122 db_sport :: String,
123 db_url :: String,
124 db_sms :: String,
125 db_editor :: Maybe String,
126 db_text :: Maybe String,
127 db_continue :: Maybe String }
128 deriving (Data, Eq, Show, Typeable)
129
130 instance ToFromXml News where
131 type Xml News = Message
132 type Container News = ()
133
134 -- Use a record wildcard here so GHC doesn't complain that we never
135 -- used our named fields.
136 to_xml (News {..}) =
137 Message
138 def
139 def
140 db_mid
141 def
142 db_sport
143 db_url
144 def
145 def
146 db_sms
147 db_editor
148 db_text
149 db_continue
150 def
151
152 -- We don't need the key argument (from_xml_fk) since the XML type
153 -- contains more information in this case.
154 from_xml (Message _ _ c _ e f _ _ i j k l _) =
155 News c e f i j k l
156
157
158 -- These types don't have special XML representations or field name
159 -- collisions so we use the defaultCodegenConfig and give their fields
160 -- nice simple names.
161 mkPersist defaultCodegenConfig [groundhog|
162 - entity: NewsTeam
163 dbName: news_teams
164 constructors:
165 - name: NewsTeam
166 uniques:
167 - name: unique_news_team
168 type: constraint
169 fields: [team_name]
170
171 - entity: NewsLocation
172 dbName: news_locations
173 constructors:
174 - name: NewsLocation
175 uniques:
176 - name: unique_news_location
177 type: constraint
178 fields: [city, state, country]
179
180 |]
181
182 mkPersist tsn_codegen_config [groundhog|
183 - entity: News
184 dbName: news
185 constructors:
186 - name: News
187 fields:
188 - name: db_mid
189 embeddedType:
190 - {name: msg_id, dbName: msg_id}
191 - {name: event_id, dbName: event_id}
192 - embedded: MsgId
193 fields:
194 - name: db_msg_id
195 dbName: msg_id
196 - name: db_event_id
197 dbName: event_id
198
199
200 - entity: News_NewsTeam
201 dbName: news__news_teams
202
203 - entity: News_NewsLocation
204 dbName: news__news_locations
205 |]
206
207 pickle_news_team :: PU NewsTeam
208 pickle_news_team =
209 xpElem "team" $
210 xpWrap (from_string, to_string) xpText
211 where
212 to_string :: NewsTeam -> String
213 to_string = team_name
214
215 from_string :: String -> NewsTeam
216 from_string = NewsTeam
217
218 instance XmlPickler NewsTeam where
219 xpickle = pickle_news_team
220
221 pickle_msg_id :: PU MsgId
222 pickle_msg_id =
223 xpElem "msg_id" $
224 xpWrap (from_tuple, to_tuple) $
225 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
226 where
227 from_tuple = uncurryN MsgId
228 to_tuple m = (db_msg_id m, db_event_id m)
229
230 instance XmlPickler MsgId where
231 xpickle = pickle_msg_id
232
233 pickle_location :: PU NewsLocation
234 pickle_location =
235 xpElem "location" $
236 xpWrap (from_tuple, to_tuple) $
237 xpTriple (xpOption (xpElem "city" xpText))
238 (xpOption (xpElem "state" xpText))
239 (xpElem "country" xpText)
240 where
241 from_tuple =
242 uncurryN NewsLocation
243 to_tuple l = (city l, state l, country l)
244
245 instance XmlPickler NewsLocation where
246 xpickle = pickle_location
247
248
249 pickle_message :: PU Message
250 pickle_message =
251 xpElem "message" $
252 xpWrap (from_tuple, to_tuple) $
253 xp13Tuple (xpElem "XML_File_ID" xpInt)
254 (xpElem "heading" xpText)
255 pickle_msg_id
256 (xpElem "category" xpText)
257 (xpElem "sport" xpText)
258 (xpElem "url" xpText)
259 (xpList pickle_news_team)
260 (xpList pickle_location)
261 (xpElem "SMS" xpText)
262 (xpOption (xpElem "Editor" xpText))
263 (xpOption (xpElem "text" xpText))
264 pickle_continue
265 (xpElem "time_stamp" xpText)
266 where
267 from_tuple = uncurryN Message
268 to_tuple m = (xml_xml_file_id m,
269 xml_heading m,
270 xml_mid m,
271 xml_category m,
272 xml_sport m,
273 xml_url m,
274 xml_teams m,
275 xml_locations m,
276 xml_sms m,
277 xml_editor m,
278 xml_text m,
279 xml_continue m,
280 xml_time_stamp m)
281
282 pickle_continue :: PU (Maybe String)
283 pickle_continue =
284 xpOption $
285 xpWrap (to_string, from_string) $
286 xpElem "continue" $
287 xpList (xpElem "P" xpText)
288 where
289 from_string :: String -> [String]
290 from_string = split "\n"
291
292 to_string :: [String] -> String
293 to_string = join "\n"
294
295 instance XmlPickler Message where
296 xpickle = pickle_message
297
298
299
300 instance DbImport News where
301 dbimport _ xml = do
302 runMigration defaultMigrationLogger $ do
303 migrate (undefined :: News)
304 migrate (undefined :: NewsTeam)
305 migrate (undefined :: NewsLocation)
306 migrate (undefined :: News_NewsTeam)
307 migrate (undefined :: News_NewsLocation)
308 let root_element = unpickleDoc xpickle xml :: Maybe Message
309 case root_element of
310 Nothing -> do
311 let errmsg = "Could not unpickle News message in dbimport."
312 return $ ImportFailed errmsg
313 Just message -> do
314 -- Insert the message and acquire its primary key (unique ID)
315 news_id <- insert (from_xml message :: News)
316
317 -- And insert each one into its own table. We use insertByAll
318 -- because we know that most teams will already exist, and we
319 -- want to get back a Left (id) for the existing team when
320 -- there's a collision. In fact, if the insert succeeds, we'll
321 -- get a Right (id) back, so we can disregard the Either
322 -- constructor entirely. That's what the (either id id) does.
323 either_nt_ids <- mapM insertByAll (xml_teams message)
324 let nt_ids = map (either id id) either_nt_ids
325
326 -- Now that the teams have been inserted, create
327 -- news__news_team records mapping beween the two.
328 let news_news_teams = map (News_NewsTeam news_id) nt_ids
329 nnt_ids <- mapM insert news_news_teams
330
331
332 -- Do all of that over again for the NewsLocations.
333 either_loc_ids <- mapM insertByAll (xml_locations message)
334 let loc_ids = map (either id id) either_loc_ids
335 let news_news_locations = map (News_NewsLocation news_id) loc_ids
336 nnl_ids <- mapM insertByAll news_news_locations
337
338 return $ ImportSucceeded (1 + -- for the News
339 (length nt_ids) +
340 (length loc_ids) +
341 (length nnt_ids) +
342 (length nnl_ids))
343
344
345 -- * Tasty Tests
346 news_tests :: TestTree
347 news_tests =
348 testGroup
349 "News tests"
350 [ test_news_fields_have_correct_names,
351 test_pickle_of_unpickle_is_identity,
352 test_unpickle_succeeds ]
353
354
355 test_news_fields_have_correct_names :: TestTree
356 test_news_fields_have_correct_names =
357 testCase "news fields get correct database names" $
358 mapM_ check (zip actual expected)
359 where
360 -- This is cool, it uses the (derived) Data instance of
361 -- News.News to get its constructor names.
362 field_names :: [String]
363 field_names =
364 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
365
366 expected :: [String]
367 expected =
368 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
369
370 actual :: [String]
371 actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
372
373 check (x,y) = (x @?= y)
374
375
376 -- | Warning, succeess of this test does not mean that unpickling
377 -- succeeded.
378 test_pickle_of_unpickle_is_identity :: TestTree
379 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
380 [ check "pickle composed with unpickle is the identity"
381 "test/xml/newsxml.xml",
382
383 check "pickle composed with unpickle is the identity (with Editor)"
384 "test/xml/newsxml-with-editor.xml" ]
385 where
386 check desc path = testCase desc $ do
387 (expected :: [Message], actual) <- pickle_unpickle "message" path
388 actual @?= expected
389
390
391 test_unpickle_succeeds :: TestTree
392 test_unpickle_succeeds = testGroup "unpickle tests"
393 [ check "unpickling succeeds"
394 "test/xml/newsxml.xml",
395
396 check "unpickling succeeds (with Editor)"
397 "test/xml/newsxml-with-editor.xml" ]
398 where
399 check desc path = testCase desc $ do
400 actual <- unpickleable path pickle_message
401 let expected = True
402 actual @?= expected