diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.8.0.1 +version: 0.8.1 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -104,16 +104,16 @@ directory-tree >= 0.10 && < 0.11, enumerator >= 0.4.15 && < 0.5, filepath >= 1.1 && < 1.4, - MonadCatchIO-transformers >= 0.2.1 && < 0.3, + MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, murmur-hash >= 0.1 && < 0.2, network >= 2.3 && < 2.4, old-locale, - snap-core >= 0.8 && < 0.9, + snap-core >= 0.8.1 && < 0.9, template-haskell >= 2.2 && < 2.8, text >= 0.11 && < 0.12, time >= 1.0 && < 1.5, - transformers >= 0.2 && < 0.3, + transformers >= 0.2 && < 0.4, unix-compat >= 0.2 && < 0.4, vector >= 0.7 && < 0.10, vector-algorithms >= 0.4 && < 0.6, diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-| @@ -17,9 +18,11 @@ , emptyConfig , defaultConfig , commandLineConfig + , extendedCommandLineConfig , completeConfig , optDescrs + , fmapOpt , getAccessLog , getBackend @@ -107,9 +110,9 @@ | ConfigIoLog (ByteString -> IO ()) -- ^ log custom IO handler instance Show ConfigLog where - show ConfigNoLog = "ConfigNoLog" - show (ConfigFileLog f) = "ConfigFileLog " ++ show f - show (ConfigIoLog _) = "ConfigIoLog" + show ConfigNoLog = "no log" + show (ConfigFileLog f) = "log to file " ++ show f + show (ConfigIoLog _) = "custom logging handler" ------------------------------------------------------------------------------ -- | A record type which represents partial configurations (for 'httpServe') @@ -207,26 +210,26 @@ } 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 - , proxyType = ov proxyType a b + { hostname = ov hostname + , accessLog = ov accessLog + , errorLog = ov errorLog + , locale = ov locale + , port = ov port + , bind = ov bind + , sslport = ov sslport + , sslbind = ov sslbind + , sslcert = ov sslcert + , sslkey = ov sslkey + , compression = ov compression + , verbose = ov verbose + , errorHandler = ov errorHandler + , defaultTimeout = ov defaultTimeout + , other = ov other + , backend = ov backend + , proxyType = ov proxyType } where - ov f x y = getLast $! (mappend `on` (Last . f)) x y + ov f = getLast $! (mappend `on` (Last . f)) a b ------------------------------------------------------------------------------ @@ -459,37 +462,45 @@ $ "don't have an error log" , Option ['c'] ["compression"] (NoArg $ Just $ setConfig setCompression True) - $ "use gzip compression on responses" + $ "use gzip compression on responses" ++ + defaultB getCompression "compressed" "uncompressed" , Option ['t'] ["timeout"] (ReqArg (\t -> Just $ mempty { defaultTimeout = Just $ read t }) "SECS") - $ "set default timeout in seconds" + $ "set default timeout in seconds" ++ defaultC defaultTimeout , Option [] ["no-compression"] (NoArg $ Just $ setConfig setCompression False) - $ "serve responses uncompressed" + $ "serve responses uncompressed" ++ + defaultB compression "compressed" "uncompressed" , Option ['v'] ["verbose"] (NoArg $ Just $ setConfig setVerbose True) - $ "print server status updates to stderr" + $ "print server status updates to stderr" ++ + defaultC getVerbose , Option ['q'] ["quiet"] (NoArg $ Just $ setConfig setVerbose False) - $ "do not print anything to stderr" + $ "do not print anything to stderr" ++ + defaultB getVerbose "verbose" "quiet" , Option [] ["proxy"] (ReqArg (\t -> Just $ setConfig setProxyType $ read t) "X_Forwarded_For") $ concat [ "Set --proxy=X_Forwarded_For if your snap application " , "is behind an HTTP reverse proxy to ensure that " - , "rqRemoteAddr is set properly."] + , "rqRemoteAddr is set properly." + , defaultC getProxyType ] , 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 + setConfig f c = f c mempty + conf = defaultConfig `mappend` defaults + defaultB f y n = maybe "" (\b -> ", default " ++ if b + then y + else n) $ f conf + defaultC f = maybe "" ((", default " ++) . show) $ f conf + defaultO f = maybe ", default off" ((", default " ++) . show) $ f conf ------------------------------------------------------------------------------ @@ -520,28 +531,56 @@ ------------------------------------------------------------------------------ --- | Returns a 'Config' obtained from parsing the options specified on the --- command-line. +-- | Returns a 'Config' obtained from parsing command-line options, using the +-- default Snap 'OptDescr' set. -- -- On Unix systems, the locale is read from the @LANG@ environment variable. commandLineConfig :: MonadSnap m => Config m a - -- ^ default configuration. This is combined with - -- 'defaultConfig' to obtain default values to use if the - -- given parameter is specified on the command line. Usually - -- it is fine to use 'emptyConfig' here. + -- ^ default configuration. This is combined with + -- 'defaultConfig' to obtain default values to use if the + -- given parameter is specified on the command line. + -- Usually it is fine to use 'emptyConfig' here. -> IO (Config m a) -commandLineConfig defaults = do +commandLineConfig defaults = extendedCommandLineConfig (optDescrs defaults) f defaults + where + -- Here getOpt can ever change the "other" field, because we only use the + -- Snap OptDescr list. The combining function will never be invoked. + f = undefined + + +------------------------------------------------------------------------------ +-- | Returns a 'Config' obtained from parsing command-line options, using the +-- default Snap 'OptDescr' set as well as a list of user OptDescrs. User +-- OptDescrs use the \"other\" field (accessible using 'getOther' and +-- 'setOther') to store additional command-line option state. These are +-- combined using a user-defined combining function. +-- +-- On Unix systems, the locale is read from the @LANG@ environment variable. + +extendedCommandLineConfig :: MonadSnap m + => [OptDescr (Maybe (Config m a))] + -- ^ User options. + -> (a -> a -> a) + -- ^ State for multiple invoked user command-line + -- options will be combined using this function. + -> Config m a + -- ^ default configuration. This is combined with + -- Snap's 'defaultConfig' to obtain default values + -- to use if the given parameter is specified on + -- the command line. Usually it is fine to use + -- 'emptyConfig' here. + -> IO (Config m a) +extendedCommandLineConfig opts combiningFunction defaults = do args <- getArgs prog <- getProgName - let opts = optDescrs defaults - - result <- either (usage prog opts) + result <- either (usage prog) return (case getOpt Permute opts args of (f, _, [] ) -> maybe (Left []) Right $ - fmap mconcat $ sequence f + fmap (foldl' combine mempty) $ + sequence f (_, _, errs) -> Left errs) #ifndef PORTABLE @@ -554,7 +593,7 @@ #endif where - usage prog opts errs = do + usage prog errs = do let hdr = "Usage:\n " ++ prog ++ " [OPTION...]\n\nOptions:" let msg = concat errs ++ usageInfo hdr opts hPutStrLn stderr msg @@ -562,3 +601,25 @@ #ifndef PORTABLE upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c #endif + + combine !a !b = a `mappend` b `mappend` newOther + where + -- combined is only a Just if both a and b have other fields, and then + -- we use the combining function. Config's mappend picks the last + -- "Just" in the other list. + combined = do + x <- getOther a + y <- getOther b + return $! combiningFunction x y + + newOther = mempty { other = combined } + +fmapArg :: (a -> b) -> ArgDescr a -> ArgDescr b +fmapArg f (NoArg a) = NoArg (f a) +fmapArg f (ReqArg g s) = ReqArg (f . g) s +fmapArg f (OptArg g s) = OptArg (f . g) s + +fmapOpt :: (a -> b) -> OptDescr a -> OptDescr b +fmapOpt f (Option s l d e) = Option s l (fmapArg f d) e + + diff --git a/test/pongserver/Main.hs b/test/pongserver/Main.hs --- a/test/pongserver/Main.hs +++ b/test/pongserver/Main.hs @@ -19,16 +19,18 @@ main :: IO () main = do - m <- newEmptyMVar - - forkIO $ go m + m <- newEmptyMVar + config <- commandLineConfig defaults + forkIO $ go m config takeMVar m - return () where - go m = httpServe config pongServer `finally` putMVar m () - config = setPort 8000 $ - setErrorLog ConfigNoLog $ - setAccessLog ConfigNoLog $ - setCompression False $ emptyConfig + defaults = setPort 8000 $ + setErrorLog ConfigNoLog $ + setAccessLog ConfigNoLog $ + setCompression False $ + setVerbose False $ + emptyConfig + + go m config = httpServe config pongServer `finally` putMVar m () diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -37,7 +37,7 @@ directory-tree, enumerator >= 0.4.15 && <0.5, filepath, - http-enumerator >= 0.7.1.6 && <0.8, + http-enumerator >= 0.7.3 && <0.8, HUnit >= 1.2 && <2, mtl >= 2 && <3, murmur-hash >= 0.1 && <0.2, @@ -45,14 +45,15 @@ old-locale, parallel >= 2 && <4, process, - snap-core >= 0.8 && <0.9, + snap-core >= 0.8.1 && <0.9, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, test-framework-quickcheck2 >= 0.2.12.1 && <0.3, text >= 0.11 && <0.12, time, - tls >= 0.8.2 && <0.10, + tls >= 0.8.2 && <0.9.2, + tls-extra >= 0.4 && <= 0.4.4, transformers, vector >= 0.7 && <0.10, vector-algorithms >= 0.4 && <0.6, @@ -117,9 +118,9 @@ murmur-hash >= 0.1 && <0.2, old-locale, parallel >= 2 && <4, - MonadCatchIO-transformers >= 0.2.1 && <0.3, + MonadCatchIO-transformers >= 0.2.1 && <0.4, network == 2.3.*, - snap-core >= 0.8 && <0.9, + snap-core >= 0.8.1 && <0.9, template-haskell, time, transformers, @@ -189,13 +190,13 @@ enumerator >= 0.4.15 && <0.5, filepath, HUnit >= 1.2 && <2, - MonadCatchIO-transformers >= 0.2.1 && <0.3, + MonadCatchIO-transformers >= 0.2.1 && <0.4, mtl >= 2 && <3, murmur-hash >= 0.1 && <0.2, network == 2.3.*, old-locale, parallel >= 2 && <4, - snap-core >= 0.8 && <0.9, + snap-core >= 0.8.1 && <0.9, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, @@ -240,5 +241,5 @@ base >= 4 && < 5, network == 2.3.*, http-enumerator >= 0.7.1.6 && <0.8, - tls >= 0.8.2 && <0.10, + tls >= 0.8.2 && <= 0.9.2, criterion >= 0.6 && <0.7