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