snap-server-0.4.3: src/Snap/Http/Server/Config.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
This module exports the 'Config' datatype which represents partially-specified
configurations of \"serve\" functions which run 'Snap' actions in 'IO'.
-}
module Snap.Http.Server.Config
( Config
, ConfigListen(..)
, ConfigBackend(..)
, emptyConfig
, defaultConfig
, completeConfig
, commandLineConfig
, getHostname
, getListen
, getAccessLog
, getErrorLog
, getLocale
, getBackend
, getCompression
, getVerbose
, getErrorHandler
, getDefaultTimeout
, getOther
, setHostname
, addListen
, setListen
, setAccessLog
, setErrorLog
, setLocale
, setBackend
, setCompression
, setVerbose
, setErrorHandler
, setDefaultTimeout
, setOther
) where
import Blaze.ByteString.Builder
import Control.Exception (SomeException)
import Control.Monad
import qualified Data.ByteString.UTF8 as U
import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
import Data.Char
import Data.List
import Data.Monoid
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
------------------------------------------------------------------------------
-- | A data type to store the bind address and port to listen on.
--
-- For SSL support, it also stores the path to the certificate in PEM format
-- and the path to the private key in PEM format
data ConfigListen = ListenHttp ByteString Int
| ListenHttps ByteString Int FilePath FilePath
instance Show ConfigListen where
show (ListenHttp b p) = "http://" ++ U.toString b ++ ":" ++ show p
show (ListenHttps b p c k) =
"https://" ++ U.toString b ++ ":" ++ show p ++
" (cert = " ++ show c ++ ", key = " ++ show k ++ ")"
------------------------------------------------------------------------------
-- | A data type to record which backend event loop should be used when
-- serving data.
data ConfigBackend = ConfigSimpleBackend
| ConfigLibEvBackend
deriving (Eq,Show)
------------------------------------------------------------------------------
-- | 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:
--
-- > addListen (ListenHttp "0.0.0.0" 9000) 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 MonadSnap m => Config m a = Config
{ hostname :: Maybe ByteString
-- ^ The name of the server
, listen :: [ConfigListen]
-- ^ The local interfaces to listen on
, accessLog :: Maybe (Maybe FilePath)
-- ^ The path to the access log
, errorLog :: Maybe (Maybe FilePath)
-- ^ The path to the error log
, locale :: Maybe String
-- ^ The locale to use
, backend :: Maybe ConfigBackend
-- ^ The backend to use
, compression :: Maybe Bool
-- ^ Whether to use compression
, verbose :: Maybe Bool
-- ^ Whether to write server status updates to stderr
, errorHandler :: Maybe (SomeException -> m ())
-- ^ A MonadSnap action to handle 500 errors
, defaultTimeout :: Maybe Int
, other :: Maybe a
-- ^ This is for any other state needed to initialize a custom server
}
------------------------------------------------------------------------------
instance MonadSnap m => Show (Config m a) where
show c = "Config {" ++ concat (intersperse ", " $ filter (/="") $ map ($c)
[ showM "hostname" . hostname
, showL "listen" . listen
, showM "accessLog" . accessLog
, showM "errorLog" . errorLog
, showM "locale" . locale
, showM "backend" . backend
, showM "compression" . compression
, showM "verbose" . verbose
, showM "errorHandler" . fmap (const ()) . errorHandler
, showM "defaultTimeout" . fmap (const ()) . defaultTimeout
]) ++ "}"
where
showM s = maybe "" ((++) (s ++ " = ") . show)
showL s l = s ++ " = " ++ show l
------------------------------------------------------------------------------
-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
-- 'Config''s 'Monoid' instance.
emptyConfig :: MonadSnap m => Config m a
emptyConfig = mempty
------------------------------------------------------------------------------
instance MonadSnap m => Monoid (Config m a) where
mempty = Config
{ hostname = Nothing
, listen = []
, accessLog = Nothing
, errorLog = Nothing
, locale = Nothing
, backend = Nothing
, compression = Nothing
, verbose = Nothing
, errorHandler = Nothing
, defaultTimeout = Nothing
, other = Nothing
}
a `mappend` b = Config
{ hostname = (hostname b) `mplus` (hostname a)
, listen = (listen b) ++ (listen a)
, accessLog = (accessLog b) `mplus` (accessLog a)
, errorLog = (errorLog b) `mplus` (errorLog a)
, locale = (locale b) `mplus` (locale a)
, backend = (backend b) `mplus` (backend a)
, compression = (compression b) `mplus` (compression a)
, verbose = (verbose b) `mplus` (verbose a)
, errorHandler = (errorHandler b) `mplus` (errorHandler a)
, defaultTimeout = (defaultTimeout b) `mplus` (defaultTimeout a)
, other = (other b) `mplus` (other a)
}
------------------------------------------------------------------------------
-- | These are the default values for all the fields in 'Config'.
--
-- > hostname = "localhost"
-- > listen = []
-- > accessLog = "log/access.log"
-- > errorLog = "log/error.log"
-- > locale = "en_US"
-- > backend = Nothing (the backend is selected based on compile options)
-- > compression = True
-- > verbose = True
-- > errorHandler = prints the error message
--
defaultConfig :: MonadSnap m => Config m a
defaultConfig = Config
{ hostname = Just "localhost"
, listen = []
, accessLog = Just $ Just "log/access.log"
, errorLog = Just $ Just "log/error.log"
, locale = Just "en_US"
, backend = Nothing
, compression = Just True
, verbose = Just True
, errorHandler = Just defaultErrorHandler
, defaultTimeout = Just 60
, other = Nothing
}
------------------------------------------------------------------------------
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 = U.fromString $ show e
msg = mappend "A web handler threw an exception. Details:\n" err
------------------------------------------------------------------------------
-- | Completes a partial 'Config' by filling in the unspecified values with
-- the default values from 'defaultConfig'. Also, if no listeners are
-- specified, adds a http listener on 0.0.0.0:8000
completeConfig :: MonadSnap m => Config m a -> Config m a
completeConfig c = case listen c' of
[] -> addListen (ListenHttp "0.0.0.0" 8000) c'
_ -> c'
where c' = mappend defaultConfig c
------------------------------------------------------------------------------
-- | A data structure used during command-line option parsing
--
-- The Config data type allows a list of listen ports, but the command line
-- options only allow one http and one https listener. This data structure
-- is used during option parsing
data MonadSnap m => OptionData m a = OptionData
{ config :: Config m a
, bind :: Maybe ByteString
, port :: Maybe Int
, sslbind :: Maybe ByteString
, sslport :: Maybe Int
, sslcert :: Maybe FilePath
, sslkey :: Maybe FilePath
, tout :: Maybe Int
}
------------------------------------------------------------------------------
instance MonadSnap m => Monoid (OptionData m a) where
mempty = OptionData
{ config = mempty
, bind = Nothing
, port = Nothing
, sslbind = Nothing
, sslport = Nothing
, sslcert = Nothing
, sslkey = Nothing
, tout = Nothing
}
a `mappend` b = OptionData
{ config = (config b) `mappend` (config a)
, bind = (bind b) `mplus` (bind a)
, port = (port b) `mplus` (port a)
, sslbind = (sslbind b) `mplus` (sslbind a)
, sslport = (sslport b) `mplus` (sslport a)
, sslcert = (sslcert b) `mplus` (sslcert a)
, sslkey = (sslkey b) `mplus` (sslkey a)
, tout = (tout b) `mplus` (tout a)
}
------------------------------------------------------------------------------
-- | These are the default values for the options
defaultOptions :: MonadSnap m => OptionData m a
defaultOptions = OptionData
{ config = defaultConfig
, bind = Just "0.0.0.0"
, port = Just 8000
, sslbind = Just "0.0.0.0"
, sslport = Nothing
, sslcert = Just "cert.pem"
, sslkey = Just "key.pem"
, tout = Just 60
}
------------------------------------------------------------------------------
-- | Convert options to config
optionsToConfig :: MonadSnap m => OptionData m a -> Config m a
optionsToConfig o = mconcat $ [config o] ++ http ++ https ++ [tmOut]
where lhttp = maybe2 [] ListenHttp (bind o) (port o)
lhttps = maybe4 [] ListenHttps (sslbind o)
(sslport o)
(sslcert o)
(sslkey o)
http = map (flip addListen mempty) lhttp
https = map (flip addListen mempty) lhttps
maybe2 _ f (Just a) (Just b) = [f a b]
maybe2 d _ _ _ = d
maybe4 _ f (Just a) (Just b) (Just c) (Just d) = [f a b c d]
maybe4 d _ _ _ _ _ = d
tmOut = maybe mempty
(\t -> mempty { defaultTimeout = Just t })
(tout o)
------------------------------------------------------------------------------
-- | Convert config to options
configToOptions :: MonadSnap m => Config m a -> OptionData m a
configToOptions c = OptionData
{ config = c
, bind = Nothing
, port = Nothing
, sslbind = Nothing
, sslport = Nothing
, sslcert = Nothing
, sslkey = Nothing
, tout = (defaultTimeout c)
}
------------------------------------------------------------------------------
-- | A description of the command-line options accepted by
-- 'commandLineConfig'.
--
-- The 'OptionData' parameter is just for specifying any default values which
-- are to override those in 'defaultOptions'. This is so the usage message can
-- accurately inform the user what the default values for the options are. In
-- most cases, you will probably just end up passing 'mempty' for this
-- parameter.
--
-- The return type is a list of options describing @'Maybe' ('OptionData' m)@
-- as opposed to @'OptionData' m@, because if the @--help@ option is given,
-- the set of command-line options no longer describe a config, but an action
-- (printing out the usage message).
options :: MonadSnap m
=> OptionData m a
-> [OptDescr (Maybe (OptionData m a))]
options defaults =
[ Option [] ["hostname"]
(ReqArg (Just . setConfig setHostname . U.fromString) "NAME")
$ "local hostname" ++ defaultC getHostname
, Option ['b'] ["address"]
(ReqArg (\s -> Just $ mempty { bind = Just $ U.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 $ U.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 { tout = 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 = configToOptions $ f c mempty
conf = completeConfig $ config defaults
opts = mappend defaultOptions defaults
defaultC f = maybe "" ((", default " ++) . show) $ f conf
defaultO f = maybe ", default off" ((", default " ++) . show) $ f opts
------------------------------------------------------------------------------
-- | This returns a 'Config' gotten from parsing the options specified on the
-- command-line.
--
-- The 'Config' parameter is just for specifying any default values which are
-- to override those in 'defaultConfig'. This is so the usage message can
-- accurately inform the user what the default values for the options are. In
-- most cases, you will probably just end up passing 'mempty' for this
-- parameter.
--
-- On Unix systems, the locale is read from the @LANG@ environment variable.
commandLineConfig :: MonadSnap m => Config m a -> IO (Config m a)
commandLineConfig defaults = do
args <- getArgs
prog <- getProgName
result <- either (usage prog) return $ case getOpt Permute opts args of
(f, _, [] ) -> maybe (Left []) Right $ fmap mconcat $ sequence f
(_, _, errs) -> Left errs
let result' = optionsToConfig $ mappend defaultOptions result
#ifndef PORTABLE
lang <- getEnv "LANG"
return $ mconcat [defaults, result', mempty {locale = fmap upToUtf8 lang}]
#else
return $ mconcat [defaults, result']
#endif
where
opts = options $ configToOptions defaults
usage prog errs = do
let hdr = "Usage:\n " ++ prog ++ " [OPTION...]\n\nOptions:"
let msg = concat errs ++ usageInfo hdr opts
hPutStrLn stderr msg
exitFailure
upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c
------------------------------------------------------------------------------
getHostname :: MonadSnap m => Config m a -> Maybe ByteString
getHostname = hostname
------------------------------------------------------------------------------
getListen :: MonadSnap m => Config m a -> [ConfigListen]
getListen = listen
------------------------------------------------------------------------------
getAccessLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)
getAccessLog = accessLog
------------------------------------------------------------------------------
getErrorLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath)
getErrorLog = errorLog
------------------------------------------------------------------------------
getLocale :: MonadSnap m => Config m a -> Maybe String
getLocale = locale
------------------------------------------------------------------------------
getBackend :: MonadSnap m => Config m a -> Maybe ConfigBackend
getBackend = backend
------------------------------------------------------------------------------
getCompression :: MonadSnap m => Config m a -> Maybe Bool
getCompression = compression
------------------------------------------------------------------------------
getVerbose :: MonadSnap m => Config m a -> Maybe Bool
getVerbose = verbose
------------------------------------------------------------------------------
getErrorHandler :: MonadSnap m => Config m a -> Maybe (SomeException -> m ())
getErrorHandler = errorHandler
------------------------------------------------------------------------------
getOther :: MonadSnap m => Config m a -> Maybe a
getOther = other
------------------------------------------------------------------------------
getDefaultTimeout :: MonadSnap m => Config m a -> Maybe Int
getDefaultTimeout = defaultTimeout
------------------------------------------------------------------------------
setHostname :: MonadSnap m => ByteString -> Config m a -> Config m a
setHostname a m = m {hostname = Just a}
------------------------------------------------------------------------------
addListen :: MonadSnap m => ConfigListen -> Config m a -> Config m a
addListen a m = m {listen = a : listen m}
------------------------------------------------------------------------------
setListen :: MonadSnap m => [ConfigListen] -> Config m a -> Config m a
setListen a m = m {listen = a}
------------------------------------------------------------------------------
setAccessLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a
setAccessLog a m = m {accessLog = Just a}
------------------------------------------------------------------------------
setErrorLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a
setErrorLog a m = m {errorLog = Just a}
------------------------------------------------------------------------------
setLocale :: MonadSnap m => String -> Config m a -> Config m a
setLocale a m = m {locale = Just a}
------------------------------------------------------------------------------
setBackend :: MonadSnap m => ConfigBackend -> Config m a -> Config m a
setBackend a m = m { backend = Just a}
------------------------------------------------------------------------------
setCompression :: MonadSnap m => Bool -> Config m a -> Config m a
setCompression a m = m {compression = Just a}
------------------------------------------------------------------------------
setVerbose :: MonadSnap m => Bool -> Config m a -> Config m a
setVerbose a m = m {verbose = Just a}
------------------------------------------------------------------------------
setErrorHandler :: MonadSnap m => (SomeException -> m ()) -> Config m a
-> Config m a
setErrorHandler a m = m {errorHandler = Just a}
------------------------------------------------------------------------------
setOther :: MonadSnap m => a -> Config m a -> Config m a
setOther a m = m {other = Just a}
------------------------------------------------------------------------------
setDefaultTimeout :: MonadSnap m => Int -> Config m a -> Config m a
setDefaultTimeout t m = m {defaultTimeout = Just t}