]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - News.hs
8026dcd621a5c489fdfeea4eea19231e2ac9a21d
[dead/htsn-import.git] / 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
11 -- a root element \<message\> that contains an entire news item.
12 --
13 module TSN.XML.News (
14 pickle_message,
15 -- * Tests
16 news_tests,
17 -- * WARNING: these are private but exported to silence warnings
18 News_NewsLocationConstructor(..),
19 News_NewsTeamConstructor(..),
20 NewsConstructor(..),
21 NewsLocationConstructor(..),
22 NewsTeamConstructor(..) )
23 where
24
25 -- System imports.
26 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
27 import Data.Time.Clock ( UTCTime )
28 import Data.List.Utils ( join, split )
29 import Data.Tuple.Curry ( uncurryN )
30 import Data.Typeable ( Typeable )
31 import Database.Groundhog (
32 countAll,
33 executeRaw,
34 insert_,
35 migrate,
36 runMigration,
37 silentMigrationLogger )
38 import Database.Groundhog.Core ( DefaultKey )
39 import Database.Groundhog.Generic ( runDbConn )
40 import Database.Groundhog.Sqlite ( withSqliteConn )
41 import Database.Groundhog.TH (
42 defaultCodegenConfig,
43 groundhog,
44 mkPersist )
45 import Test.Tasty ( TestTree, testGroup )
46 import Test.Tasty.HUnit ( (@?=), testCase )
47 import Text.XML.HXT.Core (
48 PU,
49 xp13Tuple,
50 xpAttr,
51 xpElem,
52 xpInt,
53 xpList,
54 xpOption,
55 xpPair,
56 xpText,
57 xpTriple,
58 xpWrap )
59
60 -- Local imports.
61 import TSN.Codegen (
62 tsn_codegen_config,
63 tsn_db_field_namer ) -- Used in a test
64 import TSN.Database ( insert_or_select )
65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
66 import TSN.Picklers ( xp_time_stamp )
67 import TSN.XmlImport ( XmlImport(..) )
68 import Xml (
69 FromXml(..),
70 ToDb(..),
71 pickle_unpickle,
72 unpickleable,
73 unsafe_unpickle )
74
75
76 --
77 -- DB/XML Data types
78 --
79
80 -- * News/Message
81
82 -- | The msg_id child of <message> contains an event_id attribute; we
83 -- embed it into the 'News' type. We (pointlessly) use the "db_"
84 -- prefix here so that the two names don't collide on "id" when
85 -- Groundhog is creating its fields using our field namer.
86 --
87 data MsgId =
88 MsgId {
89 db_msg_id :: Int,
90 db_event_id :: Maybe Int }
91 deriving (Data, Eq, Show, Typeable)
92
93
94 -- | The XML representation of a news item (\<message\>).
95 --
96 data Message =
97 Message {
98 xml_xml_file_id :: Int,
99 xml_heading :: String,
100 xml_mid :: MsgId,
101 xml_category :: String,
102 xml_sport :: String,
103 xml_url :: Maybe String,
104 xml_teams :: [NewsTeam],
105 xml_locations :: [NewsLocation],
106 xml_sms :: String,
107 xml_editor :: Maybe String,
108 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
109 xml_continue :: Maybe String, -- either both present or both missing.
110 xml_time_stamp :: UTCTime }
111 deriving (Eq, Show)
112
113
114 -- | The database representation of a news item. We drop several
115 -- uninteresting fields from 'Message', and omit the list fields which
116 -- will be represented as join tables.
117 --
118 data News =
119 News {
120 db_xml_file_id :: Int,
121 db_mid :: MsgId,
122 db_sport :: String,
123 db_url :: Maybe String,
124 db_sms :: String,
125 db_editor :: Maybe String,
126 db_text :: Maybe String,
127 db_continue :: Maybe String,
128 db_time_stamp :: UTCTime }
129 deriving (Data, Eq, Show, Typeable)
130
131
132
133 instance ToDb Message where
134 -- | The database representation of 'Message' is 'News'.
135 type Db Message = News
136
137 -- | Convert the XML representation 'Message' to the database
138 -- representation 'News'.
139 --
140 instance FromXml Message where
141 -- | We use a record wildcard so GHC doesn't complain that we never
142 -- used the field names.
143 --
144 from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
145 db_mid = xml_mid,
146 db_sport = xml_sport,
147 db_url = xml_url,
148 db_sms = xml_sms,
149 db_editor = xml_editor,
150 db_text = xml_text,
151 db_continue = xml_continue,
152 db_time_stamp = xml_time_stamp }
153
154 -- | This lets us insert the XML representation 'Message' directly.
155 --
156 instance XmlImport Message
157
158
159 -- * NewsTeam
160
161 -- | The database type for teams as they show up in the news.
162 --
163 data NewsTeam =
164 NewsTeam { team_name :: String }
165 deriving (Eq, Show)
166
167
168
169 -- * News_NewsTeam
170
171 -- | Mapping between News records and NewsTeam records in the
172 -- database. We don't name the fields because we don't use the names
173 -- explicitly; that means we have to give them nice database names
174 -- via groundhog.
175 --
176 data News_NewsTeam = News_NewsTeam
177 (DefaultKey News)
178 (DefaultKey NewsTeam)
179
180
181 -- * NewsLocation
182
183 -- | The database type for locations as they show up in the news.
184 --
185 data NewsLocation =
186 NewsLocation {
187 city :: Maybe String,
188 state :: Maybe String,
189 country :: String }
190 deriving (Eq, Show)
191
192
193 -- * News_NewsLocation
194
195 -- | Mapping between News records and NewsLocation records in the
196 -- database. We don't name the fields because we don't use the names
197 -- explicitly; that means we have to give them nice database names
198 -- via groundhog.
199 --
200 data News_NewsLocation = News_NewsLocation
201 (DefaultKey News)
202 (DefaultKey NewsLocation)
203
204
205
206 --
207 -- Database code
208 --
209
210 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
211 -- slightly non-generic because of our 'News_NewsTeam' and
212 -- 'News_NewsLocation' join tables.
213 --
214 instance DbImport Message where
215 dbmigrate _ =
216 run_dbmigrate $ do
217 migrate (undefined :: News)
218 migrate (undefined :: NewsTeam)
219 migrate (undefined :: News_NewsTeam)
220 migrate (undefined :: NewsLocation)
221 migrate (undefined :: News_NewsLocation)
222
223 dbimport message = do
224 -- Insert the message and acquire its primary key (unique ID)
225 news_id <- insert_xml message
226
227 -- And insert each one into its own table. We use insert_xml_or_select
228 -- because we know that most teams will already exist, and we
229 -- want to get back the id for the existing team when
230 -- there's a collision.
231 nt_ids <- mapM insert_or_select (xml_teams message)
232
233 -- Now that the teams have been inserted, create
234 -- news__news_team records mapping beween the two.
235 let news_news_teams = map (News_NewsTeam news_id) nt_ids
236 mapM_ insert_ news_news_teams
237
238 -- Do all of that over again for the NewsLocations.
239 loc_ids <- mapM insert_or_select (xml_locations message)
240 let news_news_locations = map (News_NewsLocation news_id) loc_ids
241 mapM_ insert_ news_news_locations
242
243 return ImportSucceeded
244
245
246 -- These types don't have special XML representations or field name
247 -- collisions so we use the defaultCodegenConfig and give their
248 -- fields nice simple names.
249 mkPersist defaultCodegenConfig [groundhog|
250 - entity: NewsTeam
251 dbName: news_teams
252 constructors:
253 - name: NewsTeam
254 uniques:
255 - name: unique_news_team
256 type: constraint
257 fields: [team_name]
258
259 - entity: NewsLocation
260 dbName: news_locations
261 constructors:
262 - name: NewsLocation
263 uniques:
264 - name: unique_news_location
265 type: constraint
266 fields: [city, state, country]
267
268 |]
269
270
271 -- These types have fields with e.g. db_ and xml_ prefixes, so we
272 -- use our own codegen to peel those off before naming the columns.
273 mkPersist tsn_codegen_config [groundhog|
274 - entity: News
275 dbName: news
276 constructors:
277 - name: News
278 uniques:
279 - name: unique_news
280 type: constraint
281 # Prevent multiple imports of the same message.
282 fields: [db_xml_file_id]
283 fields:
284 - name: db_mid
285 embeddedType:
286 - {name: msg_id, dbName: msg_id}
287 - {name: event_id, dbName: event_id}
288
289 - embedded: MsgId
290 fields:
291 - name: db_msg_id
292 dbName: msg_id
293 - name: db_event_id
294 dbName: event_id
295
296 - entity: News_NewsTeam
297 dbName: news__news_teams
298 constructors:
299 - name: News_NewsTeam
300 fields:
301 - name: news_NewsTeam0 # Default created by mkNormalFieldName
302 dbName: news_id
303 reference:
304 onDelete: cascade
305 - name: news_NewsTeam1 # Default created by mkNormalFieldName
306 dbName: news_teams_id
307 reference:
308 onDelete: cascade
309
310 - entity: News_NewsLocation
311 dbName: news__news_locations
312 constructors:
313 - name: News_NewsLocation
314 fields:
315 - name: news_NewsLocation0 # Default created by mkNormalFieldName
316 dbName: news_id
317 reference:
318 onDelete: cascade
319 - name: news_NewsLocation1 # Default created by mkNormalFieldName
320 dbName: news_locations_id
321 reference:
322 onDelete: cascade
323 |]
324
325
326 --
327 -- XML Picklers
328 --
329
330 -- | Convert a 'NewsTeam' to/from XML.
331 --
332 pickle_news_team :: PU NewsTeam
333 pickle_news_team =
334 xpElem "team" $
335 xpWrap (from_string, to_string) xpText
336 where
337 to_string :: NewsTeam -> String
338 to_string = team_name
339
340 from_string :: String -> NewsTeam
341 from_string = NewsTeam
342
343
344 -- | Convert a 'MsgId' to/from XML.
345 --
346 pickle_msg_id :: PU MsgId
347 pickle_msg_id =
348 xpElem "msg_id" $
349 xpWrap (from_tuple, to_tuple) $
350 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
351 where
352 from_tuple = uncurryN MsgId
353 to_tuple m = (db_msg_id m, db_event_id m)
354
355
356 -- | Convert a 'NewsLocation' to/from XML.
357 --
358 pickle_location :: PU NewsLocation
359 pickle_location =
360 xpElem "location" $
361 xpWrap (from_tuple, to_tuple) $
362 xpTriple (xpOption (xpElem "city" xpText))
363 (xpOption (xpElem "state" xpText))
364 (xpElem "country" xpText)
365 where
366 from_tuple =
367 uncurryN NewsLocation
368 to_tuple l = (city l, state l, country l)
369
370
371 -- | Convert a 'Message' to/from XML.
372 --
373 pickle_message :: PU Message
374 pickle_message =
375 xpElem "message" $
376 xpWrap (from_tuple, to_tuple) $
377 xp13Tuple (xpElem "XML_File_ID" xpInt)
378 (xpElem "heading" xpText)
379 pickle_msg_id
380 (xpElem "category" xpText)
381 (xpElem "sport" xpText)
382 (xpElem "url" $ xpOption xpText)
383 (xpList pickle_news_team)
384 (xpList pickle_location)
385 (xpElem "SMS" xpText)
386 (xpOption (xpElem "Editor" xpText))
387 (xpOption (xpElem "text" xpText))
388 pickle_continue
389 (xpElem "time_stamp" xp_time_stamp)
390 where
391 from_tuple = uncurryN Message
392 to_tuple m = (xml_xml_file_id m, -- Verbose,
393 xml_heading m, -- but
394 xml_mid m, -- eliminates
395 xml_category m, -- GHC
396 xml_sport m, -- warnings
397 xml_url m, -- .
398 xml_teams m, -- .
399 xml_locations m, -- .
400 xml_sms m,
401 xml_editor m,
402 xml_text m,
403 xml_continue m,
404 xml_time_stamp m)
405
406 -- | We combine all of the \<continue\> elements into one 'String'
407 -- while unpickling and do the reverse while pickling.
408 --
409 pickle_continue :: PU (Maybe String)
410 pickle_continue =
411 xpOption $
412 xpWrap (to_string, from_string) $
413 xpElem "continue" $
414 xpList (xpElem "P" xpText)
415 where
416 from_string :: String -> [String]
417 from_string = split "\n"
418
419 to_string :: [String] -> String
420 to_string = join "\n"
421
422
423 --
424 -- Tasty Tests
425 --
426
427 -- | A list of all tests for this module.
428 --
429 news_tests :: TestTree
430 news_tests =
431 testGroup
432 "News tests"
433 [ test_news_fields_have_correct_names,
434 test_on_delete_cascade,
435 test_pickle_of_unpickle_is_identity,
436 test_unpickle_succeeds ]
437
438
439 -- | Make sure our codegen is producing the correct database names.
440 --
441 test_news_fields_have_correct_names :: TestTree
442 test_news_fields_have_correct_names =
443 testCase "news fields get correct database names" $
444 mapM_ check (zip actual expected)
445 where
446 -- This is cool, it uses the (derived) Data instance of
447 -- News.News to get its constructor names.
448 field_names :: [String]
449 field_names =
450 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
451
452 expected :: [String]
453 expected =
454 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
455
456 actual :: [String]
457 actual = ["xml_file_id",
458 "mid",
459 "sport",
460 "url",
461 "sms",
462 "editor",
463 "text",
464 "continue"]
465
466 check (x,y) = (x @?= y)
467
468
469 -- | If we unpickle something and then pickle it, we should wind up
470 -- with the same thing we started with. WARNING: success of this
471 -- test does not mean that unpickling succeeded.
472 --
473 test_pickle_of_unpickle_is_identity :: TestTree
474 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
475 [ check "pickle composed with unpickle is the identity"
476 "test/xml/newsxml.xml",
477
478 check "pickle composed with unpickle is the identity (with Editor)"
479 "test/xml/newsxml-with-editor.xml" ]
480 where
481 check desc path = testCase desc $ do
482 (expected, actual) <- pickle_unpickle pickle_message path
483 actual @?= expected
484
485
486 -- | Make sure we can actually unpickle these things.
487 --
488 test_unpickle_succeeds :: TestTree
489 test_unpickle_succeeds = testGroup "unpickle tests"
490 [ check "unpickling succeeds"
491 "test/xml/newsxml.xml",
492
493 check "unpickling succeeds (with Editor)"
494 "test/xml/newsxml-with-editor.xml" ]
495 where
496 check desc path = testCase desc $ do
497 actual <- unpickleable path pickle_message
498 let expected = True
499 actual @?= expected
500
501
502 -- | Make sure everything gets deleted when we delete the top-level
503 -- record.
504 --
505 test_on_delete_cascade :: TestTree
506 test_on_delete_cascade = testGroup "cascading delete tests"
507 [ check "deleting news deletes its children"
508 "test/xml/newsxml.xml"
509 4 -- 2 news_teams and 2 news_locations that should remain.
510 ]
511 where
512 check desc path expected = testCase desc $ do
513 news <- unsafe_unpickle path pickle_message
514 let a = undefined :: News
515 let b = undefined :: NewsTeam
516 let c = undefined :: News_NewsTeam
517 let d = undefined :: NewsLocation
518 let e = undefined :: News_NewsLocation
519 actual <- withSqliteConn ":memory:" $ runDbConn $ do
520 runMigration silentMigrationLogger $ do
521 migrate a
522 migrate b
523 migrate c
524 migrate d
525 migrate e
526 _ <- dbimport news
527 -- No idea how 'delete' works, so do this instead.
528 executeRaw False "DELETE FROM news;" []
529 count_a <- countAll a
530 count_b <- countAll b
531 count_c <- countAll c
532 count_d <- countAll d
533 count_e <- countAll e
534 return $ count_a + count_b + count_c + count_d + count_e
535 actual @?= expected