diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs index 84f61a81..bad87566 100644 --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -25,7 +25,7 @@ import Control.Concurrent (killThread, newEmptyMVar, ne import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs) import Control.Exception (SomeException, bracket, catch, finally, mask, mask_) import qualified Control.Exception.Lifted as L -import Control.Monad (liftM, when) +import Control.Monad (liftM, when, (=<<)) import Control.Monad.Trans (MonadIO) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S @@ -44,10 +44,10 @@ import Data.ByteString.Builder (Builder, toLazyByteString) ------------------------------------------------------------------------------ import qualified Paths_snap_server as V import Snap.Core (MonadSnap (..), Request, Response, Snap, rqClientAddr, rqHeaders, rqMethod, rqURI, rqVersion, rspStatus) -import Snap.Http.Server.Config (Config, ConfigLog (..), commandLineConfig, completeConfig, defaultConfig, getAccessLog, getBind, getCompression, getDefaultTimeout, getErrorHandler, getErrorLog, getHostname, getLocale, getOther, getPort, getProxyType, getSSLBind, getSSLCert, getSSLChainCert, getSSLKey, getSSLPort, getStartupHook, getVerbose) +import Snap.Http.Server.Config (Config, ConfigLog (..), commandLineConfig, completeConfig, defaultConfig, getAccessLog, getAccessLogHandler, getBind, getCompression, getDefaultTimeout, getErrorHandler, getErrorLog, getErrorLogHandler, getHostname, getLocale, getOther, getPort, getProxyType, getSSLBind, getSSLCert, getSSLChainCert, getSSLKey, getSSLPort, getStartupHook, getVerbose) import qualified Snap.Http.Server.Types as Ty import Snap.Internal.Debug (debug) -import Snap.Internal.Http.Server.Config (ProxyType (..), emptyStartupInfo, setStartupConfig, setStartupSockets) +import Snap.Internal.Http.Server.Config (AccessLogHandler, ErrorLogHandler, ProxyType (..), emptyStartupInfo, setStartupConfig, setStartupSockets) import Snap.Internal.Http.Server.Session (httpAcceptLoop, snapToServerHandler) import qualified Snap.Internal.Http.Server.Socket as Sock import qualified Snap.Internal.Http.Server.TLS as TLS @@ -117,42 +117,36 @@ simpleHttpServe config handler = do -------------------------------------------------------------------------- - logE :: Maybe (ByteString -> IO ()) -> Builder -> IO () - logE elog b = let x = S.concat $ L.toChunks $ toLazyByteString b - in (maybe debugE (\l s -> debugE s >> logE' l s) elog) x + logE :: ErrorLogHandler -> Maybe (ByteString -> IO ()) -> Builder -> IO () + logE elh elog b = let x = S.concat $ L.toChunks $ toLazyByteString b + in (maybe debugE (\l s -> debugE s >> logE' elh l s) elog) x -------------------------------------------------------------------------- - logE' :: (ByteString -> IO ()) -> ByteString -> IO () - logE' logger s = (timestampedLogEntry s) >>= logger + logE' :: ErrorLogHandler -> (ByteString -> IO ()) -> ByteString -> IO () + logE' elh logger s = logger =<< elh s -------------------------------------------------------------------------- - logA :: Maybe (ByteString -> IO ()) + logA :: AccessLogHandler + -> Maybe (ByteString -> IO ()) -> Request -> Response -> Word64 -> IO () - logA alog = maybe (\_ _ _ -> return $! ()) logA' alog + logA alh alog = maybe (\_ _ _ -> return $! ()) (logA' alh) alog -------------------------------------------------------------------------- - logA' logger req rsp cl = do - let hdrs = rqHeaders req - let host = rqClientAddr 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 = bshow (rqMethod req) - let reql = S.intercalate " " [ method, rqURI req, ver ] - let status = rspStatus rsp - let referer = H.lookup "referer" hdrs - let userAgent = fromMaybe "-" $ H.lookup "user-agent" hdrs - - msg <- combinedLogEntry host user reql status cl referer userAgent - logger msg + logA' alh logger req rsp cl = logger =<< alh req rsp cl + + -------------------------------------------------------------------------- + accessHandler conf = fromMaybe defaultAccessLogHandler (getAccessLogHandler conf) + errorHandler conf = fromMaybe defaultErrorLogHandler (getErrorLogHandler conf) -------------------------------------------------------------------------- go conf sockets afuncs = do let tout = fromMaybe 60 $ getDefaultTimeout conf let shandler = snapToServerHandler handler + let ah = accessHandler conf + let eh = errorHandler conf setUnicodeLocale $ fromJust $ getLocale conf @@ -160,8 +154,8 @@ simpleHttpServe config handler = do (fromJust $ getErrorLog conf) $ \(alog, elog) -> do let scfg = Ty.setDefaultTimeout tout . Ty.setLocalHostname (fromJust $ getHostname conf) . - Ty.setLogAccess (logA alog) . - Ty.setLogError (logE elog) $ + Ty.setLogAccess (logA ah alog) . + Ty.setLogError (logE eh elog) $ Ty.emptyServerConfig maybe (return $! ()) ($ mkStartupInfo sockets conf) @@ -197,6 +191,25 @@ simpleHttpServe config handler = do , liftM logMsg elog <|> maybeIoLog efp)) {-# INLINE simpleHttpServe #-} +------------------------------------------------------------------------------ +defaultAccessLogHandler :: AccessLogHandler +defaultAccessLogHandler req rsp cl = do + let hdrs = rqHeaders req + let host = rqClientAddr 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 = bshow (rqMethod req) + let reql = S.intercalate " " [ method, rqURI req, ver ] + let status = rspStatus rsp + let referer = H.lookup "referer" hdrs + let userAgent = fromMaybe "-" $ H.lookup "user-agent" hdrs + + combinedLogEntry host user reql status cl referer userAgent + +------------------------------------------------------------------------------ +defaultErrorLogHandler :: ErrorLogHandler +defaultErrorLogHandler = timestampedLogEntry ------------------------------------------------------------------------------ listeners :: Config m a -> IO [(ByteString, Socket, AcceptFunc)] diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index 95e840b0..420163f2 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -7,6 +7,9 @@ module Snap.Http.Server.Config , ConfigLog(..) , ProxyType + , AccessLogHandler + , ErrorLogHandler + , emptyConfig , defaultConfig , commandLineConfig @@ -17,11 +20,13 @@ module Snap.Http.Server.Config , fmapOpt , getAccessLog + , getAccessLogHandler , getBind , getCompression , getDefaultTimeout , getErrorHandler , getErrorLog + , getErrorLogHandler , getHostname , getLocale , getOther @@ -36,11 +41,13 @@ module Snap.Http.Server.Config , getStartupHook , setAccessLog + , setAccessLogHandler , setBind , setCompression , setDefaultTimeout , setErrorHandler , setErrorLog + , setErrorLogHandler , setHostname , setLocale , setOther diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs index 6c72bc37..a9801143 100644 --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -23,12 +23,17 @@ module Snap.Internal.Http.Server.Config , optDescrs , fmapOpt + , AccessLogHandler + , ErrorLogHandler + , getAccessLog + , getAccessLogHandler , getBind , getCompression , getDefaultTimeout , getErrorHandler , getErrorLog + , getErrorLogHandler , getHostname , getLocale , getOther @@ -43,11 +48,13 @@ module Snap.Internal.Http.Server.Config , getStartupHook , setAccessLog + , setAccessLogHandler , setBind , setCompression , setDefaultTimeout , setErrorHandler , setErrorLog + , setErrorLogHandler , setHostname , setLocale , setOther @@ -90,6 +97,7 @@ import Data.Typeable.Internal (Typeable, mkTyCon3) #else import Data.Typeable (mkTyCon3) #endif +import Data.Word (Word64) import Network (Socket) #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) @@ -106,7 +114,7 @@ import System.IO (hPutStrLn, stderr) import Data.ByteString.Builder (Builder, byteString, stringUtf8, toLazyByteString) import qualified System.IO.Streams as Streams ------------------------------------------------------------------------------ -import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort), emptyResponse, finishWith, getRequest, logError, setContentLength, setContentType, setResponseBody, setResponseStatus) +import Snap.Core (MonadSnap, Request (rqClientAddr, rqClientPort), Response, emptyResponse, finishWith, getRequest, logError, setContentLength, setContentType, setResponseBody, setResponseStatus) import Snap.Internal.Debug (debug) @@ -130,6 +138,15 @@ instance Show ConfigLog where show (ConfigFileLog f) = "log to file " ++ show f show (ConfigIoLog _) = "custom logging handler" +------------------------------------------------------------------------------ +-- | 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 -> Word64 -> IO ByteString ------------------------------------------------------------------------------ -- We should be using ServerConfig here. There needs to be a clearer @@ -188,24 +205,26 @@ 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 - , 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 + , proxyType :: Maybe ProxyType + , startupHook :: Maybe (StartupInfo m a -> IO ()) } #if MIN_VERSION_base(4,7,0) deriving Typeable @@ -273,6 +292,8 @@ instance Monoid (Config m a) where { hostname = Nothing , accessLog = Nothing , errorLog = Nothing + , accessLogHandler = Nothing + , errorLogHandler = Nothing , locale = Nothing , port = Nothing , bind = Nothing @@ -294,6 +315,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 @@ -346,10 +369,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 @@ -421,9 +452,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 }