How to add logging to a Happstack server

Disclaimer: this post describes experience of a Happstack newbie.

A very simple (but already useful!) server in Happstack may be written like this:

import Happstack.Server
import System.Environment
import Control.Monad (when)

main = do
  args <- getArgs
  when (length args < 2) $ error "Usage: ./HelloHTTP <a directory to serve>"

  simpleHTTP nullConf $ serveDirectory EnableBrowsing ["index.htm"] (head args)

This has been pretty sufficient for my simple home page for some time, but now I want logging about who is visiting the page.

Let’s do this!

The problem is: we want to write to a log file, thus some IO must be done. This is handled by Control.Monad.IO.Class.liftIO used to lift to whatever monad used by serveDirectory from any Monad m => MonadIO m monad:

λ> import Control.Monad.IO.Class
λ> :i liftIO

class Monad m => MonadIO m where
    liftIO :: IO a -> m a
            -- Defined in `Control.Monad.IO.Class'

 

Now it’s time to refactor main to do some additional action when routing a request:

route webroot = do
    logRequest                  -- to be defined later
    serveDirectory EnableBrowsing ["index.htm"] webroot

main = do
    ...
    simpleHTTP nullConf $ route (head args)

Happstack has a type Request, that encapsulates information about a HTTP(S) request. It contains information about a peer who is connecting to the server and a resource on the server it requests also:

λ> :i Request
data Request
  = Request {
     ...
     -- if "/js/some.js" is requested, it's ["js", "some.js"]:
     rqPaths :: [String],
     ...
     -- Host is (String, Port):
     rqPeer :: Host, 
     ... }

How to get a request that is implicitly contained within a monad that handles requests? First of all, let’s find out what this monad really is:

λ> :i serveDirectory -- this is our starting point
serveDirectory ::
  (WebMonad Response m, ServerMonad m, FilterMonad Response m,
   Control.Monad.IO.Class.MonadIO m, Control.Monad.MonadPlus m) =>
  Browsing -> [FilePath] -> FilePath -> m Response
        -- Defined in `Happstack.Server.FileServe.BuildingBlocks'

Whoa! There’s a lot of polymorphic stuff here, not just a single monad. All those typeclasses (WebMonad, FilterMonad, MonadIO, MonadPlus, ServerMonad) introduce some restrictions that define what monad may be used here, so it must provide all these typeclasses’ interfaces. All of MonadIO, MonadPlus, FilterMonad are from the standard library, so let’s examine ServerMonad and WebMonad. This reveals the function in question:

λ> :i ServerMonad
class Monad m => ServerMonad m where
    askRq :: m Request
    ...

Now, just use askRq in the routing code:

{-| This logRequest just dumps full description of a request into the stdout |-}
logRequest = do
    rq <- askRq     -- I do not even know what monad we're extracting from!
    liftIO $ print rq  -- quick debugging hack to make sure a request is acquired

With this definition, the code above runs properly, dumping all requests into the stdout. That’s better than nothing, but the goal is to log events to a file. It’s pretty easy from this point, the only hurdle here is to learn how to use System.Time:

-- new imports:
import Data.List (intercalate)
import System.IO (appendFile)
import System.Time (formatCalendarTime, toUTCTime, getClockTime)
import System.Locale (defaultTimeLocale)

serverLog = "/var/log/hshttpd.log"

logRecordFor rq = do              -- now in IO monad
    clocktime <- getClockTime
    let showUTCTime = formatCalendarTime defaultTimeLocale "%D %T" . toUTCTime
        time = showUTCTime clocktime
        peer = fst $ rqPeer rq
        -- show the requested resource in unix path format:
        res = intercalate "/" $ rqPaths rq 
        method = show $ rqMethod rq
        record = time ++ ": " ++ peer ++ " -- " ++ method ++ " /" ++ res ++ "\n"
    appendFile serverLog record

logRequest = do
    rq <- askRq
    liftIO $ logRecordFor rq

That’s it, now /var/log/hshttpd.log is roughly similar to an Apache log.

Advertisements