path: root/Weather.hs

{-
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