2021-09-24 01:56:37 +03:00
|
|
|
-- |
|
|
|
|
-- = 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.
|
2020-05-13 15:33:16 +03:00
|
|
|
module Hasura.Eventing.HTTP
|
2021-09-24 01:56:37 +03:00
|
|
|
( HTTPErr (..),
|
|
|
|
HTTPResp (..),
|
|
|
|
runHTTP,
|
|
|
|
isNetworkError,
|
|
|
|
isNetworkErrorHC,
|
|
|
|
logHTTPForET,
|
|
|
|
logHTTPForST,
|
|
|
|
ExtraLogContext (..),
|
|
|
|
RequestDetails (..),
|
|
|
|
EventId,
|
|
|
|
InvocationVersion,
|
|
|
|
Response (..),
|
|
|
|
WebhookRequest (..),
|
|
|
|
WebhookResponse (..),
|
|
|
|
ClientError (..),
|
|
|
|
isClientError,
|
|
|
|
mkClientErr,
|
|
|
|
mkWebhookReq,
|
|
|
|
mkResp,
|
|
|
|
mkInvocationResp,
|
|
|
|
LogBehavior (..),
|
|
|
|
ResponseLogBehavior (..),
|
|
|
|
HeaderLogBehavior (..),
|
|
|
|
prepareHeaders,
|
|
|
|
getRetryAfterHeaderFromHTTPErr,
|
|
|
|
getRetryAfterHeaderFromResp,
|
|
|
|
parseRetryHeaderValue,
|
|
|
|
invocationVersionET,
|
|
|
|
invocationVersionST,
|
|
|
|
mkRequest,
|
|
|
|
invokeRequest,
|
|
|
|
)
|
|
|
|
where
|
|
|
|
|
|
|
|
import Control.Exception (try)
|
2021-09-29 11:13:30 +03:00
|
|
|
import Control.Lens (preview, set)
|
|
|
|
import Data.Aeson qualified as J
|
|
|
|
import Data.Aeson.Lens
|
2021-09-24 01:56:37 +03:00
|
|
|
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.HashMap.Lazy qualified as HML
|
|
|
|
import Data.Int (Int64)
|
|
|
|
import Data.TByteString qualified as TBS
|
|
|
|
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
|
2021-09-29 11:13:30 +03:00
|
|
|
import Hasura.RQL.DDL.RequestTransform (RequestTransform, TransformErrorBundle (..), applyRequestTransform)
|
2021-09-24 01:56:37 +03:00
|
|
|
import Hasura.RQL.Types.Common (ResolvedWebhook (..))
|
|
|
|
import Hasura.RQL.Types.EventTrigger
|
|
|
|
import Hasura.RQL.Types.Eventing
|
2021-09-29 11:13:30 +03:00
|
|
|
import Hasura.Session (SessionVariables)
|
2021-09-24 01:56:37 +03:00
|
|
|
import Hasura.Tracing
|
|
|
|
import Network.HTTP.Client.Transformable qualified as HTTP
|
|
|
|
|
|
|
|
data LogBehavior = LogBehavior
|
|
|
|
{ _lbHeader :: !HeaderLogBehavior,
|
|
|
|
_lbResponse :: !ResponseLogBehavior
|
2021-07-02 20:24:49 +03:00
|
|
|
}
|
|
|
|
|
|
|
|
data HeaderLogBehavior = LogEnvValue | LogEnvVarname
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
data ResponseLogBehavior = LogSanitisedResponse | LogEntireResponse
|
|
|
|
deriving (Show, Eq)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2020-10-27 16:53:49 +03:00
|
|
|
retryAfterHeader :: CI.CI Text
|
2020-05-13 15:33:16 +03:00
|
|
|
retryAfterHeader = "Retry-After"
|
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
data ExtraLogContext = ExtraLogContext
|
|
|
|
{ elEventId :: !EventId,
|
|
|
|
elEventName :: !(Maybe TriggerName)
|
|
|
|
}
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
data HTTPResp (a :: TriggerTypes) = HTTPResp
|
|
|
|
{ hrsStatus :: !Int,
|
|
|
|
hrsHeaders :: ![HeaderConf],
|
|
|
|
hrsBody :: !TBS.TByteString,
|
|
|
|
hrsSize :: !Int64
|
|
|
|
}
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
$(deriveToJSON hasuraJSON {omitNothingFields = True} ''HTTPResp)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
instance ToEngineLog (HTTPResp 'EventType) Hasura where
|
2021-09-29 11:13:30 +03:00
|
|
|
toEngineLog resp = (LevelInfo, eventTriggerLogType, J.toJSON resp)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
instance ToEngineLog (HTTPResp 'ScheduledType) Hasura where
|
2021-09-29 11:13:30 +03:00
|
|
|
toEngineLog resp = (LevelInfo, scheduledTriggerLogType, J.toJSON resp)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
data HTTPErr (a :: TriggerTypes)
|
2021-09-20 16:14:28 +03:00
|
|
|
= HClient !HttpException
|
2020-05-13 15:33:16 +03:00
|
|
|
| HStatus !(HTTPResp a)
|
|
|
|
| HOther !String
|
|
|
|
deriving (Show)
|
|
|
|
|
2021-09-29 11:13:30 +03:00
|
|
|
instance J.ToJSON (HTTPErr a) where
|
2020-05-13 15:33:16 +03:00
|
|
|
toJSON err = toObj $ case err of
|
2021-09-20 16:14:28 +03:00
|
|
|
(HClient httpException) ->
|
2021-09-29 11:13:30 +03:00
|
|
|
("client", J.toJSON httpException)
|
2020-05-13 15:33:16 +03:00
|
|
|
(HStatus resp) ->
|
2021-09-29 11:13:30 +03:00
|
|
|
("status", J.toJSON resp)
|
|
|
|
(HOther e) -> ("internal", J.toJSON e)
|
2020-05-13 15:33:16 +03:00
|
|
|
where
|
2021-09-29 11:13:30 +03:00
|
|
|
toObj :: (Text, J.Value) -> J.Value
|
2021-09-24 01:56:37 +03:00
|
|
|
toObj (k, v) =
|
2021-09-29 11:13:30 +03:00
|
|
|
J.object
|
|
|
|
[ "type" J..= k,
|
|
|
|
"detail" J..= v
|
2021-09-24 01:56:37 +03:00
|
|
|
]
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
instance ToEngineLog (HTTPErr 'EventType) Hasura where
|
2021-09-29 11:13:30 +03:00
|
|
|
toEngineLog err = (LevelError, eventTriggerLogType, J.toJSON err)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
instance ToEngineLog (HTTPErr 'ScheduledType) Hasura where
|
2021-09-29 11:13:30 +03:00
|
|
|
toEngineLog err = (LevelError, scheduledTriggerLogType, J.toJSON err)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
mkHTTPResp :: HTTP.Response LBS.ByteString -> HTTPResp a
|
|
|
|
mkHTTPResp resp =
|
|
|
|
HTTPResp
|
2021-09-24 01:56:37 +03:00
|
|
|
{ hrsStatus = HTTP.statusCode $ HTTP.responseStatus resp,
|
|
|
|
hrsHeaders = map decodeHeader $ HTTP.responseHeaders resp,
|
|
|
|
hrsBody = TBS.fromLBS respBody,
|
|
|
|
hrsSize = LBS.length respBody
|
|
|
|
}
|
2020-05-13 15:33:16 +03:00
|
|
|
where
|
2020-07-28 20:52:44 +03:00
|
|
|
respBody = HTTP.responseBody resp
|
2020-05-13 15:33:16 +03:00
|
|
|
decodeBS = TE.decodeUtf8With TE.lenientDecode
|
2021-09-24 01:56:37 +03:00
|
|
|
decodeHeader (hdrName, hdrVal) =
|
|
|
|
HeaderConf (decodeBS $ CI.original hdrName) (HVValue (decodeBS hdrVal))
|
|
|
|
|
|
|
|
data RequestDetails = RequestDetails
|
|
|
|
{ _rdOriginalRequest :: HTTP.Request,
|
|
|
|
_rdOriginalSize :: Int64,
|
|
|
|
_rdTransformedRequest :: Maybe HTTP.Request,
|
|
|
|
_rdTransformedSize :: Maybe Int64
|
|
|
|
}
|
|
|
|
|
2021-01-19 22:14:42 +03:00
|
|
|
$(deriveToJSON hasuraJSON ''RequestDetails)
|
2020-07-28 20:52:44 +03:00
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
data HTTPRespExtra (a :: TriggerTypes) = HTTPRespExtra
|
|
|
|
{ _hreResponse :: !(Either (HTTPErr a) (HTTPResp a)),
|
|
|
|
_hreContext :: !ExtraLogContext,
|
|
|
|
_hreRequest :: !RequestDetails,
|
|
|
|
-- | Whether to log the entire response, including the body and the headers,
|
|
|
|
-- which may contain sensitive information.
|
|
|
|
_hreLogResponse :: !ResponseLogBehavior
|
2020-05-13 15:33:16 +03:00
|
|
|
}
|
|
|
|
|
2021-09-29 11:13:30 +03:00
|
|
|
instance J.ToJSON (HTTPRespExtra a) where
|
server: sanitise event trigger logs (fix #1233)
- sanitise the response field in event trigger and scheduled trigger logs, removing the body and the headers
- flatten the log structure to include the event id at `$.detail.event_id` instead of `$.detail.context.event_id`
the log format changes as follows:
```diff
diff --git a/log b/log
index 96127e0..1fb909a 100644
--- a/log
+++ b/log
@@ -1,48 +1,15 @@
{
"detail": {
- "context": {
- "event_id": "b9d4e627-6029-43f2-9d46-31c532b07070"
- },
+ "event_id": "adcc8dcd-2f32-4554-bd55-90c787aee137",
"request": {
"size": 416
},
"response": {
- "body": "{\n \"args\": {}, \n \"data\": \"{\\\"event\\\":{\\\"session_variables\\\":{\\\"x-hasura-role\\\":\\\"admin\\\"},\\\"op\\\":\\\"INSERT\\\",\\\"data\\\":{\\\"old\\\":null,\\\"new\\\":{\\\"name\\\":\\\"someotheranimal\\\",\\\"id\\\":3}},\\\"trace_context\\\":{\\\"trace_id\\\":\\\"e8237c03de151634\\\",\\\"span_id\\\":\\\"8c5f8952e9e06da8\\\"}},\\\"created_at\\\":\\\"2021-05-06T07:52:58.796611Z\\\",\\\"id>
- "headers": [
- {
- "name": "Date",
- "value": "Thu, 06 May 2021 07:53:00 GMT"
- },
- {
- "name": "Content-Type",
- "value": "application/json"
- },
- {
- "name": "Content-Length",
- "value": "1692"
- },
- {
- "name": "Connection",
- "value": "keep-alive"
- },
- {
- "name": "Server",
- "value": "gunicorn/19.9.0"
- },
- {
- "name": "Access-Control-Allow-Origin",
- "value": "*"
- },
- {
- "name": "Access-Control-Allow-Credentials",
- "value": "true"
- }
- ],
- "size": 1692,
+ "size": 1719,
"status": 200
}
},
"level": "info",
- "timestamp": "2021-05-06T13:23:00.376+0530",
+ "timestamp": "2021-05-06T13:25:14.481+0530",
"type": "event-trigger"
}
```
GitOrigin-RevId: d9622de366737da04dc6d9ff73238be16ec9305e
2021-05-12 15:09:51 +03:00
|
|
|
toJSON (HTTPRespExtra resp ctxt req logResp) =
|
2020-05-13 15:33:16 +03:00
|
|
|
case resp of
|
2021-09-24 01:56:37 +03:00
|
|
|
Left errResp ->
|
2021-09-29 11:13:30 +03:00
|
|
|
J.object $
|
|
|
|
[ "response" J..= J.toJSON errResp,
|
|
|
|
"request" J..= J.toJSON req,
|
|
|
|
"event_id" J..= elEventId ctxt
|
2021-09-24 01:56:37 +03:00
|
|
|
]
|
|
|
|
++ eventName
|
|
|
|
Right okResp ->
|
2021-09-29 11:13:30 +03:00
|
|
|
J.object $
|
|
|
|
[ "response" J..= case logResp of
|
|
|
|
LogEntireResponse -> J.toJSON okResp
|
2021-09-24 01:56:37 +03:00
|
|
|
LogSanitisedResponse -> sanitisedRespJSON okResp,
|
2021-09-29 11:13:30 +03:00
|
|
|
"request" J..= J.toJSON req,
|
|
|
|
"event_id" J..= elEventId ctxt
|
2021-09-24 01:56:37 +03:00
|
|
|
]
|
|
|
|
++ eventName
|
server: sanitise event trigger logs (fix #1233)
- sanitise the response field in event trigger and scheduled trigger logs, removing the body and the headers
- flatten the log structure to include the event id at `$.detail.event_id` instead of `$.detail.context.event_id`
the log format changes as follows:
```diff
diff --git a/log b/log
index 96127e0..1fb909a 100644
--- a/log
+++ b/log
@@ -1,48 +1,15 @@
{
"detail": {
- "context": {
- "event_id": "b9d4e627-6029-43f2-9d46-31c532b07070"
- },
+ "event_id": "adcc8dcd-2f32-4554-bd55-90c787aee137",
"request": {
"size": 416
},
"response": {
- "body": "{\n \"args\": {}, \n \"data\": \"{\\\"event\\\":{\\\"session_variables\\\":{\\\"x-hasura-role\\\":\\\"admin\\\"},\\\"op\\\":\\\"INSERT\\\",\\\"data\\\":{\\\"old\\\":null,\\\"new\\\":{\\\"name\\\":\\\"someotheranimal\\\",\\\"id\\\":3}},\\\"trace_context\\\":{\\\"trace_id\\\":\\\"e8237c03de151634\\\",\\\"span_id\\\":\\\"8c5f8952e9e06da8\\\"}},\\\"created_at\\\":\\\"2021-05-06T07:52:58.796611Z\\\",\\\"id>
- "headers": [
- {
- "name": "Date",
- "value": "Thu, 06 May 2021 07:53:00 GMT"
- },
- {
- "name": "Content-Type",
- "value": "application/json"
- },
- {
- "name": "Content-Length",
- "value": "1692"
- },
- {
- "name": "Connection",
- "value": "keep-alive"
- },
- {
- "name": "Server",
- "value": "gunicorn/19.9.0"
- },
- {
- "name": "Access-Control-Allow-Origin",
- "value": "*"
- },
- {
- "name": "Access-Control-Allow-Credentials",
- "value": "true"
- }
- ],
- "size": 1692,
+ "size": 1719,
"status": 200
}
},
"level": "info",
- "timestamp": "2021-05-06T13:23:00.376+0530",
+ "timestamp": "2021-05-06T13:25:14.481+0530",
"type": "event-trigger"
}
```
GitOrigin-RevId: d9622de366737da04dc6d9ff73238be16ec9305e
2021-05-12 15:09:51 +03:00
|
|
|
where
|
2021-07-05 10:47:45 +03:00
|
|
|
eventName = case elEventName ctxt of
|
2021-09-29 11:13:30 +03:00
|
|
|
Just name -> ["event_name" J..= name]
|
2021-09-24 01:56:37 +03:00
|
|
|
Nothing -> []
|
|
|
|
sanitisedRespJSON v =
|
2021-09-29 11:13:30 +03:00
|
|
|
J.Object $
|
2021-09-24 01:56:37 +03:00
|
|
|
HML.fromList
|
2021-09-29 11:13:30 +03:00
|
|
|
[ "size" J..= hrsSize v,
|
|
|
|
"status" J..= hrsStatus v
|
2021-09-24 01:56:37 +03:00
|
|
|
]
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
instance ToEngineLog (HTTPRespExtra 'EventType) Hasura where
|
2021-09-29 11:13:30 +03:00
|
|
|
toEngineLog resp = (LevelInfo, eventTriggerLogType, J.toJSON resp)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
instance ToEngineLog (HTTPRespExtra 'ScheduledType) Hasura where
|
2021-09-29 11:13:30 +03:00
|
|
|
toEngineLog resp = (LevelInfo, scheduledTriggerLogType, J.toJSON resp)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
isNetworkError :: HTTPErr a -> Bool
|
|
|
|
isNetworkError = \case
|
|
|
|
HClient he -> isNetworkErrorHC he
|
2021-09-24 01:56:37 +03:00
|
|
|
_ -> False
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2021-09-20 16:14:28 +03:00
|
|
|
isNetworkErrorHC :: HttpException -> Bool
|
|
|
|
isNetworkErrorHC (HttpException exception) =
|
|
|
|
case exception of
|
|
|
|
HTTP.HttpExceptionRequest _ (HTTP.ConnectionFailure _) -> True
|
2021-09-24 01:56:37 +03:00
|
|
|
HTTP.HttpExceptionRequest _ HTTP.ConnectionTimeout -> True
|
|
|
|
HTTP.HttpExceptionRequest _ HTTP.ResponseTimeout -> True
|
|
|
|
_ -> False
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
anyBodyParser :: HTTP.Response LBS.ByteString -> Either (HTTPErr a) (HTTPResp a)
|
|
|
|
anyBodyParser resp = do
|
|
|
|
let httpResp = mkHTTPResp resp
|
|
|
|
if respCode >= HTTP.status200 && respCode < HTTP.status300
|
|
|
|
then return httpResp
|
2021-09-24 01:56:37 +03:00
|
|
|
else throwError $ HStatus httpResp
|
2020-05-13 15:33:16 +03:00
|
|
|
where
|
|
|
|
respCode = HTTP.responseStatus resp
|
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
data HTTPReq = HTTPReq
|
|
|
|
{ _hrqMethod :: !String,
|
|
|
|
_hrqUrl :: !String,
|
2021-09-29 11:13:30 +03:00
|
|
|
_hrqPayload :: !(Maybe J.Value),
|
2021-09-24 01:56:37 +03:00
|
|
|
_hrqTry :: !Int,
|
|
|
|
_hrqDelay :: !(Maybe Int)
|
|
|
|
}
|
|
|
|
deriving (Show, Eq)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
$(deriveJSON hasuraJSON {omitNothingFields = True} ''HTTPReq)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
instance ToEngineLog HTTPReq Hasura where
|
2021-09-29 11:13:30 +03:00
|
|
|
toEngineLog req = (LevelInfo, eventTriggerLogType, J.toJSON req)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
logHTTPForET ::
|
|
|
|
( MonadReader r m,
|
|
|
|
Has (Logger Hasura) r,
|
|
|
|
MonadIO m
|
|
|
|
) =>
|
|
|
|
Either (HTTPErr 'EventType) (HTTPResp 'EventType) ->
|
|
|
|
ExtraLogContext ->
|
|
|
|
RequestDetails ->
|
|
|
|
LogBehavior ->
|
|
|
|
m ()
|
2021-07-02 20:24:49 +03:00
|
|
|
logHTTPForET eitherResp extraLogCtx reqDetails logBehavior = do
|
2020-05-13 15:33:16 +03:00
|
|
|
logger :: Logger Hasura <- asks getter
|
2021-07-02 20:24:49 +03:00
|
|
|
unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails (_lbResponse logBehavior)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
logHTTPForST ::
|
|
|
|
( MonadReader r m,
|
|
|
|
Has (Logger Hasura) r,
|
|
|
|
MonadIO m
|
|
|
|
) =>
|
|
|
|
Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType) ->
|
|
|
|
ExtraLogContext ->
|
|
|
|
RequestDetails ->
|
|
|
|
LogBehavior ->
|
|
|
|
m ()
|
2021-07-02 20:24:49 +03:00
|
|
|
logHTTPForST eitherResp extraLogCtx reqDetails logBehavior = do
|
2020-05-13 15:33:16 +03:00
|
|
|
logger :: Logger Hasura <- asks getter
|
2021-07-02 20:24:49 +03:00
|
|
|
unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails (_lbResponse logBehavior)
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
runHTTP :: (MonadIO m) => HTTP.Manager -> HTTP.Request -> m (Either (HTTPErr a) (HTTPResp a))
|
|
|
|
runHTTP manager req = do
|
2021-09-16 14:03:01 +03:00
|
|
|
res <- liftIO $ try $ HTTP.performRequest req manager
|
2021-09-20 16:14:28 +03:00
|
|
|
return $ either (Left . HClient . HttpException) anyBodyParser res
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2021-09-16 14:03:01 +03:00
|
|
|
mkRequest ::
|
2021-09-24 01:56:37 +03:00
|
|
|
MonadError (HTTPErr a) m =>
|
|
|
|
[HTTP.Header] ->
|
|
|
|
HTTP.ResponseTimeout ->
|
|
|
|
-- | the request body. It is passed as a 'BL.Bytestring' because we need to
|
2020-07-28 20:52:44 +03:00
|
|
|
-- log the request size. As the logging happens outside the function, we pass
|
|
|
|
-- it the final request body, instead of 'Value'
|
2021-09-24 01:56:37 +03:00
|
|
|
LBS.ByteString ->
|
|
|
|
Maybe RequestTransform ->
|
|
|
|
ResolvedWebhook ->
|
2021-09-29 11:13:30 +03:00
|
|
|
m (Either TransformErrorBundle RequestDetails)
|
2021-09-20 16:14:28 +03:00
|
|
|
mkRequest headers timeout payload mRequestTransform (ResolvedWebhook webhook) =
|
|
|
|
case HTTP.mkRequestEither webhook of
|
|
|
|
Left excp -> throwError $ HClient $ HttpException excp
|
2021-09-16 14:03:01 +03:00
|
|
|
Right initReq ->
|
2021-09-24 01:56:37 +03:00
|
|
|
let req =
|
|
|
|
initReq & set HTTP.method "POST"
|
|
|
|
& set HTTP.headers headers
|
|
|
|
& set HTTP.body (Just payload)
|
|
|
|
& set HTTP.timeout timeout
|
2021-09-29 11:13:30 +03:00
|
|
|
in case mRequestTransform of
|
|
|
|
Nothing -> pure $ Right $ RequestDetails req (LBS.length payload) Nothing Nothing
|
|
|
|
Just reqTransform ->
|
|
|
|
let sessionVars = do
|
|
|
|
val <- J.decode @J.Value payload
|
|
|
|
varVal <- preview (key "event" . key "session_variables") val
|
|
|
|
case J.fromJSON @SessionVariables varVal of
|
|
|
|
J.Success sessionVars' -> pure sessionVars'
|
|
|
|
_ -> Nothing
|
2021-10-13 06:36:59 +03:00
|
|
|
in case applyRequestTransform webhook reqTransform req sessionVars of
|
2021-09-29 11:13:30 +03:00
|
|
|
Left err -> pure $ Left err
|
|
|
|
Right transformedReq ->
|
|
|
|
let transformedReqSize = HTTP.getReqSize transformedReq
|
|
|
|
in pure $ Right $ RequestDetails req (LBS.length payload) (Just transformedReq) (Just transformedReqSize)
|
2021-09-16 14:03:01 +03:00
|
|
|
|
|
|
|
invokeRequest ::
|
2021-09-24 01:56:37 +03:00
|
|
|
( MonadReader r m,
|
|
|
|
Has HTTP.Manager r,
|
|
|
|
MonadIO m,
|
|
|
|
MonadTrace m
|
|
|
|
) =>
|
|
|
|
RequestDetails ->
|
|
|
|
((Either (HTTPErr a) (HTTPResp a)) -> RequestDetails -> m ()) ->
|
|
|
|
m (Either (HTTPErr a) (HTTPResp a))
|
|
|
|
invokeRequest reqDetails@RequestDetails {_rdOriginalRequest, _rdTransformedRequest} logger = do
|
2021-09-16 14:03:01 +03:00
|
|
|
let finalReq = fromMaybe _rdOriginalRequest _rdTransformedRequest
|
|
|
|
manager <- asks getter
|
|
|
|
-- Perform the HTTP Request
|
|
|
|
eitherResp <- tracedHttpRequest finalReq $ runHTTP manager
|
|
|
|
-- Log the result along with the pre/post transformation Request data
|
|
|
|
logger eitherResp reqDetails
|
|
|
|
pure eitherResp
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
mkResp :: Int -> TBS.TByteString -> [HeaderConf] -> Response a
|
|
|
|
mkResp status payload headers =
|
|
|
|
let wr = WebhookResponse payload headers status
|
2021-09-24 01:56:37 +03:00
|
|
|
in ResponseHTTP wr
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
mkClientErr :: TBS.TByteString -> Response a
|
|
|
|
mkClientErr message =
|
|
|
|
let cerr = ClientError message
|
2021-09-24 01:56:37 +03:00
|
|
|
in ResponseError cerr
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2021-09-29 11:13:30 +03:00
|
|
|
mkWebhookReq :: J.Value -> [HeaderConf] -> InvocationVersion -> WebhookRequest
|
2020-05-13 15:33:16 +03:00
|
|
|
mkWebhookReq payload headers = WebhookRequest payload headers
|
|
|
|
|
2021-09-20 16:14:28 +03:00
|
|
|
mkInvocationResp :: Maybe Int -> TBS.TByteString -> [HeaderConf] -> Response a
|
|
|
|
mkInvocationResp statusMaybe responseBody responseHeaders =
|
|
|
|
case statusMaybe of
|
2021-09-24 01:56:37 +03:00
|
|
|
Nothing -> mkClientErr responseBody
|
2021-09-20 16:14:28 +03:00
|
|
|
Just status ->
|
|
|
|
if isClientError status
|
2021-09-24 01:56:37 +03:00
|
|
|
then mkClientErr responseBody
|
|
|
|
else mkResp status responseBody responseHeaders
|
2021-09-20 16:14:28 +03:00
|
|
|
|
2020-05-13 15:33:16 +03:00
|
|
|
isClientError :: Int -> Bool
|
2021-09-20 16:14:28 +03:00
|
|
|
isClientError status = status >= 300
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
encodeHeader :: EventHeaderInfo -> HTTP.Header
|
|
|
|
encodeHeader (EventHeaderInfo hconf cache) =
|
|
|
|
let (HeaderConf name _) = hconf
|
|
|
|
ciname = CI.mk $ TE.encodeUtf8 name
|
|
|
|
value = TE.encodeUtf8 cache
|
|
|
|
in (ciname, value)
|
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
decodeHeader ::
|
|
|
|
LogBehavior ->
|
|
|
|
[EventHeaderInfo] ->
|
|
|
|
(HTTP.HeaderName, BS.ByteString) ->
|
|
|
|
HeaderConf
|
|
|
|
decodeHeader logBehavior headerInfos (hdrName, hdrVal) =
|
|
|
|
let name = decodeBS $ CI.original hdrName
|
|
|
|
getName ehi =
|
|
|
|
let (HeaderConf name' _) = ehiHeaderConf ehi
|
|
|
|
in name'
|
|
|
|
mehi = find (\hi -> getName hi == name) headerInfos
|
|
|
|
in case mehi of
|
|
|
|
Nothing -> HeaderConf name (HVValue (decodeBS hdrVal))
|
|
|
|
Just ehi -> case _lbHeader logBehavior of
|
|
|
|
LogEnvValue -> HeaderConf name (HVValue (ehiCachedValue ehi))
|
|
|
|
LogEnvVarname -> ehiHeaderConf ehi
|
|
|
|
where
|
|
|
|
decodeBS = TE.decodeUtf8With TE.lenientDecode
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2021-07-02 20:24:49 +03:00
|
|
|
-- | Encodes given request headers along with our 'defaultHeaders' and returns
|
|
|
|
-- them along with the re-decoded set of headers (for logging purposes).
|
2021-09-24 01:56:37 +03:00
|
|
|
prepareHeaders ::
|
|
|
|
LogBehavior ->
|
|
|
|
[EventHeaderInfo] ->
|
|
|
|
([HTTP.Header], [HeaderConf])
|
2021-07-02 20:24:49 +03:00
|
|
|
prepareHeaders logBehavior headerInfos = (headers, logHeaders)
|
|
|
|
where
|
|
|
|
encodedHeaders = map encodeHeader headerInfos
|
|
|
|
headers = addDefaultHeaders encodedHeaders
|
|
|
|
logHeaders = map (decodeHeader logBehavior headerInfos) headers
|
|
|
|
|
2020-05-13 15:33:16 +03:00
|
|
|
getRetryAfterHeaderFromHTTPErr :: HTTPErr a -> Maybe Text
|
|
|
|
getRetryAfterHeaderFromHTTPErr (HStatus resp) = getRetryAfterHeaderFromResp resp
|
2021-09-24 01:56:37 +03:00
|
|
|
getRetryAfterHeaderFromHTTPErr _ = Nothing
|
2020-05-13 15:33:16 +03:00
|
|
|
|
|
|
|
getRetryAfterHeaderFromResp :: HTTPResp a -> Maybe Text
|
|
|
|
getRetryAfterHeaderFromResp resp =
|
|
|
|
let mHeader =
|
|
|
|
find
|
|
|
|
(\(HeaderConf name _) -> CI.mk name == retryAfterHeader)
|
|
|
|
(hrsHeaders resp)
|
|
|
|
in case mHeader of
|
|
|
|
Just (HeaderConf _ (HVValue value)) -> Just value
|
2021-09-24 01:56:37 +03:00
|
|
|
_ -> Nothing
|
2020-05-13 15:33:16 +03:00
|
|
|
|
2020-10-27 16:53:49 +03:00
|
|
|
parseRetryHeaderValue :: Text -> Maybe Int
|
2020-05-13 15:33:16 +03:00
|
|
|
parseRetryHeaderValue hValue =
|
|
|
|
let seconds = readMaybe $ T.unpack hValue
|
|
|
|
in case seconds of
|
|
|
|
Nothing -> Nothing
|
|
|
|
Just sec ->
|
|
|
|
if sec > 0
|
|
|
|
then Just sec
|
|
|
|
else Nothing
|