Warp应用中如何记录请求、响应、错误与超时？

云原生阿岚

2026-7-9

在Warp/Servant应用中正确记录请求、响应及超时的方案

问题背景

我的Servant处理器执行长时间计算时，因为使用普通return语句，处理器会立即返回，实际计算要等到Warp向客户端发送响应时才惰性执行，这会触发Warp的slowloris超时（长时间无网络数据传输）。虽然通过在服务处理器内强制求值（用return $!）修复了问题，但这个问题编译或运行时都没有提示，很难诊断，想避免再出现。

我希望至少能在运行时追踪以下内容：

记录所有请求和响应
在日志中标记错误和超时
理想情况下，标记请求的开始和完成

试过wai-logger包（通过Warp的setLogger配置），但它只在请求完成时记录，遇到错误或超时就没有日志；也试过wai-extra的RequestLogger中间件，在上述场景里会立即记录成功日志（哪怕响应没发送，因为响应体是惰性计算的），同样没有错误或超时提示。

请问在Warp应用中，记录所有请求、响应（包含错误和超时）的最佳方式是什么？

更新1：示例代码

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}

import Network.Wai.Handler.Warp
import Servant

type Service = Get '[JSON] Int

service :: Server Service
service = return $ sum [0..100000000000]

main :: IO ()
main = run 3000 $ serve @Service Proxy service

使用curl http://localhost:3000时，1分钟后会收到curl: (52) Empty reply from server（默认30s超时的2倍）。多次执行该命令后请求最终会成功，推测sum [0..100000000000]生成的部分求值闭包可在后续请求中继续计算，但不确定。使用return $! sum [0..100000000000]可修复该问题。

解决方案

一、编译时提前规避惰性求值问题

虽然Haskell的惰性求值是特性，但可以通过以下方式提前避免这类超时问题：

封装强制求值工具函数：对需要立即计算的响应结果，用deepseq或$!确保完全求值后再返回给Warp，比如：
```
import Control.DeepSeq (NFData, force)
import Servant (Handler)

returnStrict :: (NFData a) => a -> Handler a
returnStrict = return . force
```
在处理器里用returnStrict $ sum [...]替代普通return，确保计算完成后再生成响应。
启用编译器警告：添加-Wall、-Wunused-do-bind编译选项，虽不能直接检测惰性超时，但能发现潜在的非严格求值隐患。

二、运行时全链路日志方案

要覆盖请求开始、完成、错误、超时全流程日志，需要结合自定义中间件和Warp的超时回调：

1. 自定义请求生命周期中间件

放弃wai-extra默认的RequestLogger，自己实现中间件追踪请求全周期，同时处理响应体惰性求值问题：

import Network.Wai
import Network.HTTP.Types.Status
import Data.Time.Clock
import Control.Monad.IO.Class (liftIO)
import Control.Exception (catch, SomeException)

requestLifecycleMiddleware :: Middleware
requestLifecycleMiddleware app req sendResponse = do
  startTime <- liftIO getCurrentTime
  liftIO $ putStrLn $ "[START] " ++ show startTime ++ " " ++ show (requestMethod req) ++ " " ++ rawPathInfo req
  -- 包装sendResponse，确保响应体求值完成后再记录结束日志
  let wrappedSendResponse resp = do
        -- 强制求值响应体（流式响应需特殊处理）
        _ <- liftIO $ evaluate $ responseBody resp
        sendResponse resp
        endTime <- liftIO getCurrentTime
        liftIO $ putStrLn $ "[FINISH] " ++ show endTime ++ " " ++ show (responseStatus resp) ++ " " ++ show (requestMethod req) ++ " " ++ rawPathInfo req
  -- 捕获处理器抛出的异常并记录错误日志
  app req wrappedSendResponse `catch` \(e :: SomeException) -> do
    endTime <- liftIO getCurrentTime
    liftIO $ putStrLn $ "[ERROR] " ++ show endTime ++ " " ++ show e ++ " " ++ show (requestMethod req) ++ " " ++ rawPathInfo req
    sendResponse $ responseLBS status500 [] "Internal Server Error"

该中间件会在请求到达时记录开始时间，响应体求值完成后记录结束时间，同时捕获异常并输出错误日志。

2. 配置Warp超时回调

Warp默认30秒超时，超时发生时不会主动记录日志，需通过setOnTimeout配置回调：

import Network.Wai.Handler.Warp
import Data.IORef

main :: IO ()
main = do
  let settings = defaultSettings
        { port = 3000
        , onTimeout = \_ -> putStrLn "[TIMEOUT] Request timed out"
        }
  runSettings settings $ requestLifecycleMiddleware $ serve @Service Proxy service

如果需要关联具体请求信息，可以在中间件中用IORef存储Socket与请求ID的映射，实现更精准的超时日志（简单场景下直接记录超时事件即可）。

3. 组合使用注意事项

中间件必须在serve之前应用，才能捕获所有请求的生命周期。
对于流式响应（如SourceIO），不能直接用evaluate强制求值，需改用mapM_ evaluate遍历流元素，或根据业务调整日志时机。
可将日志输出替换为monad-logger、katip等专业日志库，支持分级日志、结构化输出等功能。

三、额外调试手段

临时调整Warp超时时间：用setTimeout增大超时阈值，验证是否为惰性求值导致的问题。

在处理器中添加中间日志：确认计算是否在处理器阶段执行，比如：

service :: Server Service
service = do
  liftIO $ putStrLn "Starting calculation..."
  let result = sum [0..100000000000]
  liftIO $ putStrLn "Calculation finished..."
  return $! result

内容的提问来源于stack exchange，提问作者Jules

Warp应用中如何记录请求、响应、错误与超时？

问题背景 #

解决方案 #

一、编译时提前规避惰性求值问题 #

二、运行时全链路日志方案 #