Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Issue/62 custom access and error log handlers (against master) #72

Closed
wants to merge 7 commits into from
Closed

Issue/62 custom access and error log handlers (against master) #72

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
fb438cc
Issue 62: First attempt at custom access and error log handlers.
robertmassaioli May 20, 2015
b3be5db
Issue 62: Made the error handler work and exported the handler types.
robertmassaioli May 20, 2015
e28ec29
Issue 62: Cleaning up the code to get it ready for a pull request.
robertmassaioli May 20, 2015
6b01854
Issue 62: Forgot to add one message.
robertmassaioli May 20, 2015
8fe340f
Merge branch 'issue/62-custom-access-and-error-log-handlers' into iss…
robertmassaioli May 21, 2015
8c4515f
Issue 62: Cleaned up some imports.
robertmassaioli May 21, 2015
b5e2305
Issue 62: Running Stylish Haskell on the code.
robertmassaioli May 27, 2015
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
65 changes: 39 additions & 26 deletions src/Snap/Http/Server.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -117,51 +117,45 @@ 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

withLoggers (fromJust $ getAccessLog conf)
(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)
Expand Down Expand Up @@ -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)]
Expand Down
7 changes: 7 additions & 0 deletions src/Snap/Http/Server/Config.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,9 @@ module Snap.Http.Server.Config
, ConfigLog(..)
, ProxyType

, AccessLogHandler
, ErrorLogHandler

, emptyConfig
, defaultConfig
, commandLineConfig
Expand All @@ -17,11 +20,13 @@ module Snap.Http.Server.Config
, fmapOpt

, getAccessLog
, getAccessLogHandler
, getBind
, getCompression
, getDefaultTimeout
, getErrorHandler
, getErrorLog
, getErrorLogHandler
, getHostname
, getLocale
, getOther
Expand All @@ -36,11 +41,13 @@ module Snap.Http.Server.Config
, getStartupHook

, setAccessLog
, setAccessLogHandler
, setBind
, setCompression
, setDefaultTimeout
, setErrorHandler
, setErrorLog
, setErrorLogHandler
, setHostname
, setLocale
, setOther
Expand Down
75 changes: 56 additions & 19 deletions src/Snap/Internal/Http/Server/Config.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -43,11 +48,13 @@ module Snap.Internal.Http.Server.Config
, getStartupHook

, setAccessLog
, setAccessLogHandler
, setBind
, setCompression
, setDefaultTimeout
, setErrorHandler
, setErrorLog
, setErrorLogHandler
, setHostname
, setLocale
, setOther
Expand Down Expand Up @@ -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)
Expand All @@ -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)


Expand All @@ -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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Move this into ".Types" (see the _accessLog member, we are already using this type without an alias there)

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I've just tried to work out what you meant by this comment and I can't work it out. :( I think you mean: remove the ErrorLogHandler definition and just use ByteString -> IO ByteString directly all around the code?

But part of me is thinking that maybe you want me to move these type definitions to: src/Snap/Internal/Http/Server/Types.hs

I'm just confused because the only thing that _accessLog does that is similar to this is the ConfigIoLog constructor.

So maybe what you really want me to do is:

data ErrorLogHandler = ErrorLogHandler (ByteString -> IO ByteString)

Is that more like what you meant? Which one is it? Or am I totally off the mark?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Wow, it deleted my previous changes here when I updated the PR. Not used to that. I do most of my work on BitBucket. So, what did you mean specifically about this type? Did you want me to:

  1. Move it to the Types.hs module OR
  2. Rename the type to: data ErrorLogHandler = ErrorLogHandler (ByteString -> IO ByteString)
  3. Delete it altogether and use (ByteString -> IO ByteString) everywhere?

I am just not sure what your previous comment here was asking for. Cheers.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I just meant that we already have this type in .Types without an alias (search for _logAccess in that file), so we should move the alias into .Types and use it there.

BTW why is the type of ErrorLogHandler ByteString -> IO ByteString here? We use "Builder -> IO ()" internally in the server, and we should probably do the same here.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@gregorycollins So you want me to change the type to Builder -> IO Builder? Because otherwise the ErrorLogHandler would actually have to write the logs to the ConfigLog, rather than just producing logs in a custom format as it currently does.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, the error log handler should write the logs itself and return (). The idea is that out of the box we give you logging to file, in the usual format. If you want something else, you can override with a user-provided function and do whatever you want, and we will provide you with the same building blocks that we use (that's what I meant about exporting the function that generates these common log format messages to the user).

Let's say for example that (and this is a bad idea, but just for the sake of argument) you'd like to log the access log information into an SQL database. In this case, the solution you're providing is awkward, because we serialize to string without really needing to do that. In this case it's because the API we provide the user right now is bad --- the ConfigLog type should be broken into AccessLogType and ErrorLogType, and their equivalents to the ConfigIoLog constructor should have the correct, more specific types that we use internally in snap-server 1.0.

Ideally 0.10 and 1.0 should have the same API here, so that we introduce this feature once and we don't have to break user code in the upgrade from 0.10 to 1.0. In this case I'm totally OK with breaking users


------------------------------------------------------------------------------
-- | 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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 }

Expand Down