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