{-# LANGUAGE CPP #-}
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))
newtype WeatherOpts = WeatherOpts
{ WeatherOpts -> String
weatherString :: String
}
defaultOpts :: WeatherOpts
defaultOpts :: WeatherOpts
defaultOpts = WeatherOpts
{ weatherString :: String
weatherString = String
""
}
options :: [OptDescr (WeatherOpts -> WeatherOpts)]
options :: [OptDescr (WeatherOpts -> WeatherOpts)]
options =
[ String
-> [String]
-> ArgDescr (WeatherOpts -> WeatherOpts)
-> String
-> OptDescr (WeatherOpts -> WeatherOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"w" [String
"weathers" ] ((String -> WeatherOpts -> WeatherOpts)
-> String -> ArgDescr (WeatherOpts -> WeatherOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s WeatherOpts
o -> WeatherOpts
o { weatherString = s }) String
"") String
""
]
weatherConfig :: IO MConfig
weatherConfig :: IO MConfig
weatherConfig = String -> [String] -> IO MConfig
mkMConfig
String
"<station>: <tempC>C, rh <rh>% (<hour>)"
[String
"station"
, String
"stationState"
, String
"year"
, String
"month"
, String
"day"
, String
"hour"
, String
"windCardinal"
, String
"windAzimuth"
, String
"windMph"
, String
"windKnots"
, String
"windKmh"
, String
"windMs"
, String
"visibility"
, String
"skyCondition"
, String
"skyConditionS"
, String
"weather"
, String
"weatherS"
, String
"tempC"
, String
"tempF"
, String
"dewPointC"
, String
"dewPointF"
, String
"rh"
, String
"pressure"
]
data WindInfo =
WindInfo {
WindInfo -> String
windCardinal :: String
, WindInfo -> String
windAzimuth :: String
, WindInfo -> String
windMph :: String
, WindInfo -> String
windKnots :: String
, WindInfo -> String
windKmh :: String
, WindInfo -> String
windMs :: String
} deriving (Int -> WindInfo -> ShowS
[WindInfo] -> ShowS
WindInfo -> String
(Int -> WindInfo -> ShowS)
-> (WindInfo -> String) -> ([WindInfo] -> ShowS) -> Show WindInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WindInfo -> ShowS
showsPrec :: Int -> WindInfo -> ShowS
$cshow :: WindInfo -> String
show :: WindInfo -> String
$cshowList :: [WindInfo] -> ShowS
showList :: [WindInfo] -> ShowS
Show)
data WeatherInfo =
WI { WeatherInfo -> String
stationPlace :: String
, WeatherInfo -> String
stationState :: String
, WeatherInfo -> String
year :: String
, WeatherInfo -> String
month :: String
, WeatherInfo -> String
day :: String
, WeatherInfo -> String
hour :: String
, WeatherInfo -> WindInfo
windInfo :: WindInfo
, WeatherInfo -> String
visibility :: String
, WeatherInfo -> String
skyCondition :: String
, WeatherInfo -> String
weather :: String
, WeatherInfo -> Int
tempC :: Int
, WeatherInfo -> Int
tempF :: Int
, WeatherInfo -> Int
dewPointC :: Int
, WeatherInfo -> Int
dewPointF :: Int
, WeatherInfo -> Int
humidity :: Int
, WeatherInfo -> Int
pressure :: Int
} deriving (Int -> WeatherInfo -> ShowS
[WeatherInfo] -> ShowS
WeatherInfo -> String
(Int -> WeatherInfo -> ShowS)
-> (WeatherInfo -> String)
-> ([WeatherInfo] -> ShowS)
-> Show WeatherInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WeatherInfo -> ShowS
showsPrec :: Int -> WeatherInfo -> ShowS
$cshow :: WeatherInfo -> String
show :: WeatherInfo -> String
$cshowList :: [WeatherInfo] -> ShowS
showList :: [WeatherInfo] -> ShowS
Show)
pTime :: Parser (String, String, String, String)
pTime :: Parser (String, String, String, String)
pTime = do y <- Parser String
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
noWind = String
-> String -> String -> String -> String -> String -> WindInfo
WindInfo String
"μ" String
"μ" String
"0" String
"0" String
"0" String
"0"
pWind :: Parser WindInfo
pWind :: Parser WindInfo
pWind =
let tospace :: ParsecT String u Identity String
tospace = ParsecT String u Identity Char
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ')
toKmh :: ShowS
toKmh String
knots = String
knots String -> Double -> String
$* Double
1.852
toMs :: ShowS
toMs String
knots = String
knots String -> Double -> String
$* Double
0.514
($*) :: String -> Double -> String
String
op1 $* :: String -> Double -> String
$* Double
op2 = Integer -> String
forall a. Show a => a -> String
show (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round ((String -> Double
forall a. Read a => String -> a
read String
op1::Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
op2)::Integer)
wind0 :: Parser WindInfo
wind0 = do ParsecT String () Identity Char -> Parser String -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
skipRestOfLine (String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Wind: Calm:0")
WindInfo -> Parser WindInfo
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return WindInfo
noWind
windVar :: Parser WindInfo
windVar = do ParsecT String () Identity Char -> Parser String -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
skipRestOfLine (String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Wind: Variable at ")
mph <- Parser String
forall {u}. ParsecT String u Identity String
tospace
string "MPH ("
knot <- tospace
manyTill anyChar newline
return $ WindInfo "μ" "μ" mph knot (toKmh knot) (toMs knot)
wind :: Parser WindInfo
wind = do ParsecT String () Identity Char -> Parser String -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
skipRestOfLine (String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Wind: from the ")
cardinal <- Parser String
forall {u}. ParsecT String u Identity String
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 Parser WindInfo -> Parser WindInfo
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser WindInfo
wind0 Parser WindInfo -> Parser WindInfo -> Parser WindInfo
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser WindInfo -> Parser WindInfo
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser WindInfo
windVar Parser WindInfo -> Parser WindInfo -> Parser WindInfo
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser WindInfo -> Parser WindInfo
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser WindInfo
wind Parser WindInfo -> Parser WindInfo -> Parser WindInfo
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> WindInfo -> Parser WindInfo
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return WindInfo
noWind
pTemp :: Parser (Int, Int)
pTemp :: Parser (Int, Int)
pTemp = do let num :: ParsecT String u Identity Char
num = ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
f <- ParsecT String () Identity Char
-> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall {u}. ParsecT String u Identity Char
num (ParsecT String () Identity Char -> Parser String)
-> ParsecT String () Identity Char -> Parser String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' '
manyTill anyChar $ char '('
c <- manyTill num $ char ' '
skipRestOfLine
return (floor (read c :: Double), floor (read f :: Double))
pRh :: Parser Int
pRh :: Parser Int
pRh = do s <- ParsecT String () Identity Char
-> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'%' ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.')
return $ read s
pPressure :: Parser Int
pPressure :: Parser Int
pPressure = do ParsecT String () Identity Char
-> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity Char -> Parser String)
-> ParsecT String () Identity Char -> Parser String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'('
s <- ParsecT String () Identity Char
-> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (ParsecT String () Identity Char -> Parser String)
-> ParsecT String () Identity Char -> Parser String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' '
skipRestOfLine
return $ read s
parseData :: Parser [WeatherInfo]
parseData :: Parser [WeatherInfo]
parseData =
do (st, ss) <- GenParser Char () (String, String)
-> GenParser Char () (String, String)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Station name not available" Parser String
-> GenParser Char () (String, String)
-> GenParser Char () (String, String)
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String, String) -> GenParser Char () (String, String)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"??", String
"??")) GenParser Char () (String, String)
-> GenParser Char () (String, String)
-> GenParser Char () (String, String)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
(do st <- String -> Parser String
getAllBut String
","
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 :: String
defUrl = String
"https://tgftp.nws.noaa.gov/data/observations/metar/decoded/"
stationUrl :: String -> String
stationUrl :: ShowS
stationUrl String
station = String
defUrl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
station String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".TXT"
getData :: String -> IO String
getData :: String -> IO String
getData String
station = IO String -> (SomeException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
CE.catch
(do request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ ShowS
stationUrl String
station
man <- getGlobalManager
res <- httpLbs request man
return $ B.unpack $ responseBody res)
SomeException -> IO String
errHandler
where
errHandler :: CE.SomeException -> IO String
errHandler :: SomeException -> IO String
errHandler SomeException
_ = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"<Could not retrieve data>"
formatWeather
:: WeatherOpts
-> [(String,String)]
-> [WeatherInfo]
-> Monitor String
formatWeather :: WeatherOpts
-> [(String, String)] -> [WeatherInfo] -> Monitor String
formatWeather WeatherOpts
opts [(String, String)]
sks [WI String
st String
ss String
y String
m String
d String
h WindInfo
wind String
v String
sk String
we Int
tC Int
tF Int
dC Int
dF Int
r Int
p] =
do let WindInfo String
wc String
wa String
wm String
wk String
wkh String
wms = WindInfo
wind
cel <- (Int -> String) -> Int -> Monitor String
forall a. (Num a, Ord a) => (a -> String) -> a -> Monitor String
showWithColors Int -> String
forall a. Show a => a -> String
show Int
tC
far <- showWithColors show tF
let we' = String -> ShowS
showWeather (WeatherOpts -> String
weatherString WeatherOpts
opts) String
we
sk' = [(String, String)] -> String -> ShowS
forall {t} {t}. Eq t => [(t, t)] -> t -> t -> t
findSk [(String, String)]
sks ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
sk) String
we'
we'' = [(String, String)] -> String -> ShowS
forall {t} {t}. Eq t => [(t, t)] -> t -> t -> t
findSk [(String, String)]
sks ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
we') String
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 :: [(t, t)] -> t -> t -> t
findSk ((t
a,t
b):[(t, t)]
xs) t
x t
df = if t
a t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
x then t
b else [(t, t)] -> t -> t -> t
findSk [(t, t)]
xs t
x t
df
findSk [] t
_ t
df = t
df
formatWeather WeatherOpts
_ [(String, String)]
_ [WeatherInfo]
_ = Selector String -> Monitor String
forall a. Selector a -> Monitor a
getConfigValue Selector String
naString
showWeather :: String -> String -> String
showWeather :: String -> ShowS
showWeather String
"" String
d = String
d
showWeather String
s String
_ = String
s
startWeather'
:: [(String, String)]
-> String
-> [String]
-> Int
-> (String -> IO ())
-> IO ()
startWeather' :: [(String, String)]
-> String -> [String] -> Int -> (String -> IO ()) -> IO ()
startWeather' [(String, String)]
sks String
station [String]
args Int
rate String -> IO ()
cb = do
opts <- [OptDescr (WeatherOpts -> WeatherOpts)]
-> WeatherOpts -> [String] -> IO WeatherOpts
forall opts.
[OptDescr (opts -> opts)] -> opts -> [String] -> IO opts
parseOptsWith [OptDescr (WeatherOpts -> WeatherOpts)]
options WeatherOpts
defaultOpts ([String] -> [String]
getArgvs [String]
args)
runMD
(station : args)
weatherConfig
(runWeather sks opts)
rate
weatherReady
cb
startWeather :: String -> [String] -> Int -> (String -> IO ()) -> IO ()
startWeather :: String -> [String] -> Int -> (String -> IO ()) -> IO ()
startWeather = [(String, String)]
-> String -> [String] -> Int -> (String -> IO ()) -> IO ()
startWeather' []
runWeather
:: [(String, String)]
-> WeatherOpts
-> [String]
-> Monitor String
runWeather :: [(String, String)] -> WeatherOpts -> [String] -> Monitor String
runWeather [(String, String)]
sks WeatherOpts
opts [String]
args = do
d <- IO String -> Monitor String
forall a. IO a -> Monitor a
io (IO String -> Monitor String) -> IO String -> Monitor String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getData ([String] -> String
forall a. HasCallStack => [a] -> a
head [String]
args)
i <- io $ runP parseData d
formatWeather opts sks i
weatherReady :: [String] -> Monitor Bool
weatherReady :: [String] -> Monitor Bool
weatherReady [String]
str = IO Bool -> Monitor Bool
forall a. IO a -> Monitor a
io (IO Bool -> Monitor Bool) -> IO Bool -> Monitor Bool
forall a b. (a -> b) -> a -> b
$ do
initRequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ ShowS
stationUrl ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
str
let request = Request
initRequest { method = methodHead }
CE.catch
(do man <- getGlobalManager
res <- httpLbs request man
return $ checkResult $ responseStatus res)
errHandler
where
errHandler :: CE.SomeException -> IO Bool
errHandler :: SomeException -> IO Bool
errHandler SomeException
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
checkResult :: Status -> Bool
checkResult :: Status -> Bool
checkResult Status
status
| Status -> Bool
statusIsServerError Status
status = Bool
False
| Status -> Bool
statusIsClientError Status
status = Bool
False
| Bool
otherwise = Bool
True