src/TSN/XML/AutoRacingSchedule.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   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   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   executeRaw,
  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, 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 --
  71 -- DB/XML data types
  72 --
  73
  74 -- * AutoRacingSchedule/Message
  75
  76 -- | Database representation of a 'Message'.
  77 --
  78 data AutoRacingSchedule =
  79   AutoRacingSchedule {
  80     db_xml_file_id :: Int,
  81     db_heading :: String,
  82     db_category :: String,
  83     db_sport :: String,
  84     db_title :: String,
  85     db_complete_through :: String,
  86     db_time_stamp :: UTCTime }
  87   deriving (Eq, Show)
  88
  89
  90 -- | XML Representation of an 'AutoRacingSchedule'.
  91 --
  92 data Message =
  93   Message {
  94     xml_xml_file_id :: Int,
  95     xml_heading :: String,
  96     xml_category :: String,
  97     xml_sport :: String,
  98     xml_title :: String,
  99     xml_complete_through :: String,
 100     xml_listings :: [AutoRacingScheduleListingXml],
 101     xml_time_stamp :: UTCTime }
 102   deriving (Eq, Show)
 103
 104 instance ToDb Message where
 105   type Db Message = AutoRacingSchedule
 106
 107 instance FromXml Message where
 108   from_xml Message{..} =
 109     AutoRacingSchedule {
 110       db_xml_file_id = xml_xml_file_id,
 111       db_heading = xml_heading,
 112       db_category = xml_category,
 113       db_sport = xml_sport,
 114       db_title = xml_title,
 115       db_complete_through = xml_complete_through,
 116       db_time_stamp = xml_time_stamp }
 117
 118 instance XmlImport Message
 119
 120
 121 -- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
 122
 123 -- | Database representation of a \<Listing\> contained within a
 124 --   \<Message\>. We combine the race date/time into a single
 125 --   race_time, drop the race results list, and add a foreign key to
 126 --   our parent.
 127 data AutoRacingScheduleListing =
 128   AutoRacingScheduleListing {
 129     db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
 130     db_race_id :: Int,
 131     db_race_time :: UTCTime,
 132     db_race_name :: String,
 133     db_track_name :: String,
 134     db_location :: String,
 135     db_tv_listing :: Maybe String,
 136     db_laps :: Int,
 137     db_track_length :: String -- ^ Sometimes the word "miles" shows up.
 138   }
 139
 140 -- | XML representation of a \<Listing\> contained within a
 141 --   \<message\>.
 142 --
 143 data AutoRacingScheduleListingXml =
 144   AutoRacingScheduleListingXml {
 145     xml_race_id :: Int,
 146     xml_race_date :: UTCTime,
 147     xml_race_time :: Maybe UTCTime,
 148     xml_race_name :: String,
 149     xml_track_name :: String,
 150     xml_location :: String,
 151     xml_tv_listing :: Maybe String,
 152     xml_laps :: Int,
 153     xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up.
 154     xml_race_results :: [AutoRacingScheduleListingRaceResult] }
 155   deriving (Eq, Show)
 156
 157 -- | Pseudo-accessor to get the race result listings out of a
 158 --   'AutoRacingScheduleListingXml'.
 159 result_listings :: AutoRacingScheduleListingXml
 160                 -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
 161 result_listings = (concatMap xml_race_result_listing) . xml_race_results
 162
 163
 164 instance ToDb AutoRacingScheduleListingXml where
 165   type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
 166
 167 instance FromXmlFk AutoRacingScheduleListingXml where
 168   type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
 169
 170   from_xml_fk fk AutoRacingScheduleListingXml{..} =
 171     AutoRacingScheduleListing {
 172       db_auto_racing_schedules_id = fk,
 173       db_race_id = xml_race_id,
 174       db_race_time = make_race_time xml_race_date xml_race_time,
 175       db_race_name = xml_race_name,
 176       db_track_name = xml_track_name,
 177       db_location = xml_location,
 178       db_tv_listing = xml_tv_listing,
 179       db_laps = xml_laps,
 180       db_track_length = xml_track_length }
 181     where
 182       -- Take the day part from one, the time from the other.
 183       make_race_time d Nothing = d
 184       make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
 185
 186 instance XmlImportFk AutoRacingScheduleListingXml
 187
 188 -- * AutoRacingScheduleListingRaceResult
 189
 190 -- | The XML representation of \<message\> -> \<Listing\> ->
 191 --   \<RaceResults\>. This element serves only to contain
 192 --   \<RaceResultsListing\>s, so we don't store the intermediate table
 193 --   in the database.
 194 --
 195 newtype AutoRacingScheduleListingRaceResult =
 196   AutoRacingScheduleListingRaceResult {
 197     xml_race_result_listing ::
 198       [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
 199   deriving (Eq, Show)
 200
 201 -- * AutoRacingScheduleListingRaceResultRaceResultListing /
 202 --   AutoRacingScheduleListingRaceResultRaceResultListingXml
 203
 204 data AutoRacingScheduleListingRaceResultRaceResultListing =
 205   AutoRacingScheduleListingRaceResultRaceResultListing {
 206     db_auto_racing_schedules_listings_id ::
 207       DefaultKey AutoRacingScheduleListing,
 208     db_finish_position :: Int,
 209     db_driver_id :: Int,
 210     db_name :: String,
 211     db_leading_laps :: Int,
 212     db_listing_laps :: Int, -- Avoid clash with race's "laps" field.
 213     db_earnings :: String, -- Should be an int, but they use commas.
 214     db_status :: String }
 215
 216 data AutoRacingScheduleListingRaceResultRaceResultListingXml =
 217   AutoRacingScheduleListingRaceResultRaceResultListingXml {
 218     xml_finish_position :: Int,
 219     xml_driver_id :: Int,
 220     xml_name :: String,
 221     xml_leading_laps :: Int,
 222     xml_listing_laps :: Int, -- Avoid clash with race's "laps" field.
 223     xml_earnings :: String, -- Should be an int, but they use commas.
 224     xml_status :: String }
 225   deriving (Eq, Show)
 226
 227 instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
 228   type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
 229     AutoRacingScheduleListingRaceResultRaceResultListing
 230
 231 instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
 232   type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
 233     AutoRacingScheduleListing
 234
 235   from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
 236     AutoRacingScheduleListingRaceResultRaceResultListing {
 237       db_auto_racing_schedules_listings_id = fk,
 238       db_finish_position = xml_finish_position,
 239       db_driver_id = xml_driver_id,
 240       db_name = xml_name,
 241       db_leading_laps = xml_leading_laps,
 242       db_listing_laps = xml_listing_laps,
 243       db_earnings = xml_earnings,
 244       db_status = xml_earnings }
 245
 246 instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
 247
 248 ---
 249 --- Database stuff.
 250 ---
 251
 252 instance DbImport Message where
 253   dbmigrate _ =
 254     run_dbmigrate $ do
 255       migrate (undefined :: AutoRacingSchedule)
 256       migrate (undefined :: AutoRacingScheduleListing)
 257       migrate (undefined
 258                  :: AutoRacingScheduleListingRaceResultRaceResultListing)
 259
 260   dbimport m = do
 261     msg_id <- insert_xml m
 262
 263     forM_ (xml_listings m) $ \listing -> do
 264       listing_id <- insert_xml_fk msg_id listing
 265
 266       mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
 267
 268     return ImportSucceeded
 269
 270
 271 mkPersist tsn_codegen_config [groundhog|
 272 - entity: AutoRacingSchedule
 273   dbName: auto_racing_schedules
 274   constructors:
 275     - name: AutoRacingSchedule
 276       uniques:
 277         - name: unique_auto_racing_schedule
 278           type: constraint
 279           # Prevent multiple imports of the same message.
 280           fields: [db_xml_file_id]
 281
 282 - entity: AutoRacingScheduleListing
 283   dbName: auto_racing_schedules_listings
 284   constructors:
 285     - name: AutoRacingScheduleListing
 286       fields:
 287         - name: db_auto_racing_schedules_id
 288           reference:
 289             onDelete: cascade
 290
 291 - entity: AutoRacingScheduleListingRaceResultRaceResultListing
 292   dbName: auto_racing_schedules_listings_race_result_listings
 293   constructors:
 294     - name: AutoRacingScheduleListingRaceResultRaceResultListing
 295       fields:
 296         - name: db_auto_racing_schedules_listings_id
 297           reference:
 298             onDelete: cascade
 299 |]
 300
 301
 302
 303 ---
 304 --- Pickling
 305 ---
 306
 307 -- | Pickler for the top-level 'Message'.
 308 --
 309 pickle_message :: PU Message
 310 pickle_message =
 311   xpElem "message" $
 312     xpWrap (from_tuple, to_tuple) $
 313     xp8Tuple (xpElem "XML_File_ID" xpInt)
 314              (xpElem "heading" xpText)
 315              (xpElem "category" xpText)
 316              (xpElem "sport" xpText)
 317              (xpElem "Title" xpText)
 318              (xpElem "Complete_Through" xpText)
 319              (xpList pickle_listing)
 320              (xpElem "time_stamp" xp_time_stamp)
 321   where
 322     from_tuple = uncurryN Message
 323     to_tuple m = (xml_xml_file_id m,
 324                   xml_heading m,
 325                   xml_category m,
 326                   xml_sport m,
 327                   xml_title m,
 328                   xml_complete_through m,
 329                   xml_listings m,
 330                   xml_time_stamp m)
 331
 332
 333 pickle_listing :: PU AutoRacingScheduleListingXml
 334 pickle_listing =
 335   xpElem "Listing" $
 336     xpWrap (from_tuple, to_tuple) $
 337       xp10Tuple (xpElem "RaceID" xpInt)
 338                 (xpElem "Race_Date" xp_date)
 339                 (xpElem "Race_Time" xp_tba_time)
 340                 (xpElem "RaceName" xpText)
 341                 (xpElem "TrackName" xpText)
 342                 (xpElem "Location" xpText)
 343                 (xpElem "TV_Listing" $ xpOption xpText)
 344                 (xpElem "Laps" xpInt)
 345                 (xpElem "TrackLength" xpText)
 346                 (xpList pickle_race_results)
 347   where
 348     from_tuple = uncurryN AutoRacingScheduleListingXml
 349     to_tuple m = (xml_race_id m,
 350                   xml_race_date m,
 351                   xml_race_time m,
 352                   xml_race_name m,
 353                   xml_track_name m,
 354                   xml_location m,
 355                   xml_tv_listing m,
 356                   xml_laps m,
 357                   xml_track_length m,
 358                   xml_race_results m)
 359
 360 pickle_race_results :: PU AutoRacingScheduleListingRaceResult
 361 pickle_race_results =
 362   xpElem "RaceResults" $
 363     xpWrap (to_result, from_result) $
 364       xpList pickle_race_results_listing
 365   where
 366     to_result = AutoRacingScheduleListingRaceResult
 367     from_result = xml_race_result_listing
 368
 369 pickle_race_results_listing ::
 370   PU AutoRacingScheduleListingRaceResultRaceResultListingXml
 371 pickle_race_results_listing =
 372   xpElem "RaceResultsListing" $
 373     xpWrap (from_tuple, to_tuple) $
 374       xp7Tuple (xpElem "FinishPosition" xpInt)
 375                (xpElem "DriverID" xpInt)
 376                (xpElem "Name" xpText)
 377                (xpElem "LeadingLaps" xpInt)
 378                (xpElem "Laps" xpInt)
 379                (xpElem "Earnings" xpText)
 380                (xpElem "Status" xpText)
 381   where
 382     from_tuple =
 383       uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
 384
 385     to_tuple m = (xml_finish_position m,
 386                   xml_driver_id m,
 387                   xml_name m,
 388                   xml_leading_laps m,
 389                   xml_listing_laps m,
 390                   xml_earnings m,
 391                   xml_status m)
 392
 393
 394 --
 395 -- Tasty Tests
 396 --
 397
 398 -- | A list of all tests for this module.
 399 --
 400 auto_racing_schedule_tests :: TestTree
 401 auto_racing_schedule_tests =
 402   testGroup
 403     "AutoRacingSchedule tests"
 404     [ test_on_delete_cascade,
 405       test_pickle_of_unpickle_is_identity,
 406       test_unpickle_succeeds ]
 407
 408 -- | If we unpickle something and then pickle it, we should wind up
 409 --   with the same thing we started with. WARNING: success of this
 410 --   test does not mean that unpickling succeeded.
 411 --
 412 test_pickle_of_unpickle_is_identity :: TestTree
 413 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 414   [ check "pickle composed with unpickle is the identity"
 415           "test/xml/Auto_Racing_Schedule_XML.xml",
 416
 417     check "pickle composed with unpickle is the identity (miles track length)"
 418           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 419   where
 420     check desc path = testCase desc $ do
 421       (expected, actual) <- pickle_unpickle pickle_message path
 422       actual @?= expected
 423
 424
 425 -- | Make sure we can actually unpickle these things.
 426 --
 427 test_unpickle_succeeds :: TestTree
 428 test_unpickle_succeeds = testGroup "unpickle tests"
 429   [ check "unpickling succeeds"
 430           "test/xml/Auto_Racing_Schedule_XML.xml",
 431
 432     check "unpickling succeeds (non-int team_id)"
 433           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 434   where
 435     check desc path = testCase desc $ do
 436       actual <- unpickleable path pickle_message
 437       let expected = True
 438       actual @?= expected
 439
 440
 441 -- | Make sure everything gets deleted when we delete the top-level
 442 --   record.
 443 --
 444 test_on_delete_cascade :: TestTree
 445 test_on_delete_cascade = testGroup "cascading delete tests"
 446     [ check "deleting auto_racing_schedules deletes its children"
 447           "test/xml/Auto_Racing_Schedule_XML.xml" ,
 448
 449     check ("deleting auto_racing_schedules deletes its children " ++
 450             "(miles track length)")
 451           "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
 452   where
 453     check desc path = testCase desc $ do
 454       sched <- unsafe_unpickle path pickle_message
 455       let a = undefined :: AutoRacingSchedule
 456       let b = undefined :: AutoRacingScheduleListing
 457       let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
 458
 459       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 460                   runMigration silentMigrationLogger $ do
 461                     migrate a
 462                     migrate b
 463                     migrate c
 464                   _ <- dbimport sched
 465                   -- No idea how 'delete' works, so do this instead.
 466                   executeRaw False "DELETE FROM auto_racing_schedules;" []
 467                   count_a <- countAll a
 468                   count_b <- countAll b
 469                   count_c <- countAll c
 470                   return $ sum [count_a, count_b, count_c]
 471       let expected = 0
 472       actual @?= expected