src/TSN/XML/Weather.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 \"weatherxml.dtd\". Each document
   9 --   contains a bunch of forecasts, which each contain zero or more
  10 --   leagues, which in turn (each) contain a bunch of listings.
  11 --
  12 module TSN.XML.Weather (
  13   dtd,
  14   pickle_message,
  15   -- * Tests
  16   weather_tests,
  17   -- * WARNING: these are private but exported to silence warnings
  18   WeatherConstructor(..),
  19   WeatherDetailedWeatherListingItemConstructor(..),
  20   WeatherForecastConstructor(..),
  21   WeatherForecastListingConstructor(..) )
  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   xp8Tuple,
  46   xp9Tuple,
  47   xpAttr,
  48   xpElem,
  49   xpInt,
  50   xpList,
  51   xpOption,
  52   xpPair,
  53   xpText,
  54   xpTriple,
  55   xpWrap )
  56
  57 -- Local imports.
  58 import TSN.Codegen (
  59   tsn_codegen_config )
  60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  61 import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
  62 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  63 import Xml (
  64   Child(..),
  65   FromXml(..),
  66   FromXmlFk(..),
  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 = "weatherxml.dtd"
  78
  79
  80 --
  81 -- DB/XML Data types
  82 --
  83
  84 -- * WeatherForecastListing/WeatherForecastListingXml
  85
  86 -- | XML representation of a weather forecast listing.
  87 --
  88 data WeatherForecastListingXml =
  89   WeatherForecastListingXml {
  90     xml_teams :: String,
  91     xml_weather :: String }
  92   deriving (Eq, Show)
  93
  94
  95 -- | Database representation of a weather forecast listing. The
  96 --   'db_league_name' field should come from the containing \<league\>
  97 --   element which is not stored in the database.
  98 --
  99 data WeatherForecastListing =
 100   WeatherForecastListing {
 101     db_weather_forecasts_id :: DefaultKey WeatherForecast,
 102     db_league_name :: Maybe String,
 103     db_teams :: String,
 104     db_weather :: String }
 105
 106
 107 -- | We don't make 'WeatherForecastListingXml' an instance of
 108 --   'FromXmlFk' because it needs some additional information, namely
 109 --   the league name from its containing \<league\> element.
 110 --
 111 --   When supplied with a forecast id and a league name, this will
 112 --   turn an XML listing into a database one.
 113 --
 114 from_xml_fk_league :: DefaultKey WeatherForecast
 115                    -> (Maybe String)
 116                    -> WeatherForecastListingXml
 117                    -> WeatherForecastListing
 118 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
 119     WeatherForecastListing {
 120       db_weather_forecasts_id = fk,
 121       db_league_name = ln,
 122       db_teams = xml_teams,
 123       db_weather = xml_weather }
 124
 125
 126 -- * WeatherLeague
 127
 128 -- | XML representation of a league, as they appear in the weather
 129 --   documents. There is no associated database representation because
 130 --   the league element really adds no information besides its own
 131 --   (usually empty) name. The leagues contain listings, so we
 132 --   associate the league name with each listing instead.
 133 --
 134 data WeatherLeague =
 135   WeatherLeague {
 136     league_name :: Maybe String,
 137     listings    :: [WeatherForecastListingXml] }
 138   deriving (Eq, Show)
 139
 140
 141 -- * WeatherForecast/WeatherForecastXml
 142
 143 -- | Database representation of a weather forecast.
 144 --
 145 data WeatherForecast =
 146   WeatherForecast {
 147     db_weather_id :: DefaultKey Weather,
 148     db_game_date :: UTCTime }
 149
 150
 151 -- | XML representation of a weather forecast.
 152 --
 153 data WeatherForecastXml =
 154   WeatherForecastXml {
 155     xml_game_date :: UTCTime,
 156     xml_leagues :: [WeatherLeague] }
 157   deriving (Eq, Show)
 158
 159
 160 instance ToDb WeatherForecastXml where
 161   -- | The database representation of a 'WeatherForecastXml' is a
 162   --   'WeatherForecast'.
 163   --
 164   type Db WeatherForecastXml = WeatherForecast
 165
 166
 167 instance Child WeatherForecastXml where
 168   -- | The database type containing a 'WeatherForecastXml' is
 169   --   'Weather'.
 170   type Parent WeatherForecastXml = Weather
 171
 172
 173 instance FromXmlFk WeatherForecastXml where
 174
 175   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
 176   --   just copy everything verbatim.
 177   --
 178   from_xml_fk fk WeatherForecastXml{..} =
 179     WeatherForecast {
 180       db_weather_id  = fk,
 181       db_game_date   = xml_game_date }
 182
 183
 184 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
 185 --   without first converting it to the database representation.
 186 --
 187 instance XmlImportFk WeatherForecastXml
 188
 189 -- * WeatherDetailedWeatherXml
 190
 191 -- | XML Representation of a \<Detailed_Weather\>, which just contains
 192 --   a bunch iof \<DW_Listing\>s. There is no associated database type
 193 --   since these don't really contain any information.
 194 --
 195 data WeatherDetailedWeatherXml =
 196   WeatherDetailedWeatherXml {
 197     xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
 198   deriving (Eq, Show)
 199
 200
 201 -- * WeatherDetailedWeatherXml
 202
 203 -- | XML Representation of a \<DW_Listing\>. The sport and sport code
 204 --   come as attributes, but then these just contain a bunch of
 205 --   \<Item\>s. There is no associated database type since these don't
 206 --   contain much information. The sport we already know from the
 207 --   \<message\>, while the sport code is ignored since it's already
 208 --   present in each \<Item\>s.
 209 --
 210 data WeatherDetailedWeatherListingXml =
 211   WeatherDetailedWeatherListingXml {
 212     xml_dtl_listing_sport :: String,
 213     xml_dtl_listing_sport_code :: String,
 214     xml_items :: [WeatherDetailedWeatherListingItemXml] }
 215   deriving (Eq, Show)
 216
 217 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
 218
 219 -- | Database representation of a detailed weather item. The away/home
 220 --   teams don't use the representation in "TSN.Team" because all
 221 --   we're given is a name, and a team id is required for "TSN.Team".
 222 --
 223 --   We also drop the sport name, because it's given in the parent
 224 --   'Weather'.
 225 --
 226 data WeatherDetailedWeatherListingItem =
 227   WeatherDetailedWeatherListingItem {
 228     db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
 229                                              --   using \"dtl\" prefix.
 230     db_sport_code :: String,
 231     db_game_id :: Int,
 232     db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
 233     db_away_team :: String,
 234     db_home_team :: String,
 235     db_weather_type :: Int,
 236     db_description :: String,
 237     db_temp_adjust :: String,
 238     db_temperature :: Int }
 239
 240
 241 -- | XML representation of a detailed weather item. Same as the
 242 --   database representation, only without the foreign key and the
 243 --   sport name that comes from the containing listing.
 244 data WeatherDetailedWeatherListingItemXml =
 245   WeatherDetailedWeatherListingItemXml {
 246     xml_sport_code :: String,
 247     xml_game_id :: Int,
 248     xml_dtl_game_date :: UTCTime,
 249     xml_away_team :: String,
 250     xml_home_team :: String,
 251     xml_weather_type :: Int,
 252     xml_description :: String,
 253     xml_temp_adjust :: String,
 254     xml_temperature :: Int }
 255   deriving (Eq, Show)
 256
 257
 258 instance ToDb WeatherDetailedWeatherListingItemXml where
 259   -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
 260   type Db WeatherDetailedWeatherListingItemXml =
 261     WeatherDetailedWeatherListingItem
 262
 263 instance Child WeatherDetailedWeatherListingItemXml where
 264   -- | We skip two levels of containers and say that the items belong
 265   --   to the top-level 'Weather'.
 266   type Parent WeatherDetailedWeatherListingItemXml = Weather
 267
 268 instance FromXmlFk WeatherDetailedWeatherListingItemXml where
 269   -- | To convert from the XML to database representation, we simply
 270   --   add the foreign key (to Weather) and copy the rest of the fields.
 271   from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} =
 272     WeatherDetailedWeatherListingItem {
 273       db_dtl_weather_id = fk,
 274       db_sport_code = xml_sport_code,
 275       db_game_id = xml_game_id,
 276       db_dtl_game_date = xml_dtl_game_date,
 277       db_away_team = xml_away_team,
 278       db_home_team = xml_home_team,
 279       db_weather_type = xml_weather_type,
 280       db_description = xml_description,
 281       db_temp_adjust = xml_temp_adjust,
 282       db_temperature = xml_temperature }
 283
 284 -- | This allows us to insert the XML representation directly without
 285 --   having to do the manual XML -\> DB conversion.
 286 --
 287 instance XmlImportFk WeatherDetailedWeatherListingItemXml
 288
 289 -- * Weather/Message
 290
 291 -- | The database representation of a weather message. We don't
 292 -- contain the forecasts or the detailed weather since those are
 293 -- foreigned-keyed to us.
 294 --
 295 data Weather =
 296   Weather {
 297     db_xml_file_id :: Int,
 298     db_sport :: String,
 299     db_title :: String,
 300     db_time_stamp :: UTCTime }
 301
 302
 303 -- | The XML representation of a weather message.
 304 --
 305 data Message =
 306   Message {
 307     xml_xml_file_id :: Int,
 308     xml_heading :: String,
 309     xml_category :: String,
 310     xml_sport :: String,
 311     xml_title :: String,
 312     xml_forecasts :: [WeatherForecastXml],
 313     xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
 314     xml_time_stamp :: UTCTime }
 315   deriving (Eq, Show)
 316
 317 instance ToDb Message where
 318   -- | The database representation of 'Message' is 'Weather'.
 319   --
 320   type Db Message = Weather
 321
 322 instance FromXml Message where
 323   -- | To get a 'Weather' from a 'Message', we drop a bunch of
 324   --   unwanted fields.
 325   --
 326   from_xml Message{..} =
 327     Weather {
 328       db_xml_file_id = xml_xml_file_id,
 329       db_sport = xml_sport,
 330       db_title = xml_title,
 331       db_time_stamp = xml_time_stamp }
 332
 333 -- | This allows us to insert the XML representation 'Message'
 334 --   directly.
 335 --
 336 instance XmlImport Message
 337
 338
 339 --
 340 -- * Database stuff
 341 --
 342
 343 mkPersist tsn_codegen_config [groundhog|
 344 - entity: Weather
 345   constructors:
 346     - name: Weather
 347       uniques:
 348         - name: unique_weather
 349           type: constraint
 350           # Prevent multiple imports of the same message.
 351           fields: [db_xml_file_id]
 352
 353 - entity: WeatherForecast
 354   dbName: weather_forecasts
 355   constructors:
 356     - name: WeatherForecast
 357       fields:
 358         - name: db_weather_id
 359           reference:
 360             onDelete: cascade
 361
 362 - entity: WeatherForecastListing
 363   dbName: weather_forecast_listings
 364   constructors:
 365     - name: WeatherForecastListing
 366       fields:
 367         - name: db_weather_forecasts_id
 368           reference:
 369             onDelete: cascade
 370
 371 # We rename the two fields that needed a "dtl" prefix to avoid a name clash.
 372 - entity: WeatherDetailedWeatherListingItem
 373   dbName: weather_detailed_items
 374   constructors:
 375     - name: WeatherDetailedWeatherListingItem
 376       fields:
 377         - name: db_dtl_weather_id
 378           dbName: weather_id
 379           reference:
 380             onDelete: cascade
 381         - name: db_dtl_game_date
 382           dbName: game_date
 383
 384 |]
 385
 386
 387 instance DbImport Message where
 388   dbmigrate _ =
 389     run_dbmigrate $ do
 390       migrate (undefined :: Weather)
 391       migrate (undefined :: WeatherForecast)
 392       migrate (undefined :: WeatherForecastListing)
 393       migrate (undefined :: WeatherDetailedWeatherListingItem)
 394
 395   dbimport m = do
 396     -- First we insert the top-level weather record.
 397     weather_id <- insert_xml m
 398
 399     -- Next insert all of the forecasts, one at a time.
 400     forM_ (xml_forecasts m) $ \forecast -> do
 401       forecast_id <- insert_xml_fk weather_id forecast
 402
 403       -- With the forecast id in hand, loop through this forecast's
 404       -- leagues...
 405       forM_ (xml_leagues forecast) $ \league -> do
 406         -- Construct the function that converts an XML listing to a
 407         -- database one.
 408         let todb = from_xml_fk_league forecast_id (league_name league)
 409
 410         -- Now use it to convert all of the XML listings.
 411         let db_listings = map todb (listings league)
 412
 413         -- And finally, insert those DB listings.
 414         mapM_ insert_ db_listings
 415
 416     return ImportSucceeded
 417
 418
 419 --
 420 -- * Pickling
 421 --
 422
 423 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
 424 --
 425 pickle_listing :: PU WeatherForecastListingXml
 426 pickle_listing =
 427   xpElem "listing" $
 428     xpWrap (from_pair, to_pair) $
 429       xpPair
 430         (xpElem "teams" xpText)
 431         (xpElem "weather" xpText)
 432   where
 433     from_pair = uncurry WeatherForecastListingXml
 434     to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
 435
 436
 437 -- | Pickler to convert a 'WeatherLeague' to/from XML.
 438 --
 439 pickle_league :: PU WeatherLeague
 440 pickle_league =
 441   xpElem "league" $
 442     xpWrap (from_pair, to_pair) $
 443       xpPair
 444         (xpAttr "name" $ xpOption xpText)
 445         (xpList pickle_listing)
 446   where
 447     from_pair = uncurry WeatherLeague
 448     to_pair WeatherLeague{..} = (league_name, listings)
 449
 450
 451 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
 452 --
 453 pickle_forecast :: PU WeatherForecastXml
 454 pickle_forecast =
 455   xpElem "forecast" $
 456     xpWrap (from_pair, to_pair) $
 457       xpPair
 458         (xpAttr "gamedate" xp_gamedate)
 459         (xpList pickle_league)
 460   where
 461     from_pair = uncurry WeatherForecastXml
 462     to_pair WeatherForecastXml{..} = (xml_game_date,
 463                                       xml_leagues)
 464
 465
 466
 467 -- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
 468 --
 469 pickle_item :: PU WeatherDetailedWeatherListingItemXml
 470 pickle_item =
 471   xpElem "Item" $
 472     xpWrap (from_tuple, to_tuple) $
 473     xp9Tuple (xpElem "Sportcode" xpText)
 474              (xpElem "GameID" xpInt)
 475              (xpElem "Gamedate" xp_datetime)
 476              (xpElem "AwayTeam" xpText)
 477              (xpElem "HomeTeam" xpText)
 478              (xpElem "WeatherType" xpInt)
 479              (xpElem "Description" xpText)
 480              (xpElem "TempAdjust" xpText)
 481              (xpElem "Temperature" xpInt)
 482   where
 483     from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
 484     to_tuple w = (xml_sport_code w,
 485                   xml_game_id w,
 486                   xml_dtl_game_date w,
 487                   xml_away_team w,
 488                   xml_home_team w,
 489                   xml_weather_type w,
 490                   xml_description w,
 491                   xml_temp_adjust w,
 492                   xml_temperature w)
 493
 494
 495 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
 496 --
 497 pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
 498 pickle_dw_listing =
 499   xpElem "DW_Listing" $
 500     xpWrap (from_tuple, to_tuple) $
 501     xpTriple (xpAttr "SportCode" xpText)
 502              (xpAttr "Sport" xpText)
 503              (xpList pickle_item)
 504   where
 505     from_tuple = uncurryN WeatherDetailedWeatherListingXml
 506     to_tuple w = (xml_dtl_listing_sport w,
 507                   xml_dtl_listing_sport_code w,
 508                   xml_items w)
 509
 510
 511 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
 512 --
 513 pickle_detailed_weather :: PU WeatherDetailedWeatherXml
 514 pickle_detailed_weather =
 515   xpElem "Detailed_Weather" $
 516     xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
 517     (xpList pickle_dw_listing)
 518
 519
 520 -- | Pickler to convert a 'Message' to/from XML.
 521 --
 522 pickle_message :: PU Message
 523 pickle_message =
 524   xpElem "message" $
 525     xpWrap (from_tuple, to_tuple) $
 526       xp8Tuple
 527         (xpElem "XML_File_ID" xpInt)
 528         (xpElem "heading" xpText)
 529         (xpElem "category" xpText)
 530         (xpElem "sport" xpText)
 531         (xpElem "title" xpText)
 532         (xpList pickle_forecast)
 533         (xpOption pickle_detailed_weather)
 534         (xpElem "time_stamp" xp_time_stamp)
 535   where
 536     from_tuple = uncurryN Message
 537     to_tuple Message{..} = (xml_xml_file_id,
 538                             xml_heading,
 539                             xml_category,
 540                             xml_sport,
 541                             xml_title,
 542                             xml_forecasts,
 543                             xml_detailed_weather,
 544                             xml_time_stamp)
 545
 546
 547 --
 548 -- * Tasty tests
 549 --
 550 weather_tests :: TestTree
 551 weather_tests =
 552   testGroup
 553     "Weather tests"
 554     [ test_on_delete_cascade,
 555       test_pickle_of_unpickle_is_identity,
 556       test_unpickle_succeeds ]
 557
 558
 559 -- | If we unpickle something and then pickle it, we should wind up
 560 --   with the same thing we started with. WARNING: success of this
 561 --   test does not mean that unpickling succeeded.
 562 --
 563 test_pickle_of_unpickle_is_identity :: TestTree
 564 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 565   [ check "pickle composed with unpickle is the identity"
 566           "test/xml/weatherxml.xml",
 567
 568     check "pickle composed with unpickle is the identity (detailed)"
 569           "test/xml/weatherxml-detailed.xml" ]
 570   where
 571     check desc path = testCase desc $ do
 572       (expected, actual) <- pickle_unpickle pickle_message path
 573       actual @?= expected
 574
 575
 576 -- | Make sure we can actually unpickle these things.
 577 --
 578 test_unpickle_succeeds :: TestTree
 579 test_unpickle_succeeds = testGroup "unpickle tests"
 580   [ check "unpickling succeeds"
 581           "test/xml/weatherxml.xml",
 582     check "unpickling succeeds (detailed)"
 583           "test/xml/weatherxml-detailed.xml" ]
 584   where
 585     check desc path = testCase desc $ do
 586       actual <- unpickleable path pickle_message
 587       let expected = True
 588       actual @?= expected
 589
 590
 591 -- | Make sure everything gets deleted when we delete the top-level
 592 --   record.
 593 --
 594 test_on_delete_cascade :: TestTree
 595 test_on_delete_cascade = testGroup "cascading delete tests"
 596   [ check "deleting weather deletes its children"
 597           "test/xml/weatherxml.xml",
 598     check "deleting weather deletes its children (detailed)"
 599           "test/xml/weatherxml-detailed.xml" ]
 600   where
 601     check desc path = testCase desc $ do
 602       weather <- unsafe_unpickle path pickle_message
 603       let a = undefined :: Weather
 604       let b = undefined :: WeatherForecast
 605       let c = undefined :: WeatherForecastListing
 606       let d = undefined :: WeatherDetailedWeatherListingItem
 607       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 608                   runMigration silentMigrationLogger $ do
 609                     migrate a
 610                     migrate b
 611                     migrate c
 612                     migrate d
 613                   _ <- dbimport weather
 614                   deleteAll a
 615                   count_a <- countAll a
 616                   count_b <- countAll b
 617                   count_c <- countAll c
 618                   count_d <- countAll d
 619                   return $ count_a + count_b + count_c + count_d
 620       let expected = 0
 621       actual @?= expected