Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

494 lines (416 sloc) 17.377 kb
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
This module exports the 'Config' datatype, which you can use to configure the
Snap HTTP server.
-}
module Snap.Http.Server.Config
( Config
, ConfigBackend(..)
, emptyConfig
, defaultConfig
, commandLineConfig
, completeConfig
, getAccessLog
, getBackend
, getBind
, getCompression
, getDefaultTimeout
, getErrorHandler
, getErrorLog
, getHostname
, getLocale
, getOther
, getPort
, getSSLBind
, getSSLCert
, getSSLKey
, getSSLPort
, getVerbose
, setAccessLog
, setBackend
, setBind
, setCompression
, setDefaultTimeout
, setErrorHandler
, setErrorLog
, setHostname
, setLocale
, setOther
, setPort
, setSSLBind
, setSSLCert
, setSSLKey
, setSSLPort
, setVerbose
) where
import Blaze.ByteString.Builder
import Control.Exception (SomeException)
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Prelude hiding (catch)
import Snap.Types
import Snap.Iteratee ((>==>), enumBuilder)
import Snap.Internal.Debug (debug)
import System.Console.GetOpt
import System.Environment hiding (getEnv)
#ifndef PORTABLE
import System.Posix.Env
#endif
import System.Exit
import System.IO
------------------------------------------------------------------------------
-- | This datatype allows you to override which backend (either simple or
-- libev) to use. Most users will not want to set this, preferring to rely on
-- the compile-type default.
--
-- Note that if you specify the libev backend and have not compiled in support
-- for it, your server will fail at runtime.
data ConfigBackend = ConfigSimpleBackend
| ConfigLibEvBackend
deriving (Show, Eq)
------------------------------------------------------------------------------
-- | 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 (Maybe FilePath)
, errorLog :: Maybe (Maybe FilePath)
, locale :: Maybe String
, port :: Maybe Int
, bind :: Maybe ByteString
, sslport :: Maybe Int
, sslbind :: Maybe ByteString
, sslcert :: Maybe FilePath
, sslkey :: Maybe FilePath
, compression :: Maybe Bool
, verbose :: Maybe Bool
, errorHandler :: Maybe (SomeException -> m ())
, defaultTimeout :: Maybe Int
, other :: Maybe a
, backend :: Maybe ConfigBackend
}
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
, "sslkey: " ++ _sslkey
, "compression: " ++ _compression
, "verbose: " ++ _verbose
, "defaultTimeout: " ++ _defaultTimeout
, "backend: " ++ _backend
]
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
_sslkey = show $ sslkey c
_compression = show $ compression c
_verbose = show $ verbose c
_defaultTimeout = show $ defaultTimeout c
_backend = show $ backend c
------------------------------------------------------------------------------
-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
-- 'Config''s 'Monoid' instance.
emptyConfig :: Config m a
emptyConfig = mempty
------------------------------------------------------------------------------
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
, sslkey = Nothing
, compression = Nothing
, verbose = Nothing
, errorHandler = Nothing
, defaultTimeout = Nothing
, other = Nothing
, backend = Nothing
}
a `mappend` b = Config
{ hostname = ov hostname a b
, accessLog = ov accessLog a b
, errorLog = ov errorLog a b
, locale = ov locale a b
, port = ov port a b
, bind = ov bind a b
, sslport = ov sslport a b
, sslbind = ov sslbind a b
, sslcert = ov sslcert a b
, sslkey = ov sslkey a b
, compression = ov compression a b
, verbose = ov verbose a b
, errorHandler = ov errorHandler a b
, defaultTimeout = ov defaultTimeout a b
, other = ov other a b
, backend = ov backend a b
}
where
ov f x y = getLast $! (mappend `on` (Last . f)) x y
------------------------------------------------------------------------------
-- | These are the default values for the options
defaultConfig :: MonadSnap m => Config m a
defaultConfig = mempty
{ hostname = Just "localhost"
, accessLog = Just $ Just "log/access.log"
, errorLog = Just $ Just "log/error.log"
, locale = Just "en_US"
, compression = Just True
, verbose = Just True
, errorHandler = Just defaultErrorHandler
, bind = Just "0.0.0.0"
, sslbind = Just "0.0.0.0"
, sslcert = Just "cert.pem"
, sslkey = Just "key.pem"
, defaultTimeout = Just 60
}
------------------------------------------------------------------------------
-- | The hostname of the HTTP server
getHostname :: Config m a -> Maybe ByteString
getHostname = hostname
-- | Path to the access log
getAccessLog :: Config m a -> Maybe (Maybe FilePath)
getAccessLog = accessLog
-- | Path to the error log
getErrorLog :: Config m a -> Maybe (Maybe FilePath)
getErrorLog = errorLog
-- | The locale to use
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 key file
getSSLKey :: Config m a -> Maybe FilePath
getSSLKey = sslkey
-- | 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
getBackend :: Config m a -> Maybe ConfigBackend
getBackend = backend
------------------------------------------------------------------------------
setHostname :: ByteString -> Config m a -> Config m a
setHostname x c = c { hostname = Just x }
setAccessLog :: (Maybe FilePath) -> Config m a -> Config m a
setAccessLog x c = c { accessLog = Just x }
setErrorLog :: (Maybe FilePath) -> 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 }
setSSLKey :: FilePath -> Config m a -> Config m a
setSSLKey x c = c { sslkey = Just x }
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 }
setBackend :: ConfigBackend -> Config m a -> Config m a
setBackend x c = c { backend = Just 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
noPort = isNothing (getPort cfg) && not sslValid
cfg' = emptyConfig { port = if noPort then Just 8000 else Nothing }
------------------------------------------------------------------------------
fromString :: String -> ByteString
fromString = T.encodeUtf8 . T.pack
------------------------------------------------------------------------------
options :: MonadSnap m =>
Config m a
-> [OptDescr (Maybe (Config m a))]
options defaults =
[ Option [] ["hostname"]
(ReqArg (Just . setConfig setHostname . fromString) "NAME")
$ "local hostname" ++ defaultC getHostname
, Option ['b'] ["address"]
(ReqArg (\s -> Just $ mempty { bind = Just $ fromString 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 $ fromString 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-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 . Just) "PATH")
$ "access log" ++ (defaultC $ join . getAccessLog)
, Option [] ["error-log"]
(ReqArg (Just . setConfig setErrorLog . Just) "PATH")
$ "error log" ++ (defaultC $ join . getErrorLog)
, Option [] ["no-access-log"]
(NoArg $ Just $ setConfig setErrorLog Nothing)
$ "don't have an access log"
, Option [] ["no-error-log"]
(NoArg $ Just $ setConfig setAccessLog Nothing)
$ "don't have an error log"
, Option ['c'] ["compression"]
(NoArg $ Just $ setConfig setCompression True)
$ "use gzip compression on responses"
, Option ['t'] ["timeout"]
(ReqArg (\t -> Just $ mempty {
defaultTimeout = Just $ read t
}) "SECS")
$ "set default timeout in seconds"
, Option [] ["no-compression"]
(NoArg $ Just $ setConfig setCompression False)
$ "serve responses uncompressed"
, Option ['v'] ["verbose"]
(NoArg $ Just $ setConfig setVerbose True)
$ "print server status updates to stderr"
, Option ['q'] ["quiet"]
(NoArg $ Just $ setConfig setVerbose False)
$ "do not print anything to stderr"
, Option ['h'] ["help"]
(NoArg Nothing)
$ "display this help and exit"
]
where
setConfig f c = f c mempty
conf = defaultConfig `mappend` defaults
defaultC f = maybe "" ((", default " ++) . show) $ f conf
defaultO f = maybe ", default off" ((", default " ++) . show) $ f conf
------------------------------------------------------------------------------
defaultErrorHandler :: MonadSnap m => SomeException -> m ()
defaultErrorHandler e = do
debug "Snap.Http.Server.Config errorHandler: got exception:"
debug $ show e
logError msg
finishWith $ setContentType "text/plain; charset=utf-8"
. setContentLength (fromIntegral $ B.length msg)
. setResponseStatus 500 "Internal Server Error"
. modifyResponseBody
(>==> enumBuilder (fromByteString msg))
$ emptyResponse
where
err = fromString $ show e
msg = mappend "A web handler threw an exception. Details:\n" err
------------------------------------------------------------------------------
-- | Returns a 'Config' obtained from parsing the options specified on the
-- command-line.
--
-- 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 not
-- specified on the command line. Usually it is
-- fine to use 'emptyConfig' here.
-> IO (Config m a)
commandLineConfig defaults = do
args <- getArgs
prog <- getProgName
let opts = options defaults
result <- either (usage prog opts)
return
(case getOpt Permute opts args of
(f, _, [] ) -> maybe (Left []) Right $
fmap mconcat $ 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 opts 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
Jump to Line
Something went wrong with that request. Please try again.