module Hasura.HTTP
  ( wreqOptions,
    HttpException (..),
    hdrsToText,
    textToHdrs,
    addDefaultHeaders,
    defaultHeaders,
    HttpResponse (..),
    addHttpResponseHeaders,
    getHTTPExceptionStatus,
    serializeHTTPExceptionMessage,
    ShowHeadersAndEnvVarInfo (..),
    serializeHTTPExceptionWithErrorMessage,
    serializeHTTPExceptionMessageForDebugging,
    encodeHTTPRequestJSON,
    ShowErrorInfo (..),
    getHttpExceptionJson,
    serializeServantClientErrorMessage,
    serializeServantClientErrorMessageForDebugging,
  )
where

import Control.Exception (Exception (..), fromException)
import Control.Lens hiding ((.=))
import Data.Aeson qualified as J
import Data.Aeson.KeyMap qualified as KM
import Data.CaseInsensitive (mk, original)
import Data.HashMap.Strict qualified as HashMap
import Data.Text qualified as T
import Data.Text.Conversions (UTF8 (..), convertText)
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Hasura.Prelude
import Hasura.Server.Utils (redactSensitiveHeader)
import Hasura.Server.Version (currentVersion)
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Client.Restricted qualified as Restricted
import Network.HTTP.Media qualified as HTTP
import Network.HTTP.Types qualified as HTTP
import Network.Wreq qualified as Wreq
import Servant.Client qualified as Servant

hdrsToText :: [HTTP.Header] -> [(Text, Text)]
hdrsToText :: [Header] -> [(Text, Text)]
hdrsToText [Header]
hdrs =
  [ (ByteString -> Text
bsToTxt (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
hdrName, ByteString -> Text
bsToTxt ByteString
hdrVal)
    | (HeaderName
hdrName, ByteString
hdrVal) <- [Header]
hdrs
  ]

textToHdrs :: [(Text, Text)] -> [HTTP.Header]
textToHdrs :: [(Text, Text)] -> [Header]
textToHdrs [(Text, Text)]
hdrs =
  [ (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (Text -> ByteString
txtToBs Text
hdrName), Text -> ByteString
TE.encodeUtf8 Text
hdrVal)
    | (Text
hdrName, Text
hdrVal) <- [(Text, Text)]
hdrs
  ]

wreqOptions :: HTTP.Manager -> [HTTP.Header] -> Wreq.Options
wreqOptions :: Manager -> [Header] -> Options
wreqOptions Manager
manager [Header]
hdrs =
  Options
Wreq.defaults
    Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& ([Header] -> Identity [Header]) -> Options -> Identity Options
Lens' Options [Header]
Wreq.headers (([Header] -> Identity [Header]) -> Options -> Identity Options)
-> [Header] -> Options -> Options
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Header] -> [Header]
addDefaultHeaders [Header]
hdrs
    Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& (Maybe ResponseChecker -> Identity (Maybe ResponseChecker))
-> Options -> Identity Options
Lens' Options (Maybe ResponseChecker)
Wreq.checkResponse ((Maybe ResponseChecker -> Identity (Maybe ResponseChecker))
 -> Options -> Identity Options)
-> ResponseChecker -> Options -> Options
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (\Request
_ Response BodyReader
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& (Either ManagerSettings Manager
 -> Identity (Either ManagerSettings Manager))
-> Options -> Identity Options
Lens' Options (Either ManagerSettings Manager)
Wreq.manager ((Either ManagerSettings Manager
  -> Identity (Either ManagerSettings Manager))
 -> Options -> Identity Options)
-> Either ManagerSettings Manager -> Options -> Options
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Manager -> Either ManagerSettings Manager
forall a b. b -> Either a b
Right Manager
manager

-- Adds defaults headers overwriting any existing ones
addDefaultHeaders :: [HTTP.Header] -> [HTTP.Header]
addDefaultHeaders :: [Header] -> [Header]
addDefaultHeaders [Header]
hdrs = [Header]
defaultHeaders [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header] -> [Header]
rmDefaultHeaders [Header]
hdrs
  where
    rmDefaultHeaders :: [Header] -> [Header]
rmDefaultHeaders = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Header -> Bool) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> Bool
isDefaultHeader)

isDefaultHeader :: HTTP.Header -> Bool
isDefaultHeader :: Header -> Bool
isDefaultHeader (HeaderName
hdrName, ByteString
_) = HeaderName
hdrName HeaderName -> [HeaderName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Header -> HeaderName) -> [Header] -> [HeaderName]
forall a b. (a -> b) -> [a] -> [b]
map Header -> HeaderName
forall a b. (a, b) -> a
fst [Header]
defaultHeaders

defaultHeaders :: [HTTP.Header]
defaultHeaders :: [Header]
defaultHeaders = [Header
contentType, Header
userAgent]
  where
    contentType :: Header
contentType = (HeaderName
"Content-Type", ByteString
"application/json")
    userAgent :: Header
userAgent =
      ( HeaderName
"User-Agent",
        ByteString
"hasura-graphql-engine/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> UTF8 ByteString -> ByteString
forall a. UTF8 a -> a
unUTF8 (Version -> UTF8 ByteString
forall a b. (ToText a, FromText b) => a -> b
convertText Version
currentVersion)
      )

newtype HttpException = HttpException
  {HttpException -> HttpException
unHttpException :: HTTP.HttpException}
  deriving (Int -> HttpException -> ShowS
[HttpException] -> ShowS
HttpException -> String
(Int -> HttpException -> ShowS)
-> (HttpException -> String)
-> ([HttpException] -> ShowS)
-> Show HttpException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HttpException -> ShowS
showsPrec :: Int -> HttpException -> ShowS
$cshow :: HttpException -> String
show :: HttpException -> String
$cshowList :: [HttpException] -> ShowS
showList :: [HttpException] -> ShowS
Show)

getHTTPExceptionStatus :: HttpException -> Maybe Int
getHTTPExceptionStatus :: HttpException -> Maybe Int
getHTTPExceptionStatus = \case
  (HttpException (HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
httpExceptionContent)) ->
    case HttpExceptionContent
httpExceptionContent of
      HTTP.StatusCodeException Response ()
response ByteString
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Status -> Int
HTTP.statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ()
response
      HTTP.ProxyConnectException ByteString
_ Int
_ Status
status -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Status -> Int
HTTP.statusCode Status
status
      HttpExceptionContent
_ -> Maybe Int
forall a. Maybe a
Nothing
  (HttpException (HTTP.InvalidUrlException String
_ String
_)) -> Maybe Int
forall a. Maybe a
Nothing

serializeHTTPExceptionMessage :: HttpException -> Text
serializeHTTPExceptionMessage :: HttpException -> Text
serializeHTTPExceptionMessage (HttpException (HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
httpExceptionContent)) =
  case HttpExceptionContent
httpExceptionContent of
    HTTP.StatusCodeException Response ()
_ ByteString
_ -> Text
"unexpected"
    HTTP.TooManyRedirects [Response ByteString]
_ -> Text
"Too many redirects"
    HttpExceptionContent
HTTP.OverlongHeaders -> Text
"Overlong headers"
    HttpExceptionContent
HTTP.ResponseTimeout -> Text
"Response timeout"
    HttpExceptionContent
HTTP.ConnectionTimeout -> Text
"Connection timeout"
    HTTP.ConnectionFailure SomeException
_ -> Text
"Connection failure"
    HTTP.InvalidStatusLine ByteString
_ -> Text
"Invalid HTTP Status Line"
    HTTP.InternalException SomeException
err -> case SomeException -> Maybe ConnectionRestricted
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
      Just (Restricted.ConnectionRestricted String
_ AddrInfo
_) -> Text
"Blocked connection to private IP address"
      Maybe ConnectionRestricted
Nothing -> Text
"Internal Exception"
    HTTP.ProxyConnectException {} -> Text
"Proxy connection exception"
    HttpExceptionContent
HTTP.NoResponseDataReceived -> Text
"No response data received"
    HttpExceptionContent
HTTP.TlsNotSupported -> Text
"TLS not supported"
    HTTP.InvalidDestinationHost ByteString
_ -> Text
"Invalid destination host"
    HTTP.InvalidHeader ByteString
_ -> Text
"Invalid Header"
    HTTP.InvalidRequestHeader ByteString
_ -> Text
"Invalid Request Header"
    HTTP.WrongRequestBodyStreamSize Word64
_ Word64
_ -> Text
"Wrong request body stream size"
    HTTP.ResponseBodyTooShort Word64
_ Word64
_ -> Text
"Response body too short"
    HttpExceptionContent
HTTP.InvalidChunkHeaders -> Text
"Invalid chunk headers"
    HttpExceptionContent
HTTP.IncompleteHeaders -> Text
"Incomplete headers"
    HttpExceptionContent
_ -> Text
"unexpected"
serializeHTTPExceptionMessage (HttpException (HTTP.InvalidUrlException String
url String
reason)) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"URL: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
url String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is invalid because " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
reason

newtype ShowHeadersAndEnvVarInfo = ShowHeadersAndEnvVarInfo {ShowHeadersAndEnvVarInfo -> Bool
unShowHeadersAndEnvVarInfo :: Bool}
  deriving (Int -> ShowHeadersAndEnvVarInfo -> ShowS
[ShowHeadersAndEnvVarInfo] -> ShowS
ShowHeadersAndEnvVarInfo -> String
(Int -> ShowHeadersAndEnvVarInfo -> ShowS)
-> (ShowHeadersAndEnvVarInfo -> String)
-> ([ShowHeadersAndEnvVarInfo] -> ShowS)
-> Show ShowHeadersAndEnvVarInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShowHeadersAndEnvVarInfo -> ShowS
showsPrec :: Int -> ShowHeadersAndEnvVarInfo -> ShowS
$cshow :: ShowHeadersAndEnvVarInfo -> String
show :: ShowHeadersAndEnvVarInfo -> String
$cshowList :: [ShowHeadersAndEnvVarInfo] -> ShowS
showList :: [ShowHeadersAndEnvVarInfo] -> ShowS
Show, ShowHeadersAndEnvVarInfo -> ShowHeadersAndEnvVarInfo -> Bool
(ShowHeadersAndEnvVarInfo -> ShowHeadersAndEnvVarInfo -> Bool)
-> (ShowHeadersAndEnvVarInfo -> ShowHeadersAndEnvVarInfo -> Bool)
-> Eq ShowHeadersAndEnvVarInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShowHeadersAndEnvVarInfo -> ShowHeadersAndEnvVarInfo -> Bool
== :: ShowHeadersAndEnvVarInfo -> ShowHeadersAndEnvVarInfo -> Bool
$c/= :: ShowHeadersAndEnvVarInfo -> ShowHeadersAndEnvVarInfo -> Bool
/= :: ShowHeadersAndEnvVarInfo -> ShowHeadersAndEnvVarInfo -> Bool
Eq)

serializeHTTPExceptionWithErrorMessage :: ShowHeadersAndEnvVarInfo -> HTTP.HttpException -> Text
serializeHTTPExceptionWithErrorMessage :: ShowHeadersAndEnvVarInfo -> HttpException -> Text
serializeHTTPExceptionWithErrorMessage (ShowHeadersAndEnvVarInfo Bool
isShowHeaderAndEnvVarInfo) = \case
  HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
err -> case HttpExceptionContent
err of
    HTTP.StatusCodeException Response ()
response ByteString
_ -> Text
"Response status code indicated failure" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> (Status -> Int) -> Status -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
HTTP.statusCode (Status -> Text) -> Status -> Text
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ()
response)
    HTTP.TooManyRedirects [Response ByteString]
redirects -> Text
"Too many redirects: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow ([Response ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Response ByteString]
redirects) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" redirects"
    HttpExceptionContent
HTTP.OverlongHeaders -> Text
"Overlong headers"
    HttpExceptionContent
HTTP.ResponseTimeout -> Text
"Response timeout"
    HttpExceptionContent
HTTP.ConnectionTimeout -> Text
"Connection timeout"
    HTTP.ConnectionFailure SomeException
exn -> Text
"Connection failure: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
serializeExceptionForDebugging SomeException
exn
    HTTP.InvalidStatusLine ByteString
statusLine -> Text
"Invalid HTTP status line: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
fromUtf8 ByteString
statusLine
    HTTP.InvalidHeader ByteString
header ->
      if Bool
isShowHeaderAndEnvVarInfo
        then Text
"Invalid header: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
fromUtf8 ByteString
header
        else Text
"Invalid Header"
    HTTP.InvalidRequestHeader ByteString
requestHeader ->
      if Bool
isShowHeaderAndEnvVarInfo
        then Text
"Invalid request header: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
fromUtf8 ByteString
requestHeader
        else Text
"Invalid request header"
    HTTP.InternalException SomeException
exn -> case SomeException -> Maybe ConnectionRestricted
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn of
      Just (Restricted.ConnectionRestricted String
_ AddrInfo
_) -> Text
"Blocked connection to private IP address: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
serializeExceptionForDebugging SomeException
exn
      Maybe ConnectionRestricted
Nothing -> Text
"Internal error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
serializeExceptionForDebugging SomeException
exn
    HTTP.ProxyConnectException ByteString
proxyHost Int
port Status
status -> Text
"Proxy connection to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
fromUtf8 ByteString
proxyHost Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
port Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" returned response with status code that indicated failure: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Status -> Int
HTTP.statusCode Status
status)
    HttpExceptionContent
HTTP.NoResponseDataReceived -> Text
"No response data received"
    HttpExceptionContent
HTTP.TlsNotSupported -> Text
"TLS not supported"
    HTTP.WrongRequestBodyStreamSize Word64
expected Word64
actual -> Text
"Wrong request body stream size. expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
expected Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", actual: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
actual
    HTTP.ResponseBodyTooShort Word64
expected Word64
actual -> Text
"Response body too short. expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
expected Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", actual: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
actual
    HttpExceptionContent
HTTP.InvalidChunkHeaders -> Text
"Invalid chunk headers"
    HttpExceptionContent
HTTP.IncompleteHeaders -> Text
"Incomplete headers"
    HTTP.InvalidDestinationHost ByteString
host -> Text
"Invalid destination host: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
fromUtf8 ByteString
host
    HTTP.HttpZlibException ZlibException
exn -> Text
"HTTP zlib error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ZlibException -> Text
forall e. Exception e => e -> Text
serializeExceptionForDebugging ZlibException
exn
    HTTP.InvalidProxyEnvironmentVariable Text
name Text
value ->
      if Bool
isShowHeaderAndEnvVarInfo
        then Text
"Invalid proxy environment variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value
        else Text
"Invalid proxy environment variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    HttpExceptionContent
HTTP.ConnectionClosed -> Text
"Connection closed"
    HTTP.InvalidProxySettings Text
err' -> Text
"Invalid proxy settings: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err'
  HTTP.InvalidUrlException String
url' String
reason -> Text
"Invalid url: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
url' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; reason: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
reason
  where
    fromUtf8 :: ByteString -> Text
fromUtf8 = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode

serializeHTTPExceptionMessageForDebugging :: HTTP.HttpException -> Text
serializeHTTPExceptionMessageForDebugging :: HttpException -> Text
serializeHTTPExceptionMessageForDebugging = ShowHeadersAndEnvVarInfo -> HttpException -> Text
serializeHTTPExceptionWithErrorMessage (Bool -> ShowHeadersAndEnvVarInfo
ShowHeadersAndEnvVarInfo Bool
True)

encodeHTTPRequestJSON :: HTTP.Request -> J.Value
encodeHTTPRequestJSON :: Request -> Value
encodeHTTPRequestJSON Request
request =
  Object -> Value
J.Object
    (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList
      [ (Key
"host", Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.host Request
request),
        (Key
"port", Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Request -> Int
HTTP.port Request
request),
        (Key
"secure", Bool -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Request -> Bool
HTTP.secure Request
request),
        (Key
"requestHeaders", HashMap Text Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (HashMap Text Text -> Value) -> HashMap Text Text -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Text)] -> HashMap Text Text)
-> [(Text, Text)] -> HashMap Text Text
forall a b. (a -> b) -> a -> b
$ [Header] -> [(Text, Text)]
hdrsToText ([Header] -> [(Text, Text)]) -> [Header] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ (Header -> Header) -> [Header] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map Header -> Header
redactSensitiveHeader ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$ Request -> [Header]
HTTP.requestHeaders Request
request),
        (Key
"path", Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.path Request
request),
        (Key
"queryString", Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.queryString Request
request),
        (Key
"method", Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.method Request
request),
        (Key
"responseTimeout", Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ResponseTimeout -> Text
forall a. Show a => a -> Text
tshow (ResponseTimeout -> Text) -> ResponseTimeout -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ResponseTimeout
HTTP.responseTimeout Request
request)
      ]

newtype ShowErrorInfo = ShowErrorInfo {ShowErrorInfo -> Bool
unShowErrorInfo :: Bool}
  deriving (Int -> ShowErrorInfo -> ShowS
[ShowErrorInfo] -> ShowS
ShowErrorInfo -> String
(Int -> ShowErrorInfo -> ShowS)
-> (ShowErrorInfo -> String)
-> ([ShowErrorInfo] -> ShowS)
-> Show ShowErrorInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShowErrorInfo -> ShowS
showsPrec :: Int -> ShowErrorInfo -> ShowS
$cshow :: ShowErrorInfo -> String
show :: ShowErrorInfo -> String
$cshowList :: [ShowErrorInfo] -> ShowS
showList :: [ShowErrorInfo] -> ShowS
Show, ShowErrorInfo -> ShowErrorInfo -> Bool
(ShowErrorInfo -> ShowErrorInfo -> Bool)
-> (ShowErrorInfo -> ShowErrorInfo -> Bool) -> Eq ShowErrorInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShowErrorInfo -> ShowErrorInfo -> Bool
== :: ShowErrorInfo -> ShowErrorInfo -> Bool
$c/= :: ShowErrorInfo -> ShowErrorInfo -> Bool
/= :: ShowErrorInfo -> ShowErrorInfo -> Bool
Eq)

-- this function excepts a boolean value (`ShowErrorInfo`) when True, exposes the errors associated with the HTTP
-- Exceptions using `serializeHTTPExceptionWithErrorMessage` function.
-- This function is used in event triggers, scheduled triggers and cron triggers where `ShowErrorInfo` is True
getHttpExceptionJson :: ShowErrorInfo -> HttpException -> J.Value
getHttpExceptionJson :: ShowErrorInfo -> HttpException -> Value
getHttpExceptionJson (ShowErrorInfo Bool
isShowHTTPErrorInfo) HttpException
httpException =
  case HttpException
httpException of
    (HttpException (HTTP.InvalidUrlException String
_ String
e)) ->
      [Pair] -> Value
J.object
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= (Text
"invalid_url" :: Text),
          Key
"message" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= String
e
        ]
    (HttpException (HTTP.HttpExceptionRequest Request
req HttpExceptionContent
_)) -> do
      let statusMaybe :: Maybe Int
statusMaybe = HttpException -> Maybe Int
getHTTPExceptionStatus HttpException
httpException
          exceptionContent :: Text
exceptionContent =
            if Bool
isShowHTTPErrorInfo
              then ShowHeadersAndEnvVarInfo -> HttpException -> Text
serializeHTTPExceptionWithErrorMessage (Bool -> ShowHeadersAndEnvVarInfo
ShowHeadersAndEnvVarInfo Bool
False) (HttpException -> HttpException
unHttpException HttpException
httpException)
              else HttpException -> Text
serializeHTTPExceptionMessage HttpException
httpException
          reqJSON :: Value
reqJSON = Request -> Value
encodeHTTPRequestJSON Request
req
      [Pair] -> Value
J.object
        ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= (Text
"http_exception" :: Text),
            Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Text
exceptionContent,
            Key
"request" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Value
reqJSON
          ]
        [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> (Int -> [Pair]) -> Maybe Int -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Pair]
forall a. Monoid a => a
mempty (\Int
status -> [Key
"status" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Int
status]) Maybe Int
statusMaybe

-- it will not show HTTP Exception error message info
instance J.ToJSON HttpException where
  toJSON :: HttpException -> Value
toJSON HttpException
httpException = ShowErrorInfo -> HttpException -> Value
getHttpExceptionJson (Bool -> ShowErrorInfo
ShowErrorInfo Bool
False) HttpException
httpException

data HttpResponse a = HttpResponse
  { forall a. HttpResponse a -> a
_hrBody :: !a,
    forall a. HttpResponse a -> [Header]
_hrHeaders :: !HTTP.ResponseHeaders
  }
  deriving ((forall a b. (a -> b) -> HttpResponse a -> HttpResponse b)
-> (forall a b. a -> HttpResponse b -> HttpResponse a)
-> Functor HttpResponse
forall a b. a -> HttpResponse b -> HttpResponse a
forall a b. (a -> b) -> HttpResponse a -> HttpResponse b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HttpResponse a -> HttpResponse b
fmap :: forall a b. (a -> b) -> HttpResponse a -> HttpResponse b
$c<$ :: forall a b. a -> HttpResponse b -> HttpResponse a
<$ :: forall a b. a -> HttpResponse b -> HttpResponse a
Functor, (forall m. Monoid m => HttpResponse m -> m)
-> (forall m a. Monoid m => (a -> m) -> HttpResponse a -> m)
-> (forall m a. Monoid m => (a -> m) -> HttpResponse a -> m)
-> (forall a b. (a -> b -> b) -> b -> HttpResponse a -> b)
-> (forall a b. (a -> b -> b) -> b -> HttpResponse a -> b)
-> (forall b a. (b -> a -> b) -> b -> HttpResponse a -> b)
-> (forall b a. (b -> a -> b) -> b -> HttpResponse a -> b)
-> (forall a. (a -> a -> a) -> HttpResponse a -> a)
-> (forall a. (a -> a -> a) -> HttpResponse a -> a)
-> (forall a. HttpResponse a -> [a])
-> (forall a. HttpResponse a -> Bool)
-> (forall a. HttpResponse a -> Int)
-> (forall a. Eq a => a -> HttpResponse a -> Bool)
-> (forall a. Ord a => HttpResponse a -> a)
-> (forall a. Ord a => HttpResponse a -> a)
-> (forall a. Num a => HttpResponse a -> a)
-> (forall a. Num a => HttpResponse a -> a)
-> Foldable HttpResponse
forall a. Eq a => a -> HttpResponse a -> Bool
forall a. Num a => HttpResponse a -> a
forall a. Ord a => HttpResponse a -> a
forall m. Monoid m => HttpResponse m -> m
forall a. HttpResponse a -> Bool
forall a. HttpResponse a -> Int
forall a. HttpResponse a -> [a]
forall a. (a -> a -> a) -> HttpResponse a -> a
forall m a. Monoid m => (a -> m) -> HttpResponse a -> m
forall b a. (b -> a -> b) -> b -> HttpResponse a -> b
forall a b. (a -> b -> b) -> b -> HttpResponse a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => HttpResponse m -> m
fold :: forall m. Monoid m => HttpResponse m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HttpResponse a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> HttpResponse a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> HttpResponse a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> HttpResponse a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> HttpResponse a -> b
foldr :: forall a b. (a -> b -> b) -> b -> HttpResponse a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> HttpResponse a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> HttpResponse a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> HttpResponse a -> b
foldl :: forall b a. (b -> a -> b) -> b -> HttpResponse a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> HttpResponse a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> HttpResponse a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> HttpResponse a -> a
foldr1 :: forall a. (a -> a -> a) -> HttpResponse a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HttpResponse a -> a
foldl1 :: forall a. (a -> a -> a) -> HttpResponse a -> a
$ctoList :: forall a. HttpResponse a -> [a]
toList :: forall a. HttpResponse a -> [a]
$cnull :: forall a. HttpResponse a -> Bool
null :: forall a. HttpResponse a -> Bool
$clength :: forall a. HttpResponse a -> Int
length :: forall a. HttpResponse a -> Int
$celem :: forall a. Eq a => a -> HttpResponse a -> Bool
elem :: forall a. Eq a => a -> HttpResponse a -> Bool
$cmaximum :: forall a. Ord a => HttpResponse a -> a
maximum :: forall a. Ord a => HttpResponse a -> a
$cminimum :: forall a. Ord a => HttpResponse a -> a
minimum :: forall a. Ord a => HttpResponse a -> a
$csum :: forall a. Num a => HttpResponse a -> a
sum :: forall a. Num a => HttpResponse a -> a
$cproduct :: forall a. Num a => HttpResponse a -> a
product :: forall a. Num a => HttpResponse a -> a
Foldable, Functor HttpResponse
Foldable HttpResponse
Functor HttpResponse
-> Foldable HttpResponse
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> HttpResponse a -> f (HttpResponse b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    HttpResponse (f a) -> f (HttpResponse a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> HttpResponse a -> m (HttpResponse b))
-> (forall (m :: * -> *) a.
    Monad m =>
    HttpResponse (m a) -> m (HttpResponse a))
-> Traversable HttpResponse
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
HttpResponse (m a) -> m (HttpResponse a)
forall (f :: * -> *) a.
Applicative f =>
HttpResponse (f a) -> f (HttpResponse a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HttpResponse a -> m (HttpResponse b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HttpResponse a -> f (HttpResponse b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HttpResponse a -> f (HttpResponse b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HttpResponse a -> f (HttpResponse b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HttpResponse (f a) -> f (HttpResponse a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HttpResponse (f a) -> f (HttpResponse a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HttpResponse a -> m (HttpResponse b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HttpResponse a -> m (HttpResponse b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HttpResponse (m a) -> m (HttpResponse a)
sequence :: forall (m :: * -> *) a.
Monad m =>
HttpResponse (m a) -> m (HttpResponse a)
Traversable)

addHttpResponseHeaders :: HTTP.ResponseHeaders -> HttpResponse a -> HttpResponse a
addHttpResponseHeaders :: forall a. [Header] -> HttpResponse a -> HttpResponse a
addHttpResponseHeaders [Header]
newHeaders (HttpResponse a
b [Header]
h) = a -> [Header] -> HttpResponse a
forall a. a -> [Header] -> HttpResponse a
HttpResponse a
b ([Header]
newHeaders [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
h)

serializeServantClientErrorMessage :: Servant.ClientError -> Text
serializeServantClientErrorMessage :: ClientError -> Text
serializeServantClientErrorMessage = \case
  Servant.FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
response -> Text
"response status code indicated failure: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> (Status -> Int) -> Status -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
HTTP.statusCode (Status -> Text) -> Status -> Text
forall a b. (a -> b) -> a -> b
$ Response -> Status
forall a. ResponseF a -> Status
Servant.responseStatusCode Response
response)
  Servant.DecodeFailure Text
decodeErrorText Response
_ -> Text
"unable to decode the response, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
decodeErrorText
  Servant.UnsupportedContentType MediaType
mediaType Response
_ -> Text
"unsupported content type in response: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode (MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader MediaType
mediaType)
  Servant.InvalidContentTypeHeader Response
_ -> Text
"invalid content type in response"
  Servant.ConnectionError SomeException
_ -> Text
"connection error"

serializeServantClientErrorMessageForDebugging :: Servant.ClientError -> Text
serializeServantClientErrorMessageForDebugging :: ClientError -> Text
serializeServantClientErrorMessageForDebugging = \case
  Servant.ConnectionError SomeException
exn -> case SomeException -> Maybe HttpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn of
    Just HttpException
httpException -> HttpException -> Text
serializeHTTPExceptionMessageForDebugging HttpException
httpException
    Maybe HttpException
Nothing -> Text
"error in the connection: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
serializeExceptionForDebugging SomeException
exn
  ClientError
other -> ClientError -> Text
serializeServantClientErrorMessage ClientError
other

serializeExceptionForDebugging :: (Exception e) => e -> Text
serializeExceptionForDebugging :: forall e. Exception e => e -> Text
serializeExceptionForDebugging = String -> Text
T.pack (String -> Text) -> (e -> String) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall e. Exception e => e -> String
displayException