--
-- Copyright 2018, akashche at redhat.com
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
--
-- |
-- HTTP utilities for server (WAI) and client
--

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}

module VtUtils.HTTP
    ( httpContentTypeJSON
    , httpRequestPath
    , httpRequestBodyText
    , HTTPRequestBodyJSONException(..)
    , httpRequestBodyJSON
    , httpRequestHeaders
    , httpRequestHeadersMap
    -- client
    , HTTPResponseBodyException(..)
    , httpResponseBody
    , httpResponseBodyText
    , HTTPResponseBodyJSONException(..)
    , httpResponseBodyJSON
    , httpResponseHeaders
    , httpResponseHeadersMap
    ) where

import Prelude (Either(..), Int, IO, Show(..), String, (.), ($), (>=), (<$>), fromIntegral, return)
import Control.Exception (Exception(..), throwIO)
import Control.Monad (when)
import Data.Aeson (FromJSON, eitherDecode)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as ByteStringLazy
import Data.CaseInsensitive (original)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import qualified Data.Text as Text
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Network.HTTP.Client (BodyReader, Response, brReadSome, responseBody, responseHeaders)
import Network.HTTP.Types (Header)
import Network.Wai (Request, lazyRequestBody, rawPathInfo, requestHeaders, strictRequestBody)

import VtUtils.Error (errorShow)
import VtUtils.Text (textDecodeUtf8, textShow)

uncase :: Header -> (Text, Text)
uncase (name, val) = ((textDecodeUtf8 . original) name, (textDecodeUtf8 val))

-- | @Content-Type@ header for @application/json@ type
--
httpContentTypeJSON :: Header
httpContentTypeJSON = ("Content-Type", "application/json")

-- | URL path string of the specified HTTP request
--
-- Arguments:
--
--    * @req :: Request@: HTTP request
--
-- Return value: URL path string
--
httpRequestPath :: Request -> Text
httpRequestPath = textDecodeUtf8 . rawPathInfo

-- | Reads a body of the specified HTTP request as a @Text@ string
--
-- Arguments:
--
--    * @req :: Request@: HTTP request
--
-- Return value: Request body as a @Text@ string
--
httpRequestBodyText :: Request -> IO Text
httpRequestBodyText req = (textDecodeUtf8 . ByteStringLazy.toStrict) <$> strictRequestBody req

-- | Exception for `httpRequestBodyJSON` function
--
data HTTPRequestBodyJSONException = HTTPRequestBodyJSONException
    { requestBody :: ByteString -- ^ Request body containing invalid JSON
    , message :: Text -- ^ JSON parsing error message
    }
instance Exception HTTPRequestBodyJSONException
instance Show HTTPRequestBodyJSONException where
    show e@(HTTPRequestBodyJSONException {requestBody, message}) = errorShow e $
               "JSON decoding error,"
            <> " message: [" <> message <> "],"
            <> " request body: [" <> (Text.take 1024 $ textDecodeUtf8 requestBody) <> "]"

-- | Reads a body of the specified HTTP request and parses it as a JSON value
--
-- Data type should be specified with a type annotation:
--
-- Example:
--
-- >
-- > dt <- httpRequestBodyJSON req :: IO Foo
-- >
--
-- Data must be an instance of [FromJSON](https://hackage.haskell.org/package/aeson-1.4.2.0/docs/Data-Aeson.html#t:FromJSON)
--
-- Throws an exception if request body doesn't contain valid JSON.
--
-- Arguments:
--
--    * @req :: Request@: HTTP request
--
-- Return value: Request body parsed as a JSON value
--
httpRequestBodyJSON :: forall a . FromJSON a => Request -> IO a
httpRequestBodyJSON req = do
    bs <- lazyRequestBody req
    case eitherDecode bs :: Either String a of
        Left err -> throwIO $ HTTPRequestBodyJSONException
                { requestBody = ByteStringLazy.toStrict bs
                , message = pack err
                }
        Right res -> return res

-- | Headers of the specified HTTP request as a @Vector@ of @(name, value)@ pairs
--
-- Arguments:
--
--    * @req :: Request@: HTTP request
--
-- Return value: Request headers as a @Vector@ of @(name, value)@ pairs
--
httpRequestHeaders :: Request -> Vector (Text, Text)
httpRequestHeaders req = Vector.fromList (uncase <$> requestHeaders req)

-- | Headers of the specified HTTP request as a @name -> value@ map
--
-- Arguments:
--
--    * @req :: Request@: HTTP request
--
-- Return value: Request headers as a @name -> value@ map
--
httpRequestHeadersMap :: Request -> HashMap Text Text
httpRequestHeadersMap req = HashMap.fromList (uncase <$> requestHeaders req)

-- | Exception for `httpRequestBodyJSON` function
--
data HTTPResponseBodyException = HTTPResponseBodyException
    { threshold :: Int -- ^ Max allowed bytes to read
    , read :: Int -- ^ Bytes actually read
    , label :: Text -- ^ Caller-supplied label
    , responsePart :: ByteString -- ^ Part of the response that was read
    }
instance Exception HTTPResponseBodyException
instance Show HTTPResponseBodyException where
    show e@(HTTPResponseBodyException {threshold, read, label, responsePart}) = errorShow e $
               "HTTP response size threshold exceeded,"
            <> " threshold: [" <> (textShow threshold) <> "],"
            <> " read: [" <> (textShow read) <> "],"
            <> " label: [" <> label <> "],"
            <> " response part: [" <> (Text.take 1024 $ textDecodeUtf8 responsePart) <> "]"

-- | Read a body of HTTP response as a lazy @ByteString@
--
-- Throws an exception if specified threshold is exceeded.
--
-- Arguments:
--
--    * @label :: Text@: Label used for error reporting on overly-large responses
--    * @resp :: Response BodyReader@: HTTP response
--    * @threshold :: Int@ Max response body length in bytes
--
-- Return value: Response body as a lazy @ByteString@
--
httpResponseBody :: Text -> Response BodyReader -> Int -> IO ByteStringLazy.ByteString
httpResponseBody label resp threshold = do
    let reader = responseBody resp
    lbs <- brReadSome reader threshold
    let read = (ByteStringLazy.length lbs)
    when (read >= (fromIntegral threshold)) $ throwIO $ HTTPResponseBodyException
            { threshold = threshold
            , read = fromIntegral read
            , label = label
            , responsePart = ByteStringLazy.toStrict lbs
            }
    return lbs

-- | Read a body of HTTP response as a @Text@ string
--
-- Arguments:
--
--    * @label :: Text@: Label used for error reporting on overly-large responses
--    * @resp :: Response BodyReader@: HTTP response
--    * @threshold :: Int@ Max response body length in bytes
--
-- Return value: Response body as a @Text@ string
--
httpResponseBodyText :: Text -> Response BodyReader -> Int -> IO Text
httpResponseBodyText label resp threshold = do
    lbs <- httpResponseBody label resp threshold
    let tx = textDecodeUtf8 (ByteStringLazy.toStrict lbs)
    return tx

-- | Exception for `httpResponseBodyJSON` function
--
data HTTPResponseBodyJSONException = HTTPResponseBodyJSONException
    { response :: ByteString -- ^ Response body containing invalid JSON
    , label :: Text -- ^ Caller-supplied label
    , message :: Text -- ^ JSON parsing error message
    }
instance Exception HTTPResponseBodyJSONException
instance Show HTTPResponseBodyJSONException where
    show e@(HTTPResponseBodyJSONException {response, label, message}) = errorShow e $
               "JSON decoding error,"
            <> " message: [" <> message <> "],"
            <> " label: [" <> label <> "],"
            <> " response: [" <> (Text.take 1024 $ textDecodeUtf8 response) <> "]"

-- | Read a body of HTTP response as a JSON value
--
-- Data type should be specified with a type annotation:
--
-- Example:
--
-- >
-- > dt <- httpResponseBodyJSON label resp 1024 :: IO Foo
-- >
--
-- Data must be an instance of [FromJSON](https://hackage.haskell.org/package/aeson-1.4.2.0/docs/Data-Aeson.html#t:FromJSON)
--
-- Throws an exception if response body doesn't contain valid JSON.
--
-- Arguments:
--
--    * @label :: Text@: Label used for error reporting on overly-large responses
--    * @resp :: Response BodyReader@: HTTP response
--    * @threshold :: Int@ Max response body length in bytes
--
-- Return value: Response body as a JSON value
--
httpResponseBodyJSON :: forall a . FromJSON a => Text -> Response BodyReader -> Int -> IO a
httpResponseBodyJSON label resp threshold = do
    bs <- httpResponseBody label resp threshold
    case eitherDecode bs :: Either String a of
        Left err -> throwIO $ HTTPResponseBodyJSONException
                { message = pack err
                , label = label
                , response = ByteStringLazy.toStrict bs
                }
        Right res -> return res

-- | Headers of the specified HTTP response as a @Vector@ of @(name, value)@ pairs
--
-- Arguments:
--
--    * @req :: Response@: HTTP request
--
-- Return value: Response headers as a @Vector@ of @(name, value)@ pairs
--
httpResponseHeaders :: Response a -> Vector (Text, Text)
httpResponseHeaders resp = Vector.fromList (uncase <$> responseHeaders resp)

-- | Headers of the specified HTTP response as a @name -> value@ map
--
-- Arguments:
--
--    * @req :: Response@: HTTP request
--
-- Return value: Response headers as a @name -> value@ map
--
httpResponseHeadersMap :: Response a -> HashMap Text Text
httpResponseHeadersMap resp = HashMap.fromList (uncase <$> responseHeaders resp)