-- * Tests
weather_tests,
-- * WARNING: these are private but exported to silence warnings
+ Weather_WeatherForecastConstructor(..),
WeatherConstructor(..),
+ WeatherForecast_WeatherForecastListingConstructor(..),
WeatherForecastConstructor(..),
- WeatherListingConstructor(..) )
+ WeatherForecastListingConstructor(..) )
where
-- System imports.
+import Control.Monad ( forM_ )
+import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
---import Database.Groundhog (
--- insert_,
--- migrate )
---import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog (
+ insert_,
+ migrate )
+import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.TH (
groundhog,
mkPersist )
-- Local imports.
import TSN.Codegen (
tsn_codegen_config )
-import TSN.DbImport ( DbImport(..) )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.Picklers ( xp_gamedate, xp_time_stamp )
import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
-data WeatherListing =
- WeatherListing {
+--
+-- DB/XML Data types
+--
+
+-- | Database/XML representation of a weather forecast listing.
+--
+data WeatherForecastListing =
+ WeatherForecastListing {
db_teams :: String,
db_weather :: String }
deriving (Eq, Show)
-instance FromXml WeatherListing where
- type Db WeatherListing = WeatherListing
+-- | The database analogue of a 'WeatherForecastListing' is itself.
+instance ToDb WeatherForecastListing where
+ type Db WeatherForecastListing = WeatherForecastListing
+
+-- | This is needed to define the XmlImport instance for
+-- 'WeatherForecastListing'.
+--
+instance FromXml WeatherForecastListing where
from_xml = id
-instance XmlImport WeatherListing
+-- | Allows us to call 'insert_xml' on the XML representation of
+-- WeatherForecastListing.
+--
+instance XmlImport WeatherForecastListing
+-- | 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 :: [WeatherListing] }
+ listings :: [WeatherForecastListing] }
deriving (Eq, Show)
+
+-- | Database representation of a weather forecast.
+--
data WeatherForecast =
WeatherForecast {
- db_game_date :: String, -- ^ This is a 'String' instead of 'UTCTime'
- -- because they don't use a standard
- -- time format for the day of the month.
+ 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 :: String, -- ^ This is a 'String' instead of 'UTCTime'
- -- because they don't use a standard
- -- time format for the day of the month.
+ xml_game_date :: UTCTime,
xml_league :: 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 FromXml WeatherForecastXml where
+ -- | 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) }
+-- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
+-- without first converting it to the database representation.
+--
instance XmlImport WeatherForecastXml
+-- | 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.
+--
data Message =
Message {
xml_xml_file_id :: Int,
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.
+--
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
-
-- entity: WeatherListing
- dbName: weather_listings
+ 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
+ fields:
+ - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
+ dbName: weather_id
+ - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
+ dbName: weather_forecasts_id
+
+- entity: WeatherForecast_WeatherForecastListing
+ dbName: weather_forecasts__weather_forecast_listings
+ constructors:
+ - name: WeatherForecast_WeatherForecastListing
+ fields:
+ # Default by mkNormalFieldName
+ - name: weatherForecast_WeatherForecastListing0
+ dbName: weather_forecasts_id
+
+ # Default by mkNormalFieldName
+ - name: weatherForecast_WeatherForecastListing1
+ dbName: weather_forecast_listings_id
|]
instance DbImport Message where
- dbmigrate = undefined
- dbimport = undefined
+ dbmigrate _ =
+ run_dbmigrate $ do
+ 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.
+ 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
+
+ -- Map this forecast to its parent weather record.
+ insert_ (Weather_WeatherForecast weather_id forecast_id)
+
+ -- 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
+ return ImportSucceeded
-pickle_listing :: PU WeatherListing
+
+
+-- | Pickler to convert a 'WeatherForecastListing' to/from XML.
+--
+pickle_listing :: PU WeatherForecastListing
pickle_listing =
xpElem "listing" $
xpWrap (from_pair, to_pair) $
(xpElem "teams" xpText)
(xpElem "weather" xpText)
where
- from_pair = uncurry WeatherListing
- to_pair WeatherListing{..} = (db_teams, db_weather)
+ from_pair = uncurry WeatherForecastListing
+ to_pair WeatherForecastListing{..} = (db_teams, db_weather)
+
+-- | Pickler to convert a 'WeatherLeague' to/from XML.
+--
pickle_league :: PU WeatherLeague
pickle_league =
xpElem "league" $
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" xpText)
+ (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" $
(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,
projects / dead / htsn-import.git / blobdiff