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