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   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 FromXmlFk 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   -- | To convert an 'AutoRacingResultsListingXml' to an
 220   --   'AutoRacingResultsListing', we add the foreign key and copy
 221   --   everything else verbatim.
 222   --
 223   from_xml_fk fk AutoRacingResultsListingXml{..} =
 224     AutoRacingResultsListing {
 225       db_auto_racing_results_id = fk,
 226       db_finish_position = xml_finish_position,
 227       db_starting_position = xml_starting_position,
 228       db_car_number = xml_car_number,
 229       db_driver_id = xml_driver_id,
 230       db_driver = xml_driver,
 231       db_car_make = xml_car_make,
 232       db_points = xml_points,
 233       db_laps_completed = xml_laps_completed,
 234       db_laps_leading = xml_laps_leading,
 235       db_status = xml_status,
 236       db_dnf = xml_dnf,
 237       db_nc = xml_nc,
 238       db_earnings = xml_earnings }
 239
 240
 241 -- | This allows us to insert the XML representation
 242 --   'AutoRacingResultsListingXml' directly.
 243 --
 244 instance XmlImportFk AutoRacingResultsListingXml
 245
 246
 247
 248 -- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml
 249
 250 -- | The \<Most_Laps_Leading\> child of \<Race_Information\> always
 251 --   contains exactly three fields, so we just embed those three into
 252 --   the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use
 253 --   the \"db_\" prefix since our field namer is going to strip of
 254 --   everything before the first underscore.
 255 --
 256 data MostLapsLeading =
 257   MostLapsLeading {
 258     db_most_laps_leading_driver_id :: Int,
 259     db_most_laps_leading_driver :: String,
 260     db_most_laps_leading_number_of_laps :: Int }
 261   deriving (Data, Eq, Show, Typeable)
 262
 263
 264 -- | Database representation of a \<Race_Information\> contained
 265 --   within a \<message\>.
 266 --
 267 data AutoRacingResultsRaceInformation =
 268   AutoRacingResultsRaceInformation {
 269     -- Note the apostrophe to disambiguate it from the
 270     -- AutoRacingResultsListing field.
 271     db_auto_racing_results_id' :: DefaultKey AutoRacingResults,
 272     db_track_length :: Double,
 273     db_track_length_kph :: Double,
 274     db_laps :: Int,
 275     db_average_speed_mph :: Maybe Double,
 276     db_average_speed_kph :: Maybe Double,
 277     db_average_speed :: Maybe Double,
 278     db_time_of_race :: Maybe String,
 279     db_margin_of_victory :: Maybe String,
 280     db_cautions :: Maybe String,
 281     db_lead_changes :: Maybe String,
 282     db_lap_leaders :: Maybe String,
 283     db_most_laps_leading :: MostLapsLeading }
 284
 285
 286 -- | XML representation of a \<Listing\> contained within a
 287 --   \<message\>.
 288 --
 289 data AutoRacingResultsRaceInformationXml =
 290   AutoRacingResultsRaceInformationXml {
 291     xml_track_length :: Double,
 292     xml_track_length_kph :: Double,
 293     xml_laps :: Int,
 294     xml_average_speed_mph :: Maybe Double,
 295     xml_average_speed_kph :: Maybe Double,
 296     xml_average_speed :: Maybe Double,
 297     xml_time_of_race :: Maybe String,
 298     xml_margin_of_victory :: Maybe String,
 299     xml_cautions :: Maybe String,
 300     xml_lead_changes :: Maybe String,
 301     xml_lap_leaders :: Maybe String,
 302     xml_most_laps_leading :: MostLapsLeading }
 303   deriving (Eq,Show)
 304
 305
 306 instance ToDb AutoRacingResultsRaceInformationXml where
 307   -- | The database analogue of an
 308   --   'AutoRacingResultsRaceInformationXml' is an
 309   --   'AutoRacingResultsRaceInformation'.
 310   --
 311   type Db AutoRacingResultsRaceInformationXml =
 312     AutoRacingResultsRaceInformation
 313
 314 instance FromXmlFk AutoRacingResultsRaceInformationXml where
 315   -- | Each 'AutoRacingResultsRaceInformationXml' is contained in
 316   --   (i.e. has a foreign key to) a 'AutoRacingResults'.
 317   --
 318   type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults
 319
 320   -- | To convert an 'AutoRacingResultsRaceInformationXml' to an
 321   --   'AutoRacingResultsRaceInformartion', we add the foreign key and
 322   --   copy everything else verbatim.
 323   --
 324   from_xml_fk fk AutoRacingResultsRaceInformationXml{..} =
 325     AutoRacingResultsRaceInformation {
 326       db_auto_racing_results_id' = fk,
 327       db_track_length = xml_track_length,
 328       db_track_length_kph = xml_track_length_kph,
 329       db_laps = xml_laps,
 330       db_average_speed_mph = xml_average_speed_mph,
 331       db_average_speed_kph = xml_average_speed_kph,
 332       db_average_speed = xml_average_speed,
 333       db_time_of_race = xml_time_of_race,
 334       db_margin_of_victory = xml_margin_of_victory,
 335       db_cautions = xml_cautions,
 336       db_lead_changes = xml_lead_changes,
 337       db_lap_leaders = xml_lap_leaders,
 338       db_most_laps_leading = xml_most_laps_leading }
 339
 340
 341 -- | This allows us to insert the XML representation
 342 --   'AutoRacingResultsRaceInformationXml' directly.
 343 --
 344 instance XmlImportFk AutoRacingResultsRaceInformationXml
 345
 346
 347
 348 ---
 349 --- Database stuff.
 350 ---
 351
 352 instance DbImport Message where
 353   dbmigrate _ =
 354     run_dbmigrate $ do
 355       migrate (undefined :: AutoRacingResults)
 356       migrate (undefined :: AutoRacingResultsListing)
 357       migrate (undefined :: AutoRacingResultsRaceInformation)
 358
 359   -- | We insert the message, then use its ID to insert the listings
 360   --   and race information.
 361   dbimport m = do
 362     msg_id <- insert_xml m
 363
 364     insert_xml_fk_ msg_id (xml_race_information m)
 365
 366     forM_ (xml_listings m) $ \listing -> do
 367       insert_xml_fk_ msg_id listing
 368
 369     return ImportSucceeded
 370
 371
 372
 373 mkPersist tsn_codegen_config [groundhog|
 374 - entity: AutoRacingResults
 375   dbName: auto_racing_results
 376   constructors:
 377     - name: AutoRacingResults
 378       uniques:
 379         - name: unique_auto_racing_schedule
 380           type: constraint
 381           # Prevent multiple imports of the same message.
 382           fields: [db_xml_file_id]
 383
 384
 385 - entity: AutoRacingResultsListing
 386   dbName: auto_racing_results_listings
 387   constructors:
 388     - name: AutoRacingResultsListing
 389       fields:
 390         - name: db_auto_racing_results_id
 391           reference:
 392             onDelete: cascade
 393
 394 # Note the apostrophe in the foreign key. This is to disambiguate
 395 # it from the AutoRacingResultsListing foreign key of the same name.
 396 # We strip it out of the dbName.
 397 - entity: AutoRacingResultsRaceInformation
 398   dbName: auto_racing_results_race_information
 399   constructors:
 400     - name: AutoRacingResultsRaceInformation
 401       fields:
 402         - name: db_auto_racing_results_id'
 403           dbName: auto_racing_results_id
 404           reference:
 405             onDelete: cascade
 406         - name: db_most_laps_leading
 407           embeddedType:
 408             - {name: most_laps_leading_driver_id,
 409                dbName: most_laps_leading_driver_id}
 410             - {name: most_laps_leading_driver,
 411                dbName: most_laps_leading_driver}
 412
 413 - embedded: MostLapsLeading
 414   fields:
 415     - name: db_most_laps_leading_driver_id
 416       dbName: most_laps_leading_driver_id
 417     - name: db_most_laps_leading_driver
 418       dbName: most_laps_leading_driver
 419     - name: db_most_laps_leading_number_of_laps
 420       dbName: most_laps_leading_number_of_laps
 421 |]
 422
 423
 424 ---
 425 --- Pickling
 426 ---
 427
 428 -- | Pickler for the \<Listing\>s contained within \<message\>s.
 429 --
 430 pickle_listing :: PU AutoRacingResultsListingXml
 431 pickle_listing =
 432   xpElem "Listing" $
 433     xpWrap (from_tuple, to_tuple) $
 434     xp13Tuple (xpElem "FinishPosition" xpInt)
 435               (xpElem "StartingPosition" xpInt)
 436               (xpElem "CarNumber" xpInt)
 437               (xpElem "DriverID" xpInt)
 438               (xpElem "Driver" xpText)
 439               (xpElem "CarMake" xpText)
 440               (xpElem "Points" xpInt)
 441               (xpElem "Laps_Completed" xpInt)
 442               (xpElem "Laps_Leading" xpInt)
 443               (xpElem "Status" $ xpOption xpText)
 444               (xpOption $ xpElem "DNF" xpPrim)
 445               (xpOption $ xpElem "NC" xpPrim)
 446               (xpElem "Earnings" xp_earnings)
 447   where
 448     from_tuple = uncurryN AutoRacingResultsListingXml
 449     to_tuple m = (xml_finish_position m,
 450                   xml_starting_position m,
 451                   xml_car_number m,
 452                   xml_driver_id m,
 453                   xml_driver m,
 454                   xml_car_make m,
 455                   xml_points m,
 456                   xml_laps_completed m,
 457                   xml_laps_leading m,
 458                   xml_status m,
 459                   xml_dnf m,
 460                   xml_nc m,
 461                   xml_earnings m)
 462
 463
 464 -- | Pickler for the top-level 'Message'.
 465 --
 466 pickle_message :: PU Message
 467 pickle_message =
 468   xpElem "message" $
 469     xpWrap (from_tuple, to_tuple) $
 470     xp13Tuple (xpElem "XML_File_ID" xpInt)
 471               (xpElem "heading" xpText)
 472               (xpElem "category" xpText)
 473               (xpElem "sport" xpText)
 474               (xpElem "RaceID" xpInt)
 475               (xpElem "RaceDate" xp_datetime)
 476               (xpElem "Title" xpText)
 477               (xpElem "Track_Location" xpText)
 478               (xpElem "Laps_Remaining" xpInt)
 479               (xpElem "Checkered_Flag" xpPrim)
 480               (xpList pickle_listing)
 481               pickle_race_information
 482               (xpElem "time_stamp" xp_time_stamp)
 483   where
 484     from_tuple = uncurryN Message
 485     to_tuple m = (xml_xml_file_id m,
 486                   xml_heading m,
 487                   xml_category m,
 488                   xml_sport m,
 489                   xml_race_id m,
 490                   xml_race_date m,
 491                   xml_title m,
 492                   xml_track_location m,
 493                   xml_laps_remaining m,
 494                   xml_checkered_flag m,
 495                   xml_listings m,
 496                   xml_race_information m,
 497                   xml_time_stamp m)
 498
 499
 500 -- | Pickler for the \<Most_Laps_Leading\> child of a
 501 --   \<Race_Information\>.
 502 --
 503 pickle_most_laps_leading :: PU MostLapsLeading
 504 pickle_most_laps_leading =
 505   xpElem "Most_Laps_Leading" $
 506     xpWrap (from_tuple, to_tuple) $
 507     xpTriple (xpElem "DriverID" xpInt)
 508              (xpElem "Driver" xpText)
 509              (xpElem "NumberOfLaps" xpInt)
 510   where
 511     from_tuple = uncurryN MostLapsLeading
 512     to_tuple m = (db_most_laps_leading_driver_id m,
 513                   db_most_laps_leading_driver m,
 514                   db_most_laps_leading_number_of_laps m)
 515
 516
 517 -- | Pickler for the \<Race_Information\> child of \<message\>.
 518 --
 519 pickle_race_information :: PU AutoRacingResultsRaceInformationXml
 520 pickle_race_information =
 521   xpElem "Race_Information" $
 522     xpWrap (from_tuple, to_tuple) $
 523     xp11Tuple (-- I can't think of another way to get both the
 524                -- TrackLength and its KPH attribute. So we shove them
 525                -- both in a 2-tuple. This should probably be an embedded type!
 526                  xpElem "TrackLength" $ xpPair xpPrim (xpAttr "KPH" xpPrim) )
 527               (xpElem "Laps" xpInt)
 528               (xpOption $ xpElem "AverageSpeedMPH" xpPrim)
 529               (xpOption $ xpElem "AverageSpeedKPH" xpPrim)
 530               (xpOption $ xpElem "AverageSpeed" xpPrim)
 531               (xpOption $ xpElem "TimeOfRace" xpText)
 532               (xpOption $ xpElem "MarginOfVictory" xpText)
 533               (xpOption $ xpElem "Cautions" xpText)
 534               (xpOption $ xpElem "LeadChanges" xpText)
 535               (xpOption $ xpElem "LapLeaders" xpText)
 536               pickle_most_laps_leading
 537   where
 538     -- Derp. Since the first two are paired, we have to
 539     -- manually unpack the bazillion arguments.
 540     from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) =
 541         AutoRacingResultsRaceInformationXml
 542           x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
 543
 544     -- And here we have to re-pair the first two.
 545     to_tuple m = ((xml_track_length m, xml_track_length_kph m),
 546                   xml_laps m,
 547                   xml_average_speed_mph m,
 548                   xml_average_speed_kph m,
 549                   xml_average_speed m,
 550                   xml_time_of_race m,
 551                   xml_margin_of_victory m,
 552                   xml_cautions m,
 553                   xml_lead_changes m,
 554                   xml_lap_leaders m,
 555                   xml_most_laps_leading m)
 556
 557 --
 558 -- Tasty Tests
 559 --
 560
 561 -- | A list of all tests for this module.
 562 --
 563 auto_racing_results_tests :: TestTree
 564 auto_racing_results_tests =
 565   testGroup
 566     "AutoRacingResults tests"
 567     [ test_on_delete_cascade,
 568       test_pickle_of_unpickle_is_identity,
 569       test_unpickle_succeeds ]
 570
 571 -- | If we unpickle something and then pickle it, we should wind up
 572 --   with the same thing we started with. WARNING: success of this
 573 --   test does not mean that unpickling succeeded.
 574 --
 575 test_pickle_of_unpickle_is_identity :: TestTree
 576 test_pickle_of_unpickle_is_identity =
 577   testCase "pickle composed with unpickle is the identity" $ do
 578     let path = "test/xml/AutoRacingResultsXML.xml"
 579     (expected, actual) <- pickle_unpickle pickle_message path
 580     actual @?= expected
 581
 582
 583
 584 -- | Make sure we can actually unpickle these things.
 585 --
 586 test_unpickle_succeeds :: TestTree
 587 test_unpickle_succeeds =
 588   testCase "unpickling succeeds" $ do
 589     let path = "test/xml/AutoRacingResultsXML.xml"
 590     actual <- unpickleable path pickle_message
 591
 592     let expected = True
 593     actual @?= expected
 594
 595
 596
 597 -- | Make sure everything gets deleted when we delete the top-level
 598 --   record.
 599 --
 600 test_on_delete_cascade :: TestTree
 601 test_on_delete_cascade =
 602   testCase "deleting auto_racing_results deletes its children" $ do
 603     let path = "test/xml/AutoRacingResultsXML.xml"
 604     results <- unsafe_unpickle path pickle_message
 605     let a = undefined :: AutoRacingResults
 606     let b = undefined :: AutoRacingResultsListing
 607     let c = undefined :: AutoRacingResultsRaceInformation
 608
 609     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 610                 runMigration silentMigrationLogger $ do
 611                   migrate a
 612                   migrate b
 613                   migrate c
 614                 _ <- dbimport results
 615                 deleteAll a
 616                 count_a <- countAll a
 617                 count_b <- countAll b
 618                 count_c <- countAll c
 619                 return $ sum [count_a, count_b, count_c]
 620     let expected = 0
 621     actual @?= expected