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.