Merge branch 'localize-errors'

src/Fetcher/Arpansa.hs

@@ -59,27 +59,22 @@ addresses = map makeLocation [ (sa, "Adelaide", "adl")
 fetchArpansa :: AppM [Forecast]
 fetchArpansa = do
     manager <- liftIO $ newManager defaultManagerSettings
-    liftM concat $ forM addresses $ \(loc, address) -> do
+    fmap catMaybes $ forM addresses $ \(loc, address) -> do
         logStr $ "Fetching graph for " ++ loc ^. locCity ++ "..."
         logErrors address $ do
             graphBytes <- fetchHTTP manager address
-            case decodeImage graphBytes of
-                Left err -> do
-                    logStr err
-                    return []
-                Right graphImage -> do
-                    time <- liftIO getCurrentTime
-                    let forecast = parseGraph loc graphImage time
-                    return $ maybeToList forecast
-
-parseGraph :: Location -> DynamicImage -> UTCTime -> Maybe Forecast
+            logEither (decodeImage graphBytes) $ \graphImage -> do
+                time <- liftIO getCurrentTime
+                logEither (parseGraph loc graphImage time) $ return
+
+parseGraph :: Location -> DynamicImage -> UTCTime -> Either String (Maybe Forecast)
 parseGraph loc image updated = do
     let uvLine = selectBestLine image
     let graph = map graphCoordinates uvLine
-    date <- eitherToMaybe $ parseDate image
+    date <- parseDate image
     let timeToUtc = localTimeToUTC' (locTZ loc) . LocalTime date
     let alertTimes = map (first timeToUtc) graph
-    buildForecast loc updated alertTimes
+    return $ buildForecast loc updated alertTimes
 
 forecastLineColor :: PixelRGB8
 forecastLineColor = PixelRGB8 248 135 0

src/Fetcher/Arpansa/CharacterRecognizer.hs

@@ -85,11 +85,16 @@ splitWhenChanges fn (a:as) = (a:start):splitWhenChanges fn rest
 -- Parse the date on the graph
 parseDate :: DynamicImage -> Either String Day
 parseDate img = do
-    let dateString = stringAt dateStringCoord img
-    [_, dayString, monthString, yearString] <- case splitWhenChanges isDigit dateString of
-                                                    res@[_, _, _, _] -> return res
-                                                    _ -> error $ "Invalid date parsed: " ++ dateString
-    day <- readEither "day" dayString
-    month <- maybeToEither "month" $ M.lookup (drop 2 monthString) months
-    year <- readEither "year" yearString
-    maybeToEither "invalid date" $ fromGregorianValid year month day
+  let dateString = stringAt dateStringCoord img
+  [_, dayString, monthString, yearString] <-
+    case splitWhenChanges isDigit dateString of
+      res@[_, _, _, _] -> return res
+      _ -> Left $ "Invalid date parsed: " ++ dateString
+  day <- readEither ("Invalid day: " ++ dayString) dayString
+  month <-
+    maybeToEither ("Invalid month: " ++ monthString) $
+    M.lookup (drop 2 monthString) months
+  year <- readEither ("Invalid year: " ++ yearString) yearString
+  maybeToEither
+    ("Invalid date: " ++ show year ++ "-" ++ show month ++ "-" ++ show day) $
+    fromGregorianValid year month day

src/Fetcher/BOM.hs

@@ -60,10 +60,7 @@ parseDate str = do
     day <- readEither "day" $ stringPartT 0 2 str
     month <- readEither "month" $ stringPartT 3 2 str
     year <- readEither "year" $ stringPartT 6 4 str
-    let maybeDate = fromGregorianValid year month day
-    case maybeDate of
-        Just date -> return date
-        Nothing -> error "Invalid date"
+    maybeToEither ("Invalid date: " ++ str) $ fromGregorianValid year month day
 
 parseTime :: String -> Either String TimeOfDay
 parseTime str = do

src/Fetcher/Base.hs

@@ -2,25 +2,28 @@ module Fetcher.Base where
 
 {- Base functions for all the UV level sources -}
 
-import Control.Monad
+import Control.Applicative
 import Control.Exception.Lifted
 
 import Network.HTTP.Client (HttpException)
 
 import Types.Config
-import Types
 
 
-logErrorStr :: (MonadPlus m, Show c) => c -> String -> AppM (m a)
+logErrorStr :: (Alternative m, Show c) => c -> String -> AppM (m a)
 logErrorStr context err = do
     logStr $ "Error fetching " ++ show context ++ ": " ++ err
-    return mzero
+    return empty
 
-logIOError :: (MonadPlus m, Show c) => c -> IOError -> AppM (m a)
+logIOError :: (Alternative m, Show c) => c -> IOError -> AppM (m a)
 logIOError context err = logErrorStr context (show err)
 
-logHttpError :: (MonadPlus m, Show c) => c -> HttpException -> AppM (m a)
+logHttpError :: (Alternative m, Show c) => c -> HttpException -> AppM (m a)
 logHttpError context err = logErrorStr context (show err)
 
-logErrors :: (MonadPlus m, Show c) => c -> AppM (m a) -> AppM (m a)
+logErrors :: (Alternative m, Show c) => c -> AppM (m a) -> AppM (m a)
 logErrors context = handle (logIOError context) . handle (logHttpError context)
+
+logEither :: Alternative m => Either String a -> (a -> AppM (m b)) -> AppM (m b)
+logEither (Left err) _ = logStr err >> return empty
+logEither (Right value) act = act value

src/Fetcher/JMA.hs

@@ -73,11 +73,7 @@ fetchJma = do
         \(address, imgTime) -> logErrors address $ do
              logStr $ "Fetching JMA forecast for " ++ show (utcToLocalTime' japanTZ imgTime) ++ "..."
              imgBytes <- fetchHTTP manager address
-             case decodeImage imgBytes of
-               Left err -> do
-                   logStr err
-                   return Nothing
-               Right img -> return $ Just (img, imgTime)
+             logEither (decodeImage imgBytes) $ \img -> return $ Just (img, imgTime)
     case sequence images of
       Nothing -> return []
       Just images' -> do

src/Utils.hs

@@ -10,9 +10,6 @@ readEither err str = case reads str of
     [(res, "")] -> Right res
     _ -> Left err
 
-eitherToMaybe :: Either e a -> Maybe a
-eitherToMaybe = either (const Nothing) Just
-
 maybeToEither :: e -> Maybe a -> Either e a
 maybeToEither e Nothing = Left e
 maybeToEither _ (Just a) = Right a

test/Fetcher/ArpansaSpec.hs

@@ -119,7 +119,7 @@ spec = do
 
         context "for a morning image" $ do
             img <- loadImage morningImage
-            let (Just fc) = parseGraph melbourne img testTime
+            let (Right (Just fc)) = parseGraph melbourne img testTime
             it "stores the city" $
                 fc ^. fcLocation . locCity `shouldBe` "Melbourne"
             it "stores the day" $ do
@@ -139,7 +139,7 @@ spec = do
             -- The real UV index was low in the morning, so the alert should be
             -- adjusted
             img <- loadImage eveningImage
-            let (Just fc) = parseGraph melbourne img testTime
+            let (Right (Just fc)) = parseGraph melbourne img testTime
             it "stores the city" $
                 fc ^. fcLocation . locCity `shouldBe` "Melbourne"
             it "stores the day" $ do
@@ -159,14 +159,14 @@ spec = do
             img <- loadImage quietImage
             let Just day = fromGregorianValid 2016 1 20
             it "does not have an alert forecast" $ do
-                parseGraph melbourne img testTime `shouldBe` Nothing
+                parseGraph melbourne img testTime `shouldBe` Right Nothing
 
         context "for an image with several high intervals" $ do
             -- This image has been altered to have a few intervals of high UV
             -- index
             img <- loadImage distinctPeriodsImage
             let Just day = fromGregorianValid 2016 1 20
-            let (Just fc) = parseGraph melbourne img testTime
+            let (Right (Just fc)) = parseGraph melbourne img testTime
             it "has a range of alerts" $ do
                 length (fc ^. fcAlerts) `shouldBe` 3
                 let [alert1, alert2, alert3] = fc ^. fcAlerts