IB016 HW04

Weather.hs

{- |
Fourth assignment for IB016, semester spring 2017, 20 points.

== Obtaining weather information from <http://openweathermap.org openweathermap.org>

This time, your task is to implement downloading and processing of weather data
from <http://openweathermap.org>.

You are given a partially implemented module (some data type definitions, 'main',
argument parsing and dispatch functions). Do not change any of the code
or data types provided, unless specifically allowed.

OpenWeatherMap provides a JSON API for weather forecast (it also provides XML,
but we believe JSON is simpler to process). Your task is as follows:

* Download a JSON response from server based on value of 'Query' (parsed
from the commandline arguments). That is, implement 'createUrl' and 'downloadResults'.

* Process the JSON data in functions 'weatherNow', 'weatherDetailed',
'weatherDaily' and 'warmestDay'.

* Implement the display function 'prettyPrint'.

Documentation of OpenWeatherMap's relevant API can be found at
<http://openweathermap.org/current> and
<http://openweathermap.org/forecast5>\/<http://openweathermap.org/forecast16>.
Both the query format and the reply JSON format are described in
the documentation. Beware that JSON examples on OpenWeatherMap are not always
properly indented. Furthermore, as a simplification, you can expect that
the weather field (a JSON array in response) contains at least one entry and
you can use the data from the first entry and ignore all other entries.

You can expect that OpenWeatherMap will always provide a valid JSON in responses.
If you detect an invalid JSON at any time, you can kill the program using 'exitFailure'
from @System.Exit@ (it should not die with an exception such as a lookup error).
However, the obtained JSON may not contain all the required
information (e.g. if you query an invalid city). For this reason, all
JSON-parsing functions return a type wrapped with @'WithError' a@
(working similar to @Either String a@). You should emit an
appropriate error message into 'Err' if any JSON field is missing (non-failed
values are wrapped in 'OK').
Omitting the error handling will be penalised by at most 5 points
(so it's still worth attempting the assignment, even if you are
uncomfortable working with these wrapped values).
In such case, just wrap all the results into 'OK' to match the type declaration.

== Modules and packages

You will have to use some library for working with HTTP and JSON. We recommend
packages <https://hackage.haskell.org/package/HTTP-4000.3.6 HTTP> (module
@Network.HTTP@) and <https://hackage.haskell.org/package/hjson hjson> (module
@Text.HJson@) which provide a simple and easy-to-use interface.
If you use @Network.HTTP@, you will also need to decode UTF-8
manually. For that, you can use <https://hackage.haskell.org/package/utf8-string utf8-string>
(module @Codec.Binary.UTF8.String@, function 'decodeString').

However, you can use any package/module you want. In that case you may
need to replace 'Json' type in all functions using it with an appropriate type
(this change is allowed). Furthermore, 'Rational' data type is used to
represent numeric values in weather forecast -- this is to simplify parsing from
Json, as @hjson@ uses it to represent numbers. If you use a different library, you
are allowed to replace 'Rational' with a different type capable of representing
fractional values.

As before, all used packages (except base) have to be noted in the header
of this file next to your name and UID.
To get the list of used packages on linux conveniently, you can use the following
command (copy from the source code, not from the generated HTML).

@
ghc <your-file>.hs -n -hide-all-packages 2>&1 | grep package | sed 's/^[^‘]*‘\([^’@]*\).*/\1/' | sort | uniq
@

=== Tips and tricks

*   OpenWeatherMap's API requires an API key (free registration required).
    Nevertheless, there is an API key included in the assignment ('appid'),
    so that you don't have to register. Please don't do too frequent queries
    (there is a limit of 60 queries with this key per minute).
    Remember that you all share this key.
*   Try using monads and\/or applicative to deal with @Either@/@WithError@
    values.
*   As was advised in assignment 3, don't underestimate the process of
    functional decomposition. Think of the logical units of the solution first,
    then their type and only then head to the implementation.

=== Examples


@
$ ./Weather now --city=Brno
city:        Brno (lat = 49.2, lon = 16.61)
weather:     few clouds
temperature: 2.1 °C
pressure:    993.8 hPa

$ ./Weather detailed --city=Brno
city:        Brno (lat = 49.195, lon = 16.608)
date:        05-04-2015 15:00
weather:     scattered clouds
temperature: 2.1 °C
pressure:    992.4 hPa
date:        05-04-2015 18:00
weather:     few clouds
temperature: -0.2 °C
pressure:    993.8 hPa
date:        05-04-2015 21:00
weather:     light rain
temperature: -2.3 °C
pressure:    994.1 hPa
date:        06-04-2015 00:00
weather:     sky is clear
temperature: -3.5 °C
pressure:    993.7 hPa
date:        06-04-2015 03:00
weather:     sky is clear
temperature: -3.9 °C
pressure:    993.7 hPa
{- ... -}

./Weather daily --city=Brno --count=2
city:        Brno (lat = 49.195, lon = 16.608)
date:        05-04-2015 10:00
weather:     scattered clouds
temperature: 2.1 °C
pressure:    992.4 hPa
date:        06-04-2015 10:00
weather:     light snow
temperature: 3.2 °C
pressure:    995.0 hPa

$ ./Weather warmest-day --city=Brno
city:        Brno (lat = 49.195, lon = 16.608)
date:        11-04-2015 10:00
weather:     sky is clear
temperature: 16.3 °C
pressure:    1006.6 hPa

$ ./Weather warmest-day --city=Brno --count=16
city:        Brno (lat = 49.195, lon = 16.608)
date:        20-04-2015 10:00
weather:     light rain
temperature: 19.8 °C
pressure:    988.2 hPa

$ ./Weather now --city="Žďár nad Sázavou"
city:        Žďár nad Sázavou (lat = 49.56, lon = 15.94)
weather:     scattered clouds
temperature: 0.0 °C
pressure:    977.4 hPa

$ ./Weather now --coord=49.56,15.94
city:        Zdar nad Sazavou (lat = 49.56, lon = 15.94)
weather:     scattered clouds
temperature: 0.0 °C
pressure:    977.4 hPa
@
 -}

-- Name: David Bielik
-- UID: 433629
-- Used packages: base

module Main (
    -- * Executable entry
      main
    -- * Pre-defined types and functions
    , URL
    , Query (..)
    , QueryType (..)
    , Location (..)
    , parseQuery
    , PrettyPrint (..)
    , disp, disp'
    , City (..)
    , Weather (..)
    , Date (..)
    , valid
    , usage
    , WithError (..)
    , handle
    , processData
    -- * Required functions and types
    , createUrl
    , downloadResults
    , prettyPrint
    , weatherNow
    , weatherDetailed
    , weatherDaily
    , warmestDay
    ) where

-- for timestamp conversion
import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
import Data.Time.Format ( defaultTimeLocale, formatTime )

import Control.Monad ( unless )
import Codec.Binary.UTF8.String ( decodeString )

import Data.List ( intercalate )
import Data.Monoid ( Last (..), (<>) )
import Data.Maybe ( fromMaybe )
import qualified Data.Map as Map ( lookup )

import Network.HTTP.Base ( urlEncode )
import Network.HTTP ( getRequest, simpleHTTP, getResponseBody )

import System.Environment ( getArgs )
import System.Exit ( exitFailure )
import System.IO ( stderr, hPutStrLn )

import Text.HJson ( Json (..), fromString )
import Text.Read ( readMaybe )

-- | Type alias for clarity of types
type URL = String

-- | City location specification
data Location = Name { locationName :: String }
              | Coord { locLat :: Double, locLon :: Double }
              | NoLocation
              deriving ( Eq, Show, Read )

instance Monoid Location where
    mempty = NoLocation
    x `mappend` NoLocation = x
    _ `mappend` y          = y

-- | Type of query
data QueryType = Now | Detailed | Daily | WarmestDay | NotSet
               deriving ( Eq, Show, Read )

instance Monoid QueryType where
    mempty = NotSet
    x `mappend` NotSet = x
    _ `mappend` y      = y

-- | Type representing commandline parameters
data Query = Query { queryType :: QueryType
                   , queryCity :: Location
                   , queryCount :: Last Int
                   }
           deriving ( Eq, Show, Read )

instance Monoid Query where
    mempty = Query mempty mempty mempty
    x `mappend` y = Query { queryType = queryType x `mappend` queryType y
                          , queryCity = queryCity x `mappend` queryCity y
                          , queryCount = queryCount x `mappend` queryCount y
                          }

-- | Parses command line arguments into 'Query' type
parseQuery :: [String] -> Query
parseQuery [] = mempty
parseQuery (qt:args) = mempty { queryType = qType } `mappend` mconcat (map fromArg args)
  where
    qType = case qt of
        "now"         -> Now
        "daily"       -> Daily
        "detailed"    -> Detailed
        "warmest-day" -> WarmestDay
        _             -> NotSet

    fromArg :: String -> Query
    fromArg arg = fromMaybe mempty $ do
        (k, '=':v) <- Just $ span (/= '=') arg -- if pattern fails we get Nothing from this do block
        case k of
            "--city"  -> Just $ mempty { queryCity = Name v }
            "--coord" -> do
                (slat, ',':slon) <- Just $ span (/= ',') v
                lat <- readMaybe slat
                lon <- readMaybe slon
                Just $ mempty { queryCity = Coord { locLat = lat, locLon = lon } }
            "--count" -> do
                cnt <- readMaybe v
                Just $ mempty { queryCount = Last (Just cnt) }
            _ -> Nothing

-- | A type class to facilitate pretty printing of tabular information.
class PrettyPrint a where
    -- | Format object into list of key-value pairs of string representation.
    -- This is later used by 'prettyPrint' to format data for output.
    ppKeyVal :: a -> [(String, String)]

instance (PrettyPrint a, PrettyPrint b) => PrettyPrint (a, b) where
    ppKeyVal (x, y) = ppKeyVal x ++ ppKeyVal y

instance (PrettyPrint a, PrettyPrint b, PrettyPrint c) => PrettyPrint (a, b, c) where
    ppKeyVal (x, y, z) = ppKeyVal x ++ ppKeyVal y ++ ppKeyVal z

instance PrettyPrint a => PrettyPrint [a] where
    ppKeyVal = concatMap ppKeyVal

-- | Should format data from key-value representation into pretty human-readable
-- tabular form. That is, into the form @key: value@, with value indented
-- such that all values start at the same offset. Key-value pairs should be obtained by
-- 'ppKeyVal' function from 'PrettyPrint' class.
--
-- >>> putStrLn $ prettyPrint (Date 0)
-- date: 01-01-1970 00:00
--
-- >>>  putStrLn $ prettyPrint (Date 0, Weather 0 0 "test")
-- date:        01-01-1970 00:00
-- weather:     test
-- temperature: -273.2 °C
-- pressure:    0.0 hPa
--
prettyPrint :: PrettyPrint a => a -> String
prettyPrint x = intercalate "\n" $ fmap prettyPHelp keyVals
    where
        keyVals = ppKeyVal x
        maxLen = foldl (\acc y -> (max acc . length . fst) y) 0 keyVals
        spaces a = replicate (maxLen - length a + 1) ' '
        prettyPHelp (a, b) = a <> ":" <> spaces a <> b

-- | Show rational number rounded to the given precision
--
-- >>> disp 1 1.007
-- "1.0"
--
-- >>> disp 2 1.007
-- "1.01"
--
-- >>> disp 3 2.2
-- "2.2"
disp :: Int -> Rational -> String
disp n = show . (/ 10^n) . (fromInteger :: Integer -> Double) . round . (* 10^n)

-- | Shortcut for @'disp' 1@.
disp' :: Rational -> String
disp' = disp 1

-- | Information about city and its location.
data City = City { cityName :: String
                 , cityLat  :: Rational
                 , cityLon  :: Rational
                 } deriving ( Eq, Show, Read )

instance PrettyPrint City where
    ppKeyVal c = [ ("city", cityName c ++ " (lat = " ++
                            disp 3 (cityLat c) ++ ", lon = " ++
                            disp 3 (cityLon c) ++ ")") ]

-- | Information about weather.
data Weather = Weather { temperature :: Rational
                       , pressure    :: Rational
                       , description :: String
                       } deriving ( Eq, Show, Read )

instance PrettyPrint Weather where
    ppKeyVal w = [ ("weather", description w)
                 , ("temperature", disp' (temperature w - 273.15) ++ " °C")
                 , ("pressure", disp' (pressure w) ++ " hPa")
                 ]

-- | Unix time wrapped so that it can be made instance of 'PrettyPrint'.
newtype Date = Date { timestamp :: Rational }
               deriving ( Eq, Show, Read )

instance PrettyPrint Date where
    ppKeyVal (Date d) = [ ("date", formatTime defaultTimeLocale "%d-%m-%Y %R" unixTime) ]
      where
        unixTime = posixSecondsToUTCTime (realToFrac d)

-- | API key for OpenWeatherMap
appid :: String
appid = "&APPID=affd607e92f996e508125f001725f296"
-- | Base API URL for OpenWeatherMap
baseURL :: String
baseURL = "http://api.openweathermap.org/data/2.5/"

-- | Create URL from a given query. That is, add all parameters necessary
-- to obtain the weather data. API key is in 'appid'.
--
-- It must properly encode all parameters (e.g. using functions from
-- @Network.HTTP.Base@).
--
-- >>> createUrl $ mempty {queryType = Now, queryCity = Name "Brno" }
-- "http://api.openweathermap.org/data/2.5/weather?q=Brno&APPID=…"
--
-- >>> createUrl $ mempty {queryType = Detailed, queryCity = Name "Brno" }
-- "http://api.openweathermap.org/data/2.5/forecast?q=Brno&APPID=…"
--
-- >>> createUrl $ mempty {queryType = Daily, queryCity = Name "Brno" }
-- "http://api.openweathermap.org/data/2.5/forecast/daily?q=Brno&APPID=…"
--
-- >>> createUrl $ mempty {queryType = WarmestDay, queryCity = Name "Brno", queryCount = Last (Just 5) }
-- "http://api.openweathermap.org/data/2.5/forecast/daily?q=Brno&cnt=5&APPID=…"
--
-- >>> createUrl $ mempty {queryType = Now, queryCity = Name "Žďár nad Sázavou" }
-- "http://api.openweathermap.org/data/2.5/weather?q=%C5%BD%C4%8F%C3%A1r%20nad%20S%C3%A1zavou&APPID=…"

weatherParameter :: QueryType -> String
weatherParameter Now    = "weather"
weatherParameter q      = "forecast" <> weatherPAppendix q
    where
        weatherPAppendix Daily      = "/daily"
        weatherPAppendix WarmestDay = weatherPAppendix Daily
        weatherPAppendix _          = ""

locationParameter :: Location -> String
locationParameter (Name nm) = "?q=" <> urlEncode nm
locationParameter (Coord lat lon) = "?lat=" <> show lat <> "&lon=" <> show lon
locationParameter _ = ""

createUrl :: Query -> URL
createUrl q = baseURL <> weatherP <> locationP <> countP <> appid
    where
        weatherP = (weatherParameter . queryType) q
        locationP = (locationParameter . queryCity) q
        countP = case (getLast . queryCount) q of Just l    -> "&cnt=" <> show l
                                                  Nothing   -> ""

-- | Download the requested URL and parse it to JSON.
--
-- It is recommended to use the functionality of @Network.HTTP@ (download)
-- and @Text.HJson@ (JSON representation and parsing). If you use an HTTP
-- library which does not handle unicode (such as @Network.HTTP@), you should
-- decode responses manually using 'decodeString' from @Codec.Binary.UTF8.String@
-- before feeding it to the JSON parser.
downloadResults :: URL -> IO Json
downloadResults url = getReqResult >>= getResponseBody >>= handleResp
    where
        getReqResult = (simpleHTTP . getRequest) url
        handleResp r = case (fromString . decodeString) r of
                                        Left err   -> (fail . show) err
                                        Right json -> return json

-- | Check validity of 'Query'.
valid :: Query -> Bool
valid q = queryType q /= NotSet && queryCity q /= NoLocation

-- | Program usage\/help string.
usage :: String
usage = unlines [
    "Usage: Weather {now|detailed|daily|warmest-day}",
    "               {--city=CITY | --coord=LATITUDE,LONGITUDE} [--count=CNT]",
    "",
    "    --count  applies only to daily and warmest-day and specifies number of days"
    ]

-- | A type similar to @Either String a@ but restricted only to string messages.
-- This allows us to implement 'fail' in 'Monad' more meaningfully and
-- take advantage of it.
data WithError a = Err String
                 | OK a
                 deriving ( Eq, Ord, Show, Read )

instance Functor WithError where
    fmap f (OK a)  = OK (f a)
    fmap _ (Err e) = Err e

instance Applicative WithError where
    pure = OK
    Err e <*> _ = Err e
    OK f  <*> x = fmap f x

instance Monad WithError where
    return = OK
    Err e >>= _ = Err e
    OK x  >>= f = f x
    fail = Err

-- | Handle errors in 'WithError'. If the value "has failed", passes the error
-- message to the handler function and returns its return value.
handle :: (String -> a) -> WithError a -> a
handle handler act = case act of
                        OK x  -> x
                        Err e -> handler e

-- Helper functions to deal with J____ data types
jsonToStr :: Json -> WithError String
jsonToStr (JString s) = OK s
jsonToStr y           = Err $ "Expected JString - recieved " <> show y

jsonToRat :: Json -> WithError Rational
jsonToRat (JNumber x) = OK x
jsonToRat y           = Err $ "Expected JNumber - recieved " <> show y

jsonToArr :: Json -> WithError [Json]
jsonToArr (JArray x)    = OK x
jsonToArr y             = Err $ "Expected JArray - recieved " <> show y

-- Gets a JObject recursively by specifying its path.
getJsonObj :: Json -> [String] -> WithError Json
getJsonObj json = foldl getHelper (OK json)
    where
        getHelper :: WithError Json -> String -> WithError Json
        getHelper (OK (JObject o)) s = case Map.lookup s o of
                                        Just a  -> OK a
                                        Nothing -> Err s
        getHelper x _                = Err $ errStr (show x)
        errStr = (<>) "Couldn't find key: "

-- Creates a weather description from specified JSON.
createWeatherDescription :: Json -> WithError String
createWeatherDescription json = do
    arr <- getJsonObj json ["weather"] >>= jsonToArr
    getJsonObj (head arr) ["description"] >>= jsonToStr

-- Creates a Weather type with specified paths and json.
baseWeather :: [String] -> [String] -> Json -> WithError Weather
baseWeather path1 path2 json = do
     let h = getJsonObj json
     temp <- h path1 >>= jsonToRat
     pres <- h path2 >>= jsonToRat
     desc <- createWeatherDescription json
     return $ Weather temp pres desc

-- Creates a Weather type from specified JSON.
createWeatherFromJson :: Json -> WithError Weather
createWeatherFromJson = baseWeather ["main", "temp"] ["main", "pressure"]

-- Creates a City type from specified JSON.
createCityFromJson :: Json -> WithError City
createCityFromJson json = do
    let h = getJsonObj json
    name <- h ["name"] >>= jsonToStr
    lat <- h ["coord", "lat"] >>= jsonToRat
    lon <- h ["coord", "lon"] >>= jsonToRat
    return $ City name lat lon

-- | Parse current weather from JSON,
-- see <http://openweathermap.org/current> for format description.
weatherNow :: Json -> WithError (City, Weather)
weatherNow json = do
    city <- createCityFromJson json
    weather <- createWeatherFromJson json
    return (city, weather)

-- JSON to Weather func
type WeatherHandler = (Json -> WithError Weather)

-- Creates
baseDateWeather :: WeatherHandler -> Json -> WithError (Date, Weather)
baseDateWeather weatherF json = do
    date <- getJsonObj json ["dt"] >>= jsonToRat >>= OK . Date
    weather <- weatherF json
    return (date, weather)

-- Base function for creating detailed forecast from JSON.
-- takes a WeatherHandler argument = creates Weather by JSON type.
baseDetailedWeather ::  WeatherHandler ->
                        Json ->
                        WithError (City, [(Date, Weather)])
baseDetailedWeather wthrH json = do
    let h = getJsonObj json
    city <- h ["city"] >>= createCityFromJson
    weatherList <- h ["list"] >>= jsonToArr >>= mapM (baseDateWeather wthrH)
    return (city, weatherList)

-- | Parse detailed (5-day/3 hour) forecast from JSON,
-- see <http://openweathermap.org/forecast5> for format specification.
weatherDetailed :: Json -> WithError (City, [(Date, Weather)])
weatherDetailed = baseDetailedWeather createWeatherFromJson

-- | Parse daily (16-day) forecast from JSON,
-- see <http://openweathermap.org/forecast16> for format specification.
weatherDaily :: Json -> WithError (City, [(Date, Weather)])
weatherDaily = baseDetailedWeather $ baseWeather ["temp", "day"] ["pressure"]


-- | Parse daily forecast and get warmest day from it.
warmestDay :: Json -> WithError (City, Date, Weather)
warmestDay json = do
    days <- weatherDaily json
    let warmestD = foldl1 compareTemps (snd days)
    return (fst days, fst warmestD, snd warmestD)
    where
        temp = temperature . snd
        compareTemps x y
            | temp x > temp y   = x
            | otherwise         = y


-- | Dispatch parsing functions based on 'QueryType' and handle errors.
processData :: QueryType -> Json -> String
processData qtype json = handle handler $ case qtype of
    Now        -> prettyPrint <$> weatherNow json
    Detailed   -> prettyPrint <$> weatherDetailed json
    Daily      -> prettyPrint <$> weatherDaily json
    WarmestDay -> prettyPrint <$> warmestDay json
    _          -> fail "invalid query"
  where
    handler msg = unlines [ "Error processing data, sorry", msg]

main :: IO ()
main = do
    query <- parseQuery <$> getArgs
    unless (valid query) $ do
        hPutStrLn stderr "Invalid options"
        hPutStrLn stderr usage
        exitFailure
    weather <- downloadResults (createUrl query)
    putStrLn $ processData (queryType query) weather