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