{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
module VtUtils.HTTP
( httpContentTypeJSON
, httpRequestPath
, httpRequestBodyText
, httpRequestBodyJSON
, httpRequestHeaders
, httpRequestHeadersMap
, httpResponseBody
, httpResponseBodyText
, httpResponseBodyJSON
, httpResponseHeaders
, httpResponseHeadersMap
) where
import Prelude (Either(..), Int, IO, String, (.), ($), (>=), (<$>), fromIntegral, error, return)
import Control.Monad (when)
import Data.Aeson (FromJSON, eitherDecode)
import Data.CaseInsensitive (original)
import Data.HashMap.Strict (HashMap)
import Data.Monoid ((<>))
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8)
import Data.Vector (Vector)
import Network.HTTP.Client (BodyReader, Response, brReadSome, responseBody, responseHeaders)
import Network.HTTP.Types (Header)
import Network.Wai (Request, lazyRequestBody, rawPathInfo, requestHeaders, strictRequestBody)
import qualified Data.ByteString.Lazy as ByteStringLazy
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Vector as Vector
import VtUtils.Text
uncase :: Header -> (Text, Text)
uncase (name, val) = ((decodeUtf8 . original) name, (decodeUtf8 val))
httpContentTypeJSON :: Header
httpContentTypeJSON = ("Content-Type", "application/json")
httpRequestPath :: Request -> Text
httpRequestPath = decodeUtf8 . rawPathInfo
httpRequestBodyText :: Request -> IO Text
httpRequestBodyText req = (decodeUtf8 . ByteStringLazy.toStrict) <$> strictRequestBody req
httpRequestBodyJSON :: forall a . FromJSON a => Request -> IO a
httpRequestBodyJSON req = do
bs <- lazyRequestBody req
case eitherDecode bs :: Either String a of
Left err -> error . unpack $
"JSON decoding error,"
<> " 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)
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)) $ error . unpack $
"HTTP response size threshold exceeded,"
<> " threshold: [" <> (textShow threshold) <> "],"
<> " read: [" <> (textShow read) <> "],"
<> " label: [" <> label <> "]"
return lbs
httpResponseBodyText :: Text -> Response BodyReader -> Int -> IO Text
httpResponseBodyText label resp threshold = do
lbs <- httpResponseBody label resp threshold
let tx = decodeUtf8 (ByteStringLazy.toStrict lbs)
return tx
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 -> error . unpack $
"JSON decoding error,"
<> " json: [" <> ((decodeUtf8 . ByteStringLazy.toStrict) (ByteStringLazy.take 1024 bs)) <> "],"
<> " message: [" <> pack err <> "],"
<> " label: [" <> label <> "]"
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)