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   ScheduleChangesListing_TeamConstructor(..) )
  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   deleteAll,
  32   insert,
  33   insert_,
  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 Test.Tasty ( TestTree, testGroup )
  44 import Test.Tasty.HUnit ( (@?=), testCase )
  45 import Text.XML.HXT.Core (
  46   PU,
  47   xp6Tuple,
  48   xp11Tuple,
  49   xpAttr,
  50   xpElem,
  51   xpInt,
  52   xpList,
  53   xpOption,
  54   xpPair,
  55   xpText,
  56   xpWrap )
  57
  58 -- Local imports.
  59 import TSN.Codegen (
  60   tsn_codegen_config )
  61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  62 import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
  63 import TSN.Team ( Team(..) )
  64 import TSN.XmlImport ( XmlImport(..) )
  65 import Xml (
  66   FromXml(..),
  67   ToDb(..),
  68   pickle_unpickle,
  69   unpickleable,
  70   unsafe_unpickle )
  71
  72
  73
  74 -- | The DTD to which this module corresponds. Used to invoke 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, Show)
 109
 110
 111 -- | XML representation of a 'ScheduleChanges'. It has the same
 112 --   fields, but in addition contains the 'xml_listings'.
 113 --
 114 data Message =
 115   Message {
 116     xml_xml_file_id :: Int,
 117     xml_heading :: String,
 118     xml_category :: String,
 119     xml_sport :: String,
 120     xml_schedule_changes :: [ScheduleChangeXml],
 121     xml_time_stamp :: UTCTime }
 122   deriving (Eq, Show)
 123
 124
 125
 126 instance ToDb Message where
 127   -- | The database analogue of a 'Message' is a 'ScheduleChanges'.
 128   --
 129   type Db Message = ScheduleChanges
 130
 131
 132 -- | The 'FromXml' instance for 'Message' is required for the
 133 --   'XmlImport' instance.
 134 --
 135 instance FromXml Message where
 136   -- | To convert a 'Message' to an 'ScheduleChanges', we just drop
 137   --   the 'xml_schedule_changes'.
 138   --
 139   from_xml Message{..} =
 140     ScheduleChanges {
 141       db_xml_file_id = xml_xml_file_id,
 142       db_heading = xml_heading,
 143       db_category = xml_category,
 144       db_sport = xml_sport,
 145       db_time_stamp = xml_time_stamp }
 146
 147
 148 -- | This allows us to insert the XML representation 'Message'
 149 --   directly.
 150 --
 151 instance XmlImport Message
 152
 153
 154
 155 -- * ScheduleChangesListing/ScheduleChangesListingXml
 156
 157 -- | An embedded type within 'ScheduleChangesListing'. These look
 158 --   like, \<status numeral=\"4\"\>FINAL\</status\> within the XML,
 159 --   but they're in one-to-one correspondence with the listings.
 160 --
 161 data ScheduleChangesListingStatus =
 162   ScheduleChangesListingStatus {
 163     db_status_numeral :: Int,
 164     db_status         :: Maybe String }
 165   deriving (Eq, Show)
 166
 167
 168 -- | Database representation of a \<SC_Listing\> contained within a
 169 --   \<Schedule_Change\>, within a \<message\>. During the transition
 170 --   to the database, we drop the intermediate \<Schedule_Change\>
 171 --   leaving the listing keyed to the 'ScheduleChanges' itself.
 172 --
 173 --   The home/away teams reuse the 'Team' representation and are
 174 --   connected via 'ScheduleChangesListing_Team'.
 175 --
 176 --   The sport name (sc_sport) is pulled out of the containing
 177 --   \<Schedule_Change\> and embedded into the listings themselves.
 178 --
 179 data ScheduleChangesListing =
 180   ScheduleChangesListing {
 181     db_schedule_changes_id :: DefaultKey ScheduleChanges,
 182     db_type :: String,
 183     db_sc_sport :: String,
 184     db_schedule_id :: Int,
 185     db_game_time :: UTCTime,
 186     db_location :: 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 :: UTCTime,
 202     xml_location :: 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 --   'FromXmlFk' or 'XmlImportFk' because it needs some additional
 222 --   information, namely the sport name from its containing
 223 --   \<Schedule_Change\>.
 224 --
 225 from_xml_fk_sport :: (DefaultKey ScheduleChanges)
 226                   -> String
 227                   -> ScheduleChangesListingXml
 228                   -> ScheduleChangesListing
 229 from_xml_fk_sport fk sport ScheduleChangesListingXml{..} =
 230   ScheduleChangesListing {
 231     db_schedule_changes_id = fk,
 232     db_type = xml_type,
 233     db_sc_sport = sport,
 234     db_schedule_id = xml_schedule_id,
 235     db_game_time = make_game_time xml_game_date xml_game_time,
 236     db_location = xml_location,
 237     db_vscore = xml_vscore,
 238     db_hscore = xml_hscore,
 239     db_listing_status = xml_listing_status,
 240     db_notes = xml_notes }
 241
 242   where
 243     -- | Make the database \"game time\" from the XML
 244     --   date/time. Simply take the day part from one and the time
 245     --   from the other.
 246     --
 247     make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
 248
 249
 250
 251 -- * ScheduleChangesListing_Team
 252
 253 -- | Database mapping between listings and their home/away teams.
 254 --
 255 data ScheduleChangesListing_Team =
 256   ScheduleChangesListing_Team {
 257     sclt_schedule_changes_listings_id :: DefaultKey ScheduleChangesListing,
 258     sclt_away_team_id  :: DefaultKey Team,
 259     sclt_home_team_id  :: DefaultKey Team }
 260
 261
 262 -- * ScheduleChangesListingAwayTeamXml / ScheduleChangesListingHomeTeamXml
 263
 264 -- | The XML representation of a 'ScheduleChangesListing' away
 265 --   team. Its corresponding database representation (along with that
 266 --   of the home team) is a "TSN.Team", but their XML representations
 267 --   are different.
 268 data ScheduleChangesListingAwayTeamXml =
 269   ScheduleChangesListingAwayTeamXml {
 270     away_team_id :: String,
 271     away_team_name :: String }
 272   deriving (Eq, Show)
 273
 274 instance ToDb ScheduleChangesListingAwayTeamXml where
 275   -- | The database analogue of an 'ScheduleChangesListingAwayTeamXml' is
 276   --   a 'Team'.
 277   --
 278   type Db ScheduleChangesListingAwayTeamXml = Team
 279
 280 instance FromXml ScheduleChangesListingAwayTeamXml where
 281   -- | To convert a 'ScheduleChangesListingAwayTeamXml' to a 'Team',
 282   --   we set the non-existent abbreviation to \"Nothing\" and wrap
 283   --   the always-present name field in \"Just\".
 284   --
 285   from_xml ScheduleChangesListingAwayTeamXml{..} =
 286     Team {
 287       team_id = away_team_id,
 288       team_abbreviation = Nothing,
 289       team_name  = Just away_team_name }
 290
 291 -- | Allow us to import ScheduleChangesListingAwayTeamXml directly.
 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 :: String }
 304   deriving (Eq, Show)
 305
 306 instance ToDb ScheduleChangesListingHomeTeamXml where
 307   -- | The database analogue of an 'ScheduleChangesListingHomeTeamXml'
 308   --   is a 'Team'.
 309   --
 310   type Db ScheduleChangesListingHomeTeamXml = Team
 311
 312 instance FromXml ScheduleChangesListingHomeTeamXml where
 313   -- | To convert a 'ScheduleChangesListingHomeTeamXml' to a 'Team',
 314   --   we set the non-existent abbreviation to \"Nothing\" and wrap
 315   --   the always-present name field in \"Just\".
 316   --
 317   from_xml ScheduleChangesListingHomeTeamXml{..} =
 318     Team {
 319       team_id = home_team_id,
 320       team_abbreviation = Nothing,
 321       team_name  = Just home_team_name }
 322
 323 -- | Allow us to import ScheduleChangesListingHomeTeamXml directly.
 324 instance XmlImport ScheduleChangesListingHomeTeamXml
 325
 326
 327 --
 328 -- * Database stuff.
 329 --
 330
 331 instance DbImport Message where
 332   dbmigrate _ =
 333     run_dbmigrate $ do
 334       migrate (undefined :: Team)
 335       migrate (undefined :: ScheduleChanges)
 336       migrate (undefined :: ScheduleChangesListing)
 337       migrate (undefined :: ScheduleChangesListing_Team)
 338
 339   dbimport m = do
 340     -- Insert the top-level message
 341     msg_id <- insert_xml m
 342
 343     -- Now loop through the message's schedule changes
 344     forM_ (xml_schedule_changes m) $ \sc -> do
 345       -- Construct the function that will turn an XML listing into a DB one.
 346       let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)
 347
 348       -- Now loop through the listings so that we can handle the teams
 349       -- one listing at a time.
 350       forM_ (xml_sc_listings sc) $ \listing -> do
 351         let db_listing = listing_xml_to_db listing
 352         listing_id <- insert db_listing
 353
 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         -- Insert a record into schedule_changes_listings__teams
 358         -- mapping the home/away teams to this game. Use the full
 359         -- record syntax because the types would let us mix up the
 360         -- home/away teams.
 361         insert_ ScheduleChangesListing_Team {
 362                   sclt_schedule_changes_listings_id = listing_id,
 363                   sclt_away_team_id = away_team_id,
 364                   sclt_home_team_id = home_team_id }
 365
 366     return ImportSucceeded
 367
 368
 369 mkPersist tsn_codegen_config [groundhog|
 370 - entity: ScheduleChanges
 371   dbName: schedule_changes
 372   constructors:
 373     - name: ScheduleChanges
 374       uniques:
 375         - name: unique_schedule_changes
 376           type: constraint
 377           # Prevent multiple imports of the same message.
 378           fields: [db_xml_file_id]
 379
 380
 381 - entity: ScheduleChangesListing
 382   dbName: schedule_changes_listings
 383   constructors:
 384     - name: ScheduleChangesListing
 385       fields:
 386         - name: db_schedule_changes_id
 387           reference:
 388             onDelete: cascade
 389
 390 - embedded: ScheduleChangesListingStatus
 391   fields:
 392     - name: db_status_numeral
 393       dbName: status_numeral
 394     - name: db_status
 395       dbName: status
 396
 397
 398 - entity: ScheduleChangesListing_Team
 399   dbName: schedule_changes_listings__teams
 400   constructors:
 401     - name: ScheduleChangesListing_Team
 402       fields:
 403         - name: sclt_schedule_changes_listings_id
 404           reference:
 405             onDelete: cascade
 406         - name: sclt_away_team_id
 407           reference:
 408             onDelete: cascade
 409         - name: sclt_home_team_id
 410           reference:
 411             onDelete: cascade
 412 |]
 413
 414
 415
 416 --
 417 -- * Pickling
 418 --
 419
 420 pickle_away_team :: PU ScheduleChangesListingAwayTeamXml
 421 pickle_away_team =
 422   xpElem "Away_Team" $
 423     xpWrap (from_tuple, to_tuple) $
 424     xpPair (xpAttr "AT_ID" xpText)
 425            xpText
 426   where
 427     from_tuple = uncurry ScheduleChangesListingAwayTeamXml
 428     to_tuple t = (away_team_id t,
 429                   away_team_name t)
 430
 431 pickle_home_team :: PU ScheduleChangesListingHomeTeamXml
 432 pickle_home_team =
 433   xpElem "Home_Team" $
 434     xpWrap (from_tuple, to_tuple) $
 435     xpPair (xpAttr "HT_ID" xpText)
 436            xpText
 437   where
 438     from_tuple = uncurry ScheduleChangesListingHomeTeamXml
 439     to_tuple t = (home_team_id t,
 440                   home_team_name t)
 441
 442
 443 pickle_status :: PU ScheduleChangesListingStatus
 444 pickle_status =
 445   xpElem "status" $
 446     xpWrap (from_tuple, to_tuple) $
 447     xpPair (xpAttr "numeral" xpInt)
 448            (xpOption xpText)
 449   where
 450     from_tuple = uncurry ScheduleChangesListingStatus
 451     to_tuple s = (db_status_numeral s,
 452                   db_status s)
 453
 454
 455 pickle_listing :: PU ScheduleChangesListingXml
 456 pickle_listing =
 457   xpElem "SC_Listing" $
 458     xpWrap (from_tuple, to_tuple) $
 459     xp11Tuple (xpAttr "type" xpText)
 460               (xpElem "Schedule_ID" xpInt)
 461               (xpElem "Game_Date" xp_date_padded)
 462               (xpElem "Game_Time" xp_time)
 463               (xpElem "Location" xpText)
 464               pickle_away_team
 465               pickle_home_team
 466               (xpElem "vscore" xpInt)
 467               (xpElem "hscore" xpInt)
 468               pickle_status
 469               (xpElem "notes" (xpOption xpText))
 470   where
 471     from_tuple = uncurryN ScheduleChangesListingXml
 472     to_tuple l = (xml_type l,
 473                   xml_schedule_id l,
 474                   xml_game_date l,
 475                   xml_game_time l,
 476                   xml_location l,
 477                   xml_away_team l,
 478                   xml_home_team l,
 479                   xml_vscore l,
 480                   xml_hscore l,
 481                   xml_listing_status l,
 482                   xml_notes l)
 483
 484 pickle_schedule_change :: PU ScheduleChangeXml
 485 pickle_schedule_change =
 486   xpElem "Schedule_Change" $
 487     xpWrap (from_tuple, to_tuple) $
 488     xpPair (xpAttr "Sport" xpText)
 489            (xpList pickle_listing)
 490   where
 491     from_tuple = uncurry ScheduleChangeXml
 492     to_tuple sc = (xml_sc_sport sc,
 493                    xml_sc_listings sc)
 494
 495
 496 -- | Pickler for the top-level 'Message'.
 497 --
 498 pickle_message :: PU Message
 499 pickle_message =
 500   xpElem "message" $
 501     xpWrap (from_tuple, to_tuple) $
 502     xp6Tuple (xpElem "XML_File_ID" xpInt)
 503              (xpElem "heading" xpText)
 504              (xpElem "category" xpText)
 505              (xpElem "sport" xpText)
 506              (xpList pickle_schedule_change)
 507              (xpElem "time_stamp" xp_time_stamp)
 508   where
 509     from_tuple = uncurryN Message
 510     to_tuple m = (xml_xml_file_id m,
 511                   xml_heading m,
 512                   xml_category m,
 513                   xml_sport m,
 514                   xml_schedule_changes m,
 515                   xml_time_stamp m)
 516
 517
 518
 519 --
 520 -- * Tests
 521 --
 522 -- | A list of all tests for this module.
 523 --
 524 schedule_changes_tests :: TestTree
 525 schedule_changes_tests =
 526   testGroup
 527     "ScheduleChanges tests"
 528     [ test_on_delete_cascade,
 529       test_pickle_of_unpickle_is_identity,
 530       test_unpickle_succeeds ]
 531
 532 -- | If we unpickle something and then pickle it, we should wind up
 533 --   with the same thing we started with. WARNING: success of this
 534 --   test does not mean that unpickling succeeded.
 535 --
 536 test_pickle_of_unpickle_is_identity :: TestTree
 537 test_pickle_of_unpickle_is_identity =
 538   testCase "pickle composed with unpickle is the identity" $ do
 539     let path = "test/xml/Schedule_Changes_XML.xml"
 540     (expected, actual) <- pickle_unpickle pickle_message path
 541     actual @?= expected
 542
 543
 544
 545 -- | Make sure we can actually unpickle these things.
 546 --
 547 test_unpickle_succeeds :: TestTree
 548 test_unpickle_succeeds =
 549   testCase "unpickling succeeds" $ do
 550     let path = "test/xml/Schedule_Changes_XML.xml"
 551     actual <- unpickleable path pickle_message
 552
 553     let expected = True
 554     actual @?= expected
 555
 556
 557
 558 -- | Make sure everything gets deleted when we delete the top-level
 559 --   record.
 560 --
 561 test_on_delete_cascade :: TestTree
 562 test_on_delete_cascade =
 563   testCase "deleting auto_racing_results deletes its children" $ do
 564     let path = "test/xml/Schedule_Changes_XML.xml"
 565     results <- unsafe_unpickle path pickle_message
 566     let a = undefined :: Team
 567     let b = undefined :: ScheduleChanges
 568     let c = undefined :: ScheduleChangesListing
 569     let d = undefined :: ScheduleChangesListing_Team
 570
 571     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 572                 runMigration silentMigrationLogger $ do
 573                   migrate a
 574                   migrate b
 575                   migrate c
 576                   migrate d
 577                 _ <- dbimport results
 578                 deleteAll b
 579                 count_a <- countAll a
 580                 count_b <- countAll b
 581                 count_c <- countAll c
 582                 count_d <- countAll d
 583                 return $ sum [count_a, count_b, count_c, count_d]
 584     let expected = 12 -- There are 16 team elements, but 4 are dupes,
 585                       -- so 12 unique teams should be left over.
 586     actual @?= expected