src/TSN/XML/AutoRacingSchedule.hs

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