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   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 :: String }
 270
 271
 272 -- | XML Representation of an
 273 --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
 274 --
 275 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
 276   AutoRacingScheduleListingRaceResultRaceResultListingXml {
 277     xml_finish_position :: Int,
 278     xml_driver_id :: Int,
 279     xml_name :: String,
 280     xml_leading_laps :: Int,
 281     xml_listing_laps :: Int, -- ^ Avoid clash with race's \"laps\" field.
 282     xml_earnings :: String,  -- ^ Should be an 'Int', but can have commas.
 283     xml_status :: String }
 284   deriving (Eq, Show)
 285
 286
 287 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
 288   -- | The database representation of an
 289   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' is an
 290   --   'AutoRacingScheduleListingRaceResultRaceResultListing'.
 291   --
 292   type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
 293     AutoRacingScheduleListingRaceResultRaceResultListing
 294
 295
 296 instance Child AutoRacingScheduleListingRaceResultRaceResultListingXml where
 297   -- | Each 'AutoRacingScheduleListingRaceResultRaceResultListingXml'
 298   --   is contained in (i.e. has a foreign key to) an
 299   --   'AutoRacingScheduleListing'. We skip the intermediate
 300   --   \<RaceResults\>.
 301   --
 302   type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
 303     AutoRacingScheduleListing
 304
 305
 306 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
 307   -- | To convert an
 308   --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to an
 309   --   'AutoRacingScheduleListingRaceResultRaceResultListing', we just
 310   --   add the foreign key to the parent 'AutoRacingScheduleListing'.
 311   --
 312   from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
 313     AutoRacingScheduleListingRaceResultRaceResultListing {
 314       db_auto_racing_schedules_listings_id = fk,
 315       db_finish_position = xml_finish_position,
 316       db_driver_id = xml_driver_id,
 317       db_name = xml_name,
 318       db_leading_laps = xml_leading_laps,
 319       db_listing_laps = xml_listing_laps,
 320       db_earnings = xml_earnings,
 321       db_status = xml_earnings }
 322
 323
 324 -- | This allows us to insert the XML representation
 325 --   'AutoRacingScheduleListingRaceResultRaceResultListingXml'
 326 --   directly.
 327 --
 328 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
 329
 330
 331 ---
 332 --- Database stuff.
 333 ---
 334
 335 instance DbImport Message where
 336   dbmigrate _ =
 337     run_dbmigrate $ do
 338       migrate (undefined :: AutoRacingSchedule)
 339       migrate (undefined :: AutoRacingScheduleListing)
 340       migrate (undefined
 341                  :: AutoRacingScheduleListingRaceResultRaceResultListing)
 342
 343
 344   -- | We insert the message, then use its ID to insert the listings,
 345   --   using their IDs to insert the race result listings.
 346   --
 347   dbimport m = do
 348     msg_id <- insert_xml m
 349
 350     forM_ (xml_listings m) $ \listing -> do
 351       listing_id <- insert_xml_fk msg_id listing
 352
 353       mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
 354
 355     return ImportSucceeded
 356
 357
 358 mkPersist tsn_codegen_config [groundhog|
 359 - entity: AutoRacingSchedule
 360   dbName: auto_racing_schedules
 361   constructors:
 362     - name: AutoRacingSchedule
 363       uniques:
 364         - name: unique_auto_racing_schedule
 365           type: constraint
 366           # Prevent multiple imports of the same message.
 367           fields: [db_xml_file_id]
 368
 369 - entity: AutoRacingScheduleListing
 370   dbName: auto_racing_schedules_listings
 371   constructors:
 372     - name: AutoRacingScheduleListing
 373       fields:
 374         - name: db_auto_racing_schedules_id
 375           reference:
 376             onDelete: cascade
 377
 378 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
 379   dbName: auto_racing_schedules_listings_race_result_listings
 380   constructors:
 381     - name: AutoRacingScheduleListingRaceResultRaceResultListing
 382       fields:
 383         - name: db_auto_racing_schedules_listings_id
 384           reference:
 385             onDelete: cascade
 386 |]
 387
 388
 389
 390 ---
 391 --- Pickling
 392 ---
 393
 394 -- | Pickler for the top-level 'Message'.
 395 --
 396 pickle_message :: PU Message
 397 pickle_message =
 398   xpElem "message" $
 399     xpWrap (from_tuple, to_tuple) $
 400     xp8Tuple (xpElem "XML_File_ID" xpInt)
 401              (xpElem "heading" xpText)
 402              (xpElem "category" xpText)
 403              (xpElem "sport" xpText)
 404              (xpElem "Title" xpText)
 405              (xpElem "Complete_Through" xpText)
 406              (xpList pickle_listing)
 407              (xpElem "time_stamp" xp_time_stamp)
 408   where
 409     from_tuple = uncurryN Message
 410     to_tuple m = (xml_xml_file_id m,
 411                   xml_heading m,
 412                   xml_category m,
 413                   xml_sport m,
 414                   xml_title m,
 415                   xml_complete_through m,
 416                   xml_listings m,
 417                   xml_time_stamp m)
 418
 419
 420 -- | Convert an 'AutoRacingScheduleListingXml' to/from XML.
 421 --
 422 pickle_listing :: PU AutoRacingScheduleListingXml
 423 pickle_listing =
 424   xpElem "Listing" $
 425     xpWrap (from_tuple, to_tuple) $
 426       xp10Tuple (xpElem "RaceID" xpInt)
 427                 (xpElem "Race_Date" xp_date_padded)
 428                 (xpElem "Race_Time" xp_tba_time)
 429                 (xpElem "RaceName" xpText)
 430                 (xpElem "TrackName" xpText)
 431                 (xpElem "Location" xpText)
 432                 (xpElem "TV_Listing" $ xpOption xpText)
 433                 (xpElem "Laps" xpInt)
 434                 (xpElem "TrackLength" xpText)
 435                 (xpList pickle_race_results)
 436   where
 437     from_tuple = uncurryN AutoRacingScheduleListingXml
 438     to_tuple m = (xml_race_id m,
 439                   xml_race_date m,
 440                   xml_race_time m,
 441                   xml_race_name m,
 442                   xml_track_name m,
 443                   xml_location m,
 444                   xml_tv_listing m,
 445                   xml_laps m,
 446                   xml_track_length m,
 447                   xml_race_results m)
 448
 449
 450 -- | Convert an 'AutoRacingScheduleListingRaceResult' to/from XML.
 451 --
 452 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
 453 pickle_race_results =
 454   xpElem "RaceResults" $
 455     xpWrap (to_result, from_result) $
 456       xpList pickle_race_results_listing
 457   where
 458     to_result = AutoRacingScheduleListingRaceResult
 459     from_result = xml_race_result_listing
 460
 461
 462 -- | Convert an
 463 --   'AutoRacingScheduleListingRaceResultRaceResultListingXml' to/from
 464 --   XML.
 465 --
 466 pickle_race_results_listing ::
 467   PU AutoRacingScheduleListingRaceResultRaceResultListingXml
 468 pickle_race_results_listing =
 469   xpElem "RaceResultsListing" $
 470     xpWrap (from_tuple, to_tuple) $
 471       xp7Tuple (xpElem "FinishPosition" xpInt)
 472                (xpElem "DriverID" xpInt)
 473                (xpElem "Name" xpText)
 474                (xpElem "LeadingLaps" xpInt)
 475                (xpElem "Laps" xpInt)
 476                (xpElem "Earnings" xpText)
 477                (xpElem "Status" xpText)
 478   where
 479     from_tuple =
 480       uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
 481
 482     to_tuple m = (xml_finish_position m,
 483                   xml_driver_id m,
 484                   xml_name m,
 485                   xml_leading_laps m,
 486                   xml_listing_laps m,
 487                   xml_earnings m,
 488                   xml_status m)
 489
 490
 491 --
 492 -- Tasty Tests
 493 --
 494
 495 -- | A list of all tests for this module.
 496 --
 497 auto_racing_schedule_tests :: TestTree
 498 auto_racing_schedule_tests =
 499   testGroup
 500     "AutoRacingSchedule tests"
 501     [ test_on_delete_cascade,
 502       test_pickle_of_unpickle_is_identity,
 503       test_unpickle_succeeds ]
 504
 505 -- | If we unpickle something and then pickle it, we should wind up
 506 --   with the same thing we started with. WARNING: success of this
 507 --   test does not mean that unpickling succeeded.
 508 --
 509 test_pickle_of_unpickle_is_identity :: TestTree
 510 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 511   [ check "pickle composed with unpickle is the identity"
 512           "test/xml/Auto_Racing_Schedule_XML.xml",
 513
 514     check "pickle composed with unpickle is the identity (miles track length)"
 515           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 516   where
 517     check desc path = testCase desc $ do
 518       (expected, actual) <- pickle_unpickle pickle_message path
 519       actual @?= expected
 520
 521
 522 -- | Make sure we can actually unpickle these things.
 523 --
 524 test_unpickle_succeeds :: TestTree
 525 test_unpickle_succeeds = testGroup "unpickle tests"
 526   [ check "unpickling succeeds"
 527           "test/xml/Auto_Racing_Schedule_XML.xml",
 528
 529     check "unpickling succeeds (non-int team_id)"
 530           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 531   where
 532     check desc path = testCase desc $ do
 533       actual <- unpickleable path pickle_message
 534       let expected = True
 535       actual @?= expected
 536
 537
 538 -- | Make sure everything gets deleted when we delete the top-level
 539 --   record.
 540 --
 541 test_on_delete_cascade :: TestTree
 542 test_on_delete_cascade = testGroup "cascading delete tests"
 543     [ check "deleting auto_racing_schedules deletes its children"
 544           "test/xml/Auto_Racing_Schedule_XML.xml" ,
 545
 546     check ("deleting auto_racing_schedules deletes its children " ++
 547             "(miles track length)")
 548           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 549   where
 550     check desc path = testCase desc $ do
 551       sched <- unsafe_unpickle path pickle_message
 552       let a = undefined :: AutoRacingSchedule
 553       let b = undefined :: AutoRacingScheduleListing
 554       let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
 555
 556       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 557                   runMigration silentMigrationLogger $ do
 558                     migrate a
 559                     migrate b
 560                     migrate c
 561                   _ <- dbimport sched
 562                   deleteAll a
 563                   count_a <- countAll a
 564                   count_b <- countAll b
 565                   count_c <- countAll c
 566                   return $ sum [count_a, count_b, count_c]
 567       let expected = 0
 568       actual @?= expected