Commandline utility to get weather from openweathermap.org written in haskell

Weather.hs

{- |
This is the fourth assignment for IB016, semester spring 2015.
Name: Adam Melkus
UID: 374010

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

This time your task is to implement download and processing of weather data
from <http://openweathermap.org>. Following it partially filled program, which
already contains some data type definitions, 'main', argument parsing, and
dispatch functions to run your implementation. You should not change any of
already defined data types and functions, unless it is specifically allowed.

OpenWeatherMap provides JSON API for weather forecast (it also provides XML,
but we believe JSON is simpler to process), your task is:

* Download JSON data from serwer based on value of 'Query' (which was parsed
from commandline arguments). That is implement 'createUrl' and
'downloadResults'.

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

* Implement helper function 'prettyPrint'.

You will have to use some library for HTTP and for JSON, we recommend following
packages and modules @http@ (module @Network.HTTP@) and @hjson@ (module
@Text.HJson@) which provide simple and easy to use interface. Both of these
modules can be installed with @cabal@ (they are not part of standard
distribution). If you use @http@ module you will also need to decode UTF-8
manually, you can use @utf-string@ (module @Codec.Binary.UTF8.String@, function
'decodeString') for that. You can also use any other module which implements
given functionality, in that case you might need to replace 'Json' type in all
functions using it with 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 another library you are allowed to replace Rational with another
type cabable of representing fractional values.

Documentation of OpenWeatherMap's current and forecast API can be found at
<http://openweathermap.org/current> and <http://openweathermap.org/forecast>
respectively, JSON reply format is also linked from appropriate function
documentation. Beware that JSON examples on OpenWeatherMap are not always
properly indented. Furthermore, as a simplification, you can expect that
weather field (which is 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 you will obtain a valid JSON from OpenWeatherMap.
If you detect an invalid JSON, you can kill the program using 'exitFailure'
from @System.Exit@ .
However, you should expect that the obtained JSON does not contain all required
information (which might happen if you query an invalid city). For this reason all
JSON-parsing functions you should implement are returning type wrapped with
'WithError a' which is an alias to 'Either String String'. You should emit an
appropriate error message into 'Left' if any JSON field is missing. However, if
you don't feel like it, you can just omit error handling at all which will be
penalised with 5 points (in this case you should just wrap the result into
'Right' to match type declaration).

=== 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
@
 -}

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

-- for timestamp conversion
import           Data.Time.Clock.POSIX
import           Data.Time.Format
import           System.Locale

import           Control.Applicative
import           Control.Monad

import           Data.Map                 (Map)
import           Data.Maybe
import           Data.Monoid

import qualified Data.Map                 as M

import           Numeric


import           System.Environment
import           System.Exit
import           System.IO

import           Network.HTTP

import           Text.HJson
import           Text.Read                (readMaybe)

import           Codec.Binary.UTF8.String (decodeString)

type URL = String

-- | City location specification
data Location = Name { locName :: String }
              | Coord { lat :: Double, lon :: 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
                   , city      :: Location
                   , count     :: 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
                          , city = city x `mappend` city y
                          , count = count x `mappend` count y
                          }

-- | Parses commandline 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 fail we get Nothing from this do block
        case k of
            "--city"  -> Just $ mempty { city = Name v }
            "--coord" -> do
                (slat, ',':slon) <- Just $ span (/= ',') v
                lat <- readMaybe slat
                lon <- readMaybe slon
                Just $ mempty { city = Coord { lat = lat, lon = lon } }
            "--count" -> do
                cnt <- readMaybe v
                return $ mempty { count = Last (Just cnt) }
            _ -> Nothing

-- | A type class to facilitate pretty printing of tablular 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 which can have key-value representation into well
-- readable tabular form. That is all the form key: value, with value indented
-- such that all values start at 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 v = process (ppKeyVal v)
    where
        tabs x | length x <= 4 = ":\t\t"
               | otherwise = ":\t"
        process [] = ""
        process (x:xs) = fst x ++ tabs (fst x) ++ snd x ++ "\n" ++ process xs

-- | Show rational number rounded with 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) . fromIntegral . 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)

-- | Create URL from given query, that is add in all parameters necessary to
-- obtain weather data.
--
-- It must properly encode all parameters for example using functions from
-- @Network.HTTP.Base@.
--
-- >>> createUrl $ mempty {queryType = Now, city = Name "Brno" }
-- "http://api.openweathermap.org/data/2.5/weather?q=Brno"
--
-- >>>  createUrl $ mempty {queryType = Detailed, city = Name "Brno" }
-- "http://api.openweathermap.org/data/2.5/forecast?q=Brno"
--
-- >>> createUrl $ mempty {queryType = Daily, city = Name "Brno" }
-- "http://api.openweathermap.org/data/2.5/forecast/daily?q=Brno"
--
-- >>> createUrl $ mempty {queryType = WarmestDay, city = Name "Brno", count = Last (Just 5) }
-- "http://api.openweathermap.org/data/2.5/forecast/daily?q=Brno&cnt=5"
--
-- >>> createUrl $ mempty {queryType = Now, city = Name "¦Ô r nad S zavou" }
-- "http://api.openweathermap.org/data/2.5/weather?q=%C5%BD%C4%8F%C3%A1r%20nad%20S%C3%A1zavou"
createUrl :: Query -> URL
createUrl query = baseUrl ++ typeP ++ dailyP ++ urlEncode cityP ++ countP
  where
    baseUrl = "http://api.openweathermap.org/data/2.5/"
    typeP   = if queryType query == Now then "weather" else "forecast"
    cityP   = case city query of    Name a     -> "?q=" ++ a
                                    Coord lat lon -> "?lat=" ++ show lat ++ "&lon=" ++ show lon
    dailyP  = if queryType query == Daily || queryType query == WarmestDay then "/daily" else ""
    countP  = case (getLast . count) query of Just v    -> "&cnt=" ++ show v
                                              Nothing   -> ""

-- | Download requested URL and parse JSON out of it.
--
-- It is recommended to use functionality of @Network.HTTP@ for download
-- and @Text.HJson@ for JSON representation and parsing. If you use HTTP
-- library which does not handle unicode (such as @Network.HTTP@), you should
-- decode response manualy using 'decodeString' from @Codec.Binary.UTF8.String@.
downloadResults :: URL -> IO Json
downloadResults url = do
  response <- (simpleHTTP . getRequest) url >>= getResponseBody
  let decodeResult = (fromString . decodeString)  response
  case decodeResult of Left  s      -> (error .show) s
                       Right jsonr  -> return jsonr

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

-- | Program usage.
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"
    ]

-- | Alias to 'Either' to simplify types.
type WithError a = Either String a

-- | Parse current weather from JSON,
-- see <http://openweathermap.org/weather-data#current> for format description.
weatherNow :: Json -> WithError (City, Weather)
weatherNow json = handleError json jsonIncomplete (cityRes, weatherRes)
    where
        jsonIncomplete  = not . jsonContains ["name", "weather description", "main pressure", "main temp", "coord lat", "coord lon"]
        cityRes         = extractCity json
        weatherRes      = extractWeather json


-- | Parse detailed (5-day/3 hour) forecast from JSON,
-- see <http://openweathermap.org/weather-data#5days> for format specification.
weatherDetailed :: Json -> WithError (City, [(Date, Weather)])
weatherDetailed json = weatherCommon json ["city coord lat", "city coord lon", "city name", "list dt", "list weather description", "list main temp", "list main pressure"]


-- | Parse daily (16-day) forecast from JSON,
-- see <http://openweathermap.org/weather-data#16days> for format specification.
-- Note: you should use temperature from @day@ temperature entry.
weatherDaily :: Json -> WithError (City, [(Date, Weather)])
weatherDaily json = weatherCommon json ["city coord lat", "city coord lon", "city name", "list dt", "list weather description", "list temp day", "list pressure"]



weatherCommon :: Json -> [String] -> WithError (City, [(Date, Weather)])
weatherCommon json jsonFields = handleError json jsonIncomplete (cityRes, dwList)
    where
        jsonIncomplete      = not . jsonContains jsonFields
        cityRes             = extractCity $ jsonGetElem "city" json
        generateDateWeather = map extractDateWeather
        dwList              = case jsonGetElem "list" json of (JArray a) -> generateDateWeather a

-- | Parse daily forecast and get warmest day from it.
warmestDay :: Json -> WithError (City, Date, Weather)
warmestDay json = handleError json jsonIncomplete (cityRes, fst dwList, snd dwList)
    where
       jsonIncomplete   = not . jsonContains ["city coord lat", "city coord lon", "city name", "list dt", "list weather description", "list temp day", "list pressure"]
       cityRes          = extractCity $ jsonGetElem "city" json
       max' (d1, w1) (d2, w2)   = if temperature w1 > temperature w2 then (d1, w1) else (d2, w2)
       generateDateWeather [x]  = extractDateWeather x
       generateDateWeather (w:ws) = max' (extractDateWeather w) (generateDateWeather ws)
       dwList           = case jsonGetElem "list" json of (JArray a) -> generateDateWeather a

-- | Composes tuple of date and weather information from Json
-- Doesn't do any kind of error checking, valid Json on input is assumed
extractDateWeather :: Json -> (Date, Weather)
extractDateWeather j = (extractDate, extractWeather j)
    where extractDate = Date {timestamp = toNumber $ jsonGetElem "dt" j}

-- | Extracts city information from given Json
-- Doesn't do any kind of error checking, valid Json on input is assumed
extractCity :: Json -> City
extractCity json = City {cityName = cName, cityLat = cLat, cityLon = cLon}
    where
        cName   = toString' $ jsonGetElem "name"      json
        cLat    = toNumber  $ jsonGetElem "coord lat" json
        cLon    = toNumber  $ jsonGetElem "coord lon" json

-- | Extracts wather information from given Json
-- Doesn't do any kind of error checking, valid Json on input is assumed.
-- It can handle 2 different configurations of weather information provided by forecast and daily forecast
extractWeather :: Json -> Weather
extractWeather json = Weather {temperature=wTemp, pressure=wPressure, description=wDescription}
    where
        wDescription = case jsonGetElem "weather" json of (JArray a) -> toString' $ jsonGetElem "description" (head a)
                                                          _          -> "No description"
        cont        = if jsonContains ["main"]      json then "main "    else ""
        temp        = if jsonContains ["temp day"]  json then "temp day" else "temp"
        wPressure   = toNumber $ jsonGetElem (cont++"pressure") json
        wTemp       = toNumber $ jsonGetElem (cont++temp)       json

-- | Extracts value from Json on given path
-- Doesn't do any kind of error checking, valid Json on input is assumed.
-- It can extract values only from map. Can't do extraction from array
-- Path is given in format "root_element nested_element final_elemet" this would extract final_element from the JSON
jsonGetElem :: String -> Json -> Json
jsonGetElem path = extractElem (words path)
    where
        extractElem [x] json    = case json of (JObject map) -> map M.! x
                                               a -> a
        extractElem (x:xs) json = case json of (JObject map) -> extractElem xs (map M.! x)
                                               a -> a
-- | Checks if specified elements are in the JSON
-- Path is given in format "root_element nested_element final_elemet" this would check if final_element is in the json JSON
-- Checks even inside of arrays
jsonContains :: [String] -> Json -> Bool
jsonContains [] _ = True
jsonContains (x:xs) json = checkPath (words x) json && jsonContains xs json
    where
        checkPath (y:ys) json = case json of (JObject map)   -> M.member y map && (null ys || checkPath ys (map M.! y))
                                             (JArray (j:js)) -> checkPath (y:ys) j || (not (null js) && checkPath (y:ys) (JArray js))
                                             _ -> False

-- | Converts some JSON values to number
toNumber :: Json -> Rational
toNumber (JNumber num) = num
toNumber (JString num) = fst . head $ readSigned readFloat num

-- | Converts some JSON values to string
toString' :: Json -> String
toString' (JString str) = str
toString' (JNumber num) = show num

-- | Checks for valid JSON and error and outputs either error message or given result
handleError :: Json -> (Json -> Bool) -> a -> Either String a
handleError json f result = case handleInvalidResponse json of
                                    Just a -> Left a
                                    Nothing -> if f json then Left "Error parsing JSON, some element was missing"
                                                         else Right result

-- | Checks if the response code from web service returns error message from server if code wasn't OK
handleInvalidResponse :: Json -> Maybe String
handleInvalidResponse json = if resultCode /= 200 then Just errorMessage else Nothing
    where 
        resultCode   = toNumber  $ jsonGetElem "cod"     json
        errorMessage = toString' $ jsonGetElem "message" json


-- | Dispatch parsing functionas based on 'QueryType' and handle errors.
processData :: QueryType -> Json -> String
processData qtype json = either handler id $ case qtype of
    Now        -> prettyPrint <$> weatherNow json
    Detailed   -> prettyPrint <$> weatherDetailed json
    Daily      -> prettyPrint <$> weatherDaily json
    WarmestDay -> prettyPrint <$> warmestDay json
    _          -> Left "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
    --(error . createUrl) query
    weather <- downloadResults (createUrl query)
    putStrLn $ processData (queryType query) weather