{-# 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.
+-- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
+-- contains a bunch of forecasts, which each contain zero or more
+-- leagues, which in turn (each) contain a bunch of listings.
--
module TSN.XML.Weather (
+ dtd,
pickle_message,
-- * Tests
weather_tests,
-- * WARNING: these are private but exported to silence warnings
- Weather_WeatherForecastConstructor(..),
WeatherConstructor(..),
- WeatherForecast_WeatherForecastListingConstructor(..),
WeatherForecastConstructor(..),
WeatherForecastListingConstructor(..) )
where
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog (
+ countAll,
+ deleteAll,
insert_,
- migrate )
+ 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 TSN.Codegen (
tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_gamedate )
-import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import TSN.Picklers ( xp_gamedate, xp_time_stamp )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+ Child(..),
+ FromXml(..),
+ FromXmlFk(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
--- | Database/XML representation of a weather forecast listing.
+-- | 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. The
+-- 'db_league_name' field should come from the containing \<league\>
+-- element which is not stored in the database.
--
data WeatherForecastListing =
WeatherForecastListing {
+ db_weather_forecasts_id :: DefaultKey WeatherForecast,
+ db_league_name :: Maybe String,
db_teams :: String,
db_weather :: String }
- deriving (Eq, Show)
--- | This is needed to define the XmlImport instance for
--- 'WeatherForecastListing'; it basically says that the DB
--- representation is the same as the XML representation.
---
-instance FromXml WeatherForecastListing where
- type Db WeatherForecastListing = WeatherForecastListing
- from_xml = id
--- | Allows us to call 'insert_xml' on the XML representation of
--- WeatherForecastListing.
+-- | We don't make 'WeatherForecastListingXml' an instance of
+-- 'FromXmlFk' because it needs some additional information, namely
+-- the league name from its containing \<league\> element.
+--
+-- When supplied with a forecast id and a league name, this will
+-- turn an XML listing into a database one.
--
-instance XmlImport WeatherForecastListing
+from_xml_fk_league :: DefaultKey WeatherForecast
+ -> (Maybe String)
+ -> WeatherForecastListingXml
+ -> WeatherForecastListing
+from_xml_fk_league fk ln WeatherForecastListingXml{..} =
+ WeatherForecastListing {
+ db_weather_forecasts_id = fk,
+ db_league_name = ln,
+ db_teams = xml_teams,
+ db_weather = xml_weather }
+-- * 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.
+-- (usually empty) name. The leagues contain listings, so we
+-- associate the league name with each listing instead.
--
data WeatherLeague =
WeatherLeague {
- league_name :: Maybe String,
- listings :: [WeatherForecastListing] }
+ league_name :: Maybe String,
+ listings :: [WeatherForecastListingXml] }
deriving (Eq, Show)
+-- * WeatherForecast/WeatherForecastXml
+
-- | Database representation of a weather forecast.
--
data WeatherForecast =
WeatherForecast {
- db_game_date :: UTCTime,
- db_league_name :: Maybe String }
+ db_weather_id :: DefaultKey Weather,
+ db_game_date :: UTCTime }
--- | XML representation of a weather forecast. It would have been
--- cleaner to omit the 'WeatherLeague' middleman, but having it
--- simplifies parsing.
+
+-- | XML representation of a weather forecast.
--
data WeatherForecastXml =
WeatherForecastXml {
xml_game_date :: UTCTime,
- xml_league :: WeatherLeague }
+ xml_leagues :: [WeatherLeague] }
deriving (Eq, Show)
-instance FromXml WeatherForecastXml where
+instance ToDb WeatherForecastXml where
-- | The database representation of a 'WeatherForecastXml' is a
-- 'WeatherForecast'.
--
type Db WeatherForecastXml = WeatherForecast
+
+instance Child WeatherForecastXml where
+ -- | The database type containing a 'WeatherForecastXml' is
+ -- 'Weather'.
+ type Parent WeatherForecastXml = Weather
+
+
+instance FromXmlFk WeatherForecastXml where
+
-- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
- -- replace the 'WeatherLeague' with its name.
+ -- just copy everything verbatim.
--
- from_xml WeatherForecastXml{..} =
- WeatherForecast { db_game_date = xml_game_date,
- db_league_name = (league_name xml_league) }
+ from_xml_fk fk WeatherForecastXml{..} =
+ WeatherForecast {
+ db_weather_id = fk,
+ db_game_date = xml_game_date }
+
-- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
-- without first converting it to the database representation.
--
-instance XmlImport WeatherForecastXml
+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_title :: String,
+ db_time_stamp :: UTCTime }
-- | The XML representation of a weather message.
xml_sport :: String,
xml_title :: String,
xml_forecasts :: [WeatherForecastXml],
- xml_time_stamp :: String }
+ xml_time_stamp :: UTCTime }
deriving (Eq, Show)
-
-instance FromXml Message where
+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_title = xml_title,
+ db_time_stamp = xml_time_stamp }
--- | This allows us to call 'insert_xml' on a 'Message' without first
--- converting it to the database representation.
+-- | This allows us to insert the XML representation 'Message'
+-- directly.
--
instance XmlImport Message
--- | A mapping between 'Weather' objects and their children
--- 'WeatherForecast's.
--
-data Weather_WeatherForecast =
- Weather_WeatherForecast
- (DefaultKey Weather)
- (DefaultKey WeatherForecast)
-
--- | A mapping between 'WeatherForecast' objects and their children
--- 'WeatherForecastListing's.
+-- Database stuff
--
-data WeatherForecast_WeatherForecastListing =
- WeatherForecast_WeatherForecastListing
- (DefaultKey WeatherForecast)
- (DefaultKey WeatherForecastListing)
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
-
-- entity: WeatherForecastListing
- dbName: weather_forecast_listings
-
-- entity: Weather_WeatherForecast
- dbName: weather__weather_forecasts
constructors:
- - name: Weather_WeatherForecast
+ - name: WeatherForecast
fields:
- - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
- dbName: weather_id
- - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
- dbName: weather_forecasts_id
+ - name: db_weather_id
+ reference:
+ onDelete: cascade
-- entity: WeatherForecast_WeatherForecastListing
- dbName: weather_forecasts__weather_forecast_listings
+- entity: WeatherForecastListing
+ dbName: weather_forecast_listings
constructors:
- - name: WeatherForecast_WeatherForecastListing
+ - name: WeatherForecastListing
fields:
- # Default by mkNormalFieldName
- - name: weatherForecast_WeatherForecastListing0
- dbName: weather_forecasts_id
+ - name: db_weather_forecasts_id
+ reference:
+ onDelete: cascade
- # Default by mkNormalFieldName
- - name: weatherForecast_WeatherForecastListing1
- dbName: weather_forecast_listings_id
|]
migrate (undefined :: Weather)
migrate (undefined :: WeatherForecast)
migrate (undefined :: WeatherForecastListing)
- migrate (undefined :: Weather_WeatherForecast)
- migrate (undefined :: WeatherForecast_WeatherForecastListing)
dbimport m = do
- -- The weather database schema has a nice linear structure. First
- -- we insert the top-level weather record.
+ -- 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 forecast
+ forecast_id <- insert_xml_fk weather_id forecast
- -- Map this forecast to its parent weather record.
- insert_ (Weather_WeatherForecast weather_id forecast_id)
+ -- With the forecast id in hand, loop through this forecast's
+ -- leagues...
+ forM_ (xml_leagues forecast) $ \league -> do
+ -- Construct the function that converts an XML listing to a
+ -- database one.
+ let todb = from_xml_fk_league forecast_id (league_name league)
- -- Insert all of this forecast's listings.
- forM_ (listings $ xml_league forecast) $ \listing -> do
- listing_id <- insert_xml listing
+ -- Now use it to convert all of the XML listings.
+ let db_listings = map todb (listings league)
- -- Map this listing to its parent forecast.
- insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
+ -- And finally, insert those DB listings.
+ mapM_ insert_ db_listings
return ImportSucceeded
+---
+--- Pickling
+---
--- | Pickler to convert a 'WeatherForecastListing' to/from XML.
+-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
--
-pickle_listing :: PU WeatherForecastListing
+pickle_listing :: PU WeatherForecastListingXml
pickle_listing =
xpElem "listing" $
xpWrap (from_pair, to_pair) $
(xpElem "teams" xpText)
(xpElem "weather" xpText)
where
- from_pair = uncurry WeatherForecastListing
- to_pair WeatherForecastListing{..} = (db_teams, db_weather)
+ from_pair = uncurry WeatherForecastListingXml
+ to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
-- | Pickler to convert a 'WeatherLeague' to/from XML.
xpWrap (from_pair, to_pair) $
xpPair
(xpAttr "gamedate" xp_gamedate)
- pickle_league
+ (xpList pickle_league)
where
from_pair = uncurry WeatherForecastXml
to_pair WeatherForecastXml{..} = (xml_game_date,
- xml_league)
+ xml_leagues)
(xpElem "sport" xpText)
(xpElem "title" xpText)
(xpList pickle_forecast)
- (xpElem "time_stamp" xpText)
+ (xpElem "time_stamp" xp_time_stamp)
where
from_tuple = uncurryN Message
to_tuple Message{..} = (xml_xml_file_id,
weather_tests =
testGroup
"Weather tests"
- [ test_pickle_of_unpickle_is_identity,
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
test_unpickle_succeeds ]
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
+ 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
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ count_c <- countAll c
+ return $ count_a + count_b + count_c
+ let expected = 0
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff