graphql-engine/server/src-lib/Hasura/Eventing/HTTP.hs

411 lines
13 KiB
Haskell
Raw Normal View History

-- |
-- = 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 (..),
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)
import Control.Lens (preview, set)
import Data.Aeson qualified as J
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.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
import Hasura.RQL.DDL.RequestTransform (RequestTransform, TransformErrorBundle (..), applyRequestTransform)
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
data LogBehavior = LogBehavior
{ _lbHeader :: !HeaderLogBehavior,
_lbResponse :: !ResponseLogBehavior
}
data HeaderLogBehavior = LogEnvValue | LogEnvVarname
deriving (Show, Eq)
data ResponseLogBehavior = LogSanitisedResponse | LogEntireResponse
deriving (Show, Eq)
retryAfterHeader :: CI.CI Text
retryAfterHeader = "Retry-After"
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)
instance ToEngineLog (HTTPResp 'EventType) Hasura where
toEngineLog resp = (LevelInfo, eventTriggerLogType, J.toJSON resp)
instance ToEngineLog (HTTPResp 'ScheduledType) Hasura where
toEngineLog resp = (LevelInfo, scheduledTriggerLogType, J.toJSON resp)
data HTTPErr (a :: TriggerTypes)
= HClient !HttpException
| HStatus !(HTTPResp a)
| HOther !String
deriving (Show)
instance J.ToJSON (HTTPErr a) where
toJSON err = toObj $ case err of
(HClient httpException) ->
("client", J.toJSON httpException)
(HStatus resp) ->
("status", J.toJSON resp)
(HOther e) -> ("internal", J.toJSON e)
where
toObj :: (Text, J.Value) -> J.Value
toObj (k, v) =
J.object
[ "type" J..= k,
"detail" J..= v
]
instance ToEngineLog (HTTPErr 'EventType) Hasura where
toEngineLog err = (LevelError, eventTriggerLogType, J.toJSON err)
instance ToEngineLog (HTTPErr 'ScheduledType) Hasura where
toEngineLog err = (LevelError, scheduledTriggerLogType, J.toJSON err)
mkHTTPResp :: HTTP.Response LBS.ByteString -> HTTPResp a
mkHTTPResp resp =
HTTPResp
{ hrsStatus = HTTP.statusCode $ HTTP.responseStatus resp,
hrsHeaders = map decodeHeader $ HTTP.responseHeaders resp,
hrsBody = TBS.fromLBS respBody,
hrsSize = LBS.length respBody
}
where
respBody = HTTP.responseBody resp
decodeBS = TE.decodeUtf8With TE.lenientDecode
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
}
$(deriveToJSON hasuraJSON ''RequestDetails)
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
}
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) =
case resp of
Left errResp ->
J.object $
[ "response" J..= J.toJSON errResp,
"request" J..= J.toJSON req,
"event_id" J..= elEventId ctxt
]
++ eventName
Right okResp ->
J.object $
[ "response" J..= case logResp of
LogEntireResponse -> J.toJSON okResp
LogSanitisedResponse -> sanitisedRespJSON okResp,
"request" J..= J.toJSON req,
"event_id" J..= elEventId ctxt
]
++ 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
eventName = case elEventName ctxt of
Just name -> ["event_name" J..= name]
Nothing -> []
sanitisedRespJSON v =
J.Object $
HML.fromList
[ "size" J..= hrsSize v,
"status" J..= hrsStatus v
]
instance ToEngineLog (HTTPRespExtra 'EventType) Hasura where
toEngineLog resp = (LevelInfo, eventTriggerLogType, J.toJSON resp)
instance ToEngineLog (HTTPRespExtra 'ScheduledType) Hasura where
toEngineLog resp = (LevelInfo, scheduledTriggerLogType, J.toJSON resp)
isNetworkError :: HTTPErr a -> Bool
isNetworkError = \case
HClient he -> isNetworkErrorHC he
_ -> False
isNetworkErrorHC :: HttpException -> Bool
isNetworkErrorHC (HttpException exception) =
case exception of
HTTP.HttpExceptionRequest _ (HTTP.ConnectionFailure _) -> True
HTTP.HttpExceptionRequest _ HTTP.ConnectionTimeout -> True
HTTP.HttpExceptionRequest _ HTTP.ResponseTimeout -> True
_ -> False
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
else throwError $ HStatus httpResp
where
respCode = HTTP.responseStatus resp
data HTTPReq = HTTPReq
{ _hrqMethod :: !String,
_hrqUrl :: !String,
_hrqPayload :: !(Maybe J.Value),
_hrqTry :: !Int,
_hrqDelay :: !(Maybe Int)
}
deriving (Show, Eq)
$(deriveJSON hasuraJSON {omitNothingFields = True} ''HTTPReq)
instance ToEngineLog HTTPReq Hasura where
toEngineLog req = (LevelInfo, eventTriggerLogType, J.toJSON req)
logHTTPForET ::
( MonadReader r m,
Has (Logger Hasura) r,
MonadIO m
) =>
Either (HTTPErr 'EventType) (HTTPResp 'EventType) ->
ExtraLogContext ->
RequestDetails ->
LogBehavior ->
m ()
logHTTPForET eitherResp extraLogCtx reqDetails logBehavior = do
logger :: Logger Hasura <- asks getter
unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails (_lbResponse logBehavior)
logHTTPForST ::
( MonadReader r m,
Has (Logger Hasura) r,
MonadIO m
) =>
Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType) ->
ExtraLogContext ->
RequestDetails ->
LogBehavior ->
m ()
logHTTPForST eitherResp extraLogCtx reqDetails logBehavior = do
logger :: Logger Hasura <- asks getter
unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails (_lbResponse logBehavior)
runHTTP :: (MonadIO m) => HTTP.Manager -> HTTP.Request -> m (Either (HTTPErr a) (HTTPResp a))
runHTTP manager req = do
res <- liftIO $ try $ HTTP.performRequest req manager
return $ either (Left . HClient . HttpException) anyBodyParser res
mkRequest ::
MonadError (HTTPErr 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 (Either TransformErrorBundle RequestDetails)
mkRequest headers timeout payload mRequestTransform (ResolvedWebhook webhook) =
case HTTP.mkRequestEither webhook of
Left excp -> throwError $ HClient $ HttpException excp
Right initReq ->
let req =
initReq & set HTTP.method "POST"
& set HTTP.headers headers
& set HTTP.body (Just payload)
& set HTTP.timeout timeout
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
in case applyRequestTransform webhook reqTransform req sessionVars of
Left err -> pure $ Left err
Right transformedReq ->
let transformedReqSize = HTTP.getReqSize transformedReq
in pure $ Right $ RequestDetails req (LBS.length payload) (Just transformedReq) (Just transformedReqSize)
invokeRequest ::
( 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
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
mkResp :: Int -> TBS.TByteString -> [HeaderConf] -> Response a
mkResp status payload headers =
let wr = WebhookResponse payload headers status
in ResponseHTTP wr
mkClientErr :: TBS.TByteString -> Response a
mkClientErr message =
let cerr = ClientError message
in ResponseError cerr
mkWebhookReq :: J.Value -> [HeaderConf] -> InvocationVersion -> WebhookRequest
mkWebhookReq payload headers = WebhookRequest payload headers
mkInvocationResp :: Maybe Int -> TBS.TByteString -> [HeaderConf] -> Response a
mkInvocationResp statusMaybe responseBody responseHeaders =
case statusMaybe of
Nothing -> mkClientErr responseBody
Just status ->
if isClientError status
then mkClientErr responseBody
else mkResp status responseBody responseHeaders
isClientError :: Int -> Bool
isClientError status = status >= 300
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)
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
-- | Encodes given request headers along with our 'defaultHeaders' and returns
-- them along with the re-decoded set of headers (for logging purposes).
prepareHeaders ::
LogBehavior ->
[EventHeaderInfo] ->
([HTTP.Header], [HeaderConf])
prepareHeaders logBehavior headerInfos = (headers, logHeaders)
where
encodedHeaders = map encodeHeader headerInfos
headers = addDefaultHeaders encodedHeaders
logHeaders = map (decodeHeader logBehavior headerInfos) headers
getRetryAfterHeaderFromHTTPErr :: HTTPErr a -> Maybe Text
getRetryAfterHeaderFromHTTPErr (HStatus resp) = getRetryAfterHeaderFromResp resp
getRetryAfterHeaderFromHTTPErr _ = Nothing
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
_ -> Nothing
parseRetryHeaderValue :: Text -> Maybe Int
parseRetryHeaderValue hValue =
let seconds = readMaybe $ T.unpack hValue
in case seconds of
Nothing -> Nothing
Just sec ->
if sec > 0
then Just sec
else Nothing