src/TSN/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 :: String, -- ^ Usually a Double, but sometimes a String,
 276                                --   like \"1.25 miles\".
 277     db_track_length_kph :: Double,
 278     db_laps :: Int,
 279     db_average_speed_mph :: Maybe Double,
 280     db_average_speed_kph :: Maybe Double,
 281     db_average_speed :: Maybe Double,
 282     db_time_of_race :: Maybe String,
 283     db_margin_of_victory :: Maybe String,
 284     db_cautions :: Maybe String,
 285     db_lead_changes :: Maybe String,
 286     db_lap_leaders :: Maybe String,
 287     db_most_laps_leading :: MostLapsLeading }
 288
 289
 290 -- | XML representation of a \<Listing\> contained within a
 291 --   \<message\>.
 292 --
 293 data AutoRacingResultsRaceInformationXml =
 294   AutoRacingResultsRaceInformationXml {
 295     xml_track_length :: String,
 296     xml_track_length_kph :: Double,
 297     xml_laps :: Int,
 298     xml_average_speed_mph :: Maybe Double,
 299     xml_average_speed_kph :: Maybe Double,
 300     xml_average_speed :: Maybe Double,
 301     xml_time_of_race :: Maybe String,
 302     xml_margin_of_victory :: Maybe String,
 303     xml_cautions :: Maybe String,
 304     xml_lead_changes :: Maybe String,
 305     xml_lap_leaders :: Maybe String,
 306     xml_most_laps_leading :: MostLapsLeading }
 307   deriving (Eq,Show)
 308
 309
 310 instance ToDb AutoRacingResultsRaceInformationXml where
 311   -- | The database analogue of an
 312   --   'AutoRacingResultsRaceInformationXml' is an
 313   --   'AutoRacingResultsRaceInformation'.
 314   --
 315   type Db AutoRacingResultsRaceInformationXml =
 316     AutoRacingResultsRaceInformation
 317
 318
 319 instance Child AutoRacingResultsRaceInformationXml where
 320   -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
 321   --   (i.e. has a foreign key to) a 'AutoRacingResults'.
 322   --
 323   type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
 324
 325
 326 instance FromXmlFk AutoRacingResultsRaceInformationXml where
 327   -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
 328   --   'AutoRacingResultsRaceInformartion', we add the foreign key and
 329   --   copy everything else verbatim.
 330   --
 331   from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
 332     AutoRacingResultsRaceInformation {
 333       db_auto_racing_results_id' = fk,
 334       db_track_length = xml_track_length,
 335       db_track_length_kph = xml_track_length_kph,
 336       db_laps = xml_laps,
 337       db_average_speed_mph = xml_average_speed_mph,
 338       db_average_speed_kph = xml_average_speed_kph,
 339       db_average_speed = xml_average_speed,
 340       db_time_of_race = xml_time_of_race,
 341       db_margin_of_victory = xml_margin_of_victory,
 342       db_cautions = xml_cautions,
 343       db_lead_changes = xml_lead_changes,
 344       db_lap_leaders = xml_lap_leaders,
 345       db_most_laps_leading = xml_most_laps_leading }
 346
 347
 348 -- | This allows us to insert the XML representation
 349 --   'AutoRacingResultsRaceInformationXml' directly.
 350 --
 351 instance XmlImportFk AutoRacingResultsRaceInformationXml
 352
 353
 354
 355 ---
 356 --- Database stuff.
 357 ---
 358
 359 instance DbImport Message where
 360   dbmigrate _ =
 361     run_dbmigrate $ do
 362       migrate (undefined :: AutoRacingResults)
 363       migrate (undefined :: AutoRacingResultsListing)
 364       migrate (undefined :: AutoRacingResultsRaceInformation)
 365
 366   -- | We insert the message, then use its ID to insert the listings
 367   --   and race information.
 368   dbimport m = do
 369     msg_id <- insert_xml m
 370
 371     insert_xml_fk_ msg_id (xml_race_information m)
 372
 373     forM_ (xml_listings m) $ insert_xml_fk_ msg_id
 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 xpText (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