From 1f1f0bd8b811740c84215f9ed4fa5ebd8309a990 Mon Sep 17 00:00:00 2001 From: slotThe Date: Thu, 9 Jan 2020 15:54:47 +0100 Subject: Use a single Manager across the whole application --- src/Xmobar/Plugins/Monitors/Common/Types.hs | 9 +++-- src/Xmobar/Plugins/Monitors/UVMeter.hs | 30 +++++++------- src/Xmobar/Plugins/Monitors/Weather.hs | 62 ++++++++++++++++++----------- 3 files changed, 61 insertions(+), 40 deletions(-) (limited to 'src/Xmobar/Plugins') diff --git a/src/Xmobar/Plugins/Monitors/Common/Types.hs b/src/Xmobar/Plugins/Monitors/Common/Types.hs index c36a562..8662ba3 100644 --- a/src/Xmobar/Plugins/Monitors/Common/Types.hs +++ b/src/Xmobar/Plugins/Monitors/Common/Types.hs @@ -25,8 +25,9 @@ module Xmobar.Plugins.Monitors.Common.Types ( Monitor , io ) where -import Data.IORef -import Control.Monad.Reader +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import Control.Monad.Reader (ReaderT, ask, liftIO) +import Network.HTTP.Conduit (Manager, newManager, tlsManagerSettings) type Monitor a = ReaderT MConfig IO a @@ -55,6 +56,7 @@ data MConfig = , naString :: IORef String , maxTotalWidth :: IORef Int , maxTotalWidthEllipsis :: IORef String + , manager :: IORef Manager } -- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' @@ -102,7 +104,8 @@ mkMConfig tmpl exprts = na <- newIORef "N/A" mt <- newIORef 0 mtel <- newIORef "" - return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel + man <- newIORef =<< newManager tlsManagerSettings + return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel man data Opts = HighColor String | NormalColor String diff --git a/src/Xmobar/Plugins/Monitors/UVMeter.hs b/src/Xmobar/Plugins/Monitors/UVMeter.hs index 079177f..3756856 100644 --- a/src/Xmobar/Plugins/Monitors/UVMeter.hs +++ b/src/Xmobar/Plugins/Monitors/UVMeter.hs @@ -18,14 +18,14 @@ module Xmobar.Plugins.Monitors.UVMeter where import Xmobar.Plugins.Monitors.Common import qualified Control.Exception as CE -import Network.HTTP.Conduit - (parseRequest, newManager, tlsManagerSettings, httpLbs, - responseBody) +import Network.HTTP.Conduit (httpLbs, parseRequest, responseBody) import Data.ByteString.Lazy.Char8 as B import Text.Read (readMaybe) import Text.Parsec import Text.Parsec.String import Control.Monad (void) +import Control.Monad.Reader (asks) +import Data.IORef (readIORef) uvConfig :: IO MConfig @@ -40,16 +40,18 @@ newtype UvInfo = UV { index :: String } uvURL :: String uvURL = "https://uvdata.arpansa.gov.au/xml/uvvalues.xml" -getData :: IO String -getData = - CE.catch (do request <- parseRequest uvURL - manager <- newManager tlsManagerSettings - res <- httpLbs request manager - return $ B.unpack $ responseBody res) - errHandler - where errHandler - :: CE.SomeException -> IO String - errHandler _ = return "" +-- | Get the UV data from the given url. +getData :: Monitor String +getData = do + man <- io =<< readIORef <$> asks manager + io $ CE.catch + (do request <- parseRequest uvURL + res <- httpLbs request man + return $ B.unpack $ responseBody res) + errHandler + where + errHandler :: CE.SomeException -> IO String + errHandler _ = return "" textToXMLDocument :: String -> Either ParseError [XML] textToXMLDocument = parse document "" @@ -73,7 +75,7 @@ getUVRating _ [] = Nothing runUVMeter :: [String] -> Monitor String runUVMeter [] = return "N.A." runUVMeter (s:_) = do - resp <- io getData + resp <- getData case textToXMLDocument resp of Right doc -> formatUVRating (getUVRating s doc) Left _ -> getConfigValue naString diff --git a/src/Xmobar/Plugins/Monitors/Weather.hs b/src/Xmobar/Plugins/Monitors/Weather.hs index 07d8cc4..250c258 100644 --- a/src/Xmobar/Plugins/Monitors/Weather.hs +++ b/src/Xmobar/Plugins/Monitors/Weather.hs @@ -19,11 +19,13 @@ import Xmobar.Plugins.Monitors.Common import qualified Control.Exception as CE -import Network.HTTP.Conduit -import Network.HTTP.Types.Status -import Network.HTTP.Types.Method +import Control.Monad.Reader (asks) import qualified Data.ByteString.Lazy.Char8 as B import Data.Char (toLower) +import Data.IORef (readIORef) +import Network.HTTP.Conduit +import Network.HTTP.Types.Method (methodHead) +import Network.HTTP.Types.Status import Text.ParserCombinators.Parsec import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(Option)) @@ -208,15 +210,18 @@ defUrl = "https://tgftp.nws.noaa.gov/data/observations/metar/decoded/" stationUrl :: String -> String stationUrl station = defUrl ++ station ++ ".TXT" -getData :: String -> IO String -getData station = CE.catch (do - manager <- newManager tlsManagerSettings - request <- parseUrlThrow $ stationUrl station - res <- httpLbs request manager - return $ B.unpack $ responseBody res - ) errHandler - where errHandler :: CE.SomeException -> IO String - errHandler _ = return "" +-- | Get the decoded weather data from the given station. +getData :: String -> Monitor String +getData station = do + man <- io =<< readIORef <$> asks manager + io $ CE.catch ( do + request <- parseUrlThrow $ stationUrl station + res <- httpLbs request man + return $ B.unpack $ responseBody res + ) errHandler + where + errHandler :: CE.SomeException -> IO String + errHandler _ = return "" formatSk :: Eq p => [(p, p)] -> p -> p formatSk ((a,b):sks) sk = if a == sk then b else formatSk sks sk @@ -242,27 +247,38 @@ showWeather :: String -> String -> String showWeather "" d = d showWeather s _ = s +-- | Run the 'Weather' monitor. runWeather :: [String] -> Monitor String runWeather = runWeather' [] -runWeather' :: [(String, String)] -> [String] -> Monitor String +-- | Run the 'WeatherX' monitor. +runWeather' + :: [(String, String)] -- ^ 'SkyConditionS' replacement strings + -> [String] -- ^ User supplied arguments + -> Monitor String runWeather' sks args = - do d <- io $ getData $ head args + do d <- getData $ head args o <- io $ parseOptsWith options defaultOpts args i <- io $ runP parseData d formatWeather o sks i +-- | Test internet connectivity before executing the monitor. weatherReady :: [String] -> Monitor Bool weatherReady str = do initRequest <- parseUrlThrow $ stationUrl $ head str let request = initRequest{method = methodHead} + man <- io =<< readIORef <$> asks manager io $ CE.catch ( do - manager <- newManager tlsManagerSettings - res <- httpLbs request manager - return $ checkResult $responseStatus res ) errHandler - where errHandler :: CE.SomeException -> IO Bool - errHandler _ = return False - checkResult status - | statusIsServerError status = False - | statusIsClientError status = False - | otherwise = True + res <- httpLbs request man + return $ checkResult $ responseStatus res ) errHandler + where + -- | If any exception occurs, indicate that the monitor is not ready. + errHandler :: CE.SomeException -> IO Bool + errHandler _ = return False + + -- | Check for and indicate any errors in the http response. + checkResult :: Status -> Bool + checkResult status + | statusIsServerError status = False + | statusIsClientError status = False + | otherwise = True -- cgit v1.2.3