src/TSN/XML/ScheduleChanges.hs

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