src/TSN/XML/AutoRacingSchedule.hs

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