From fb438ccd751eb740536b151a3916b397fe1274e5 Mon Sep 17 00:00:00 2001 From: Robert Massaioli Date: Wed, 20 May 2015 14:26:30 +1000 Subject: [PATCH 1/6] Issue 62: First attempt at custom access and error log handlers. This is my first attempt at custom access and error log handlers. --- src/Snap/Http/Server.hs | 2 + src/Snap/Http/Server/Config.hs | 4 ++ src/Snap/Internal/Http/Server.hs | 54 +++++++++++++--------- src/Snap/Internal/Http/Server/Config.hs | 59 ++++++++++++++++--------- 4 files changed, 77 insertions(+), 42 deletions(-) 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..b2a74b2f 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -19,11 +19,13 @@ module Snap.Http.Server.Config , fmapOpt , getAccessLog + , getAccessLogHandler , getBind , getCompression , getDefaultTimeout , getErrorHandler , getErrorLog + , getErrorLogHandler , getHostname , getLocale , getOther @@ -38,11 +40,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.hs b/src/Snap/Internal/Http/Server.hs index d6b3d44d..24df61be 100644 --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -155,11 +155,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 @@ -204,7 +206,7 @@ httpServe defaultTimeout ports localHostname alog' elog' initial handler = 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) + $ runHTTP defaultTimeout alog alh elog elh handler localHostname) `finally` do logE elog "Server.httpServe: SHUTDOWN" @@ -224,6 +226,24 @@ httpServe defaultTimeout ports localHostname alog' elog' initial handler = debugE :: (MonadIO m) => ByteString -> m () debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s) +type ErrorLogHandler = ByteString -> IO ByteString +type AccessLogHandler = Request -> Response -> IO ByteString + +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 ------------------------------------------------------------------------------ logE :: Maybe (ByteString -> IO ()) -> ByteString -> IO () @@ -241,33 +261,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 +285,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 () @@ -301,7 +309,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 elog) $ httpSession defaultTimeout writeEnd buf onSendFile tickle handler let iter = iterateeDebugWrapper "httpSession iteratee" iter1 @@ -314,6 +322,8 @@ runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile run_ $ readEnd step debug "runHTTP/go: finished" + accessHandle = fromMaybe defaultAccessLogHandler alh + ------------------------------------------------------------------------------ requestErrorMessage :: Request -> SomeException -> Builder diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs index 4b44c8bc..4e650e25 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,17 @@ 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 +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 +332,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 } From b3be5db2af9c746a2b756fdf28901bd5d2824b98 Mon Sep 17 00:00:00 2001 From: Robert Massaioli Date: Wed, 20 May 2015 17:26:24 +1000 Subject: [PATCH 2/6] Issue 62: Made the error handler work and exported the handler types. --- src/Snap/Http/Server/Config.hs | 4 ++++ src/Snap/Internal/Http/Server.hs | 30 ++++++++++++++++++------------ 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index b2a74b2f..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 @@ -65,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 24df61be..b5cf1621 100644 --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -172,7 +172,7 @@ httpServe defaultTimeout ports localHostname alog' alh elog' elh initial handler -------------------------------------------------------------------------- sslException (e@(TLS.TLSException msg)) = do - logE elog' msg + logE errorHandle elog' msg SC.hPutStrLn stderr msg throw e @@ -185,14 +185,14 @@ httpServe defaultTimeout ports localHostname alog' alh elog' elh 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;} @@ -205,22 +205,24 @@ httpServe defaultTimeout ports localHostname alog' alh elog' elh 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) + (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 () @@ -245,14 +247,17 @@ defaultAccessLogHandler req rsp = do 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 ------------------------------------------------------------------------------ @@ -296,7 +301,7 @@ runHTTP defaultTimeout alog alh elog elh handler lh sinfo readEnd writeEnd onSen , Handler $ \(e :: AsyncException) -> do throwIO e , Handler $ \(e :: SomeException) -> - logE elog $ toByteString $ lmsg e + logE errorHandle elog $ toByteString $ lmsg e ] where @@ -309,7 +314,7 @@ runHTTP defaultTimeout alog alh elog elh handler lh sinfo readEnd writeEnd onSen go = do buf <- allocBuffer 16384 - let iter1 = runServerMonad lh sinfo (logA accessHandle 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 @@ -323,6 +328,7 @@ runHTTP defaultTimeout alog alh elog elh handler lh sinfo readEnd writeEnd onSen debug "runHTTP/go: finished" accessHandle = fromMaybe defaultAccessLogHandler alh + errorHandle = fromMaybe defaultErrorLogHandler elh ------------------------------------------------------------------------------ From e28ec2984cbeccc49018ddd7a0d499d683a4b720 Mon Sep 17 00:00:00 2001 From: Robert Massaioli Date: Thu, 21 May 2015 08:25:44 +1000 Subject: [PATCH 3/6] Issue 62: Cleaning up the code to get it ready for a pull request. --- src/Snap/Internal/Http/Server.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs index b5cf1621..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 = @@ -228,9 +237,7 @@ httpServe defaultTimeout ports localHostname alog' alh elog' elh initial handler debugE :: (MonadIO m) => ByteString -> m () debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s) -type ErrorLogHandler = ByteString -> IO ByteString -type AccessLogHandler = Request -> Response -> IO ByteString - +------------------------------------------------------------------------------ defaultAccessLogHandler :: AccessLogHandler defaultAccessLogHandler req rsp = do let hdrs = rqHeaders req @@ -247,6 +254,7 @@ defaultAccessLogHandler req rsp = do combinedLogEntry host user reql status cl referer userAgent +------------------------------------------------------------------------------ defaultErrorLogHandler :: ErrorLogHandler defaultErrorLogHandler = timestampedLogEntry From 6b018544b5ff5cedb373eb20ff8ddbc0cb9a8c4e Mon Sep 17 00:00:00 2001 From: Robert Massaioli Date: Thu, 21 May 2015 08:27:13 +1000 Subject: [PATCH 4/6] Issue 62: Forgot to add one message. --- src/Snap/Internal/Http/Server/Config.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs index 4e650e25..d0879871 100644 --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -255,6 +255,7 @@ getAccessLogHandler = accessLogHandler getErrorLog :: Config m a -> Maybe ConfigLog getErrorLog = errorLog +-- | Get the error log handler getErrorLogHandler :: Config m a -> Maybe ErrorLogHandler getErrorLogHandler = errorLogHandler From 1427db86c205a8c61349b846644edf401599384b Mon Sep 17 00:00:00 2001 From: Robert Massaioli Date: Tue, 2 Jun 2015 07:24:26 +1000 Subject: [PATCH 5/6] Issue #62: Bumping the version number. As requested. --- snap-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/snap-server.cabal b/snap-server.cabal index 0afa8b0d..b47226e2 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.9.5.0 +version: 0.9.6.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 From f379fb48101edc4603b05ca21ae82efde1e09983 Mon Sep 17 00:00:00 2001 From: Robert Massaioli Date: Thu, 11 Jun 2015 17:43:12 +1000 Subject: [PATCH 6/6] Issue #62: Bumped to version 0.10.0.0 to meet version requirements. --- snap-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/snap-server.cabal b/snap-server.cabal index b47226e2..cbf9b39c 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.9.6.0 +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