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