How to access the response code in happstack?

Question

I'm trying to store 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 notFound adds a filter that sets the code, which hasn't been run at the time I am inspecting the response.

I can't hook in with my own filter, since it has type Response -> Response and I need to be in the IO monad to access the mvar. I found mapServerPartT which looks like it could be possible to hook in my own code, but I'm not quite sure whether that's overkill in this scenario.

I did find simpleHttp'' which seems to directly call runWebT, which then runs appFilterToResp outside of any code I can hook. Perhaps I have to build my own version of simpleHttp''?

UPDATE: This works, is it the best way?

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

A possibly related question: I also want to be able to time requests, which means I would have to hook in at probably the same spot at the end of the request cycle.

UPDATE 2: I was able to get timings for requests:

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

How to access the response code in happstack?

0 Answers0