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