X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=bda29ee2541005efb4ca1eaedcccf77d1231d201;hb=fa27649ae583f6bdc20c54db4fc8f38a382a536c;hp=4cbfb479002ffde908ac22f67f7728e642245f13;hpb=72d597df08493474acd291dcc8b43409c686b3c4;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index 4cbfb47..bda29ee 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -5,26 +5,34 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | Parse TSN XML for the DTD "weatherxml.dtd". Each document +-- | 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(..), - 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 ( + countAll, + deleteAll, + migrate, + runMigration, + silentMigrationLogger ) +import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) @@ -45,60 +53,150 @@ import Text.XML.HXT.Core ( -- Local imports. import TSN.Codegen ( tsn_codegen_config ) -import TSN.DbImport ( DbImport(..) ) -import TSN.XmlImport ( XmlImport(..) ) -import Xml ( FromXml(..), pickle_unpickle, unpickleable ) +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 ) -data WeatherListing = - WeatherListing { + +-- | 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 } - deriving (Eq, Show) -instance FromXml WeatherListing where - type Db WeatherListing = WeatherListing - from_xml = id -instance XmlImport WeatherListing +-- | 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 :: [WeatherListing] } + listings :: [WeatherForecastListingXml] } deriving (Eq, Show) + +-- * WeatherForecast/WeatherForecastXml + +-- | 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_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 :: 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 - from_xml WeatherForecastXml{..} = - WeatherForecast { db_game_date = xml_game_date, - db_league_name = (league_name xml_league) } -instance XmlImport WeatherForecastXml +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_title :: String, + db_time_stamp :: UTCTime } + +-- | The XML representation of a weather message. +-- data Message = Message { xml_xml_file_id :: Int, @@ -107,37 +205,95 @@ data 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 insert the XML representation 'Message' +-- directly. +-- instance XmlImport Message +-- +-- Database stuff +-- + 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 + 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 = undefined - dbimport = undefined + 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 +--- -pickle_listing :: PU WeatherListing +-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML. +-- +pickle_listing :: PU WeatherForecastListingXml pickle_listing = xpElem "listing" $ xpWrap (from_pair, to_pair) $ @@ -145,9 +301,12 @@ pickle_listing = (xpElem "teams" xpText) (xpElem "weather" xpText) where - from_pair = uncurry WeatherListing - to_pair WeatherListing{..} = (db_teams, db_weather) + 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" $ @@ -159,18 +318,25 @@ pickle_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" $ @@ -182,7 +348,7 @@ pickle_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, @@ -201,7 +367,8 @@ weather_tests :: TestTree weather_tests = testGroup "Weather tests" - [ test_pickle_of_unpickle_is_identity, + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] @@ -222,7 +389,33 @@ test_pickle_of_unpickle_is_identity = 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