-- * Tests
weather_tests,
-- * WARNING: these are private but exported to silence warnings
- Weather_WeatherForecastConstructor(..),
WeatherConstructor(..),
- WeatherForecast_WeatherForecastListingConstructor(..),
WeatherForecastConstructor(..),
WeatherForecastListingConstructor(..) )
where
import Control.Monad ( forM_ )
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
-import Database.Groundhog (
- insert_,
- migrate )
+import Database.Groundhog ( migrate )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.TH (
groundhog,
tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_gamedate, xp_time_stamp )
-import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+ FromXml(..),
+ FromXmlFk(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable )
--
-- DB/XML Data types
--
--- | Database/XML representation of a weather forecast listing.
+-- | 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 }
- deriving (Eq, Show)
--- | The database analogue of a 'WeatherForecastListing' is itself.
-instance ToDb WeatherForecastListing where
- type Db WeatherForecastListing = WeatherForecastListing
+
+-- | The database analogue of a 'WeatherForecastListingXml' is
+-- 'WeatherForecastListing'.
+--
+instance ToDb WeatherForecastListingXml where
+ type Db WeatherForecastListingXml = WeatherForecastListing
-- | This is needed to define the XmlImport instance for
-- 'WeatherForecastListing'.
--
-instance FromXml WeatherForecastListing where
- from_xml = id
+instance FromXmlFk WeatherForecastListingXml where
+ type Parent WeatherForecastListingXml = WeatherForecast
+
+ from_xml_fk fk WeatherForecastListingXml{..} =
+ WeatherForecastListing {
+ db_weather_forecasts_id = fk,
+ db_teams = xml_teams,
+ db_weather = xml_weather }
-- | Allows us to call 'insert_xml' on the XML representation of
-- WeatherForecastListing.
--
-instance XmlImport WeatherForecastListing
+instance XmlImportFk WeatherForecastListingXml
-- | XML representation of a league, as they appear in the weather
data WeatherLeague =
WeatherLeague {
league_name :: Maybe String,
- listings :: [WeatherForecastListing] }
+ listings :: [WeatherForecastListingXml] }
deriving (Eq, Show)
-
-- | Database representation of a weather forecast.
--
data WeatherForecast =
WeatherForecast {
+ db_weather_id :: DefaultKey Weather,
db_game_date :: UTCTime,
db_league_name :: Maybe String }
xml_league :: WeatherLeague }
deriving (Eq, Show)
-
instance ToDb WeatherForecastXml where
-- | The database representation of a 'WeatherForecastXml' is a
-- 'WeatherForecast'.
--
type Db WeatherForecastXml = WeatherForecast
-instance FromXml WeatherForecastXml where
+instance FromXmlFk WeatherForecastXml where
+ type Parent WeatherForecastXml = Weather
+
-- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
-- replace the 'WeatherLeague' with its name.
--
- 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,
+ 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 XmlImport WeatherForecastXml
+instance XmlImportFk WeatherForecastXml
-- | The database representation of a weather message.
xml_time_stamp :: UTCTime }
deriving (Eq, Show)
-
instance ToDb Message where
-- | The database representation of 'Message' is 'Weather'.
--
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.
---
-data WeatherForecast_WeatherForecastListing =
- WeatherForecast_WeatherForecastListing
- (DefaultKey WeatherForecast)
- (DefaultKey WeatherForecastListing)
-
mkPersist tsn_codegen_config [groundhog|
- entity: Weather
constructors:
- 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
-- Next insert all of the forecasts, one at a time.
forM_ (xml_forecasts m) $ \forecast -> do
- forecast_id <- insert_xml forecast
-
- -- Map this forecast to its parent weather record.
- insert_ (Weather_WeatherForecast weather_id forecast_id)
+ forecast_id <- insert_xml_fk weather_id forecast
-- Insert all of this forecast's listings.
- forM_ (listings $ xml_league forecast) $ \listing -> do
- listing_id <- insert_xml listing
-
- -- Map this listing to its parent forecast.
- insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
+ mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)
return ImportSucceeded
--- | 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.
projects / dead / htsn-import.git / commitdiff
