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) $ \listing -> do
 374       insert_xml_fk_ msg_id listing
 375
 376     return ImportSucceeded
 377
 378
 379
 380 mkPersist tsn_codegen_config [groundhog|
 381 - entity: AutoRacingResults
 382   dbName: auto_racing_results
 383   constructors:
 384     - name: AutoRacingResults
 385       uniques:
 386         - name: unique_auto_racing_schedule
 387           type: constraint
 388           # Prevent multiple imports of the same message.
 389           fields: [db_xml_file_id]
 390
 391
 392 - entity: AutoRacingResultsListing
 393   dbName: auto_racing_results_listings
 394   constructors:
 395     - name: AutoRacingResultsListing
 396       fields:
 397         - name: db_auto_racing_results_id
 398           reference:
 399             onDelete: cascade
 400
 401 # Note the apostrophe in the foreign key. This is to disambiguate
 402 # it from the AutoRacingResultsListing foreign key of the same name.
 403 # We strip it out of the dbName.
 404 - entity: AutoRacingResultsRaceInformation
 405   dbName: auto_racing_results_race_information
 406   constructors:
 407     - name: AutoRacingResultsRaceInformation
 408       fields:
 409         - name: db_auto_racing_results_id'
 410           dbName: auto_racing_results_id
 411           reference:
 412             onDelete: cascade
 413         - name: db_most_laps_leading
 414           embeddedType:
 415             - {name: most_laps_leading_driver_id,
 416                dbName: most_laps_leading_driver_id}
 417             - {name: most_laps_leading_driver,
 418                dbName: most_laps_leading_driver}
 419
 420 - embedded: MostLapsLeading
 421   fields:
 422     - name: db_most_laps_leading_driver_id
 423       dbName: most_laps_leading_driver_id
 424     - name: db_most_laps_leading_driver
 425       dbName: most_laps_leading_driver
 426     - name: db_most_laps_leading_number_of_laps
 427       dbName: most_laps_leading_number_of_laps
 428 |]
 429
 430
 431 ---
 432 --- Pickling
 433 ---
 434
 435 -- | Pickler for the \<Listing\>s contained within \<message\>s.
 436 --
 437 pickle_listing :: PU AutoRacingResultsListingXml
 438 pickle_listing =
 439   xpElem "Listing" $
 440     xpWrap (from_tuple, to_tuple) $
 441     xp13Tuple (xpElem "FinishPosition" xpInt)
 442               (xpElem "StartingPosition" xpInt)
 443               (xpElem "CarNumber" xpInt)
 444               (xpElem "DriverID" xpInt)
 445               (xpElem "Driver" xpText)
 446               (xpElem "CarMake" xpText)
 447               (xpElem "Points" xpInt)
 448               (xpElem "Laps_Completed" xpInt)
 449               (xpElem "Laps_Leading" xpInt)
 450               (xpElem "Status" $ xpOption xpText)
 451               (xpOption $ xpElem "DNF" xpPrim)
 452               (xpOption $ xpElem "NC" xpPrim)
 453               (xpElem "Earnings" xp_earnings)
 454   where
 455     from_tuple = uncurryN AutoRacingResultsListingXml
 456     to_tuple m = (xml_finish_position m,
 457                   xml_starting_position m,
 458                   xml_car_number m,
 459                   xml_driver_id m,
 460                   xml_driver m,
 461                   xml_car_make m,
 462                   xml_points m,
 463                   xml_laps_completed m,
 464                   xml_laps_leading m,
 465                   xml_status m,
 466                   xml_dnf m,
 467                   xml_nc m,
 468                   xml_earnings m)
 469
 470
 471 -- | Pickler for the top-level 'Message'.
 472 --
 473 pickle_message :: PU Message
 474 pickle_message =
 475   xpElem "message" $
 476     xpWrap (from_tuple, to_tuple) $
 477     xp13Tuple (xpElem "XML_File_ID" xpInt)
 478               (xpElem "heading" xpText)
 479               (xpElem "category" xpText)
 480               (xpElem "sport" xpText)
 481               (xpElem "RaceID" xpInt)
 482               (xpElem "RaceDate" xp_datetime)
 483               (xpElem "Title" xpText)
 484               (xpElem "Track_Location" xpText)
 485               (xpElem "Laps_Remaining" xpInt)
 486               (xpElem "Checkered_Flag" xpPrim)
 487               (xpList pickle_listing)
 488               pickle_race_information
 489               (xpElem "time_stamp" xp_time_stamp)
 490   where
 491     from_tuple = uncurryN Message
 492     to_tuple m = (xml_xml_file_id m,
 493                   xml_heading m,
 494                   xml_category m,
 495                   xml_sport m,
 496                   xml_race_id m,
 497                   xml_race_date m,
 498                   xml_title m,
 499                   xml_track_location m,
 500                   xml_laps_remaining m,
 501                   xml_checkered_flag m,
 502                   xml_listings m,
 503                   xml_race_information m,
 504                   xml_time_stamp m)
 505
 506
 507 -- | Pickler for the \<Most_Laps_Leading\> child of a
 508 --   \<Race_Information\>.
 509 --
 510 pickle_most_laps_leading :: PU MostLapsLeading
 511 pickle_most_laps_leading =
 512   xpElem "Most_Laps_Leading" $
 513     xpWrap (from_tuple, to_tuple) $
 514     xpTriple (xpElem "DriverID" xpInt)
 515              (xpElem "Driver" xpText)
 516              (xpElem "NumberOfLaps" xpInt)
 517   where
 518     from_tuple = uncurryN MostLapsLeading
 519     to_tuple m = (db_most_laps_leading_driver_id m,
 520                   db_most_laps_leading_driver m,
 521                   db_most_laps_leading_number_of_laps m)
 522
 523
 524 -- | Pickler for the \<Race_Information\> child of \<message\>.
 525 --
 526 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
 527 pickle_race_information =
 528   xpElem "Race_Information" $
 529     xpWrap (from_tuple, to_tuple) $
 530     xp11Tuple (-- I can't think of another way to get both the
 531                -- TrackLength and its KPH attribute. So we shove them
 532                -- both in a 2-tuple. This should probably be an embedded type!
 533                  xpElem "TrackLength" $ xpPair xpText (xpAttr "KPH" xpPrim) )
 534               (xpElem "Laps" xpInt)
 535               (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
 536               (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
 537               (xpOption $ xpElem "AverageSpeed" xpPrim)
 538               (xpOption $ xpElem "TimeOfRace" xpText)
 539               (xpOption $ xpElem "MarginOfVictory" xpText)
 540               (xpOption $ xpElem "Cautions" xpText)
 541               (xpOption $ xpElem "LeadChanges" xpText)
 542               (xpOption $ xpElem "LapLeaders" xpText)
 543               pickle_most_laps_leading
 544   where
 545     -- Derp. Since the first two are paired, we have to
 546     -- manually unpack the bazillion arguments.
 547     from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
 548         AutoRacingResultsRaceInformationXml
 549           x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
 550
 551     -- And here we have to re-pair the first two.
 552     to_tuple m = ((xml_track_length m, xml_track_length_kph m),
 553                   xml_laps m,
 554                   xml_average_speed_mph m,
 555                   xml_average_speed_kph m,
 556                   xml_average_speed m,
 557                   xml_time_of_race m,
 558                   xml_margin_of_victory m,
 559                   xml_cautions m,
 560                   xml_lead_changes m,
 561                   xml_lap_leaders m,
 562                   xml_most_laps_leading m)
 563
 564 --
 565 -- Tasty Tests
 566 --
 567
 568 -- | A list of all tests for this module.
 569 --
 570 auto_racing_results_tests :: TestTree
 571 auto_racing_results_tests =
 572   testGroup
 573     "AutoRacingResults tests"
 574     [ test_on_delete_cascade,
 575       test_pickle_of_unpickle_is_identity,
 576       test_unpickle_succeeds ]
 577
 578 -- | If we unpickle something and then pickle it, we should wind up
 579 --   with the same thing we started with. WARNING: success of this
 580 --   test does not mean that unpickling succeeded.
 581 --
 582 test_pickle_of_unpickle_is_identity :: TestTree
 583 test_pickle_of_unpickle_is_identity =
 584   testCase "pickle composed with unpickle is the identity" $ do
 585     let path = "test/xml/AutoRacingResultsXML.xml"
 586     (expected, actual) <- pickle_unpickle pickle_message path
 587     actual @?= expected
 588
 589
 590
 591 -- | Make sure we can actually unpickle these things.
 592 --
 593 test_unpickle_succeeds :: TestTree
 594 test_unpickle_succeeds =
 595   testCase "unpickling succeeds" $ do
 596     let path = "test/xml/AutoRacingResultsXML.xml"
 597     actual <- unpickleable path pickle_message
 598
 599     let expected = True
 600     actual @?= expected
 601
 602
 603
 604 -- | Make sure everything gets deleted when we delete the top-level
 605 --   record.
 606 --
 607 test_on_delete_cascade :: TestTree
 608 test_on_delete_cascade =
 609   testCase "deleting auto_racing_results deletes its children" $ do
 610     let path = "test/xml/AutoRacingResultsXML.xml"
 611     results <- unsafe_unpickle path pickle_message
 612     let a = undefined :: AutoRacingResults
 613     let b = undefined :: AutoRacingResultsListing
 614     let c = undefined :: AutoRacingResultsRaceInformation
 615
 616     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 617                 runMigration silentMigrationLogger $ do
 618                   migrate a
 619                   migrate b
 620                   migrate c
 621                 _ <- dbimport results
 622                 deleteAll a
 623                 count_a <- countAll a
 624                 count_b <- countAll b
 625                 count_c <- countAll c
 626                 return $ sum [count_a, count_b, count_c]
 627     let expected = 0
 628     actual @?= expected