{-
Copyright (C) 2022 Yuchen Pei.
This file is part of weather.
weather is free software: you can redistribute it and/or modify it under
the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
weather is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
Public License for more details.
You should have received a copy of the GNU Affero General Public
License along with weather. If not, see <https://www.gnu.org/licenses/>.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
import qualified Data.Map as Map
import Data.Maybe
import Data.Text hiding (head, tail, null, init)
import Data.Time
import Data.Aeson
import System.IO
import System.Process
import Text.XML.Light
import Yesod hiding (parseTime)
weatherUrl = "ftp://ftp.bom.gov.au/anon/gen/fwo/IDV10753.xml"
wgetCommand = "wget -O- 2>/dev/null"
xmlFileHandle :: IO Handle
xmlFileHandle = openFile "out.xml" ReadMode
xmlFromString :: String -> Element
xmlFromString = head . tail . onlyElems . parseXML
xmlFromHandle :: IO Handle -> IO Element
xmlFromHandle handle = xmlFromString <$> (hGetContents =<< handle)
xmlFromUrl :: IO Element
xmlFromUrl = xmlFromString <$> readCreateProcess
(shell $ wgetCommand ++ " " ++ weatherUrl) ""
-- main weather datatype
data WeatherPeriod =
WeatherPeriod { startTime :: ZonedTime,
endTime :: ZonedTime,
precis :: Text,
minTemp :: Maybe Int,
maxTemp :: Maybe Int,
probPrec :: Int,
precRange :: Maybe (Float, Float)}
deriving (Show)
data WeatherData =
WeatherData { cityName :: Text,
issueTime :: ZonedTime,
periods :: [WeatherPeriod] }
instance ToJSON WeatherPeriod where
toJSON weather =
object ["startTime" .= startTime weather,
"endTime" .= endTime weather,
"precis" .= precis weather,
"minTemp" .= minTemp weather,
"maxTemp" .= maxTemp weather,
"probPrec" .= probPrec weather,
"precRange" .= precRange weather]
instance ToJSON WeatherData where
toJSON (WeatherData cityName issueTime periods) =
object ["cityName" .= cityName,
"issueTime" .= issueTime,
"periods" .= periods]
-- utility functions for filtering and parsing
q :: String -> QName
q name = QName name Nothing Nothing
descriptionIs :: String -> Element -> Bool
descriptionIs desc elem = findAttr (q "description") elem == Just desc
typeIs :: String -> Element -> Bool
typeIs ty elem = findAttr (q "type") elem == Just ty
nameIs :: String -> Element -> Bool
nameIs name elem = elName elem == q name
pairFromAttr :: String -> Element -> (Text, Text)
pairFromAttr attr period = (pack attr, pack $ strFromAttr attr period)
pairFromType :: String -> Element -> (Text, Text)
pairFromType ty period = (pack ty, pack $ strFromType ty period)
forecastPeriods = filterElements (nameIs "forecast-period")
strFromAttr :: String -> Element -> String
strFromAttr attr period =
fromMaybe "" $ findAttr (q attr) period
strFromType :: String -> Element -> String
strFromType ty period = strContent $
fromMaybe blank_element $ filterElement (typeIs ty) period
parsePrecRange :: String -> Maybe (Float, Float)
parsePrecRange raw =
case splitOn " " (pack raw) of
[lo, "to", hi, "mm"] -> Just (read $ unpack lo, read $ unpack hi)
otherwise -> Nothing
parseProbPrec :: String -> Int
parseProbPrec = read . init
parseTemp :: String -> Maybe Int
parseTemp temp =
if null temp then Nothing else Just $ read temp
parseTime :: String -> ZonedTime
parseTime = parseTimeOrError False defaultTimeLocale "%FT%X%Ez"
nameFromCity :: Element -> Map.Map Text Text
nameFromCity city = Map.fromList [pairFromAttr "description" city]
cityNames :: Element -> [Map.Map Text Text]
cityNames xml =
nameFromCity <$>
filterElements (\e -> nameIs "area" e && typeIs "location" e) xml
dataFromPeriod :: Element -> WeatherPeriod
dataFromPeriod period =
WeatherPeriod
{ startTime = parseTime $ strFromAttr "start-time-local" period,
endTime = parseTime $ strFromAttr "end-time-local" period,
precis = pack $ strFromType "precis" period,
minTemp = parseTemp $ strFromType "air_temperature_minimum" period,
maxTemp = parseTemp $ strFromType "air_temperature_maximum" period,
probPrec = parseProbPrec $ strFromType "probability_of_precipitation" period,
precRange = parsePrecRange $ strFromType "precipitation_range" period
}
weather :: Text -> Element -> Maybe WeatherData
weather city xml = do
periods <- forecastPeriods <$> filterElement
(\e -> descriptionIs (unpack city) e && nameIs "area" e) xml
issueTime <- filterElement (nameIs "issue-time-local") xml
return $
WeatherData city (parseTime $ strContent issueTime)
(dataFromPeriod <$> periods)
-- yesod part
-- the main site
data Weather = Weather
mkYesod "Weather" [parseRoutes|
/ HomeR GET
/city/#Text CityR GET
/json/ HomeJR GET
/json/cities CitiesJR GET
/json/city/#Text CityJR GET
|]
instance Yesod Weather
-- render utilities
renderMaybeNumber :: Show t => Maybe t -> String
renderMaybeNumber x = if isNothing x then "" else show $ fromJust x
renderRange :: Show t => Maybe t -> Maybe t -> String -> Text
renderRange lo hi unit = case (lo, hi) of
(Nothing, Nothing) -> ""
otherwise -> pack $ renderMaybeNumber lo ++ "--" ++ renderMaybeNumber hi ++ unit
renderTempRange :: WeatherPeriod -> Text
renderTempRange weather = renderRange (minTemp weather) (maxTemp weather) "C"
renderPrecRange :: Maybe (Float, Float) -> Text
renderPrecRange r = case r of
Just (lo, hi) -> renderRange (Just lo) (Just hi) "mm"
otherwise -> ""
renderDay :: ZonedTime -> String
renderDay = formatTime defaultTimeLocale "%F %a"
renderDayWithAnnot :: ZonedTime -> IO Text
renderDayWithAnnot time =
let initial = renderDay time in
do
zonedTime <- getZonedTime
if localDay (zonedTimeToLocalTime zonedTime) ==
localDay (zonedTimeToLocalTime time)
then return $ pack $ initial ++ " (today)"
else return $ pack initial
widgetLiIfNotNull :: Text -> WidgetFor Weather ()
widgetLiIfNotNull t = case t of
"" -> [whamlet||]
otherwise -> [whamlet|<li>#{t}|]
widgetDay :: WeatherPeriod -> WidgetFor Weather ()
widgetDay weather =
(liftIO . renderDayWithAnnot . startTime) weather
>>= \s -> [whamlet|#{s}|]
renderWeatherPeriods :: [WeatherPeriod] -> WidgetFor Weather ()
renderWeatherPeriods periods = [whamlet|
<ul>
$forall weather <- periods
<li>^{widgetDay weather}
<ul>
<li>#{precis weather}
^{widgetLiIfNotNull $ renderTempRange weather}
<li>Rain: #{probPrec weather}% #{renderPrecRange $ precRange weather}|]
renderWeather :: Maybe WeatherData -> WidgetFor Weather ()
renderWeather weather = do
toWidgetHead [hamlet|
<meta name="viewport" content="width=device-width, initial-scale=1">
|]
case weather of
Nothing -> [whamlet|No weather data!|]
Just w -> do
[whamlet|<h2>Weather forecast for #{cityName w}|]
renderWeatherPeriods $ periods $ w
[whamlet|Last updated on #{show $ issueTime w}.|]
-- routers
getHomeR :: HandlerFor Weather Html
getHomeR = defaultLayout $ liftIO (weather "Melbourne" <$> xmlFromUrl) >>= renderWeather
getCityR :: Text -> HandlerFor Weather Html
getCityR city =
defaultLayout $ liftIO (weather city <$> xmlFromUrl) >>= renderWeather
getHomeJR :: HandlerFor Weather Value
getHomeJR = getCityJR "Melbourne"
getCityJR :: Text -> HandlerFor Weather Value
getCityJR city =
liftIO $ (toJSON . weather city) <$> xmlFromUrl
getCitiesJR = liftIO $ (toJSON . cityNames) <$> xmlFromUrl
main :: IO ()
main = warp 3000 Weather