1 {-# LANGUAGE CPP #-}
    2 {-# LANGUAGE OverloadedStrings #-}
    3 
    4 {-|
    5 
    6 This module exports the 'Config' datatype, which you can use to configure the
    7 Snap HTTP server.
    8 
    9 -}
   10 
   11 module Snap.Http.Server.Config
   12   ( Config
   13   , ConfigBackend(..)
   14 
   15   , emptyConfig
   16   , defaultConfig
   17   , commandLineConfig
   18   , completeConfig
   19 
   20   , getAccessLog
   21   , getBackend
   22   , getBind
   23   , getCompression
   24   , getDefaultTimeout
   25   , getErrorHandler
   26   , getErrorLog
   27   , getHostname
   28   , getLocale
   29   , getOther
   30   , getPort
   31   , getSSLBind
   32   , getSSLCert
   33   , getSSLKey
   34   , getSSLPort
   35   , getVerbose
   36 
   37   , setAccessLog
   38   , setBackend
   39   , setBind
   40   , setCompression
   41   , setDefaultTimeout
   42   , setErrorHandler
   43   , setErrorLog
   44   , setHostname
   45   , setLocale
   46   , setOther
   47   , setPort
   48   , setSSLBind
   49   , setSSLCert
   50   , setSSLKey
   51   , setSSLPort
   52   , setVerbose
   53   ) where
   54 
   55 
   56 import           Blaze.ByteString.Builder
   57 import           Control.Exception (SomeException)
   58 import           Control.Monad
   59 import qualified Data.ByteString.Char8 as B
   60 import           Data.ByteString (ByteString)
   61 import           Data.Char
   62 import           Data.Function
   63 import           Data.List
   64 import           Data.Maybe
   65 import           Data.Monoid
   66 import qualified Data.Text as T
   67 import qualified Data.Text.Encoding as T
   68 import           Prelude hiding (catch)
   69 import           Snap.Types
   70 import           Snap.Iteratee ((>==>), enumBuilder)
   71 import           Snap.Internal.Debug (debug)
   72 import           System.Console.GetOpt
   73 import           System.Environment hiding (getEnv)
   74 #ifndef PORTABLE
   75 import           System.Posix.Env
   76 #endif
   77 import           System.Exit
   78 import           System.IO
   79 
   80 
   81 ------------------------------------------------------------------------------
   82 -- | This datatype allows you to override which backend (either simple or
   83 -- libev) to use. Most users will not want to set this, preferring to rely on
   84 -- the compile-type default.
   85 --
   86 -- Note that if you specify the libev backend and have not compiled in support
   87 -- for it, your server will fail at runtime.
   88 data ConfigBackend = ConfigSimpleBackend
   89                    | ConfigLibEvBackend
   90   deriving (Show, Eq)
   91 
   92 ------------------------------------------------------------------------------
   93 -- | A record type which represents partial configurations (for 'httpServe')
   94 -- by wrapping all of its fields in a 'Maybe'. Values of this type are usually
   95 -- constructed via its 'Monoid' instance by doing something like:
   96 --
   97 -- > setPort 1234 mempty
   98 --
   99 -- Any fields which are unspecified in the 'Config' passed to 'httpServe' (and
  100 -- this is the norm) are filled in with default values from 'defaultConfig'.
  101 data Config m a = Config
  102     { hostname       :: Maybe ByteString
  103     , accessLog      :: Maybe (Maybe FilePath)
  104     , errorLog       :: Maybe (Maybe FilePath)
  105     , locale         :: Maybe String
  106     , port           :: Maybe Int
  107     , bind           :: Maybe ByteString
  108     , sslport        :: Maybe Int
  109     , sslbind        :: Maybe ByteString
  110     , sslcert        :: Maybe FilePath
  111     , sslkey         :: Maybe FilePath
  112     , compression    :: Maybe Bool
  113     , verbose        :: Maybe Bool
  114     , errorHandler   :: Maybe (SomeException -> m ())
  115     , defaultTimeout :: Maybe Int
  116     , other          :: Maybe a
  117     , backend        :: Maybe ConfigBackend
  118     }
  119 
  120 instance Show (Config m a) where
  121     show c = unlines [ "Config:"
  122                      , "hostname: "       ++ _hostname
  123                      , "accessLog: "      ++ _accessLog
  124                      , "errorLog: "       ++ _errorLog
  125                      , "locale: "         ++ _locale
  126                      , "port: "           ++ _port
  127                      , "bind: "           ++ _bind
  128                      , "sslport: "        ++ _sslport
  129                      , "sslbind: "        ++ _sslbind
  130                      , "sslcert: "        ++ _sslcert
  131                      , "sslkey: "         ++ _sslkey
  132                      , "compression: "    ++ _compression
  133                      , "verbose: "        ++ _verbose
  134                      , "defaultTimeout: " ++ _defaultTimeout
  135                      , "backend: "        ++ _backend
  136                      ]
  137 
  138       where
  139         _hostname       = show $ hostname       c
  140         _accessLog      = show $ accessLog      c
  141         _errorLog       = show $ errorLog       c
  142         _locale         = show $ locale         c
  143         _port           = show $ port           c
  144         _bind           = show $ bind           c
  145         _sslport        = show $ sslport        c
  146         _sslbind        = show $ sslbind        c
  147         _sslcert        = show $ sslcert        c
  148         _sslkey         = show $ sslkey         c
  149         _compression    = show $ compression    c
  150         _verbose        = show $ verbose        c
  151         _defaultTimeout = show $ defaultTimeout c
  152         _backend        = show $ backend        c
  153 
  154 
  155 ------------------------------------------------------------------------------
  156 -- | Returns a completely empty 'Config'. Equivalent to 'mempty' from
  157 -- 'Config''s 'Monoid' instance.
  158 emptyConfig :: Config m a
  159 emptyConfig = mempty
  160 
  161 
  162 ------------------------------------------------------------------------------
  163 instance Monoid (Config m a) where
  164     mempty = Config
  165         { hostname       = Nothing
  166         , accessLog      = Nothing
  167         , errorLog       = Nothing
  168         , locale         = Nothing
  169         , port           = Nothing
  170         , bind           = Nothing
  171         , sslport        = Nothing
  172         , sslbind        = Nothing
  173         , sslcert        = Nothing
  174         , sslkey         = Nothing
  175         , compression    = Nothing
  176         , verbose        = Nothing
  177         , errorHandler   = Nothing
  178         , defaultTimeout = Nothing
  179         , other          = Nothing
  180         , backend        = Nothing
  181         }
  182 
  183     a `mappend` b = Config
  184         { hostname       = ov hostname       a b
  185         , accessLog      = ov accessLog      a b
  186         , errorLog       = ov errorLog       a b
  187         , locale         = ov locale         a b
  188         , port           = ov port           a b
  189         , bind           = ov bind           a b
  190         , sslport        = ov sslport        a b
  191         , sslbind        = ov sslbind        a b
  192         , sslcert        = ov sslcert        a b
  193         , sslkey         = ov sslkey         a b
  194         , compression    = ov compression    a b
  195         , verbose        = ov verbose        a b
  196         , errorHandler   = ov errorHandler   a b
  197         , defaultTimeout = ov defaultTimeout a b
  198         , other          = ov other          a b
  199         , backend        = ov backend        a b
  200         }
  201       where
  202         ov f x y = getLast $! (mappend `on` (Last . f)) x y
  203 
  204 
  205 ------------------------------------------------------------------------------
  206 -- | These are the default values for the options
  207 defaultConfig :: MonadSnap m => Config m a
  208 defaultConfig = mempty
  209     { hostname       = Just "localhost"
  210     , accessLog      = Just $ Just "log/access.log"
  211     , errorLog       = Just $ Just "log/error.log"
  212     , locale         = Just "en_US"
  213     , compression    = Just True
  214     , verbose        = Just True
  215     , errorHandler   = Just defaultErrorHandler
  216     , bind           = Just "0.0.0.0"
  217     , sslbind        = Just "0.0.0.0"
  218     , sslcert        = Just "cert.pem"
  219     , sslkey         = Just "key.pem"
  220     , defaultTimeout = Just 60
  221     }
  222 
  223 
  224 ------------------------------------------------------------------------------
  225 -- | The hostname of the HTTP server
  226 getHostname       :: Config m a -> Maybe ByteString
  227 getHostname = hostname
  228 
  229 -- | Path to the access log
  230 getAccessLog      :: Config m a -> Maybe (Maybe FilePath)
  231 getAccessLog = accessLog
  232 
  233 -- | Path to the error log
  234 getErrorLog       :: Config m a -> Maybe (Maybe FilePath)
  235 getErrorLog = errorLog
  236 
  237 -- | The locale to use
  238 getLocale         :: Config m a -> Maybe String
  239 getLocale = locale
  240 
  241 -- | Returns the port to listen on (for http)
  242 getPort           :: Config m a -> Maybe Int
  243 getPort = port
  244 
  245 -- | Returns the address to bind to (for http)
  246 getBind           :: Config m a -> Maybe ByteString
  247 getBind = bind
  248 
  249 -- | Returns the port to listen on (for https)
  250 getSSLPort        :: Config m a -> Maybe Int
  251 getSSLPort = sslport
  252 
  253 -- | Returns the address to bind to (for https)
  254 getSSLBind        :: Config m a -> Maybe ByteString
  255 getSSLBind = sslbind
  256 
  257 -- | Path to the SSL certificate file
  258 getSSLCert        :: Config m a -> Maybe FilePath
  259 getSSLCert = sslcert
  260 
  261 -- | Path to the SSL key file
  262 getSSLKey         :: Config m a -> Maybe FilePath
  263 getSSLKey = sslkey
  264 
  265 -- | If set and set to True, compression is turned on when applicable
  266 getCompression    :: Config m a -> Maybe Bool
  267 getCompression = compression
  268 
  269 -- | Whether to write server status updates to stderr
  270 getVerbose        :: Config m a -> Maybe Bool
  271 getVerbose = verbose
  272 
  273 -- | A MonadSnap action to handle 500 errors
  274 getErrorHandler   :: Config m a -> Maybe (SomeException -> m ())
  275 getErrorHandler = errorHandler
  276 
  277 getDefaultTimeout :: Config m a -> Maybe Int
  278 getDefaultTimeout = defaultTimeout
  279 
  280 getOther :: Config m a -> Maybe a
  281 getOther = other
  282 
  283 getBackend :: Config m a -> Maybe ConfigBackend
  284 getBackend = backend
  285 
  286 
  287 ------------------------------------------------------------------------------
  288 setHostname       :: ByteString              -> Config m a -> Config m a
  289 setHostname x c = c { hostname = Just x }
  290 
  291 setAccessLog      :: (Maybe FilePath)        -> Config m a -> Config m a
  292 setAccessLog x c = c { accessLog = Just x }
  293 
  294 setErrorLog       :: (Maybe FilePath)        -> Config m a -> Config m a
  295 setErrorLog x c = c { errorLog = Just x }
  296 
  297 setLocale         :: String                  -> Config m a -> Config m a
  298 setLocale x c = c { locale = Just x }
  299 
  300 setPort           :: Int                     -> Config m a -> Config m a
  301 setPort x c = c { port = Just x }
  302 
  303 setBind           :: ByteString              -> Config m a -> Config m a
  304 setBind x c = c { bind = Just x }
  305 
  306 setSSLPort        :: Int                     -> Config m a -> Config m a
  307 setSSLPort x c = c { sslport = Just x }
  308 
  309 setSSLBind        :: ByteString              -> Config m a -> Config m a
  310 setSSLBind x c = c { sslbind = Just x }
  311 
  312 setSSLCert        :: FilePath                -> Config m a -> Config m a
  313 setSSLCert x c = c { sslcert = Just x }
  314 
  315 setSSLKey         :: FilePath                -> Config m a -> Config m a
  316 setSSLKey x c = c { sslkey = Just x }
  317 
  318 setCompression    :: Bool                    -> Config m a -> Config m a
  319 setCompression x c = c { compression = Just x }
  320 
  321 setVerbose        :: Bool                    -> Config m a -> Config m a
  322 setVerbose x c = c { verbose = Just x }
  323 
  324 setErrorHandler   :: (SomeException -> m ()) -> Config m a -> Config m a
  325 setErrorHandler x c = c { errorHandler = Just x }
  326 
  327 setDefaultTimeout :: Int                     -> Config m a -> Config m a
  328 setDefaultTimeout x c = c { defaultTimeout = Just x }
  329 
  330 setOther          :: a                       -> Config m a -> Config m a
  331 setOther x c = c { other = Just x }
  332 
  333 setBackend        :: ConfigBackend           -> Config m a -> Config m a
  334 setBackend x c = c { backend = Just x }
  335 
  336 
  337 ------------------------------------------------------------------------------
  338 completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a)
  339 completeConfig config = do
  340     when noPort $ hPutStrLn stderr "no port specified, defaulting to port 8000"
  341 
  342     return $ cfg `mappend` cfg'
  343 
  344   where
  345     cfg = defaultConfig `mappend` config
  346 
  347     sslVals = map ($ cfg) [ isJust . getSSLPort
  348                           , isJust . getSSLBind
  349                           , isJust . getSSLKey
  350                           , isJust . getSSLCert ]
  351 
  352     sslValid   = and sslVals
  353     noPort = isNothing (getPort cfg) && not sslValid
  354 
  355     cfg' = emptyConfig { port = if noPort then Just 8000 else Nothing }
  356 
  357 
  358 ------------------------------------------------------------------------------
  359 fromString :: String -> ByteString
  360 fromString = T.encodeUtf8 . T.pack
  361 
  362 
  363 ------------------------------------------------------------------------------
  364 options :: MonadSnap m =>
  365            Config m a
  366         -> [OptDescr (Maybe (Config m a))]
  367 options defaults =
  368     [ Option [] ["hostname"]
  369              (ReqArg (Just . setConfig setHostname . fromString) "NAME")
  370              $ "local hostname" ++ defaultC getHostname
  371     , Option ['b'] ["address"]
  372              (ReqArg (\s -> Just $ mempty { bind = Just $ fromString s })
  373                      "ADDRESS")
  374              $ "address to bind to" ++ defaultO bind
  375     , Option ['p'] ["port"]
  376              (ReqArg (\s -> Just $ mempty { port = Just $ read s}) "PORT")
  377              $ "port to listen on" ++ defaultO port
  378     , Option [] ["ssl-address"]
  379              (ReqArg (\s -> Just $ mempty { sslbind = Just $ fromString s })
  380                      "ADDRESS")
  381              $ "ssl address to bind to" ++ defaultO sslbind
  382     , Option [] ["ssl-port"]
  383              (ReqArg (\s -> Just $ mempty { sslport = Just $ read s}) "PORT")
  384              $ "ssl port to listen on" ++ defaultO sslport
  385     , Option [] ["ssl-cert"]
  386              (ReqArg (\s -> Just $ mempty { sslcert = Just s}) "PATH")
  387              $ "path to ssl certificate in PEM format" ++ defaultO sslcert
  388     , Option [] ["ssl-key"]
  389              (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH")
  390              $ "path to ssl private key in PEM format" ++ defaultO sslkey
  391     , Option [] ["access-log"]
  392              (ReqArg (Just . setConfig setAccessLog . Just) "PATH")
  393              $ "access log" ++ (defaultC $ join . getAccessLog)
  394     , Option [] ["error-log"]
  395              (ReqArg (Just . setConfig setErrorLog . Just) "PATH")
  396              $ "error log" ++ (defaultC $ join . getErrorLog)
  397     , Option [] ["no-access-log"]
  398              (NoArg $ Just $ setConfig setErrorLog Nothing)
  399              $ "don't have an access log"
  400     , Option [] ["no-error-log"]
  401              (NoArg $ Just $ setConfig setAccessLog Nothing)
  402              $ "don't have an error log"
  403     , Option ['c'] ["compression"]
  404              (NoArg $ Just $ setConfig setCompression True)
  405              $ "use gzip compression on responses"
  406     , Option ['t'] ["timeout"]
  407              (ReqArg (\t -> Just $ mempty {
  408                               defaultTimeout = Just $ read t
  409                             }) "SECS")
  410              $ "set default timeout in seconds"
  411     , Option [] ["no-compression"]
  412              (NoArg $ Just $ setConfig setCompression False)
  413              $ "serve responses uncompressed"
  414     , Option ['v'] ["verbose"]
  415              (NoArg $ Just $ setConfig setVerbose True)
  416              $ "print server status updates to stderr"
  417     , Option ['q'] ["quiet"]
  418              (NoArg $ Just $ setConfig setVerbose False)
  419              $ "do not print anything to stderr"
  420     , Option ['h'] ["help"]
  421              (NoArg Nothing)
  422              $ "display this help and exit"
  423     ]
  424   where
  425     setConfig f c = f c mempty
  426     conf          = defaultConfig `mappend` defaults
  427     defaultC f    = maybe "" ((", default " ++) . show) $ f conf
  428     defaultO f    = maybe ", default off" ((", default " ++) . show) $ f conf
  429 
  430 
  431 
  432 
  433 ------------------------------------------------------------------------------
  434 defaultErrorHandler :: MonadSnap m => SomeException -> m ()
  435 defaultErrorHandler e = do
  436     debug "Snap.Http.Server.Config errorHandler: got exception:"
  437     debug $ show e
  438     logError msg
  439     finishWith $ setContentType "text/plain; charset=utf-8"
  440                . setContentLength (fromIntegral $ B.length msg)
  441                . setResponseStatus 500 "Internal Server Error"
  442                . modifyResponseBody
  443                      (>==> enumBuilder (fromByteString msg))
  444                $ emptyResponse
  445   where
  446     err = fromString $ show e
  447     msg = mappend "A web handler threw an exception. Details:\n" err
  448 
  449 
  450 
  451 ------------------------------------------------------------------------------
  452 -- | Returns a 'Config' obtained from parsing the options specified on the
  453 -- command-line.
  454 --
  455 -- On Unix systems, the locale is read from the @LANG@ environment variable.
  456 commandLineConfig :: MonadSnap m =>
  457                      Config m a   -- ^ default configuration. This is combined
  458                                   -- with 'defaultConfig' to obtain default
  459                                   -- values to use if the given parameter is not
  460                                   -- specified on the command line. Usually it is
  461                                   -- fine to use 'emptyConfig' here.
  462                   -> IO (Config m a)
  463 commandLineConfig defaults = do
  464     args <- getArgs
  465     prog <- getProgName
  466 
  467     let opts = options defaults
  468 
  469     result <- either (usage prog opts)
  470                      return
  471                      (case getOpt Permute opts args of
  472                         (f, _, []  ) -> maybe (Left []) Right $
  473                                         fmap mconcat $ sequence f
  474                         (_, _, errs) -> Left errs)
  475 
  476 #ifndef PORTABLE
  477     lang <- getEnv "LANG"
  478     completeConfig $ mconcat [defaults,
  479                               mempty {locale = fmap upToUtf8 lang},
  480                               result]
  481 #else
  482     completeConfig $ mconcat [defaults, result]
  483 #endif
  484 
  485   where
  486     usage prog opts errs = do
  487         let hdr = "Usage:\n  " ++ prog ++ " [OPTION...]\n\nOptions:"
  488         let msg = concat errs ++ usageInfo hdr opts
  489         hPutStrLn stderr msg
  490         exitFailure
  491 #ifndef PORTABLE
  492     upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c
  493 #endif