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