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