{- - 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 . -} {-# 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