mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-20 22:11:45 +03:00
5cc91aebc3
- add name fields to log output in several spots:
- action logs get the action name in detail.action_name
- events (triggered and scheduled) get the trigger name in detail.event_name
- one-off scheduled events don't have a trigger name; instead, they get the
comment if it exists
- remove unused event creation timestamp from ExtraLogContext
https://github.com/hasura/graphql-engine-mono/pull/1712
GitOrigin-RevId: 28907340d4e2d9adc0c48cc5d3010eef1fa902e1
434 lines
13 KiB
Haskell
434 lines
13 KiB
Haskell
{-|
|
|
= 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(..)
|
|
, tryWebhook
|
|
, runHTTP
|
|
, isNetworkError
|
|
, isNetworkErrorHC
|
|
, logHTTPForET
|
|
, logHTTPForST
|
|
, ExtraLogContext(..)
|
|
, RequestDetails (..)
|
|
, EventId
|
|
, Invocation(..)
|
|
, InvocationVersion
|
|
, Response(..)
|
|
, WebhookRequest(..)
|
|
, WebhookResponse(..)
|
|
, ClientError(..)
|
|
, isClientError
|
|
, mkClientErr
|
|
, mkWebhookReq
|
|
, mkResp
|
|
, LogBehavior(..)
|
|
, ResponseLogBehavior(..)
|
|
, HeaderLogBehavior(..)
|
|
, prepareHeaders
|
|
, getRetryAfterHeaderFromHTTPErr
|
|
, getRetryAfterHeaderFromResp
|
|
, parseRetryHeaderValue
|
|
, TriggerTypes(..)
|
|
, invocationVersionET
|
|
, invocationVersionST
|
|
) where
|
|
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.HashMap.Lazy as HML
|
|
import qualified Data.TByteString as TBS
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Text.Encoding.Error as TE
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Types as HTTP
|
|
|
|
import Control.Exception (try)
|
|
import Data.Aeson
|
|
import Data.Aeson.TH
|
|
import Data.Either
|
|
import Data.Has
|
|
import Data.Int (Int64)
|
|
import Hasura.HTTP (addDefaultHeaders)
|
|
import Hasura.Logging
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.DDL.Headers
|
|
import Hasura.RQL.Types.EventTrigger
|
|
import Hasura.Server.Version (HasVersion)
|
|
import Hasura.Tracing
|
|
|
|
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 WebhookRequest
|
|
= WebhookRequest
|
|
{ _rqPayload :: Value
|
|
, _rqHeaders :: [HeaderConf]
|
|
, _rqVersion :: Text
|
|
}
|
|
$(deriveToJSON hasuraJSON{omitNothingFields=True} ''WebhookRequest)
|
|
|
|
data WebhookResponse
|
|
= WebhookResponse
|
|
{ _wrsBody :: TBS.TByteString
|
|
, _wrsHeaders :: [HeaderConf]
|
|
, _wrsStatus :: Int
|
|
}
|
|
$(deriveToJSON hasuraJSON{omitNothingFields=True} ''WebhookResponse)
|
|
|
|
newtype ClientError = ClientError { _ceMessage :: TBS.TByteString}
|
|
$(deriveToJSON hasuraJSON{omitNothingFields=True} ''ClientError)
|
|
|
|
type InvocationVersion = Text
|
|
|
|
invocationVersionET :: InvocationVersion
|
|
invocationVersionET = "2"
|
|
|
|
invocationVersionST :: InvocationVersion
|
|
invocationVersionST = "1"
|
|
|
|
-- | There are two types of events: EventType (for event triggers) and ScheduledType (for scheduled triggers)
|
|
data TriggerTypes = EventType | ScheduledType
|
|
|
|
data Response (a :: TriggerTypes) =
|
|
ResponseHTTP WebhookResponse | ResponseError ClientError
|
|
|
|
instance ToJSON (Response 'EventType) where
|
|
toJSON (ResponseHTTP resp) = object
|
|
[ "type" .= String "webhook_response"
|
|
, "data" .= toJSON resp
|
|
, "version" .= invocationVersionET
|
|
]
|
|
toJSON (ResponseError err) = object
|
|
[ "type" .= String "client_error"
|
|
, "data" .= toJSON err
|
|
, "version" .= invocationVersionET
|
|
]
|
|
|
|
instance ToJSON (Response 'ScheduledType) where
|
|
toJSON (ResponseHTTP resp) = object
|
|
[ "type" .= String "webhook_response"
|
|
, "data" .= toJSON resp
|
|
, "version" .= invocationVersionST
|
|
]
|
|
toJSON (ResponseError err) = object
|
|
[ "type" .= String "client_error"
|
|
, "data" .= toJSON err
|
|
, "version" .= invocationVersionST
|
|
]
|
|
|
|
|
|
data Invocation (a :: TriggerTypes)
|
|
= Invocation
|
|
{ iEventId :: EventId
|
|
, iStatus :: Int
|
|
, iRequest :: WebhookRequest
|
|
, iResponse :: Response a
|
|
}
|
|
|
|
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, toJSON resp)
|
|
|
|
instance ToEngineLog (HTTPResp 'ScheduledType) Hasura where
|
|
toEngineLog resp = (LevelInfo, scheduledTriggerLogType, toJSON resp)
|
|
|
|
data HTTPErr (a :: TriggerTypes)
|
|
= HClient !HTTP.HttpException
|
|
| HParse !HTTP.Status !String
|
|
| HStatus !(HTTPResp a)
|
|
| HOther !String
|
|
deriving (Show)
|
|
|
|
instance ToJSON (HTTPErr a) where
|
|
toJSON err = toObj $ case err of
|
|
(HClient e) -> ("client", toJSON $ show e)
|
|
(HParse st e) ->
|
|
( "parse"
|
|
, toJSON (HTTP.statusCode st, show e)
|
|
)
|
|
(HStatus resp) ->
|
|
("status", toJSON resp)
|
|
(HOther e) -> ("internal", toJSON $ show e)
|
|
where
|
|
toObj :: (Text, Value) -> Value
|
|
toObj (k, v) = object [ "type" .= k
|
|
, "detail" .= v]
|
|
|
|
instance ToEngineLog (HTTPErr 'EventType) Hasura where
|
|
toEngineLog err = (LevelError, eventTriggerLogType, toJSON err)
|
|
|
|
instance ToEngineLog (HTTPErr 'ScheduledType) Hasura where
|
|
toEngineLog err = (LevelError, scheduledTriggerLogType, 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))
|
|
|
|
newtype RequestDetails
|
|
= RequestDetails { _rdSize :: Int64 }
|
|
$(deriveToJSON hasuraJSON ''RequestDetails)
|
|
|
|
data HTTPRespExtra (a :: TriggerTypes)
|
|
= HTTPRespExtra
|
|
{ _hreResponse :: !(Either (HTTPErr a) (HTTPResp a))
|
|
, _hreContext :: !ExtraLogContext
|
|
, _hreRequest :: !RequestDetails
|
|
, _hreLogResponse :: !ResponseLogBehavior
|
|
-- ^ Whether to log the entire response, including the body and the headers,
|
|
-- which may contain sensitive information.
|
|
}
|
|
|
|
instance ToJSON (HTTPRespExtra a) where
|
|
toJSON (HTTPRespExtra resp ctxt req logResp) =
|
|
case resp of
|
|
Left errResp -> object $
|
|
[ "response" .= toJSON errResp
|
|
, "request" .= toJSON req
|
|
, "event_id" .= elEventId ctxt
|
|
] ++ eventName
|
|
Right okResp -> object $
|
|
[ "response" .= case logResp of
|
|
LogEntireResponse -> toJSON okResp
|
|
LogSanitisedResponse -> sanitisedRespJSON okResp
|
|
, "request" .= toJSON req
|
|
, "event_id" .= elEventId ctxt
|
|
] ++ eventName
|
|
where
|
|
eventName = case elEventName ctxt of
|
|
Just name -> [ "event_name" .= name ]
|
|
Nothing -> []
|
|
sanitisedRespJSON v
|
|
= Object $ HML.fromList
|
|
[ "size" .= hrsSize v
|
|
, "status" .= hrsStatus v
|
|
]
|
|
|
|
instance ToEngineLog (HTTPRespExtra 'EventType) Hasura where
|
|
toEngineLog resp = (LevelInfo, eventTriggerLogType, toJSON resp)
|
|
|
|
instance ToEngineLog (HTTPRespExtra 'ScheduledType) Hasura where
|
|
toEngineLog resp = (LevelInfo, scheduledTriggerLogType, toJSON resp)
|
|
|
|
isNetworkError :: HTTPErr a -> Bool
|
|
isNetworkError = \case
|
|
HClient he -> isNetworkErrorHC he
|
|
_ -> False
|
|
|
|
isNetworkErrorHC :: HTTP.HttpException -> Bool
|
|
isNetworkErrorHC = \case
|
|
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 Value)
|
|
, _hrqTry :: !Int
|
|
, _hrqDelay :: !(Maybe Int)
|
|
} deriving (Show, Eq)
|
|
|
|
$(deriveJSON hasuraJSON{omitNothingFields=True} ''HTTPReq)
|
|
|
|
instance ToEngineLog HTTPReq Hasura where
|
|
toEngineLog req = (LevelInfo, eventTriggerLogType, 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.httpLbs req manager
|
|
return $ either (Left . HClient) anyBodyParser res
|
|
|
|
tryWebhook ::
|
|
( MonadReader r m
|
|
, Has HTTP.Manager r
|
|
, MonadIO m
|
|
, MonadError (HTTPErr a) m
|
|
, MonadTrace m
|
|
)
|
|
=> [HTTP.Header]
|
|
-> HTTP.ResponseTimeout
|
|
-> LBS.ByteString
|
|
-- ^ 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'
|
|
-> String
|
|
-> m (HTTPResp a)
|
|
tryWebhook headers timeout payload webhook = do
|
|
initReqE <- liftIO $ try $ HTTP.parseRequest webhook
|
|
manager <- asks getter
|
|
case initReqE of
|
|
Left excp -> throwError $ HClient excp
|
|
Right initReq -> do
|
|
let req =
|
|
initReq
|
|
{ HTTP.method = "POST"
|
|
, HTTP.requestHeaders = headers
|
|
, HTTP.requestBody = HTTP.RequestBodyLBS payload
|
|
, HTTP.responseTimeout = timeout
|
|
}
|
|
tracedHttpRequest req $ \req' -> do
|
|
eitherResp <- runHTTP manager req'
|
|
onLeft eitherResp throwError
|
|
|
|
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 :: Value -> [HeaderConf] -> InvocationVersion -> WebhookRequest
|
|
mkWebhookReq payload headers = WebhookRequest payload headers
|
|
|
|
isClientError :: Int -> Bool
|
|
isClientError status = status >= 1000
|
|
|
|
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
|
|
:: HasVersion
|
|
=> 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
|