response size logging

Logs response size with requestResponseLogger, after the response
completes. If the response doesn't complete, we still log it as it
goes out if it's large.

src/Chainweb/Chainweb/CheckReachability.hs

@@ -150,4 +150,3 @@ peerServerSettings peer
     = W.setPort (int . _hostAddressPort . _peerAddr $ _peerInfo peer)
     . W.setHost (_peerInterface peer)
     $ W.defaultSettings
-

src/Chainweb/Utils/RequestLog.hs

@@ -43,6 +43,7 @@ module Chainweb.Utils.RequestLog
 , requestResponseLogRequest
 , requestResponseLogStatus
 , requestResponseLogDurationMicro
+, requestResponseLogResponseSize
 , requestResponseLogger
 ) where
 
@@ -76,6 +77,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Builder as Builder
 import qualified Data.ByteString.Lazy as LBS
 import Data.ByteString (ByteString)
+import Control.Monad
 
 -- -------------------------------------------------------------------------- --
 -- Request Logger
@@ -188,6 +190,7 @@ data RequestResponseLog = RequestResponseLog
     { _requestResponseLogRequest :: !RequestLog
     , _requestResponseLogStatus :: !T.Text
     , _requestResponseLogDurationMicro :: !Int
+    , _requestResponseLogResponseSize :: !Int
     }
     deriving (Show, Eq, Ord, Generic)
     deriving anyclass (NFData)
@@ -199,6 +202,7 @@ requestResponseLogProperties o =
     [ "request" .= _requestResponseLogRequest o
     , "status" .= _requestResponseLogStatus o
     , "durationMicro" .= _requestResponseLogDurationMicro o
+    , "responseSize" .= _requestResponseLogResponseSize o
     ]
 
 instance ToJSON RequestResponseLog where
@@ -207,13 +211,6 @@ instance ToJSON RequestResponseLog where
     {-# INLINE toJSON #-}
     {-# INLINE toEncoding #-}
 
-logRequestResponse :: RequestLog -> Response -> Int -> RequestResponseLog
-logRequestResponse reqLog res d = RequestResponseLog
-    { _requestResponseLogRequest = reqLog
-    , _requestResponseLogStatus = sshow $ responseStatus res
-    , _requestResponseLogDurationMicro = d
-    }
-
 -- | NOTE: this middleware should only be used for APIs that don't stream. Otherwise
 -- the logg may be delayed for indefinite time.
 --
@@ -223,9 +220,35 @@ requestResponseLogger logger app req respond = do
     (req', reqLog) <- logRequest lvl req
     reqTime <- getTime Monotonic
     app req' $ \res -> do
-        r <- respond res
+        responseByteCounter <- newIORef 0
+        responseLoggedForSize <- newIORef False
+        -- deconstruct the outgoing response body into a stream.
+        let (status, headers, withResponseBody) = responseToStream res
+        let monitoredWriteChunk writeChunk b = do
+                let lbs = Builder.toLazyByteString b
+                let chunks = LBS.toChunks lbs
+                -- for each chunk of the outgoing stream, add its length to the accumulator.
+                -- if it's over the limit, log, and don't log for any subsequent chunk.
+                forM_ chunks $ \chunk -> do
+                    responseByteCount' <- atomicModifyIORef' responseByteCounter $ \count ->
+                        let count' = count + BS.length chunk
+                        in (count', count')
+                    loggedAlready <- readIORef responseLoggedForSize
+                    when (responseByteCount' >= 50 * kilo && not loggedAlready) $ do
+                        logFunctionText logger Warn $ "Large response body (>50KB) outbound from path " <> T.decodeUtf8 (rawPathInfo req)
+                        writeIORef responseLoggedForSize True
+                    -- send the chunk, regardless of if we're over the limit
+                    writeChunk (Builder.byteString chunk)
+        respReceived <- withResponseBody $ \originalBody ->
+            respond $ responseStream status headers $ \writeChunk doFlush ->
+                originalBody (monitoredWriteChunk writeChunk) doFlush
+        finalResponseByteCount <- readIORef responseByteCounter
         resTime <- getTime Monotonic
         logFunctionJson logger Info
-            $ logRequestResponse reqLog res
-            $ (int $ toNanoSecs $ diffTimeSpec resTime reqTime) `div` 1000
-        return r
+            $ RequestResponseLog
+            { _requestResponseLogRequest = reqLog
+            , _requestResponseLogStatus = sshow $ responseStatus res
+            , _requestResponseLogDurationMicro = (int $ toNanoSecs $ diffTimeSpec resTime reqTime) `div` 1000
+            , _requestResponseLogResponseSize = finalResponseByteCount
+            }
+        return respReceived