server: log request/response sizes for event triggers (#5463)

* server: log request/response sizes for event triggers

  event triggers (and scheduled triggers) now have request/response size
  in their logs.

* add changelog entry

CHANGELOG.md

@@ -7,6 +7,7 @@
 (Add entries here in the order of: server, console, cli, docs, others)
 
 - console: update sidebar icons for different action and trigger types
+- server: add request/response sizes in event triggers (and scheduled trigger) logs
 
 ## `v1.3.0`
 

server/src-lib/Hasura/Eventing/EventTrigger.hs

@@ -64,6 +64,7 @@ import           Hasura.SQL.Types
 import qualified Hasura.Tracing                       as Tracing
 
 import qualified Control.Concurrent.Async.Lifted.Safe as LA
+import qualified Data.ByteString.Lazy                 as LBS
 import qualified Data.HashMap.Strict                  as M
 import qualified Data.TByteString                     as TBS
 import qualified Data.Text                            as T
@@ -272,9 +273,11 @@ processEventQueue logger logenv httpMgr pool getSchemaCache eeCtx@EventEngineCtx
               etHeaders = map encodeHeader headerInfos
               headers = addDefaultHeaders etHeaders
               ep = createEventPayload retryConf e
+              payload = encode $ toJSON ep
               extraLogCtx = ExtraLogContext Nothing (epId ep) -- avoiding getting current time here to avoid another IO call with each event call
-          res <- runExceptT $ tryWebhook headers responseTimeout (toJSON ep) webhook
-          logHTTPForET res extraLogCtx
+              requestDetails = RequestDetails $ LBS.length payload
+          res <- runExceptT $ tryWebhook headers responseTimeout payload webhook
+          logHTTPForET res extraLogCtx requestDetails
           let decodedHeaders = map (decodeHeader logenv headerInfos) headers
           either
             (processError pool e retryConf decodedHeaders ep)

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

@@ -17,6 +17,7 @@ module Hasura.Eventing.HTTP
   , logHTTPForET
   , logHTTPForST
   , ExtraLogContext(..)
+  , RequestDetails (..)
   , EventId
   , Invocation(..)
   , InvocationVersion
@@ -46,9 +47,9 @@ 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 Data.Time.Clock               as Time
 import qualified Network.HTTP.Client           as HTTP
 import qualified Network.HTTP.Types            as HTTP
-import qualified Data.Time.Clock               as Time
 
 import           Control.Exception             (try)
 import           Data.Aeson
@@ -56,6 +57,7 @@ import           Data.Aeson.Casing
 import           Data.Aeson.TH
 import           Data.Either
 import           Data.Has
+import           Data.Int                      (Int64)
 import           Hasura.Logging
 import           Hasura.Prelude
 import           Hasura.RQL.DDL.Headers
@@ -146,6 +148,7 @@ data HTTPResp (a :: TriggerTypes)
    { hrsStatus  :: !Int
    , hrsHeaders :: ![HeaderConf]
    , hrsBody    :: !TBS.TByteString
+   , hrsSize    :: !Int64
    } deriving (Show, Eq)
 
 $(deriveToJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''HTTPResp)
@@ -189,28 +192,37 @@ mkHTTPResp resp =
   HTTPResp
   { hrsStatus = HTTP.statusCode $ HTTP.responseStatus resp
   , hrsHeaders = map decodeHeader $ HTTP.responseHeaders resp
-  , hrsBody = TBS.fromLBS $ HTTP.responseBody 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 (aesonDrop 3 snakeCase) ''RequestDetails)
+
 data HTTPRespExtra (a :: TriggerTypes)
   = HTTPRespExtra
-  { _hreResponse :: Either (HTTPErr a) (HTTPResp a)
-  , _hreContext  :: ExtraLogContext
+  { _hreResponse :: !(Either (HTTPErr a) (HTTPResp a))
+  , _hreContext  :: !ExtraLogContext
+  , _hreRequest  :: !RequestDetails
   }
 
 instance ToJSON (HTTPRespExtra a) where
-  toJSON (HTTPRespExtra resp ctxt) = do
+  toJSON (HTTPRespExtra resp ctxt req) =
     case resp of
       Left errResp ->
         object [ "response" .= toJSON errResp
+               , "request" .= toJSON req
                , "context" .= toJSON ctxt
                ]
       Right rsp ->
         object [ "response" .= toJSON rsp
+               , "request" .= toJSON req
                , "context" .= toJSON ctxt
                ]
 
@@ -260,20 +272,26 @@ logHTTPForET
      , Has (Logger Hasura) r
      , MonadIO m
      )
-  => Either (HTTPErr 'EventType) (HTTPResp 'EventType) -> ExtraLogContext -> m ()
-logHTTPForET eitherResp extraLogCtx = do
+  => Either (HTTPErr 'EventType) (HTTPResp 'EventType)
+  -> ExtraLogContext
+  -> RequestDetails
+  -> m ()
+logHTTPForET eitherResp extraLogCtx reqDetails = do
   logger :: Logger Hasura <- asks getter
-  unLogger logger $ HTTPRespExtra eitherResp extraLogCtx
+  unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails
 
 logHTTPForST
   :: ( MonadReader r m
      , Has (Logger Hasura) r
      , MonadIO m
      )
-  => Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType) -> ExtraLogContext -> m ()
-logHTTPForST eitherResp extraLogCtx = do
+  => Either (HTTPErr 'ScheduledType) (HTTPResp 'ScheduledType)
+  -> ExtraLogContext
+  -> RequestDetails
+  -> m ()
+logHTTPForST eitherResp extraLogCtx reqDetails = do
   logger :: Logger Hasura <- asks getter
-  unLogger logger $ HTTPRespExtra eitherResp extraLogCtx
+  unLogger logger $ HTTPRespExtra eitherResp extraLogCtx reqDetails
 
 runHTTP :: (MonadIO m) => HTTP.Manager -> HTTP.Request -> m (Either (HTTPErr a) (HTTPResp a))
 runHTTP manager req = do
@@ -289,10 +307,13 @@ tryWebhook ::
   )
   => [HTTP.Header]
   -> HTTP.ResponseTimeout
-  -> Value
+  -> 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 = traceHttpRequest (T.pack webhook) do
+tryWebhook headers timeout payload webhook = traceHttpRequest (T.pack webhook) $ do
   initReqE <- liftIO $ try $ HTTP.parseRequest webhook
   manager <- asks getter
   case initReqE of
@@ -302,10 +323,10 @@ tryWebhook headers timeout payload webhook = traceHttpRequest (T.pack webhook) d
             initReq
               { HTTP.method = "POST"
               , HTTP.requestHeaders = headers
-              , HTTP.requestBody = HTTP.RequestBodyLBS (encode payload)
+              , HTTP.requestBody = HTTP.RequestBodyLBS payload
               , HTTP.responseTimeout = timeout
               }
-      pure $ SuspendedRequest req \req' -> do
+      pure $ SuspendedRequest req $ \req' -> do
         eitherResp <- runHTTP manager req'
         onLeft eitherResp throwError
 

server/src-lib/Hasura/Eventing/ScheduledTrigger.hs

@@ -95,6 +95,7 @@ import           System.Cron
 import qualified Data.Aeson                  as J
 import qualified Data.Aeson.Casing           as J
 import qualified Data.Aeson.TH               as J
+import qualified Data.ByteString.Lazy        as BL
 import qualified Data.Environment            as Env
 import qualified Data.HashMap.Strict         as Map
 import qualified Data.Set                    as Set
@@ -489,8 +490,10 @@ processScheduledEvent
           webhookReqPayload =
             ScheduledEventWebhookPayload sefId sefName sefScheduledTime sefPayload sefComment currentTime
           webhookReqBodyJson = J.toJSON webhookReqPayload
-      res <- runExceptT $ tryWebhook headers httpTimeout webhookReqBodyJson (T.unpack sefWebhook)
-      logHTTPForST res extraLogCtx
+          webhookReqBody = J.encode webhookReqBodyJson
+          requestDetails = RequestDetails $ BL.length webhookReqBody
+      res <- runExceptT $ tryWebhook headers httpTimeout webhookReqBody (T.unpack sefWebhook)
+      logHTTPForST res extraLogCtx requestDetails
       let decodedHeaders = map (decodeHeader logEnv sefHeaders) headers
       either
         (processError pgpool se decodedHeaders type' webhookReqBodyJson)