src/TSN/XML/ScheduleChanges.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   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 \"Schedule_Changes_XML.dtd\". Each
  10 --   \<message\> element contains zero or more \<Schedule_Change\>
  11 --   which are just a wrapper around zero or more \<SC_Listing\>s.
  12 --
  13 --   The teams appear to use the shared "TSN.Team" representation.
  14 --
  15 module TSN.XML.ScheduleChanges (
  16   dtd,
  17   pickle_message,
  18   -- * Tests
  19   schedule_changes_tests,
  20   -- * WARNING: these are private but exported to silence warnings
  21   ScheduleChangesConstructor(..),
  22   ScheduleChangesListingConstructor(..) )
  23 where
  24
  25 -- System imports.
  26 import Control.Monad ( forM_ )
  27 import Data.Time ( UTCTime(..) )
  28 import Data.Tuple.Curry ( uncurryN )
  29 import qualified Data.Vector.HFixed as H ( HVector, convert )
  30 import Database.Groundhog (
  31   countAll,
  32   deleteAll,
  33   insert_,
  34   migrate )
  35 import Database.Groundhog.Core ( DefaultKey )
  36 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
  37 import Database.Groundhog.Sqlite ( withSqliteConn )
  38 import Database.Groundhog.TH (
  39   groundhog,
  40   mkPersist )
  41 import qualified GHC.Generics as GHC ( Generic )
  42 import Test.Tasty ( TestTree, testGroup )
  43 import Test.Tasty.HUnit ( (@?=), testCase )
  44 import Text.XML.HXT.Core (
  45   PU,
  46   xp6Tuple,
  47   xp11Tuple,
  48   xpAttr,
  49   xpElem,
  50   xpInt,
  51   xpList,
  52   xpOption,
  53   xpPair,
  54   xpText,
  55   xpWrap )
  56
  57 -- Local imports.
  58 import TSN.Codegen ( tsn_codegen_config )
  59 import TSN.Database ( insert_or_select )
  60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  61 import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
  62 import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
  63 import TSN.XmlImport ( XmlImport(..) )
  64 import Xml (
  65   FromXml(..),
  66   ToDb(..),
  67   pickle_unpickle,
  68   unpickleable,
  69   unsafe_unpickle )
  70
  71
  72
  73 -- | The DTD to which this module corresponds. Used to invoke
  74 --   'dbimport'.
  75 --
  76 dtd :: String
  77 dtd = "Schedule_Changes_XML.dtd"
  78
  79
  80 --
  81 -- DB/XML data types
  82 --
  83
  84 -- * ScheduleChanges/Message
  85
  86 -- | Database representation of a 'Message'. Comparatively, it lacks
  87 --   the listings since they are linked via a foreign key.
  88 --
  89 data ScheduleChanges =
  90   ScheduleChanges {
  91     db_xml_file_id :: Int,
  92     db_heading :: String,
  93     db_category :: String,
  94     db_sport :: String,
  95     db_time_stamp :: UTCTime }
  96   deriving (Eq, Show)
  97
  98
  99 -- | XML representation of a \<Schedule_Change\> within a
 100 --   \<message\>. These are wrappers around a bunch of
 101 --   \<SC_Listing\>s, but they also contain the sport name for all of
 102 --   the contained listings.
 103 --
 104 data ScheduleChangeXml =
 105   ScheduleChangeXml {
 106     xml_sc_sport :: String,
 107     xml_sc_listings :: [ScheduleChangesListingXml] }
 108   deriving (Eq, GHC.Generic, Show)
 109
 110
 111 -- | For 'H.convert'.
 112 --
 113 instance H.HVector ScheduleChangeXml
 114
 115
 116 -- | XML representation of a 'ScheduleChanges'. It has the same
 117 --   fields, but in addition contains the 'xml_listings'.
 118 --
 119 data Message =
 120   Message {
 121     xml_xml_file_id :: Int,
 122     xml_heading :: String,
 123     xml_category :: String,
 124     xml_sport :: String,
 125     xml_schedule_changes :: [ScheduleChangeXml],
 126     xml_time_stamp :: UTCTime }
 127   deriving (Eq, GHC.Generic, Show)
 128
 129
 130 -- | For 'H.convert'.
 131 --
 132 instance H.HVector Message
 133
 134
 135 instance ToDb Message where
 136   -- | The database analogue of a 'Message' is a 'ScheduleChanges'.
 137   --
 138   type Db Message = ScheduleChanges
 139
 140
 141 -- | The 'FromXml' instance for 'Message' is required for the
 142 --   'XmlImport' instance.
 143 --
 144 instance FromXml Message where
 145   -- | To convert a 'Message' to an 'ScheduleChanges', we just drop
 146   --   the 'xml_schedule_changes'.
 147   --
 148   from_xml Message{..} =
 149     ScheduleChanges {
 150       db_xml_file_id = xml_xml_file_id,
 151       db_heading = xml_heading,
 152       db_category = xml_category,
 153       db_sport = xml_sport,
 154       db_time_stamp = xml_time_stamp }
 155
 156
 157 -- | This allows us to insert the XML representation 'Message'
 158 --   directly.
 159 --
 160 instance XmlImport Message
 161
 162
 163
 164 -- * ScheduleChangesListing/ScheduleChangesListingXml
 165
 166 -- | An embedded type within 'ScheduleChangesListing'. These look
 167 --   like, \<status numeral=\"4\"\>FINAL\</status\> within the XML,
 168 --   but they're in one-to-one correspondence with the listings.
 169 --
 170 --   The leading underscores prevent unused field warnings.
 171 --
 172 data ScheduleChangesListingStatus =
 173   ScheduleChangesListingStatus {
 174     _db_status_numeral :: Int,
 175     _db_status         :: Maybe String } -- Yes, they can be empty.
 176   deriving (Eq, GHC.Generic, Show)
 177
 178
 179 -- | For 'H.convert'.
 180 --
 181 instance H.HVector ScheduleChangesListingStatus
 182
 183
 184 -- | Database representation of a \<SC_Listing\> contained within a
 185 --   \<Schedule_Change\>, within a \<message\>. During the transition
 186 --   to the database, we drop the intermediate \<Schedule_Change\>
 187 --   leaving the listing keyed to the 'ScheduleChanges' itself.
 188 --
 189 --   The home/away teams reuse the 'Team' representation.
 190 --
 191 --   The sport name (sc_sport) is pulled out of the containing
 192 --   \<Schedule_Change\> and embedded into the listings themselves.
 193 --
 194 data ScheduleChangesListing =
 195   ScheduleChangesListing {
 196     db_schedule_changes_id :: DefaultKey ScheduleChanges,
 197     db_away_team_id :: DefaultKey Team,
 198     db_home_team_id ::DefaultKey Team,
 199     db_type :: String,
 200     db_sc_sport :: String,
 201     db_schedule_id :: Int,
 202     db_game_time :: UTCTime,
 203     db_location :: Maybe String,
 204     db_vscore :: Int,
 205     db_hscore :: Int,
 206     db_listing_status :: ScheduleChangesListingStatus,
 207     db_notes :: Maybe String }
 208
 209
 210 -- | XML representation of a \<SC_Listing\> contained within a
 211 --   \<Schedule_Change\>, within a \<message\>.
 212 --
 213 data ScheduleChangesListingXml =
 214   ScheduleChangesListingXml {
 215     xml_type :: String,
 216     xml_schedule_id :: Int,
 217     xml_game_date :: UTCTime,
 218     xml_game_time :: Maybe UTCTime,
 219     xml_location :: Maybe String,
 220     xml_away_team :: VTeam,
 221     xml_home_team :: HTeam,
 222     xml_vscore :: Int,
 223     xml_hscore :: Int,
 224     xml_listing_status :: ScheduleChangesListingStatus,
 225     xml_notes :: Maybe String }
 226   deriving (Eq, GHC.Generic, Show)
 227
 228
 229 -- | For 'H.convert'.
 230 --
 231 instance H.HVector ScheduleChangesListingXml
 232
 233
 234 instance ToDb ScheduleChangesListingXml where
 235   -- | The database analogue of an 'ScheduleChangesListingXml' is
 236   --   an 'ScheduleChangesListing'.
 237   --
 238   type Db ScheduleChangesListingXml = ScheduleChangesListing
 239
 240
 241
 242 -- | We don't make 'ScheduleChangesListingXml' an instance of
 243 --   'FromXmlFkTeams' because it needs some additional information,
 244 --   namely the sport name from its containing \<Schedule_Change\>.
 245 --   But essentially we'll need to do the same thing as
 246 --   'from_xml_fk_teams'. This function accomplishes the same thing,
 247 --   with the addition of the sport that's passed in.
 248 --
 249 --   The parameter order is for convenience later (see dbimport).
 250 --
 251 from_xml_fk_sport :: (DefaultKey ScheduleChanges)
 252                   -> String -- ^ The sport from our containing schedule change
 253                   -> (DefaultKey Team) -- ^ Away team FK
 254                   -> (DefaultKey Team) -- ^ Home team FK
 255                   -> ScheduleChangesListingXml
 256                   -> ScheduleChangesListing
 257 from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} =
 258   ScheduleChangesListing {
 259     db_schedule_changes_id = fk,
 260     db_away_team_id = fk_away,
 261     db_home_team_id = fk_home,
 262     db_type = xml_type,
 263     db_sc_sport = sport,
 264     db_schedule_id = xml_schedule_id,
 265     db_game_time = make_game_time xml_game_date xml_game_time,
 266     db_location = xml_location,
 267     db_vscore = xml_vscore,
 268     db_hscore = xml_hscore,
 269     db_listing_status = xml_listing_status,
 270     db_notes = xml_notes }
 271   where
 272     -- | Make the database \"game time\" from the XML
 273     --   date/time. Simply take the day part from one and the time
 274     --   from the other.
 275     --
 276     make_game_time d Nothing = d
 277     make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
 278
 279
 280
 281 --
 282 -- * Database stuff.
 283 --
 284
 285 instance DbImport Message where
 286   dbmigrate _ =
 287     run_dbmigrate $ do
 288       migrate (undefined :: Team)
 289       migrate (undefined :: ScheduleChanges)
 290       migrate (undefined :: ScheduleChangesListing)
 291
 292   dbimport m = do
 293     -- Insert the top-level message
 294     msg_id <- insert_xml m
 295
 296     -- Now loop through the message's schedule changes
 297     forM_ (xml_schedule_changes m) $ \sc -> do
 298       -- Construct the function that will turn an XML listing into a DB one.
 299       -- This is only partially applied without the away/home team IDs.
 300       let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)
 301
 302       -- Now loop through the listings so that we can handle the teams
 303       -- one listing at a time.
 304       forM_ (xml_sc_listings sc) $ \listing -> do
 305         away_team_id <- insert_or_select (vteam $ xml_away_team listing)
 306         home_team_id <- insert_or_select (hteam $ xml_home_team listing)
 307
 308         -- Finish constructing the xml -> db function.
 309         let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id
 310         let db_listing = listing_xml_to_db' listing
 311
 312         insert_ db_listing
 313
 314     return ImportSucceeded
 315
 316
 317 mkPersist tsn_codegen_config [groundhog|
 318 - entity: ScheduleChanges
 319   dbName: schedule_changes
 320   constructors:
 321     - name: ScheduleChanges
 322       uniques:
 323         - name: unique_schedule_changes
 324           type: constraint
 325           # Prevent multiple imports of the same message.
 326           fields: [db_xml_file_id]
 327
 328   # Note: we drop the "sc" prefix from the db_sc_sport field.
 329 - entity: ScheduleChangesListing
 330   dbName: schedule_changes_listings
 331   constructors:
 332     - name: ScheduleChangesListing
 333       fields:
 334         - name: db_schedule_changes_id
 335           reference:
 336             onDelete: cascade
 337         - name: db_away_team_id
 338           reference:
 339             onDelete: cascade
 340         - name: db_home_team_id
 341           reference:
 342             onDelete: cascade
 343         - name: db_sc_sport
 344           dbName: sport
 345         - name: db_listing_status
 346           embeddedType:
 347             - {name: status_numeral, dbName: status_numeral}
 348             - {name: status, dbName: status}
 349
 350 - embedded: ScheduleChangesListingStatus
 351   fields:
 352     - name: _db_status_numeral
 353       dbName: status_numeral
 354     - name: _db_status
 355       dbName: status
 356
 357 |]
 358
 359
 360
 361 --
 362 -- * Pickling
 363 --
 364
 365 -- | An (un)pickler for the \<Away_Team\> elements.
 366 --
 367 pickle_away_team :: PU VTeam
 368 pickle_away_team =
 369   xpElem "Away_Team" $
 370     xpWrap (from_tuple, to_tuple') $
 371     xpPair (xpAttr "AT_ID" xpText)
 372            (xpOption xpText)
 373   where
 374     from_tuple (x,y) = VTeam (Team x Nothing y)
 375     to_tuple' (VTeam t) = (team_id t, name t)
 376
 377
 378 -- | An (un)pickler for the \<Away_Team\> elements.
 379 --
 380 pickle_home_team :: PU HTeam
 381 pickle_home_team =
 382   xpElem "Home_Team" $
 383     xpWrap (from_tuple, to_tuple') $
 384     xpPair (xpAttr "HT_ID" xpText)
 385            (xpOption xpText)
 386   where
 387     from_tuple (x,y) = HTeam (Team x Nothing y)
 388     to_tuple' (HTeam t) = (team_id t, name t)
 389
 390
 391 -- | An (un)pickler for the \<status\> elements.
 392 --
 393 pickle_status :: PU ScheduleChangesListingStatus
 394 pickle_status =
 395   xpElem "status" $
 396     xpWrap (from_tuple, H.convert) $
 397     xpPair (xpAttr "numeral" xpInt)
 398            (xpOption xpText)
 399   where
 400     from_tuple = uncurry ScheduleChangesListingStatus
 401
 402
 403 -- | An (un)pickler for the \<SC_Listing\> elements.
 404 --
 405 pickle_listing :: PU ScheduleChangesListingXml
 406 pickle_listing =
 407   xpElem "SC_Listing" $
 408     xpWrap (from_tuple, H.convert) $
 409     xp11Tuple (xpAttr "type" xpText)
 410               (xpElem "Schedule_ID" xpInt)
 411               (xpElem "Game_Date" xp_date_padded)
 412               (xpElem "Game_Time" xp_tba_time)
 413               (xpElem "Location" (xpOption xpText))
 414               pickle_away_team
 415               pickle_home_team
 416               (xpElem "vscore" xpInt)
 417               (xpElem "hscore" xpInt)
 418               pickle_status
 419               (xpElem "notes" (xpOption xpText))
 420   where
 421     from_tuple = uncurryN ScheduleChangesListingXml
 422
 423
 424 -- | An (un)pickler for the \<Schedule_Change\> elements.
 425 --
 426 pickle_schedule_change :: PU ScheduleChangeXml
 427 pickle_schedule_change =
 428   xpElem "Schedule_Change" $
 429     xpWrap (from_tuple, H.convert) $
 430     xpPair (xpAttr "Sport" xpText)
 431            (xpList pickle_listing)
 432   where
 433     from_tuple = uncurry ScheduleChangeXml
 434
 435
 436 -- | Pickler for the top-level 'Message'.
 437 --
 438 pickle_message :: PU Message
 439 pickle_message =
 440   xpElem "message" $
 441     xpWrap (from_tuple, H.convert) $
 442     xp6Tuple (xpElem "XML_File_ID" xpInt)
 443              (xpElem "heading" xpText)
 444              (xpElem "category" xpText)
 445              (xpElem "sport" xpText)
 446              (xpList pickle_schedule_change)
 447              (xpElem "time_stamp" xp_time_stamp)
 448   where
 449     from_tuple = uncurryN Message
 450
 451
 452
 453 --
 454 -- * Tests
 455 --
 456 -- | A list of all tests for this module.
 457 --
 458 schedule_changes_tests :: TestTree
 459 schedule_changes_tests =
 460   testGroup
 461     "ScheduleChanges tests"
 462     [ test_on_delete_cascade,
 463       test_pickle_of_unpickle_is_identity,
 464       test_unpickle_succeeds ]
 465
 466 -- | If we unpickle something and then pickle it, we should wind up
 467 --   with the same thing we started with. WARNING: success of this
 468 --   test does not mean that unpickling succeeded.
 469 --
 470 test_pickle_of_unpickle_is_identity :: TestTree
 471 test_pickle_of_unpickle_is_identity =
 472   testCase "pickle composed with unpickle is the identity" $ do
 473     let path = "test/xml/Schedule_Changes_XML.xml"
 474     (expected, actual) <- pickle_unpickle pickle_message path
 475     actual @?= expected
 476
 477
 478
 479 -- | Make sure we can actually unpickle these things.
 480 --
 481 test_unpickle_succeeds :: TestTree
 482 test_unpickle_succeeds =
 483   testCase "unpickling succeeds" $ do
 484     let path = "test/xml/Schedule_Changes_XML.xml"
 485     actual <- unpickleable path pickle_message
 486
 487     let expected = True
 488     actual @?= expected
 489
 490
 491
 492 -- | Make sure everything gets deleted when we delete the top-level
 493 --   record.
 494 --
 495 test_on_delete_cascade :: TestTree
 496 test_on_delete_cascade =
 497   testCase "deleting auto_racing_results deletes its children" $ do
 498     let path = "test/xml/Schedule_Changes_XML.xml"
 499     results <- unsafe_unpickle path pickle_message
 500     let a = undefined :: Team
 501     let b = undefined :: ScheduleChanges
 502     let c = undefined :: ScheduleChangesListing
 503
 504     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 505                 runMigrationSilent $ do
 506                   migrate a
 507                   migrate b
 508                   migrate c
 509                 _ <- dbimport results
 510                 deleteAll b
 511                 count_a <- countAll a
 512                 count_b <- countAll b
 513                 count_c <- countAll c
 514                 return $ sum [count_a, count_b, count_c]
 515     let expected = 12 -- There are 16 team elements, but 4 are dupes,
 516                       -- so 12 unique teams should be left over.
 517     actual @?= expected