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 one league, and
  10 --   that league contains a bunch of listings.
  11 --
  12 module TSN.XML.Weather (
  13   pickle_message,
  14   -- * Tests
  15   weather_tests,
  16   -- * WARNING: these are private but exported to silence warnings
  17   WeatherConstructor(..),
  18   WeatherForecastConstructor(..),
  19   WeatherForecastListingConstructor(..) )
  20 where
  21
  22 -- System imports.
  23 import Control.Monad ( forM_ )
  24 import Data.Time ( UTCTime )
  25 import Data.Tuple.Curry ( uncurryN )
  26 import Database.Groundhog (
  27   countAll,
  28   executeRaw,
  29   migrate,
  30   runMigration,
  31   silentMigrationLogger )
  32 import Database.Groundhog.Core ( DefaultKey )
  33 import Database.Groundhog.Generic ( runDbConn )
  34 import Database.Groundhog.Sqlite ( withSqliteConn )
  35 import Database.Groundhog.TH (
  36   groundhog,
  37   mkPersist )
  38 import Test.Tasty ( TestTree, testGroup )
  39 import Test.Tasty.HUnit ( (@?=), testCase )
  40 import Text.XML.HXT.Core (
  41   PU,
  42   xp7Tuple,
  43   xpAttr,
  44   xpElem,
  45   xpInt,
  46   xpList,
  47   xpOption,
  48   xpPair,
  49   xpText,
  50   xpWrap )
  51
  52 -- Local imports.
  53 import TSN.Codegen (
  54   tsn_codegen_config )
  55 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  56 import TSN.Picklers ( xp_gamedate, xp_time_stamp )
  57 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  58 import Xml (
  59   FromXml(..),
  60   FromXmlFk(..),
  61   ToDb(..),
  62   pickle_unpickle,
  63   unpickleable,
  64   unsafe_unpickle )
  65
  66
  67 --
  68 -- DB/XML Data types
  69 --
  70
  71 -- * WeatherForecastListing/WeatherForecastListingXml
  72
  73 -- | XML representation of a weather forecast listing.
  74 --
  75 data WeatherForecastListingXml =
  76   WeatherForecastListingXml {
  77     xml_teams :: String,
  78     xml_weather :: String }
  79   deriving (Eq, Show)
  80
  81 -- | Database representation of a weather forecast listing.
  82 --
  83 data WeatherForecastListing =
  84   WeatherForecastListing {
  85     db_weather_forecasts_id :: DefaultKey WeatherForecast,
  86     db_teams :: String,
  87     db_weather :: String }
  88
  89
  90 -- | The database analogue of a 'WeatherForecastListingXml' is
  91 --   'WeatherForecastListing'.
  92 --
  93 instance ToDb WeatherForecastListingXml where
  94   type Db WeatherForecastListingXml = WeatherForecastListing
  95
  96 -- | This is needed to define the 'XmlImportFk' instance for
  97 --   'WeatherForecastListing'.
  98 --
  99 instance FromXmlFk WeatherForecastListingXml where
 100   -- | Each 'WeatherForecastListingXml' is contained in a
 101   --   'WeatherForecast'.
 102   --
 103   type Parent WeatherForecastListingXml = WeatherForecast
 104
 105   from_xml_fk fk WeatherForecastListingXml{..} =
 106     WeatherForecastListing {
 107       db_weather_forecasts_id = fk,
 108       db_teams = xml_teams,
 109       db_weather = xml_weather }
 110
 111 -- | This allows us to insert the XML representation
 112 --   'WeatherForecastListingXml' directly.
 113 --
 114 instance XmlImportFk WeatherForecastListingXml
 115
 116
 117 -- * WeatherLeague
 118
 119 -- | XML representation of a league, as they appear in the weather
 120 --   documents. There is no associated database representation because
 121 --   the league element really adds no information besides its own
 122 --   (usually empty) name. Since there's exactly one league per
 123 --   forecast, we just store the league_name in the database
 124 --   representation of a forecast.
 125 --
 126 data WeatherLeague =
 127   WeatherLeague {
 128     league_name     :: Maybe String,
 129     listings :: [WeatherForecastListingXml] }
 130   deriving (Eq, Show)
 131
 132
 133 -- * WeatherForecast/WeatherForecastXml
 134
 135 -- | Database representation of a weather forecast.
 136 --
 137 data WeatherForecast =
 138   WeatherForecast {
 139     db_weather_id :: DefaultKey Weather,
 140     db_game_date :: UTCTime,
 141     db_league_name :: Maybe String }
 142
 143 -- | XML representation of a weather forecast. It would have been
 144 --   cleaner to omit the 'WeatherLeague' middleman, but having it
 145 --   simplifies parsing.
 146 --
 147 data WeatherForecastXml =
 148   WeatherForecastXml {
 149     xml_game_date :: UTCTime,
 150     xml_league :: WeatherLeague }
 151   deriving (Eq, Show)
 152
 153 instance ToDb WeatherForecastXml where
 154   -- | The database representation of a 'WeatherForecastXml' is a
 155   --   'WeatherForecast'.
 156   --
 157   type Db WeatherForecastXml = WeatherForecast
 158
 159 instance FromXmlFk WeatherForecastXml where
 160   type Parent WeatherForecastXml = Weather
 161
 162   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
 163   --   replace the 'WeatherLeague' with its name.
 164   --
 165   from_xml_fk fk WeatherForecastXml{..} =
 166     WeatherForecast {
 167       db_weather_id  = fk,
 168       db_game_date   = xml_game_date,
 169       db_league_name = (league_name xml_league) }
 170
 171
 172 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
 173 --   without first converting it to the database representation.
 174 --
 175 instance XmlImportFk WeatherForecastXml
 176
 177
 178 -- * Weather/Message
 179
 180 -- | The database representation of a weather message.
 181 --
 182 data Weather =
 183   Weather {
 184     db_xml_file_id :: Int,
 185     db_sport :: String,
 186     db_title :: String,
 187     db_time_stamp :: UTCTime }
 188
 189
 190 -- | The XML representation of a weather message.
 191 --
 192 data Message =
 193   Message {
 194     xml_xml_file_id :: Int,
 195     xml_heading :: String,
 196     xml_category :: String,
 197     xml_sport :: String,
 198     xml_title :: String,
 199     xml_forecasts :: [WeatherForecastXml],
 200     xml_time_stamp :: UTCTime }
 201   deriving (Eq, Show)
 202
 203 instance ToDb Message where
 204   -- | The database representation of 'Message' is 'Weather'.
 205   --
 206   type Db Message = Weather
 207
 208 instance FromXml Message where
 209   -- | To get a 'Weather' from a 'Message', we drop a bunch of
 210   --   unwanted fields.
 211   --
 212   from_xml Message{..} =
 213     Weather {
 214       db_xml_file_id = xml_xml_file_id,
 215       db_sport = xml_sport,
 216       db_title = xml_title,
 217       db_time_stamp = xml_time_stamp }
 218
 219 -- | This allows us to insert the XML representation 'Message'
 220 --   directly.
 221 --
 222 instance XmlImport Message
 223
 224
 225 --
 226 -- Database stuff
 227 --
 228
 229 mkPersist tsn_codegen_config [groundhog|
 230 - entity: Weather
 231   constructors:
 232     - name: Weather
 233       uniques:
 234         - name: unique_weather
 235           type: constraint
 236           # Prevent multiple imports of the same message.
 237           fields: [db_xml_file_id]
 238
 239 - entity: WeatherForecast
 240   dbName: weather_forecasts
 241   constructors:
 242     - name: WeatherForecast
 243       fields:
 244         - name: db_weather_id
 245           reference:
 246             onDelete: cascade
 247
 248 - entity: WeatherForecastListing
 249   dbName: weather_forecast_listings
 250   constructors:
 251     - name: WeatherForecastListing
 252       fields:
 253         - name: db_weather_forecasts_id
 254           reference:
 255             onDelete: cascade
 256
 257 |]
 258
 259
 260 instance DbImport Message where
 261   dbmigrate _ =
 262     run_dbmigrate $ do
 263       migrate (undefined :: Weather)
 264       migrate (undefined :: WeatherForecast)
 265       migrate (undefined :: WeatherForecastListing)
 266
 267   dbimport m = do
 268     -- The weather database schema has a nice linear structure. First
 269     -- we insert the top-level weather record.
 270     weather_id <- insert_xml m
 271
 272     -- Next insert all of the forecasts, one at a time.
 273     forM_ (xml_forecasts m) $ \forecast -> do
 274       forecast_id <- insert_xml_fk weather_id forecast
 275
 276       -- Insert all of this forecast's listings.
 277       mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)
 278
 279     return ImportSucceeded
 280
 281
 282 ---
 283 --- Pickling
 284 ---
 285
 286 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
 287 --
 288 pickle_listing :: PU WeatherForecastListingXml
 289 pickle_listing =
 290   xpElem "listing" $
 291     xpWrap (from_pair, to_pair) $
 292       xpPair
 293         (xpElem "teams" xpText)
 294         (xpElem "weather" xpText)
 295   where
 296     from_pair = uncurry WeatherForecastListingXml
 297     to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
 298
 299
 300 -- | Pickler to convert a 'WeatherLeague' to/from XML.
 301 --
 302 pickle_league :: PU WeatherLeague
 303 pickle_league =
 304   xpElem "league" $
 305     xpWrap (from_pair, to_pair) $
 306       xpPair
 307         (xpAttr "name" $ xpOption xpText)
 308         (xpList pickle_listing)
 309   where
 310     from_pair = uncurry WeatherLeague
 311     to_pair WeatherLeague{..} = (league_name, listings)
 312
 313
 314 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
 315 --
 316 pickle_forecast :: PU WeatherForecastXml
 317 pickle_forecast =
 318   xpElem "forecast" $
 319     xpWrap (from_pair, to_pair) $
 320       xpPair
 321         (xpAttr "gamedate" xp_gamedate)
 322         pickle_league
 323   where
 324     from_pair = uncurry WeatherForecastXml
 325     to_pair WeatherForecastXml{..} = (xml_game_date,
 326                                       xml_league)
 327
 328
 329
 330 -- | Pickler to convert a 'Message' to/from XML.
 331 --
 332 pickle_message :: PU Message
 333 pickle_message =
 334   xpElem "message" $
 335     xpWrap (from_tuple, to_tuple) $
 336       xp7Tuple
 337         (xpElem "XML_File_ID" xpInt)
 338         (xpElem "heading" xpText)
 339         (xpElem "category" xpText)
 340         (xpElem "sport" xpText)
 341         (xpElem "title" xpText)
 342         (xpList pickle_forecast)
 343         (xpElem "time_stamp" xp_time_stamp)
 344   where
 345     from_tuple = uncurryN Message
 346     to_tuple Message{..} = (xml_xml_file_id,
 347                             xml_heading,
 348                             xml_category,
 349                             xml_sport,
 350                             xml_title,
 351                             xml_forecasts,
 352                             xml_time_stamp)
 353
 354 --
 355 -- Tasty tests
 356 --
 357
 358 weather_tests :: TestTree
 359 weather_tests =
 360   testGroup
 361     "Weather tests"
 362     [ test_on_delete_cascade,
 363       test_pickle_of_unpickle_is_identity,
 364       test_unpickle_succeeds ]
 365
 366
 367 -- | If we unpickle something and then pickle it, we should wind up
 368 --   with the same thing we started with. WARNING: success of this
 369 --   test does not mean that unpickling succeeded.
 370 --
 371 test_pickle_of_unpickle_is_identity :: TestTree
 372 test_pickle_of_unpickle_is_identity =
 373   testCase "pickle composed with unpickle is the identity" $ do
 374     let path = "test/xml/weatherxml.xml"
 375     (expected, actual) <- pickle_unpickle pickle_message path
 376     actual @?= expected
 377
 378
 379 -- | Make sure we can actually unpickle these things.
 380 --
 381 test_unpickle_succeeds :: TestTree
 382 test_unpickle_succeeds =
 383   testCase "unpickling succeeds" $ do
 384     let path = "test/xml/weatherxml.xml"
 385     actual <- unpickleable path pickle_message
 386     let expected = True
 387     actual @?= expected
 388
 389
 390 -- | Make sure everything gets deleted when we delete the top-level
 391 --   record.
 392 --
 393 test_on_delete_cascade :: TestTree
 394 test_on_delete_cascade =
 395   testCase "deleting weather deletes its children" $ do
 396     let path = "test/xml/weatherxml.xml"
 397     weather <- unsafe_unpickle path pickle_message
 398     let a = undefined :: Weather
 399     let b = undefined :: WeatherForecast
 400     let c = undefined :: WeatherForecastListing
 401     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 402                 runMigration silentMigrationLogger $ do
 403                   migrate a
 404                   migrate b
 405                   migrate c
 406                 _ <- dbimport weather
 407                 -- No idea how 'delete' works, so do this instead.
 408                 executeRaw False "DELETE FROM weather;" []
 409                 count_a <- countAll a
 410                 count_b <- countAll b
 411                 count_c <- countAll c
 412                 return $ count_a + count_b + count_c
 413     let expected = 0
 414     actual @?= expected