From: Michael Orlitzky Date: Thu, 16 Jan 2014 01:33:19 +0000 (-0500) Subject: Minimal undocumented implementation of TSN.XML.Weather. X-Git-Tag: 0.0.1~44 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=4fc769d60f0cac3b4a0cf38add8d8e883583bd61;p=dead%2Fhtsn-import.git Minimal undocumented implementation of TSN.XML.Weather. Add weatherxml.dtd support to Main. --- diff --git a/src/Main.hs b/src/Main.hs index 10b1ace..663c51c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -172,6 +172,11 @@ import_file cfg path = do let errmsg = "Could not unpickle Odds_XML." maybe (return $ ImportFailed errmsg) migrate_and_import m + | dtd == "weatherxml.dtd" = do + let m = unpickleDoc Weather.pickle_message xml + let errmsg = "Could not unpickle weatherxml." + maybe (return $ ImportFailed errmsg) migrate_and_import m + | otherwise = do let infomsg = "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "." diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index 4cbfb47..092cc7e 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -14,17 +14,21 @@ module TSN.XML.Weather ( -- * 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 ) @@ -45,42 +49,39 @@ import Text.XML.HXT.Core ( -- Local imports. import TSN.Codegen ( tsn_codegen_config ) -import TSN.DbImport ( DbImport(..) ) +import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) +import TSN.Picklers ( xp_gamedate ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), pickle_unpickle, unpickleable ) -data WeatherListing = - WeatherListing { +data WeatherForecastListing = + WeatherForecastListing { db_teams :: String, db_weather :: String } deriving (Eq, Show) -instance FromXml WeatherListing where - type Db WeatherListing = WeatherListing +instance FromXml WeatherForecastListing where + type Db WeatherForecastListing = WeatherForecastListing from_xml = id -instance XmlImport WeatherListing +instance XmlImport WeatherForecastListing data WeatherLeague = WeatherLeague { league_name :: Maybe String, - listings :: [WeatherListing] } + listings :: [WeatherForecastListing] } deriving (Eq, Show) 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 } 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) @@ -120,24 +121,73 @@ instance FromXml Message where instance XmlImport Message +data Weather_WeatherForecast = + Weather_WeatherForecast + (DefaultKey Weather) + (DefaultKey WeatherForecast) + +data WeatherForecast_WeatherForecastListing = + WeatherForecast_WeatherForecastListing + (DefaultKey WeatherForecast) + (DefaultKey WeatherForecastListing) + mkPersist tsn_codegen_config [groundhog| - entity: Weather -- entity: WeatherListing - dbName: weather_listings - - 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 + weather_id <- insert_xml m + + forM_ (xml_forecasts m) $ \forecast -> do + forecast_id <- insert_xml forecast + insert_ (Weather_WeatherForecast weather_id forecast_id) + forM_ (listings $ xml_league forecast) $ \listing -> do + listing_id <- insert_xml listing + insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id + + return ImportSucceeded -pickle_listing :: PU WeatherListing +pickle_listing :: PU WeatherForecastListing pickle_listing = xpElem "listing" $ xpWrap (from_pair, to_pair) $ @@ -145,8 +195,8 @@ pickle_listing = (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) pickle_league :: PU WeatherLeague pickle_league = @@ -164,7 +214,7 @@ pickle_forecast = xpElem "forecast" $ xpWrap (from_pair, to_pair) $ xpPair - (xpAttr "gamedate" xpText) + (xpAttr "gamedate" xp_gamedate) pickle_league where from_pair = uncurry WeatherForecastXml