4

我正在尝试在我的 happstack 应用程序中存储所有 200 个响应代码的计数器。

module Main where

import Happstack.Server

import Control.Concurrent
import Control.Monad.IO.Class ( liftIO )
import Control.Monad

main :: IO ()
main = do
  counter <- (newMVar 0) :: IO (MVar Integer)

  simpleHTTP nullConf $ countResponses counter (app counter)

countResponses :: MVar Integer -> ServerPart Response -> ServerPart Response
countResponses counter r = do
  resp <- r
  liftIO $ putStrLn $ show resp
  -- TODO: Does not work, response code always 200
  if rsCode resp == 200
    then liftIO $ (putMVar counter . (+) 1) =<< takeMVar counter
    else liftIO $ putStrLn $ "Unknown code: " ++ (show $ rsCode resp)
  return resp

app counter = do
  c <- liftIO $ readMVar counter

  msum
    [ dir "error" $ notFound $ toResponse $ "NOT HERE"
    , ok $ toResponse $ "Hello, World! " ++ (show c)
    ]

据我所知，问题在于notFound添加了一个设置代码的过滤器，在我检查响应时该代码尚未运行。

我不能使用我自己的过滤器，因为它有类型Response -> Response并且我需要在 IO monad 中才能访问 mvar。我发现mapServerPartT这看起来可以挂在我自己的代码中，但我不太确定在这种情况下这是否是矫枉过正。

我确实找到了 simpleHttp''，它似乎直接调用runWebT，然后在我可以挂钩的任何代码appFilterToResp 之外运行。也许我必须建立自己的版本simpleHttp''？

更新：这行得通，这是最好的方法吗？

-- Use this instead of simpleHTTP
withMetrics :: (ToMessage a) => MVar Integer -> Conf -> ServerPartT IO a -> IO ()
withMetrics counter conf hs =
    Listen.listen conf (\req -> (simpleHTTP'' (mapServerPartT id hs) req) >>=
                                runValidator (fromMaybe return (validator conf)) >>=
                                countResponses counter)

一个可能相关的问题：我还希望能够对请求进行计时，这意味着我必须在请求周期结束时在同一个位置挂上钩子。

更新2：我能够获得请求的时间：

logMessage x = logM "Happstack.Server.AccessLog.Combined" INFO x

withMetrics :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()
withMetrics conf hs =
    Listen.listen conf $ \req -> do
      startTime     <- liftIO $ getCurrentTime
      resp          <- simpleHTTP'' (mapServerPartT id hs) req
      validatedResp <- runValidator (fromMaybe return (validator conf)) resp
      endTime       <- liftIO $ getCurrentTime
      logMessage $ rqUri req ++ " " ++ show (diffUTCTime endTime startTime)
      return validatedResp
4

0 回答 0