X-Git-Url: https://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=1d17fb017ba130522df58c217f70ee82b0798b8b;hb=819ac1c4b1f16bde572728d76bfd72282d0605ec;hp=c2eee4a6c739625d9ec19f114fadae12f854072b;hpb=6ccdf3223bd4025a8e57cec1c99633a381a9698e;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index c2eee4a..1d17fb0 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -11,7 +12,9 @@ -- module TSN.XML.Weather ( dtd, + is_type1, pickle_message, + teams_are_normal, -- * Tests weather_tests, -- * WARNING: these are private but exported to silence warnings @@ -38,10 +41,21 @@ import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, + XmlTree, + (/>), + (>>>), + addNav, + descendantAxis, + filterAxis, + followingSiblingAxis, + hasName, + remNav, + runLA, xp8Tuple, xp9Tuple, xpAttr, @@ -55,6 +69,7 @@ import Text.XML.HXT.Core ( xpWrap ) -- Local imports. +import Generics ( Generic(..), to_tuple ) import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) @@ -67,6 +82,7 @@ import Xml ( ToDb(..), pickle_unpickle, unpickleable, + unsafe_read_document, unsafe_unpickle ) @@ -88,8 +104,13 @@ dtd = "weatherxml.dtd" data WeatherForecastListingXml = WeatherForecastListingXml { xml_teams :: String, - xml_weather :: String } - deriving (Eq, Show) + xml_weather :: Maybe String } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic WeatherForecastListingXml -- | Database representation of a weather forecast listing. The @@ -101,7 +122,7 @@ data WeatherForecastListing = db_weather_forecasts_id :: DefaultKey WeatherForecast, db_league_name :: Maybe String, db_teams :: String, - db_weather :: String } + db_weather :: Maybe String } -- | We don't make 'WeatherForecastListingXml' an instance of @@ -154,7 +175,12 @@ data WeatherForecastXml = WeatherForecastXml { xml_game_date :: UTCTime, xml_leagues :: [WeatherLeague] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic WeatherForecastXml instance ToDb WeatherForecastXml where @@ -173,7 +199,8 @@ instance Child WeatherForecastXml where instance FromXmlFk WeatherForecastXml where -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we - -- just copy everything verbatim. + -- add the foreign key to the containing 'Weather', and copy the + -- game date. -- from_xml_fk fk WeatherForecastXml{..} = WeatherForecast { @@ -208,11 +235,26 @@ data WeatherDetailedWeatherXml = -- present in each \s. -- data WeatherDetailedWeatherListingXml = - WeatherDetailedWeatherListingXml { - xml_dtl_listing_sport :: String, - xml_dtl_listing_sport_code :: String, - xml_items :: [WeatherDetailedWeatherListingItemXml] } - deriving (Eq, Show) + WeatherDetailedWeatherListingXml + String -- xml_dtl_listing_sport, unused + String -- xml_dtl_listing_sport_code, unused + [WeatherDetailedWeatherListingItemXml] -- xml_items + deriving (Eq, GHC.Generic, Show) + + +-- | Accessor for the third field of WeatherDetailedWeatherListingXml. +-- We don't use field names to avoid the unused field warnings that +-- we'd otherwise get for the first two fields. +-- +xml_items :: WeatherDetailedWeatherListingXml + -> [WeatherDetailedWeatherListingItemXml] +xml_items (WeatherDetailedWeatherListingXml _ _ items) = items + + +-- | For 'Generics.to_tuple'. +-- +instance Generic WeatherDetailedWeatherListingXml + -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml @@ -233,8 +275,8 @@ data WeatherDetailedWeatherListingItem = db_away_team :: String, db_home_team :: String, db_weather_type :: Int, - db_description :: String, - db_temp_adjust :: String, + db_description :: Maybe String, + db_temp_adjust :: Maybe String, db_temperature :: Int } @@ -249,11 +291,15 @@ data WeatherDetailedWeatherListingItemXml = xml_away_team :: String, xml_home_team :: String, xml_weather_type :: Int, - xml_description :: String, - xml_temp_adjust :: String, + xml_description :: Maybe String, + xml_temp_adjust :: Maybe String, xml_temperature :: Int } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + +-- | For 'Generics.to_tuple'. +-- +instance Generic WeatherDetailedWeatherListingItemXml instance ToDb WeatherDetailedWeatherListingItemXml where -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'. @@ -312,7 +358,13 @@ data Message = xml_forecasts :: [WeatherForecastXml], xml_detailed_weather :: Maybe WeatherDetailedWeatherXml, xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic Message + instance ToDb Message where -- | The database representation of 'Message' is 'Weather'. @@ -368,7 +420,8 @@ mkPersist tsn_codegen_config [groundhog| reference: onDelete: cascade -# We rename the two fields that needed a "dtl" prefix to avoid a name clash. + # We rename the two fields that needed a "dtl" prefix to avoid a name + # clash. - entity: WeatherDetailedWeatherListingItem dbName: weather_detailed_items constructors: @@ -384,6 +437,61 @@ mkPersist tsn_codegen_config [groundhog| |] + +-- | There are two different types of documents that claim to be +-- \"weatherxml.dtd\". The first, more common type has listings +-- within forecasts. The second type has forecasts within +-- listings. Clearly we can't parse both of these using the same +-- parser! +-- +-- For now we're simply punting on the issue and refusing to parse +-- the second type. This will check the given @xmltree@ to see if +-- there are any forecasts contained within listings. If there are, +-- then it's the second type that we don't know what to do with. +-- +is_type1 :: XmlTree -> Bool +is_type1 xmltree = + case elements of + [] -> True + _ -> False + where + parse :: XmlTree -> [XmlTree] + parse = runLA $ hasName "/" + /> hasName "message" + /> hasName "listing" + /> hasName "forecast" + + elements = parse xmltree + + +-- | Some weatherxml documents even have the Home/Away teams in the +-- wrong order. We can't parse that! This next bit of voodoo detects +-- whether or not there are any \ elements that are +-- directly followed by sibling \ elements. This is the +-- opposite of the usual order. +-- +teams_are_normal :: XmlTree -> Bool +teams_are_normal xmltree = + case elements of + [] -> True + _ -> False + where + parse :: XmlTree -> [XmlTree] + parse = runLA $ hasName "/" + /> hasName "message" + /> hasName "Detailed_Weather" + /> hasName "DW_Listing" + /> hasName "Item" + >>> addNav + >>> descendantAxis + >>> filterAxis (hasName "HomeTeam") + >>> followingSiblingAxis + >>> remNav + >>> hasName "AwayTeam" + + elements = parse xmltree + + instance DbImport Message where dbmigrate _ = run_dbmigrate $ do @@ -413,6 +521,14 @@ instance DbImport Message where -- And finally, insert those DB listings. mapM_ insert_ db_listings + -- Now we do the detailed weather items. + case (xml_detailed_weather m) of + Nothing -> return () + Just dw -> do + let detailed_listings = xml_detailed_listings dw + let items = concatMap xml_items detailed_listings + mapM_ (insert_xml_fk_ weather_id) items + return ImportSucceeded @@ -425,13 +541,13 @@ instance DbImport Message where pickle_listing :: PU WeatherForecastListingXml pickle_listing = xpElem "listing" $ - xpWrap (from_pair, to_pair) $ + xpWrap (from_pair, to_tuple) $ xpPair (xpElem "teams" xpText) - (xpElem "weather" xpText) + (xpElem "weather" (xpOption xpText)) where from_pair = uncurry WeatherForecastListingXml - to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather) + -- | Pickler to convert a 'WeatherLeague' to/from XML. @@ -476,20 +592,12 @@ pickle_item = (xpElem "AwayTeam" xpText) (xpElem "HomeTeam" xpText) (xpElem "WeatherType" xpInt) - (xpElem "Description" xpText) - (xpElem "TempAdjust" xpText) + (xpElem "Description" (xpOption xpText)) + (xpElem "TempAdjust" (xpOption xpText)) (xpElem "Temperature" xpInt) where from_tuple = uncurryN WeatherDetailedWeatherListingItemXml - to_tuple w = (xml_sport_code w, - xml_game_id w, - xml_dtl_game_date w, - xml_away_team w, - xml_home_team w, - xml_weather_type w, - xml_description w, - xml_temp_adjust w, - xml_temperature w) + -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'. @@ -503,9 +611,6 @@ pickle_dw_listing = (xpList pickle_item) where from_tuple = uncurryN WeatherDetailedWeatherListingXml - to_tuple w = (xml_dtl_listing_sport w, - xml_dtl_listing_sport_code w, - xml_items w) -- | (Un)pickle a 'WeatherDetailedWeatherXml' @@ -534,14 +639,6 @@ pickle_message = (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple Message{..} = (xml_xml_file_id, - xml_heading, - xml_category, - xml_sport, - xml_title, - xml_forecasts, - xml_detailed_weather, - xml_time_stamp) -- @@ -553,7 +650,9 @@ weather_tests = "Weather tests" [ test_on_delete_cascade, test_pickle_of_unpickle_is_identity, - test_unpickle_succeeds ] + test_unpickle_succeeds, + test_types_detected_correctly, + test_normal_teams_detected_correctly ] -- | If we unpickle something and then pickle it, we should wind up @@ -580,7 +679,9 @@ test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" "test/xml/weatherxml.xml", check "unpickling succeeds (detailed)" - "test/xml/weatherxml-detailed.xml" ] + "test/xml/weatherxml-detailed.xml", + check "unpickling succeeds (empty weather)" + "test/xml/weatherxml-empty-weather.xml"] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -596,7 +697,9 @@ test_on_delete_cascade = testGroup "cascading delete tests" [ check "deleting weather deletes its children" "test/xml/weatherxml.xml", check "deleting weather deletes its children (detailed)" - "test/xml/weatherxml-detailed.xml" ] + "test/xml/weatherxml-detailed.xml", + check "deleting weather deletes its children (empty weather)" + "test/xml/weatherxml-empty-weather.xml"] where check desc path = testCase desc $ do weather <- unsafe_unpickle path pickle_message @@ -619,3 +722,49 @@ test_on_delete_cascade = testGroup "cascading delete tests" return $ count_a + count_b + count_c + count_d let expected = 0 actual @?= expected + + +-- | We want to make sure type1 documents are detected as type1, and +-- type2 documents detected as type2.. +-- +test_types_detected_correctly :: TestTree +test_types_detected_correctly = + testGroup "weatherxml types detected correctly" + [ check "test/xml/weatherxml.xml" + "first type detected correctly" + True, + check "test/xml/weatherxml-detailed.xml" + "first type detected correctly (detailed)" + True, + check "test/xml/weatherxml-empty-weather.xml" + "first type detected correctly (empty weather)" + True, + check "test/xml/weatherxml-type2.xml" + "second type detected correctly" + False ] + where + check path desc expected = testCase desc $ do + xmltree <- unsafe_read_document path + let actual = is_type1 xmltree + actual @?= expected + + +-- | We want to make sure normal teams are detected as normal, and the +-- backwards ones are flagged as backwards. +-- +test_normal_teams_detected_correctly :: TestTree +test_normal_teams_detected_correctly = + testGroup "team order is detected correctly" [ + + check "normal teams are detected correctly" + "test/xml/weatherxml.xml" + True, + + check "backwards teams are detected correctly" + "test/xml/weatherxml-backwards-teams.xml" + False ] + where + check desc path expected = testCase desc $ do + xmltree <- unsafe_read_document path + let actual = teams_are_normal xmltree + actual @?= expected