Issue/62 custom access and error log handlers (against 0.9-stable)

snap-server.cabal

@@ -1,5 +1,5 @@
 name:           snap-server
-version:        0.9.5.1
+version:        0.10.0.0
 synopsis:       A fast, iteratee-based, epoll-enabled web server for the Snap Framework
 description:
   Snap is a simple and fast web development framework and server written in

src/Snap/Http/Server.hs

@@ -77,7 +77,9 @@ simpleHttpServe config handler = do
                           (listeners conf)
                           (fromJust $ getHostname  conf)
                           alog
+                          (getAccessLogHandler conf)
                           elog
+                          (getErrorLogHandler conf)
                           (\sockets -> let dat = mkStartupInfo sockets conf
                                        in maybe (return ())
                                                 ($ dat)

src/Snap/Http/Server/Config.hs

@@ -9,6 +9,9 @@ module Snap.Http.Server.Config
   ( Config
   , ConfigLog(..)
 
+  , AccessLogHandler
+  , ErrorLogHandler
+
   , emptyConfig
   , defaultConfig
   , commandLineConfig
@@ -19,11 +22,13 @@ module Snap.Http.Server.Config
   , fmapOpt
 
   , getAccessLog
+  , getAccessLogHandler
   , getBind
   , getCompression
   , getDefaultTimeout
   , getErrorHandler
   , getErrorLog
+  , getErrorLogHandler
   , getHostname
   , getLocale
   , getOther
@@ -38,11 +43,13 @@ module Snap.Http.Server.Config
   , getStartupHook
 
   , setAccessLog
+  , setAccessLogHandler
   , setBind
   , setCompression
   , setDefaultTimeout
   , setErrorHandler
   , setErrorLog
+  , setErrorLogHandler
   , setHostname
   , setLocale
   , setOther
@@ -61,3 +68,4 @@ module Snap.Http.Server.Config
   ) where
 
 import Snap.Internal.Http.Server.Config
+import Snap.Internal.Http.Server

src/Snap/Internal/Http/Server.hs

@@ -93,6 +93,15 @@ type ServerHandler = (ByteString -> IO ())
 ------------------------------------------------------------------------------
 type ServerMonad = StateT ServerState (Iteratee ByteString IO)
 
+------------------------------------------------------------------------------
+-- | This handler may be used (in conjunction with setErrorLogHandler) to write out error logs in a 
+-- custom manner.
+type ErrorLogHandler = ByteString -> IO ByteString
+
+------------------------------------------------------------------------------
+-- | This handler may be used (in conjunction with setAccessLogHandler) to write out access logs in a
+-- custom manner.
+type AccessLogHandler = Request -> Response -> IO ByteString
 
 ------------------------------------------------------------------------------
 data ListenPort =
@@ -155,11 +164,13 @@ httpServe :: Int                         -- ^ default timeout
           -> [ListenPort]                -- ^ ports to listen on
           -> ByteString                  -- ^ local hostname (server name)
           -> Maybe (ByteString -> IO ()) -- ^ access log action
+          -> Maybe AccessLogHandler
           -> Maybe (ByteString -> IO ()) -- ^ error log action
+          -> Maybe ErrorLogHandler
           -> ([Socket] -> IO ())         -- ^ initialisation
           -> ServerHandler               -- ^ handler procedure
           -> IO ()
-httpServe defaultTimeout ports localHostname alog' elog' initial handler =
+httpServe defaultTimeout ports localHostname alog' alh elog' elh initial handler =
     withSocketsDo $ spawnAll alog' elog' `catches` errorHandlers
 
   where
@@ -170,7 +181,7 @@ httpServe defaultTimeout ports localHostname alog' elog' initial handler =
 
     --------------------------------------------------------------------------
     sslException (e@(TLS.TLSException msg)) = do
-        logE elog' msg
+        logE errorHandle elog' msg
         SC.hPutStrLn stderr msg
         throw e
 
@@ -183,14 +194,14 @@ httpServe defaultTimeout ports localHostname alog' elog' initial handler =
                     "Error on startup: \n"
                   , T.encodeUtf8 $ T.pack $ show e
                   ]
-        logE elog' msg
+        logE errorHandle elog' msg
         SC.hPutStrLn stderr msg
         throw e
 
     --------------------------------------------------------------------------
     spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do
 
-        logE elog $ S.concat [ "Server.httpServe: START, binding to "
+        logE errorHandle elog $ S.concat [ "Server.httpServe: START, binding to "
                              , bshow ports ]
 
         let isHttps p = case p of { (HttpsPort _ _ _ _ _) -> True; _ -> False;}
@@ -203,36 +214,58 @@ httpServe defaultTimeout ports localHostname alog' elog' initial handler =
         nports <- mapM bindPort ports
         let socks = map (\x -> case x of ListenHttp s -> s; ListenHttps s _ -> s) nports
 
-        (simpleEventLoop defaultTimeout nports numCapabilities (logE elog) (initial socks)
-                    $ runHTTP defaultTimeout alog elog handler localHostname)
+        (simpleEventLoop defaultTimeout nports numCapabilities (logE errorHandle elog) (initial socks)
+                    $ runHTTP defaultTimeout alog alh elog elh handler localHostname)
           `finally` do
-            logE elog "Server.httpServe: SHUTDOWN"
+            logE errorHandle elog "Server.httpServe: SHUTDOWN"
 
             if initHttps
                 then TLS.stopTLS
                 else return ()
 
-            logE elog "Server.httpServe: BACKEND STOPPED"
+            logE errorHandle elog "Server.httpServe: BACKEND STOPPED"
 
     --------------------------------------------------------------------------
     bindPort (HttpPort  baddr port         ) = bindHttp  baddr port
     bindPort (HttpsPort baddr port cert chainCert key) =
         TLS.bindHttps baddr port cert chainCert key
 
+    errorHandle = fromMaybe defaultErrorLogHandler elh
+
 
 ------------------------------------------------------------------------------
 debugE :: (MonadIO m) => ByteString -> m ()
 debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s)
 
+------------------------------------------------------------------------------
+defaultAccessLogHandler :: AccessLogHandler
+defaultAccessLogHandler req rsp = do
+    let hdrs      = rqHeaders req
+    let host      = rqRemoteAddr req
+    let user      = Nothing -- TODO we don't do authentication yet
+    let (v, v')   = rqVersion req
+    let ver       = S.concat [ "HTTP/", bshow v, ".", bshow v' ]
+    let method    = toBS $ show (rqMethod req)
+    let reql      = S.intercalate " " [ method, rqURI req, ver ]
+    let status    = rspStatus rsp
+    let cl        = rspContentLength rsp
+    let referer   = maybe Nothing (Just . head) $ H.lookup "referer" hdrs
+    let userAgent = maybe "-" head $ H.lookup "user-agent" hdrs
+
+    combinedLogEntry host user reql status cl referer userAgent
+
+------------------------------------------------------------------------------
+defaultErrorLogHandler :: ErrorLogHandler
+defaultErrorLogHandler = timestampedLogEntry
 
 ------------------------------------------------------------------------------
-logE :: Maybe (ByteString -> IO ()) -> ByteString -> IO ()
-logE elog = maybe debugE (\l s -> debugE s >> logE' l s) elog
+logE :: ErrorLogHandler -> Maybe (ByteString -> IO ()) -> ByteString -> IO ()
+logE elh elog = maybe debugE (\l s -> debugE s >> logE' elh l s) elog
 
 
 ------------------------------------------------------------------------------
-logE' :: (ByteString -> IO ()) -> ByteString -> IO ()
-logE' logger s = (timestampedLogEntry s) >>= logger
+logE' :: ErrorLogHandler -> (ByteString -> IO ()) -> ByteString -> IO ()
+logE' elh logger s = logger =<< elh s
 
 
 ------------------------------------------------------------------------------
@@ -241,33 +274,21 @@ bshow = toBS . show
 
 
 ------------------------------------------------------------------------------
-logA :: Maybe (ByteString -> IO ()) -> Request -> Response -> IO ()
-logA alog = maybe (\_ _ -> return ()) logA' alog
+logA :: AccessLogHandler -> Maybe (ByteString -> IO ()) -> Request -> Response -> IO ()
+logA alh alog = maybe (\_ _ -> return ()) (logA' alh) alog
 
 
 ------------------------------------------------------------------------------
-logA' :: (ByteString -> IO ()) -> Request -> Response -> IO ()
-logA' logger req rsp = do
-    let hdrs      = rqHeaders req
-    let host      = rqRemoteAddr req
-    let user      = Nothing -- TODO we don't do authentication yet
-    let (v, v')   = rqVersion req
-    let ver       = S.concat [ "HTTP/", bshow v, ".", bshow v' ]
-    let method    = toBS $ show (rqMethod req)
-    let reql      = S.intercalate " " [ method, rqURI req, ver ]
-    let status    = rspStatus rsp
-    let cl        = rspContentLength rsp
-    let referer   = maybe Nothing (Just . head) $ H.lookup "referer" hdrs
-    let userAgent = maybe "-" head $ H.lookup "user-agent" hdrs
-
-    msg <- combinedLogEntry host user reql status cl referer userAgent
-    logger msg
+logA' :: AccessLogHandler -> (ByteString -> IO ()) -> Request -> Response -> IO ()
+logA' alh logger req rsp = logger =<< alh req rsp
 
 
 ------------------------------------------------------------------------------
 runHTTP :: Int                           -- ^ default timeout
         -> Maybe (ByteString -> IO ())   -- ^ access logger
+        -> Maybe AccessLogHandler
         -> Maybe (ByteString -> IO ())   -- ^ error logger
+        -> Maybe ErrorLogHandler
         -> ServerHandler                 -- ^ handler procedure
         -> ByteString                    -- ^ local host name
         -> SessionInfo                   -- ^ session port information
@@ -277,7 +298,7 @@ runHTTP :: Int                           -- ^ default timeout
                                          -- ^ sendfile end
         -> ((Int -> Int) -> IO ())       -- ^ timeout tickler
         -> IO ()
-runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
+runHTTP defaultTimeout alog alh elog elh handler lh sinfo readEnd writeEnd onSendFile
         tickle =
     go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do
                        return ()
@@ -288,7 +309,7 @@ runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
                  , Handler $ \(e :: AsyncException) -> do
                        throwIO e
                  , Handler $ \(e :: SomeException) ->
-                       logE elog $ toByteString $ lmsg e
+                       logE errorHandle elog $ toByteString $ lmsg e
                  ]
 
   where
@@ -301,7 +322,7 @@ runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
 
     go = do
         buf <- allocBuffer 16384
-        let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $
+        let iter1 = runServerMonad lh sinfo (logA accessHandle alog) (logE errorHandle elog) $
                                    httpSession defaultTimeout writeEnd buf
                                                onSendFile tickle handler
         let iter = iterateeDebugWrapper "httpSession iteratee" iter1
@@ -314,6 +335,9 @@ runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
         run_ $ readEnd step
         debug "runHTTP/go: finished"
 
+    accessHandle = fromMaybe defaultAccessLogHandler alh
+    errorHandle = fromMaybe defaultErrorLogHandler elh
+
 
 ------------------------------------------------------------------------------
 requestErrorMessage :: Request -> SomeException -> Builder

src/Snap/Internal/Http/Server/Config.hs

@@ -43,7 +43,7 @@ import           System.Posix.Env
 import           System.Exit
 import           System.IO
 ------------------------------------------------------------------------------
-import           Snap.Internal.Http.Server (requestErrorMessage)
+import           Snap.Internal.Http.Server (requestErrorMessage, ErrorLogHandler, AccessLogHandler)
 
 
 ------------------------------------------------------------------------------
@@ -78,25 +78,27 @@ instance Show ConfigLog where
 -- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and
 -- this is the norm) are filled in with default values from 'defaultConfig'.
 data Config m a = Config
-    { hostname       :: Maybe ByteString
-    , accessLog      :: Maybe ConfigLog
-    , errorLog       :: Maybe ConfigLog
-    , locale         :: Maybe String
-    , port           :: Maybe Int
-    , bind           :: Maybe ByteString
-    , sslport        :: Maybe Int
-    , sslbind        :: Maybe ByteString
-    , sslcert        :: Maybe FilePath
-    , sslchaincert   :: Maybe Bool
-    , sslkey         :: Maybe FilePath
-    , compression    :: Maybe Bool
-    , verbose        :: Maybe Bool
-    , errorHandler   :: Maybe (SomeException -> m ())
-    , defaultTimeout :: Maybe Int
-    , other          :: Maybe a
-    , backend        :: Maybe ConfigBackend
-    , proxyType      :: Maybe ProxyType
-    , startupHook    :: Maybe (StartupInfo m a -> IO ())
+    { hostname          :: Maybe ByteString
+    , accessLog         :: Maybe ConfigLog
+    , errorLog          :: Maybe ConfigLog
+    , accessLogHandler  :: Maybe AccessLogHandler
+    , errorLogHandler   :: Maybe ErrorLogHandler
+    , locale            :: Maybe String
+    , port              :: Maybe Int
+    , bind              :: Maybe ByteString
+    , sslport           :: Maybe Int
+    , sslbind           :: Maybe ByteString
+    , sslcert           :: Maybe FilePath
+    , sslchaincert      :: Maybe Bool
+    , sslkey            :: Maybe FilePath
+    , compression       :: Maybe Bool
+    , verbose           :: Maybe Bool
+    , errorHandler      :: Maybe (SomeException -> m ())
+    , defaultTimeout    :: Maybe Int
+    , other             :: Maybe a
+    , backend           :: Maybe ConfigBackend
+    , proxyType         :: Maybe ProxyType
+    , startupHook       :: Maybe (StartupInfo m a -> IO ())
     }
 #if MIN_VERSION_base(4,7,0)
   deriving Typeable
@@ -167,6 +169,8 @@ instance Monoid (Config m a) where
         { hostname       = Nothing
         , accessLog      = Nothing
         , errorLog       = Nothing
+        , accessLogHandler = Nothing
+        , errorLogHandler = Nothing
         , locale         = Nothing
         , port           = Nothing
         , bind           = Nothing
@@ -189,6 +193,8 @@ instance Monoid (Config m a) where
         { hostname       = ov hostname
         , accessLog      = ov accessLog
         , errorLog       = ov errorLog
+        , accessLogHandler = ov accessLogHandler 
+        , errorLogHandler = ov errorLogHandler
         , locale         = ov locale
         , port           = ov port
         , bind           = ov bind
@@ -241,10 +247,18 @@ getHostname = hostname
 getAccessLog      :: Config m a -> Maybe ConfigLog
 getAccessLog = accessLog
 
+-- | Get the access log handler
+getAccessLogHandler :: Config m a -> Maybe AccessLogHandler
+getAccessLogHandler = accessLogHandler
+
 -- | Path to the error log
 getErrorLog       :: Config m a -> Maybe ConfigLog
 getErrorLog = errorLog
 
+-- | Get the error log handler
+getErrorLogHandler :: Config m a -> Maybe ErrorLogHandler
+getErrorLogHandler = errorLogHandler
+
 -- | Gets the locale to use. Locales are used on Unix only, to set the
 -- @LANG@\/@LC_ALL@\/etc. environment variable. For instance if you set the
 -- locale to \"@en_US@\", we'll set the relevant environment variables to
@@ -319,9 +333,15 @@ setHostname x c = c { hostname = Just x }
 setAccessLog      :: ConfigLog               -> Config m a -> Config m a
 setAccessLog x c = c { accessLog = Just x }
 
+setAccessLogHandler :: AccessLogHandler      -> Config m a -> Config m a
+setAccessLogHandler x c = c { accessLogHandler = Just x }
+
 setErrorLog       :: ConfigLog               -> Config m a -> Config m a
 setErrorLog x c = c { errorLog = Just x }
 
+setErrorLogHandler :: ErrorLogHandler        -> Config m a -> Config m a
+setErrorLogHandler x c = c { errorLogHandler = Just x }
+
 setLocale         :: String                  -> Config m a -> Config m a
 setLocale x c = c { locale = Just x }