]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - XML/AutoRacingResults.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / XML / AutoRacingResults.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 \"AutoRacingResultsXML.dtd\". Each
10 -- \<message\> element contains a \<Race_Information\> and a bunch of
11 -- \<Listing\>s.
12 --
13 module TSN.XML.AutoRacingResults (
14 dtd,
15 pickle_message,
16 -- * Tests
17 auto_racing_results_tests,
18 -- * WARNING: these are private but exported to silence warnings
19 AutoRacingResultsConstructor(..),
20 AutoRacingResultsListingConstructor(..),
21 AutoRacingResultsRaceInformationConstructor(..) )
22 where
23
24 -- System imports.
25 import Control.Monad ( forM_ )
26 import Data.Data ( Data )
27 import Data.Time ( UTCTime(..) )
28 import Data.Tuple.Curry ( uncurryN )
29 import Data.Typeable ( Typeable )
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 xp11Tuple,
47 xp13Tuple,
48 xpAttr,
49 xpElem,
50 xpInt,
51 xpList,
52 xpOption,
53 xpPair,
54 xpPrim,
55 xpText,
56 xpTriple,
57 xpWrap )
58
59 -- Local imports.
60 import TSN.Codegen ( tsn_codegen_config )
61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.Picklers ( xp_earnings, xp_datetime, xp_time_stamp )
63 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
64 import Xml (
65 Child(..),
66 FromXml(..),
67 FromXmlFk(..),
68 ToDb(..),
69 pickle_unpickle,
70 unpickleable,
71 unsafe_unpickle )
72
73
74 -- | The DTD to which this module corresponds. Used to invoke dbimport.
75 --
76 dtd :: String
77 dtd = "AutoRacingResultsXML.dtd"
78
79 --
80 -- DB/XML data types
81 --
82
83 -- * AutoRacingResults/Message
84
85 -- | Database representation of a 'Message'. Comparatively, it lacks
86 -- the listings and race information since they are linked via a
87 -- foreign key.
88 --
89 data AutoRacingResults =
90 AutoRacingResults {
91 db_xml_file_id :: Int,
92 db_heading :: String,
93 db_category :: String,
94 db_sport :: String,
95 db_race_id :: Int,
96 db_race_date :: UTCTime,
97 db_title :: String,
98 db_track_location :: String,
99 db_laps_remaining :: Int,
100 db_checkered_flag :: Bool,
101 db_time_stamp :: UTCTime }
102 deriving (Eq, Show)
103
104
105
106 -- | XML Representation of an 'AutoRacingResults'. It has the same
107 -- fields, but in addition contains the 'xml_listings' and
108 -- 'xml_race_information'.
109 --
110 data Message =
111 Message {
112 xml_xml_file_id :: Int,
113 xml_heading :: String,
114 xml_category :: String,
115 xml_sport :: String,
116 xml_race_id :: Int,
117 xml_race_date :: UTCTime,
118 xml_title :: String,
119 xml_track_location :: String,
120 xml_laps_remaining :: Int,
121 xml_checkered_flag :: Bool,
122 xml_listings :: [AutoRacingResultsListingXml],
123 xml_race_information :: AutoRacingResultsRaceInformationXml,
124 xml_time_stamp :: UTCTime }
125 deriving (Eq, Show)
126
127
128 instance ToDb Message where
129 -- | The database analogue of a 'Message' is a 'AutoRacingResults'.
130 --
131 type Db Message = AutoRacingResults
132
133
134 -- | The 'FromXml' instance for 'Message' is required for the
135 -- 'XmlImport' instance.
136 --
137 instance FromXml Message where
138 -- | To convert a 'Message' to an 'AutoRacingResults', we just drop
139 -- the 'xml_listings' and 'xml_race_information'.
140 --
141 from_xml Message{..} =
142 AutoRacingResults {
143 db_xml_file_id = xml_xml_file_id,
144 db_heading = xml_heading,
145 db_category = xml_category,
146 db_sport = xml_sport,
147 db_race_id = xml_race_id,
148 db_race_date = xml_race_date,
149 db_title = xml_title,
150 db_track_location = xml_track_location,
151 db_laps_remaining = xml_laps_remaining,
152 db_checkered_flag = xml_checkered_flag,
153 db_time_stamp = xml_time_stamp }
154
155
156 -- | This allows us to insert the XML representation 'Message'
157 -- directly.
158 --
159 instance XmlImport Message
160
161
162 -- * AutoRacingResultsListing/AutoRacingResultsListingXml
163
164 -- | Database representation of a \<Listing\> contained within a
165 -- \<message\>.
166 --
167 data AutoRacingResultsListing =
168 AutoRacingResultsListing {
169 db_auto_racing_results_id :: DefaultKey AutoRacingResults,
170 db_finish_position :: Int,
171 db_starting_position :: Int,
172 db_car_number :: Int,
173 db_driver_id :: Int,
174 db_driver :: String,
175 db_car_make :: String,
176 db_points :: Int,
177 db_laps_completed :: Int,
178 db_laps_leading :: Int,
179 db_status :: Maybe String,
180 db_dnf :: Maybe Bool,
181 db_nc :: Maybe Bool,
182 db_earnings :: Maybe Int }
183
184
185 -- | XML representation of a \<Listing\> contained within a
186 -- \<message\>.
187 --
188 data AutoRacingResultsListingXml =
189 AutoRacingResultsListingXml {
190 xml_finish_position :: Int,
191 xml_starting_position :: Int,
192 xml_car_number :: Int,
193 xml_driver_id :: Int,
194 xml_driver :: String,
195 xml_car_make :: String,
196 xml_points :: Int,
197 xml_laps_completed :: Int,
198 xml_laps_leading :: Int,
199 xml_status :: Maybe String,
200 xml_dnf :: Maybe Bool,
201 xml_nc :: Maybe Bool,
202 xml_earnings :: Maybe Int }
203 deriving (Eq, Show)
204
205
206 instance ToDb AutoRacingResultsListingXml where
207 -- | The database analogue of an 'AutoRacingResultsListingXml' is
208 -- an 'AutoRacingResultsListing'.
209 --
210 type Db AutoRacingResultsListingXml = AutoRacingResultsListing
211
212
213 instance Child AutoRacingResultsListingXml where
214 -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a
215 -- foreign key to) a 'AutoRacingResults'.
216 --
217 type Parent AutoRacingResultsListingXml = AutoRacingResults
218
219
220 instance FromXmlFk AutoRacingResultsListingXml where
221 -- | To convert an 'AutoRacingResultsListingXml' to an
222 -- 'AutoRacingResultsListing', we add the foreign key and copy
223 -- everything else verbatim.
224 --
225 from_xml_fk fk AutoRacingResultsListingXml{..} =
226 AutoRacingResultsListing {
227 db_auto_racing_results_id = fk,
228 db_finish_position = xml_finish_position,
229 db_starting_position = xml_starting_position,
230 db_car_number = xml_car_number,
231 db_driver_id = xml_driver_id,
232 db_driver = xml_driver,
233 db_car_make = xml_car_make,
234 db_points = xml_points,
235 db_laps_completed = xml_laps_completed,
236 db_laps_leading = xml_laps_leading,
237 db_status = xml_status,
238 db_dnf = xml_dnf,
239 db_nc = xml_nc,
240 db_earnings = xml_earnings }
241
242
243 -- | This allows us to insert the XML representation
244 -- 'AutoRacingResultsListingXml' directly.
245 --
246 instance XmlImportFk AutoRacingResultsListingXml
247
248
249
250 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
251
252 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
253 -- contains exactly three fields, so we just embed those three into
254 -- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
255 -- the \"db_\" prefix since our field namer is going to strip of
256 -- everything before the first underscore.
257 --
258 data MostLapsLeading =
259 MostLapsLeading {
260 db_most_laps_leading_driver_id :: Int,
261 db_most_laps_leading_driver :: String,
262 db_most_laps_leading_number_of_laps :: Int }
263 deriving (Data, Eq, Show, Typeable)
264
265
266 -- | Database representation of a \<Race_Information\> contained
267 -- within a \<message\>.
268 --
269 data AutoRacingResultsRaceInformation =
270 AutoRacingResultsRaceInformation {
271 -- Note the apostrophe to disambiguate it from the
272 -- AutoRacingResultsListing field.
273 db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
274 db_track_length :: String, -- ^ Usually a Double, but sometimes a String,
275 -- like \"1.25 miles\".
276 db_track_length_kph :: Double,
277 db_laps :: Int,
278 db_average_speed_mph :: Maybe Double,
279 db_average_speed_kph :: Maybe Double,
280 db_average_speed :: Maybe Double,
281 db_time_of_race :: Maybe String,
282 db_margin_of_victory :: Maybe String,
283 db_cautions :: Maybe String,
284 db_lead_changes :: Maybe String,
285 db_lap_leaders :: Maybe String,
286 db_most_laps_leading :: MostLapsLeading }
287
288
289 -- | XML representation of a \<Listing\> contained within a
290 -- \<message\>.
291 --
292 data AutoRacingResultsRaceInformationXml =
293 AutoRacingResultsRaceInformationXml {
294 xml_track_length :: String,
295 xml_track_length_kph :: Double,
296 xml_laps :: Int,
297 xml_average_speed_mph :: Maybe Double,
298 xml_average_speed_kph :: Maybe Double,
299 xml_average_speed :: Maybe Double,
300 xml_time_of_race :: Maybe String,
301 xml_margin_of_victory :: Maybe String,
302 xml_cautions :: Maybe String,
303 xml_lead_changes :: Maybe String,
304 xml_lap_leaders :: Maybe String,
305 xml_most_laps_leading :: MostLapsLeading }
306 deriving (Eq,Show)
307
308
309 instance ToDb AutoRacingResultsRaceInformationXml where
310 -- | The database analogue of an
311 -- 'AutoRacingResultsRaceInformationXml' is an
312 -- 'AutoRacingResultsRaceInformation'.
313 --
314 type Db AutoRacingResultsRaceInformationXml =
315 AutoRacingResultsRaceInformation
316
317
318 instance Child AutoRacingResultsRaceInformationXml where
319 -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
320 -- (i.e. has a foreign key to) a 'AutoRacingResults'.
321 --
322 type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
323
324
325 instance FromXmlFk AutoRacingResultsRaceInformationXml where
326 -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
327 -- 'AutoRacingResultsRaceInformartion', we add the foreign key and
328 -- copy everything else verbatim.
329 --
330 from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
331 AutoRacingResultsRaceInformation {
332 db_auto_racing_results_id' = fk,
333 db_track_length = xml_track_length,
334 db_track_length_kph = xml_track_length_kph,
335 db_laps = xml_laps,
336 db_average_speed_mph = xml_average_speed_mph,
337 db_average_speed_kph = xml_average_speed_kph,
338 db_average_speed = xml_average_speed,
339 db_time_of_race = xml_time_of_race,
340 db_margin_of_victory = xml_margin_of_victory,
341 db_cautions = xml_cautions,
342 db_lead_changes = xml_lead_changes,
343 db_lap_leaders = xml_lap_leaders,
344 db_most_laps_leading = xml_most_laps_leading }
345
346
347 -- | This allows us to insert the XML representation
348 -- 'AutoRacingResultsRaceInformationXml' directly.
349 --
350 instance XmlImportFk AutoRacingResultsRaceInformationXml
351
352
353
354 --
355 -- * Database stuff.
356 --
357
358 instance DbImport Message where
359 dbmigrate _ =
360 run_dbmigrate $ do
361 migrate (undefined :: AutoRacingResults)
362 migrate (undefined :: AutoRacingResultsListing)
363 migrate (undefined :: AutoRacingResultsRaceInformation)
364
365 -- | We insert the message, then use its ID to insert the listings
366 -- and race information.
367 dbimport m = do
368 msg_id <- insert_xml m
369
370 insert_xml_fk_ msg_id (xml_race_information m)
371
372 forM_ (xml_listings m) $ insert_xml_fk_ msg_id
373
374 return ImportSucceeded
375
376
377
378 mkPersist tsn_codegen_config [groundhog|
379 - entity: AutoRacingResults
380 dbName: auto_racing_results
381 constructors:
382 - name: AutoRacingResults
383 uniques:
384 - name: unique_auto_racing_results
385 type: constraint
386 # Prevent multiple imports of the same message.
387 fields: [db_xml_file_id]
388
389
390 - entity: AutoRacingResultsListing
391 dbName: auto_racing_results_listings
392 constructors:
393 - name: AutoRacingResultsListing
394 fields:
395 - name: db_auto_racing_results_id
396 reference:
397 onDelete: cascade
398
399 # Note the apostrophe in the foreign key. This is to disambiguate
400 # it from the AutoRacingResultsListing foreign key of the same name.
401 # We strip it out of the dbName.
402 - entity: AutoRacingResultsRaceInformation
403 dbName: auto_racing_results_race_information
404 constructors:
405 - name: AutoRacingResultsRaceInformation
406 fields:
407 - name: db_auto_racing_results_id'
408 dbName: auto_racing_results_id
409 reference:
410 onDelete: cascade
411 - name: db_most_laps_leading
412 embeddedType:
413 - {name: most_laps_leading_driver_id,
414 dbName: most_laps_leading_driver_id}
415 - {name: most_laps_leading_driver,
416 dbName: most_laps_leading_driver}
417
418 - embedded: MostLapsLeading
419 fields:
420 - name: db_most_laps_leading_driver_id
421 dbName: most_laps_leading_driver_id
422 - name: db_most_laps_leading_driver
423 dbName: most_laps_leading_driver
424 - name: db_most_laps_leading_number_of_laps
425 dbName: most_laps_leading_number_of_laps
426 |]
427
428
429 ---
430 --- Pickling
431 ---
432
433 -- | Pickler for the \<Listing\>s contained within \<message\>s.
434 --
435 pickle_listing :: PU AutoRacingResultsListingXml
436 pickle_listing =
437 xpElem "Listing" $
438 xpWrap (from_tuple, to_tuple) $
439 xp13Tuple (xpElem "FinishPosition" xpInt)
440 (xpElem "StartingPosition" xpInt)
441 (xpElem "CarNumber" xpInt)
442 (xpElem "DriverID" xpInt)
443 (xpElem "Driver" xpText)
444 (xpElem "CarMake" xpText)
445 (xpElem "Points" xpInt)
446 (xpElem "Laps_Completed" xpInt)
447 (xpElem "Laps_Leading" xpInt)
448 (xpElem "Status" $ xpOption xpText)
449 (xpOption $ xpElem "DNF" xpPrim)
450 (xpOption $ xpElem "NC" xpPrim)
451 (xpElem "Earnings" xp_earnings)
452 where
453 from_tuple = uncurryN AutoRacingResultsListingXml
454 to_tuple m = (xml_finish_position m,
455 xml_starting_position m,
456 xml_car_number m,
457 xml_driver_id m,
458 xml_driver m,
459 xml_car_make m,
460 xml_points m,
461 xml_laps_completed m,
462 xml_laps_leading m,
463 xml_status m,
464 xml_dnf m,
465 xml_nc m,
466 xml_earnings m)
467
468
469 -- | Pickler for the top-level 'Message'.
470 --
471 pickle_message :: PU Message
472 pickle_message =
473 xpElem "message" $
474 xpWrap (from_tuple, to_tuple) $
475 xp13Tuple (xpElem "XML_File_ID" xpInt)
476 (xpElem "heading" xpText)
477 (xpElem "category" xpText)
478 (xpElem "sport" xpText)
479 (xpElem "RaceID" xpInt)
480 (xpElem "RaceDate" xp_datetime)
481 (xpElem "Title" xpText)
482 (xpElem "Track_Location" xpText)
483 (xpElem "Laps_Remaining" xpInt)
484 (xpElem "Checkered_Flag" xpPrim)
485 (xpList pickle_listing)
486 pickle_race_information
487 (xpElem "time_stamp" xp_time_stamp)
488 where
489 from_tuple = uncurryN Message
490 to_tuple m = (xml_xml_file_id m,
491 xml_heading m,
492 xml_category m,
493 xml_sport m,
494 xml_race_id m,
495 xml_race_date m,
496 xml_title m,
497 xml_track_location m,
498 xml_laps_remaining m,
499 xml_checkered_flag m,
500 xml_listings m,
501 xml_race_information m,
502 xml_time_stamp m)
503
504
505 -- | Pickler for the \<Most_Laps_Leading\> child of a
506 -- \<Race_Information\>.
507 --
508 pickle_most_laps_leading :: PU MostLapsLeading
509 pickle_most_laps_leading =
510 xpElem "Most_Laps_Leading" $
511 xpWrap (from_tuple, to_tuple) $
512 xpTriple (xpElem "DriverID" xpInt)
513 (xpElem "Driver" xpText)
514 (xpElem "NumberOfLaps" xpInt)
515 where
516 from_tuple = uncurryN MostLapsLeading
517 to_tuple m = (db_most_laps_leading_driver_id m,
518 db_most_laps_leading_driver m,
519 db_most_laps_leading_number_of_laps m)
520
521
522 -- | Pickler for the \<Race_Information\> child of \<message\>.
523 --
524 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
525 pickle_race_information =
526 xpElem "Race_Information" $
527 xpWrap (from_tuple, to_tuple) $
528 xp11Tuple (-- I can't think of another way to get both the
529 -- TrackLength and its KPH attribute. So we shove them
530 -- both in a 2-tuple. This should probably be an embedded type!
531 xpElem "TrackLength" $ xpPair xpText (xpAttr "KPH" xpPrim) )
532 (xpElem "Laps" xpInt)
533 (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
534 (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
535 (xpOption $ xpElem "AverageSpeed" xpPrim)
536 (xpOption $ xpElem "TimeOfRace" xpText)
537 (xpOption $ xpElem "MarginOfVictory" xpText)
538 (xpOption $ xpElem "Cautions" xpText)
539 (xpOption $ xpElem "LeadChanges" xpText)
540 (xpOption $ xpElem "LapLeaders" xpText)
541 pickle_most_laps_leading
542 where
543 -- Derp. Since the first two are paired, we have to
544 -- manually unpack the bazillion arguments.
545 from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
546 AutoRacingResultsRaceInformationXml
547 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
548
549 -- And here we have to re-pair the first two.
550 to_tuple m = ((xml_track_length m, xml_track_length_kph m),
551 xml_laps m,
552 xml_average_speed_mph m,
553 xml_average_speed_kph m,
554 xml_average_speed m,
555 xml_time_of_race m,
556 xml_margin_of_victory m,
557 xml_cautions m,
558 xml_lead_changes m,
559 xml_lap_leaders m,
560 xml_most_laps_leading m)
561
562 --
563 -- Tasty Tests
564 --
565
566 -- | A list of all tests for this module.
567 --
568 auto_racing_results_tests :: TestTree
569 auto_racing_results_tests =
570 testGroup
571 "AutoRacingResults tests"
572 [ test_on_delete_cascade,
573 test_pickle_of_unpickle_is_identity,
574 test_unpickle_succeeds ]
575
576 -- | If we unpickle something and then pickle it, we should wind up
577 -- with the same thing we started with. WARNING: success of this
578 -- test does not mean that unpickling succeeded.
579 --
580 test_pickle_of_unpickle_is_identity :: TestTree
581 test_pickle_of_unpickle_is_identity =
582 testCase "pickle composed with unpickle is the identity" $ do
583 let path = "test/xml/AutoRacingResultsXML.xml"
584 (expected, actual) <- pickle_unpickle pickle_message path
585 actual @?= expected
586
587
588
589 -- | Make sure we can actually unpickle these things.
590 --
591 test_unpickle_succeeds :: TestTree
592 test_unpickle_succeeds =
593 testCase "unpickling succeeds" $ do
594 let path = "test/xml/AutoRacingResultsXML.xml"
595 actual <- unpickleable path pickle_message
596
597 let expected = True
598 actual @?= expected
599
600
601
602 -- | Make sure everything gets deleted when we delete the top-level
603 -- record.
604 --
605 test_on_delete_cascade :: TestTree
606 test_on_delete_cascade =
607 testCase "deleting auto_racing_results deletes its children" $ do
608 let path = "test/xml/AutoRacingResultsXML.xml"
609 results <- unsafe_unpickle path pickle_message
610 let a = undefined :: AutoRacingResults
611 let b = undefined :: AutoRacingResultsListing
612 let c = undefined :: AutoRacingResultsRaceInformation
613
614 actual <- withSqliteConn ":memory:" $ runDbConn $ do
615 runMigration silentMigrationLogger $ do
616 migrate a
617 migrate b
618 migrate c
619 _ <- dbimport results
620 deleteAll a
621 count_a <- countAll a
622 count_b <- countAll b
623 count_c <- countAll c
624 return $ sum [count_a, count_b, count_c]
625 let expected = 0
626 actual @?= expected