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