Weather.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

-- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
--   contains a bunch of forecasts, which each contain one league, and
--   that league contains a bunch of listings.
--
module TSN.XML.Weather (
  dtd,
  pickle_message,
  -- * Tests
  weather_tests,
  -- * WARNING: these are private but exported to silence warnings
  WeatherConstructor(..),
  WeatherForecastConstructor(..),
  WeatherForecastListingConstructor(..) )
where

-- System imports.
import Control.Monad ( forM_ )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog (
  countAll,
  executeRaw,
  migrate,
  runMigration,
  silentMigrationLogger )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.Generic ( runDbConn )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
  groundhog,
  mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  xp7Tuple,
  xpAttr,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPair,
  xpText,
  xpWrap )

-- Local imports.
import TSN.Codegen (
  tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_gamedate, xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
  FromXml(..),
  FromXmlFk(..),
  ToDb(..),
  pickle_unpickle,
  unpickleable,
  unsafe_unpickle )



-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
dtd :: String
dtd = "weatherxml.dtd"


--
-- DB/XML Data types
--

-- * WeatherForecastListing/WeatherForecastListingXml

-- | XML representation of a weather forecast listing.
--
data WeatherForecastListingXml =
  WeatherForecastListingXml {
    xml_teams :: String,
    xml_weather :: String }
  deriving (Eq, Show)

-- | Database representation of a weather forecast listing.
--
data WeatherForecastListing =
  WeatherForecastListing {
    db_weather_forecasts_id :: DefaultKey WeatherForecast,
    db_teams :: String,
    db_weather :: String }


-- | The database analogue of a 'WeatherForecastListingXml' is
--   'WeatherForecastListing'.
--
instance ToDb WeatherForecastListingXml where
  type Db WeatherForecastListingXml = WeatherForecastListing

-- | This is needed to define the 'XmlImportFk' instance for
--   'WeatherForecastListing'.
--
instance FromXmlFk WeatherForecastListingXml where
  -- | Each 'WeatherForecastListingXml' is contained in a
  --   'WeatherForecast'.
  --
  type Parent WeatherForecastListingXml = WeatherForecast

  from_xml_fk fk WeatherForecastListingXml{..} =
    WeatherForecastListing {
      db_weather_forecasts_id = fk,
      db_teams = xml_teams,
      db_weather = xml_weather }

-- | This allows us to insert the XML representation
--   'WeatherForecastListingXml' directly.
--
instance XmlImportFk WeatherForecastListingXml


-- * WeatherLeague

-- | XML representation of a league, as they appear in the weather
--   documents. There is no associated database representation because
--   the league element really adds no information besides its own
--   (usually empty) name. Since there's exactly one league per
--   forecast, we just store the league_name in the database
--   representation of a forecast.
--
data WeatherLeague =
  WeatherLeague {
    league_name     :: Maybe String,
    listings :: [WeatherForecastListingXml] }
  deriving (Eq, Show)


-- * WeatherForecast/WeatherForecastXml

-- | Database representation of a weather forecast.
--
data WeatherForecast =
  WeatherForecast {
    db_weather_id :: DefaultKey Weather,
    db_game_date :: UTCTime,
    db_league_name :: Maybe String }

-- | XML representation of a weather forecast. It would have been
--   cleaner to omit the 'WeatherLeague' middleman, but having it
--   simplifies parsing.
--
data WeatherForecastXml =
  WeatherForecastXml {
    xml_game_date :: UTCTime,
    xml_league :: WeatherLeague }
  deriving (Eq, Show)

instance ToDb WeatherForecastXml where
  -- | The database representation of a 'WeatherForecastXml' is a
  --   'WeatherForecast'.
  --
  type Db WeatherForecastXml = WeatherForecast

instance FromXmlFk WeatherForecastXml where
  type Parent WeatherForecastXml = Weather

  -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
  --   replace the 'WeatherLeague' with its name.
  --
  from_xml_fk fk WeatherForecastXml{..} =
    WeatherForecast {
      db_weather_id  = fk,
      db_game_date   = xml_game_date,
      db_league_name = (league_name xml_league) }


-- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
--   without first converting it to the database representation.
--
instance XmlImportFk WeatherForecastXml


-- * Weather/Message

-- | The database representation of a weather message.
--
data Weather =
  Weather {
    db_xml_file_id :: Int,
    db_sport :: String,
    db_title :: String,
    db_time_stamp :: UTCTime }


-- | The XML representation of a weather message.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_title :: String,
    xml_forecasts :: [WeatherForecastXml],
    xml_time_stamp :: UTCTime }
  deriving (Eq, Show)

instance ToDb Message where
  -- | The database representation of 'Message' is 'Weather'.
  --
  type Db Message = Weather

instance FromXml Message where
  -- | To get a 'Weather' from a 'Message', we drop a bunch of
  --   unwanted fields.
  --
  from_xml Message{..} =
    Weather {
      db_xml_file_id = xml_xml_file_id,
      db_sport = xml_sport,
      db_title = xml_title,
      db_time_stamp = xml_time_stamp }

-- | This allows us to insert the XML representation 'Message'
--   directly.
--
instance XmlImport Message


--
-- Database stuff
--

mkPersist tsn_codegen_config [groundhog|
- entity: Weather
  constructors:
    - name: Weather
      uniques:
        - name: unique_weather
          type: constraint
          # Prevent multiple imports of the same message.
          fields: [db_xml_file_id]

- entity: WeatherForecast
  dbName: weather_forecasts
  constructors:
    - name: WeatherForecast
      fields:
        - name: db_weather_id
          reference:
            onDelete: cascade

- entity: WeatherForecastListing
  dbName: weather_forecast_listings
  constructors:
    - name: WeatherForecastListing
      fields:
        - name: db_weather_forecasts_id
          reference:
            onDelete: cascade

|]


instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: Weather)
      migrate (undefined :: WeatherForecast)
      migrate (undefined :: WeatherForecastListing)

  dbimport m = do
    -- The weather database schema has a nice linear structure. First
    -- we insert the top-level weather record.
    weather_id <- insert_xml m

    -- Next insert all of the forecasts, one at a time.
    forM_ (xml_forecasts m) $ \forecast -> do
      forecast_id <- insert_xml_fk weather_id forecast

      -- Insert all of this forecast's listings.
      mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)

    return ImportSucceeded


---
--- Pickling
---

-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
--
pickle_listing :: PU WeatherForecastListingXml
pickle_listing =
  xpElem "listing" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpElem "teams" xpText)
        (xpElem "weather" xpText)
  where
    from_pair = uncurry WeatherForecastListingXml
    to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)


-- | Pickler to convert a 'WeatherLeague' to/from XML.
--
pickle_league :: PU WeatherLeague
pickle_league =
  xpElem "league" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpAttr "name" $ xpOption xpText)
        (xpList pickle_listing)
  where
    from_pair = uncurry WeatherLeague
    to_pair WeatherLeague{..} = (league_name, listings)


-- | Pickler to convert a 'WeatherForecastXml' to/from XML.
--
pickle_forecast :: PU WeatherForecastXml
pickle_forecast =
  xpElem "forecast" $
    xpWrap (from_pair, to_pair) $
      xpPair
        (xpAttr "gamedate" xp_gamedate)
        pickle_league
  where
    from_pair = uncurry WeatherForecastXml
    to_pair WeatherForecastXml{..} = (xml_game_date,
                                      xml_league)



-- | Pickler to convert a 'Message' to/from XML.
--
pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, to_tuple) $
      xp7Tuple
        (xpElem "XML_File_ID" xpInt)
        (xpElem "heading" xpText)
        (xpElem "category" xpText)
        (xpElem "sport" xpText)
        (xpElem "title" xpText)
        (xpList pickle_forecast)
        (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message
    to_tuple Message{..} = (xml_xml_file_id,
                            xml_heading,
                            xml_category,
                            xml_sport,
                            xml_title,
                            xml_forecasts,
                            xml_time_stamp)

--
-- Tasty tests
--

weather_tests :: TestTree
weather_tests =
  testGroup
    "Weather tests"
    [ test_on_delete_cascade,
      test_pickle_of_unpickle_is_identity,
      test_unpickle_succeeds ]


-- | If we unpickle something and then pickle it, we should wind up
--   with the same thing we started with. WARNING: success of this
--   test does not mean that unpickling succeeded.
--
test_pickle_of_unpickle_is_identity :: TestTree
test_pickle_of_unpickle_is_identity =
  testCase "pickle composed with unpickle is the identity" $ do
    let path = "test/xml/weatherxml.xml"
    (expected, actual) <- pickle_unpickle pickle_message path
    actual @?= expected


-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds =
  testCase "unpickling succeeds" $ do
    let path = "test/xml/weatherxml.xml"
    actual <- unpickleable path pickle_message
    let expected = True
    actual @?= expected


-- | Make sure everything gets deleted when we delete the top-level
--   record.
--
test_on_delete_cascade :: TestTree
test_on_delete_cascade =
  testCase "deleting weather deletes its children" $ do
    let path = "test/xml/weatherxml.xml"
    weather <- unsafe_unpickle path pickle_message
    let a = undefined :: Weather
    let b = undefined :: WeatherForecast
    let c = undefined :: WeatherForecastListing
    actual <- withSqliteConn ":memory:" $ runDbConn $ do
                runMigration silentMigrationLogger $ do
                  migrate a
                  migrate b
                  migrate c
                _ <- dbimport weather
                -- No idea how 'delete' works, so do this instead.
                executeRaw False "DELETE FROM weather;" []
                count_a <- countAll a
                count_b <- countAll b
                count_c <- countAll c
                return $ count_a + count_b + count_c
    let expected = 0
    actual @?= expected