{- 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 . -} {-# 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|
  • #{t}|] widgetDay :: WeatherPeriod -> WidgetFor Weather () widgetDay weather = (liftIO . renderDayWithAnnot . startTime) weather >>= \s -> [whamlet|#{s}|] renderWeatherPeriods :: [WeatherPeriod] -> WidgetFor Weather () renderWeatherPeriods periods = [whamlet|