module System.Taffybar.Weather (
WeatherConfig(..),
WeatherInfo(..),
WeatherFormatter(WeatherFormatter),
weatherNew,
weatherCustomNew,
defaultWeatherConfig
) where
import Network.HTTP
import Network.URI
import Graphics.UI.Gtk
import Text.Parsec
import Text.Printf
import Text.StringTemplate
import qualified Network.Browser as Browser
import System.Taffybar.Widgets.PollingLabel
data WeatherInfo =
WI { stationPlace :: String
, stationState :: String
, year :: String
, month :: String
, day :: String
, hour :: String
, wind :: String
, visibility :: String
, skyCondition :: String
, tempC :: Int
, tempF :: Int
, dewPoint :: String
, humidity :: Int
, pressure :: Int
} deriving (Show)
type Parser = Parsec String ()
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))
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
parseData :: Parser WeatherInfo
parseData = do
st <- getAllBut ","
_ <- space
ss <- getAllBut "("
_ <- skipRestOfLine >> getAllBut "/"
(y,m,d,h) <- pTime
w <- getAfterString "Wind: "
v <- getAfterString "Visibility: "
sk <- getAfterString "Sky conditions: "
_ <- skipTillString "Temperature: "
(tC,tF) <- pTemp
dp <- getAfterString "Dew Point: "
_ <- skipTillString "Relative Humidity: "
rh <- pRh
_ <- skipTillString "Pressure (altimeter): "
p <- pPressure
_ <- manyTill skipRestOfLine eof
return $ WI st ss y m d h w v sk tC tF dp rh p
getAllBut :: String -> Parser String
getAllBut s =
manyTill (noneOf s) (char $ head s)
getAfterString :: String -> Parser String
getAfterString s = pAfter <|> return ("<" ++ s ++ " not found!>")
where
pAfter = do
_ <- try $ manyTill skipRestOfLine $ string s
v <- manyTill anyChar $ newline
return v
skipTillString :: String -> Parser String
skipTillString s =
manyTill skipRestOfLine $ string s
getNumbersAsString :: Parser String
getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n
skipRestOfLine :: Parser Char
skipRestOfLine = do
_ <- many $ noneOf "\n\r"
newline
downloadURL :: Maybe String -> String -> IO (Either String String)
downloadURL mProxy url = do
(_, r) <- Browser.browse $ do
case mProxy of
Just proxy -> Browser.setProxy $ Browser.Proxy proxy Nothing
Nothing -> return ()
Browser.setAllowRedirects True
Browser.request request
case rspCode r of
(2,_,_) -> return $ Right (rspBody r)
_ -> return $ Left (show r)
where
request = Request { rqURI = uri
, rqMethod = GET
, rqHeaders = []
, rqBody = ""
}
Just uri = parseURI url
getWeather :: Maybe String -> String -> IO (Either String WeatherInfo)
getWeather mProxy url = do
dat <- downloadURL mProxy url
case dat of
Right dat' -> case parse parseData url dat' of
Right d -> return (Right d)
Left err -> return (Left (show err))
Left err -> return (Left (show err))
defaultFormatter :: StringTemplate String -> WeatherInfo -> String
defaultFormatter tpl wi = render tpl'
where
tpl' = setManyAttrib [ ("stationPlace", stationPlace wi)
, ("stationState", stationState wi)
, ("year", year wi)
, ("month", month wi)
, ("day", day wi)
, ("hour", hour wi)
, ("wind", wind wi)
, ("visibility", visibility wi)
, ("skyCondition", skyCondition wi)
, ("tempC", show (tempC wi))
, ("tempF", show (tempF wi))
, ("dewPoint", dewPoint wi)
, ("humidity", show (humidity wi))
, ("pressure", show (pressure wi))
] tpl
getCurrentWeather :: IO (Either String WeatherInfo)
-> StringTemplate String
-> StringTemplate String
-> WeatherFormatter
-> IO (String, Maybe String)
getCurrentWeather getter labelTpl tooltipTpl formatter = do
dat <- getter
case dat of
Right wi ->
return $ case formatter of
DefaultWeatherFormatter -> (escapeMarkup $ defaultFormatter labelTpl wi,
Just $ escapeMarkup $ defaultFormatter tooltipTpl wi)
WeatherFormatter f -> (f wi, Just $ f wi)
Left err -> do
putStrLn err
return ("N/A", Nothing)
baseUrl :: String
baseUrl = "http://tgftp.nws.noaa.gov/data/observations/metar/decoded"
data WeatherFormatter = WeatherFormatter (WeatherInfo -> String)
| DefaultWeatherFormatter
data WeatherConfig =
WeatherConfig { weatherStation :: String
, weatherTemplate :: String
, weatherTemplateTooltip :: String
, weatherFormatter :: WeatherFormatter
, weatherProxy :: Maybe String
}
defaultWeatherConfig :: String -> WeatherConfig
defaultWeatherConfig station = WeatherConfig
{ weatherStation = station
, weatherTemplate = "$tempF$ °F"
, weatherTemplateTooltip = unlines ["Station: $stationPlace$",
"Time: $day$.$month$.$year$ $hour$",
"Temperature: $tempF$ °F",
"Pressure: $pressure$ hPa",
"Wind: $wind$",
"Visibility: $visibility$",
"Sky Condition: $skyCondition$",
"Dew Point: $dewPoint$",
"Humidity: $humidity$"
]
, weatherFormatter = DefaultWeatherFormatter
, weatherProxy = Nothing}
weatherNew :: WeatherConfig
-> Double
-> IO Widget
weatherNew cfg delayMinutes = do
let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)
getter = getWeather (weatherProxy cfg) url
weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg)
(weatherFormatter cfg) delayMinutes
weatherCustomNew :: IO (Either String WeatherInfo)
-> String
-> String
-> WeatherFormatter
-> Double
-> IO Widget
weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = do
let labelTpl' = newSTMP labelTpl
tooltipTpl' = newSTMP tooltipTpl
l <- pollingLabelNewWithTooltip "N/A" (delayMinutes * 60)
(getCurrentWeather getter labelTpl' tooltipTpl' formatter)
widgetShowAll l
return l