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
data ConfigBackend = ConfigSimpleBackend
| ConfigLibEvBackend
deriving (Show, Eq)
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
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
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
}
getHostname :: Config m a -> Maybe ByteString
getHostname = hostname
getAccessLog :: Config m a -> Maybe (Maybe FilePath)
getAccessLog = accessLog
getErrorLog :: Config m a -> Maybe (Maybe FilePath)
getErrorLog = errorLog
getLocale :: Config m a -> Maybe String
getLocale = locale
getPort :: Config m a -> Maybe Int
getPort = port
getBind :: Config m a -> Maybe ByteString
getBind = bind
getSSLPort :: Config m a -> Maybe Int
getSSLPort = sslport
getSSLBind :: Config m a -> Maybe ByteString
getSSLBind = sslbind
getSSLCert :: Config m a -> Maybe FilePath
getSSLCert = sslcert
getSSLKey :: Config m a -> Maybe FilePath
getSSLKey = sslkey
getCompression :: Config m a -> Maybe Bool
getCompression = compression
getVerbose :: Config m a -> Maybe Bool
getVerbose = verbose
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
commandLineConfig :: MonadSnap m =>
Config m a
-> 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