X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=e7c0e3c7004ecd456e6d4a4caa92d8e4aba9a7d6;hb=183dae121707b8ef1a58f9e8d4828f9847011015;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..e7c0e3c 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -11,7 +11,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
@@ -42,6 +44,16 @@ 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,
@@ -67,6 +79,7 @@ import Xml (
   ToDb(..),
   pickle_unpickle,
   unpickleable,
+  unsafe_read_document,
   unsafe_unpickle )
 
 
@@ -88,7 +101,7 @@ dtd = "weatherxml.dtd"
 data WeatherForecastListingXml =
   WeatherForecastListingXml {
     xml_teams :: String,
-    xml_weather :: String }
+    xml_weather :: Maybe String }
   deriving (Eq, Show)
 
 
@@ -101,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
@@ -173,7 +186,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 {
@@ -233,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 }
 
 
@@ -249,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)
 
@@ -368,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:
@@ -384,6 +399,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 \<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
@@ -413,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
 
 
@@ -428,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)
 
@@ -476,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
@@ -553,7 +632,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 +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
@@ -596,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
@@ -619,3 +704,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