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