pickle_message )
import qualified TSN.XML.Scores as Scores ( dtd, pickle_message )
import qualified TSN.XML.SportInfo as SportInfo ( dtds, parse_xml )
-import qualified TSN.XML.Weather as Weather ( dtd, is_type1, pickle_message )
+import qualified TSN.XML.Weather as Weather (
+ dtd,
+ is_type1,
+ pickle_message,
+ teams_are_normal )
import Xml ( DtdName(..), parse_opts )
-- SportInfo and GameInfo appear last in the guards
| dtd == Weather.dtd =
+ -- Some of the weatherxml docs are busted in predictable ways.
+ -- We want them to "succeed" so that they're deleted.
+ -- We already know we can't parse them.
if Weather.is_type1 xml
- then go Weather.pickle_message
+ then if Weather.teams_are_normal xml
+ then go Weather.pickle_message
+ else do
+ let msg = "Teams in reverse order in weatherxml.dtd" ++
+ " (" ++ path ++ ")"
+ return $ ImportUnsupported msg
else do
- -- We want these to "succeed" so that they're deleted.
- -- We already know we can't parse them.
let msg = "Unsupported weatherxml.dtd type (" ++ path ++ ")"
return $ ImportUnsupported msg
dtd,
is_type1,
pickle_message,
+ teams_are_normal,
-- * Tests
weather_tests,
-- * WARNING: these are private but exported to silence warnings
PU,
XmlTree,
(/>),
+ (>>>),
+ addNav,
+ descendantAxis,
+ filterAxis,
+ followingSiblingAxis,
hasName,
readDocument,
+ remNav,
runLA,
runX,
xp8Tuple,
db_home_team :: String,
db_weather_type :: Int,
db_description :: String,
- db_temp_adjust :: String,
+ db_temp_adjust :: Maybe String,
db_temperature :: Int }
xml_home_team :: String,
xml_weather_type :: Int,
xml_description :: String,
- xml_temp_adjust :: String,
+ xml_temp_adjust :: Maybe String,
xml_temperature :: Int }
deriving (Eq, Show)
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 \<HomeTeam\> elements that are
+-- directly followed by sibling \<AwayTeam\> 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
(xpElem "HomeTeam" xpText)
(xpElem "WeatherType" xpInt)
(xpElem "Description" xpText)
- (xpElem "TempAdjust" xpText)
+ (xpElem "TempAdjust" (xpOption xpText))
(xpElem "Temperature" xpInt)
where
from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
[ 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
actual @?= expected
+-- | This is used in a few tests to extract an 'XmlTree' from a path.
+--
+unsafe_get_xmltree :: String -> IO XmlTree
+unsafe_get_xmltree path =
+ fmap head $ runX $ readDocument parse_opts path
+
+
+-- | 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" $
"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
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_get_xmltree path
+ let actual = teams_are_normal xmltree
+ actual @?= expected
>>>= 0
# We note the number of XML files that we have. There's one extra
-# Heartbeat.xml that doesn't really count, and a weatherxml that
-# isn't really supposed to import.
+# Heartbeat.xml that doesn't really count, and 2 weatherxml that
+# aren't really supposed to import.
find ./test/xml -maxdepth 1 -name '*.xml' | wc -l
>>>
-23
+25
>>>= 0
# Run the imports again; we should get complaints about the duplicate
-# xml_file_ids. There are 2 errors for each violation, so we expect 2*21
+# xml_file_ids. There are 2 errors for each violation, so we expect 2*22
# occurrences of the string 'ERROR'.
./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l
>>>
-42
+44
>>>= 0
# Finally, clean up after ourselves.