xmobar-0.49: src/Xmobar/Plugins/Monitors/Weather.hs
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Plugins.Monitors.Weather
-- Copyright : (c) Andrea Rossato
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
-- Stability : unstable
-- Portability : unportable
--
-- A weather monitor for Xmobar
--
-----------------------------------------------------------------------------
module Xmobar.Plugins.Monitors.Weather where
import Xmobar.Plugins.Monitors.Common
import qualified Control.Exception as CE
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char (toLower)
import Network.HTTP.Conduit
import Network.HTTP.Types.Status
import Network.HTTP.Types.Method
import Network.HTTP.Client.TLS (getGlobalManager)
import Text.ParserCombinators.Parsec
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(Option))
-- | Options the user may specify.
newtype WeatherOpts = WeatherOpts
{ weatherString :: String
}
-- | Default values for options.
defaultOpts :: WeatherOpts
defaultOpts = WeatherOpts
{ weatherString = ""
}
-- | Apply options.
options :: [OptDescr (WeatherOpts -> WeatherOpts)]
options =
[ Option "w" ["weathers" ] (ReqArg (\s o -> o { weatherString = s }) "") ""
]
weatherConfig :: IO MConfig
weatherConfig = mkMConfig
"<station>: <tempC>C, rh <rh>% (<hour>)" -- template
["station" -- available replacements
, "stationState"
, "year"
, "month"
, "day"
, "hour"
, "windCardinal"
, "windAzimuth"
, "windMph"
, "windKnots"
, "windKmh"
, "windMs"
, "visibility"
, "skyCondition"
, "skyConditionS"
, "weather"
, "weatherS"
, "tempC"
, "tempF"
, "dewPointC"
, "dewPointF"
, "rh"
, "pressure"
]
data WindInfo =
WindInfo {
windCardinal :: String -- cardinal direction
, windAzimuth :: String -- azimuth direction
, windMph :: String -- speed (MPH)
, windKnots :: String -- speed (knot)
, windKmh :: String -- speed (km/h)
, windMs :: String -- speed (m/s)
} deriving (Show)
data WeatherInfo =
WI { stationPlace :: String
, stationState :: String
, year :: String
, month :: String
, day :: String
, hour :: String
, windInfo :: WindInfo
, visibility :: String
, skyCondition :: String
, weather :: String
, tempC :: Int
, tempF :: Int
, dewPointC :: Int
, dewPointF :: Int
, humidity :: Int
, pressure :: Int
} deriving (Show)
pTime :: Parser (String, String, String, String)
pTime = do y <- getNumbersAsString
char '.'
m <- getNumbersAsString
char '.'
d <- getNumbersAsString
char ' '
(h:hh:mi:mimi) <- getNumbersAsString
char ' '
return (y, m, d ,h:hh:":"++mi:mimi)
noWind :: WindInfo
noWind = WindInfo "μ" "μ" "0" "0" "0" "0"
pWind :: Parser WindInfo
pWind =
let tospace = manyTill anyChar (char ' ')
toKmh knots = knots $* 1.852
toMs knots = knots $* 0.514
($*) :: String -> Double -> String
op1 $* op2 = show (round ((read op1::Double) * op2)::Integer)
-- Occasionally there is no wind and a METAR report gives simply, "Wind: Calm:0"
wind0 = do manyTill skipRestOfLine (string "Wind: Calm:0")
return noWind
windVar = do manyTill skipRestOfLine (string "Wind: Variable at ")
mph <- tospace
string "MPH ("
knot <- tospace
manyTill anyChar newline
return $ WindInfo "μ" "μ" mph knot (toKmh knot) (toMs knot)
wind = do manyTill skipRestOfLine (string "Wind: from the ")
cardinal <- tospace
char '('
azimuth <- tospace
string "degrees) at "
mph <- tospace
string "MPH ("
knot <- tospace
manyTill anyChar newline
return $ WindInfo cardinal azimuth mph knot (toKmh knot) (toMs knot)
in try wind0 <|> try windVar <|> try wind <|> return noWind
pTemp :: Parser (Int, Int)
pTemp = do let num = digit <|> char '-' <|> char '.'
f <- manyTill num $ char ' '
manyTill anyChar $ char '('
c <- manyTill num $ char ' '
skipRestOfLine
return (floor (read c :: Double), floor (read f :: Double))
pRh :: Parser Int
pRh = do s <- manyTill digit (char '%' <|> char '.')
return $ read s
pPressure :: Parser Int
pPressure = do manyTill anyChar $ char '('
s <- manyTill digit $ char ' '
skipRestOfLine
return $ read s
{-
example of 'http://weather.noaa.gov/pub/data/observations/metar/decoded/VTUD.TXT':
Station name not available
Aug 11, 2013 - 10:00 AM EDT / 2013.08.11 1400 UTC
Wind: from the N (350 degrees) at 1 MPH (1 KT):0
Visibility: 4 mile(s):0
Sky conditions: mostly clear
Temperature: 77 F (25 C)
Dew Point: 73 F (23 C)
Relative Humidity: 88%
Pressure (altimeter): 29.77 in. Hg (1008 hPa)
ob: VTUD 111400Z 35001KT 8000 FEW030 25/23 Q1008 A2977 INFO R RWY30
cycle: 14
-}
parseData :: Parser [WeatherInfo]
parseData =
do (st, ss) <- try (string "Station name not available" >> return ("??", "??")) <|>
(do st <- getAllBut ","
space
ss <- getAllBut "("
return (st, ss)
)
skipRestOfLine >> getAllBut "/"
(y,m,d,h) <- pTime
w <- pWind
v <- getAfterString "Visibility: "
sk <- getAfterString "Sky conditions: "
we <- getAfterString "Weather: "
skipTillString "Temperature: "
(tC,tF) <- pTemp
skipTillString "Dew Point: "
(dC, dF) <- pTemp
skipTillString "Relative Humidity: "
rh <- pRh
skipTillString "Pressure (altimeter): "
p <- pPressure
manyTill skipRestOfLine eof
return [WI st ss y m d h w v sk we tC tF dC dF rh p]
defUrl :: String
defUrl = "https://tgftp.nws.noaa.gov/data/observations/metar/decoded/"
stationUrl :: String -> String
stationUrl station = defUrl ++ station ++ ".TXT"
-- | Get the decoded weather data from the given station.
getData :: String -> IO String
getData station = CE.catch
(do request <- parseUrlThrow $ stationUrl station
man <- getGlobalManager
res <- httpLbs request man
return $ B.unpack $ responseBody res)
errHandler
where
errHandler :: CE.SomeException -> IO String
errHandler _ = return "<Could not retrieve data>"
formatWeather
:: WeatherOpts -- ^ Formatting options from the cfg file
-> [(String,String)] -- ^ 'SkyConditionS' for 'WeatherX'
-> [WeatherInfo] -- ^ The actual weather info
-> Monitor String
formatWeather opts sks [WI st ss y m d h wind v sk we tC tF dC dF r p] =
do let WindInfo wc wa wm wk wkh wms = wind
cel <- showWithColors show tC
far <- showWithColors show tF
let we' = showWeather (weatherString opts) we
sk' = findSk sks (map toLower sk) we'
we'' = findSk sks (map toLower we') sk'
parseTemplate [st, ss, y, m, d, h, wc, wa, wm, wk, wkh
, wms, v, sk, sk', we', we'', cel, far
, show dC, show dF, show r , show p ]
where findSk ((a,b):xs) x df = if a == x then b else findSk xs x df
findSk [] _ df = df
formatWeather _ _ _ = getConfigValue naString
-- | Show the 'weather' field with a default string in case it was empty.
showWeather :: String -> String -> String
showWeather "" d = d
showWeather s _ = s
-- | Start a weather monitor, create a new 'Maybe Manager', should the user have
-- chosen to use one.
startWeather'
:: [(String, String)] -- ^ 'SkyConditionS' replacement strings
-> String -- ^ Weather station
-> [String] -- ^ User supplied arguments
-> Int -- ^ Update rate
-> (String -> IO ())
-> IO ()
startWeather' sks station args rate cb = do
opts <- parseOptsWith options defaultOpts (getArgvs args)
runMD
(station : args)
weatherConfig
(runWeather sks opts)
rate
weatherReady
cb
-- | Same as 'startWeather'', only for 'Weather' instead of 'WeatherX', meaning
-- no 'SkyConditionS'.
startWeather :: String -> [String] -> Int -> (String -> IO ()) -> IO ()
startWeather = startWeather' []
-- | Run a weather monitor.
runWeather
:: [(String, String)] -- ^ 'SkyConditionS' replacement strings
-> WeatherOpts -- ^ Weather specific options
-> [String] -- ^ User supplied arguments
-> Monitor String
runWeather sks opts args = do
d <- io $ getData (head args)
i <- io $ runP parseData d
formatWeather opts sks i
weatherReady :: [String] -> Monitor Bool
weatherReady str = io $ do
initRequest <- parseUrlThrow $ stationUrl $ head str
let request = initRequest { method = methodHead }
CE.catch
(do man <- getGlobalManager
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