new config.hs

Config.hs

{-# 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

  , emptyConfig
  , defaultConfig
  , commandLineConfig

  , getAccessLog
  , getBind
  , getCompression
  , getDefaultTimeout
  , getErrorHandler
  , getErrorLog
  , getHostname
  , getLocale
  , getPort
  , getSSLBind
  , getSSLCert
  , getSSLKey
  , getSSLPort
  , getVerbose

  , setAccessLog
  , setBind
  , setCompression
  , setDefaultTimeout
  , setErrorHandler
  , setErrorLog
  , setHostname
  , setLocale
  , 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.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


------------------------------------------------------------------------------
-- | 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 = 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
    }


------------------------------------------------------------------------------
-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
-- 'Config''s 'Monoid' instance.
emptyConfig :: Config m
emptyConfig = mempty


------------------------------------------------------------------------------
instance Monoid (Config m) 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
        }

    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
        }
      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
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"
    , port           = Just 8000
    , 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 -> Maybe ByteString
getHostname = hostname

-- | Path to the access log
getAccessLog      :: Config m -> Maybe (Maybe FilePath)
getAccessLog = accessLog

-- | Path to the error log
getErrorLog       :: Config m -> Maybe (Maybe FilePath)
getErrorLog = errorLog

-- | The locale to use
getLocale         :: Config m -> Maybe String
getLocale = locale

-- | Returns the port to listen on (for http)
getPort           :: Config m -> Maybe Int
getPort = port

-- | Returns the address to bind to (for http)
getBind           :: Config m -> Maybe ByteString
getBind = bind

-- | Returns the port to listen on (for https)
getSSLPort        :: Config m -> Maybe Int
getSSLPort = sslport

-- | Returns the address to bind to (for https)
getSSLBind        :: Config m -> Maybe ByteString
getSSLBind = sslbind

-- | Path to the SSL certificate file
getSSLCert        :: Config m -> Maybe FilePath
getSSLCert = sslcert

-- | Path to the SSL key file
getSSLKey         :: Config m -> Maybe FilePath
getSSLKey = sslkey

-- | If set and set to True, compression is turned on when applicable
getCompression    :: Config m -> Maybe Bool
getCompression = compression

-- | Whether to write server status updates to stderr
getVerbose        :: Config m -> Maybe Bool
getVerbose = verbose

-- | A MonadSnap action to handle 500 errors
getErrorHandler   :: Config m -> Maybe (SomeException -> m ())
getErrorHandler = errorHandler

getDefaultTimeout :: Config m -> Maybe Int
getDefaultTimeout = defaultTimeout


------------------------------------------------------------------------------
setHostname       :: ByteString              -> Config m -> Config m
setHostname x c = c { hostname = Just x }

setAccessLog      :: (Maybe FilePath)        -> Config m -> Config m
setAccessLog x c = c { accessLog = Just x }

setErrorLog       :: (Maybe FilePath)        -> Config m -> Config m
setErrorLog x c = c { errorLog = Just x }

setLocale         :: String                  -> Config m -> Config m
setLocale x c = c { locale = Just x }

setPort           :: Int                     -> Config m -> Config m
setPort x c = c { port = Just x }

setBind           :: ByteString              -> Config m -> Config m
setBind x c = c { bind = Just x }

setSSLPort        :: Int                     -> Config m -> Config m
setSSLPort x c = c { sslport = Just x }

setSSLBind        :: ByteString              -> Config m -> Config m
setSSLBind x c = c { sslbind = Just x }

setSSLCert        :: FilePath                -> Config m -> Config m
setSSLCert x c = c { sslcert = Just x }

setSSLKey         :: FilePath                -> Config m -> Config m
setSSLKey x c = c { sslkey = Just x }

setCompression    :: Bool                    -> Config m -> Config m
setCompression x c = c { compression = Just x }

setVerbose        :: Bool                    -> Config m -> Config m
setVerbose x c = c { verbose = Just x }

setErrorHandler   :: (SomeException -> m ()) -> Config m -> Config m
setErrorHandler x c = c { errorHandler = Just x }

setDefaultTimeout :: Int                     -> Config m -> Config m
setDefaultTimeout x c = c { defaultTimeout = Just x }


------------------------------------------------------------------------------
fromString :: String -> ByteString
fromString = T.encodeUtf8 . T.pack


------------------------------------------------------------------------------
options :: MonadSnap m =>
           Config m
        -> [OptDescr (Maybe (Config m))]
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   -- ^ 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)
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

#ifndef PORTABLE
    lang <- getEnv "LANG"
    return $ mconcat [defaults, result, mempty {locale = fmap upToUtf8 lang}]
#else
    return $ mconcat [defaults, result]
#endif

  where
    opts = options defaults

    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