Add a function to TSN.XML.Weather to detect the unsupported second type.

[dead/htsn-import.git] / src / TSN / XML / Weather.hs

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index c2eee4a6c739625d9ec19f114fadae12f854072b..351df2489a980984017354717e4eb77024f8c34a 100644 (file)
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -11,6 +11,7 @@
 --
 module TSN.XML.Weather (
   dtd,
+  is_type1,
   pickle_message,
   -- * Tests
   weather_tests,
@@ -42,6 +43,12 @@ import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
   PU,
+  XmlTree,
+  (/>),
+  hasName,
+  readDocument,
+  runLA,
+  runX,
   xp8Tuple,
   xp9Tuple,
   xpAttr,
@@ -65,6 +72,7 @@ import Xml (
   FromXml(..),
   FromXmlFk(..),
   ToDb(..),
+  parse_opts,
   pickle_unpickle,
   unpickleable,
   unsafe_unpickle )
@@ -384,6 +392,33 @@ 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
+
+
 instance DbImport Message where
   dbmigrate _ =
     run_dbmigrate $ do
@@ -553,7 +588,8 @@ weather_tests =
     "Weather tests"
     [ test_on_delete_cascade,
       test_pickle_of_unpickle_is_identity,
-      test_unpickle_succeeds ]
+      test_unpickle_succeeds,
+      test_types_detected_correctly ]
 
 
 -- | If we unpickle something and then pickle it, we should wind up
@@ -619,3 +655,26 @@ test_on_delete_cascade = testGroup "cascading delete tests"
                   return $ count_a + count_b + count_c + count_d
       let expected = 0
       actual @?= expected
+
+
+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-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
+      let actual = is_type1 xmltree
+      actual @?= expected