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