-- |
--  = Hasura.Eventing.HTTP
--
--  This module is an utility module providing HTTP utilities for
--  "Hasura.Eventing.EventTriggers" and "Hasura.Eventing.ScheduledTriggers".
--
--  The event triggers and scheduled triggers share the event delivery
--  mechanism using the 'tryWebhook' function defined in this module.
module Hasura.Eventing.HTTP
  ( HTTPErr (..),
    HTTPResp (..),
    httpExceptionErrorEncoding,
    runHTTP,
    isNetworkError,
    isNetworkErrorHC,
    logHTTPForET,
    logHTTPForST,
    ExtraLogContext (..),
    RequestDetails (..),
    extractRequest,
    EventId,
    InvocationVersion,
    Response (..),
    WebhookRequest (..),
    WebhookResponse (..),
    ClientError (..),
    isClientError,
    mkClientErr,
    mkWebhookReq,
    mkResp,
    mkInvocationResp,
    prepareHeaders,
    getRetryAfterHeaderFromHTTPErr,
    getRetryAfterHeaderFromResp,
    parseRetryHeaderValue,
    invocationVersionET,
    invocationVersionST,
    mkRequest,
    invokeRequest,
    TransformableRequestError (..),
  )
where

import Control.Exception (try)
import Control.Lens (preview, set, (.~))
import Data.Aeson qualified as J
import Data.Aeson.Encoding qualified as JE
import Data.Aeson.Key qualified as J
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Lens
import Data.ByteString qualified as BS
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.CaseInsensitive qualified as CI
import Data.Either
import Data.Has
import Data.Int (Int64)
import Data.SerializableBlob qualified as SB
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Data.URL.Template (mkPlainTemplate, printTemplate)
import Hasura.HTTP
import Hasura.Logging
import Hasura.Prelude
import Hasura.RQL.DDL.Webhook.Transform qualified as Transform
import Hasura.RQL.Types.Common (ResolvedWebhook (..))
import Hasura.RQL.Types.EventTrigger
import Hasura.RQL.Types.Eventing
import Hasura.RQL.Types.Headers
import Hasura.Session (SessionVariables)
import Hasura.Tracing
import Network.HTTP.Client.Transformable qualified as HTTP

retryAfterHeader :: CI.CI Text
retryAfterHeader :: CI HeaderName
retryAfterHeader = CI HeaderName
"Retry-After"

data ExtraLogContext = ExtraLogContext
  { ExtraLogContext -> EventId
elEventId :: !EventId,
    ExtraLogContext -> Maybe TriggerName
elEventName :: !(Maybe TriggerName)
  }
  deriving (Int -> ExtraLogContext -> ShowS
[ExtraLogContext] -> ShowS
ExtraLogContext -> String
(Int -> ExtraLogContext -> ShowS)
-> (ExtraLogContext -> String)
-> ([ExtraLogContext] -> ShowS)
-> Show ExtraLogContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExtraLogContext -> ShowS
showsPrec :: Int -> ExtraLogContext -> ShowS
$cshow :: ExtraLogContext -> String
show :: ExtraLogContext -> String
$cshowList :: [ExtraLogContext] -> ShowS
showList :: [ExtraLogContext] -> ShowS
Show, ExtraLogContext -> ExtraLogContext -> Bool
(ExtraLogContext -> ExtraLogContext -> Bool)
-> (ExtraLogContext -> ExtraLogContext -> Bool)
-> Eq ExtraLogContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExtraLogContext -> ExtraLogContext -> Bool
== :: ExtraLogContext -> ExtraLogContext -> Bool
$c/= :: ExtraLogContext -> ExtraLogContext -> Bool
/= :: ExtraLogContext -> ExtraLogContext -> Bool
Eq)

data HTTPResp (a :: TriggerTypes) = HTTPResp
  { forall (a :: TriggerTypes). HTTPResp a -> Int
hrsStatus :: !Int,
    forall (a :: TriggerTypes). HTTPResp a -> [HeaderConf]
hrsHeaders :: ![HeaderConf],
    forall (a :: TriggerTypes). HTTPResp a -> SerializableBlob
hrsBody :: !SB.SerializableBlob,
    forall (a :: TriggerTypes). HTTPResp a -> Int64
hrsSize :: !Int64
  }
  deriving ((forall x. HTTPResp a -> Rep (HTTPResp a) x)
-> (forall x. Rep (HTTPResp a) x -> HTTPResp a)
-> Generic (HTTPResp a)
forall x. Rep (HTTPResp a) x -> HTTPResp a
forall x. HTTPResp a -> Rep (HTTPResp a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (a :: TriggerTypes) x. Rep (HTTPResp a) x -> HTTPResp a
forall (a :: TriggerTypes) x. HTTPResp a -> Rep (HTTPResp a) x
$cfrom :: forall (a :: TriggerTypes) x. HTTPResp a -> Rep (HTTPResp a) x
from :: forall x. HTTPResp a -> Rep (HTTPResp a) x
$cto :: forall (a :: TriggerTypes) x. Rep (HTTPResp a) x -> HTTPResp a
to :: forall x. Rep (HTTPResp a) x -> HTTPResp a
Generic, Int -> HTTPResp a -> ShowS
[HTTPResp a] -> ShowS
HTTPResp a -> String
(Int -> HTTPResp a -> ShowS)
-> (HTTPResp a -> String)
-> ([HTTPResp a] -> ShowS)
-> Show (HTTPResp a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: TriggerTypes). Int -> HTTPResp a -> ShowS
forall (a :: TriggerTypes). [HTTPResp a] -> ShowS
forall (a :: TriggerTypes). HTTPResp a -> String
$cshowsPrec :: forall (a :: TriggerTypes). Int -> HTTPResp a -> ShowS
showsPrec :: Int -> HTTPResp a -> ShowS
$cshow :: forall (a :: TriggerTypes). HTTPResp a -> String
show :: HTTPResp a -> String
$cshowList :: forall (a :: TriggerTypes). [HTTPResp a] -> ShowS
showList :: [HTTPResp a] -> ShowS
Show)

instance J.ToJSON (HTTPResp a) where
  toJSON :: HTTPResp a -> Value
toJSON = Options -> HTTPResp a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON {omitNothingFields :: Bool
J.omitNothingFields = Bool
True}
  toEncoding :: HTTPResp a -> Encoding
toEncoding = Options -> HTTPResp a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON {omitNothingFields :: Bool
J.omitNothingFields = Bool
True}

instance ToEngineLog (HTTPResp 'EventType) Hasura where
  toEngineLog :: HTTPResp 'EventType -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog HTTPResp 'EventType
resp = (LogLevel
LevelInfo, EngineLogType Hasura
eventTriggerLogType, HTTPResp 'EventType -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPResp 'EventType
resp)

instance ToEngineLog (HTTPResp 'ScheduledType) Hasura where
  toEngineLog :: HTTPResp 'ScheduledType -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog HTTPResp 'ScheduledType
resp = (LogLevel
LevelInfo, EngineLogType Hasura
scheduledTriggerLogType, HTTPResp 'ScheduledType -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPResp 'ScheduledType
resp)

data HTTPErr (a :: TriggerTypes)
  = HClient !HttpException
  | HStatus !(HTTPResp a)
  | HOther !String
  deriving (Int -> HTTPErr a -> ShowS
[HTTPErr a] -> ShowS
HTTPErr a -> String
(Int -> HTTPErr a -> ShowS)
-> (HTTPErr a -> String)
-> ([HTTPErr a] -> ShowS)
-> Show (HTTPErr a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: TriggerTypes). Int -> HTTPErr a -> ShowS
forall (a :: TriggerTypes). [HTTPErr a] -> ShowS
forall (a :: TriggerTypes). HTTPErr a -> String
$cshowsPrec :: forall (a :: TriggerTypes). Int -> HTTPErr a -> ShowS
showsPrec :: Int -> HTTPErr a -> ShowS
$cshow :: forall (a :: TriggerTypes). HTTPErr a -> String
show :: HTTPErr a -> String
$cshowList :: forall (a :: TriggerTypes). [HTTPErr a] -> ShowS
showList :: [HTTPErr a] -> ShowS
Show)

instance J.ToJSON (HTTPErr a) where
  toJSON :: HTTPErr a -> Value
toJSON HTTPErr a
err = (HeaderName, Value) -> Value
toObj ((HeaderName, Value) -> Value) -> (HeaderName, Value) -> Value
forall a b. (a -> b) -> a -> b
$ case HTTPErr a
err of
    (HClient HttpException
httpException) ->
      (HeaderName
"client", ShowErrorInfo -> HttpException -> Value
getHttpExceptionJson (Bool -> ShowErrorInfo
ShowErrorInfo Bool
True) HttpException
httpException)
    (HStatus HTTPResp a
resp) ->
      (HeaderName
"status", HTTPResp a -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPResp a
resp)
    (HOther String
e) -> (HeaderName
"internal", String -> Value
forall a. ToJSON a => a -> Value
J.toJSON String
e)
    where
      toObj :: (Text, J.Value) -> J.Value
      toObj :: (HeaderName, Value) -> Value
toObj (HeaderName
k, Value
v) =
        [Pair] -> Value
J.object
          [ Key
"type" Key -> HeaderName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= HeaderName
k,
            Key
"detail" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Value
v
          ]

-- similar to Aeson.encode function which uses `getHttpExceptionJson` function instead of ToJSON instance of
-- HttpException
httpExceptionErrorEncoding :: HttpException -> ByteString
httpExceptionErrorEncoding :: HttpException -> ByteString
httpExceptionErrorEncoding = Encoding -> ByteString
forall a. Encoding' a -> ByteString
JE.encodingToLazyByteString (Encoding -> ByteString)
-> (HttpException -> Encoding) -> HttpException -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Encoding
JE.value (Value -> Encoding)
-> (HttpException -> Value) -> HttpException -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowErrorInfo -> HttpException -> Value
getHttpExceptionJson (Bool -> ShowErrorInfo
ShowErrorInfo Bool
True))

instance ToEngineLog (HTTPErr 'EventType) Hasura where
  toEngineLog :: HTTPErr 'EventType -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog HTTPErr 'EventType
err = (LogLevel
LevelError, EngineLogType Hasura
eventTriggerLogType, HTTPErr 'EventType -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPErr 'EventType
err)

instance ToEngineLog (HTTPErr 'ScheduledType) Hasura where
  toEngineLog :: HTTPErr 'ScheduledType -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog HTTPErr 'ScheduledType
err = (LogLevel
LevelError, EngineLogType Hasura
scheduledTriggerLogType, HTTPErr 'ScheduledType -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPErr 'ScheduledType
err)

mkHTTPResp :: HTTP.Response LBS.ByteString -> HTTPResp a
mkHTTPResp :: forall (a :: TriggerTypes). Response ByteString -> HTTPResp a
mkHTTPResp Response ByteString
resp =
  HTTPResp
    { hrsStatus :: Int
hrsStatus = Status -> Int
HTTP.statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
resp,
      hrsHeaders :: [HeaderConf]
hrsHeaders = (Header -> HeaderConf) -> [Header] -> [HeaderConf]
forall a b. (a -> b) -> [a] -> [b]
map Header -> HeaderConf
decodeHeader' ([Header] -> [HeaderConf]) -> [Header] -> [HeaderConf]
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [Header]
forall body. Response body -> [Header]
HTTP.responseHeaders Response ByteString
resp,
      hrsBody :: SerializableBlob
hrsBody = ByteString -> SerializableBlob
SB.fromLBS ByteString
respBody,
      hrsSize :: Int64
hrsSize = ByteString -> Int64
LBS.length ByteString
respBody
    }
  where
    respBody :: ByteString
respBody = Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
resp
    decodeBS :: ByteString -> HeaderName
decodeBS = OnDecodeError -> ByteString -> HeaderName
TE.decodeUtf8With OnDecodeError
TE.lenientDecode
    decodeHeader' :: Header -> HeaderConf
decodeHeader' (CI ByteString
hdrName, ByteString
hdrVal) =
      HeaderName -> HeaderValue -> HeaderConf
HeaderConf (ByteString -> HeaderName
decodeBS (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
hdrName) (Template -> HeaderValue
HVValue (Template -> HeaderValue) -> Template -> HeaderValue
forall a b. (a -> b) -> a -> b
$ HeaderName -> Template
mkPlainTemplate (ByteString -> HeaderName
decodeBS ByteString
hdrVal))

data RequestDetails = RequestDetails
  { RequestDetails -> Request
_rdOriginalRequest :: HTTP.Request,
    RequestDetails -> Int64
_rdOriginalSize :: Int64,
    RequestDetails -> Maybe Request
_rdTransformedRequest :: Maybe HTTP.Request,
    RequestDetails -> Maybe Int64
_rdTransformedSize :: Maybe Int64,
    RequestDetails -> Maybe RequestContext
_rdReqTransformCtx :: Maybe Transform.RequestContext,
    RequestDetails -> Maybe SessionVariables
_rdSessionVars :: Maybe SessionVariables
  }
  deriving ((forall x. RequestDetails -> Rep RequestDetails x)
-> (forall x. Rep RequestDetails x -> RequestDetails)
-> Generic RequestDetails
forall x. Rep RequestDetails x -> RequestDetails
forall x. RequestDetails -> Rep RequestDetails x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RequestDetails -> Rep RequestDetails x
from :: forall x. RequestDetails -> Rep RequestDetails x
$cto :: forall x. Rep RequestDetails x -> RequestDetails
to :: forall x. Rep RequestDetails x -> RequestDetails
Generic)

extractRequest :: RequestDetails -> HTTP.Request
extractRequest :: RequestDetails -> Request
extractRequest RequestDetails {Int64
Maybe Int64
Maybe Request
Maybe SessionVariables
Maybe RequestContext
Request
_rdOriginalRequest :: RequestDetails -> Request
_rdOriginalSize :: RequestDetails -> Int64
_rdTransformedRequest :: RequestDetails -> Maybe Request
_rdTransformedSize :: RequestDetails -> Maybe Int64
_rdReqTransformCtx :: RequestDetails -> Maybe RequestContext
_rdSessionVars :: RequestDetails -> Maybe SessionVariables
_rdOriginalRequest :: Request
_rdOriginalSize :: Int64
_rdTransformedRequest :: Maybe Request
_rdTransformedSize :: Maybe Int64
_rdReqTransformCtx :: Maybe RequestContext
_rdSessionVars :: Maybe SessionVariables
..} = Request -> Maybe Request -> Request
forall a. a -> Maybe a -> a
fromMaybe Request
_rdOriginalRequest Maybe Request
_rdTransformedRequest

instance J.ToJSON RequestDetails where
  toJSON :: RequestDetails -> Value
toJSON = Options -> RequestDetails -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON
  toEncoding :: RequestDetails -> Encoding
toEncoding = Options -> RequestDetails -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON

data HTTPRespExtra (a :: TriggerTypes) = HTTPRespExtra
  { forall (a :: TriggerTypes).
HTTPRespExtra a -> Either (HTTPErr a) (HTTPResp a)
_hreResponse :: !(Either (HTTPErr a) (HTTPResp a)),
    forall (a :: TriggerTypes). HTTPRespExtra a -> ExtraLogContext
_hreContext :: !ExtraLogContext,
    forall (a :: TriggerTypes). HTTPRespExtra a -> RequestDetails
_hreRequest :: !RequestDetails,
    forall (a :: TriggerTypes). HTTPRespExtra a -> HeaderName
_hreWebhookVarName :: !Text,
    forall (a :: TriggerTypes). HTTPRespExtra a -> [HeaderConf]
_hreLogHeaders :: ![HeaderConf]
  }

instance J.ToJSON (HTTPRespExtra a) where
  toJSON :: HTTPRespExtra a -> Value
toJSON (HTTPRespExtra Either (HTTPErr a) (HTTPResp a)
resp ExtraLogContext
ctxt RequestDetails
req HeaderName
webhookVarName [HeaderConf]
logHeaders) =
    case Either (HTTPErr a) (HTTPResp a)
resp of
      Left HTTPErr a
errResp ->
        [Pair] -> Value
J.object
          ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"response" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= HTTPErr a -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPErr a
errResp,
              Key
"request" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= RequestDetails -> Value
sanitiseReqJSON RequestDetails
req,
              Key
"event_id" Key -> EventId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= ExtraLogContext -> EventId
elEventId ExtraLogContext
ctxt
            ]
          [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
eventName
      Right HTTPResp a
okResp ->
        [Pair] -> Value
J.object
          ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"response" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= HTTPResp a -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPResp a
okResp,
              Key
"request" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= RequestDetails -> Value
forall a. ToJSON a => a -> Value
J.toJSON RequestDetails
req,
              Key
"event_id" Key -> EventId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= ExtraLogContext -> EventId
elEventId ExtraLogContext
ctxt
            ]
          [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
eventName
    where
      eventName :: [Pair]
eventName = case ExtraLogContext -> Maybe TriggerName
elEventName ExtraLogContext
ctxt of
        Just TriggerName
name -> [Key
"event_name" Key -> TriggerName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= TriggerName
name]
        Maybe TriggerName
Nothing -> []
      getValue :: HeaderValue -> Value
getValue HeaderValue
val = case HeaderValue
val of
        HVValue Template
txt -> HeaderName -> Value
J.String (Template -> HeaderName
printTemplate Template
txt)
        HVEnv HeaderName
txt -> HeaderName -> Value
J.String HeaderName
txt
      getRedactedHeaders :: Value
getRedactedHeaders =
        Object -> Value
J.Object
          (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (HeaderConf -> Object -> Object)
-> Object -> [HeaderConf] -> Object
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(HeaderConf HeaderName
name HeaderValue
val) -> Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (HeaderName -> Key
J.fromText HeaderName
name) (HeaderValue -> Value
getValue HeaderValue
val)) Object
forall a. Monoid a => a
mempty [HeaderConf]
logHeaders
      updateReqDetail :: RequestDetails -> Key -> Value
updateReqDetail RequestDetails
v Key
reqType =
        let webhookRedactedReq :: Value
webhookRedactedReq = RequestDetails -> Value
forall a. ToJSON a => a -> Value
J.toJSON RequestDetails
v Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
reqType ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"url" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HeaderName -> Value
J.String HeaderName
webhookVarName
            redactedReq :: Value
redactedReq = Value
webhookRedactedReq Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
reqType ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"headers" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Value
getRedactedHeaders
         in Value
redactedReq
      -- redact the resolved webhook and headers value, this helps in not logging
      -- sensitive info
      sanitiseReqJSON :: RequestDetails -> Value
sanitiseReqJSON RequestDetails
v = case RequestDetails -> Maybe Request
_rdTransformedRequest RequestDetails
v of
        Maybe Request
Nothing -> RequestDetails -> Key -> Value
updateReqDetail RequestDetails
v Key
"original_request"
        Just Request
_ -> RequestDetails -> Key -> Value
updateReqDetail RequestDetails
v Key
"transformed_request"

instance ToEngineLog (HTTPRespExtra 'EventType) Hasura where
  toEngineLog :: HTTPRespExtra 'EventType -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog HTTPRespExtra 'EventType
resp = (LogLevel
LevelInfo, EngineLogType Hasura
eventTriggerLogType, HTTPRespExtra 'EventType -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPRespExtra 'EventType
resp)

instance ToEngineLog (HTTPRespExtra 'ScheduledType) Hasura where
  toEngineLog :: HTTPRespExtra 'ScheduledType
-> (LogLevel, EngineLogType Hasura, Value)
toEngineLog HTTPRespExtra 'ScheduledType
resp = (LogLevel
LevelInfo, EngineLogType Hasura
scheduledTriggerLogType, HTTPRespExtra 'ScheduledType -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPRespExtra 'ScheduledType
resp)

isNetworkError :: HTTPErr a -> Bool
isNetworkError :: forall (a :: TriggerTypes). HTTPErr a -> Bool
isNetworkError = \case
  HClient HttpException
he -> HttpException -> Bool
isNetworkErrorHC HttpException
he
  HTTPErr a
_ -> Bool
False

isNetworkErrorHC :: HttpException -> Bool
isNetworkErrorHC :: HttpException -> Bool
isNetworkErrorHC (HttpException HttpException
exception) =
  case HttpException
exception of
    HTTP.HttpExceptionRequest Request
_ (HTTP.ConnectionFailure SomeException
_) -> Bool
True
    HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
HTTP.ConnectionTimeout -> Bool
True
    HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
HTTP.ResponseTimeout -> Bool
True
    HttpException
_ -> Bool
False

anyBodyParser :: HTTP.Response LBS.ByteString -> Either (HTTPErr a) (HTTPResp a)
anyBodyParser :: forall (a :: TriggerTypes).
Response ByteString -> Either (HTTPErr a) (HTTPResp a)
anyBodyParser Response ByteString
resp = do
  let httpResp :: HTTPResp a
httpResp = Response ByteString -> HTTPResp a
forall (a :: TriggerTypes). Response ByteString -> HTTPResp a
mkHTTPResp Response ByteString
resp
  if Status
respCode Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
>= Status
HTTP.status200 Bool -> Bool -> Bool
&& Status
respCode Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
HTTP.status300
    then HTTPResp a -> Either (HTTPErr a) (HTTPResp a)
forall a. a -> Either (HTTPErr a) a
forall (m :: * -> *) a. Monad m => a -> m a
return HTTPResp a
httpResp
    else HTTPErr a -> Either (HTTPErr a) (HTTPResp a)
forall a. HTTPErr a -> Either (HTTPErr a) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HTTPErr a -> Either (HTTPErr a) (HTTPResp a))
-> HTTPErr a -> Either (HTTPErr a) (HTTPResp a)
forall a b. (a -> b) -> a -> b
$ HTTPResp a -> HTTPErr a
forall (a :: TriggerTypes). HTTPResp a -> HTTPErr a
HStatus HTTPResp a
httpResp
  where
    respCode :: Status
respCode = Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
resp

data HTTPReq = HTTPReq
  { HTTPReq -> String
_hrqMethod :: !String,
    HTTPReq -> String
_hrqUrl :: !String,
    HTTPReq -> Maybe Value
_hrqPayload :: !(Maybe J.Value),
    HTTPReq -> Int
_hrqTry :: !Int,
    HTTPReq -> Maybe Int
_hrqDelay :: !(Maybe Int)
  }
  deriving (Int -> HTTPReq -> ShowS
[HTTPReq] -> ShowS
HTTPReq -> String
(Int -> HTTPReq -> ShowS)
-> (HTTPReq -> String) -> ([HTTPReq] -> ShowS) -> Show HTTPReq
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HTTPReq -> ShowS
showsPrec :: Int -> HTTPReq -> ShowS
$cshow :: HTTPReq -> String
show :: HTTPReq -> String
$cshowList :: [HTTPReq] -> ShowS
showList :: [HTTPReq] -> ShowS
Show, (forall x. HTTPReq -> Rep HTTPReq x)
-> (forall x. Rep HTTPReq x -> HTTPReq) -> Generic HTTPReq
forall x. Rep HTTPReq x -> HTTPReq
forall x. HTTPReq -> Rep HTTPReq x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HTTPReq -> Rep HTTPReq x
from :: forall x. HTTPReq -> Rep HTTPReq x
$cto :: forall x. Rep HTTPReq x -> HTTPReq
to :: forall x. Rep HTTPReq x -> HTTPReq
Generic, HTTPReq -> HTTPReq -> Bool
(HTTPReq -> HTTPReq -> Bool)
-> (HTTPReq -> HTTPReq -> Bool) -> Eq HTTPReq
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HTTPReq -> HTTPReq -> Bool
== :: HTTPReq -> HTTPReq -> Bool
$c/= :: HTTPReq -> HTTPReq -> Bool
/= :: HTTPReq -> HTTPReq -> Bool
Eq)

instance J.ToJSON HTTPReq where
  toJSON :: HTTPReq -> Value
toJSON = Options -> HTTPReq -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON {omitNothingFields :: Bool
J.omitNothingFields = Bool
True}
  toEncoding :: HTTPReq -> Encoding
toEncoding = Options -> HTTPReq -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON {omitNothingFields :: Bool
J.omitNothingFields = Bool
True}

instance ToEngineLog HTTPReq Hasura where
  toEngineLog :: HTTPReq -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog HTTPReq
req = (LogLevel
LevelInfo, EngineLogType Hasura
eventTriggerLogType, HTTPReq -> Value
forall a. ToJSON a => a -> Value
J.toJSON HTTPReq
req)

logHTTPForET ::
  ( MonadReader r m,
    Has (Logger Hasura) r,
    MonadIO m
  ) =>
  Either (HTTPErr 'EventType) (HTTPResp 'EventType) ->
  ExtraLogContext ->
  RequestDetails ->
  Text ->
  [HeaderConf] ->
  m ()
logHTTPForET :: forall r (m :: * -> *).
(MonadReader r m, Has (Logger Hasura) r, MonadIO m) =>
Either (HTTPErr 'EventType) (HTTPResp 'EventType)
-> ExtraLogContext
-> RequestDetails
-> HeaderName
-> [HeaderConf]
-> m ()
logHTTPForET Either (HTTPErr 'EventType) (HTTPResp 'EventType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails HeaderName
webhookVarName [HeaderConf]
logHeaders = do
  Logger Hasura
logger :: Logger Hasura <- (r -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Logger Hasura
forall a t. Has a t => t -> a
getter
  Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (HTTPRespExtra 'EventType -> m ())
-> HTTPRespExtra 'EventType -> m ()
forall a b. (a -> b) -> a -> b
$ Either (HTTPErr 'EventType) (HTTPResp 'EventType)
-> ExtraLogContext
-> RequestDetails
-> HeaderName
-> [HeaderConf]
-> HTTPRespExtra 'EventType
forall (a :: TriggerTypes).
Either (HTTPErr a) (HTTPResp a)
-> ExtraLogContext
-> RequestDetails
-> HeaderName
-> [HeaderConf]
-> HTTPRespExtra a
HTTPRespExtra Either (HTTPErr 'EventType) (HTTPResp 'EventType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails HeaderName
webhookVarName [HeaderConf]
logHeaders

logHTTPForST ::
  ( MonadReader r m,
    Has (Logger Hasura) r,
    MonadIO m
  ) =>
  Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType) ->
  ExtraLogContext ->
  RequestDetails ->
  Text ->
  [HeaderConf] ->
  m ()
logHTTPForST :: forall r (m :: * -> *).
(MonadReader r m, Has (Logger Hasura) r, MonadIO m) =>
Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
-> ExtraLogContext
-> RequestDetails
-> HeaderName
-> [HeaderConf]
-> m ()
logHTTPForST Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails HeaderName
webhookVarName [HeaderConf]
logHeaders = do
  Logger Hasura
logger :: Logger Hasura <- (r -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Logger Hasura
forall a t. Has a t => t -> a
getter
  Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger (HTTPRespExtra 'ScheduledType -> m ())
-> HTTPRespExtra 'ScheduledType -> m ()
forall a b. (a -> b) -> a -> b
$ Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
-> ExtraLogContext
-> RequestDetails
-> HeaderName
-> [HeaderConf]
-> HTTPRespExtra 'ScheduledType
forall (a :: TriggerTypes).
Either (HTTPErr a) (HTTPResp a)
-> ExtraLogContext
-> RequestDetails
-> HeaderName
-> [HeaderConf]
-> HTTPRespExtra a
HTTPRespExtra Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails HeaderName
webhookVarName [HeaderConf]
logHeaders

runHTTP :: (MonadIO m) => HTTP.Manager -> HTTP.Request -> m (Either (HTTPErr a) (HTTPResp a))
runHTTP :: forall (m :: * -> *) (a :: TriggerTypes).
MonadIO m =>
Manager -> Request -> m (Either (HTTPErr a) (HTTPResp a))
runHTTP Manager
manager Request
req = do
  Either HttpException (Response ByteString)
res <- IO (Either HttpException (Response ByteString))
-> m (Either HttpException (Response ByteString))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HttpException (Response ByteString))
 -> m (Either HttpException (Response ByteString)))
-> IO (Either HttpException (Response ByteString))
-> m (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
manager
  Either (HTTPErr a) (HTTPResp a)
-> m (Either (HTTPErr a) (HTTPResp a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (HTTPErr a) (HTTPResp a)
 -> m (Either (HTTPErr a) (HTTPResp a)))
-> Either (HTTPErr a) (HTTPResp a)
-> m (Either (HTTPErr a) (HTTPResp a))
forall a b. (a -> b) -> a -> b
$ (HttpException -> Either (HTTPErr a) (HTTPResp a))
-> (Response ByteString -> Either (HTTPErr a) (HTTPResp a))
-> Either HttpException (Response ByteString)
-> Either (HTTPErr a) (HTTPResp a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HTTPErr a -> Either (HTTPErr a) (HTTPResp a)
forall a b. a -> Either a b
Left (HTTPErr a -> Either (HTTPErr a) (HTTPResp a))
-> (HttpException -> HTTPErr a)
-> HttpException
-> Either (HTTPErr a) (HTTPResp a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> HTTPErr a
forall (a :: TriggerTypes). HttpException -> HTTPErr a
HClient (HttpException -> HTTPErr a)
-> (HttpException -> HttpException) -> HttpException -> HTTPErr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> HttpException
HttpException) Response ByteString -> Either (HTTPErr a) (HTTPResp a)
forall (a :: TriggerTypes).
Response ByteString -> Either (HTTPErr a) (HTTPResp a)
anyBodyParser Either HttpException (Response ByteString)
res

data TransformableRequestError a
  = HTTPError J.Value (HTTPErr a)
  | TransformationError J.Value Transform.TransformErrorBundle
  deriving (Int -> TransformableRequestError a -> ShowS
[TransformableRequestError a] -> ShowS
TransformableRequestError a -> String
(Int -> TransformableRequestError a -> ShowS)
-> (TransformableRequestError a -> String)
-> ([TransformableRequestError a] -> ShowS)
-> Show (TransformableRequestError a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: TriggerTypes).
Int -> TransformableRequestError a -> ShowS
forall (a :: TriggerTypes). [TransformableRequestError a] -> ShowS
forall (a :: TriggerTypes). TransformableRequestError a -> String
$cshowsPrec :: forall (a :: TriggerTypes).
Int -> TransformableRequestError a -> ShowS
showsPrec :: Int -> TransformableRequestError a -> ShowS
$cshow :: forall (a :: TriggerTypes). TransformableRequestError a -> String
show :: TransformableRequestError a -> String
$cshowList :: forall (a :: TriggerTypes). [TransformableRequestError a] -> ShowS
showList :: [TransformableRequestError a] -> ShowS
Show)

mkRequest ::
  (MonadError (TransformableRequestError a) m) =>
  [HTTP.Header] ->
  HTTP.ResponseTimeout ->
  -- | the request body. It is passed as a 'BL.Bytestring' because we need to
  -- log the request size. As the logging happens outside the function, we pass
  -- it the final request body, instead of 'Value'
  LBS.ByteString ->
  Maybe Transform.RequestTransform ->
  ResolvedWebhook ->
  m RequestDetails
mkRequest :: forall (a :: TriggerTypes) (m :: * -> *).
MonadError (TransformableRequestError a) m =>
[Header]
-> ResponseTimeout
-> ByteString
-> Maybe RequestTransform
-> ResolvedWebhook
-> m RequestDetails
mkRequest [Header]
headers ResponseTimeout
timeout ByteString
payload Maybe RequestTransform
mRequestTransform (ResolvedWebhook HeaderName
webhook) =
  let body :: Value
body = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
J.Null (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Maybe a
J.decode @J.Value ByteString
payload
   in case HeaderName -> Either HttpException Request
HTTP.mkRequestEither HeaderName
webhook of
        Left HttpException
excp -> TransformableRequestError a -> m RequestDetails
forall a. TransformableRequestError a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TransformableRequestError a -> m RequestDetails)
-> TransformableRequestError a -> m RequestDetails
forall a b. (a -> b) -> a -> b
$ Value -> HTTPErr a -> TransformableRequestError a
forall (a :: TriggerTypes).
Value -> HTTPErr a -> TransformableRequestError a
HTTPError Value
body (HttpException -> HTTPErr a
forall (a :: TriggerTypes). HttpException -> HTTPErr a
HClient (HttpException -> HTTPErr a) -> HttpException -> HTTPErr a
forall a b. (a -> b) -> a -> b
$ HttpException -> HttpException
HttpException HttpException
excp)
        Right Request
initReq ->
          let req :: Request
req =
                Request
initReq
                  Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request ByteString ByteString
-> ByteString -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request ByteString ByteString
Lens' Request ByteString
HTTP.method ByteString
"POST"
                  Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request [Header] [Header]
-> [Header] -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request [Header] [Header]
Lens' Request [Header]
HTTP.headers [Header]
headers
                  Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request RequestBody RequestBody
-> RequestBody -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request RequestBody RequestBody
Lens' Request RequestBody
HTTP.body (ByteString -> RequestBody
HTTP.RequestBodyLBS ByteString
payload)
                  Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request ResponseTimeout ResponseTimeout
-> ResponseTimeout -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request ResponseTimeout ResponseTimeout
Lens' Request ResponseTimeout
HTTP.timeout ResponseTimeout
timeout
              sessionVars :: Maybe SessionVariables
sessionVars = do
                Value
val <- forall a. FromJSON a => ByteString -> Maybe a
J.decode @J.Value ByteString
payload
                Value
varVal <- Getting (First Value) Value Value -> Value -> Maybe Value
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"event" Getting (First Value) Value Value
-> Getting (First Value) Value Value
-> Getting (First Value) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"session_variables") Value
val
                case forall a. FromJSON a => Value -> Result a
J.fromJSON @SessionVariables Value
varVal of
                  J.Success SessionVariables
sessionVars' -> SessionVariables -> Maybe SessionVariables
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SessionVariables
sessionVars'
                  Result SessionVariables
_ -> Maybe SessionVariables
forall a. Maybe a
Nothing
           in case Maybe RequestTransform
mRequestTransform of
                Maybe RequestTransform
Nothing ->
                  RequestDetails -> m RequestDetails
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestDetails -> m RequestDetails)
-> RequestDetails -> m RequestDetails
forall a b. (a -> b) -> a -> b
$ Request
-> Int64
-> Maybe Request
-> Maybe Int64
-> Maybe RequestContext
-> Maybe SessionVariables
-> RequestDetails
RequestDetails Request
req (ByteString -> Int64
LBS.length ByteString
payload) Maybe Request
forall a. Maybe a
Nothing Maybe Int64
forall a. Maybe a
Nothing Maybe RequestContext
forall a. Maybe a
Nothing Maybe SessionVariables
sessionVars
                Just Transform.RequestTransform {TemplatingEngine
Version
RequestFields (WithOptional TransformFn)
version :: Version
requestFields :: RequestFields (WithOptional TransformFn)
templateEngine :: TemplatingEngine
version :: RequestTransform -> Version
requestFields :: RequestTransform -> RequestFields (WithOptional TransformFn)
templateEngine :: RequestTransform -> TemplatingEngine
..} ->
                  let reqTransformCtx :: Request -> RequestTransformCtx
reqTransformCtx = HeaderName
-> Maybe SessionVariables
-> TemplatingEngine
-> Request
-> RequestTransformCtx
Transform.mkReqTransformCtx HeaderName
webhook Maybe SessionVariables
sessionVars TemplatingEngine
templateEngine
                      requestContext :: Request -> RequestContext
requestContext = (RequestTransformCtx -> RequestContext)
-> (Request -> RequestTransformCtx) -> Request -> RequestContext
forall a b. (a -> b) -> (Request -> a) -> Request -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RequestTransformCtx -> RequestContext
Transform.mkRequestContext Request -> RequestTransformCtx
reqTransformCtx
                   in case (Request -> RequestContext)
-> RequestFields (WithOptional TransformFn)
-> Request
-> Either TransformErrorBundle Request
forall (m :: * -> *).
MonadError TransformErrorBundle m =>
(Request -> RequestContext)
-> RequestFields (WithOptional TransformFn) -> Request -> m Request
Transform.applyRequestTransform Request -> RequestContext
requestContext RequestFields (WithOptional TransformFn)
requestFields Request
req of
                        Left TransformErrorBundle
err -> TransformableRequestError a -> m RequestDetails
forall a. TransformableRequestError a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TransformableRequestError a -> m RequestDetails)
-> TransformableRequestError a -> m RequestDetails
forall a b. (a -> b) -> a -> b
$ Value -> TransformErrorBundle -> TransformableRequestError a
forall (a :: TriggerTypes).
Value -> TransformErrorBundle -> TransformableRequestError a
TransformationError Value
body TransformErrorBundle
err
                        Right Request
transformedReq ->
                          let transformedReqSize :: Int64
transformedReqSize = Request -> Int64
HTTP.getReqSize Request
transformedReq
                           in RequestDetails -> m RequestDetails
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestDetails -> m RequestDetails)
-> RequestDetails -> m RequestDetails
forall a b. (a -> b) -> a -> b
$ Request
-> Int64
-> Maybe Request
-> Maybe Int64
-> Maybe RequestContext
-> Maybe SessionVariables
-> RequestDetails
RequestDetails Request
req (ByteString -> Int64
LBS.length ByteString
payload) (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
transformedReq) (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
transformedReqSize) (RequestContext -> Maybe RequestContext
forall a. a -> Maybe a
Just (RequestContext -> Maybe RequestContext)
-> RequestContext -> Maybe RequestContext
forall a b. (a -> b) -> a -> b
$ Request -> RequestContext
requestContext Request
req) Maybe SessionVariables
sessionVars

invokeRequest ::
  ( MonadReader r m,
    MonadError (TransformableRequestError a) m,
    Has HTTP.Manager r,
    Has (Logger Hasura) r,
    MonadIO m,
    MonadTrace m
  ) =>
  RequestDetails ->
  Maybe Transform.ResponseTransform ->
  Maybe SessionVariables ->
  ((Either (HTTPErr a) (HTTPResp a)) -> RequestDetails -> m ()) ->
  m (HTTPResp a)
invokeRequest :: forall r (m :: * -> *) (a :: TriggerTypes).
(MonadReader r m, MonadError (TransformableRequestError a) m,
 Has Manager r, Has (Logger Hasura) r, MonadIO m, MonadTrace m) =>
RequestDetails
-> Maybe ResponseTransform
-> Maybe SessionVariables
-> (Either (HTTPErr a) (HTTPResp a) -> RequestDetails -> m ())
-> m (HTTPResp a)
invokeRequest reqDetails :: RequestDetails
reqDetails@RequestDetails {Int64
Maybe Int64
Maybe Request
Maybe SessionVariables
Maybe RequestContext
Request
_rdOriginalRequest :: RequestDetails -> Request
_rdOriginalSize :: RequestDetails -> Int64
_rdTransformedRequest :: RequestDetails -> Maybe Request
_rdTransformedSize :: RequestDetails -> Maybe Int64
_rdReqTransformCtx :: RequestDetails -> Maybe RequestContext
_rdSessionVars :: RequestDetails -> Maybe SessionVariables
_rdOriginalRequest :: Request
_rdOriginalSize :: Int64
_rdTransformedRequest :: Maybe Request
_rdTransformedSize :: Maybe Int64
_rdReqTransformCtx :: Maybe RequestContext
_rdSessionVars :: Maybe SessionVariables
..} Maybe ResponseTransform
respTransform' Maybe SessionVariables
sessionVars Either (HTTPErr a) (HTTPResp a) -> RequestDetails -> m ()
logger = do
  let finalReq :: Request
finalReq = Request -> Maybe Request -> Request
forall a. a -> Maybe a -> a
fromMaybe Request
_rdOriginalRequest Maybe Request
_rdTransformedRequest
      reqBody :: Value
reqBody = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
J.Null (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Getting (First ByteString) Request ByteString
-> Request -> Maybe ByteString
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((RequestBody -> Const (First ByteString) RequestBody)
-> Request -> Const (First ByteString) Request
Lens' Request RequestBody
HTTP.body ((RequestBody -> Const (First ByteString) RequestBody)
 -> Request -> Const (First ByteString) Request)
-> ((ByteString -> Const (First ByteString) ByteString)
    -> RequestBody -> Const (First ByteString) RequestBody)
-> Getting (First ByteString) Request ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const (First ByteString) ByteString)
-> RequestBody -> Const (First ByteString) RequestBody
Prism' RequestBody ByteString
HTTP._RequestBodyLBS) Request
finalReq Maybe ByteString -> (ByteString -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FromJSON a => ByteString -> Maybe a
J.decode @J.Value
  Manager
manager <- (r -> Manager) -> m Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Manager
forall a t. Has a t => t -> a
getter
  -- Perform the HTTP Request
  Either (HTTPErr a) (HTTPResp a)
eitherResp <- Request
-> (Request -> m (Either (HTTPErr a) (HTTPResp a)))
-> m (Either (HTTPErr a) (HTTPResp a))
forall (m :: * -> *) a.
(MonadIO m, MonadTrace m) =>
Request -> (Request -> m a) -> m a
traceHTTPRequest Request
finalReq ((Request -> m (Either (HTTPErr a) (HTTPResp a)))
 -> m (Either (HTTPErr a) (HTTPResp a)))
-> (Request -> m (Either (HTTPErr a) (HTTPResp a)))
-> m (Either (HTTPErr a) (HTTPResp a))
forall a b. (a -> b) -> a -> b
$ Manager -> Request -> m (Either (HTTPErr a) (HTTPResp a))
forall (m :: * -> *) (a :: TriggerTypes).
MonadIO m =>
Manager -> Request -> m (Either (HTTPErr a) (HTTPResp a))
runHTTP Manager
manager
  -- Log the result along with the pre/post transformation Request data
  Either (HTTPErr a) (HTTPResp a) -> RequestDetails -> m ()
logger Either (HTTPErr a) (HTTPResp a)
eitherResp RequestDetails
reqDetails
  HTTPResp a
resp <- Either (HTTPErr a) (HTTPResp a)
eitherResp Either (HTTPErr a) (HTTPResp a)
-> (HTTPErr a -> m (HTTPResp a)) -> m (HTTPResp a)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` (TransformableRequestError a -> m (HTTPResp a)
forall a. TransformableRequestError a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TransformableRequestError a -> m (HTTPResp a))
-> (HTTPErr a -> TransformableRequestError a)
-> HTTPErr a
-> m (HTTPResp a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> HTTPErr a -> TransformableRequestError a
forall (a :: TriggerTypes).
Value -> HTTPErr a -> TransformableRequestError a
HTTPError Value
reqBody)
  case Maybe ResponseTransform
respTransform' of
    Maybe ResponseTransform
Nothing -> HTTPResp a -> m (HTTPResp a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HTTPResp a
resp
    Just ResponseTransform
respTransform -> do
      let respBody :: ByteString
respBody = SerializableBlob -> ByteString
SB.toLBS (SerializableBlob -> ByteString) -> SerializableBlob -> ByteString
forall a b. (a -> b) -> a -> b
$ HTTPResp a -> SerializableBlob
forall (a :: TriggerTypes). HTTPResp a -> SerializableBlob
hrsBody HTTPResp a
resp
          engine :: TemplatingEngine
engine = ResponseTransform -> TemplatingEngine
Transform.respTransformTemplateEngine ResponseTransform
respTransform
          respTransformCtx :: ResponseTransformCtx
respTransformCtx = Maybe RequestContext
-> Maybe SessionVariables
-> TemplatingEngine
-> ByteString
-> Int
-> ResponseTransformCtx
Transform.buildRespTransformCtx Maybe RequestContext
_rdReqTransformCtx Maybe SessionVariables
sessionVars TemplatingEngine
engine ByteString
respBody (HTTPResp a -> Int
forall (a :: TriggerTypes). HTTPResp a -> Int
hrsStatus HTTPResp a
resp)
       in case ResponseTransform
-> ResponseTransformCtx -> Either TransformErrorBundle ByteString
Transform.applyResponseTransform ResponseTransform
respTransform ResponseTransformCtx
respTransformCtx of
            Left TransformErrorBundle
err -> do
              -- Log The Response Transformation Error
              Logger Hasura
logger' :: Logger Hasura <- (r -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Logger Hasura
forall a t. Has a t => t -> a
getter
              Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
unLogger Logger Hasura
logger' (UnstructuredLog -> m ()) -> UnstructuredLog -> m ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> SerializableBlob -> UnstructuredLog
UnstructuredLog LogLevel
LevelError (ByteString -> SerializableBlob
SB.fromLBS (ByteString -> SerializableBlob) -> ByteString -> SerializableBlob
forall a b. (a -> b) -> a -> b
$ TransformErrorBundle -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode TransformErrorBundle
err)
              -- Throw an exception with the Transformation Error
              TransformableRequestError a -> m (HTTPResp a)
forall a. TransformableRequestError a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TransformableRequestError a -> m (HTTPResp a))
-> TransformableRequestError a -> m (HTTPResp a)
forall a b. (a -> b) -> a -> b
$ Value -> HTTPErr a -> TransformableRequestError a
forall (a :: TriggerTypes).
Value -> HTTPErr a -> TransformableRequestError a
HTTPError Value
reqBody (HTTPErr a -> TransformableRequestError a)
-> HTTPErr a -> TransformableRequestError a
forall a b. (a -> b) -> a -> b
$ String -> HTTPErr a
forall (a :: TriggerTypes). String -> HTTPErr a
HOther (String -> HTTPErr a) -> String -> HTTPErr a
forall a b. (a -> b) -> a -> b
$ HeaderName -> String
T.unpack (HeaderName -> String) -> HeaderName -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> HeaderName
TE.decodeUtf8 (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ TransformErrorBundle -> Value
forall a. ToJSON a => a -> Value
J.toJSON TransformErrorBundle
err
            Right ByteString
transformedBody -> HTTPResp a -> m (HTTPResp a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HTTPResp a -> m (HTTPResp a)) -> HTTPResp a -> m (HTTPResp a)
forall a b. (a -> b) -> a -> b
$ HTTPResp a
resp {hrsBody :: SerializableBlob
hrsBody = ByteString -> SerializableBlob
SB.fromLBS ByteString
transformedBody}

mkResp :: Int -> SB.SerializableBlob -> [HeaderConf] -> Response a
mkResp :: forall (a :: TriggerTypes).
Int -> SerializableBlob -> [HeaderConf] -> Response a
mkResp Int
status SerializableBlob
payload [HeaderConf]
headers =
  let wr :: WebhookResponse
wr = SerializableBlob -> [HeaderConf] -> Int -> WebhookResponse
WebhookResponse SerializableBlob
payload [HeaderConf]
headers Int
status
   in WebhookResponse -> Response a
forall (a :: TriggerTypes). WebhookResponse -> Response a
ResponseHTTP WebhookResponse
wr

mkClientErr :: SB.SerializableBlob -> Response a
mkClientErr :: forall (a :: TriggerTypes). SerializableBlob -> Response a
mkClientErr SerializableBlob
message =
  let cerr :: ClientError
cerr = SerializableBlob -> ClientError
ClientError SerializableBlob
message
   in ClientError -> Response a
forall (a :: TriggerTypes). ClientError -> Response a
ResponseError ClientError
cerr

mkWebhookReq :: J.Value -> [HeaderConf] -> InvocationVersion -> WebhookRequest
mkWebhookReq :: Value -> [HeaderConf] -> HeaderName -> WebhookRequest
mkWebhookReq Value
payload [HeaderConf]
headers = Value -> [HeaderConf] -> HeaderName -> WebhookRequest
WebhookRequest Value
payload [HeaderConf]
headers

mkInvocationResp :: Maybe Int -> SB.SerializableBlob -> [HeaderConf] -> Response a
mkInvocationResp :: forall (a :: TriggerTypes).
Maybe Int -> SerializableBlob -> [HeaderConf] -> Response a
mkInvocationResp Maybe Int
statusMaybe SerializableBlob
responseBody [HeaderConf]
responseHeaders =
  case Maybe Int
statusMaybe of
    Maybe Int
Nothing -> SerializableBlob -> Response a
forall (a :: TriggerTypes). SerializableBlob -> Response a
mkClientErr SerializableBlob
responseBody
    Just Int
status ->
      if Int -> Bool
isClientError Int
status
        then SerializableBlob -> Response a
forall (a :: TriggerTypes). SerializableBlob -> Response a
mkClientErr SerializableBlob
responseBody
        else Int -> SerializableBlob -> [HeaderConf] -> Response a
forall (a :: TriggerTypes).
Int -> SerializableBlob -> [HeaderConf] -> Response a
mkResp Int
status SerializableBlob
responseBody [HeaderConf]
responseHeaders

isClientError :: Int -> Bool
isClientError :: Int -> Bool
isClientError Int
status = Int
status Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300

encodeHeader :: EventHeaderInfo -> HTTP.Header
encodeHeader :: EventHeaderInfo -> Header
encodeHeader (EventHeaderInfo HeaderConf
hconf HeaderName
cache) =
  let (HeaderConf HeaderName
name HeaderValue
_) = HeaderConf
hconf
      ciname :: CI ByteString
ciname = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
TE.encodeUtf8 HeaderName
name
      value :: ByteString
value = HeaderName -> ByteString
TE.encodeUtf8 HeaderName
cache
   in (CI ByteString
ciname, ByteString
value)

decodeHeader ::
  [EventHeaderInfo] ->
  (HTTP.HeaderName, BS.ByteString) ->
  HeaderConf
decodeHeader :: [EventHeaderInfo] -> Header -> HeaderConf
decodeHeader [EventHeaderInfo]
headerInfos (CI ByteString
hdrName, ByteString
hdrVal) =
  let name :: HeaderName
name = ByteString -> HeaderName
decodeBS (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
hdrName
      getName :: EventHeaderInfo -> HeaderName
getName EventHeaderInfo
ehi =
        let (HeaderConf HeaderName
name' HeaderValue
_) = EventHeaderInfo -> HeaderConf
ehiHeaderConf EventHeaderInfo
ehi
         in HeaderName
name'
      mehi :: Maybe EventHeaderInfo
mehi = (EventHeaderInfo -> Bool)
-> [EventHeaderInfo] -> Maybe EventHeaderInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\EventHeaderInfo
hi -> EventHeaderInfo -> HeaderName
getName EventHeaderInfo
hi HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name) [EventHeaderInfo]
headerInfos
   in case Maybe EventHeaderInfo
mehi of
        Maybe EventHeaderInfo
Nothing -> HeaderName -> HeaderValue -> HeaderConf
HeaderConf HeaderName
name (Template -> HeaderValue
HVValue (Template -> HeaderValue) -> Template -> HeaderValue
forall a b. (a -> b) -> a -> b
$ HeaderName -> Template
mkPlainTemplate (ByteString -> HeaderName
decodeBS ByteString
hdrVal))
        Just EventHeaderInfo
ehi -> EventHeaderInfo -> HeaderConf
ehiHeaderConf EventHeaderInfo
ehi
  where
    decodeBS :: ByteString -> HeaderName
decodeBS = OnDecodeError -> ByteString -> HeaderName
TE.decodeUtf8With OnDecodeError
TE.lenientDecode

-- | Encodes given request headers along with our 'defaultHeaders' and returns
-- them along with the re-decoded set of headers (for logging purposes).
prepareHeaders ::
  [EventHeaderInfo] ->
  ([HTTP.Header], [HeaderConf])
prepareHeaders :: [EventHeaderInfo] -> ([Header], [HeaderConf])
prepareHeaders [EventHeaderInfo]
headerInfos = ([Header]
headers, [HeaderConf]
logHeaders)
  where
    encodedHeaders :: [Header]
encodedHeaders = (EventHeaderInfo -> Header) -> [EventHeaderInfo] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map EventHeaderInfo -> Header
encodeHeader [EventHeaderInfo]
headerInfos
    headers :: [Header]
headers = [Header] -> [Header]
addDefaultHeaders [Header]
encodedHeaders
    logHeaders :: [HeaderConf]
logHeaders = (Header -> HeaderConf) -> [Header] -> [HeaderConf]
forall a b. (a -> b) -> [a] -> [b]
map ([EventHeaderInfo] -> Header -> HeaderConf
decodeHeader [EventHeaderInfo]
headerInfos) [Header]
headers

getRetryAfterHeaderFromHTTPErr :: HTTPErr a -> Maybe Text
getRetryAfterHeaderFromHTTPErr :: forall (a :: TriggerTypes). HTTPErr a -> Maybe HeaderName
getRetryAfterHeaderFromHTTPErr (HStatus HTTPResp a
resp) = HTTPResp a -> Maybe HeaderName
forall (a :: TriggerTypes). HTTPResp a -> Maybe HeaderName
getRetryAfterHeaderFromResp HTTPResp a
resp
getRetryAfterHeaderFromHTTPErr HTTPErr a
_ = Maybe HeaderName
forall a. Maybe a
Nothing

getRetryAfterHeaderFromResp :: HTTPResp a -> Maybe Text
getRetryAfterHeaderFromResp :: forall (a :: TriggerTypes). HTTPResp a -> Maybe HeaderName
getRetryAfterHeaderFromResp HTTPResp a
resp =
  let mHeader :: Maybe HeaderConf
mHeader =
        (HeaderConf -> Bool) -> [HeaderConf] -> Maybe HeaderConf
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
          (\(HeaderConf HeaderName
name HeaderValue
_) -> HeaderName -> CI HeaderName
forall s. FoldCase s => s -> CI s
CI.mk HeaderName
name CI HeaderName -> CI HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== CI HeaderName
retryAfterHeader)
          (HTTPResp a -> [HeaderConf]
forall (a :: TriggerTypes). HTTPResp a -> [HeaderConf]
hrsHeaders HTTPResp a
resp)
   in case Maybe HeaderConf
mHeader of
        Just (HeaderConf HeaderName
_ (HVValue Template
value)) -> HeaderName -> Maybe HeaderName
forall a. a -> Maybe a
Just (HeaderName -> Maybe HeaderName) -> HeaderName -> Maybe HeaderName
forall a b. (a -> b) -> a -> b
$ Template -> HeaderName
printTemplate Template
value
        Maybe HeaderConf
_ -> Maybe HeaderName
forall a. Maybe a
Nothing

parseRetryHeaderValue :: Text -> Maybe Int
parseRetryHeaderValue :: HeaderName -> Maybe Int
parseRetryHeaderValue HeaderName
hValue =
  let seconds :: Maybe Int
seconds = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ HeaderName -> String
T.unpack HeaderName
hValue
   in case Maybe Int
seconds of
        Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing
        Just Int
sec ->
          if Int
sec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
sec
            else Maybe Int
forall a. Maybe a
Nothing