{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
module VtUtils.HTTP
( httpContentTypeJSON
, httpRequestPath
, httpRequestBodyText
, HTTPRequestBodyJSONException(..)
, httpRequestBodyJSON
, httpRequestHeaders
, httpRequestHeadersMap
, 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))
httpContentTypeJSON :: Header
httpContentTypeJSON = ("Content-Type", "application/json")
httpRequestPath :: Request -> Text
httpRequestPath = textDecodeUtf8 . rawPathInfo
httpRequestBodyText :: Request -> IO Text
httpRequestBodyText req = (textDecodeUtf8 . ByteStringLazy.toStrict) <$> strictRequestBody req
data HTTPRequestBodyJSONException = HTTPRequestBodyJSONException
{ requestBody :: ByteString
, message :: Text
}
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) <> "]"
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
httpRequestHeaders :: Request -> Vector (Text, Text)
httpRequestHeaders req = Vector.fromList (uncase <$> requestHeaders req)
httpRequestHeadersMap :: Request -> HashMap Text Text
httpRequestHeadersMap req = HashMap.fromList (uncase <$> requestHeaders req)
data HTTPResponseBodyException = HTTPResponseBodyException
{ threshold :: Int
, read :: Int
, label :: Text
, responsePart :: ByteString
}
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) <> "]"
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
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
data HTTPResponseBodyJSONException = HTTPResponseBodyJSONException
{ response :: ByteString
, label :: Text
, message :: Text
}
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) <> "]"
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
httpResponseHeaders :: Response a -> Vector (Text, Text)
httpResponseHeaders resp = Vector.fromList (uncase <$> responseHeaders resp)
httpResponseHeadersMap :: Response a -> HashMap Text Text
httpResponseHeadersMap resp = HashMap.fromList (uncase <$> responseHeaders resp)