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 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 :: String -> IO (Either String String)
downloadURL url = do
resp <- simpleHTTP request
case resp of
Left x -> return $ Left ("Error connecting: " ++ show x)
Right r ->
case rspCode r of
(2,_,_) -> return $ Right (rspBody r)
(3,_,_) ->
case findHeader HdrLocation r of
Nothing -> return $ Left (show r)
Just url' -> downloadURL url'
_ -> return $ Left (show r)
where
request = Request { rqURI = uri
, rqMethod = GET
, rqHeaders = []
, rqBody = ""
}
Just uri = parseURI url
getWeather :: String -> IO (Either String WeatherInfo)
getWeather url = do
dat <- downloadURL 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
-> WeatherFormatter
-> IO String
getCurrentWeather getter tpl formatter = do
dat <- getter
case dat of
Right wi -> do
case formatter of
DefaultWeatherFormatter -> return (defaultFormatter tpl wi)
WeatherFormatter f -> return (f wi)
Left err -> do
putStrLn err
return "N/A"
baseUrl :: String
baseUrl = "http://weather.noaa.gov/pub/data/observations/metar/decoded"
data WeatherFormatter = WeatherFormatter (WeatherInfo -> String)
| DefaultWeatherFormatter
data WeatherConfig =
WeatherConfig { weatherStation :: String
, weatherTemplate :: String
, weatherFormatter :: WeatherFormatter
}
defaultWeatherConfig :: String -> WeatherConfig
defaultWeatherConfig station = WeatherConfig { weatherStation = station
, weatherTemplate = "$tempF$ °F"
, weatherFormatter = DefaultWeatherFormatter
}
weatherNew :: WeatherConfig
-> Double
-> IO Widget
weatherNew cfg delayMinutes = do
let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)
getter = getWeather url
weatherCustomNew getter (weatherTemplate cfg) (weatherFormatter cfg) delayMinutes
weatherCustomNew :: IO (Either String WeatherInfo)
-> String
-> WeatherFormatter
-> Double
-> IO Widget
weatherCustomNew getter tpl formatter delayMinutes = do
let tpl' = newSTMP tpl
l <- pollingLabelNew "N/A" (delayMinutes * 60) (getCurrentWeather getter tpl' formatter)
widgetShowAll l
return l