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