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