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 zero or more
  10 --   leagues, which in turn (each) contain a bunch of listings.
  11 --
  12 module TSN.XML.Weather (
  13   dtd,
  14   is_type1,
  15   pickle_message,
  16   -- * Tests
  17   weather_tests,
  18   -- * WARNING: these are private but exported to silence warnings
  19   WeatherConstructor(..),
  20   WeatherDetailedWeatherListingItemConstructor(..),
  21   WeatherForecastConstructor(..),
  22   WeatherForecastListingConstructor(..) )
  23 where
  24
  25 -- System imports.
  26 import Control.Monad ( forM_ )
  27 import Data.Time ( UTCTime )
  28 import Data.Tuple.Curry ( uncurryN )
  29 import Database.Groundhog (
  30   countAll,
  31   deleteAll,
  32   insert_,
  33   migrate,
  34   runMigration,
  35   silentMigrationLogger )
  36 import Database.Groundhog.Core ( DefaultKey )
  37 import Database.Groundhog.Generic ( runDbConn )
  38 import Database.Groundhog.Sqlite ( withSqliteConn )
  39 import Database.Groundhog.TH (
  40   groundhog,
  41   mkPersist )
  42 import Test.Tasty ( TestTree, testGroup )
  43 import Test.Tasty.HUnit ( (@?=), testCase )
  44 import Text.XML.HXT.Core (
  45   PU,
  46   XmlTree,
  47   (/>),
  48   hasName,
  49   readDocument,
  50   runLA,
  51   runX,
  52   xp8Tuple,
  53   xp9Tuple,
  54   xpAttr,
  55   xpElem,
  56   xpInt,
  57   xpList,
  58   xpOption,
  59   xpPair,
  60   xpText,
  61   xpTriple,
  62   xpWrap )
  63
  64 -- Local imports.
  65 import TSN.Codegen (
  66   tsn_codegen_config )
  67 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  68 import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
  69 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  70 import Xml (
  71   Child(..),
  72   FromXml(..),
  73   FromXmlFk(..),
  74   ToDb(..),
  75   parse_opts,
  76   pickle_unpickle,
  77   unpickleable,
  78   unsafe_unpickle )
  79
  80
  81
  82 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  83 --
  84 dtd :: String
  85 dtd = "weatherxml.dtd"
  86
  87
  88 --
  89 -- DB/XML Data types
  90 --
  91
  92 -- * WeatherForecastListing/WeatherForecastListingXml
  93
  94 -- | XML representation of a weather forecast listing.
  95 --
  96 data WeatherForecastListingXml =
  97   WeatherForecastListingXml {
  98     xml_teams :: String,
  99     xml_weather :: String }
 100   deriving (Eq, Show)
 101
 102
 103 -- | Database representation of a weather forecast listing. The
 104 --   'db_league_name' field should come from the containing \<league\>
 105 --   element which is not stored in the database.
 106 --
 107 data WeatherForecastListing =
 108   WeatherForecastListing {
 109     db_weather_forecasts_id :: DefaultKey WeatherForecast,
 110     db_league_name :: Maybe String,
 111     db_teams :: String,
 112     db_weather :: String }
 113
 114
 115 -- | We don't make 'WeatherForecastListingXml' an instance of
 116 --   'FromXmlFk' because it needs some additional information, namely
 117 --   the league name from its containing \<league\> element.
 118 --
 119 --   When supplied with a forecast id and a league name, this will
 120 --   turn an XML listing into a database one.
 121 --
 122 from_xml_fk_league :: DefaultKey WeatherForecast
 123                    -> (Maybe String)
 124                    -> WeatherForecastListingXml
 125                    -> WeatherForecastListing
 126 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
 127     WeatherForecastListing {
 128       db_weather_forecasts_id = fk,
 129       db_league_name = ln,
 130       db_teams = xml_teams,
 131       db_weather = xml_weather }
 132
 133
 134 -- * WeatherLeague
 135
 136 -- | XML representation of a league, as they appear in the weather
 137 --   documents. There is no associated database representation because
 138 --   the league element really adds no information besides its own
 139 --   (usually empty) name. The leagues contain listings, so we
 140 --   associate the league name with each listing instead.
 141 --
 142 data WeatherLeague =
 143   WeatherLeague {
 144     league_name :: Maybe String,
 145     listings    :: [WeatherForecastListingXml] }
 146   deriving (Eq, Show)
 147
 148
 149 -- * WeatherForecast/WeatherForecastXml
 150
 151 -- | Database representation of a weather forecast.
 152 --
 153 data WeatherForecast =
 154   WeatherForecast {
 155     db_weather_id :: DefaultKey Weather,
 156     db_game_date :: UTCTime }
 157
 158
 159 -- | XML representation of a weather forecast.
 160 --
 161 data WeatherForecastXml =
 162   WeatherForecastXml {
 163     xml_game_date :: UTCTime,
 164     xml_leagues :: [WeatherLeague] }
 165   deriving (Eq, Show)
 166
 167
 168 instance ToDb WeatherForecastXml where
 169   -- | The database representation of a 'WeatherForecastXml' is a
 170   --   'WeatherForecast'.
 171   --
 172   type Db WeatherForecastXml = WeatherForecast
 173
 174
 175 instance Child WeatherForecastXml where
 176   -- | The database type containing a 'WeatherForecastXml' is
 177   --   'Weather'.
 178   type Parent WeatherForecastXml = Weather
 179
 180
 181 instance FromXmlFk WeatherForecastXml where
 182
 183   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
 184   --   add the foreign key to the containing 'Weather', and copy the
 185   --   game date.
 186   --
 187   from_xml_fk fk WeatherForecastXml{..} =
 188     WeatherForecast {
 189       db_weather_id  = fk,
 190       db_game_date   = xml_game_date }
 191
 192
 193 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
 194 --   without first converting it to the database representation.
 195 --
 196 instance XmlImportFk WeatherForecastXml
 197
 198 -- * WeatherDetailedWeatherXml
 199
 200 -- | XML Representation of a \<Detailed_Weather\>, which just contains
 201 --   a bunch iof \<DW_Listing\>s. There is no associated database type
 202 --   since these don't really contain any information.
 203 --
 204 data WeatherDetailedWeatherXml =
 205   WeatherDetailedWeatherXml {
 206     xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
 207   deriving (Eq, Show)
 208
 209
 210 -- * WeatherDetailedWeatherXml
 211
 212 -- | XML Representation of a \<DW_Listing\>. The sport and sport code
 213 --   come as attributes, but then these just contain a bunch of
 214 --   \<Item\>s. There is no associated database type since these don't
 215 --   contain much information. The sport we already know from the
 216 --   \<message\>, while the sport code is ignored since it's already
 217 --   present in each \<Item\>s.
 218 --
 219 data WeatherDetailedWeatherListingXml =
 220   WeatherDetailedWeatherListingXml {
 221     xml_dtl_listing_sport :: String,
 222     xml_dtl_listing_sport_code :: String,
 223     xml_items :: [WeatherDetailedWeatherListingItemXml] }
 224   deriving (Eq, Show)
 225
 226 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
 227
 228 -- | Database representation of a detailed weather item. The away/home
 229 --   teams don't use the representation in "TSN.Team" because all
 230 --   we're given is a name, and a team id is required for "TSN.Team".
 231 --
 232 --   We also drop the sport name, because it's given in the parent
 233 --   'Weather'.
 234 --
 235 data WeatherDetailedWeatherListingItem =
 236   WeatherDetailedWeatherListingItem {
 237     db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
 238                                              --   using \"dtl\" prefix.
 239     db_sport_code :: String,
 240     db_game_id :: Int,
 241     db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
 242     db_away_team :: String,
 243     db_home_team :: String,
 244     db_weather_type :: Int,
 245     db_description :: String,
 246     db_temp_adjust :: String,
 247     db_temperature :: Int }
 248
 249
 250 -- | XML representation of a detailed weather item. Same as the
 251 --   database representation, only without the foreign key and the
 252 --   sport name that comes from the containing listing.
 253 data WeatherDetailedWeatherListingItemXml =
 254   WeatherDetailedWeatherListingItemXml {
 255     xml_sport_code :: String,
 256     xml_game_id :: Int,
 257     xml_dtl_game_date :: UTCTime,
 258     xml_away_team :: String,
 259     xml_home_team :: String,
 260     xml_weather_type :: Int,
 261     xml_description :: String,
 262     xml_temp_adjust :: String,
 263     xml_temperature :: Int }
 264   deriving (Eq, Show)
 265
 266
 267 instance ToDb WeatherDetailedWeatherListingItemXml where
 268   -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
 269   type Db WeatherDetailedWeatherListingItemXml =
 270     WeatherDetailedWeatherListingItem
 271
 272 instance Child WeatherDetailedWeatherListingItemXml where
 273   -- | We skip two levels of containers and say that the items belong
 274   --   to the top-level 'Weather'.
 275   type Parent WeatherDetailedWeatherListingItemXml = Weather
 276
 277 instance FromXmlFk WeatherDetailedWeatherListingItemXml where
 278   -- | To convert from the XML to database representation, we simply
 279   --   add the foreign key (to Weather) and copy the rest of the fields.
 280   from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} =
 281     WeatherDetailedWeatherListingItem {
 282       db_dtl_weather_id = fk,
 283       db_sport_code = xml_sport_code,
 284       db_game_id = xml_game_id,
 285       db_dtl_game_date = xml_dtl_game_date,
 286       db_away_team = xml_away_team,
 287       db_home_team = xml_home_team,
 288       db_weather_type = xml_weather_type,
 289       db_description = xml_description,
 290       db_temp_adjust = xml_temp_adjust,
 291       db_temperature = xml_temperature }
 292
 293 -- | This allows us to insert the XML representation directly without
 294 --   having to do the manual XML -\> DB conversion.
 295 --
 296 instance XmlImportFk WeatherDetailedWeatherListingItemXml
 297
 298 -- * Weather/Message
 299
 300 -- | The database representation of a weather message. We don't
 301 -- contain the forecasts or the detailed weather since those are
 302 -- foreigned-keyed to us.
 303 --
 304 data Weather =
 305   Weather {
 306     db_xml_file_id :: Int,
 307     db_sport :: String,
 308     db_title :: String,
 309     db_time_stamp :: UTCTime }
 310
 311
 312 -- | The XML representation of a weather message.
 313 --
 314 data Message =
 315   Message {
 316     xml_xml_file_id :: Int,
 317     xml_heading :: String,
 318     xml_category :: String,
 319     xml_sport :: String,
 320     xml_title :: String,
 321     xml_forecasts :: [WeatherForecastXml],
 322     xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
 323     xml_time_stamp :: UTCTime }
 324   deriving (Eq, Show)
 325
 326 instance ToDb Message where
 327   -- | The database representation of 'Message' is 'Weather'.
 328   --
 329   type Db Message = Weather
 330
 331 instance FromXml Message where
 332   -- | To get a 'Weather' from a 'Message', we drop a bunch of
 333   --   unwanted fields.
 334   --
 335   from_xml Message{..} =
 336     Weather {
 337       db_xml_file_id = xml_xml_file_id,
 338       db_sport = xml_sport,
 339       db_title = xml_title,
 340       db_time_stamp = xml_time_stamp }
 341
 342 -- | This allows us to insert the XML representation 'Message'
 343 --   directly.
 344 --
 345 instance XmlImport Message
 346
 347
 348 --
 349 -- * Database stuff
 350 --
 351
 352 mkPersist tsn_codegen_config [groundhog|
 353 - entity: Weather
 354   constructors:
 355     - name: Weather
 356       uniques:
 357         - name: unique_weather
 358           type: constraint
 359           # Prevent multiple imports of the same message.
 360           fields: [db_xml_file_id]
 361
 362 - entity: WeatherForecast
 363   dbName: weather_forecasts
 364   constructors:
 365     - name: WeatherForecast
 366       fields:
 367         - name: db_weather_id
 368           reference:
 369             onDelete: cascade
 370
 371 - entity: WeatherForecastListing
 372   dbName: weather_forecast_listings
 373   constructors:
 374     - name: WeatherForecastListing
 375       fields:
 376         - name: db_weather_forecasts_id
 377           reference:
 378             onDelete: cascade
 379
 380 # We rename the two fields that needed a "dtl" prefix to avoid a name clash.
 381 - entity: WeatherDetailedWeatherListingItem
 382   dbName: weather_detailed_items
 383   constructors:
 384     - name: WeatherDetailedWeatherListingItem
 385       fields:
 386         - name: db_dtl_weather_id
 387           dbName: weather_id
 388           reference:
 389             onDelete: cascade
 390         - name: db_dtl_game_date
 391           dbName: game_date
 392
 393 |]
 394
 395
 396
 397 -- | There are two different types of documents that claim to be
 398 --   \"weatherxml.dtd\". The first, more common type has listings
 399 --   within forecasts. The second type has forecasts within
 400 --   listings. Clearly we can't parse both of these using the same
 401 --   parser!
 402 --
 403 --   For now we're simply punting on the issue and refusing to parse
 404 --   the second type. This will check the given @xmltree@ to see if
 405 --   there are any forecasts contained within listings. If there are,
 406 --   then it's the second type that we don't know what to do with.
 407 --
 408 is_type1 :: XmlTree -> Bool
 409 is_type1 xmltree =
 410   case elements of
 411     [] -> True
 412     _  -> False
 413   where
 414     parse :: XmlTree -> [XmlTree]
 415     parse = runLA $  hasName "/"
 416                   /> hasName "message"
 417                   /> hasName "listing"
 418                   /> hasName "forecast"
 419
 420     elements = parse xmltree
 421
 422
 423 instance DbImport Message where
 424   dbmigrate _ =
 425     run_dbmigrate $ do
 426       migrate (undefined :: Weather)
 427       migrate (undefined :: WeatherForecast)
 428       migrate (undefined :: WeatherForecastListing)
 429       migrate (undefined :: WeatherDetailedWeatherListingItem)
 430
 431   dbimport m = do
 432     -- First we insert the top-level weather record.
 433     weather_id <- insert_xml m
 434
 435     -- Next insert all of the forecasts, one at a time.
 436     forM_ (xml_forecasts m) $ \forecast -> do
 437       forecast_id <- insert_xml_fk weather_id forecast
 438
 439       -- With the forecast id in hand, loop through this forecast's
 440       -- leagues...
 441       forM_ (xml_leagues forecast) $ \league -> do
 442         -- Construct the function that converts an XML listing to a
 443         -- database one.
 444         let todb = from_xml_fk_league forecast_id (league_name league)
 445
 446         -- Now use it to convert all of the XML listings.
 447         let db_listings = map todb (listings league)
 448
 449         -- And finally, insert those DB listings.
 450         mapM_ insert_ db_listings
 451
 452     return ImportSucceeded
 453
 454
 455 --
 456 -- * Pickling
 457 --
 458
 459 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
 460 --
 461 pickle_listing :: PU WeatherForecastListingXml
 462 pickle_listing =
 463   xpElem "listing" $
 464     xpWrap (from_pair, to_pair) $
 465       xpPair
 466         (xpElem "teams" xpText)
 467         (xpElem "weather" xpText)
 468   where
 469     from_pair = uncurry WeatherForecastListingXml
 470     to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
 471
 472
 473 -- | Pickler to convert a 'WeatherLeague' to/from XML.
 474 --
 475 pickle_league :: PU WeatherLeague
 476 pickle_league =
 477   xpElem "league" $
 478     xpWrap (from_pair, to_pair) $
 479       xpPair
 480         (xpAttr "name" $ xpOption xpText)
 481         (xpList pickle_listing)
 482   where
 483     from_pair = uncurry WeatherLeague
 484     to_pair WeatherLeague{..} = (league_name, listings)
 485
 486
 487 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
 488 --
 489 pickle_forecast :: PU WeatherForecastXml
 490 pickle_forecast =
 491   xpElem "forecast" $
 492     xpWrap (from_pair, to_pair) $
 493       xpPair
 494         (xpAttr "gamedate" xp_gamedate)
 495         (xpList pickle_league)
 496   where
 497     from_pair = uncurry WeatherForecastXml
 498     to_pair WeatherForecastXml{..} = (xml_game_date,
 499                                       xml_leagues)
 500
 501
 502
 503 -- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
 504 --
 505 pickle_item :: PU WeatherDetailedWeatherListingItemXml
 506 pickle_item =
 507   xpElem "Item" $
 508     xpWrap (from_tuple, to_tuple) $
 509     xp9Tuple (xpElem "Sportcode" xpText)
 510              (xpElem "GameID" xpInt)
 511              (xpElem "Gamedate" xp_datetime)
 512              (xpElem "AwayTeam" xpText)
 513              (xpElem "HomeTeam" xpText)
 514              (xpElem "WeatherType" xpInt)
 515              (xpElem "Description" xpText)
 516              (xpElem "TempAdjust" xpText)
 517              (xpElem "Temperature" xpInt)
 518   where
 519     from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
 520     to_tuple w = (xml_sport_code w,
 521                   xml_game_id w,
 522                   xml_dtl_game_date w,
 523                   xml_away_team w,
 524                   xml_home_team w,
 525                   xml_weather_type w,
 526                   xml_description w,
 527                   xml_temp_adjust w,
 528                   xml_temperature w)
 529
 530
 531 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
 532 --
 533 pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
 534 pickle_dw_listing =
 535   xpElem "DW_Listing" $
 536     xpWrap (from_tuple, to_tuple) $
 537     xpTriple (xpAttr "SportCode" xpText)
 538              (xpAttr "Sport" xpText)
 539              (xpList pickle_item)
 540   where
 541     from_tuple = uncurryN WeatherDetailedWeatherListingXml
 542     to_tuple w = (xml_dtl_listing_sport w,
 543                   xml_dtl_listing_sport_code w,
 544                   xml_items w)
 545
 546
 547 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
 548 --
 549 pickle_detailed_weather :: PU WeatherDetailedWeatherXml
 550 pickle_detailed_weather =
 551   xpElem "Detailed_Weather" $
 552     xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
 553     (xpList pickle_dw_listing)
 554
 555
 556 -- | Pickler to convert a 'Message' to/from XML.
 557 --
 558 pickle_message :: PU Message
 559 pickle_message =
 560   xpElem "message" $
 561     xpWrap (from_tuple, to_tuple) $
 562       xp8Tuple
 563         (xpElem "XML_File_ID" xpInt)
 564         (xpElem "heading" xpText)
 565         (xpElem "category" xpText)
 566         (xpElem "sport" xpText)
 567         (xpElem "title" xpText)
 568         (xpList pickle_forecast)
 569         (xpOption pickle_detailed_weather)
 570         (xpElem "time_stamp" xp_time_stamp)
 571   where
 572     from_tuple = uncurryN Message
 573     to_tuple Message{..} = (xml_xml_file_id,
 574                             xml_heading,
 575                             xml_category,
 576                             xml_sport,
 577                             xml_title,
 578                             xml_forecasts,
 579                             xml_detailed_weather,
 580                             xml_time_stamp)
 581
 582
 583 --
 584 -- * Tasty tests
 585 --
 586 weather_tests :: TestTree
 587 weather_tests =
 588   testGroup
 589     "Weather tests"
 590     [ test_on_delete_cascade,
 591       test_pickle_of_unpickle_is_identity,
 592       test_unpickle_succeeds,
 593       test_types_detected_correctly ]
 594
 595
 596 -- | If we unpickle something and then pickle it, we should wind up
 597 --   with the same thing we started with. WARNING: success of this
 598 --   test does not mean that unpickling succeeded.
 599 --
 600 test_pickle_of_unpickle_is_identity :: TestTree
 601 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 602   [ check "pickle composed with unpickle is the identity"
 603           "test/xml/weatherxml.xml",
 604
 605     check "pickle composed with unpickle is the identity (detailed)"
 606           "test/xml/weatherxml-detailed.xml" ]
 607   where
 608     check desc path = testCase desc $ do
 609       (expected, actual) <- pickle_unpickle pickle_message path
 610       actual @?= expected
 611
 612
 613 -- | Make sure we can actually unpickle these things.
 614 --
 615 test_unpickle_succeeds :: TestTree
 616 test_unpickle_succeeds = testGroup "unpickle tests"
 617   [ check "unpickling succeeds"
 618           "test/xml/weatherxml.xml",
 619     check "unpickling succeeds (detailed)"
 620           "test/xml/weatherxml-detailed.xml" ]
 621   where
 622     check desc path = testCase desc $ do
 623       actual <- unpickleable path pickle_message
 624       let expected = True
 625       actual @?= expected
 626
 627
 628 -- | Make sure everything gets deleted when we delete the top-level
 629 --   record.
 630 --
 631 test_on_delete_cascade :: TestTree
 632 test_on_delete_cascade = testGroup "cascading delete tests"
 633   [ check "deleting weather deletes its children"
 634           "test/xml/weatherxml.xml",
 635     check "deleting weather deletes its children (detailed)"
 636           "test/xml/weatherxml-detailed.xml" ]
 637   where
 638     check desc path = testCase desc $ do
 639       weather <- unsafe_unpickle path pickle_message
 640       let a = undefined :: Weather
 641       let b = undefined :: WeatherForecast
 642       let c = undefined :: WeatherForecastListing
 643       let d = undefined :: WeatherDetailedWeatherListingItem
 644       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 645                   runMigration silentMigrationLogger $ do
 646                     migrate a
 647                     migrate b
 648                     migrate c
 649                     migrate d
 650                   _ <- dbimport weather
 651                   deleteAll a
 652                   count_a <- countAll a
 653                   count_b <- countAll b
 654                   count_c <- countAll c
 655                   count_d <- countAll d
 656                   return $ count_a + count_b + count_c + count_d
 657       let expected = 0
 658       actual @?= expected
 659
 660
 661 test_types_detected_correctly :: TestTree
 662 test_types_detected_correctly =
 663   testGroup "weatherxml types detected correctly" $
 664     [ check "test/xml/weatherxml.xml"
 665             "first type detected correctly"
 666             True,
 667       check "test/xml/weatherxml-detailed.xml"
 668             "first type detected correctly (detailed)"
 669             True,
 670       check "test/xml/weatherxml-type2.xml"
 671             "second type detected correctly"
 672             False ]
 673   where
 674     unsafe_get_xmltree :: String -> IO XmlTree
 675     unsafe_get_xmltree path =
 676       fmap head $ runX $ readDocument parse_opts path
 677
 678     check path desc expected = testCase desc $ do
 679       xmltree <- unsafe_get_xmltree path
 680       let actual = is_type1 xmltree
 681       actual @?= expected