{-# LANGUAGE TemplateHaskell #-}

-- |
--  = 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 (..),
    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, view, (.~))
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as J
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Lens
import Data.Aeson.TH
import Data.ByteString qualified as BS
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 Hasura.HTTP (HttpException (..), addDefaultHeaders)
import Hasura.Logging
import Hasura.Prelude
import Hasura.RQL.DDL.Headers
import Hasura.RQL.DDL.Webhook.Transform
import Hasura.RQL.DDL.Webhook.Transform.Class (mkReqTransformCtx)
import Hasura.RQL.Types.Common (ResolvedWebhook (..))
import Hasura.RQL.Types.EventTrigger
import Hasura.RQL.Types.Eventing
import Hasura.Session (SessionVariables)
import Hasura.Tracing
import Network.HTTP.Client.Transformable qualified as HTTP

retryAfterHeader :: CI.CI Text
retryAfterHeader :: CI Text
retryAfterHeader = CI Text
"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
showList :: [ExtraLogContext] -> ShowS
$cshowList :: [ExtraLogContext] -> ShowS
show :: ExtraLogContext -> String
$cshow :: ExtraLogContext -> String
showsPrec :: Int -> ExtraLogContext -> ShowS
$cshowsPrec :: Int -> ExtraLogContext -> ShowS
Show, ExtraLogContext -> ExtraLogContext -> Bool
(ExtraLogContext -> ExtraLogContext -> Bool)
-> (ExtraLogContext -> ExtraLogContext -> Bool)
-> Eq ExtraLogContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtraLogContext -> ExtraLogContext -> Bool
$c/= :: ExtraLogContext -> ExtraLogContext -> Bool
== :: ExtraLogContext -> ExtraLogContext -> Bool
$c== :: ExtraLogContext -> ExtraLogContext -> Bool
Eq)

data HTTPResp (a :: TriggerTypes) = HTTPResp
  { HTTPResp a -> Int
hrsStatus :: !Int,
    HTTPResp a -> [HeaderConf]
hrsHeaders :: ![HeaderConf],
    HTTPResp a -> SerializableBlob
hrsBody :: !SB.SerializableBlob,
    HTTPResp a -> Int64
hrsSize :: !Int64
  }
  deriving (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
showList :: [HTTPResp a] -> ShowS
$cshowList :: forall (a :: TriggerTypes). [HTTPResp a] -> ShowS
show :: HTTPResp a -> String
$cshow :: forall (a :: TriggerTypes). HTTPResp a -> String
showsPrec :: Int -> HTTPResp a -> ShowS
$cshowsPrec :: forall (a :: TriggerTypes). Int -> HTTPResp a -> ShowS
Show)

$(deriveToJSON hasuraJSON {omitNothingFields = True} ''HTTPResp)

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
showList :: [HTTPErr a] -> ShowS
$cshowList :: forall (a :: TriggerTypes). [HTTPErr a] -> ShowS
show :: HTTPErr a -> String
$cshow :: forall (a :: TriggerTypes). HTTPErr a -> String
showsPrec :: Int -> HTTPErr a -> ShowS
$cshowsPrec :: forall (a :: TriggerTypes). Int -> HTTPErr a -> ShowS
Show)

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

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 :: Response ByteString -> HTTPResp a
mkHTTPResp Response ByteString
resp =
  HTTPResp :: forall (a :: TriggerTypes).
Int -> [HeaderConf] -> SerializableBlob -> Int64 -> HTTPResp a
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 = ((CI ByteString, ByteString) -> HeaderConf)
-> [(CI ByteString, ByteString)] -> [HeaderConf]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> HeaderConf
decodeHeader ([(CI ByteString, ByteString)] -> [HeaderConf])
-> [(CI ByteString, ByteString)] -> [HeaderConf]
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [(CI ByteString, ByteString)]
forall body. Response body -> [(CI ByteString, ByteString)]
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 -> Text
decodeBS = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode
    decodeHeader :: (CI ByteString, ByteString) -> HeaderConf
decodeHeader (CI ByteString
hdrName, ByteString
hdrVal) =
      Text -> HeaderValue -> HeaderConf
HeaderConf (ByteString -> Text
decodeBS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
hdrName) (Text -> HeaderValue
HVValue (ByteString -> Text
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 RequestTransformCtx
_rdReqTransformCtx :: Maybe RequestTransformCtx,
    RequestDetails -> Maybe SessionVariables
_rdSessionVars :: Maybe SessionVariables
  }

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

$(deriveToJSON hasuraJSON ''RequestDetails)

data HTTPRespExtra (a :: TriggerTypes) = HTTPRespExtra
  { HTTPRespExtra a -> Either (HTTPErr a) (HTTPResp a)
_hreResponse :: !(Either (HTTPErr a) (HTTPResp a)),
    HTTPRespExtra a -> ExtraLogContext
_hreContext :: !ExtraLogContext,
    HTTPRespExtra a -> RequestDetails
_hreRequest :: !RequestDetails,
    HTTPRespExtra a -> Text
_hreWebhookVarName :: !Text,
    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 Text
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
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
J..= RequestDetails -> Value
sanitiseReqJSON RequestDetails
req,
            Key
"event_id" Key -> EventId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
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
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
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
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
J..= TriggerName
name]
        Maybe TriggerName
Nothing -> []
      getValue :: HeaderValue -> Value
getValue HeaderValue
val = case HeaderValue
val of
        HVValue Text
txt -> Text -> Value
J.String Text
txt
        HVEnv Text
txt -> Text -> Value
J.String Text
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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(HeaderConf Text
name HeaderValue
val) -> Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (Text -> Key
J.fromText Text
name) (HeaderValue -> Value
getValue HeaderValue
val)) Object
forall a. Monoid a => a
mempty [HeaderConf]
logHeaders
      updateReqDetail :: RequestDetails -> Text -> Value
updateReqDetail RequestDetails
v Text
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
& Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
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
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"url" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Value
J.String Text
webhookVarName
            redactedReq :: Value
redactedReq = Value
webhookRedactedReq Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
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
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"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 -> Text -> Value
updateReqDetail RequestDetails
v Text
"original_request"
        Just Request
_ -> RequestDetails -> Text -> Value
updateReqDetail RequestDetails
v Text
"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 :: 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return HTTPResp a
httpResp
    else HTTPErr a -> Either (HTTPErr a) (HTTPResp 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
showList :: [HTTPReq] -> ShowS
$cshowList :: [HTTPReq] -> ShowS
show :: HTTPReq -> String
$cshow :: HTTPReq -> String
showsPrec :: Int -> HTTPReq -> ShowS
$cshowsPrec :: Int -> HTTPReq -> ShowS
Show, HTTPReq -> HTTPReq -> Bool
(HTTPReq -> HTTPReq -> Bool)
-> (HTTPReq -> HTTPReq -> Bool) -> Eq HTTPReq
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HTTPReq -> HTTPReq -> Bool
$c/= :: HTTPReq -> HTTPReq -> Bool
== :: HTTPReq -> HTTPReq -> Bool
$c== :: HTTPReq -> HTTPReq -> Bool
Eq)

$(deriveJSON hasuraJSON {omitNothingFields = True} ''HTTPReq)

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 :: Either (HTTPErr 'EventType) (HTTPResp 'EventType)
-> ExtraLogContext
-> RequestDetails
-> Text
-> [HeaderConf]
-> m ()
logHTTPForET Either (HTTPErr 'EventType) (HTTPResp 'EventType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails Text
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
-> Text
-> [HeaderConf]
-> HTTPRespExtra 'EventType
forall (a :: TriggerTypes).
Either (HTTPErr a) (HTTPResp a)
-> ExtraLogContext
-> RequestDetails
-> Text
-> [HeaderConf]
-> HTTPRespExtra a
HTTPRespExtra Either (HTTPErr 'EventType) (HTTPResp 'EventType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails Text
webhookVarName [HeaderConf]
logHeaders

logHTTPForST ::
  ( MonadReader r m,
    Has (Logger Hasura) r,
    MonadIO m
  ) =>
  Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType) ->
  ExtraLogContext ->
  RequestDetails ->
  Text ->
  [HeaderConf] ->
  m ()
logHTTPForST :: Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
-> ExtraLogContext
-> RequestDetails
-> Text
-> [HeaderConf]
-> m ()
logHTTPForST Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails Text
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
-> Text
-> [HeaderConf]
-> HTTPRespExtra 'ScheduledType
forall (a :: TriggerTypes).
Either (HTTPErr a) (HTTPResp a)
-> ExtraLogContext
-> RequestDetails
-> Text
-> [HeaderConf]
-> HTTPRespExtra a
HTTPRespExtra Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
eitherResp ExtraLogContext
extraLogCtx RequestDetails
reqDetails Text
webhookVarName [HeaderConf]
logHeaders

runHTTP :: (MonadIO m) => HTTP.Manager -> HTTP.Request -> m (Either (HTTPErr a) (HTTPResp a))
runHTTP :: 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 (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.performRequest Request
req Manager
manager
  Either (HTTPErr a) (HTTPResp a)
-> m (Either (HTTPErr a) (HTTPResp 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 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
showList :: [TransformableRequestError a] -> ShowS
$cshowList :: forall (a :: TriggerTypes). [TransformableRequestError a] -> ShowS
show :: TransformableRequestError a -> String
$cshow :: forall (a :: TriggerTypes). TransformableRequestError a -> String
showsPrec :: Int -> TransformableRequestError a -> ShowS
$cshowsPrec :: forall (a :: TriggerTypes).
Int -> 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 RequestTransform ->
  ResolvedWebhook ->
  m RequestDetails
mkRequest :: [(CI ByteString, ByteString)]
-> ResponseTimeout
-> ByteString
-> Maybe RequestTransform
-> ResolvedWebhook
-> m RequestDetails
mkRequest [(CI ByteString, ByteString)]
headers ResponseTimeout
timeout ByteString
payload Maybe RequestTransform
mRequestTransform (ResolvedWebhook Text
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
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
J.decode @J.Value ByteString
payload
   in case Text -> Either HttpException Request
HTTP.mkRequestEither Text
webhook of
        Left HttpException
excp -> TransformableRequestError a -> m RequestDetails
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
  [(CI ByteString, ByteString)]
  [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)] -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Request
  Request
  [(CI ByteString, ByteString)]
  [(CI ByteString, ByteString)]
Lens' Request [(CI ByteString, ByteString)]
HTTP.headers [(CI ByteString, ByteString)]
headers
                  Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request (Maybe ByteString) (Maybe ByteString)
-> Maybe ByteString -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request (Maybe ByteString) (Maybe ByteString)
Lens' Request (Maybe ByteString)
HTTP.body (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just 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 <- ByteString -> Maybe Value
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 (Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"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
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"session_variables") Value
val
                case Value -> Result SessionVariables
forall a. FromJSON a => Value -> Result a
J.fromJSON @SessionVariables Value
varVal of
                  J.Success SessionVariables
sessionVars' -> SessionVariables -> Maybe SessionVariables
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 (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 RequestTransformCtx
-> 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 RequestTransformCtx
forall a. Maybe a
Nothing Maybe SessionVariables
sessionVars
                Just RequestTransform {Version
TemplatingEngine
RequestFields (WithOptional TransformFn)
templateEngine :: RequestTransform -> TemplatingEngine
requestFields :: RequestTransform -> RequestFields (WithOptional TransformFn)
version :: RequestTransform -> Version
templateEngine :: TemplatingEngine
requestFields :: RequestFields (WithOptional TransformFn)
version :: Version
..} ->
                  let reqTransformCtx :: Request -> RequestTransformCtx
reqTransformCtx = Text
-> Maybe SessionVariables
-> TemplatingEngine
-> Request
-> RequestTransformCtx
mkReqTransformCtx Text
webhook Maybe SessionVariables
sessionVars TemplatingEngine
templateEngine
                   in case (Request -> RequestTransformCtx)
-> RequestFields (WithOptional TransformFn)
-> Request
-> Either TransformErrorBundle Request
forall (m :: * -> *).
MonadError TransformErrorBundle m =>
(Request -> RequestTransformCtx)
-> RequestFields (WithOptional TransformFn) -> Request -> m Request
applyRequestTransform Request -> RequestTransformCtx
reqTransformCtx RequestFields (WithOptional TransformFn)
requestFields Request
req of
                        Left TransformErrorBundle
err -> TransformableRequestError a -> m RequestDetails
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 (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 RequestTransformCtx
-> 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) (RequestTransformCtx -> Maybe RequestTransformCtx
forall a. a -> Maybe a
Just (RequestTransformCtx -> Maybe RequestTransformCtx)
-> RequestTransformCtx -> Maybe RequestTransformCtx
forall a b. (a -> b) -> a -> b
$ Request -> RequestTransformCtx
reqTransformCtx 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 ResponseTransform ->
  Maybe SessionVariables ->
  ((Either (HTTPErr a) (HTTPResp a)) -> RequestDetails -> m ()) ->
  m (HTTPResp a)
invokeRequest :: 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 RequestTransformCtx
Request
_rdSessionVars :: Maybe SessionVariables
_rdReqTransformCtx :: Maybe RequestTransformCtx
_rdTransformedSize :: Maybe Int64
_rdTransformedRequest :: Maybe Request
_rdOriginalSize :: Int64
_rdOriginalRequest :: Request
_rdSessionVars :: RequestDetails -> Maybe SessionVariables
_rdReqTransformCtx :: RequestDetails -> Maybe RequestTransformCtx
_rdTransformedSize :: RequestDetails -> Maybe Int64
_rdTransformedRequest :: RequestDetails -> Maybe Request
_rdOriginalSize :: RequestDetails -> Int64
_rdOriginalRequest :: RequestDetails -> Request
..} 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 (Maybe ByteString) Request (Maybe ByteString)
-> Request -> Maybe ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe ByteString) Request (Maybe ByteString)
Lens' Request (Maybe ByteString)
HTTP.body Request
finalReq Maybe ByteString -> (ByteString -> Maybe Value) -> Maybe Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FromJSON Value => ByteString -> Maybe Value
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.
MonadTrace m =>
Request -> (Request -> m a) -> m a
tracedHttpRequest 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 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 (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
respTransformTemplateEngine ResponseTransform
respTransform
          respTransformCtx :: ResponseTransformCtx
respTransformCtx = Maybe RequestTransformCtx
-> Maybe SessionVariables
-> TemplatingEngine
-> ByteString
-> ResponseTransformCtx
buildRespTransformCtx Maybe RequestTransformCtx
_rdReqTransformCtx Maybe SessionVariables
sessionVars TemplatingEngine
engine ByteString
respBody
       in case ResponseTransform
-> ResponseTransformCtx -> Either TransformErrorBundle ByteString
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 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
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
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 (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 :: 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 :: 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] -> Text -> WebhookRequest
mkWebhookReq Value
payload [HeaderConf]
headers = Value -> [HeaderConf] -> Text -> WebhookRequest
WebhookRequest Value
payload [HeaderConf]
headers

mkInvocationResp :: Maybe Int -> SB.SerializableBlob -> [HeaderConf] -> Response a
mkInvocationResp :: 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 -> (CI ByteString, ByteString)
encodeHeader (EventHeaderInfo HeaderConf
hconf Text
cache) =
  let (HeaderConf Text
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
$ Text -> ByteString
TE.encodeUtf8 Text
name
      value :: ByteString
value = Text -> ByteString
TE.encodeUtf8 Text
cache
   in (CI ByteString
ciname, ByteString
value)

decodeHeader ::
  [EventHeaderInfo] ->
  (HTTP.HeaderName, BS.ByteString) ->
  HeaderConf
decodeHeader :: [EventHeaderInfo] -> (CI ByteString, ByteString) -> HeaderConf
decodeHeader [EventHeaderInfo]
headerInfos (CI ByteString
hdrName, ByteString
hdrVal) =
  let name :: Text
name = ByteString -> Text
decodeBS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
hdrName
      getName :: EventHeaderInfo -> Text
getName EventHeaderInfo
ehi =
        let (HeaderConf Text
name' HeaderValue
_) = EventHeaderInfo -> HeaderConf
ehiHeaderConf EventHeaderInfo
ehi
         in Text
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 -> Text
getName EventHeaderInfo
hi Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) [EventHeaderInfo]
headerInfos
   in case Maybe EventHeaderInfo
mehi of
        Maybe EventHeaderInfo
Nothing -> Text -> HeaderValue -> HeaderConf
HeaderConf Text
name (Text -> HeaderValue
HVValue (ByteString -> Text
decodeBS ByteString
hdrVal))
        Just EventHeaderInfo
ehi -> EventHeaderInfo -> HeaderConf
ehiHeaderConf EventHeaderInfo
ehi
  where
    decodeBS :: ByteString -> Text
decodeBS = OnDecodeError -> ByteString -> Text
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] -> ([(CI ByteString, ByteString)], [HeaderConf])
prepareHeaders [EventHeaderInfo]
headerInfos = ([(CI ByteString, ByteString)]
headers, [HeaderConf]
logHeaders)
  where
    encodedHeaders :: [(CI ByteString, ByteString)]
encodedHeaders = (EventHeaderInfo -> (CI ByteString, ByteString))
-> [EventHeaderInfo] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map EventHeaderInfo -> (CI ByteString, ByteString)
encodeHeader [EventHeaderInfo]
headerInfos
    headers :: [(CI ByteString, ByteString)]
headers = [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
addDefaultHeaders [(CI ByteString, ByteString)]
encodedHeaders
    logHeaders :: [HeaderConf]
logHeaders = ((CI ByteString, ByteString) -> HeaderConf)
-> [(CI ByteString, ByteString)] -> [HeaderConf]
forall a b. (a -> b) -> [a] -> [b]
map ([EventHeaderInfo] -> (CI ByteString, ByteString) -> HeaderConf
decodeHeader [EventHeaderInfo]
headerInfos) [(CI ByteString, ByteString)]
headers

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

getRetryAfterHeaderFromResp :: HTTPResp a -> Maybe Text
getRetryAfterHeaderFromResp :: HTTPResp a -> Maybe Text
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 Text
name HeaderValue
_) -> Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk Text
name CI Text -> CI Text -> Bool
forall a. Eq a => a -> a -> Bool
== CI Text
retryAfterHeader)
          (HTTPResp a -> [HeaderConf]
forall (a :: TriggerTypes). HTTPResp a -> [HeaderConf]
hrsHeaders HTTPResp a
resp)
   in case Maybe HeaderConf
mHeader of
        Just (HeaderConf Text
_ (HVValue Text
value)) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
value
        Maybe HeaderConf
_ -> Maybe Text
forall a. Maybe a
Nothing

parseRetryHeaderValue :: Text -> Maybe Int
parseRetryHeaderValue :: Text -> Maybe Int
parseRetryHeaderValue Text
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
$ Text -> String
T.unpack Text
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