diff --git a/snap-server.cabal b/snap-server.cabal index 71b9dfd6..33e607bf 100644 --- a/snap-server.cabal +++ b/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 diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs index 44f0fc62..87771eca 100644 --- a/src/Snap/Http/Server.hs +++ b/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) diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index 71596691..76a2c23e 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/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 diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs index d6b3d44d..20dc354f 100644 --- a/src/Snap/Internal/Http/Server.hs +++ b/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 diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs index 4b44c8bc..d0879871 100644 --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/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 }