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