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