snap-server-1.1.1.0: src/Snap/Internal/Http/Server/Config.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
------------------------------------------------------------------------------
-- | This module exports the 'Config' datatype, which you can use to configure
-- the Snap HTTP server.
--
module Snap.Internal.Http.Server.Config
-- NOTE: also edit Snap.Http.Server.Config if you change these
( ConfigLog(..)
, Config(..)
, ProxyType(..)
, emptyConfig
, defaultConfig
, commandLineConfig
, extendedCommandLineConfig
, completeConfig
, optDescrs
, fmapOpt
, getAccessLog
, getBind
, getCompression
, getDefaultTimeout
, getErrorHandler
, getErrorLog
, getHostname
, getLocale
, getOther
, getPort
, getProxyType
, getSSLBind
, getSSLCert
, getSSLChainCert
, getSSLKey
, getSSLPort
, getVerbose
, getStartupHook
, getUnixSocket
, getUnixSocketAccessMode
, setAccessLog
, setBind
, setCompression
, setDefaultTimeout
, setErrorHandler
, setErrorLog
, setHostname
, setLocale
, setOther
, setPort
, setProxyType
, setSSLBind
, setSSLCert
, setSSLChainCert
, setSSLKey
, setSSLPort
, setVerbose
, setUnixSocket
, setUnixSocketAccessMode
, setStartupHook
, StartupInfo(..)
, getStartupSockets
, getStartupConfig
-- * Private
, emptyStartupInfo
, setStartupSockets
, setStartupConfig
) where
------------------------------------------------------------------------------
import Control.Exception (SomeException)
import Control.Monad (when)
import Data.Bits ((.&.))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.CaseInsensitive as CI
import Data.Function (on)
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (isJust, isNothing)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid (..))
#endif
import Data.Monoid (Last (Last, getLast))
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
#if MIN_VERSION_base(4,7,0)
import Data.Typeable (Typeable)
#else
import Data.Typeable (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp)
#endif
import Network.Socket (Socket)
import Numeric (readOct, showOct)
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif
import System.Console.GetOpt (ArgDescr (..), ArgOrder (Permute), OptDescr (..), getOpt, usageInfo)
import System.Environment hiding (getEnv)
#ifndef PORTABLE
import Data.Char (isAlpha)
import System.Posix.Env (getEnv)
#endif
import System.Exit (exitFailure)
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, rqParams, rqPostParams), emptyResponse, finishWith, getsRequest, logError, setContentLength, setContentType, setResponseBody, setResponseStatus)
import Snap.Internal.Debug (debug)
------------------------------------------------------------------------------
-- | FIXME
--
-- Note: this type changed in snap-server 1.0.0.0.
data ProxyType = NoProxy
| HaProxy
| X_Forwarded_For
deriving (Show, Eq, Typeable)
------------------------------------------------------------------------------
-- | Data type representing the configuration of a logging target
data ConfigLog = ConfigNoLog -- ^ no logging
| ConfigFileLog FilePath -- ^ log to text file
| ConfigIoLog (ByteString -> IO ()) -- ^ log custom IO handler
instance Show ConfigLog where
show ConfigNoLog = "no log"
show (ConfigFileLog f) = "log to file " ++ show f
show (ConfigIoLog _) = "custom logging handler"
------------------------------------------------------------------------------
-- We should be using ServerConfig here. There needs to be a clearer
-- separation between:
--
-- * what the underlying code needs to configure itself
--
-- * what the command-line processing does.
--
-- The latter will provide "library" helper functions that operate on
-- ServerConfig/etc in order to allow users to configure their own environment.
--
--
-- Todo:
--
-- * need a function ::
-- CommandLineConfig -> IO [(ServerConfig hookState, AcceptFunc)]
--
-- this will prep for another function that will spawn all of the
-- accept loops with httpAcceptLoop.
--
-- * all backends provide "Some -> Foo -> Config -> IO AcceptFunc"
--
-- * add support for socket activation to command line, or delegate to
-- different library? It's linux-only anyways, need to ifdef. It would be
-- silly to depend on the socket-activation library for that one little
-- function.
--
-- * break config into multiple modules:
--
-- * everything that modifies the snap handler (compression, proxy
-- settings, error handler)
--
-- * everything that directly modifies server settings (hostname /
-- defaultTimeout / hooks / etc)
--
-- * everything that configures backends (port/bind/ssl*)
--
-- * everything that handles command line stuff
--
-- * utility stuff
--
-- Cruft that definitely must be removed:
--
-- * ConfigLog -- this becomes a binary option on the command-line side (no
-- logging or yes, to this file), but the ConfigIoLog gets zapped
-- altogether.
------------------------------------------------------------------------------
-- | A record type which represents partial configurations (for 'httpServe')
-- by wrapping all of its fields in a 'Maybe'. Values of this type are usually
-- constructed via its 'Monoid' instance by doing something like:
--
-- > setPort 1234 mempty
--
-- 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
, unixsocket :: Maybe FilePath
, unixaccessmode :: Maybe Int
, 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
#else
------------------------------------------------------------------------------
-- | The 'Typeable1' instance is here so 'Config' values can be
-- dynamically loaded with Hint.
configTyCon :: TyCon
configTyCon = mkTyCon3 "snap-server" "Snap.Http.Server.Config" "Config"
{-# NOINLINE configTyCon #-}
instance (Typeable1 m) => Typeable1 (Config m) where
typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())]
#endif
instance Show (Config m a) where
show c = unlines [ "Config:"
, "hostname: " ++ _hostname
, "accessLog: " ++ _accessLog
, "errorLog: " ++ _errorLog
, "locale: " ++ _locale
, "port: " ++ _port
, "bind: " ++ _bind
, "sslport: " ++ _sslport
, "sslbind: " ++ _sslbind
, "sslcert: " ++ _sslcert
, "sslchaincert: " ++ _sslchaincert
, "sslkey: " ++ _sslkey
, "unixsocket: " ++ _unixsocket
, "unixaccessmode: " ++ _unixaccessmode
, "compression: " ++ _compression
, "verbose: " ++ _verbose
, "defaultTimeout: " ++ _defaultTimeout
, "proxyType: " ++ _proxyType
]
where
_hostname = show $ hostname c
_accessLog = show $ accessLog c
_errorLog = show $ errorLog c
_locale = show $ locale c
_port = show $ port c
_bind = show $ bind c
_sslport = show $ sslport c
_sslbind = show $ sslbind c
_sslcert = show $ sslcert c
_sslchaincert = show $ sslchaincert c
_sslkey = show $ sslkey c
_compression = show $ compression c
_verbose = show $ verbose c
_defaultTimeout = show $ defaultTimeout c
_proxyType = show $ proxyType c
_unixsocket = show $ unixsocket c
_unixaccessmode = case unixaccessmode c of
Nothing -> "Nothing"
Just s -> ("Just 0" ++) . showOct s $ []
------------------------------------------------------------------------------
-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
-- 'Config''s 'Monoid' instance.
emptyConfig :: Config m a
emptyConfig = mempty
------------------------------------------------------------------------------
instance Semigroup (Config m a) where
a <> b = Config
{ hostname = ov hostname
, accessLog = ov accessLog
, errorLog = ov errorLog
, locale = ov locale
, port = ov port
, bind = ov bind
, sslport = ov sslport
, sslbind = ov sslbind
, sslcert = ov sslcert
, sslchaincert = ov sslchaincert
, sslkey = ov sslkey
, unixsocket = ov unixsocket
, unixaccessmode = ov unixaccessmode
, compression = ov compression
, verbose = ov verbose
, errorHandler = ov errorHandler
, defaultTimeout = ov defaultTimeout
, other = ov other
, proxyType = ov proxyType
, startupHook = ov startupHook
}
where
ov :: (Config m a -> Maybe b) -> Maybe b
ov f = getLast $! (mappend `on` (Last . f)) a b
instance Monoid (Config m a) where
mempty = Config
{ hostname = Nothing
, accessLog = Nothing
, errorLog = Nothing
, locale = Nothing
, port = Nothing
, bind = Nothing
, sslport = Nothing
, sslbind = Nothing
, sslcert = Nothing
, sslchaincert = Nothing
, sslkey = Nothing
, unixsocket = Nothing
, unixaccessmode = Nothing
, compression = Nothing
, verbose = Nothing
, errorHandler = Nothing
, defaultTimeout = Nothing
, other = Nothing
, proxyType = Nothing
, startupHook = Nothing
}
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
------------------------------------------------------------------------------
-- | These are the default values for the options
defaultConfig :: MonadSnap m => Config m a
defaultConfig = mempty
{ hostname = Just "localhost"
, accessLog = Just $ ConfigFileLog "log/access.log"
, errorLog = Just $ ConfigFileLog "log/error.log"
, locale = Just "en_US"
, compression = Just True
, verbose = Just True
, errorHandler = Just defaultErrorHandler
, bind = Just "0.0.0.0"
, sslbind = Nothing
, sslcert = Nothing
, sslkey = Nothing
, sslchaincert = Nothing
, defaultTimeout = Just 60
}
------------------------------------------------------------------------------
-- | The hostname of the HTTP server. This field has the same format as an HTTP
-- @Host@ header; if a @Host@ header came in with the request, we use that,
-- otherwise we default to this value specified in the configuration.
getHostname :: Config m a -> Maybe ByteString
getHostname = hostname
-- | Path to the access log
getAccessLog :: Config m a -> Maybe ConfigLog
getAccessLog = accessLog
-- | Path to the error log
getErrorLog :: Config m a -> Maybe ConfigLog
getErrorLog = errorLog
-- | 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
-- \"@en_US.UTF-8@\".
getLocale :: Config m a -> Maybe String
getLocale = locale
-- | Returns the port to listen on (for http)
getPort :: Config m a -> Maybe Int
getPort = port
-- | Returns the address to bind to (for http)
getBind :: Config m a -> Maybe ByteString
getBind = bind
-- | Returns the port to listen on (for https)
getSSLPort :: Config m a -> Maybe Int
getSSLPort = sslport
-- | Returns the address to bind to (for https)
getSSLBind :: Config m a -> Maybe ByteString
getSSLBind = sslbind
-- | Path to the SSL certificate file
getSSLCert :: Config m a -> Maybe FilePath
getSSLCert = sslcert
-- | Path to the SSL certificate file
getSSLChainCert :: Config m a -> Maybe Bool
getSSLChainCert = sslchaincert
-- | Path to the SSL key file
getSSLKey :: Config m a -> Maybe FilePath
getSSLKey = sslkey
-- | File path to unix socket. Must be absolute path, but allows for symbolic
-- links.
getUnixSocket :: Config m a -> Maybe FilePath
getUnixSocket = unixsocket
-- | Access mode for unix socket, by default is system specific.
-- This should only be used to grant additional permissions to created
-- socket file, and not to remove permissions set by default.
-- The only portable way to limit access to socket is creating it in a
-- directory with proper permissions set.
--
-- Most BSD systems ignore access permissions on unix sockets.
--
-- Note: This uses umask. There is a race condition if process creates other
-- files at the same time as opening a unix socket with this option set.
getUnixSocketAccessMode :: Config m a -> Maybe Int
getUnixSocketAccessMode = unixaccessmode
-- | If set and set to True, compression is turned on when applicable
getCompression :: Config m a -> Maybe Bool
getCompression = compression
-- | Whether to write server status updates to stderr
getVerbose :: Config m a -> Maybe Bool
getVerbose = verbose
-- | A MonadSnap action to handle 500 errors
getErrorHandler :: Config m a -> Maybe (SomeException -> m ())
getErrorHandler = errorHandler
getDefaultTimeout :: Config m a -> Maybe Int
getDefaultTimeout = defaultTimeout
getOther :: Config m a -> Maybe a
getOther = other
getProxyType :: Config m a -> Maybe ProxyType
getProxyType = proxyType
-- | A startup hook is run after the server initializes but before user request
-- processing begins. The server passes, through a 'StartupInfo' object, the
-- startup hook a list of the sockets it is listening on and the final 'Config'
-- object completed after command-line processing.
getStartupHook :: Config m a -> Maybe (StartupInfo m a -> IO ())
getStartupHook = startupHook
------------------------------------------------------------------------------
setHostname :: ByteString -> Config m a -> Config m a
setHostname x c = c { hostname = Just x }
setAccessLog :: ConfigLog -> Config m a -> Config m a
setAccessLog x c = c { accessLog = Just x }
setErrorLog :: ConfigLog -> Config m a -> Config m a
setErrorLog x c = c { errorLog = Just x }
setLocale :: String -> Config m a -> Config m a
setLocale x c = c { locale = Just x }
setPort :: Int -> Config m a -> Config m a
setPort x c = c { port = Just x }
setBind :: ByteString -> Config m a -> Config m a
setBind x c = c { bind = Just x }
setSSLPort :: Int -> Config m a -> Config m a
setSSLPort x c = c { sslport = Just x }
setSSLBind :: ByteString -> Config m a -> Config m a
setSSLBind x c = c { sslbind = Just x }
setSSLCert :: FilePath -> Config m a -> Config m a
setSSLCert x c = c { sslcert = Just x }
setSSLChainCert :: Bool -> Config m a -> Config m a
setSSLChainCert x c = c { sslchaincert = Just x }
setSSLKey :: FilePath -> Config m a -> Config m a
setSSLKey x c = c { sslkey = Just x }
setUnixSocket :: FilePath -> Config m a -> Config m a
setUnixSocket x c = c { unixsocket = Just x }
setUnixSocketAccessMode :: Int -> Config m a -> Config m a
setUnixSocketAccessMode p c = c { unixaccessmode = Just ( p .&. 0o777) }
setCompression :: Bool -> Config m a -> Config m a
setCompression x c = c { compression = Just x }
setVerbose :: Bool -> Config m a -> Config m a
setVerbose x c = c { verbose = Just x }
setErrorHandler :: (SomeException -> m ()) -> Config m a -> Config m a
setErrorHandler x c = c { errorHandler = Just x }
setDefaultTimeout :: Int -> Config m a -> Config m a
setDefaultTimeout x c = c { defaultTimeout = Just x }
setOther :: a -> Config m a -> Config m a
setOther x c = c { other = Just x }
setProxyType :: ProxyType -> Config m a -> Config m a
setProxyType x c = c { proxyType = Just x }
setStartupHook :: (StartupInfo m a -> IO ()) -> Config m a -> Config m a
setStartupHook x c = c { startupHook = Just x }
------------------------------------------------------------------------------
-- | Arguments passed to 'setStartupHook'.
data StartupInfo m a = StartupInfo
{ startupHookConfig :: Config m a
, startupHookSockets :: [Socket]
}
emptyStartupInfo :: StartupInfo m a
emptyStartupInfo = StartupInfo emptyConfig []
-- | The 'Socket's opened by the server. There will be two 'Socket's for SSL
-- connections, and one otherwise.
getStartupSockets :: StartupInfo m a -> [Socket]
getStartupSockets = startupHookSockets
-- The 'Config', after any command line parsing has been performed.
getStartupConfig :: StartupInfo m a -> Config m a
getStartupConfig = startupHookConfig
setStartupSockets :: [Socket] -> StartupInfo m a -> StartupInfo m a
setStartupSockets x c = c { startupHookSockets = x }
setStartupConfig :: Config m a -> StartupInfo m a -> StartupInfo m a
setStartupConfig x c = c { startupHookConfig = x }
------------------------------------------------------------------------------
completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a)
completeConfig config = do
when noPort $ hPutStrLn stderr
"no port specified, defaulting to port 8000"
return $! cfg `mappend` cfg'
where
cfg = defaultConfig `mappend` config
sslVals = map ($ cfg) [ isJust . getSSLPort
, isJust . getSSLBind
, isJust . getSSLKey
, isJust . getSSLCert ]
sslValid = and sslVals
unixValid = isJust $ unixsocket cfg
noPort = isNothing (getPort cfg) && not sslValid && not unixValid
cfg' = emptyConfig { port = if noPort then Just 8000 else Nothing }
------------------------------------------------------------------------------
bsFromString :: String -> ByteString
bsFromString = T.encodeUtf8 . T.pack
------------------------------------------------------------------------------
toString :: ByteString -> String
toString = T.unpack . T.decodeUtf8
------------------------------------------------------------------------------
-- | Returns a description of the snap command line options suitable for use
-- with "System.Console.GetOpt".
optDescrs :: forall m a . MonadSnap m =>
Config m a -- ^ the configuration defaults.
-> [OptDescr (Maybe (Config m a))]
optDescrs defaults =
[ Option "" ["hostname"]
(ReqArg (Just . setConfig setHostname . bsFromString) "NAME")
$ "local hostname" ++ defaultC getHostname
, Option "b" ["address"]
(ReqArg (\s -> Just $ mempty { bind = Just $ bsFromString s })
"ADDRESS")
$ "address to bind to" ++ defaultO bind
, Option "p" ["port"]
(ReqArg (\s -> Just $ mempty { port = Just $ read s}) "PORT")
$ "port to listen on" ++ defaultO port
, Option "" ["ssl-address"]
(ReqArg (\s -> Just $ mempty { sslbind = Just $ bsFromString s })
"ADDRESS")
$ "ssl address to bind to" ++ defaultO sslbind
, Option "" ["ssl-port"]
(ReqArg (\s -> Just $ mempty { sslport = Just $ read s}) "PORT")
$ "ssl port to listen on" ++ defaultO sslport
, Option "" ["ssl-cert"]
(ReqArg (\s -> Just $ mempty { sslcert = Just s}) "PATH")
$ "path to ssl certificate in PEM format" ++ defaultO sslcert
, Option [] ["ssl-chain-cert"]
(NoArg $ Just $ setConfig setSSLChainCert True)
$ "certificate file contains complete certificate chain" ++ defaultB sslchaincert "site certificate only" "complete certificate chain"
, Option [] ["no-ssl-chain-cert"]
(NoArg $ Just $ setConfig setSSLChainCert False)
$ "certificate file contains only the site certificate" ++ defaultB sslchaincert "site certificate only" "complete certificate chain"
, Option [] ["ssl-key"]
(ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH")
$ "path to ssl private key in PEM format" ++ defaultO sslkey
, Option "" ["access-log"]
(ReqArg (Just . setConfig setAccessLog . ConfigFileLog) "PATH")
$ "access log" ++ defaultC getAccessLog
, Option "" ["error-log"]
(ReqArg (Just . setConfig setErrorLog . ConfigFileLog) "PATH")
$ "error log" ++ defaultC getErrorLog
, Option "" ["no-access-log"]
(NoArg $ Just $ setConfig setAccessLog ConfigNoLog)
"don't have an access log"
, Option "" ["no-error-log"]
(NoArg $ Just $ setConfig setErrorLog ConfigNoLog)
"don't have an error log"
, Option "c" ["compression"]
(NoArg $ Just $ setConfig setCompression True)
$ "use gzip compression on responses" ++
defaultB getCompression "compressed" "uncompressed"
, Option "t" ["timeout"]
(ReqArg (\t -> Just $ mempty {
defaultTimeout = Just $ read t
}) "SECS")
$ "set default timeout in seconds" ++ defaultC defaultTimeout
, Option "" ["no-compression"]
(NoArg $ Just $ setConfig setCompression False)
$ "serve responses uncompressed" ++
defaultB compression "compressed" "uncompressed"
, Option "v" ["verbose"]
(NoArg $ Just $ setConfig setVerbose True)
$ "print server status updates to stderr" ++
defaultC getVerbose
, Option "q" ["quiet"]
(NoArg $ Just $ setConfig setVerbose False)
$ "do not print anything to stderr" ++
defaultB getVerbose "verbose" "quiet"
, Option "" ["proxy"]
(ReqArg (Just . setConfig setProxyType . parseProxy . CI.mk)
"X_Forwarded_For")
$ concat [ "Set --proxy=X_Forwarded_For if your snap application \n"
, "is behind an HTTP reverse proxy to ensure that \n"
, "rqClientAddr is set properly.\n"
, "Set --proxy=haproxy to use the haproxy protocol\n("
, "http://haproxy.1wt.eu/download/1.5/doc/proxy-protocol.txt)"
, defaultC getProxyType ]
, Option "" ["unix-socket"]
(ReqArg (Just . setConfig setUnixSocket) "PATH")
$ concat ["Absolute path to unix socket file. "
, "File will be removed if already exists"]
, Option "" ["unix-socket-mode"]
(ReqArg (Just . setConfig setUnixSocketAccessMode . parseOctal)
"MODE")
$ concat ["Access mode for unix socket in octal, for example 0760.\n"
," Default is system specific."]
, Option "h" ["help"]
(NoArg Nothing)
"display this help and exit"
]
where
parseProxy s | s == "NoProxy" = NoProxy
| s == "X_Forwarded_For" = X_Forwarded_For
| s == "haproxy" = HaProxy
| otherwise = error $ concat [
"Error (--proxy): expected one of 'NoProxy', "
, "'X_Forwarded_For', or 'haproxy'. Got '"
, CI.original s
, "'"
]
parseOctal s = case readOct s of
((v, _):_) | v >= 0 && v <= 0o777 -> v
_ -> error $ "Error (--unix-socket-mode): expected octal access mode"
setConfig f c = f c mempty
conf = defaultConfig `mappend` defaults
defaultB :: (Config m a -> Maybe Bool) -> String -> String -> String
defaultB f y n = (maybe "" (\b -> ", default " ++ if b
then y
else n) $ f conf) :: String
defaultC :: (Show b) => (Config m a -> Maybe b) -> String
defaultC f = maybe "" ((", default " ++) . show) $ f conf
defaultO :: (Show b) => (Config m a -> Maybe b) -> String
defaultO f = maybe ", default off" ((", default " ++) . show) $ f conf
------------------------------------------------------------------------------
defaultErrorHandler :: MonadSnap m => SomeException -> m ()
defaultErrorHandler e = do
debug "Snap.Http.Server.Config errorHandler:"
req <- getsRequest blindParams
let sm = smsg req
debug $ toString sm
logError sm
finishWith $ setContentType "text/plain; charset=utf-8"
. setContentLength (fromIntegral $ S.length msg)
. setResponseStatus 500 "Internal Server Error"
. setResponseBody errBody
$ emptyResponse
where
blindParams r = r { rqPostParams = rmValues $ rqPostParams r
, rqParams = rmValues $ rqParams r }
rmValues = Map.map (const ["..."])
errBody os = Streams.write (Just msgB) os >> return os
toByteString = S.concat . L.toChunks . toLazyByteString
smsg req = toByteString $ requestErrorMessage req e
msg = toByteString msgB
msgB = mconcat [
byteString "A web handler threw an exception. Details:\n"
, stringUtf8 $ show e
]
------------------------------------------------------------------------------
-- | Returns a 'Config' obtained from parsing command-line options, using the
-- default Snap 'OptDescr' set.
--
-- On Unix systems, the locale is read from the @LANG@ environment variable.
commandLineConfig :: MonadSnap m
=> Config m a
-- ^ default configuration. This is combined with
-- 'defaultConfig' to obtain default values to use if the
-- given parameter is specified on the command line.
-- Usually it is fine to use 'emptyConfig' here.
-> IO (Config m a)
commandLineConfig defaults = extendedCommandLineConfig (optDescrs defaults) f defaults
where
-- Here getOpt can ever change the "other" field, because we only use the
-- Snap OptDescr list. The combining function will never be invoked.
f = undefined
------------------------------------------------------------------------------
-- | Returns a 'Config' obtained from parsing command-line options, using the
-- default Snap 'OptDescr' set as well as a list of user OptDescrs. User
-- OptDescrs use the \"other\" field (accessible using 'getOther' and
-- 'setOther') to store additional command-line option state. These are
-- combined using a user-defined combining function.
--
-- On Unix systems, the locale is read from the @LANG@ environment variable.
extendedCommandLineConfig :: MonadSnap m
=> [OptDescr (Maybe (Config m a))]
-- ^ Full list of command line options (combine
-- yours with 'optDescrs' to extend Snap's default
-- set of options)
-> (a -> a -> a)
-- ^ State for multiple invoked user command-line
-- options will be combined using this function.
-> Config m a
-- ^ default configuration. This is combined with
-- Snap's 'defaultConfig' to obtain default values
-- to use if the given parameter is specified on
-- the command line. Usually it is fine to use
-- 'emptyConfig' here.
-> IO (Config m a)
extendedCommandLineConfig opts combiningFunction defaults = do
args <- getArgs
prog <- getProgName
result <- either (usage prog)
return
(case getOpt Permute opts args of
(f, _, [] ) -> maybe (Left []) Right $
fmap (foldl' combine mempty) $
sequence f
(_, _, errs) -> Left errs)
#ifndef PORTABLE
lang <- getEnv "LANG"
completeConfig $ mconcat [defaults,
mempty {locale = fmap upToUtf8 lang},
result]
#else
completeConfig $ mconcat [defaults, result]
#endif
where
usage prog errs = do
let hdr = "Usage:\n " ++ prog ++ " [OPTION...]\n\nOptions:"
let msg = concat errs ++ usageInfo hdr opts
hPutStrLn stderr msg
exitFailure
#ifndef PORTABLE
upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c
#endif
combine !a !b = a `mappend` b `mappend` newOther
where
-- combined is only a Just if both a and b have other fields, and then
-- we use the combining function. Config's mappend picks the last
-- "Just" in the other list.
combined = do
x <- getOther a
y <- getOther b
return $! combiningFunction x y
newOther = mempty { other = combined }
fmapArg :: (a -> b) -> ArgDescr a -> ArgDescr b
fmapArg f (NoArg a) = NoArg (f a)
fmapArg f (ReqArg g s) = ReqArg (f . g) s
fmapArg f (OptArg g s) = OptArg (f . g) s
fmapOpt :: (a -> b) -> OptDescr a -> OptDescr b
fmapOpt f (Option s l d e) = Option s l (fmapArg f d) e
------------------------------------------------------------------------------
requestErrorMessage :: Request -> SomeException -> Builder
requestErrorMessage req e =
mconcat [ byteString "During processing of request from "
, byteString $ rqClientAddr req
, byteString ":"
, fromShow $ rqClientPort req
, byteString "\nrequest:\n"
, fromShow $ show req
, byteString "\n"
, msgB
]
where
msgB = mconcat [
byteString "A web handler threw an exception. Details:\n"
, fromShow e
]
------------------------------------------------------------------------------
fromShow :: Show a => a -> Builder
fromShow = stringUtf8 . show