diff options
Diffstat (limited to 'Weather.hs')
| -rw-r--r-- | Weather.hs | 258 |
1 files changed, 258 insertions, 0 deletions
diff --git a/Weather.hs b/Weather.hs new file mode 100644 index 0000000..b5ebaa1 --- /dev/null +++ b/Weather.hs @@ -0,0 +1,258 @@ +{- +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 |