Merge pull request #13 from koterpillar/fix-arpansa

Fix ARPANSA parsing

src/API.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 
 module API

src/App.hs

@@ -22,12 +22,12 @@ initConfig :: IO Config
 initConfig = do
   store <- newMVar emptyStore
   apiKey <-
-    liftM APIKey $ do
+    APIKey <$> do
       key <- getEnv "PEBBLE_API_KEY"
       when (key == "") $ error "Pebble API key must be provided."
       return key
-  listenPort <- liftM (read . fromMaybe "8000") $ lookupEnv "LISTEN_PORT"
-  return $
+  listenPort <- (read . fromMaybe "8000") <$> lookupEnv "LISTEN_PORT"
+  return
     Config
     { coStore = store
     , coApiKey = apiKey

src/Fetcher.hs

@@ -34,7 +34,7 @@ fetcher =
     liftIO $ threadDelay updateInterval
 
 fetchAll :: [Fetcher] -> AppM ()
-fetchAll fs = do
+fetchAll fs =
   forM_ fs $ \f -> do
     logStr $ "Fetching from " ++ fName f ++ "..."
     newForecasts <- fFetch f

src/Fetcher/Arpansa.hs

@@ -3,9 +3,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
+{-| Fetch UV alert data from ARPANSA. -}
 module Fetcher.Arpansa where
 
-{- Fetch UV alert data from ARPANSA. -}
 import Control.Applicative
 import Control.Lens
 import Control.Monad.IO.Class
@@ -18,6 +18,7 @@ import Data.Time.Clock
 import Data.Time.Format
 import Data.Time.LocalTime
 import Data.Time.LocalTime.TimeZone.Series
+import Data.Traversable
 
 import Network.HTTP.Client
 import Network.HTTP.Simple
@@ -73,15 +74,18 @@ addresses =
 
 data ForecastPointT time = ForecastPointT
   { _fpTime :: time
-  , _fpForecast :: Maybe UVLevel
-  , _fpMeasured :: Maybe UVLevel
+  , _fpForecast :: Maybe Double
+  , _fpMeasured :: Maybe Double
   } deriving (Show, Functor)
 
 makeLenses ''ForecastPointT
 
+fpUVLevel :: ForecastPointT time -> Maybe UVLevel
+fpUVLevel pt = fmap (UVLevel . round) (pt ^. fpMeasured <|> pt ^. fpForecast)
+
 fpMeasurement :: ForecastPointT time -> (time, UVLevel)
 fpMeasurement pt =
-  (pt ^. fpTime, fromMaybe (UVLevel 0) (pt ^. fpMeasured <|> pt ^. fpForecast))
+  (pt ^. fpTime, fromMaybe (UVLevel 0) (fpUVLevel pt))
 
 parseArpansaTime :: Monad m => String -> m LocalTime
 parseArpansaTime = parseTimeM False defaultTimeLocale "%F %R"
@@ -90,11 +94,11 @@ instance FromJSON (ForecastPointT LocalTime) where
   parseJSON =
     withObject "forecast point" $ \o -> do
       date <- o .: "Date" >>= parseArpansaTime
-      forecast <- fmap UVLevel <$> o .:? "Forecast"
-      measured <- fmap UVLevel <$> o .:? "Measured"
+      forecast <- o .:? "Forecast"
+      measured <- o .:? "Measured"
       return $ ForecastPointT date forecast measured
 
-data ArpansaForecastT time = ArpansaForecastT
+newtype ArpansaForecastT time = ArpansaForecastT
   { _afPoints :: [ForecastPointT time]
   } deriving (Show, Functor)
 
@@ -107,7 +111,7 @@ instance FromJSON (ArpansaForecastT LocalTime) where
 fetchArpansa :: AppM [Forecast]
 fetchArpansa = do
   baseRequest <- parseRequest "https://uvdata.arpansa.gov.au/api/uvlevel/"
-  fmap catMaybes $ flip traverse addresses $ \loc -> do
+  fmap catMaybes $ for addresses $ \loc -> do
     logStr $ "Fetching graph for " ++ loc ^. alLocation . locCity ++ "..."
     time <- liftIO getCurrentTime
     let tz = loc ^. alLocation . to locTZ

src/Fetcher/BOM.hs

@@ -1,11 +1,10 @@
 module Fetcher.BOM where
 
-{-
+{-|
 Fetch UV forecast from Buerau of Meteorology.
 
 Unfortunately, this data is free for personal use but not for redistribution.
 -}
-import Control.Monad
 import Control.Monad.IO.Class
 
 import Data.Either
@@ -43,7 +42,7 @@ fetchBOM address = do
 fetchLines :: MonadIO m => URI -> m String
 fetchLines uri =
   liftIO $ do
-    let (Just host) = liftM uriRegName $ uriAuthority uri
+    let (Just host) = uriRegName <$> uriAuthority uri
     conn <- easyConnectFTP host
     _ <- loginAnon conn
     (content, _) <- getbinary conn $ uriPath uri
@@ -81,8 +80,8 @@ parseForecast updated str = do
   date <- parseDate $ stringPart 38 10 str
   tStart <- parseTime $ stringPart 64 5 str
   tEnd <- parseTime $ stringPart 73 5 str
-  maxLevel <- liftM UVLevel $ readEither "UV level" $ stringPartT 84 3 str
-  return $
+  maxLevel <- fmap UVLevel $ readEither "UV level" $ stringPartT 84 3 str
+  return
     Forecast
     { _fcLocation = location
     , _fcDate = date

src/Fetcher/EPA.hs

@@ -1,8 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
+{-| Fetch USA data from EPA API. -}
 module Fetcher.EPA where
 
-{- Fetch USA data from EPA API. -}
+import Control.Arrow
 import Control.Lens
 import Control.Monad
 import Control.Monad.IO.Class
@@ -27,17 +28,16 @@ epaFetcher :: Fetcher
 epaFetcher = Fetcher "EPA" fetchEpa usLocations
 
 fetchEpa :: AppM [Forecast]
-fetchEpa = do
-  liftM concat $ forM usLocations $ \location -> do
+fetchEpa =
+  fmap concat $
+  forM usLocations $ \location -> do
     logStr $ "Fetching forecast for " ++ show location ++ "..."
     let address = forecastAddress location
     logErrors address $ do
       response <- parseRequest address >>= httpJSON
       time <- liftIO getCurrentTime
       let measurements =
-            map
-              (\fi -> (fiDateTime location fi, fiLevel fi))
-              (responseBody response)
+            map (fiDateTime location &&& fiLevel) (responseBody response)
       return $ maybeToList $ buildForecast location time measurements
 
 forecastAddress :: Location -> String
@@ -58,7 +58,7 @@ data ForecastItem = ForecastItem
 instance FromJSON ForecastItem where
   parseJSON =
     withObject "forecast item" $ \v -> do
-      level <- liftM UVLevel $ v .: "UV_VALUE"
+      level <- UVLevel <$> v .: "UV_VALUE"
       time <- (v .: "DATE_TIME") >>= parseLocalTime
       return $ ForecastItem time level
     where

src/Fetcher/JMA.hs

@@ -76,8 +76,7 @@ fetchJma = do
           return $ Just (img, imgTime)
   case sequence images of
     Nothing -> return []
-    Just images' -> do
-      return $ catMaybes $ map (forecast time images') cities
+    Just images' -> return $ mapMaybe (forecast time images') cities
 
 imageRange :: [Int]
 imageRange = [0 .. 12]
@@ -89,17 +88,15 @@ imageNameTime now index = (url, time)
       urlBase ++
       zeroPad 4 year ++
       zp2 month ++ zp2 day ++ zp2 fcUpdatedHour ++ "00-" ++ zp2 index ++ ".png"
-    zeroPad n val = take (n - length str) (repeat '0') ++ str
+    zeroPad n val = replicate (n - length str) '0' ++ str
       where
         str = show val
     zp2 = zeroPad 2
     LocalTime date (TimeOfDay hour _ _) = utcToLocalTime' japanTZ now
-    (fcUpdatedDate, fcUpdatedHour) =
-      if hour < 6
-        then (addDays (-1) date, 18)
-        else if hour < 18
-               then (date, 6)
-               else (date, 18)
+    (fcUpdatedDate, fcUpdatedHour)
+      | hour < 6 = (addDays (-1) date, 18)
+      | hour < 18 = (date, 6)
+      | otherwise = (date, 18)
     (year, month, day) = toGregorian fcUpdatedDate
     fcEffectiveDate =
       if hour < 18
@@ -161,13 +158,13 @@ imageUVLevel coo img = firstJust $ map averageLevel levels
     circles :: [[ImageCoord]]
     circles = map (circleAround coo img) [0 .. maxDist]
     levels :: [[Maybe UVLevel]]
-    levels = map (map (flip imageUVLevelExact img)) circles
+    levels = map (map (`imageUVLevelExact` img)) circles
 
 -- All points at most dist pixels away from the given point, sorted by distance
 -- to that point
 circleAround :: ImageCoord -> DynamicImage -> Int -> [ImageCoord]
 circleAround coo img dist =
-  sortOn (distance coo) $ filter ((< (fromIntegral dist)) . distance coo) square
+  sortOn (distance coo) $ filter ((< fromIntegral dist) . distance coo) square
   where
     square =
       [ ImageCoord x y
@@ -201,5 +198,5 @@ forecast time imagesTimes (loc, lonlat) =
   where
     (images, times) = unzip imagesTimes
     measurements :: Maybe [Measurement]
-    measurements = zip times <$> (imageUVLevels coo images)
+    measurements = zip times <$> imageUVLevels coo images
     coo = imageCoord lonlat

src/Pebble/Types.hs

@@ -84,8 +84,8 @@ instance ToJSON Layout where
       , maybePair "paragraphs" paragraphTexts
       ]
     where
-      paragraphHeadings = liftM (map paragraphHeading) maybeParagraphs
-      paragraphTexts = liftM (map paragraphText) maybeParagraphs
+      paragraphHeadings = map paragraphHeading <$> maybeParagraphs
+      paragraphTexts = map paragraphText <$> maybeParagraphs
       maybeParagraphs =
         case layoutParagraphs of
           [] -> Nothing
@@ -108,7 +108,7 @@ pinTypeJSON WeatherPin {..} =
 pinTypeJSON GenericReminder = ["type" .= ("genericReminder" :: String)]
 pinTypeJSON GenericNotification = ["type" .= ("genericNotification" :: String)]
 
-data Color =
+newtype Color =
   Color Int -- Hex
 
 instance ToJSON Color where
@@ -145,19 +145,19 @@ data ActionType
   = OpenWatchAppAction
   | HttpAction
 
-data UserToken =
+newtype UserToken =
   UserToken String
 
 instance ToHttpApiData UserToken where
   toUrlPiece (UserToken token) = T.pack token
 
-data APIKey =
+newtype APIKey =
   APIKey String
 
 instance ToHttpApiData APIKey where
   toUrlPiece (APIKey key) = T.pack key
 
-data Topics =
+newtype Topics =
   Topics [T.Text]
 
 instance ToHttpApiData Topics where

src/Pusher.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 
 module Pusher where
 
@@ -79,11 +78,11 @@ forecastPin fc = do
         { layoutTitle = "UV Alert end"
         , layoutTinyIcon = Just "system://images/TIMELINE_SUN"
         }
-  let pinId =
+  let pinId_ =
         normalizeValue $ (fc ^. fcLocation . locId) `T.append`
         (fc ^. fcDate . to show . packed)
   [ Pin
-    { pinId = pinId `T.append` "start"
+    { pinId = pinId_ `T.append` "start"
     , pinTime = fcAlertStartTime fc alert
     , pinDuration = Nothing
     , pinCreateNotification = Nothing
@@ -93,7 +92,7 @@ forecastPin fc = do
     , pinActions = []
     }
     , Pin
-      { pinId = pinId `T.append` "end"
+      { pinId = pinId_ `T.append` "end"
       , pinTime = fcAlertEndTime fc alert
       , pinDuration = Nothing
       , pinCreateNotification = Nothing
@@ -108,7 +107,7 @@ forecastPin fc = do
 -- sufficient. Have to maintain for backwards compatibility
 forecastTopics :: Forecast -> Topics
 forecastTopics forecast =
-  Topics $ [locTopic] ++ [legacyTopic | country == "Australia"]
+  Topics $ locTopic : [legacyTopic | country == "Australia"]
   where
     legacyTopic = normalizeValue city
     locTopic = "v2-" `T.append` (forecast ^. fcLocation . locId)

src/Server.hs

@@ -44,7 +44,7 @@ allLocations = asks $ concatMap fLocations . coFetchers
 getForecast :: Location -> AppSM [Forecast]
 getForecast loc = do
   locations <- allLocations
-  when (not $ elem loc locations) $
+  when (loc `notElem` locations) $
     lift $ throwError $ err404 {errBody = "Location not found"}
   forecasts <- stateM $ use stForecasts
   return $

src/Types.hs

@@ -10,7 +10,7 @@ import Control.Lens hiding ((.=))
 import Control.Arrow
 
 import Data.Aeson
-import Data.Function
+import Data.Ord
 import Data.Maybe
 import Data.Time.Calendar
 import Data.Time.Clock
@@ -25,7 +25,7 @@ import Types.Location
 import Utils
 
 -- Supplementary types
-data UVLevel = UVLevel
+newtype UVLevel = UVLevel
   { _uvValue :: Int
   } deriving (Eq, Ord, Show, Generic)
 
@@ -65,7 +65,7 @@ data Forecast = Forecast
 makeLenses ''Forecast
 
 compareUpdated :: Forecast -> Forecast -> Ordering
-compareUpdated = compare `on` (view fcUpdated)
+compareUpdated = comparing $ view fcUpdated
 
 fcTZ :: Forecast -> TimeZoneSeries
 fcTZ fc = fc ^. fcLocation . to locTZ
@@ -108,7 +108,7 @@ buildForecast location updated measurements = do
   let tz = locTZ location
   let localDayTime = localTimeOfDay . utcToLocalTime' tz
   let alertTimes = alertIntervals measurements
-  firstAlert <- fmap fst $ listToMaybe alertTimes
+  firstAlert <- fst <$> listToMaybe alertTimes
   maxlevel <- maybeMaximum $ map snd measurements
   return
     Forecast
@@ -140,7 +140,7 @@ alertIntervals =
     uvToFloat :: UVLevel -> Double
     uvToFloat v = v ^. uvValue . to toInteger . to fromInteger
 
-data AppKey = AppKey
+newtype AppKey = AppKey
   { akKey :: String
   }