How to access response code in happstack?

Question

I am trying to keep a counter of all 200 response codes in my happstack application.

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)
    ]

The problem, as far as I can tell, is that it notFoundadds a filter that sets code that was not run while checking the response.

I can’t connect to my own filter, because it has a type Response -> Response, and I need to be in the IO monad to access mvar. I found mapServerPartTone that looks like one could plug in my own code, but I'm not quite sure if this is overkill in this scenario.

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