snap-server 0.8.0.1 → 0.8.1
raw patch · 4 files changed
+130/−66 lines, 4 filesdep ~MonadCatchIO-transformersdep ~snap-coredep ~transformersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: MonadCatchIO-transformers, snap-core, transformers
API changes (from Hackage documentation)
+ Snap.Http.Server.Config: extendedCommandLineConfig :: MonadSnap m => [OptDescr (Maybe (Config m a))] -> (a -> a -> a) -> Config m a -> IO (Config m a)
+ Snap.Http.Server.Config: fmapOpt :: (a -> b) -> OptDescr a -> OptDescr b
Files
- snap-server.cabal +4/−4
- src/Snap/Http/Server/Config.hs +106/−45
- test/pongserver/Main.hs +11/−9
- test/snap-server-testsuite.cabal +9/−8
snap-server.cabal view
@@ -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,
src/Snap/Http/Server/Config.hs view
@@ -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++
test/pongserver/Main.hs view
@@ -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 ()
test/snap-server-testsuite.cabal view
@@ -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