src/TSN/XML/AutoRacingSchedule.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD
  11 --   \"Auto_Racing_Schedule_XML.dtd\". There's a top-level
  12 --   \<message\>, containing \<Listing\>s, containing \<RaceResults\>,
  13 --   containing \<RaceResultsListing\>s.
  14 --
  15 module TSN.XML.AutoRacingSchedule (
  16   pickle_message,
  17   -- * Tests
  18   auto_racing_schedule_tests,
  19   -- * WARNING: these are private but exported to silence warnings
  20   AutoRacingScheduleConstructor(..),
  21   AutoRacingScheduleListingConstructor(..),
  22   AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
  23 where
  24
  25 -- System imports.
  26 import Control.Monad ( forM_ )
  27 import Data.Time ( UTCTime(..) )
  28 import Data.Tuple.Curry ( uncurryN )
  29 import Database.Groundhog (
  30   countAll,
  31   executeRaw,
  32   migrate,
  33   runMigration,
  34   silentMigrationLogger )
  35 import Database.Groundhog.Core ( DefaultKey )
  36 import Database.Groundhog.Generic ( runDbConn )
  37 import Database.Groundhog.Sqlite ( withSqliteConn )
  38 import Database.Groundhog.TH (
  39   groundhog,
  40   mkPersist )
  41 import Test.Tasty ( TestTree, testGroup )
  42 import Test.Tasty.HUnit ( (@?=), testCase )
  43 import Text.XML.HXT.Core (
  44   PU,
  45   xp7Tuple,
  46   xp8Tuple,
  47   xp10Tuple,
  48   xpElem,
  49   xpInt,
  50   xpList,
  51   xpOption,
  52   xpText,
  53   xpWrap )
  54
  55 -- Local imports.
  56 import TSN.Codegen (
  57   tsn_codegen_config )
  58 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  59 import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp )
  60 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  61 import Xml (
  62   FromXml(..),
  63   FromXmlFk(..),
  64   ToDb(..),
  65   pickle_unpickle,
  66   unpickleable,
  67   unsafe_unpickle )
  68
  69
  70 --
  71 -- DB/XML data types
  72 --
  73
  74 -- * AutoRacingSchedule/Message
  75
  76 -- | Database representation of a 'Message'.
  77 --
  78 data AutoRacingSchedule =
  79   AutoRacingSchedule {
  80     db_xml_file_id :: Int,
  81     db_heading :: String,
  82     db_category :: String,
  83     db_sport :: String,
  84     db_title :: String,
  85     db_complete_through :: String,
  86     db_time_stamp :: UTCTime }
  87   deriving (Eq, Show)
  88
  89
  90 -- | XML Representation of an 'AutoRacingSchedule'.
  91 --
  92 data Message =
  93   Message {
  94     xml_xml_file_id :: Int,
  95     xml_heading :: String,
  96     xml_category :: String,
  97     xml_sport :: String,
  98     xml_title :: String,
  99     xml_complete_through :: String,
 100     xml_listings :: [AutoRacingScheduleListingXml],
 101     xml_time_stamp :: UTCTime }
 102   deriving (Eq, Show)
 103
 104
 105 instance ToDb Message where
 106   -- | The database analogue of a 'Message' is a 'AutoRacingSchedule'.
 107   --
 108   type Db Message = AutoRacingSchedule
 109
 110
 111 -- | The 'FromXml' instance for 'Message' is required for the
 112 --   'XmlImport' instance.
 113 --
 114 instance FromXml Message where
 115   -- | To convert a 'Message' to an 'AutoRacingSchedule', we just drop
 116   --   the 'xml_listings'.
 117   --
 118   from_xml Message{..} =
 119     AutoRacingSchedule {
 120       db_xml_file_id = xml_xml_file_id,
 121       db_heading = xml_heading,
 122       db_category = xml_category,
 123       db_sport = xml_sport,
 124       db_title = xml_title,
 125       db_complete_through = xml_complete_through,
 126       db_time_stamp = xml_time_stamp }
 127
 128
 129 -- | This allows us to insert the XML representation 'Message'
 130 --   directly.
 131 --
 132 instance XmlImport Message
 133
 134
 135 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
 136
 137 -- | Database representation of a \<Listing\> contained within a
 138 --   \<Message\>. We combine the race date/time into a single
 139 --   race_time, drop the race results list, and add a foreign key to
 140 --   our parent.
 141 --
 142 data AutoRacingScheduleListing =
 143   AutoRacingScheduleListing {
 144     db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
 145     db_race_id :: Int,
 146     db_race_time :: UTCTime,
 147     db_race_name :: String,
 148     db_track_name :: String,
 149     db_location :: String,
 150     db_tv_listing :: Maybe String,
 151     db_laps :: Int,
 152     db_track_length :: String -- ^ Sometimes the word "miles" shows up.
 153   }
 154
 155
 156 -- | XML representation of a \<Listing\> contained within a
 157 --   \<message\>.
 158 --
 159 data AutoRacingScheduleListingXml =
 160   AutoRacingScheduleListingXml {
 161     xml_race_id :: Int,
 162     xml_race_date :: UTCTime,
 163     xml_race_time :: Maybe UTCTime,
 164     xml_race_name :: String,
 165     xml_track_name :: String,
 166     xml_location :: String,
 167     xml_tv_listing :: Maybe String,
 168     xml_laps :: Int,
 169     xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up,
 170                                 --   so we can't do the right thing and use
 171                                 --   a 'Double'.
 172     xml_race_results :: [AutoRacingScheduleListingRaceResult] }
 173   deriving (Eq, Show)
 174
 175
 176 -- | Pseudo-accessor to get the race result listings out of a
 177 --   'AutoRacingScheduleListingXml'. A poor man's lens.
 178 --
 179 result_listings :: AutoRacingScheduleListingXml
 180                 -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
 181 result_listings = (concatMap xml_race_result_listing) . xml_race_results
 182
 183
 184 instance ToDb AutoRacingScheduleListingXml where
 185   -- | The database analogue of an 'AutoRacingScheduleListingXml' is
 186   --   an 'AutoRacingScheduleListing'.
 187   --
 188   type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
 189
 190 instance FromXmlFk AutoRacingScheduleListingXml where
 191   -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
 192   --   foreign key to) a 'AutoRacingSchedule'.
 193   --
 194   type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
 195
 196   -- | To convert an 'AutoRacingScheduleListingXml' to an
 197   --   'AutoRacingScheduleListing', we add the foreign key and drop
 198   --   the 'xml_race_results'. We also mash the date/time together
 199   --   into one field.
 200   --
 201   from_xml_fk fk AutoRacingScheduleListingXml{..} =
 202     AutoRacingScheduleListing {
 203       db_auto_racing_schedules_id = fk,
 204       db_race_id = xml_race_id,
 205       db_race_time = make_race_time xml_race_date xml_race_time,
 206       db_race_name = xml_race_name,
 207       db_track_name = xml_track_name,
 208       db_location = xml_location,
 209       db_tv_listing = xml_tv_listing,
 210       db_laps = xml_laps,
 211       db_track_length = xml_track_length }
 212     where
 213       -- | Make the database \"race time\" from the XML
 214       --   date/time. Simply take the day part from one and the time
 215       --   from the other.
 216       --
 217       make_race_time d Nothing = d
 218       make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
 219
 220
 221 -- | This allows us to insert the XML representation
 222 --   'AutoRacingScheduleListingXml' directly.
 223 --
 224 instance XmlImportFk AutoRacingScheduleListingXml
 225
 226
 227
 228 -- * AutoRacingScheduleListingRaceResult
 229
 230 -- | The XML representation of \<message\> -> \<Listing\> ->
 231 --   \<RaceResults\>. This element serves only to contain
 232 --   \<RaceResultsListing\>s, so we don't store the intermediate table
 233 --   in the database.
 234 --
 235 newtype AutoRacingScheduleListingRaceResult =
 236   AutoRacingScheduleListingRaceResult {
 237     xml_race_result_listing ::
 238       [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
 239   deriving (Eq, Show)
 240
 241
 242 -- * AutoRacingScheduleListingRaceResultRaceResultListing /
 243 --   AutoRacingScheduleListingRaceResultRaceResultListingXml
 244 --
 245 --   Sorry about the names yo.
 246 --
 247
 248 -- | Database representation of \<RaceResultListing\> within
 249 --   \<RaceResults\> within \<Listing\> within... \<message\>!
 250 --
 251 data AutoRacingScheduleListingRaceResultRaceResultListing =
 252   AutoRacingScheduleListingRaceResultRaceResultListing {
 253     db_auto_racing_schedules_listings_id ::
 254       DefaultKey AutoRacingScheduleListing,
 255     db_finish_position :: Int,
 256     db_driver_id :: Int,
 257     db_name :: String,
 258     db_leading_laps :: Int,
 259     db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
 260     db_earnings :: String,  -- ^ This should be an Int, but can have commas.
 261     db_status :: String }
 262
 263
 264 -- | XML Representation of an
 265 --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
 266 --
 267 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
 268   AutoRacingScheduleListingRaceResultRaceResultListingXml {
 269     xml_finish_position :: Int,
 270     xml_driver_id :: Int,
 271     xml_name :: String,
 272     xml_leading_laps :: Int,
 273     xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
 274     xml_earnings :: String,  -- ^ Should be an 'Int', but can have commas.
 275     xml_status :: String }
 276   deriving (Eq, Show)
 277
 278
 279 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
 280   -- | The database representation of an
 281   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
 282   --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
 283   --
 284   type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
 285     AutoRacingScheduleListingRaceResultRaceResultListing
 286
 287
 288 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
 289   -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
 290   --   is contained in (i.e. has a foreign key to) an
 291   --   'AutoRacingScheduleListing'. We skip the intermediate
 292   --   \<RaceResults\>.
 293   --
 294   type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
 295     AutoRacingScheduleListing
 296
 297   -- | To convert an
 298   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
 299   --   'AutoRacingScheduleListingRaceResultRaceResultListing', we just
 300   --   add the foreign key to the parent 'AutoRacingScheduleListing'.
 301   --
 302   from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
 303     AutoRacingScheduleListingRaceResultRaceResultListing {
 304       db_auto_racing_schedules_listings_id = fk,
 305       db_finish_position = xml_finish_position,
 306       db_driver_id = xml_driver_id,
 307       db_name = xml_name,
 308       db_leading_laps = xml_leading_laps,
 309       db_listing_laps = xml_listing_laps,
 310       db_earnings = xml_earnings,
 311       db_status = xml_earnings }
 312
 313
 314 -- | This allows us to insert the XML representation
 315 --   'AutoRacingScheduleListingRaceResultRaceResultListingXml'
 316 --   directly.
 317 --
 318 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
 319
 320
 321 ---
 322 --- Database stuff.
 323 ---
 324
 325 instance DbImport Message where
 326   dbmigrate _ =
 327     run_dbmigrate $ do
 328       migrate (undefined :: AutoRacingSchedule)
 329       migrate (undefined :: AutoRacingScheduleListing)
 330       migrate (undefined
 331                  :: AutoRacingScheduleListingRaceResultRaceResultListing)
 332
 333
 334   -- | We insert the message, then use its ID to insert the listings,
 335   --   using their IDs to insert the race result listings.
 336   --
 337   dbimport m = do
 338     msg_id <- insert_xml m
 339
 340     forM_ (xml_listings m) $ \listing -> do
 341       listing_id <- insert_xml_fk msg_id listing
 342
 343       mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
 344
 345     return ImportSucceeded
 346
 347
 348 mkPersist tsn_codegen_config [groundhog|
 349 - entity: AutoRacingSchedule
 350   dbName: auto_racing_schedules
 351   constructors:
 352     - name: AutoRacingSchedule
 353       uniques:
 354         - name: unique_auto_racing_schedule
 355           type: constraint
 356           # Prevent multiple imports of the same message.
 357           fields: [db_xml_file_id]
 358
 359 - entity: AutoRacingScheduleListing
 360   dbName: auto_racing_schedules_listings
 361   constructors:
 362     - name: AutoRacingScheduleListing
 363       fields:
 364         - name: db_auto_racing_schedules_id
 365           reference:
 366             onDelete: cascade
 367
 368 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
 369   dbName: auto_racing_schedules_listings_race_result_listings
 370   constructors:
 371     - name: AutoRacingScheduleListingRaceResultRaceResultListing
 372       fields:
 373         - name: db_auto_racing_schedules_listings_id
 374           reference:
 375             onDelete: cascade
 376 |]
 377
 378
 379
 380 ---
 381 --- Pickling
 382 ---
 383
 384 -- | Pickler for the top-level 'Message'.
 385 --
 386 pickle_message :: PU Message
 387 pickle_message =
 388   xpElem "message" $
 389     xpWrap (from_tuple, to_tuple) $
 390     xp8Tuple (xpElem "XML_File_ID" xpInt)
 391              (xpElem "heading" xpText)
 392              (xpElem "category" xpText)
 393              (xpElem "sport" xpText)
 394              (xpElem "Title" xpText)
 395              (xpElem "Complete_Through" xpText)
 396              (xpList pickle_listing)
 397              (xpElem "time_stamp" xp_time_stamp)
 398   where
 399     from_tuple = uncurryN Message
 400     to_tuple m = (xml_xml_file_id m,
 401                   xml_heading m,
 402                   xml_category m,
 403                   xml_sport m,
 404                   xml_title m,
 405                   xml_complete_through m,
 406                   xml_listings m,
 407                   xml_time_stamp m)
 408
 409
 410 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
 411 --
 412 pickle_listing :: PU AutoRacingScheduleListingXml
 413 pickle_listing =
 414   xpElem "Listing" $
 415     xpWrap (from_tuple, to_tuple) $
 416       xp10Tuple (xpElem "RaceID" xpInt)
 417                 (xpElem "Race_Date" xp_date)
 418                 (xpElem "Race_Time" xp_tba_time)
 419                 (xpElem "RaceName" xpText)
 420                 (xpElem "TrackName" xpText)
 421                 (xpElem "Location" xpText)
 422                 (xpElem "TV_Listing" $ xpOption xpText)
 423                 (xpElem "Laps" xpInt)
 424                 (xpElem "TrackLength" xpText)
 425                 (xpList pickle_race_results)
 426   where
 427     from_tuple = uncurryN AutoRacingScheduleListingXml
 428     to_tuple m = (xml_race_id m,
 429                   xml_race_date m,
 430                   xml_race_time m,
 431                   xml_race_name m,
 432                   xml_track_name m,
 433                   xml_location m,
 434                   xml_tv_listing m,
 435                   xml_laps m,
 436                   xml_track_length m,
 437                   xml_race_results m)
 438
 439
 440 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
 441 --
 442 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
 443 pickle_race_results =
 444   xpElem "RaceResults" $
 445     xpWrap (to_result, from_result) $
 446       xpList pickle_race_results_listing
 447   where
 448     to_result = AutoRacingScheduleListingRaceResult
 449     from_result = xml_race_result_listing
 450
 451
 452 -- | Convert an
 453 --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
 454 --   XML.
 455 --
 456 pickle_race_results_listing ::
 457   PU AutoRacingScheduleListingRaceResultRaceResultListingXml
 458 pickle_race_results_listing =
 459   xpElem "RaceResultsListing" $
 460     xpWrap (from_tuple, to_tuple) $
 461       xp7Tuple (xpElem "FinishPosition" xpInt)
 462                (xpElem "DriverID" xpInt)
 463                (xpElem "Name" xpText)
 464                (xpElem "LeadingLaps" xpInt)
 465                (xpElem "Laps" xpInt)
 466                (xpElem "Earnings" xpText)
 467                (xpElem "Status" xpText)
 468   where
 469     from_tuple =
 470       uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
 471
 472     to_tuple m = (xml_finish_position m,
 473                   xml_driver_id m,
 474                   xml_name m,
 475                   xml_leading_laps m,
 476                   xml_listing_laps m,
 477                   xml_earnings m,
 478                   xml_status m)
 479
 480
 481 --
 482 -- Tasty Tests
 483 --
 484
 485 -- | A list of all tests for this module.
 486 --
 487 auto_racing_schedule_tests :: TestTree
 488 auto_racing_schedule_tests =
 489   testGroup
 490     "AutoRacingSchedule tests"
 491     [ test_on_delete_cascade,
 492       test_pickle_of_unpickle_is_identity,
 493       test_unpickle_succeeds ]
 494
 495 -- | If we unpickle something and then pickle it, we should wind up
 496 --   with the same thing we started with. WARNING: success of this
 497 --   test does not mean that unpickling succeeded.
 498 --
 499 test_pickle_of_unpickle_is_identity :: TestTree
 500 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 501   [ check "pickle composed with unpickle is the identity"
 502           "test/xml/Auto_Racing_Schedule_XML.xml",
 503
 504     check "pickle composed with unpickle is the identity (miles track length)"
 505           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 506   where
 507     check desc path = testCase desc $ do
 508       (expected, actual) <- pickle_unpickle pickle_message path
 509       actual @?= expected
 510
 511
 512 -- | Make sure we can actually unpickle these things.
 513 --
 514 test_unpickle_succeeds :: TestTree
 515 test_unpickle_succeeds = testGroup "unpickle tests"
 516   [ check "unpickling succeeds"
 517           "test/xml/Auto_Racing_Schedule_XML.xml",
 518
 519     check "unpickling succeeds (non-int team_id)"
 520           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 521   where
 522     check desc path = testCase desc $ do
 523       actual <- unpickleable path pickle_message
 524       let expected = True
 525       actual @?= expected
 526
 527
 528 -- | Make sure everything gets deleted when we delete the top-level
 529 --   record.
 530 --
 531 test_on_delete_cascade :: TestTree
 532 test_on_delete_cascade = testGroup "cascading delete tests"
 533     [ check "deleting auto_racing_schedules deletes its children"
 534           "test/xml/Auto_Racing_Schedule_XML.xml" ,
 535
 536     check ("deleting auto_racing_schedules deletes its children " ++
 537             "(miles track length)")
 538           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 539   where
 540     check desc path = testCase desc $ do
 541       sched <- unsafe_unpickle path pickle_message
 542       let a = undefined :: AutoRacingSchedule
 543       let b = undefined :: AutoRacingScheduleListing
 544       let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
 545
 546       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 547                   runMigration silentMigrationLogger $ do
 548                     migrate a
 549                     migrate b
 550                     migrate c
 551                   _ <- dbimport sched
 552                   -- No idea how 'delete' works, so do this instead.
 553                   executeRaw False "DELETE FROM auto_racing_schedules;" []
 554                   count_a <- countAll a
 555                   count_b <- countAll b
 556                   count_c <- countAll c
 557                   return $ sum [count_a, count_b, count_c]
 558       let expected = 0
 559       actual @?= expected