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 ( 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