{-# LANGUAGE OverloadedStrings #-}
-- | This module defines a simple textual weather widget that polls
-- NOAA for weather data.  To find your weather station, you can use
-- either of the following:
--
-- <https://www.weather.gov/tg/siteloc>
-- <https://cnrfc.noaa.gov/metar.php>
--
-- For example, Madison, WI is KMSN.
--
-- NOAA provides several pieces of information in each request; you can control
-- which pieces end up in your weather widget by providing a _template_ that is
-- filled in with the current information. The template is just a 'String' with
-- variables between dollar signs. The variables will be substituted with real
-- data by the widget. Example:
--
-- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" }
-- >     weatherWidget = weatherNew wcfg 10
--
-- This example makes a new weather widget that checks the weather at KMSN
-- (Madison, WI) every 10 minutes, and displays the results in Celcius.
--
-- Available variables:
--
-- [@stationPlace@] The name of the weather station
--
-- [@stationState@] The state that the weather station is in
--
-- [@year@] The year the report was generated
--
-- [@month@] The month the report was generated
--
-- [@day@] The day the report was generated
--
-- [@hour@] The hour the report was generated
--
-- [@wind@] The direction and strength of the wind
--
-- [@visibility@] Description of current visibility conditions
--
-- [@skyCondition@] ?
--
-- [@tempC@] The temperature in Celsius
--
-- [@tempF@] The temperature in Farenheit
--
-- [@dewPoint@] The current dew point
--
-- [@humidity@] The current relative humidity
--
-- [@pressure@] The current pressure
--
--
-- As an example, a template like
--
-- > "$tempF$ °F"
--
-- would yield a widget displaying the temperature in Farenheit with a small
-- label after it.
--
-- Implementation Note: the weather data parsing code is taken from xmobar. This
-- version of the code makes direct HTTP requests instead of invoking a separate
-- cURL process.

module System.Taffybar.Widget.Weather
  ( WeatherConfig(..)
  , WeatherInfo(..)
  , WeatherFormatter(WeatherFormatter)
  , weatherNew
  , weatherCustomNew
  , defaultWeatherConfig
  ) where

import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as LB
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GI.GLib(markupEscapeText)
import GI.Gtk
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status
import System.Log.Logger
import Text.Parsec
import Text.Printf
import Text.StringTemplate

import System.Taffybar.Widget.Generic.PollingLabel

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 -> String
wind :: String
  , WeatherInfo -> String
visibility :: String
  , WeatherInfo -> String
skyCondition :: String
  , WeatherInfo -> Int
tempC :: Int
  , WeatherInfo -> Int
tempF :: Int
  , WeatherInfo -> String
dewPoint :: String
  , 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)

-- Parsers stolen from xmobar

type Parser = Parsec String ()

pTime :: Parser (String, String, String, String)
pTime :: Parser (String, String, String, String)
pTime = do
  String
y <- Parser String
getNumbersAsString
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
  String
m <- Parser String
getNumbersAsString
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
  String
d <- Parser String
getNumbersAsString
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' '
  (Char
h:Char
hh:Char
mi:String
mimi) <- Parser String
getNumbersAsString
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' '
  (String, String, String, String)
-> Parser (String, String, String, String)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
y, String
m, String
d , [Char
h]String -> ShowS
forall a. [a] -> [a] -> [a]
++[Char
hh]String -> ShowS
forall a. [a] -> [a] -> [a]
++String
":"String -> ShowS
forall a. [a] -> [a] -> [a]
++[Char
mi]String -> ShowS
forall a. [a] -> [a] -> [a]
++String
mimi)

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
'.'
  String
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
' '
  String
_ <- 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
'('
  String
c <- 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
' '
  Char
_ <- ParsecT String () Identity Char
skipRestOfLine
  (Int, Int) -> Parser (Int, Int)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (String -> Double
forall a. Read a => String -> a
read String
c :: Double), Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (String -> Double
forall a. Read a => String -> a
read String
f :: Double))

pRh :: Parser Int
pRh :: Parser Int
pRh = do
  String
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
'%' 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
'.'
  Int -> Parser Int
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
s

pPressure :: Parser Int
pPressure :: Parser Int
pPressure = do
  String
_ <- 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
'('
  String
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
' '
  Char
_ <- ParsecT String () Identity Char
skipRestOfLine
  Int -> Parser Int
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
s

parseData :: Parser WeatherInfo
parseData :: Parser WeatherInfo
parseData = do
  String
st <- String -> Parser String
getAllBut String
","
  Char
_ <- ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
  String
ss <- String -> Parser String
getAllBut String
"("
  String
_ <- ParsecT String () Identity Char
skipRestOfLine ParsecT String () Identity Char -> Parser String -> Parser 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 -> Parser String
getAllBut String
"/"
  (String
y,String
m,String
d,String
h) <- Parser (String, String, String, String)
pTime
  String
w <- String -> Parser String
getAfterString String
"Wind: "
  String
v <- String -> Parser String
getAfterString String
"Visibility: "
  String
sk <- String -> Parser String
getAfterString String
"Sky conditions: "
  String
_ <- String -> Parser String
skipTillString String
"Temperature: "
  (Int
tC,Int
tF) <- Parser (Int, Int)
pTemp
  String
dp <- String -> Parser String
getAfterString String
"Dew Point: "
  String
_ <- String -> Parser String
skipTillString String
"Relative Humidity: "
  Int
rh <- Parser Int
pRh
  String
_ <- String -> Parser String
skipTillString String
"Pressure (altimeter): "
  Int
p <- Parser Int
pPressure
  String
_ <- ParsecT String () Identity Char
-> ParsecT String () Identity () -> 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 ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  WeatherInfo -> Parser WeatherInfo
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (WeatherInfo -> Parser WeatherInfo)
-> WeatherInfo -> Parser WeatherInfo
forall a b. (a -> b) -> a -> b
$ String
-> String
-> String
-> String
-> String
-> String
-> String
-> String
-> String
-> Int
-> Int
-> String
-> Int
-> Int
-> WeatherInfo
WI String
st String
ss String
y String
m String
d String
h String
w String
v String
sk Int
tC Int
tF String
dp Int
rh Int
p

getAllBut :: String -> Parser String
getAllBut :: String -> Parser String
getAllBut String
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 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
s) (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)
-> Char -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ String -> Char
forall a. HasCallStack => [a] -> a
head String
s)

getAfterString :: String -> Parser String
getAfterString :: String -> Parser String
getAfterString String
s = Parser String
pAfter Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> Parser String
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found!>")
  where
    pAfter :: Parser String
pAfter = do
      String
_ <- Parser String -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ 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 (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
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
anyChar ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline

skipTillString :: String -> Parser String
skipTillString :: String -> Parser String
skipTillString String
s =
    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 (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
s

getNumbersAsString :: Parser String
getNumbersAsString :: Parser String
getNumbersAsString = ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT String () Identity () -> Parser String -> Parser 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
>> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit Parser String -> (String -> Parser String) -> Parser String
forall a b.
ParsecT String () Identity a
-> (a -> ParsecT String () Identity b)
-> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
n -> String -> Parser String
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return String
n

skipRestOfLine :: Parser Char
skipRestOfLine :: ParsecT String () Identity Char
skipRestOfLine = do
  String
_ <- ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char -> Parser String)
-> ParsecT String () Identity Char -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\n\r"
  ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline

-- | Simple: download the document at a URL.
downloadURL :: Manager -> Request -> IO (Either String String)
downloadURL :: Manager -> Request -> IO (Either String String)
downloadURL Manager
mgr Request
request = do
  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
mgr
  case Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response of
    Status
s | Status
s Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
>= Status
status200 Bool -> Bool -> Bool
&& Status
s Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
status300 ->
      Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. b -> Either a b
Right (Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.toStrict (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response)
    Status
otherStatus ->
      Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
"HTTP 2XX status was expected but received " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Status -> String
forall a. Show a => a -> String
show Status
otherStatus

getWeather :: Manager -> String -> IO (Either String WeatherInfo)
getWeather :: Manager -> String -> IO (Either String WeatherInfo)
getWeather Manager
mgr String
url = do
  Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
  Either String String
dat <- Manager -> Request -> IO (Either String String)
downloadURL Manager
mgr Request
request
  case Either String String
dat of
    Right String
dat' -> case Parser WeatherInfo
-> String -> String -> Either ParseError WeatherInfo
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser WeatherInfo
parseData String
url String
dat' of
      Right WeatherInfo
d -> Either String WeatherInfo -> IO (Either String WeatherInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WeatherInfo -> Either String WeatherInfo
forall a b. b -> Either a b
Right WeatherInfo
d)
      Left ParseError
err -> Either String WeatherInfo -> IO (Either String WeatherInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String WeatherInfo
forall a b. a -> Either a b
Left (ParseError -> String
forall a. Show a => a -> String
show ParseError
err))
    Left String
err -> Either String WeatherInfo -> IO (Either String WeatherInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String WeatherInfo
forall a b. a -> Either a b
Left (ShowS
forall a. Show a => a -> String
show String
err))

defaultFormatter :: StringTemplate String -> WeatherInfo -> String
defaultFormatter :: StringTemplate String -> WeatherInfo -> String
defaultFormatter StringTemplate String
tpl WeatherInfo
wi = StringTemplate String -> String
forall a. Stringable a => StringTemplate a -> a
render StringTemplate String
tpl'
  where
    tpl' :: StringTemplate String
tpl' = [(String, String)]
-> StringTemplate String -> StringTemplate String
forall a b.
(ToSElem a, Stringable b) =>
[(String, a)] -> StringTemplate b -> StringTemplate b
setManyAttrib [ (String
"stationPlace", WeatherInfo -> String
stationPlace WeatherInfo
wi)
                         , (String
"stationState", WeatherInfo -> String
stationState WeatherInfo
wi)
                         , (String
"year", WeatherInfo -> String
year WeatherInfo
wi)
                         , (String
"month", WeatherInfo -> String
month WeatherInfo
wi)
                         , (String
"day", WeatherInfo -> String
day WeatherInfo
wi)
                         , (String
"hour", WeatherInfo -> String
hour WeatherInfo
wi)
                         , (String
"wind", WeatherInfo -> String
wind WeatherInfo
wi)
                         , (String
"visibility", WeatherInfo -> String
visibility WeatherInfo
wi)
                         , (String
"skyCondition", WeatherInfo -> String
skyCondition WeatherInfo
wi)
                         , (String
"tempC", Int -> String
forall a. Show a => a -> String
show (WeatherInfo -> Int
tempC WeatherInfo
wi))
                         , (String
"tempF", Int -> String
forall a. Show a => a -> String
show (WeatherInfo -> Int
tempF WeatherInfo
wi))
                         , (String
"dewPoint", WeatherInfo -> String
dewPoint WeatherInfo
wi)
                         , (String
"humidity", Int -> String
forall a. Show a => a -> String
show (WeatherInfo -> Int
humidity WeatherInfo
wi))
                         , (String
"pressure", Int -> String
forall a. Show a => a -> String
show (WeatherInfo -> Int
pressure WeatherInfo
wi))
                         ] StringTemplate String
tpl

getCurrentWeather :: IO (Either String WeatherInfo)
    -> StringTemplate String
    -> StringTemplate String
    -> WeatherFormatter
    -> IO (T.Text, Maybe T.Text)
getCurrentWeather :: IO (Either String WeatherInfo)
-> StringTemplate String
-> StringTemplate String
-> WeatherFormatter
-> IO (Text, Maybe Text)
getCurrentWeather IO (Either String WeatherInfo)
getter StringTemplate String
labelTpl StringTemplate String
tooltipTpl WeatherFormatter
formatter = do
  Either String WeatherInfo
dat <- IO (Either String WeatherInfo)
getter
  case Either String WeatherInfo
dat of
    Right WeatherInfo
wi ->
      case WeatherFormatter
formatter of
        WeatherFormatter
DefaultWeatherFormatter -> do
          let rawLabel :: Text
rawLabel = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ StringTemplate String -> WeatherInfo -> String
defaultFormatter StringTemplate String
labelTpl WeatherInfo
wi
          let rawTooltip :: Text
rawTooltip = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ StringTemplate String -> WeatherInfo -> String
defaultFormatter StringTemplate String
tooltipTpl WeatherInfo
wi
          Text
lbl <- Text -> Int64 -> IO Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Text
markupEscapeText Text
rawLabel (-Int64
1)
          Text
tooltip <- Text -> Int64 -> IO Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Text
markupEscapeText Text
rawTooltip (-Int64
1)
          (Text, Maybe Text) -> IO (Text, Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
lbl, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
tooltip)
        WeatherFormatter WeatherInfo -> String
f -> do
          let rawLabel :: Text
rawLabel = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ WeatherInfo -> String
f WeatherInfo
wi
          Text
lbl <- Text -> Int64 -> IO Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Text
markupEscapeText Text
rawLabel (-Int64
1)
          (Text, Maybe Text) -> IO (Text, Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
lbl, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
lbl)
    Left String
err -> do
      String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Widget.Weather" Priority
ERROR (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error in weather: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
err
      (Text, Maybe Text) -> IO (Text, Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"N/A", Maybe Text
forall a. Maybe a
Nothing)

-- | The NOAA URL to get data from
baseUrl :: String
baseUrl :: String
baseUrl = String
"https://tgftp.nws.noaa.gov/data/observations/metar/decoded"

-- | A wrapper to allow users to specify a custom weather formatter.
-- The default interpolates variables into a string as described
-- above.  Custom formatters can do basically anything.
data WeatherFormatter
  = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo'
  | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter

-- | The configuration for the weather widget.  You can provide a custom
-- format string through 'weatherTemplate' as described above, or you can
-- provide a custom function to turn a 'WeatherInfo' into a String via the
-- 'weatherFormatter' field.
data WeatherConfig = WeatherConfig
  { WeatherConfig -> String
weatherStation :: String -- ^ The weather station to poll. No default
  , WeatherConfig -> String
weatherTemplate :: String -- ^ Template string, as described above.  Default: $tempF$ °F
  , WeatherConfig -> String
weatherTemplateTooltip :: String -- ^ Template string, as described above.  Default: $tempF$ °F
  , WeatherConfig -> WeatherFormatter
weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)
  , WeatherConfig -> Maybe String
weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing
  }

-- | A sensible default configuration for the weather widget that just
-- renders the temperature.
defaultWeatherConfig :: String -> WeatherConfig
defaultWeatherConfig :: String -> WeatherConfig
defaultWeatherConfig String
station =
  WeatherConfig
  { weatherStation :: String
weatherStation = String
station
  , weatherTemplate :: String
weatherTemplate = String
"$tempF$ °F"
  , weatherTemplateTooltip :: String
weatherTemplateTooltip =
      [String] -> String
unlines
        [ String
"Station: $stationPlace$"
        , String
"Time: $day$.$month$.$year$ $hour$"
        , String
"Temperature: $tempF$ °F"
        , String
"Pressure: $pressure$ hPa"
        , String
"Wind: $wind$"
        , String
"Visibility: $visibility$"
        , String
"Sky Condition: $skyCondition$"
        , String
"Dew Point: $dewPoint$"
        , String
"Humidity: $humidity$"
        ]
  , weatherFormatter :: WeatherFormatter
weatherFormatter = WeatherFormatter
DefaultWeatherFormatter
  , weatherProxy :: Maybe String
weatherProxy = Maybe String
forall a. Maybe a
Nothing
  }

-- | Create a periodically-updating weather widget that polls NOAA.
weatherNew :: MonadIO m
           => WeatherConfig -- ^ Configuration to render
           -> Double     -- ^ Polling period in _minutes_
           -> m GI.Gtk.Widget
weatherNew :: forall (m :: * -> *).
MonadIO m =>
WeatherConfig -> Double -> m Widget
weatherNew WeatherConfig
cfg Double
delayMinutes = IO Widget -> m Widget
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> m Widget) -> IO Widget -> m Widget
forall a b. (a -> b) -> a -> b
$ do
  -- TODO: add explicit proxy host/port to WeatherConfig and
  -- get rid of this ugly stringly-typed setting
  let usedProxy :: ProxyOverride
usedProxy = case WeatherConfig -> Maybe String
weatherProxy WeatherConfig
cfg of
        Maybe String
Nothing -> ProxyOverride
noProxy
        Just String
str ->
          let strToBs :: String -> ByteString
strToBs = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
              noHttp :: String
noHttp = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
str (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"http://" String
str
              (ByteString
phost, Int
pport) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
':'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
noHttp of
                (String
h, String
"") -> (String -> ByteString
strToBs String
h, Int
80) -- HTTP seems to assume 80 to be the default
                (String
h, Char
':':String
p) -> (String -> ByteString
strToBs String
h, String -> Int
forall a. Read a => String -> a
read String
p)
                (String, String)
_ -> String -> (ByteString, Int)
forall a. HasCallStack => String -> a
error String
"unreachable: broken span"
          in Proxy -> ProxyOverride
useProxy (Proxy -> ProxyOverride) -> Proxy -> ProxyOverride
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> Proxy
Proxy ByteString
phost Int
pport
  Manager
mgr <- ManagerSettings -> IO Manager
newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetProxy ProxyOverride
usedProxy ManagerSettings
tlsManagerSettings
  let url :: String
url = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s/%s.TXT" String
baseUrl (WeatherConfig -> String
weatherStation WeatherConfig
cfg)
  let getter :: IO (Either String WeatherInfo)
getter = Manager -> String -> IO (Either String WeatherInfo)
getWeather Manager
mgr String
url
  IO (Either String WeatherInfo)
-> String -> String -> WeatherFormatter -> Double -> IO Widget
forall (m :: * -> *).
MonadIO m =>
IO (Either String WeatherInfo)
-> String -> String -> WeatherFormatter -> Double -> m Widget
weatherCustomNew IO (Either String WeatherInfo)
getter (WeatherConfig -> String
weatherTemplate WeatherConfig
cfg) (WeatherConfig -> String
weatherTemplateTooltip WeatherConfig
cfg)
    (WeatherConfig -> WeatherFormatter
weatherFormatter WeatherConfig
cfg) Double
delayMinutes

-- | Create a periodically-updating weather widget using custom weather getter
weatherCustomNew
  :: MonadIO m
  => IO (Either String WeatherInfo) -- ^ Weather querying action
  -> String -- ^ Weather template
  -> String -- ^ Weather template
  -> WeatherFormatter -- ^ Weather formatter
  -> Double -- ^ Polling period in _minutes_
  -> m GI.Gtk.Widget
weatherCustomNew :: forall (m :: * -> *).
MonadIO m =>
IO (Either String WeatherInfo)
-> String -> String -> WeatherFormatter -> Double -> m Widget
weatherCustomNew IO (Either String WeatherInfo)
getter String
labelTpl String
tooltipTpl WeatherFormatter
formatter Double
delayMinutes = IO Widget -> m Widget
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> m Widget) -> IO Widget -> m Widget
forall a b. (a -> b) -> a -> b
$ do
  let labelTpl' :: StringTemplate String
labelTpl' = String -> StringTemplate String
forall a. Stringable a => String -> StringTemplate a
newSTMP String
labelTpl
      tooltipTpl' :: StringTemplate String
tooltipTpl' = String -> StringTemplate String
forall a. Stringable a => String -> StringTemplate a
newSTMP String
tooltipTpl

  Widget
l <- Double -> IO (Text, Maybe Text) -> IO Widget
forall (m :: * -> *).
MonadIO m =>
Double -> IO (Text, Maybe Text) -> m Widget
pollingLabelNewWithTooltip (Double
delayMinutes Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
60)
       (IO (Either String WeatherInfo)
-> StringTemplate String
-> StringTemplate String
-> WeatherFormatter
-> IO (Text, Maybe Text)
getCurrentWeather IO (Either String WeatherInfo)
getter StringTemplate String
labelTpl' StringTemplate String
tooltipTpl' WeatherFormatter
formatter)

  Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
GI.Gtk.widgetShowAll Widget
l
  Widget -> IO Widget
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Widget
l