X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=e7c0e3c7004ecd456e6d4a4caa92d8e4aba9a7d6;hb=183dae121707b8ef1a58f9e8d4828f9847011015;hp=2146c3f6f565597e166244bac8b970e7360b9590;hpb=e96fc68293b6ac51eb0e8a4fe9ac9afa515cca83;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index 2146c3f..e7c0e3c 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -13,6 +13,7 @@ module TSN.XML.Weather ( dtd, is_type1, pickle_message, + teams_are_normal, -- * Tests weather_tests, -- * WARNING: these are private but exported to silence warnings @@ -45,10 +46,14 @@ import Text.XML.HXT.Core ( PU, XmlTree, (/>), + (>>>), + addNav, + descendantAxis, + filterAxis, + followingSiblingAxis, hasName, - readDocument, + remNav, runLA, - runX, xp8Tuple, xp9Tuple, xpAttr, @@ -72,9 +77,9 @@ import Xml ( FromXml(..), FromXmlFk(..), ToDb(..), - parse_opts, pickle_unpickle, unpickleable, + unsafe_read_document, unsafe_unpickle ) @@ -96,7 +101,7 @@ dtd = "weatherxml.dtd" data WeatherForecastListingXml = WeatherForecastListingXml { xml_teams :: String, - xml_weather :: String } + xml_weather :: Maybe String } deriving (Eq, Show) @@ -109,7 +114,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 @@ -242,8 +247,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 } @@ -258,8 +263,8 @@ 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) @@ -377,7 +382,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: @@ -420,6 +426,34 @@ is_type1 xmltree = 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 @@ -449,6 +483,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 @@ -464,8 +506,9 @@ pickle_listing = xpWrap (from_pair, to_pair) $ xpPair (xpElem "teams" xpText) - (xpElem "weather" xpText) + (xpElem "weather" (xpOption xpText)) where +-- from_pair (ts, Nothing) = WeatherForecastListingXml ts (Just "") from_pair = uncurry WeatherForecastListingXml to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather) @@ -512,8 +555,8 @@ 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 @@ -590,7 +633,8 @@ weather_tests = [ test_on_delete_cascade, test_pickle_of_unpickle_is_identity, test_unpickle_succeeds, - test_types_detected_correctly ] + test_types_detected_correctly, + test_normal_teams_detected_correctly ] -- | If we unpickle something and then pickle it, we should wind up @@ -617,7 +661,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 @@ -633,7 +679,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 @@ -658,24 +706,47 @@ test_on_delete_cascade = testGroup "cascading delete tests" 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" $ + 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 - unsafe_get_xmltree :: String -> IO XmlTree - unsafe_get_xmltree path = - fmap head $ runX $ readDocument parse_opts path - check path desc expected = testCase desc $ do - xmltree <- unsafe_get_xmltree path + 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