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