X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;ds=sidebyside;f=src%2FTSN%2FXML%2FWeather.hs;h=6df3ce37615cfa48ba28cc028fb355a90dcbbb1d;hb=b2c39ebe5ff9c1ea3224231df5078c52d0ad8737;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..6df3ce3 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -5,26 +5,35 @@ {-# 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 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, + insert_, + 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 +54,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 ( + Child(..), + FromXml(..), + FromXmlFk(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) -data WeatherListing = - WeatherListing { - db_teams :: String, - db_weather :: String } + +-- | 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) -instance FromXml WeatherListing where - type Db WeatherListing = WeatherListing - from_xml = id -instance XmlImport WeatherListing +-- | Database representation of a weather forecast listing. The +-- 'db_league_name' field should come from the containing \ +-- 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 } +-- | We don't make 'WeatherForecastListingXml' an instance of +-- 'FromXmlFk' because it needs some additional information, namely +-- the league name from its containing \ element. +-- +-- When supplied with a forecast id and a league name, this will +-- turn an XML listing into a database one. +-- +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. The leagues contain listings, so we +-- associate the league name with each listing instead. +-- data WeatherLeague = WeatherLeague { - league_name :: Maybe String, - listings :: [WeatherListing] } + league_name :: Maybe String, + 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_league_name :: Maybe String } + db_weather_id :: DefaultKey Weather, + db_game_date :: UTCTime } + +-- | XML representation of a weather forecast. +-- 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_league :: WeatherLeague } + xml_game_date :: UTCTime, + 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 - from_xml WeatherForecastXml{..} = - WeatherForecast { db_game_date = xml_game_date, - db_league_name = (league_name xml_league) } -instance XmlImport WeatherForecastXml +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 + -- just copy everything verbatim. + -- + 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 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 +206,104 @@ 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 + -- 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 + + -- 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) + + -- Now use it to convert all of the XML listings. + let db_listings = map todb (listings league) + + -- And finally, insert those DB listings. + mapM_ insert_ db_listings + + 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 +311,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 +328,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) - pickle_league + (xpAttr "gamedate" xp_gamedate) + (xpList pickle_league) where from_pair = uncurry WeatherForecastXml to_pair WeatherForecastXml{..} = (xml_game_date, - xml_league) + xml_leagues) + + +-- | Pickler to convert a 'Message' to/from XML. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -182,7 +358,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 +377,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 +399,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