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