Simple WAI logging

Log.hs

{-# LANGUAGE UnicodeSyntax #-}

module Log where

import Network.Wai
import Network.HTTP.Types

import System.Log.Logger
import qualified Data.ByteString.Char8 as C
import Control.Monad.Trans
import Data.Time.Clock
import Data.Time.Format
import System.Locale
import System.Log.Handler.Simple
import System.Log.Handler.Syslog
import System.IO


-- WAI Application wrapper that writes apache-style logs with hslogger
logRequests ∷ MonadIO m ⇒
  (Request → m Response) → Request → m Response
logRequests app request = do
  response ← app request
  time ← liftIO formatLogTimeNow
  withStatus response $
    \status → infoM "request" . unwords $ [
      C.unpack $ serverName request,
      host,
      "-",
      "-",
      time,
      q $ unwords [
        C.unpack $ requestMethod request,
        C.unpack $ rawPathInfo request],
      show $ statusCode status,
      "-",
      q $ header "referer",
      q $ header "user-agent"]
  where
   header h = maybe "-" C.unpack . lookup h $
     requestHeaders request
   host = reverse . tail . snd . break (==':') . reverse . show $
     remoteHost request


-- setLogPrio (Just DEBUG) Nothing : log all to stderr
-- setLogPrio Nothing (Just NOTICE) : log important to syslog
setLogPrio verbosity syslog = do
  updateGlobalLogger rootLoggerName
    (setLevel DEBUG . setHandlers ([] ∷ [GenericHandler ()]))
  flip (maybe (return ())) syslog $ \prio → do
    s ← openlog "WAI" [PID] USER prio
    updateGlobalLogger rootLoggerName (addHandler s)
  flip (maybe (return ())) verbosity $ \prio → do
    s ← streamHandler stderr prio
    updateGlobalLogger rootLoggerName (addHandler s)

formatLogTimeNow = do
  flip fmap getCurrentTime $ formatTime defaultTimeLocale
    "[%d/%b/%Y:%T %z]"

withStatus ∷ MonadIO m ⇒
  Response → (Status → IO ()) → m Response
withStatus r@(ResponseFile s _ _ _) f =
  liftIO (f s) >> return r
withStatus r@(ResponseBuilder s _ _) f =
  liftIO (f s) >> return r
withStatus (ResponseEnumerator g) f = return $ 
  ResponseEnumerator $ \k → g $ \s h → liftIO (f s) >> k s h

q = ("\"" ++) . (++ "\"")