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   dtd,
  17   pickle_message,
  18   -- * Tests
  19   auto_racing_schedule_tests,
  20   -- * WARNING: these are private but exported to silence warnings
  21   AutoRacingScheduleConstructor(..),
  22   AutoRacingScheduleListingConstructor(..),
  23   AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
  24 where
  25
  26 -- System imports.
  27 import Control.Monad ( forM_ )
  28 import Data.Time ( UTCTime(..) )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Database.Groundhog (
  31   countAll,
  32   executeRaw,
  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   xp7Tuple,
  47   xp8Tuple,
  48   xp10Tuple,
  49   xpElem,
  50   xpInt,
  51   xpList,
  52   xpOption,
  53   xpText,
  54   xpWrap )
  55
  56 -- Local imports.
  57 import TSN.Codegen (
  58   tsn_codegen_config )
  59 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  60 import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp )
  61 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  62 import Xml (
  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 instance FromXmlFk AutoRacingScheduleListingXml where
 197   -- | Each 'AutoRacingScheduleListingXml' is contained in (i.e. has a
 198   --   foreign key to) a 'AutoRacingSchedule'.
 199   --
 200   type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
 201
 202   -- | To convert an 'AutoRacingScheduleListingXml' to an
 203   --   'AutoRacingScheduleListing', we add the foreign key and drop
 204   --   the 'xml_race_results'. We also mash the date/time together
 205   --   into one field.
 206   --
 207   from_xml_fk fk AutoRacingScheduleListingXml{..} =
 208     AutoRacingScheduleListing {
 209       db_auto_racing_schedules_id = fk,
 210       db_race_id = xml_race_id,
 211       db_race_time = make_race_time xml_race_date xml_race_time,
 212       db_race_name = xml_race_name,
 213       db_track_name = xml_track_name,
 214       db_location = xml_location,
 215       db_tv_listing = xml_tv_listing,
 216       db_laps = xml_laps,
 217       db_track_length = xml_track_length }
 218     where
 219       -- | Make the database \"race time\" from the XML
 220       --   date/time. Simply take the day part from one and the time
 221       --   from the other.
 222       --
 223       make_race_time d Nothing = d
 224       make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
 225
 226
 227 -- | This allows us to insert the XML representation
 228 --   'AutoRacingScheduleListingXml' directly.
 229 --
 230 instance XmlImportFk AutoRacingScheduleListingXml
 231
 232
 233
 234 -- * AutoRacingScheduleListingRaceResult
 235
 236 -- | The XML representation of \<message\> -> \<Listing\> ->
 237 --   \<RaceResults\>. This element serves only to contain
 238 --   \<RaceResultsListing\>s, so we don't store the intermediate table
 239 --   in the database.
 240 --
 241 newtype AutoRacingScheduleListingRaceResult =
 242   AutoRacingScheduleListingRaceResult {
 243     xml_race_result_listing ::
 244       [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
 245   deriving (Eq, Show)
 246
 247
 248 -- * AutoRacingScheduleListingRaceResultRaceResultListing /
 249 --   AutoRacingScheduleListingRaceResultRaceResultListingXml
 250 --
 251 --   Sorry about the names yo.
 252 --
 253
 254 -- | Database representation of \<RaceResultListing\> within
 255 --   \<RaceResults\> within \<Listing\> within... \<message\>!
 256 --
 257 data AutoRacingScheduleListingRaceResultRaceResultListing =
 258   AutoRacingScheduleListingRaceResultRaceResultListing {
 259     db_auto_racing_schedules_listings_id ::
 260       DefaultKey AutoRacingScheduleListing,
 261     db_finish_position :: Int,
 262     db_driver_id :: Int,
 263     db_name :: String,
 264     db_leading_laps :: Int,
 265     db_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
 266     db_earnings :: String,  -- ^ This should be an Int, but can have commas.
 267     db_status :: String }
 268
 269
 270 -- | XML Representation of an
 271 --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
 272 --
 273 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
 274   AutoRacingScheduleListingRaceResultRaceResultListingXml {
 275     xml_finish_position :: Int,
 276     xml_driver_id :: Int,
 277     xml_name :: String,
 278     xml_leading_laps :: Int,
 279     xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
 280     xml_earnings :: String,  -- ^ Should be an 'Int', but can have commas.
 281     xml_status :: String }
 282   deriving (Eq, Show)
 283
 284
 285 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
 286   -- | The database representation of an
 287   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
 288   --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
 289   --
 290   type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
 291     AutoRacingScheduleListingRaceResultRaceResultListing
 292
 293
 294 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
 295   -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
 296   --   is contained in (i.e. has a foreign key to) an
 297   --   'AutoRacingScheduleListing'. We skip the intermediate
 298   --   \<RaceResults\>.
 299   --
 300   type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
 301     AutoRacingScheduleListing
 302
 303   -- | To convert an
 304   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
 305   --   'AutoRacingScheduleListingRaceResultRaceResultListing', we just
 306   --   add the foreign key to the parent 'AutoRacingScheduleListing'.
 307   --
 308   from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
 309     AutoRacingScheduleListingRaceResultRaceResultListing {
 310       db_auto_racing_schedules_listings_id = fk,
 311       db_finish_position = xml_finish_position,
 312       db_driver_id = xml_driver_id,
 313       db_name = xml_name,
 314       db_leading_laps = xml_leading_laps,
 315       db_listing_laps = xml_listing_laps,
 316       db_earnings = xml_earnings,
 317       db_status = xml_earnings }
 318
 319
 320 -- | This allows us to insert the XML representation
 321 --   'AutoRacingScheduleListingRaceResultRaceResultListingXml'
 322 --   directly.
 323 --
 324 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
 325
 326
 327 ---
 328 --- Database stuff.
 329 ---
 330
 331 instance DbImport Message where
 332   dbmigrate _ =
 333     run_dbmigrate $ do
 334       migrate (undefined :: AutoRacingSchedule)
 335       migrate (undefined :: AutoRacingScheduleListing)
 336       migrate (undefined
 337                  :: AutoRacingScheduleListingRaceResultRaceResultListing)
 338
 339
 340   -- | We insert the message, then use its ID to insert the listings,
 341   --   using their IDs to insert the race result listings.
 342   --
 343   dbimport m = do
 344     msg_id <- insert_xml m
 345
 346     forM_ (xml_listings m) $ \listing -> do
 347       listing_id <- insert_xml_fk msg_id listing
 348
 349       mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
 350
 351     return ImportSucceeded
 352
 353
 354 mkPersist tsn_codegen_config [groundhog|
 355 - entity: AutoRacingSchedule
 356   dbName: auto_racing_schedules
 357   constructors:
 358     - name: AutoRacingSchedule
 359       uniques:
 360         - name: unique_auto_racing_schedule
 361           type: constraint
 362           # Prevent multiple imports of the same message.
 363           fields: [db_xml_file_id]
 364
 365 - entity: AutoRacingScheduleListing
 366   dbName: auto_racing_schedules_listings
 367   constructors:
 368     - name: AutoRacingScheduleListing
 369       fields:
 370         - name: db_auto_racing_schedules_id
 371           reference:
 372             onDelete: cascade
 373
 374 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
 375   dbName: auto_racing_schedules_listings_race_result_listings
 376   constructors:
 377     - name: AutoRacingScheduleListingRaceResultRaceResultListing
 378       fields:
 379         - name: db_auto_racing_schedules_listings_id
 380           reference:
 381             onDelete: cascade
 382 |]
 383
 384
 385
 386 ---
 387 --- Pickling
 388 ---
 389
 390 -- | Pickler for the top-level 'Message'.
 391 --
 392 pickle_message :: PU Message
 393 pickle_message =
 394   xpElem "message" $
 395     xpWrap (from_tuple, to_tuple) $
 396     xp8Tuple (xpElem "XML_File_ID" xpInt)
 397              (xpElem "heading" xpText)
 398              (xpElem "category" xpText)
 399              (xpElem "sport" xpText)
 400              (xpElem "Title" xpText)
 401              (xpElem "Complete_Through" xpText)
 402              (xpList pickle_listing)
 403              (xpElem "time_stamp" xp_time_stamp)
 404   where
 405     from_tuple = uncurryN Message
 406     to_tuple m = (xml_xml_file_id m,
 407                   xml_heading m,
 408                   xml_category m,
 409                   xml_sport m,
 410                   xml_title m,
 411                   xml_complete_through m,
 412                   xml_listings m,
 413                   xml_time_stamp m)
 414
 415
 416 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
 417 --
 418 pickle_listing :: PU AutoRacingScheduleListingXml
 419 pickle_listing =
 420   xpElem "Listing" $
 421     xpWrap (from_tuple, to_tuple) $
 422       xp10Tuple (xpElem "RaceID" xpInt)
 423                 (xpElem "Race_Date" xp_date)
 424                 (xpElem "Race_Time" xp_tba_time)
 425                 (xpElem "RaceName" xpText)
 426                 (xpElem "TrackName" xpText)
 427                 (xpElem "Location" xpText)
 428                 (xpElem "TV_Listing" $ xpOption xpText)
 429                 (xpElem "Laps" xpInt)
 430                 (xpElem "TrackLength" xpText)
 431                 (xpList pickle_race_results)
 432   where
 433     from_tuple = uncurryN AutoRacingScheduleListingXml
 434     to_tuple m = (xml_race_id m,
 435                   xml_race_date m,
 436                   xml_race_time m,
 437                   xml_race_name m,
 438                   xml_track_name m,
 439                   xml_location m,
 440                   xml_tv_listing m,
 441                   xml_laps m,
 442                   xml_track_length m,
 443                   xml_race_results m)
 444
 445
 446 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
 447 --
 448 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
 449 pickle_race_results =
 450   xpElem "RaceResults" $
 451     xpWrap (to_result, from_result) $
 452       xpList pickle_race_results_listing
 453   where
 454     to_result = AutoRacingScheduleListingRaceResult
 455     from_result = xml_race_result_listing
 456
 457
 458 -- | Convert an
 459 --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
 460 --   XML.
 461 --
 462 pickle_race_results_listing ::
 463   PU AutoRacingScheduleListingRaceResultRaceResultListingXml
 464 pickle_race_results_listing =
 465   xpElem "RaceResultsListing" $
 466     xpWrap (from_tuple, to_tuple) $
 467       xp7Tuple (xpElem "FinishPosition" xpInt)
 468                (xpElem "DriverID" xpInt)
 469                (xpElem "Name" xpText)
 470                (xpElem "LeadingLaps" xpInt)
 471                (xpElem "Laps" xpInt)
 472                (xpElem "Earnings" xpText)
 473                (xpElem "Status" xpText)
 474   where
 475     from_tuple =
 476       uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
 477
 478     to_tuple m = (xml_finish_position m,
 479                   xml_driver_id m,
 480                   xml_name m,
 481                   xml_leading_laps m,
 482                   xml_listing_laps m,
 483                   xml_earnings m,
 484                   xml_status m)
 485
 486
 487 --
 488 -- Tasty Tests
 489 --
 490
 491 -- | A list of all tests for this module.
 492 --
 493 auto_racing_schedule_tests :: TestTree
 494 auto_racing_schedule_tests =
 495   testGroup
 496     "AutoRacingSchedule tests"
 497     [ test_on_delete_cascade,
 498       test_pickle_of_unpickle_is_identity,
 499       test_unpickle_succeeds ]
 500
 501 -- | If we unpickle something and then pickle it, we should wind up
 502 --   with the same thing we started with. WARNING: success of this
 503 --   test does not mean that unpickling succeeded.
 504 --
 505 test_pickle_of_unpickle_is_identity :: TestTree
 506 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 507   [ check "pickle composed with unpickle is the identity"
 508           "test/xml/Auto_Racing_Schedule_XML.xml",
 509
 510     check "pickle composed with unpickle is the identity (miles track length)"
 511           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 512   where
 513     check desc path = testCase desc $ do
 514       (expected, actual) <- pickle_unpickle pickle_message path
 515       actual @?= expected
 516
 517
 518 -- | Make sure we can actually unpickle these things.
 519 --
 520 test_unpickle_succeeds :: TestTree
 521 test_unpickle_succeeds = testGroup "unpickle tests"
 522   [ check "unpickling succeeds"
 523           "test/xml/Auto_Racing_Schedule_XML.xml",
 524
 525     check "unpickling succeeds (non-int team_id)"
 526           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 527   where
 528     check desc path = testCase desc $ do
 529       actual <- unpickleable path pickle_message
 530       let expected = True
 531       actual @?= expected
 532
 533
 534 -- | Make sure everything gets deleted when we delete the top-level
 535 --   record.
 536 --
 537 test_on_delete_cascade :: TestTree
 538 test_on_delete_cascade = testGroup "cascading delete tests"
 539     [ check "deleting auto_racing_schedules deletes its children"
 540           "test/xml/Auto_Racing_Schedule_XML.xml" ,
 541
 542     check ("deleting auto_racing_schedules deletes its children " ++
 543             "(miles track length)")
 544           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 545   where
 546     check desc path = testCase desc $ do
 547       sched <- unsafe_unpickle path pickle_message
 548       let a = undefined :: AutoRacingSchedule
 549       let b = undefined :: AutoRacingScheduleListing
 550       let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
 551
 552       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 553                   runMigration silentMigrationLogger $ do
 554                     migrate a
 555                     migrate b
 556                     migrate c
 557                   _ <- dbimport sched
 558                   -- No idea how 'delete' works, so do this instead.
 559                   executeRaw False "DELETE FROM auto_racing_schedules;" []
 560                   count_a <- countAll a
 561                   count_b <- countAll b
 562                   count_c <- countAll c
 563                   return $ sum [count_a, count_b, count_c]
 564       let expected = 0
 565       actual @?= expected