log request body with debug log level

kadena-io · Oct 12, 2024 · 834c09e · 834c09e
1 parent 578e9fc
commit 834c09e
Showing 1 changed file with 62 additions and 26 deletions.
diff --git a/src/Chainweb/Utils/RequestLog.hs b/src/Chainweb/Utils/RequestLog.hs
@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
 
 -- |
 -- Module: Chainweb.Utils.RequestLog
@@ -32,7 +33,7 @@ module Chainweb.Utils.RequestLog
 , requestLogRawRemoteHost
 , requestLogRemoteHost
 , requestLogQueryString
-, requestLogBodyLength
+, requestLogBody
 , requestLogUserAgent
 , requestLogHeaders
 , requestLogger
@@ -48,7 +49,7 @@ module Chainweb.Utils.RequestLog
 import Control.DeepSeq
 import Control.Lens hiding ((.=))
 
-import Data.Aeson
+import Data.Aeson hiding (Error)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as T
@@ -57,18 +58,24 @@ import qualified Data.Text.Encoding as T
 import GHC.Generics
 
 import Network.HTTP.Types
-import Network.Socket
+import Network.Socket hiding (Debug)
 import Network.Wai
 
 import Numeric.Natural
 
 import System.Clock
 import System.LogLevel
+import System.Logger(setLoggerLevel, LogLevel(Debug))
 
 -- internal modules
 
 import Chainweb.Logger
 import Chainweb.Utils
+import Data.IORef
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as Builder
+import qualified Data.ByteString.Lazy as LBS
+import Data.ByteString (ByteString)
 
 -- -------------------------------------------------------------------------- --
 -- Request Logger
@@ -91,7 +98,7 @@ data RequestLog = RequestLog
     , _requestLogRawRemoteHost :: !T.Text
     , _requestLogRemoteHost :: !JsonSockAddr
     , _requestLogQueryString :: !QueryText
-    , _requestLogBodyLength :: !(Maybe Natural)
+    , _requestLogBody :: !(Either (Maybe Natural) ByteString)
     , _requestLogUserAgent :: !(Maybe T.Text)
     , _requestLogHeaders :: !(HM.HashMap T.Text T.Text)
     }
@@ -109,10 +116,13 @@ requestLogProperties o =
     , "rawRemoteHost" .= _requestLogRawRemoteHost o
     , "remoteHost" .= _requestLogRemoteHost o
     , "queryString" .= _requestLogQueryString o
-    , "bodyLength" .= _requestLogBodyLength o
     , "userAgent" .= _requestLogUserAgent o
     , "headers" .= _requestLogHeaders o
-    ]
+    ] ++ case _requestLogBody o of
+        Left bodyLength ->
+            ["bodyLength" .= bodyLength]
+        Right body ->
+            ["body" .= T.decodeUtf8 body, "bodyLength" .= BS.length body]
 {-# INLINE requestLogProperties #-}
 
 instance ToJSON RequestLog where
@@ -124,27 +134,52 @@ instance ToJSON RequestLog where
 -- | INVARIANT: this result of this function must not retain pointers to
 -- the original request data that came over the wire.
 --
-logRequest :: Request -> RequestLog
-logRequest req = RequestLog
-    { _requestLogVersion = sshow $ httpVersion req
-    , _requestLogMethod = T.decodeUtf8 $ requestMethod req
-    , _requestLogPath = pathInfo req
-    , _requestLogIsSecure = isSecure req
-    , _requestLogRawRemoteHost = sshow $ remoteHost req
-    , _requestLogRemoteHost = JsonSockAddr $ remoteHost req
-    , _requestLogQueryString = queryToQueryText $ queryString req
-    , _requestLogBodyLength = case requestBodyLength req of
-        ChunkedBody -> Nothing
-        KnownLength x -> Just $ int x
-    , _requestLogUserAgent = T.decodeUtf8 <$> requestHeaderUserAgent req
-    , _requestLogHeaders = HM.fromList $
-        bimap (T.decodeUtf8 . CI.original) T.decodeUtf8 <$> (requestHeaders req)
-    }
+logRequest :: System.Logger.LogLevel -> Request -> IO (Request, RequestLog)
+logRequest lvl req = do
+    (req', body) <-
+        if lvl >= System.Logger.Debug
+        then getBody mempty
+        else return $ (req,) $ Left $ case requestBodyLength req of
+            ChunkedBody -> Nothing
+            KnownLength x -> Just $ int x
+    let !reqLog = RequestLog
+            { _requestLogVersion = sshow $ httpVersion req
+            , _requestLogMethod = T.decodeUtf8 $ requestMethod req
+            , _requestLogPath = pathInfo req
+            , _requestLogIsSecure = isSecure req
+            , _requestLogRawRemoteHost = sshow $ remoteHost req
+            , _requestLogRemoteHost = JsonSockAddr $ remoteHost req
+            , _requestLogQueryString = queryToQueryText $ queryString req
+            , _requestLogBody = body
+            , _requestLogUserAgent = T.decodeUtf8 <$> requestHeaderUserAgent req
+            , _requestLogHeaders = HM.fromList $
+                bimap (T.decodeUtf8 . CI.original) T.decodeUtf8 <$> (requestHeaders req)
+            }
+    return (req', reqLog)
+    where
+    getBody bodySoFar = do
+        nextChunk <- getRequestBodyChunk req
+        if BS.null nextChunk
+        then do
+            let !finalStrictBody = LBS.toStrict $ Builder.toLazyByteString bodySoFar
+            -- here we set the entire request body to be a single chunk, which
+            -- is the entire request body that we accumulated. this requires
+            -- that we emit the chunk when called and emit empty chunks after
+            fetchedChunk <- newIORef False
+            let fetchChunk = do
+                    fetched <- readIORef fetchedChunk
+                    if fetched then return mempty
+                    else return finalStrictBody
+            return (setRequestBodyChunks fetchChunk req, Right finalStrictBody)
+        else getBody (bodySoFar <> Builder.byteString nextChunk)
 
 requestLogger :: Logger l => l -> Middleware
 requestLogger logger app req respond = do
-    logFunctionJson logger Info $ logRequest req
-    app req respond
+    let lvl = logger ^. setLoggerLevel
+    (req', lg) <- logRequest lvl req
+
+    logFunctionJson logger Info lg
+    app req' respond
 
 -- -------------------------------------------------------------------------- --
 -- Request-Response Logger
@@ -184,9 +219,10 @@ logRequestResponse reqLog res d = RequestResponseLog
 --
 requestResponseLogger :: Logger l => l -> Middleware
 requestResponseLogger logger app req respond = do
-    let !reqLog = logRequest req
+    let lvl = logger ^. setLoggerLevel
+    (req', reqLog) <- logRequest lvl req
     reqTime <- getTime Monotonic
-    app req $ \res -> do
+    app req' $ \res -> do
         r <- respond res
         resTime <- getTime Monotonic
         logFunctionJson logger Info