weatherhs-1.0.0: app/Main.hs
{-
- Copyright (C) 2022 Nikola Hadžić
-
- This file is part of weatherhs.
-
- weatherhs is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- weatherhs 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 General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with weatherhs. If not, see <https://www.gnu.org/licenses/>.
-}
{-# LANGUAGE CPP, OverloadedStrings #-}
module Main where
import qualified Paths_weatherhs as Paths
import Control.Exception
import Data.Maybe
import Data.Version (showVersion)
import qualified Data.ByteString.Char8 as BSC8
import qualified Data.ByteString.Lazy as BSL
import Text.Printf (printf)
import Text.I18N.GetText (bindTextDomain, textDomain)
import Text.Regex.PCRE ((=~))
import System.IO (stderr, hPutStrLn)
import System.Locale.SetLocale (Category(LC_ALL), setLocale)
import System.Environment (getArgs, lookupEnv)
import System.Exit (ExitCode(ExitFailure), exitWith)
import qualified System.Console.Terminal.Size as TermSize
import qualified Network.HTTP.Types.Status as HTTPStatus
import qualified Network.HTTP.Client as HTTPClient
import qualified Network.HTTP.Client.TLS as HTTPClientTLS
import GetText
import DateTime
import ArgParser
import Draw
#ifdef FLAG_ENCRYPTION
import qualified Data.ByteString as BS
import System.Directory (getHomeDirectory)
import qualified Crypto.Gpgme
#endif
#ifndef FLAG_NOJSON
import qualified Data.Scientific as Scientific
import qualified Data.Text as Text
import qualified Data.Aeson.Types as JSONTypes
import qualified Data.Aeson as JSON
import Data.Aeson ((.:))
#endif
#ifndef FLAG_NOXML
import Data.Text.Lazy.Encoding as TextEncLazy
import Text.Read (readMaybe)
import Data.List (find)
import qualified Text.XML.Light.Types as XMLTypes
import qualified Text.XML.Light.Proc as XMLProc
import qualified Text.XML.Light.Input as XMLInput
#endif
#if !defined(FLAG_NOJSON) || !defined(FLAG_NOXML)
import FormatWeather
#endif
-- Default macro values.
#ifndef __MESSAGE_CATALOG_DOMAIN__
#define __MESSAGE_CATALOG_DOMAIN__ "weatherhs"
#endif
#ifndef __MESSAGE_CATALOG_DIR__
#define __MESSAGE_CATALOG_DIR__ "/usr/share/locale/"
#endif
-- Program exit codes.
#define EXIT_CODE_SUCCESS 0
#define EXIT_CODE_BAD_ENVIRONMENT 1
#define EXIT_CODE_SYSTEM_ERROR 2
#define EXIT_CODE_NETWORK_ERROR 3
#define EXIT_CODE_PARSING_ERROR 4
#ifdef FLAG_ENCRYPTION
-- Decrypts and returns the API key needed to retrieve the data from the server.
getAPIKeyEnc :: IO (Either Crypto.Gpgme.DecryptError (Maybe String))
getAPIKeyEnc = do
mKeyEncPath <- lookupEnv("WEATHERHS_API_KEY_ENC")
case mKeyEncPath of
Nothing -> return (Right Nothing)
Just keyEncPath ->
if (length keyEncPath) == 0 then
return (Right Nothing)
else do
locale <- setLocale LC_ALL Nothing
homedir <- lookupEnv("GNUPGHOME") >>= \mHomedir -> case mHomedir of
Nothing -> fmap (++ "/.gnupg/") getHomeDirectory
Just homedir -> return homedir
Crypto.Gpgme.withCtx homedir (fromMaybe "C" locale) Crypto.Gpgme.OpenPGP (\context -> do
file <- BS.readFile keyEncPath
decrypted <- Crypto.Gpgme.decrypt context file
return (case decrypted of
Left err -> Left err
Right plain -> Right (if plain =~ ("^[0-9a-fA-F]+$" :: String) then Just (BSC8.unpack plain) else Nothing)))
#endif
-- Returns the unencrypted API key needed to retrieve the data from the server.
getAPIKey :: IO (Maybe String)
getAPIKey = do
mKey <- lookupEnv("WEATHERHS_API_KEY")
return (case mKey of
Nothing -> Nothing
Just key -> if key =~ ("^[0-9a-fA-F]+$" :: String) then mKey else Nothing)
-- Returns the location to query the data for.
getLocation :: IO (Maybe String)
getLocation = do
mLocation <- lookupEnv("WEATHERHS_LOCATION")
return (case mLocation of
Nothing -> Nothing
Just location -> if location =~ ("^[ ,.[:alnum:]]+$" :: String) then mLocation else Nothing)
-- Returns the language in which to request data.
getLanguage :: IO String
getLanguage = do
mLanguage <- lookupEnv("WEATHERHS_LANGUAGE")
return (case mLanguage of
Nothing -> "en"
Just language -> if language =~ ("^[a-z_]+$" :: String) then language else "en")
-- Returns the data request URL.
getRequestURL :: String -> String -> String -> String -> String -> Bool -> Bool -> Int -> String -> Bool -> String
getRequestURL mode format key language location aqi alerts days date safe = (printf "http%s://api.weatherapi.com/v1/%s.%s?key=%s&lang=%s&q=%s" ((if safe then "s" else "") :: String) mode format key language location) ++
case mode of
"timezone" -> ""
"current" -> printf "&aqi=%s" ((if aqi then "yes" else "no") :: String)
"forecast" -> printf "&aqi=%s&alerts=%s&days=%d" ((if aqi then "yes" else "no") :: String) ((if alerts then "yes" else "no") :: String) days
"astronomy" -> printf "&dt=%s" date
_ -> error ("Unknown information type mode: " ++ mode)
-- Parses the given JSON weather data and returns the appropriate output according to the given options.
parseWeatherDataJSON :: Word -> Bool -> String -> Bool -> Bool -> BSL.ByteString -> Either String String
#ifndef FLAG_NOJSON
parseWeatherDataJSON termWidth pp mode aqi alerts input = do
case JSON.decode input of
Nothing -> Left (__ "Failed decoding JSON data input.")
Just result -> do
output <- case mode of
"timezone" -> flip JSONTypes.parseEither result $ \obj -> do
location <- obj .: "location" :: JSONTypes.Parser JSON.Object
name <- fmap Text.unpack (location .: "name" :: JSONTypes.Parser Text.Text)
region <- fmap Text.unpack (location .: "region" :: JSONTypes.Parser Text.Text)
country <- fmap Text.unpack (location .: "country" :: JSONTypes.Parser Text.Text)
lat <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (location .: "lat" :: JSONTypes.Parser Scientific.Scientific)
lon <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (location .: "lon" :: JSONTypes.Parser Scientific.Scientific)
tz_id <- fmap Text.unpack (location .: "tz_id" :: JSONTypes.Parser Text.Text)
localtime <- fmap Text.unpack (location .: "localtime" :: JSONTypes.Parser Text.Text)
return (formatWeatherTimeZone termWidth pp name region country (lat, lon) tz_id localtime)
"current" -> flip JSONTypes.parseEither result $ \obj -> do
location <- obj .: "location" :: JSONTypes.Parser JSON.Object
name <- fmap Text.unpack (location .: "name" :: JSONTypes.Parser Text.Text)
region <- fmap Text.unpack (location .: "region" :: JSONTypes.Parser Text.Text)
country <- fmap Text.unpack (location .: "country" :: JSONTypes.Parser Text.Text)
current <- obj .: "current" :: JSONTypes.Parser JSON.Object
last_updated <- fmap Text.unpack (current .: "last_updated" :: JSONTypes.Parser Text.Text)
temp_c <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "temp_c" :: JSONTypes.Parser Scientific.Scientific)
temp_f <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "temp_f" :: JSONTypes.Parser Scientific.Scientific)
feelslike_c <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "feelslike_c" :: JSONTypes.Parser Scientific.Scientific)
feelslike_f <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "feelslike_f" :: JSONTypes.Parser Scientific.Scientific)
wind_kph <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "wind_kph" :: JSONTypes.Parser Scientific.Scientific)
wind_mph <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "wind_mph" :: JSONTypes.Parser Scientific.Scientific)
wind_degree <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (current .: "wind_degree" :: JSONTypes.Parser Scientific.Scientific)
wind_dir <- fmap Text.unpack (current .: "wind_dir" :: JSONTypes.Parser Text.Text)
pressure_mb <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "pressure_mb" :: JSONTypes.Parser Scientific.Scientific)
pressure_in <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "pressure_in" :: JSONTypes.Parser Scientific.Scientific)
precip_mm <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "precip_mm" :: JSONTypes.Parser Scientific.Scientific)
precip_in <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "precip_in" :: JSONTypes.Parser Scientific.Scientific)
humidity <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (current .: "humidity" :: JSONTypes.Parser Scientific.Scientific)
cloud <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (current .: "cloud" :: JSONTypes.Parser Scientific.Scientific)
uv <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "uv" :: JSONTypes.Parser Scientific.Scientific)
gust_kph <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "gust_kph" :: JSONTypes.Parser Scientific.Scientific)
gust_mph <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (current .: "gust_mph" :: JSONTypes.Parser Scientific.Scientific)
condition <- current .: "condition" :: JSONTypes.Parser JSON.Object
condition_text <- fmap Text.unpack (condition .: "text" :: JSONTypes.Parser Text.Text)
mAqi <- if aqi then do
air_quality <- current .: "air_quality" :: JSONTypes.Parser JSON.Object
co <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (air_quality .: "co" :: JSONTypes.Parser Scientific.Scientific)
o3 <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (air_quality .: "o3" :: JSONTypes.Parser Scientific.Scientific)
no2 <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (air_quality .: "no2" :: JSONTypes.Parser Scientific.Scientific)
so2 <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (air_quality .: "so2" :: JSONTypes.Parser Scientific.Scientific)
pm2_5 <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (air_quality .: "pm2_5" :: JSONTypes.Parser Scientific.Scientific)
pm10 <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (air_quality .: "pm10" :: JSONTypes.Parser Scientific.Scientific)
us_epa_index <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (air_quality .: "us-epa-index" :: JSONTypes.Parser Scientific.Scientific)
gb_defra_index <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (air_quality .: "gb-defra-index" :: JSONTypes.Parser Scientific.Scientific)
return (Just (FormatWeatherAirQuality co o3 no2 so2 pm2_5 pm10 us_epa_index gb_defra_index))
else
return Nothing
return (formatWeatherCurrent termWidth pp name region country last_updated temp_c temp_f feelslike_c feelslike_f condition_text wind_kph wind_mph wind_degree wind_dir pressure_mb pressure_in precip_mm precip_in humidity cloud uv gust_kph gust_mph mAqi)
"forecast" -> flip JSONTypes.parseEither result $ \obj -> do
location <- obj .: "location" :: JSONTypes.Parser JSON.Object
name <- fmap Text.unpack (location .: "name" :: JSONTypes.Parser Text.Text)
region <- fmap Text.unpack (location .: "region" :: JSONTypes.Parser Text.Text)
country <- fmap Text.unpack (location .: "country" :: JSONTypes.Parser Text.Text)
mAlerts <- if alerts then do
alerts <- obj .: "alerts" :: JSONTypes.Parser JSON.Object
alert <- alerts .: "alert" :: JSONTypes.Parser JSON.Array
result <- foldr (\one accu -> case one of
JSON.Object obj -> do
headline <- fmap Text.unpack (obj .: "headline" :: JSONTypes.Parser Text.Text)
msgtype <- fmap Text.unpack (obj .: "msgtype" :: JSONTypes.Parser Text.Text)
severity <- fmap Text.unpack (obj .: "severity" :: JSONTypes.Parser Text.Text)
urgency <- fmap Text.unpack (obj .: "urgency" :: JSONTypes.Parser Text.Text)
areas <- fmap Text.unpack (obj .: "areas" :: JSONTypes.Parser Text.Text)
category <- fmap Text.unpack (obj .: "category" :: JSONTypes.Parser Text.Text)
certainty <- fmap Text.unpack (obj .: "certainty" :: JSONTypes.Parser Text.Text)
event <- fmap Text.unpack (obj .: "event" :: JSONTypes.Parser Text.Text)
note <- fmap Text.unpack (obj .: "note" :: JSONTypes.Parser Text.Text)
effective <- fmap Text.unpack (obj .: "effective" :: JSONTypes.Parser Text.Text)
expires <- fmap Text.unpack (obj .: "expires" :: JSONTypes.Parser Text.Text)
desc <- fmap Text.unpack (obj .: "desc" :: JSONTypes.Parser Text.Text)
instruction <- fmap Text.unpack (obj .: "instruction" :: JSONTypes.Parser Text.Text)
fmap ((:) (FormatWeatherAlert headline msgtype severity urgency areas category certainty event note effective expires desc instruction)) accu
_ -> accu) (return []) alert
return (Just result)
else
return Nothing
forecast <- obj .: "forecast" :: JSONTypes.Parser JSON.Object
forecastday <- forecast .: "forecastday" :: JSONTypes.Parser JSON.Array
days <- foldr (\one accu -> case one of
JSON.Object obj -> do
date <- fmap Text.unpack (obj .: "date" :: JSONTypes.Parser Text.Text)
day <- obj .: "day" :: JSONTypes.Parser JSON.Object
maxtemp_c <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "maxtemp_c" :: JSONTypes.Parser Scientific.Scientific)
maxtemp_f <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "maxtemp_f" :: JSONTypes.Parser Scientific.Scientific)
mintemp_c <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "mintemp_c" :: JSONTypes.Parser Scientific.Scientific)
mintemp_f <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "mintemp_f" :: JSONTypes.Parser Scientific.Scientific)
avgtemp_c <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "avgtemp_c" :: JSONTypes.Parser Scientific.Scientific)
avgtemp_f <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "avgtemp_f" :: JSONTypes.Parser Scientific.Scientific)
maxwind_kph <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "maxwind_kph" :: JSONTypes.Parser Scientific.Scientific)
maxwind_mph <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "maxwind_mph" :: JSONTypes.Parser Scientific.Scientific)
totalprecip_mm <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "totalprecip_mm" :: JSONTypes.Parser Scientific.Scientific)
totalprecip_in <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "totalprecip_in" :: JSONTypes.Parser Scientific.Scientific)
avgvis_km <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "avgvis_km" :: JSONTypes.Parser Scientific.Scientific)
avgvis_miles <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "avgvis_miles" :: JSONTypes.Parser Scientific.Scientific)
avghumidity <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (day .: "avghumidity" :: JSONTypes.Parser Scientific.Scientific)
uv <- fmap (Scientific.toRealFloat :: Scientific.Scientific -> Double) (day .: "uv" :: JSONTypes.Parser Scientific.Scientific)
daily_chance_of_rain <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (day .: "daily_chance_of_rain" :: JSONTypes.Parser Scientific.Scientific)
daily_chance_of_snow <- fmap ((fromMaybe 0) . (Scientific.toBoundedInteger :: Scientific.Scientific -> Maybe Word)) (day .: "daily_chance_of_snow" :: JSONTypes.Parser Scientific.Scientific)
condition <- day .: "condition" :: JSONTypes.Parser JSON.Object
condition_text <- fmap Text.unpack (condition .: "text" :: JSONTypes.Parser Text.Text)
astro <- obj .: "astro" :: JSONTypes.Parser JSON.Object
sunrise <- fmap Text.unpack (astro .: "sunrise" :: JSONTypes.Parser Text.Text)
sunset <- fmap Text.unpack (astro .: "sunset" :: JSONTypes.Parser Text.Text)
moonrise <- fmap Text.unpack (astro .: "moonrise" :: JSONTypes.Parser Text.Text)
moonset <- fmap Text.unpack (astro .: "moonset" :: JSONTypes.Parser Text.Text)
moon_phase <- fmap Text.unpack (astro .: "moon_phase" :: JSONTypes.Parser Text.Text)
moon_illumination <- fmap ((read :: String -> Word) . Text.unpack) (astro .: "moon_illumination" :: JSONTypes.Parser Text.Text)
fmap ((:) (date, FormatWeatherDay maxtemp_c maxtemp_f mintemp_c mintemp_f avgtemp_c avgtemp_f maxwind_kph maxwind_mph totalprecip_mm totalprecip_in avgvis_km avgvis_miles avghumidity condition_text uv daily_chance_of_rain daily_chance_of_snow, FormatWeatherAstro sunrise sunset moonrise moonset moon_phase moon_illumination)) accu
_ -> accu) (return []) forecastday
return (formatWeatherForecast termWidth pp name region country mAlerts days)
"astronomy" -> flip JSONTypes.parseEither result $ \obj -> do
location <- obj .: "location" :: JSONTypes.Parser JSON.Object
name <- fmap Text.unpack (location .: "name" :: JSONTypes.Parser Text.Text)
region <- fmap Text.unpack (location .: "region" :: JSONTypes.Parser Text.Text)
country <- fmap Text.unpack (location .: "country" :: JSONTypes.Parser Text.Text)
astronomy <- obj .: "astronomy" :: JSONTypes.Parser JSON.Object
astro <- astronomy .: "astro" :: JSONTypes.Parser JSON.Object
sunrise <- fmap Text.unpack (astro .: "sunrise" :: JSONTypes.Parser Text.Text)
sunset <- fmap Text.unpack (astro .: "sunset" :: JSONTypes.Parser Text.Text)
moonrise <- fmap Text.unpack (astro .: "moonrise" :: JSONTypes.Parser Text.Text)
moonset <- fmap Text.unpack (astro .: "moonset" :: JSONTypes.Parser Text.Text)
moon_phase <- fmap Text.unpack (astro .: "moon_phase" :: JSONTypes.Parser Text.Text)
moon_illumination <- fmap ((read :: String -> Word) . Text.unpack) (astro .: "moon_illumination" :: JSONTypes.Parser Text.Text)
return (formatWeatherAstronomy termWidth pp name region country (FormatWeatherAstro sunrise sunset moonrise moonset moon_phase moon_illumination))
_ -> error ("Unknown information type mode: " ++ mode)
Right output
#else
parseWeatherDataJSON _ _ _ _ _ _ = Left (__ "Support for JSON was disabled during compilation! Try another format.")
#endif
-- Parses the given XML weather data and returns the appropriate output according to the given options.
parseWeatherDataXML :: Word -> Bool -> String -> Bool -> Bool -> BSL.ByteString -> Either String String
#ifndef FLAG_NOXML
parseWeatherDataXML termWidth pp mode aqi alerts input = do
let root = fromMaybe (error "No valid root element found.") (find (\element -> case XMLTypes.elName element of
XMLTypes.QName "root" Nothing Nothing -> True
_ -> False) (XMLProc.onlyElems (XMLInput.parseXML (TextEncLazy.decodeUtf8 input))))
let getTextField = \parent name converter def errstr -> fromMaybe def (converter (XMLTypes.cdData (fromMaybe (XMLTypes.CData XMLTypes.CDataText "" Nothing) (find (\cdata -> case XMLTypes.cdVerbatim cdata of
XMLTypes.CDataText -> True
_ -> False) (XMLProc.onlyText (XMLTypes.elContent (fromMaybe (error errstr) (XMLProc.findElement (XMLTypes.QName name Nothing Nothing) parent))))))))
output <- case mode of
"timezone" -> do
let location = fromMaybe (error "No root/location element found.") (XMLProc.findElement (XMLTypes.QName "location" Nothing Nothing) root)
let name = getTextField location "name" (Just . id) "" "No root/location/name element found."
let region = getTextField location "region" (Just . id) "" "No root/location/region element found."
let country = getTextField location "country" (Just . id) "" "No root/location/country element found."
let lat = getTextField location "lat" (readMaybe :: String -> Maybe Double) 0.0 "No root/location/lat element found."
let lon = getTextField location "lon" (readMaybe :: String -> Maybe Double) 0.0 "No root/location/lon element found."
let tz_id = getTextField location "tz_id" (Just . id) "" "No root/location/tz_id element found."
let localtime = getTextField location "localtime" (Just . id) "" "No root/location/localtime element found."
return (formatWeatherTimeZone termWidth pp name region country (lat, lon) tz_id localtime)
"current" -> do
let location = fromMaybe (error "No root/location element found.") (XMLProc.findElement (XMLTypes.QName "location" Nothing Nothing) root)
let name = getTextField location "name" (Just . id) "" "No root/location/name element found."
let region = getTextField location "region" (Just . id) "" "No root/location/region element found."
let country = getTextField location "country" (Just . id) "" "No root/location/country element found."
let current = fromMaybe (error "No root/current element found.") (XMLProc.findElement (XMLTypes.QName "current" Nothing Nothing) root)
let last_updated = getTextField current "last_updated" (Just . id) "" "No root/current/last_updated element found."
let temp_c = getTextField current "temp_c" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/temp_c element found."
let temp_f = getTextField current "temp_f" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/temp_f element found."
let feelslike_c = getTextField current "feelslike_c" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/feelslike_c element found."
let feelslike_f = getTextField current "feelslike_f" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/feelslike_f element found."
let wind_kph = getTextField current "wind_kph" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/wind_kph element found."
let wind_mph = getTextField current "wind_mph" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/wind_mph element found."
let wind_degree = getTextField current "wind_degree" (readMaybe :: String -> Maybe Word) 0 "No root/current/wind_degree element found."
let wind_dir = getTextField current "wind_dir" (Just . id) "" "No root/current/wind_dir element found."
let pressure_mb = getTextField current "pressure_mb" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/pressure_mb element found."
let pressure_in = getTextField current "pressure_in" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/pressure_in element found."
let precip_mm = getTextField current "precip_mm" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/precip_mm element found."
let precip_in = getTextField current "precip_in" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/precip_in element found."
let humidity = getTextField current "humidity" (readMaybe :: String -> Maybe Word) 0 "No root/current/humidity element found."
let cloud = getTextField current "cloud" (readMaybe :: String -> Maybe Word) 0 "No root/current/cloud element found."
let uv = getTextField current "uv" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/uv element found."
let gust_kph = getTextField current "gust_kph" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/gust_kph element found."
let gust_mph = getTextField current "gust_mph" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/gust_mph element found."
let condition = fromMaybe (error "No root/current/condition element found.") (XMLProc.findElement (XMLTypes.QName "condition" Nothing Nothing) current)
let condition_text = getTextField condition "text" (Just . id) "" "No root/current/condition/text element found."
mAqi <- if aqi then do
let air_quality = fromMaybe (error "No root/current/air_quality element found.") (XMLProc.findElement (XMLTypes.QName "air_quality" Nothing Nothing) current)
let co = getTextField air_quality "co" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/air_quality/co element found."
let o3 = getTextField air_quality "o3" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/air_quality/o3 element found."
let no2 = getTextField air_quality "no2" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/air_quality/no2 element found."
let so2 = getTextField air_quality "so2" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/air_quality/so2 element found."
let pm2_5 = getTextField air_quality "pm2_5" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/air_quality/pm2_5 element found."
let pm10 = getTextField air_quality "pm10" (readMaybe :: String -> Maybe Double) 0.0 "No root/current/air_quality/pm10 element found."
let us_epa_index = getTextField air_quality "us-epa-index" (readMaybe :: String -> Maybe Word) 0 "No root/current/air_quality/us-epa-index element found."
let gb_defra_index = getTextField air_quality "gb-defra-index" (readMaybe :: String -> Maybe Word) 0 "No root/current/air_quality/gb-defra-index element found."
return (Just (FormatWeatherAirQuality co o3 no2 so2 pm2_5 pm10 us_epa_index gb_defra_index))
else
return Nothing
return (formatWeatherCurrent termWidth pp name region country last_updated temp_c temp_f feelslike_c feelslike_f condition_text wind_kph wind_mph wind_degree wind_dir pressure_mb pressure_in precip_mm precip_in humidity cloud uv gust_kph gust_mph mAqi)
"forecast" -> do
let location = fromMaybe (error "No root/location element found.") (XMLProc.findElement (XMLTypes.QName "location" Nothing Nothing) root)
let name = getTextField location "name" (Just . id) "" "No root/location/name element found."
let region = getTextField location "region" (Just . id) "" "No root/location/region element found."
let country = getTextField location "country" (Just . id) "" "No root/location/country element found."
mAlerts <- if alerts then do
let alerts = XMLProc.onlyElems (XMLTypes.elContent (fromMaybe (error "No root/alerts element found.") (XMLProc.findElement (XMLTypes.QName "alerts" Nothing Nothing) root)))
let result = foldr (\alert accu -> case alert of
XMLTypes.Element (XMLTypes.QName "alert" Nothing Nothing) _ _ _ -> do
let headline = getTextField alert "headline" (Just . id) "" "No root/alerts/alert/headline alert found."
let msgtype = getTextField alert "msgtype" (Just . id) "" "No root/alerts/alert/msgtype alert found."
let severity = getTextField alert "severity" (Just . id) "" "No root/alerts/alert/severity alert found."
let urgency = getTextField alert "urgency" (Just . id) "" "No root/alerts/alert/urgency alert found."
let areas = getTextField alert "areas" (Just . id) "" "No root/alerts/alert/areas alert found."
let category = getTextField alert "category" (Just . id) "" "No root/alerts/alert/category alert found."
let certainty = getTextField alert "certainty" (Just . id) "" "No root/alerts/alert/certainty alert found."
let event = getTextField alert "event" (Just . id) "" "No root/alerts/alert/event alert found."
let note = getTextField alert "note" (Just . id) "" "No root/alerts/alert/note alert found."
let effective = getTextField alert "effective" (Just . id) "" "No root/alerts/alert/effective alert found."
let expires = getTextField alert "expires" (Just . id) "" "No root/alerts/alert/expires alert found."
let desc = getTextField alert "desc" (Just . id) "" "No root/alerts/alert/desc alert found."
let instruction = getTextField alert "instruction" (Just . id) "" "No root/alerts/alert/instruction alert found."
(FormatWeatherAlert headline msgtype severity urgency areas category certainty event note effective expires desc instruction) : accu
_ -> accu) [] alerts
return (Just result)
else
return Nothing
let forecast = XMLProc.onlyElems (XMLTypes.elContent (fromMaybe (error "No root/forecast element found.") (XMLProc.findElement (XMLTypes.QName "forecast" Nothing Nothing) root)))
let days = foldr (\one accu -> case one of
XMLTypes.Element (XMLTypes.QName "forecastday" Nothing Nothing) _ _ _ -> do
let date = getTextField one "date" (Just . id) "" "No root/forecast/forecastday/date element found."
let day = fromMaybe (error "No root/forecast/forecastday/day element found.") (XMLProc.findElement (XMLTypes.QName "day" Nothing Nothing) one)
let maxtemp_c = getTextField day "maxtemp_c" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/maxtemp_c element found."
let maxtemp_f = getTextField day "maxtemp_f" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/maxtemp_f element found."
let mintemp_c = getTextField day "mintemp_c" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/mintemp_c element found."
let mintemp_f = getTextField day "mintemp_f" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/mintemp_f element found."
let avgtemp_c = getTextField day "avgtemp_c" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/avgtemp_c element found."
let avgtemp_f = getTextField day "avgtemp_f" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/avgtemp_f element found."
let maxwind_kph = getTextField day "maxwind_kph" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/maxwind_kph element found."
let maxwind_mph = getTextField day "maxwind_mph" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/maxwind_mph element found."
let totalprecip_mm = getTextField day "totalprecip_mm" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/totalprecip_mm element found."
let totalprecip_in = getTextField day "totalprecip_in" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/totalprecip_in element found."
let avgvis_km = getTextField day "avgvis_km" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/avgvis_km element found."
let avgvis_miles = getTextField day "avgvis_miles" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/avgvis_miles element found."
let avghumidity = getTextField day "avghumidity" (readMaybe :: String -> Maybe Word) 0 "No root/forecast/forecastday/day/avghumidity element found."
let uv = getTextField day "uv" (readMaybe :: String -> Maybe Double) 0.0 "No root/forecast/forecastday/day/uv element found."
let daily_chance_of_rain = getTextField day "daily_chance_of_rain" (readMaybe :: String -> Maybe Word) 0 "No root/forecast/forecastday/day/daily_chance_of_rain element found."
let daily_chance_of_snow = getTextField day "daily_chance_of_snow" (readMaybe :: String -> Maybe Word) 0 "No root/forecast/forecastday/day/daily_chance_of_snow element found."
let condition = fromMaybe (error "No root/forecast/forecastday/day/condition element found.") (XMLProc.findElement (XMLTypes.QName "condition" Nothing Nothing) day)
let condition_text = getTextField condition "text" (Just . id) "" "No root/forecast/forecastday/day/condition/text element found."
let astro = fromMaybe (error "No root/forecast/forecastday/astro element found.") (XMLProc.findElement (XMLTypes.QName "astro" Nothing Nothing) one)
let sunrise = getTextField astro "sunrise" (Just . id) "" "No root/forecast/forecastday/astro/sunrise element found."
let sunset = getTextField astro "sunset" (Just . id) "" "No root/forecast/forecastday/astro/sunset element found."
let moonrise = getTextField astro "moonrise" (Just . id) "" "No root/forecast/forecastday/astro/moonrise element found."
let moonset = getTextField astro "moonset" (Just . id) "" "No root/forecast/forecastday/astro/moonset element found."
let moon_phase = getTextField astro "moon_phase" (Just . id) "" "No root/forecast/forecastday/astro/moon_phase element found."
let moon_illumination = getTextField astro "moon_illumination" (readMaybe :: String -> Maybe Word) 0 "No root/forecast/forecastday/astro/moon_illumination element found."
(date, FormatWeatherDay maxtemp_c maxtemp_f mintemp_c mintemp_f avgtemp_c avgtemp_f maxwind_kph maxwind_mph totalprecip_mm totalprecip_in avgvis_km avgvis_miles avghumidity condition_text uv daily_chance_of_rain daily_chance_of_snow, FormatWeatherAstro sunrise sunset moonrise moonset moon_phase moon_illumination) : accu
_ -> accu) [] forecast
return (formatWeatherForecast termWidth pp name region country mAlerts days)
"astronomy" -> do
let location = fromMaybe (error "No root/location element found.") (XMLProc.findElement (XMLTypes.QName "location" Nothing Nothing) root)
let name = getTextField location "name" (Just . id) "" "No root/location/name element found."
let region = getTextField location "region" (Just . id) "" "No root/location/region element found."
let country = getTextField location "country" (Just . id) "" "No root/location/country element found."
let astronomy = fromMaybe (error "No root/astronomy element found.") (XMLProc.findElement (XMLTypes.QName "astronomy" Nothing Nothing) root)
let astro = fromMaybe (error "No root/astronomy/astro element found.") (XMLProc.findElement (XMLTypes.QName "astro" Nothing Nothing) astronomy)
let sunrise = getTextField astro "sunrise" (Just . id) "" "No root/astronomy/astro/sunrise element found."
let sunset = getTextField astro "sunset" (Just . id) "" "No root/astronomy/astro/sunset element found."
let moonrise = getTextField astro "moonrise" (Just . id) "" "No root/astronomy/astro/moonrise element found."
let moonset = getTextField astro "moonset" (Just . id) "" "No root/astronomy/astro/moonset element found."
let moon_phase = getTextField astro "moon_phase" (Just . id) "" "No root/astronomy/astro/moon_phase element found."
let moon_illumination = getTextField astro "moon_illumination" (readMaybe :: String -> Maybe Word) 0 "No root/astronomy/astro/moon_illumination element found."
return (formatWeatherAstronomy termWidth pp name region country (FormatWeatherAstro sunrise sunset moonrise moonset moon_phase moon_illumination))
_ -> error ("Unknown information type mode: " ++ mode)
Right output
#else
parseWeatherDataXML _ _ _ _ _ _ = Left (__ "Support for XML was disabled during compilation! Try another format.")
#endif
-- Does the main work of the program:
-- Retrieves the data file from the server, prints it unparsed if Unsafe flag is set,
-- or parses it and displays it using the appropriate formatting if not.
mainWork :: String -> [Flag] -> IO ()
mainWork key flags = do
-- Get location to query the data for.
mLocation <- getLocation
case mLocation of
Just location -> do
-- Extract values from value-taking flags.
let mode = foldr (\flag res -> case flag of
Mode str -> str
_ -> res) "current" flags
let days = foldr (\flag res -> case flag of
Days str -> read str :: Int
_ -> res) 3 flags
currentDate <- getCurrentDate >>= (\date -> case date of (year, month, day) -> return (printf "%d-%d-%d" year month day))
let date = foldr (\flag res -> case flag of
Date str -> str
_ -> res) currentDate flags
let format = foldr (\flag res -> case flag of
Format str -> str
_ -> res) "json" flags
manager <- HTTPClient.newManager (if elem Unsafe flags then HTTPClient.defaultManagerSettings else HTTPClientTLS.tlsManagerSettings)
language <- getLanguage
request <- HTTPClient.parseRequest (getRequestURL mode format key language location (elem AirQuality flags) (elem Alerts flags) days date (notElem Unsafe flags))
mResponse <- try (HTTPClient.httpLbs request manager) :: IO (Either HTTPClient.HttpException (HTTPClient.Response BSL.ByteString))
case mResponse of
Left _ -> do
hPutStrLn stderr (__ "Error getting the server response.")
exitWith (ExitFailure EXIT_CODE_NETWORK_ERROR)
Right response -> do
let status = HTTPClient.responseStatus response
let code = HTTPStatus.statusCode status
if code < 200 || code > 299 then do
hPutStrLn stderr (printf (__ "HTTP error %d: %s") code (BSC8.unpack (HTTPStatus.statusMessage status)))
exitWith (ExitFailure EXIT_CODE_NETWORK_ERROR)
else if elem GetFile flags then
BSC8.putStrLn (BSL.toStrict (HTTPClient.responseBody response))
else do
mTermSize <- TermSize.size :: IO (Maybe (TermSize.Window Word))
case mTermSize of
Nothing -> do
hPutStrLn stderr (__ "Failed to get terminal size.")
exitWith (ExitFailure EXIT_CODE_SYSTEM_ERROR)
Just termSize ->
if (TermSize.width termSize) < minTermWidth then do
hPutStrLn stderr (printf (__ "Terminal width is lower than required: %u < %u") (TermSize.width termSize) minTermWidth)
exitWith (ExitFailure EXIT_CODE_SYSTEM_ERROR)
else do
let eWeatherData = (case format of
"json" -> parseWeatherDataJSON
"xml" -> parseWeatherDataXML
_ -> error ("Unknown data format: " ++ format)) (TermSize.width termSize) (notElem NoPP flags) mode (elem AirQuality flags) (elem Alerts flags) (HTTPClient.responseBody response)
case eWeatherData of
Left err -> do
hPutStrLn stderr (printf (__ "Failed to parse retrieved weather data: %s") err)
exitWith (ExitFailure EXIT_CODE_PARSING_ERROR)
Right weatherData -> putStrLn weatherData
Nothing -> fail (__ "Location to query the data for unspecified; make sure that WEATHERHS_LOCATION is set and non-empty.")
return ()
main :: IO ()
main = do
-- Setup I18N.
_ <- setLocale LC_ALL (Just "")
_ <- bindTextDomain __MESSAGE_CATALOG_DOMAIN__ (Just __MESSAGE_CATALOG_DIR__)
_ <- textDomain (Just __MESSAGE_CATALOG_DOMAIN__)
-- Parse command-line arguments.
args <- getArgs >>= parseArgs
-- Handle exit-now command-line options.
if elem Help args then
helpMenu >>= putStrLn
else if elem Version args then
putStrLn (showVersion Paths.version)
else do
#ifdef FLAG_ENCRYPTION
-- Attempt to get the encrypted API key first and try to decrypt it.
-- In case that there is no encrypted API key attempt to get the unencrypted API key.
-- On success retrieve and print weather and related data.
mKeyEnc <- getAPIKeyEnc
case mKeyEnc of
Left err -> fail (__ (printf "Failed to decrypt API key: %s" (case err of
Crypto.Gpgme.NoData -> (__ "No data to decrypt.")
Crypto.Gpgme.Failed -> (__ "Not a valid cipher.")
Crypto.Gpgme.BadPass -> (__ "Wrong passphrase.")
Crypto.Gpgme.Unknown errGpgme -> (Crypto.Gpgme.errorString errGpgme) ++ " " ++ (printf (__ "(source: %s)") (Crypto.Gpgme.sourceString errGpgme)))))
Right Nothing -> do
mKey <- getAPIKey
case mKey of
Nothing -> fail (__ "No API key found; make sure that either WEATHERHS_API_KEY_ENC or WEATHERHS_API_KEY is set and non-empty.")
Just key -> mainWork key args
Right (Just key) -> mainWork key args
#else
-- Attempt to get the API key.
-- On success retrieve and print weather and related data.
mKey <- getAPIKey
case mKey of
Nothing -> fail (__ "No API key found; make sure that WEATHERHS_API_KEY is set and non-empty.")
Just key -> mainWork key args
#endif