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