]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/AutoRacingSchedule.hs
Add a minor TODO note.
[dead/htsn-import.git] / src / TSN / XML / AutoRacingSchedule.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
11 -- \"Auto_Racing_Schedule_XML.dtd\". There's a top-level
12 -- \<message\>, containing \<Listing\>s, containing \<RaceResults\>,
13 -- containing \<RaceResultsListing\>s.
14 --
15 module TSN.XML.AutoRacingSchedule (
16 dtd,
17 pickle_message,
18 -- * Tests
19 auto_racing_schedule_tests,
20 -- * WARNING: these are private but exported to silence warnings
21 AutoRacingScheduleConstructor(..),
22 AutoRacingScheduleListingConstructor(..),
23 AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
24 where
25
26 -- System imports.
27 import Control.Monad ( forM_ )
28 import Data.Time ( UTCTime(..) )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
31 countAll,
32 deleteAll,
33 migrate,
34 runMigration,
35 silentMigrationLogger )
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
40 groundhog,
41 mkPersist )
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
45 PU,
46 xp7Tuple,
47 xp8Tuple,
48 xp10Tuple,
49 xpElem,
50 xpInt,
51 xpList,
52 xpOption,
53 xpText,
54 xpWrap )
55
56 -- Local imports.
57 import TSN.Codegen (
58 tsn_codegen_config )
59 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
60 import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp )
61 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
62 import Xml (
63 FromXml(..),
64 FromXmlFk(..),
65 ToDb(..),
66 pickle_unpickle,
67 unpickleable,
68 unsafe_unpickle )
69
70
71 -- | The DTD to which this module corresponds. Used to invoke dbimport.
72 --
73 dtd :: String
74 dtd = "Auto_Racing_Schedule_XML.dtd"
75
76 --
77 -- DB/XML data types
78 --
79
80 -- * AutoRacingSchedule/Message
81
82 -- | Database representation of a 'Message'.
83 --
84 data AutoRacingSchedule =
85 AutoRacingSchedule {
86 db_xml_file_id :: Int,
87 db_heading :: String,
88 db_category :: String,
89 db_sport :: String,
90 db_title :: String,
91 db_complete_through :: String,
92 db_time_stamp :: UTCTime }
93 deriving (Eq, Show)
94
95
96 -- | XML Representation of an 'AutoRacingSchedule'.
97 --
98 data Message =
99 Message {
100 xml_xml_file_id :: Int,
101 xml_heading :: String,
102 xml_category :: String,
103 xml_sport :: String,
104 xml_title :: String,
105 xml_complete_through :: String,
106 xml_listings :: [AutoRacingScheduleListingXml],
107 xml_time_stamp :: UTCTime }
108 deriving (Eq, Show)
109
110
111 instance ToDb Message where
112 -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'.
113 --
114 type Db Message = AutoRacingSchedule
115
116
117 -- | The 'FromXml' instance for 'Message' is required for the
118 -- 'XmlImport' instance.
119 --
120 instance FromXml Message where
121 -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop
122 -- the 'xml_listings'.
123 --
124 from_xml Message{..} =
125 AutoRacingSchedule {
126 db_xml_file_id = xml_xml_file_id,
127 db_heading = xml_heading,
128 db_category = xml_category,
129 db_sport = xml_sport,
130 db_title = xml_title,
131 db_complete_through = xml_complete_through,
132 db_time_stamp = xml_time_stamp }
133
134
135 -- | This allows us to insert the XML representation 'Message'
136 -- directly.
137 --
138 instance XmlImport Message
139
140
141 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
142
143 -- | Database representation of a \<Listing\> contained within a
144 -- \<Message\>. We combine the race date/time into a single
145 -- race_time, drop the race results list, and add a foreign key to
146 -- our parent.
147 --
148 data AutoRacingScheduleListing =
149 AutoRacingScheduleListing {
150 db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
151 db_race_id :: Int,
152 db_race_time :: UTCTime,
153 db_race_name :: String,
154 db_track_name :: String,
155 db_location :: String,
156 db_tv_listing :: Maybe String,
157 db_laps :: Int,
158 db_track_length :: String -- ^ Sometimes the word "miles" shows up.
159 }
160
161
162 -- | XML representation of a \<Listing\> contained within a
163 -- \<message\>.
164 --
165 data AutoRacingScheduleListingXml =
166 AutoRacingScheduleListingXml {
167 xml_race_id :: Int,
168 xml_race_date :: UTCTime,
169 xml_race_time :: Maybe UTCTime,
170 xml_race_name :: String,
171 xml_track_name :: String,
172 xml_location :: String,
173 xml_tv_listing :: Maybe String,
174 xml_laps :: Int,
175 xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up,
176 -- so we can't do the right thing and use
177 -- a 'Double'.
178 xml_race_results :: [AutoRacingScheduleListingRaceResult] }
179 deriving (Eq, Show)
180
181
182 -- | Pseudo-accessor to get the race result listings out of a
183 -- 'AutoRacingScheduleListingXml'. A poor man's lens.
184 --
185 result_listings :: AutoRacingScheduleListingXml
186 -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
187 result_listings = (concatMap xml_race_result_listing) . xml_race_results
188
189
190 instance ToDb AutoRacingScheduleListingXml where
191 -- | The database analogue of an 'AutoRacingScheduleListingXml' is
192 -- an 'AutoRacingScheduleListing'.
193 --
194 type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
195
196 instance FromXmlFk AutoRacingScheduleListingXml where
197 -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
198 -- foreign key to) a 'AutoRacingSchedule'.
199 --
200 type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
201
202 -- | To convert an 'AutoRacingScheduleListingXml' to an
203 -- 'AutoRacingScheduleListing', we add the foreign key and drop
204 -- the 'xml_race_results'. We also mash the date/time together
205 -- into one field.
206 --
207 from_xml_fk fk AutoRacingScheduleListingXml{..} =
208 AutoRacingScheduleListing {
209 db_auto_racing_schedules_id = fk,
210 db_race_id = xml_race_id,
211 db_race_time = make_race_time xml_race_date xml_race_time,
212 db_race_name = xml_race_name,
213 db_track_name = xml_track_name,
214 db_location = xml_location,
215 db_tv_listing = xml_tv_listing,
216 db_laps = xml_laps,
217 db_track_length = xml_track_length }
218 where
219 -- | Make the database \"race time\" from the XML
220 -- date/time. Simply take the day part from one and the time
221 -- from the other.
222 --
223 make_race_time d Nothing = d
224 make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
225
226
227 -- | This allows us to insert the XML representation
228 -- 'AutoRacingScheduleListingXml' directly.
229 --
230 instance XmlImportFk AutoRacingScheduleListingXml
231
232
233
234 -- * AutoRacingScheduleListingRaceResult
235
236 -- | The XML representation of \<message\> -> \<Listing\> ->
237 -- \<RaceResults\>. This element serves only to contain
238 -- \<RaceResultsListing\>s, so we don't store the intermediate table
239 -- in the database.
240 --
241 newtype AutoRacingScheduleListingRaceResult =
242 AutoRacingScheduleListingRaceResult {
243 xml_race_result_listing ::
244 [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
245 deriving (Eq, Show)
246
247
248 -- * AutoRacingScheduleListingRaceResultRaceResultListing /
249 -- AutoRacingScheduleListingRaceResultRaceResultListingXml
250 --
251 -- Sorry about the names yo.
252 --
253
254 -- | Database representation of \<RaceResultListing\> within
255 -- \<RaceResults\> within \<Listing\> within... \<message\>!
256 --
257 data AutoRacingScheduleListingRaceResultRaceResultListing =
258 AutoRacingScheduleListingRaceResultRaceResultListing {
259 db_auto_racing_schedules_listings_id ::
260 DefaultKey AutoRacingScheduleListing,
261 db_finish_position :: Int,
262 db_driver_id :: Int,
263 db_name :: String,
264 db_leading_laps :: Int,
265 db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
266 db_earnings :: String, -- ^ This should be an Int, but can have commas.
267 db_status :: String }
268
269
270 -- | XML Representation of an
271 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
272 --
273 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
274 AutoRacingScheduleListingRaceResultRaceResultListingXml {
275 xml_finish_position :: Int,
276 xml_driver_id :: Int,
277 xml_name :: String,
278 xml_leading_laps :: Int,
279 xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
280 xml_earnings :: String, -- ^ Should be an 'Int', but can have commas.
281 xml_status :: String }
282 deriving (Eq, Show)
283
284
285 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
286 -- | The database representation of an
287 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
288 -- 'AutoRacingScheduleListingRaceResultRaceResultListing'.
289 --
290 type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
291 AutoRacingScheduleListingRaceResultRaceResultListing
292
293
294 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
295 -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
296 -- is contained in (i.e. has a foreign key to) an
297 -- 'AutoRacingScheduleListing'. We skip the intermediate
298 -- \<RaceResults\>.
299 --
300 type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
301 AutoRacingScheduleListing
302
303 -- | To convert an
304 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
305 -- 'AutoRacingScheduleListingRaceResultRaceResultListing', we just
306 -- add the foreign key to the parent 'AutoRacingScheduleListing'.
307 --
308 from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
309 AutoRacingScheduleListingRaceResultRaceResultListing {
310 db_auto_racing_schedules_listings_id = fk,
311 db_finish_position = xml_finish_position,
312 db_driver_id = xml_driver_id,
313 db_name = xml_name,
314 db_leading_laps = xml_leading_laps,
315 db_listing_laps = xml_listing_laps,
316 db_earnings = xml_earnings,
317 db_status = xml_earnings }
318
319
320 -- | This allows us to insert the XML representation
321 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
322 -- directly.
323 --
324 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
325
326
327 ---
328 --- Database stuff.
329 ---
330
331 instance DbImport Message where
332 dbmigrate _ =
333 run_dbmigrate $ do
334 migrate (undefined :: AutoRacingSchedule)
335 migrate (undefined :: AutoRacingScheduleListing)
336 migrate (undefined
337 :: AutoRacingScheduleListingRaceResultRaceResultListing)
338
339
340 -- | We insert the message, then use its ID to insert the listings,
341 -- using their IDs to insert the race result listings.
342 --
343 dbimport m = do
344 msg_id <- insert_xml m
345
346 forM_ (xml_listings m) $ \listing -> do
347 listing_id <- insert_xml_fk msg_id listing
348
349 mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
350
351 return ImportSucceeded
352
353
354 mkPersist tsn_codegen_config [groundhog|
355 - entity: AutoRacingSchedule
356 dbName: auto_racing_schedules
357 constructors:
358 - name: AutoRacingSchedule
359 uniques:
360 - name: unique_auto_racing_schedule
361 type: constraint
362 # Prevent multiple imports of the same message.
363 fields: [db_xml_file_id]
364
365 - entity: AutoRacingScheduleListing
366 dbName: auto_racing_schedules_listings
367 constructors:
368 - name: AutoRacingScheduleListing
369 fields:
370 - name: db_auto_racing_schedules_id
371 reference:
372 onDelete: cascade
373
374 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
375 dbName: auto_racing_schedules_listings_race_result_listings
376 constructors:
377 - name: AutoRacingScheduleListingRaceResultRaceResultListing
378 fields:
379 - name: db_auto_racing_schedules_listings_id
380 reference:
381 onDelete: cascade
382 |]
383
384
385
386 ---
387 --- Pickling
388 ---
389
390 -- | Pickler for the top-level 'Message'.
391 --
392 pickle_message :: PU Message
393 pickle_message =
394 xpElem "message" $
395 xpWrap (from_tuple, to_tuple) $
396 xp8Tuple (xpElem "XML_File_ID" xpInt)
397 (xpElem "heading" xpText)
398 (xpElem "category" xpText)
399 (xpElem "sport" xpText)
400 (xpElem "Title" xpText)
401 (xpElem "Complete_Through" xpText)
402 (xpList pickle_listing)
403 (xpElem "time_stamp" xp_time_stamp)
404 where
405 from_tuple = uncurryN Message
406 to_tuple m = (xml_xml_file_id m,
407 xml_heading m,
408 xml_category m,
409 xml_sport m,
410 xml_title m,
411 xml_complete_through m,
412 xml_listings m,
413 xml_time_stamp m)
414
415
416 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
417 --
418 pickle_listing :: PU AutoRacingScheduleListingXml
419 pickle_listing =
420 xpElem "Listing" $
421 xpWrap (from_tuple, to_tuple) $
422 xp10Tuple (xpElem "RaceID" xpInt)
423 (xpElem "Race_Date" xp_date)
424 (xpElem "Race_Time" xp_tba_time)
425 (xpElem "RaceName" xpText)
426 (xpElem "TrackName" xpText)
427 (xpElem "Location" xpText)
428 (xpElem "TV_Listing" $ xpOption xpText)
429 (xpElem "Laps" xpInt)
430 (xpElem "TrackLength" xpText)
431 (xpList pickle_race_results)
432 where
433 from_tuple = uncurryN AutoRacingScheduleListingXml
434 to_tuple m = (xml_race_id m,
435 xml_race_date m,
436 xml_race_time m,
437 xml_race_name m,
438 xml_track_name m,
439 xml_location m,
440 xml_tv_listing m,
441 xml_laps m,
442 xml_track_length m,
443 xml_race_results m)
444
445
446 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
447 --
448 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
449 pickle_race_results =
450 xpElem "RaceResults" $
451 xpWrap (to_result, from_result) $
452 xpList pickle_race_results_listing
453 where
454 to_result = AutoRacingScheduleListingRaceResult
455 from_result = xml_race_result_listing
456
457
458 -- | Convert an
459 -- 'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
460 -- XML.
461 --
462 pickle_race_results_listing ::
463 PU AutoRacingScheduleListingRaceResultRaceResultListingXml
464 pickle_race_results_listing =
465 xpElem "RaceResultsListing" $
466 xpWrap (from_tuple, to_tuple) $
467 xp7Tuple (xpElem "FinishPosition" xpInt)
468 (xpElem "DriverID" xpInt)
469 (xpElem "Name" xpText)
470 (xpElem "LeadingLaps" xpInt)
471 (xpElem "Laps" xpInt)
472 (xpElem "Earnings" xpText)
473 (xpElem "Status" xpText)
474 where
475 from_tuple =
476 uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
477
478 to_tuple m = (xml_finish_position m,
479 xml_driver_id m,
480 xml_name m,
481 xml_leading_laps m,
482 xml_listing_laps m,
483 xml_earnings m,
484 xml_status m)
485
486
487 --
488 -- Tasty Tests
489 --
490
491 -- | A list of all tests for this module.
492 --
493 auto_racing_schedule_tests :: TestTree
494 auto_racing_schedule_tests =
495 testGroup
496 "AutoRacingSchedule tests"
497 [ test_on_delete_cascade,
498 test_pickle_of_unpickle_is_identity,
499 test_unpickle_succeeds ]
500
501 -- | If we unpickle something and then pickle it, we should wind up
502 -- with the same thing we started with. WARNING: success of this
503 -- test does not mean that unpickling succeeded.
504 --
505 test_pickle_of_unpickle_is_identity :: TestTree
506 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
507 [ check "pickle composed with unpickle is the identity"
508 "test/xml/Auto_Racing_Schedule_XML.xml",
509
510 check "pickle composed with unpickle is the identity (miles track length)"
511 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
512 where
513 check desc path = testCase desc $ do
514 (expected, actual) <- pickle_unpickle pickle_message path
515 actual @?= expected
516
517
518 -- | Make sure we can actually unpickle these things.
519 --
520 test_unpickle_succeeds :: TestTree
521 test_unpickle_succeeds = testGroup "unpickle tests"
522 [ check "unpickling succeeds"
523 "test/xml/Auto_Racing_Schedule_XML.xml",
524
525 check "unpickling succeeds (non-int team_id)"
526 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
527 where
528 check desc path = testCase desc $ do
529 actual <- unpickleable path pickle_message
530 let expected = True
531 actual @?= expected
532
533
534 -- | Make sure everything gets deleted when we delete the top-level
535 -- record.
536 --
537 test_on_delete_cascade :: TestTree
538 test_on_delete_cascade = testGroup "cascading delete tests"
539 [ check "deleting auto_racing_schedules deletes its children"
540 "test/xml/Auto_Racing_Schedule_XML.xml" ,
541
542 check ("deleting auto_racing_schedules deletes its children " ++
543 "(miles track length)")
544 "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
545 where
546 check desc path = testCase desc $ do
547 sched <- unsafe_unpickle path pickle_message
548 let a = undefined :: AutoRacingSchedule
549 let b = undefined :: AutoRacingScheduleListing
550 let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
551
552 actual <- withSqliteConn ":memory:" $ runDbConn $ do
553 runMigration silentMigrationLogger $ do
554 migrate a
555 migrate b
556 migrate c
557 _ <- dbimport sched
558 deleteAll a
559 count_a <- countAll a
560 count_b <- countAll b
561 count_c <- countAll c
562 return $ sum [count_a, count_b, count_c]
563 let expected = 0
564 actual @?= expected