snap-server 0.8.1.1 → 0.9.0
raw patch · 15 files changed
+732/−1496 lines, 15 filesdep −PSQueuedep −hlibevdep ~containersdep ~snap-core
Dependencies removed: PSQueue, hlibev
Dependency ranges changed: containers, snap-core
Files
- README.SNAP.md +1/−2
- README.md +2/−13
- snap-server.cabal +6/−15
- src/Snap/Http/Server.hs +23/−14
- src/Snap/Http/Server/Config.hs +6/−570
- src/Snap/Internal/Http/Parser.hs +2/−2
- src/Snap/Internal/Http/Server.hs +9/−31
- src/Snap/Internal/Http/Server/Backend.hs +1/−0
- src/Snap/Internal/Http/Server/Config.hs +616/−0
- src/Snap/Internal/Http/Server/LibevBackend.hs +0/−760
- src/Snap/Internal/Http/Server/SimpleBackend.hs +2/−1
- test/snap-server-testsuite.cabal +7/−23
- test/suite/Snap/Internal/Http/Server/Tests.hs +12/−9
- test/suite/Test/Blackbox.hs +33/−34
- test/suite/TestSuite.hs +12/−22
README.SNAP.md view
@@ -11,8 +11,7 @@ The Snap core system consists of: - * a high-speed HTTP server, with an optional high-concurrency backend using- the [libev](http://software.schmorp.de/pkg/libev.html) library+ * a high-speed HTTP server * a sensible and clean monad for web programming
README.md view
@@ -31,10 +31,6 @@ ### Optional dependencies -The `snap-server` library can optionally use the-[libev](http://software.schmorp.de/pkg/libev.html) for high-speed, O(1)-scalable socket event processing.- If you would like SSL support, `snap-server` requires the [openssl](http://www.openssl.org/) library. @@ -46,19 +42,13 @@ cabal install -to get the "stock" version of Snap. If you would like to try the optional-`libev` backend, pass the `libev` flag to `cabal install`:-- cabal install -flibev+to install snap-server. -And if you would like SSL support, pass the `openssl` flag to `cabal install`:+If you would like SSL support, pass the `openssl` flag to `cabal install`: cabal install -fopenssl -Note that the "`-flibev`" and "`-fopenssl`" flags are not mutually-exclusive,-and if you would like you can use them together. - ## Building the Haddock Documentation The haddock documentation can be built using the supplied `haddock.sh` shell@@ -75,7 +65,6 @@ `cd` into the `test/` directory and run $ cabal configure # for the stock backend, or..- $ cabal configure -flibev # for the libev backend, and/or.. $ cabal configure -fopenssl # for the SSL backend $ cabal build
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.8.1.1+version: 0.9.0 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@@ -52,10 +52,6 @@ test/testserver/static/hello.txt -Flag libev- Description: Use libev?- Default: False- Flag portable Description: Compile in cross-platform mode. No platform-specific code or optimizations such as C routines will be used.@@ -82,12 +78,12 @@ Snap.Internal.Http.Server.Address, Snap.Internal.Http.Server.Date, Snap.Internal.Http.Server.Backend,+ Snap.Internal.Http.Server.Config, Snap.Internal.Http.Server.ListenHelpers, Snap.Internal.Http.Server.HttpPort, Snap.Internal.Http.Server.SimpleBackend, Snap.Internal.Http.Server.TimeoutManager,- Snap.Internal.Http.Server.TLS,- Snap.Internal.Http.Server.LibevBackend+ Snap.Internal.Http.Server.TLS build-depends: array >= 0.2 && <0.5,@@ -100,7 +96,7 @@ bytestring >= 0.9.1 && < 0.10, bytestring-nums, case-insensitive >= 0.3 && < 0.5,- containers >= 0.3 && < 0.5,+ containers >= 0.3 && < 0.6, directory-tree >= 0.10 && < 0.11, enumerator >= 0.4.15 && < 0.5, filepath >= 1.1 && < 1.4,@@ -109,15 +105,14 @@ murmur-hash >= 0.1 && < 0.2, network >= 2.3 && < 2.4, old-locale,- snap-core >= 0.8.1 && < 0.9,+ snap-core >= 0.9 && < 0.10, template-haskell >= 2.2 && < 2.8, text >= 0.11 && < 0.12, time >= 1.0 && < 1.5, transformers >= 0.2 && < 0.4, unix-compat >= 0.2 && < 0.4, vector >= 0.7 && < 0.10,- vector-algorithms >= 0.4 && < 0.6,- PSQueue >= 1.1 && < 1.2+ vector-algorithms >= 0.4 && < 0.6 extensions: BangPatterns,@@ -137,10 +132,6 @@ cpp-options: -DPORTABLE else build-depends: unix-- if flag(libev)- build-depends: hlibev >= 0.2.8 && < 0.5- cpp-options: -DLIBEV if flag(openssl) cpp-options: -DOPENSSL
src/Snap/Http/Server.hs view
@@ -29,6 +29,9 @@ import Prelude hiding (catch) import Snap.Http.Server.Config import qualified Snap.Internal.Http.Server as Int+import Snap.Internal.Http.Server.Config (emptyStartupInfo,+ setStartupSockets,+ setStartupConfig) import Snap.Core import Snap.Util.GZip import Snap.Util.Proxy@@ -61,27 +64,39 @@ go conf `finally` output "\nShutting down..." where+ -------------------------------------------------------------------------- go conf = do let tout = fromMaybe 60 $ getDefaultTimeout conf setUnicodeLocale $ fromJust $ getLocale conf withLoggers (fromJust $ getAccessLog conf)- (fromJust $ getErrorLog conf) $- \(alog, elog) -> Int.httpServe tout- (listeners conf)- (fmap backendToInternal $ getBackend conf)- (fromJust $ getHostname conf)- alog- elog- (runSnap handler)+ (fromJust $ getErrorLog conf) $ \(alog, elog) ->+ Int.httpServe tout+ (listeners conf)+ (fromJust $ getHostname conf)+ alog+ elog+ (\sockets -> let dat = mkStartupInfo sockets conf+ in maybe (return ())+ ($ dat)+ (getStartupHook conf))+ (runSnap handler) + --------------------------------------------------------------------------+ mkStartupInfo sockets conf =+ setStartupSockets sockets $+ setStartupConfig conf emptyStartupInfo++ -------------------------------------------------------------------------- maybeSpawnLogger f (ConfigFileLog fp) = liftM Just $ newLoggerWithCustomErrorFunction f fp maybeSpawnLogger _ _ = return Nothing + -------------------------------------------------------------------------- maybeIoLog (ConfigIoLog a) = Just a maybeIoLog _ = Nothing + -------------------------------------------------------------------------- withLoggers afp efp act = bracket (do mvar <- newMVar () let f s = withMVar mvar@@ -177,9 +192,3 @@ #else const $ return () #endif----------------------------------------------------------------------------------backendToInternal :: ConfigBackend -> Int.EventLoopType-backendToInternal ConfigSimpleBackend = Int.EventLoopSimple-backendToInternal ConfigLibEvBackend = Int.EventLoopLibEv
src/Snap/Http/Server/Config.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}- {-| This module exports the 'Config' datatype, which you can use to configure the@@ -12,7 +7,6 @@ module Snap.Http.Server.Config ( Config- , ConfigBackend(..) , ConfigLog(..) , emptyConfig@@ -25,7 +19,6 @@ , fmapOpt , getAccessLog- , getBackend , getBind , getCompression , getDefaultTimeout@@ -41,9 +34,9 @@ , getSSLKey , getSSLPort , getVerbose+ , getStartupHook , setAccessLog- , setBackend , setBind , setCompression , setDefaultTimeout@@ -59,567 +52,10 @@ , setSSLKey , setSSLPort , setVerbose+ , setStartupHook+ , StartupInfo+ , getStartupSockets+ , getStartupConfig ) where --------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char8-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.Maybe-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Typeable-import Prelude hiding (catch)-import Snap.Core-import Snap.Iteratee ((>==>), enumBuilder)-import Snap.Internal.Debug (debug)-import Snap.Util.Proxy-import System.Console.GetOpt-import System.Environment hiding (getEnv)-#ifndef PORTABLE-import System.Posix.Env-#endif-import System.Exit-import System.IO--------------------------------------------------------------------------------import Snap.Internal.Http.Server (requestErrorMessage)------------------------------------------------------------------------------------ | This datatype allows you to override which backend (either simple or--- libev) to use. Most users will not want to set this, preferring to rely on--- the compile-type default.------ Note that if you specify the libev backend and have not compiled in support--- for it, your server will fail at runtime.-data ConfigBackend = ConfigSimpleBackend- | ConfigLibEvBackend- deriving (Show, Eq)----------------------------------------------------------------------------------- | Data type representing the configuration of a logging target-data ConfigLog = ConfigNoLog -- ^ no logging- | ConfigFileLog FilePath -- ^ log to text file- | ConfigIoLog (ByteString -> IO ()) -- ^ log custom IO handler--instance Show ConfigLog where- 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')--- 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 a = Config- { hostname :: Maybe ByteString- , accessLog :: Maybe ConfigLog- , errorLog :: Maybe ConfigLog- , 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- , other :: Maybe a- , backend :: Maybe ConfigBackend- , proxyType :: Maybe ProxyType- }--instance Show (Config m a) where- show c = unlines [ "Config:"- , "hostname: " ++ _hostname- , "accessLog: " ++ _accessLog- , "errorLog: " ++ _errorLog- , "locale: " ++ _locale- , "port: " ++ _port- , "bind: " ++ _bind- , "sslport: " ++ _sslport- , "sslbind: " ++ _sslbind- , "sslcert: " ++ _sslcert- , "sslkey: " ++ _sslkey- , "compression: " ++ _compression- , "verbose: " ++ _verbose- , "defaultTimeout: " ++ _defaultTimeout- , "backend: " ++ _backend- , "proxyType: " ++ _proxyType- ]-- where- _hostname = show $ hostname c- _accessLog = show $ accessLog c- _errorLog = show $ errorLog c- _locale = show $ locale c- _port = show $ port c- _bind = show $ bind c- _sslport = show $ sslport c- _sslbind = show $ sslbind c- _sslcert = show $ sslcert c- _sslkey = show $ sslkey c- _compression = show $ compression c- _verbose = show $ verbose c- _defaultTimeout = show $ defaultTimeout c- _backend = show $ backend c- _proxyType = show $ proxyType c------------------------------------------------------------------------------------ | Returns a completely empty 'Config'. Equivalent to 'mempty' from--- 'Config''s 'Monoid' instance.-emptyConfig :: Config m a-emptyConfig = mempty----------------------------------------------------------------------------------instance Monoid (Config m a) 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- , other = Nothing- , backend = Nothing- , proxyType = Nothing- }-- a `mappend` b = Config- { 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 = getLast $! (mappend `on` (Last . f)) a b------------------------------------------------------------------------------------ | The 'Typeable1' instance is here so 'Config' values can be--- dynamically loaded with Hint.-configTyCon :: TyCon-configTyCon = mkTyCon "Snap.Http.Server.Config.Config"-{-# NOINLINE configTyCon #-}--instance (Typeable1 m) => Typeable1 (Config m) where- typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())]------------------------------------------------------------------------------------ | These are the default values for the options-defaultConfig :: MonadSnap m => Config m a-defaultConfig = mempty- { hostname = Just "localhost"- , accessLog = Just $ ConfigFileLog "log/access.log"- , errorLog = Just $ ConfigFileLog "log/error.log"- , locale = Just "en_US"- , compression = Just True- , verbose = Just True- , errorHandler = Just defaultErrorHandler- , bind = Just "0.0.0.0"- , sslbind = Just "0.0.0.0"- , sslcert = Just "cert.pem"- , sslkey = Just "key.pem"- , defaultTimeout = Just 60- }------------------------------------------------------------------------------------ | The hostname of the HTTP server. This field has the same format as an HTTP--- @Host@ header; if a @Host@ header came in with the request, we use that,--- otherwise we default to this value specified in the configuration.-getHostname :: Config m a -> Maybe ByteString-getHostname = hostname---- | Path to the access log-getAccessLog :: Config m a -> Maybe ConfigLog-getAccessLog = accessLog---- | Path to the error log-getErrorLog :: Config m a -> Maybe ConfigLog-getErrorLog = errorLog---- | Gets the locale to use. Locales are used on Unix only, to set the--- @LANG@\/@LC_ALL@\/etc. environment variable. For instance if you set the--- locale to \"@en_US@\", we'll set the relevant environment variables to--- \"@en_US.UTF-8@\".-getLocale :: Config m a -> Maybe String-getLocale = locale---- | Returns the port to listen on (for http)-getPort :: Config m a -> Maybe Int-getPort = port---- | Returns the address to bind to (for http)-getBind :: Config m a -> Maybe ByteString-getBind = bind---- | Returns the port to listen on (for https)-getSSLPort :: Config m a -> Maybe Int-getSSLPort = sslport---- | Returns the address to bind to (for https)-getSSLBind :: Config m a -> Maybe ByteString-getSSLBind = sslbind---- | Path to the SSL certificate file-getSSLCert :: Config m a -> Maybe FilePath-getSSLCert = sslcert---- | Path to the SSL key file-getSSLKey :: Config m a -> Maybe FilePath-getSSLKey = sslkey---- | If set and set to True, compression is turned on when applicable-getCompression :: Config m a -> Maybe Bool-getCompression = compression---- | Whether to write server status updates to stderr-getVerbose :: Config m a -> Maybe Bool-getVerbose = verbose---- | A MonadSnap action to handle 500 errors-getErrorHandler :: Config m a -> Maybe (SomeException -> m ())-getErrorHandler = errorHandler--getDefaultTimeout :: Config m a -> Maybe Int-getDefaultTimeout = defaultTimeout--getOther :: Config m a -> Maybe a-getOther = other--getBackend :: Config m a -> Maybe ConfigBackend-getBackend = backend--getProxyType :: Config m a -> Maybe ProxyType-getProxyType = proxyType----------------------------------------------------------------------------------setHostname :: ByteString -> Config m a -> Config m a-setHostname x c = c { hostname = Just x }--setAccessLog :: ConfigLog -> Config m a -> Config m a-setAccessLog x c = c { accessLog = Just x }--setErrorLog :: ConfigLog -> Config m a -> Config m a-setErrorLog x c = c { errorLog = Just x }--setLocale :: String -> Config m a -> Config m a-setLocale x c = c { locale = Just x }--setPort :: Int -> Config m a -> Config m a-setPort x c = c { port = Just x }--setBind :: ByteString -> Config m a -> Config m a-setBind x c = c { bind = Just x }--setSSLPort :: Int -> Config m a -> Config m a-setSSLPort x c = c { sslport = Just x }--setSSLBind :: ByteString -> Config m a -> Config m a-setSSLBind x c = c { sslbind = Just x }--setSSLCert :: FilePath -> Config m a -> Config m a-setSSLCert x c = c { sslcert = Just x }--setSSLKey :: FilePath -> Config m a -> Config m a-setSSLKey x c = c { sslkey = Just x }--setCompression :: Bool -> Config m a -> Config m a-setCompression x c = c { compression = Just x }--setVerbose :: Bool -> Config m a -> Config m a-setVerbose x c = c { verbose = Just x }--setErrorHandler :: (SomeException -> m ()) -> Config m a -> Config m a-setErrorHandler x c = c { errorHandler = Just x }--setDefaultTimeout :: Int -> Config m a -> Config m a-setDefaultTimeout x c = c { defaultTimeout = Just x }--setOther :: a -> Config m a -> Config m a-setOther x c = c { other = Just x }--setBackend :: ConfigBackend -> Config m a -> Config m a-setBackend x c = c { backend = Just x }--setProxyType :: ProxyType -> Config m a -> Config m a-setProxyType x c = c { proxyType = Just x }----------------------------------------------------------------------------------completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a)-completeConfig config = do- when noPort $ hPutStrLn stderr- "no port specified, defaulting to port 8000"-- return $! cfg `mappend` cfg'-- where- cfg = defaultConfig `mappend` config-- sslVals = map ($ cfg) [ isJust . getSSLPort- , isJust . getSSLBind- , isJust . getSSLKey- , isJust . getSSLCert ]-- sslValid = and sslVals- noPort = isNothing (getPort cfg) && not sslValid-- cfg' = emptyConfig { port = if noPort then Just 8000 else Nothing }----------------------------------------------------------------------------------bsFromString :: String -> ByteString-bsFromString = T.encodeUtf8 . T.pack----------------------------------------------------------------------------------toString :: ByteString -> String-toString = T.unpack . T.decodeUtf8------------------------------------------------------------------------------------ | Returns a description of the snap command line options suitable for use--- with "System.Console.GetOpt".-optDescrs :: MonadSnap m =>- Config m a -- ^ the configuration defaults.- -> [OptDescr (Maybe (Config m a))]-optDescrs defaults =- [ Option [] ["hostname"]- (ReqArg (Just . setConfig setHostname . bsFromString) "NAME")- $ "local hostname" ++ defaultC getHostname- , Option ['b'] ["address"]- (ReqArg (\s -> Just $ mempty { bind = Just $ bsFromString 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 $ bsFromString 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 . ConfigFileLog) "PATH")- $ "access log" ++ (defaultC $ getAccessLog)- , Option [] ["error-log"]- (ReqArg (Just . setConfig setErrorLog . ConfigFileLog) "PATH")- $ "error log" ++ (defaultC $ getErrorLog)- , Option [] ["no-access-log"]- (NoArg $ Just $ setConfig setAccessLog ConfigNoLog)- $ "don't have an access log"- , Option [] ["no-error-log"]- (NoArg $ Just $ setConfig setErrorLog ConfigNoLog)- $ "don't have an error log"- , Option ['c'] ["compression"]- (NoArg $ Just $ setConfig setCompression True)- $ "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" ++ defaultC defaultTimeout- , Option [] ["no-compression"]- (NoArg $ Just $ setConfig setCompression False)- $ "serve responses uncompressed" ++- defaultB compression "compressed" "uncompressed"- , Option ['v'] ["verbose"]- (NoArg $ Just $ setConfig setVerbose True)- $ "print server status updates to stderr" ++- defaultC getVerbose- , Option ['q'] ["quiet"]- (NoArg $ Just $ setConfig setVerbose False)- $ "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."- , defaultC getProxyType ]- , Option ['h'] ["help"]- (NoArg Nothing)- $ "display this help and exit"- ]-- where- 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----------------------------------------------------------------------------------defaultErrorHandler :: MonadSnap m => SomeException -> m ()-defaultErrorHandler e = do- debug "Snap.Http.Server.Config errorHandler:"- req <- getRequest- let sm = smsg req- debug $ toString sm- logError sm-- finishWith $ setContentType "text/plain; charset=utf-8"- . setContentLength (fromIntegral $ B.length msg)- . setResponseStatus 500 "Internal Server Error"- . modifyResponseBody- (>==> enumBuilder (fromByteString msg))- $ emptyResponse-- where- smsg req = toByteString $ requestErrorMessage req e-- msg = toByteString msgB- msgB = mconcat [- fromByteString "A web handler threw an exception. Details:\n"- , fromShow e- ]------------------------------------------------------------------------------------- | 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.- -> IO (Config m a)-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-- result <- either (usage prog)- return- (case getOpt Permute opts args of- (f, _, [] ) -> maybe (Left []) Right $- fmap (foldl' combine mempty) $- sequence f- (_, _, errs) -> Left errs)--#ifndef PORTABLE- lang <- getEnv "LANG"- completeConfig $ mconcat [defaults,- mempty {locale = fmap upToUtf8 lang},- result]-#else- completeConfig $ mconcat [defaults, result]-#endif-- where- 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-- 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--+import Snap.Internal.Http.Server.Config
src/Snap/Internal/Http/Parser.hs view
@@ -171,8 +171,8 @@ methodFromString "TRACE" = return TRACE methodFromString "OPTIONS" = return OPTIONS methodFromString "CONNECT" = return CONNECT-methodFromString s =- throwError $ HttpParseException $ "Bad method '" ++ S.unpack s ++ "'"+methodFromString "PATCH" = return PATCH+methodFromString s = return $ Method s ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server.hs view
@@ -40,7 +40,7 @@ import Data.Typeable import Data.Version import GHC.Conc-import Network.Socket (withSocketsDo)+import Network.Socket (withSocketsDo, Socket) import Prelude hiding (catch) import System.PosixCompat.Files hiding (setFileSize) import System.Posix.Types (FileOffset)@@ -57,7 +57,6 @@ import Snap.Internal.Http.Server.HttpPort import qualified Snap.Internal.Http.Server.TLS as TLS import Snap.Internal.Http.Server.SimpleBackend-import Snap.Internal.Http.Server.LibevBackend import Snap.Internal.Iteratee.Debug import Snap.Iteratee hiding (head, take, map)@@ -104,12 +103,6 @@ -------------------------------------------------------------------------------data EventLoopType = EventLoopSimple- | EventLoopLibEv- deriving (Show)--------------------------------------------------------------------------------- -- This exception will be thrown if we decided to terminate the request before -- running the user handler. data TerminatedBeforeHandlerException = TerminatedBeforeHandlerException@@ -124,15 +117,6 @@ -------------------------------------------------------------------------------defaultEvType :: EventLoopType-#ifdef LIBEV-defaultEvType = EventLoopLibEv-#else-defaultEvType = EventLoopSimple-#endif--------------------------------------------------------------------------------- data ServerState = ServerState { _forceConnectionClose :: Bool , _localHostname :: ByteString@@ -161,23 +145,21 @@ ------------------------------------------------------------------------------ httpServe :: Int -- ^ default timeout -> [ListenPort] -- ^ ports to listen on- -> Maybe EventLoopType -- ^ Specify a given event loop,- -- otherwise a default is picked -> ByteString -- ^ local hostname (server name) -> Maybe (ByteString -> IO ()) -- ^ access log action -> Maybe (ByteString -> IO ()) -- ^ error log action+ -> ([Socket] -> IO ()) -- ^ initialisation -> ServerHandler -- ^ handler procedure -> IO ()-httpServe defaultTimeout ports mevType localHostname alog' elog'- handler = withSocketsDo $ spawnAll alog' elog'+httpServe defaultTimeout ports localHostname alog' elog' initial handler =+ withSocketsDo $ spawnAll alog' elog'+ where -------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do - let evType = maybe defaultEvType id mevType-- logE elog $ S.concat [ "Server.httpServe: START ("- , toBS $ show evType, ")"]+ logE elog $ S.concat [ "Server.httpServe: START, binding to "+ , bshow ports ] let isHttps p = case p of { (HttpsPort _ _ _ _) -> True; _ -> False;} let initHttps = foldr (\p b -> b || isHttps p) False ports@@ -187,8 +169,9 @@ else return () nports <- mapM bindPort ports+ let socks = map (\x -> case x of ListenHttp s -> s; ListenHttps s _ -> s) nports - (runEventLoop evType defaultTimeout nports numCapabilities (logE elog)+ (simpleEventLoop defaultTimeout nports numCapabilities (logE elog) (initial socks) $ runHTTP defaultTimeout alog elog handler localHostname) `finally` do logE elog "Server.httpServe: SHUTDOWN"@@ -203,11 +186,6 @@ bindPort (HttpPort baddr port ) = bindHttp baddr port bindPort (HttpsPort baddr port cert key) = TLS.bindHttps baddr port cert key--- --------------------------------------------------------------------------- runEventLoop EventLoopSimple = simpleEventLoop- runEventLoop EventLoopLibEv = libEvEventLoop ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/Backend.hs view
@@ -51,6 +51,7 @@ -> [ListenSocket] -- ^ list of ports -> Int -- ^ number of capabilities -> (ByteString -> IO ()) -- ^ error log+ -> IO () -- ^ initialisation function -> SessionHandler -- ^ session handler -> IO ()
+ src/Snap/Internal/Http/Server/Config.hs view
@@ -0,0 +1,616 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|++This module exports the 'Config' datatype, which you can use to configure the+Snap HTTP server.++-}++module Snap.Internal.Http.Server.Config where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+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.Maybe+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Typeable+import Network(Socket)+import Prelude hiding (catch)+import Snap.Core+import Snap.Iteratee ((>==>), enumBuilder)+import Snap.Internal.Debug (debug)+import Snap.Util.Proxy+import System.Console.GetOpt+import System.Environment hiding (getEnv)+#ifndef PORTABLE+import System.Posix.Env+#endif+import System.Exit+import System.IO+------------------------------------------------------------------------------+import Snap.Internal.Http.Server (requestErrorMessage)+++------------------------------------------------------------------------------+-- | This datatype allows you to override which backend (either simple or+-- libev) to use. Most users will not want to set this, preferring to rely on+-- the compile-type default.+--+-- Note that if you specify the libev backend and have not compiled in support+-- for it, your server will fail at runtime.+data ConfigBackend = ConfigSimpleBackend+ | ConfigLibEvBackend+ deriving (Show, Eq)++------------------------------------------------------------------------------+-- | Data type representing the configuration of a logging target+data ConfigLog = ConfigNoLog -- ^ no logging+ | ConfigFileLog FilePath -- ^ log to text file+ | ConfigIoLog (ByteString -> IO ()) -- ^ log custom IO handler++instance Show ConfigLog where+ 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')+-- 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 a = Config+ { hostname :: Maybe ByteString+ , accessLog :: Maybe ConfigLog+ , errorLog :: Maybe ConfigLog+ , 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+ , other :: Maybe a+ , backend :: Maybe ConfigBackend+ , proxyType :: Maybe ProxyType+ , startupHook :: Maybe (StartupInfo m a -> IO ())+ }++instance Show (Config m a) where+ show c = unlines [ "Config:"+ , "hostname: " ++ _hostname+ , "accessLog: " ++ _accessLog+ , "errorLog: " ++ _errorLog+ , "locale: " ++ _locale+ , "port: " ++ _port+ , "bind: " ++ _bind+ , "sslport: " ++ _sslport+ , "sslbind: " ++ _sslbind+ , "sslcert: " ++ _sslcert+ , "sslkey: " ++ _sslkey+ , "compression: " ++ _compression+ , "verbose: " ++ _verbose+ , "defaultTimeout: " ++ _defaultTimeout+ , "backend: " ++ _backend+ , "proxyType: " ++ _proxyType+ ]++ where+ _hostname = show $ hostname c+ _accessLog = show $ accessLog c+ _errorLog = show $ errorLog c+ _locale = show $ locale c+ _port = show $ port c+ _bind = show $ bind c+ _sslport = show $ sslport c+ _sslbind = show $ sslbind c+ _sslcert = show $ sslcert c+ _sslkey = show $ sslkey c+ _compression = show $ compression c+ _verbose = show $ verbose c+ _defaultTimeout = show $ defaultTimeout c+ _backend = show $ backend c+ _proxyType = show $ proxyType c+++------------------------------------------------------------------------------+-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from+-- 'Config''s 'Monoid' instance.+emptyConfig :: Config m a+emptyConfig = mempty+++------------------------------------------------------------------------------+instance Monoid (Config m a) 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+ , other = Nothing+ , backend = Nothing+ , proxyType = Nothing+ , startupHook = Nothing+ }++ a `mappend` b = Config+ { 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+ , startupHook = ov startupHook+ }+ where+ ov f = getLast $! (mappend `on` (Last . f)) a b+++------------------------------------------------------------------------------+-- | The 'Typeable1' instance is here so 'Config' values can be+-- dynamically loaded with Hint.+configTyCon :: TyCon+configTyCon = mkTyCon "Snap.Http.Server.Config.Config"+{-# NOINLINE configTyCon #-}++instance (Typeable1 m) => Typeable1 (Config m) where+ typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())]+++------------------------------------------------------------------------------+-- | These are the default values for the options+defaultConfig :: MonadSnap m => Config m a+defaultConfig = mempty+ { hostname = Just "localhost"+ , accessLog = Just $ ConfigFileLog "log/access.log"+ , errorLog = Just $ ConfigFileLog "log/error.log"+ , locale = Just "en_US"+ , compression = Just True+ , verbose = Just True+ , errorHandler = Just defaultErrorHandler+ , bind = Just "0.0.0.0"+ , sslbind = Just "0.0.0.0"+ , sslcert = Just "cert.pem"+ , sslkey = Just "key.pem"+ , defaultTimeout = Just 60+ }+++------------------------------------------------------------------------------+-- | The hostname of the HTTP server. This field has the same format as an HTTP+-- @Host@ header; if a @Host@ header came in with the request, we use that,+-- otherwise we default to this value specified in the configuration.+getHostname :: Config m a -> Maybe ByteString+getHostname = hostname++-- | Path to the access log+getAccessLog :: Config m a -> Maybe ConfigLog+getAccessLog = accessLog++-- | Path to the error log+getErrorLog :: Config m a -> Maybe ConfigLog+getErrorLog = errorLog++-- | Gets the locale to use. Locales are used on Unix only, to set the+-- @LANG@\/@LC_ALL@\/etc. environment variable. For instance if you set the+-- locale to \"@en_US@\", we'll set the relevant environment variables to+-- \"@en_US.UTF-8@\".+getLocale :: Config m a -> Maybe String+getLocale = locale++-- | Returns the port to listen on (for http)+getPort :: Config m a -> Maybe Int+getPort = port++-- | Returns the address to bind to (for http)+getBind :: Config m a -> Maybe ByteString+getBind = bind++-- | Returns the port to listen on (for https)+getSSLPort :: Config m a -> Maybe Int+getSSLPort = sslport++-- | Returns the address to bind to (for https)+getSSLBind :: Config m a -> Maybe ByteString+getSSLBind = sslbind++-- | Path to the SSL certificate file+getSSLCert :: Config m a -> Maybe FilePath+getSSLCert = sslcert++-- | Path to the SSL key file+getSSLKey :: Config m a -> Maybe FilePath+getSSLKey = sslkey++-- | If set and set to True, compression is turned on when applicable+getCompression :: Config m a -> Maybe Bool+getCompression = compression++-- | Whether to write server status updates to stderr+getVerbose :: Config m a -> Maybe Bool+getVerbose = verbose++-- | A MonadSnap action to handle 500 errors+getErrorHandler :: Config m a -> Maybe (SomeException -> m ())+getErrorHandler = errorHandler++getDefaultTimeout :: Config m a -> Maybe Int+getDefaultTimeout = defaultTimeout++getOther :: Config m a -> Maybe a+getOther = other++getBackend :: Config m a -> Maybe ConfigBackend+getBackend = backend++getProxyType :: Config m a -> Maybe ProxyType+getProxyType = proxyType++-- | A startup hook is run after the server initializes but before user request+-- processing begins. The server passes, through a 'StartupInfo' object, the+-- startup hook a list of the sockets it is listening on and the final 'Config'+-- object completed after command-line processing.+getStartupHook :: Config m a -> Maybe (StartupInfo m a -> IO ())+getStartupHook = startupHook+++------------------------------------------------------------------------------+setHostname :: ByteString -> Config m a -> Config m a+setHostname x c = c { hostname = Just x }++setAccessLog :: ConfigLog -> Config m a -> Config m a+setAccessLog x c = c { accessLog = Just x }++setErrorLog :: ConfigLog -> Config m a -> Config m a+setErrorLog x c = c { errorLog = Just x }++setLocale :: String -> Config m a -> Config m a+setLocale x c = c { locale = Just x }++setPort :: Int -> Config m a -> Config m a+setPort x c = c { port = Just x }++setBind :: ByteString -> Config m a -> Config m a+setBind x c = c { bind = Just x }++setSSLPort :: Int -> Config m a -> Config m a+setSSLPort x c = c { sslport = Just x }++setSSLBind :: ByteString -> Config m a -> Config m a+setSSLBind x c = c { sslbind = Just x }++setSSLCert :: FilePath -> Config m a -> Config m a+setSSLCert x c = c { sslcert = Just x }++setSSLKey :: FilePath -> Config m a -> Config m a+setSSLKey x c = c { sslkey = Just x }++setCompression :: Bool -> Config m a -> Config m a+setCompression x c = c { compression = Just x }++setVerbose :: Bool -> Config m a -> Config m a+setVerbose x c = c { verbose = Just x }++setErrorHandler :: (SomeException -> m ()) -> Config m a -> Config m a+setErrorHandler x c = c { errorHandler = Just x }++setDefaultTimeout :: Int -> Config m a -> Config m a+setDefaultTimeout x c = c { defaultTimeout = Just x }++setOther :: a -> Config m a -> Config m a+setOther x c = c { other = Just x }++setBackend :: ConfigBackend -> Config m a -> Config m a+setBackend x c = c { backend = Just x }++setProxyType :: ProxyType -> Config m a -> Config m a+setProxyType x c = c { proxyType = Just x }++setStartupHook :: (StartupInfo m a -> IO ()) -> Config m a -> Config m a+setStartupHook x c = c { startupHook = Just x }+++------------------------------------------------------------------------------++-- | Arguments passed to 'setStartupHook'.+data StartupInfo m a = StartupInfo+ { startupHookConfig :: Config m a+ , startupHookSockets :: [Socket]+ }++emptyStartupInfo :: StartupInfo m a+emptyStartupInfo = StartupInfo emptyConfig []++-- | The the 'Socket's opened by the server. There will be two 'Socket's for SSL connections, and one otherwise.+getStartupSockets :: StartupInfo m a -> [Socket]+getStartupSockets = startupHookSockets++-- The 'Config', after any command line parsing has been performed.+getStartupConfig :: StartupInfo m a -> Config m a+getStartupConfig = startupHookConfig++setStartupSockets :: [Socket] -> StartupInfo m a -> StartupInfo m a+setStartupSockets x c = c { startupHookSockets = x }++setStartupConfig :: Config m a -> StartupInfo m a -> StartupInfo m a+setStartupConfig x c = c { startupHookConfig = x }+++------------------------------------------------------------------------------+completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a)+completeConfig config = do+ when noPort $ hPutStrLn stderr+ "no port specified, defaulting to port 8000"++ return $! cfg `mappend` cfg'++ where+ cfg = defaultConfig `mappend` config++ sslVals = map ($ cfg) [ isJust . getSSLPort+ , isJust . getSSLBind+ , isJust . getSSLKey+ , isJust . getSSLCert ]++ sslValid = and sslVals+ noPort = isNothing (getPort cfg) && not sslValid++ cfg' = emptyConfig { port = if noPort then Just 8000 else Nothing }+++------------------------------------------------------------------------------+bsFromString :: String -> ByteString+bsFromString = T.encodeUtf8 . T.pack+++------------------------------------------------------------------------------+toString :: ByteString -> String+toString = T.unpack . T.decodeUtf8+++------------------------------------------------------------------------------+-- | Returns a description of the snap command line options suitable for use+-- with "System.Console.GetOpt".+optDescrs :: MonadSnap m =>+ Config m a -- ^ the configuration defaults.+ -> [OptDescr (Maybe (Config m a))]+optDescrs defaults =+ [ Option [] ["hostname"]+ (ReqArg (Just . setConfig setHostname . bsFromString) "NAME")+ $ "local hostname" ++ defaultC getHostname+ , Option ['b'] ["address"]+ (ReqArg (\s -> Just $ mempty { bind = Just $ bsFromString 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 $ bsFromString 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 . ConfigFileLog) "PATH")+ $ "access log" ++ (defaultC $ getAccessLog)+ , Option [] ["error-log"]+ (ReqArg (Just . setConfig setErrorLog . ConfigFileLog) "PATH")+ $ "error log" ++ (defaultC $ getErrorLog)+ , Option [] ["no-access-log"]+ (NoArg $ Just $ setConfig setAccessLog ConfigNoLog)+ $ "don't have an access log"+ , Option [] ["no-error-log"]+ (NoArg $ Just $ setConfig setErrorLog ConfigNoLog)+ $ "don't have an error log"+ , Option ['c'] ["compression"]+ (NoArg $ Just $ setConfig setCompression True)+ $ "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" ++ defaultC defaultTimeout+ , Option [] ["no-compression"]+ (NoArg $ Just $ setConfig setCompression False)+ $ "serve responses uncompressed" +++ defaultB compression "compressed" "uncompressed"+ , Option ['v'] ["verbose"]+ (NoArg $ Just $ setConfig setVerbose True)+ $ "print server status updates to stderr" +++ defaultC getVerbose+ , Option ['q'] ["quiet"]+ (NoArg $ Just $ setConfig setVerbose False)+ $ "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."+ , defaultC getProxyType ]+ , Option ['h'] ["help"]+ (NoArg Nothing)+ $ "display this help and exit"+ ]++ where+ 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+++------------------------------------------------------------------------------+defaultErrorHandler :: MonadSnap m => SomeException -> m ()+defaultErrorHandler e = do+ debug "Snap.Http.Server.Config errorHandler:"+ req <- getRequest+ let sm = smsg req+ debug $ toString sm+ logError sm++ finishWith $ setContentType "text/plain; charset=utf-8"+ . setContentLength (fromIntegral $ B.length msg)+ . setResponseStatus 500 "Internal Server Error"+ . modifyResponseBody+ (>==> enumBuilder (fromByteString msg))+ $ emptyResponse++ where+ smsg req = toByteString $ requestErrorMessage req e++ msg = toByteString msgB+ msgB = mconcat [+ fromByteString "A web handler threw an exception. Details:\n"+ , fromShow e+ ]++++------------------------------------------------------------------------------+-- | 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.+ -> IO (Config m a)+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++ result <- either (usage prog)+ return+ (case getOpt Permute opts args of+ (f, _, [] ) -> maybe (Left []) Right $+ fmap (foldl' combine mempty) $+ sequence f+ (_, _, errs) -> Left errs)++#ifndef PORTABLE+ lang <- getEnv "LANG"+ completeConfig $ mconcat [defaults,+ mempty {locale = fmap upToUtf8 lang},+ result]+#else+ completeConfig $ mconcat [defaults, result]+#endif++ where+ 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++ 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++
− src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -1,760 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module Snap.Internal.Http.Server.LibevBackend- ( libEvEventLoop- ) where--#ifndef LIBEV--import Control.Exception-import Data.Typeable-import Snap.Internal.Http.Server.Backend--data LibevException = LibevException String- deriving (Show, Typeable)-instance Exception LibevException--libEvEventLoop :: EventLoop-libEvEventLoop _ _ _ _ _ = throwIO $- LibevException "libev event loop is not supported"--#else-------------------------------- TODO: document module ---------------------------------------------------------------------------------------------------------------import Control.Concurrent hiding (yield)-import Control.Exception-import Control.Monad-import Control.Monad.Trans-import Data.ByteString (ByteString)-import Data.ByteString.Internal (c2w)-import qualified Data.ByteString as S-import Data.Maybe-import Data.IORef-import Data.Typeable-import Foreign hiding (new)-import Foreign.C.Types-import GHC.Conc (forkOnIO)-import Network.Libev-import Network.Socket-import Prelude hiding (catch)----------------------------------------------------------------------------------- FIXME: should be HashSet, make that later.-import qualified Data.Concurrent.HashMap as H-import Data.Concurrent.HashMap (HashMap)-import Snap.Iteratee hiding (map)-import Snap.Internal.Debug-import Snap.Internal.Http.Server.Date-import Snap.Internal.Http.Server.Backend-import Snap.Internal.Http.Server.Address-import qualified Snap.Internal.Http.Server.ListenHelpers as Listen--#if defined(HAS_SENDFILE)-import qualified System.SendFile as SF-import System.Posix.IO-import System.Posix.Types (Fd(..))-#endif----------------------------------------------------------------------------------data Backend = Backend- { _acceptSockets :: [ListenSocket]- , _evLoop :: !EvLoopPtr- , _acceptIOCallbacks :: ![MVar (FunPtr IoCallback)]- , _acceptIOObjs :: ![EvIoPtr]- , _mutexCallbacks :: !(FunPtr MutexCallback, FunPtr MutexCallback)- , _loopLock :: !(MVar ())- , _asyncCb :: !(FunPtr AsyncCallback)- , _asyncObj :: !EvAsyncPtr- , _killCb :: !(FunPtr AsyncCallback)- , _killObj :: !EvAsyncPtr- , _connectionThreads :: !(HashMap ThreadId Connection)- , _backendCPU :: !Int- , _loopExit :: !(MVar ())- }----------------------------------------------------------------------------------data Connection = Connection- { _backend :: !Backend- , _listenSocket :: !ListenSocket- , _rawSocket :: !CInt- , _sessionInfo :: !SessionInfo- , _readAvailable :: !(MVar ())- , _writeAvailable :: !(MVar ())- , _timerObj :: !EvTimerPtr- , _timerCallback :: !(FunPtr TimerCallback)- , _timerTimeoutTime :: !(IORef CTime)- , _readActive :: !(IORef Bool)- , _writeActive :: !(IORef Bool)- , _connReadIOObj :: !EvIoPtr- , _connReadIOCallback :: !(FunPtr IoCallback)- , _connWriteIOObj :: !EvIoPtr- , _connWriteIOCallback :: !(FunPtr IoCallback)- , _connThread :: !(ThreadId)- }----------------------------------------------------------------------------------libEvEventLoop :: EventLoop-libEvEventLoop defaultTimeout sockets cap elog handler = do- backends <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)- [0..(cap-1)]-- debug "libevEventLoop: waiting for loop exit"- ignoreException (Prelude.mapM_ (takeMVar . _loopExit) backends)- debug "libevEventLoop: stopping all backends"- ignoreException $ mapM stop backends- ignoreException $ mapM Listen.closeSocket sockets----------------------------------------------------------------------------------newLoop :: Int -- ^ default timeout- -> [ListenSocket] -- ^ value you got from bindIt- -> SessionHandler -- ^ handler- -> (ByteString -> IO ()) -- ^ error logger- -> Int -- ^ cpu- -> IO Backend-newLoop defaultTimeout sockets handler elog cpu = do- -- We'll try kqueue on OSX even though the libev docs complain that it's- -- "broken", in the hope that it works as expected for sockets- f <- evRecommendedBackends- lp <- evLoopNew $ toEnum . fromEnum $ f .|. evbackend_kqueue--- -- we'll be working multithreaded so we need to set up locking for the C- -- event loop struct- (mc1,mc2,looplock) <- setupLockingForLoop lp-- -- setup async callbacks -- these allow us to wake up the main loop- -- (normally blocked in c-land) from other threads- asyncObj <- mkEvAsync- asyncCB <- mkAsyncCallback $ \_ _ _ -> do- debug "async wakeup"- return ()-- killObj <- mkEvAsync- killCB <- mkAsyncCallback $ \_ _ _ -> do- debug "async kill wakeup"- evUnloop lp evunloop_all- return ()-- evAsyncInit asyncObj asyncCB- evAsyncStart lp asyncObj- evAsyncInit killObj killCB- evAsyncStart lp killObj-- -- create the ios for the accept callbacks- accMVars <- forM sockets $ \_ -> newEmptyMVar- accIOs <- forM sockets $ \_ -> mkEvIo-- -- thread set stuff- connSet <- H.new (H.hashString . show)-- -- freed gets stuffed with () when all resources are released.- freed <- newEmptyMVar-- let b = Backend sockets- lp- accMVars- accIOs- (mc1,mc2)- looplock- asyncCB- asyncObj- killCB- killObj- connSet- cpu- freed-- -- setup the accept callback; this watches for read readiness on the- -- listen port- forM_ (zip3 sockets accIOs accMVars) $ \(sock, accIO, x) -> do- accCB <- mkIoCallback $ acceptCallback defaultTimeout b handler elog- cpu sock- evIoInit accIO accCB (fdSocket $ Listen.listenSocket sock) ev_read- evIoStart lp accIO- putMVar x accCB-- forkOnIO cpu $ loopThread b-- debug $ "LibEv.newLoop: loop spawned"- return b------------------------------------------------------------------------------------ | Run evLoop in a thread-loopThread :: Backend -> IO ()-loopThread backend = do- debug $ "starting loop"- (ignoreException go) `finally` cleanup- debug $ "loop finished"- where- cleanup = block $ do- debug $ "loopThread: cleaning up"- ignoreException $ freeBackend backend- putMVar (_loopExit backend) ()-- lock = _loopLock backend- loop = _evLoop backend- go = takeMVar lock >> block (evLoop loop 0)----------------------------------------------------------------------------------acceptCallback :: Int- -> Backend- -> SessionHandler- -> (ByteString -> IO ())- -> Int- -> ListenSocket- -> IoCallback-acceptCallback defaultTimeout back handler- elog cpu sock _loopPtr _ioPtr _ = do- debug "inside acceptCallback"- r <- c_accept $ fdSocket $ Listen.listenSocket sock-- case r of- -- this (EWOULDBLOCK) shouldn't happen (we just got told it was ready!),- -- if it does (maybe the request got picked up by another thread) we'll- -- just bail out- -2 -> return ()- -1 -> debugErrno "Libev.acceptCallback:c_accept()"- fd -> do- debug $ "acceptCallback: accept()ed fd, writing to chan " ++ show fd- forkOnIO cpu $ (go r `catches` cleanup)- return ()- where- go = runSession defaultTimeout back handler sock- cleanup = [ Handler $ \(_ :: TimeoutException) -> return ()- , Handler $ \(_ :: AsyncException) -> return ()- , Handler $ \(e :: SomeException) ->- elog $ S.concat [ "libev.acceptCallback: "- , S.pack . map c2w $ show e ]- ]----------------------------------------------------------------------------------ioReadCallback :: CInt -> IORef Bool -> MVar () -> IoCallback-ioReadCallback fd active ra _loopPtr _ioPtr _ = do- -- send notifications to the worker thread- debug $ "ioReadCallback: notification (" ++ show fd ++ ")"- tryPutMVar ra ()- debug $ "stopping ioReadCallback (" ++ show fd ++ ")"- evIoStop _loopPtr _ioPtr- writeIORef active False----------------------------------------------------------------------------------ioWriteCallback :: CInt -> IORef Bool -> MVar () -> IoCallback-ioWriteCallback fd active wa _loopPtr _ioPtr _ = do- -- send notifications to the worker thread- debug $ "ioWriteCallback: notification (" ++ show fd ++ ")"- tryPutMVar wa ()- debug $ "stopping ioWriteCallback (" ++ show fd ++ ")"- evIoStop _loopPtr _ioPtr- writeIORef active False----------------------------------------------------------------------------------stop :: Backend -> IO ()-stop b = ignoreException $ do- debug $ "Libev.stop"-- -- 1. take the loop lock- -- 2. shut down the accept() callback- -- 3. call evUnloop and wake up the loop using evAsyncSend- -- 4. release the loop lock, the main loop thread should then free/clean- -- everything up (threads, connections, io objects, callbacks, etc)-- withMVar lock $ \_ -> do- forM acceptObjs $ evIoStop loop- evUnloop loop evunloop_all- evAsyncSend loop killObj-- where- loop = _evLoop b- acceptObjs = _acceptIOObjs b- killObj = _killObj b- lock = _loopLock b------------------------------------------------------------------------------------ | Throws a timeout exception to the handling thread. The thread will clean--- up everything.-timerCallback :: EvLoopPtr -- ^ loop obj- -> EvTimerPtr -- ^ timer obj- -> IORef CTime -- ^ when to timeout?- -> ThreadId -- ^ thread to kill- -> TimerCallback-timerCallback loop tmr ioref tid _ _ _ = do- debug "Libev.timerCallback: entered"-- now <- getCurrentDateTime- whenToDie <- readIORef ioref-- if whenToDie <= now- then do- debug "Libev.timerCallback: killing thread"- throwTo tid TimeoutException-- else do- debug $ "Libev.timerCallback: now=" ++ show now- ++ ", whenToDie=" ++ show whenToDie- evTimerSetRepeat tmr $ fromRational . toRational $ (whenToDie - now)- evTimerAgain loop tmr------------------------------------------------------------------------------------ | If you already hold the loop lock, you are entitled to destroy a--- connection-destroyConnection :: Connection -> IO ()-destroyConnection conn = do- debug "Libev.destroyConnection: closing socket and killing connection"- c_close fd-- -- stop and free timer object- evTimerStop loop timerObj- freeEvTimer timerObj- freeTimerCallback timerCb-- -- stop and free i/o objects- evIoStop loop ioWrObj- freeEvIo ioWrObj- freeIoCallback ioWrCb-- evIoStop loop ioRdObj- freeEvIo ioRdObj- freeIoCallback ioRdCb-- where- backend = _backend conn- loop = _evLoop backend-- fd = _rawSocket conn- ioWrObj = _connWriteIOObj conn- ioWrCb = _connWriteIOCallback conn- ioRdObj = _connReadIOObj conn- ioRdCb = _connReadIOCallback conn- timerObj = _timerObj conn- timerCb = _timerCallback conn----------------------------------------------------------------------------------freeConnection :: Connection -> IO ()-freeConnection conn = ignoreException $ do- withMVar loopLock $ \_ -> block $ do- debug $ "freeConnection (" ++ show (_rawSocket conn) ++ ")"- destroyConnection conn- let tid = _connThread conn-- -- remove the thread id from the backend set- H.delete tid $ _connectionThreads backend-- -- wake up the event loop so it can be apprised of the changes- evAsyncSend loop asyncObj-- where- backend = _backend conn- loop = _evLoop backend- loopLock = _loopLock backend- asyncObj = _asyncObj backend----------------------------------------------------------------------------------freeBackend :: Backend -> IO ()-freeBackend backend = ignoreException $ block $ do- -- note: we only get here after an unloop, so we have the loop lock- -- here. (?)-- -- kill everything in thread table- tset <- H.toList $ _connectionThreads backend-- let nthreads = Prelude.length tset-- debug $ "Libev.freeBackend: killing active connection threads"-- Prelude.mapM_ (destroyConnection . snd) tset-- -- kill the threads twice, they're probably getting stuck in the- -- freeConnection 'finally' handler- Prelude.mapM_ (killThread . fst) tset- Prelude.mapM_ (killThread . fst) tset-- debug $ "Libev.freeBackend: " ++ show nthreads ++ " thread(s) killed"- debug $ "Libev.freeBackend: destroying libev resources"-- mapM freeEvIo acceptObjs- forM acceptCbs $ \x -> do- acceptCb <- readMVar x- freeIoCallback acceptCb-- evAsyncStop loop asyncObj- freeEvAsync asyncObj- freeAsyncCallback asyncCb-- evAsyncStop loop killObj- freeEvAsync killObj- freeAsyncCallback killCb-- freeMutexCallback mcb1- freeMutexCallback mcb2-- evLoopDestroy loop- debug $ "Libev.freeBackend: resources destroyed"-- where- acceptObjs = _acceptIOObjs backend- acceptCbs = _acceptIOCallbacks backend- asyncObj = _asyncObj backend- asyncCb = _asyncCb backend- killObj = _killObj backend- killCb = _killCb backend- (mcb1,mcb2) = _mutexCallbacks backend- loop = _evLoop backend------------------------------------------------------------------------------------ | Note: proc gets run in the background-runSession :: Int- -> Backend- -> SessionHandler- -> ListenSocket- -> CInt- -> IO ()-runSession defaultTimeout backend handler lsock fd = do- sock <- mkSocket fd AF_INET Stream 0 Connected- peerName <- getPeerName sock- sockName <- getSocketName sock- tid <- myThreadId-- -- set_linger fd- c_setnonblocking fd-- (rport, raddr) <- getAddress peerName- (lport, laddr) <- getAddress sockName-- let lp = _evLoop backend-- -- makes sense to assume the socket is read/write available when- -- opened; worst-case is we get EWOULDBLOCK- ra <- newMVar ()- wa <- newMVar ()-- ------------------ -- setup timer --- ------------------ tmr <- mkEvTimer- now <- getCurrentDateTime- timeoutTime <- newIORef $ now + (fromIntegral defaultTimeout)- tcb <- mkTimerCallback $ timerCallback lp- tmr- timeoutTime- tid- evTimerInit tmr tcb 0 (fromIntegral defaultTimeout)--- readActive <- newIORef True- writeActive <- newIORef True-- evioRead <- mkEvIo- ioReadCb <- mkIoCallback $ ioReadCallback fd readActive ra-- evioWrite <- mkEvIo- ioWriteCb <- mkIoCallback $ ioWriteCallback fd writeActive wa-- evIoInit evioRead ioReadCb fd ev_read- evIoInit evioWrite ioWriteCb fd ev_write-- -- take ev_loop lock, start timer and io watchers- withMVar (_loopLock backend) $ \_ -> do- evTimerAgain lp tmr- evIoStart lp evioRead- evIoStart lp evioWrite-- -- wakeup the loop thread so that these new watchers get- -- registered next time through the loop- evAsyncSend lp $ _asyncObj backend-- let sinfo = SessionInfo laddr lport raddr rport $- Listen.isSecure lsock- let conn = Connection backend- lsock- fd- sinfo- ra- wa- tmr- tcb- timeoutTime- readActive- writeActive- evioRead- ioReadCb- evioWrite- ioWriteCb- tid-- go sinfo conn `finally` (block $ do- debug "runSession: thread finished, freeing connection"- ignoreException $ freeConnection conn)-- where- go sinfo conn =- bracket (Listen.createSession lsock bLOCKSIZE fd $- waitForLock True conn)- (\session -> block $ do- debug "runSession: session finished, cleaning up"- ignoreException $ Listen.endSession lsock session- )- (\session -> do H.update (_connThread conn)- conn- (_connectionThreads backend)- handler sinfo- (enumerate conn session)- (writeOut defaultTimeout conn session)- (sendFile defaultTimeout conn session)- (modifyTimeout conn)- )----------------------------------------------------------------------------------ignoreException :: IO a -> IO ()-ignoreException act =- (act >> return ()) `catch` \(_::SomeException) -> return ()----------------------------------------------------------------------------------data AddressNotSupportedException = AddressNotSupportedException String- deriving (Typeable)--instance Show AddressNotSupportedException where- show (AddressNotSupportedException x) = "Address not supported: " ++ x--instance Exception AddressNotSupportedException-----------------------------------------------------------------------------------bLOCKSIZE :: Int-bLOCKSIZE = 8192------- About timeouts------ It's not good enough to restart the timer from io(Read|Write)Callback,--- because those seem to be edge-triggered. I've definitely had where after 20--- seconds they still weren't being re-awakened.-------------------------------------------------------------------------------------data TimeoutException = TimeoutException- deriving (Typeable)--instance Show TimeoutException where- show _ = "timeout"--instance Exception TimeoutException----------------------------------------------------------------------------------modifyTimeout :: Connection -> (Int -> Int) -> IO ()-modifyTimeout conn f = do- debug "Libev.modifyTimeout"- !prev <- readIORef tt- !now <- getCurrentDateTime-- let !remaining = fromEnum $ max 0 (prev - now)- let !newRemaining = f remaining- let !newTimeout = now + toEnum newRemaining-- writeIORef tt $! now + toEnum newRemaining-- -- Here the question is: do we reset the ev timer? If we're extending the- -- timeout, the ev manual suggests it's more efficient to let the timer- -- lapse and re-arm. If we're shortening the timeout, we need to update the- -- timer so it fires when it's supposed to.- when (newTimeout < prev) $ withMVar loopLock $ \_ -> do- evTimerSetRepeat tmr $! toEnum newRemaining- evTimerAgain loop tmr- -- wake up the event loop so it can be apprised of the changes- evAsyncSend loop asyncObj-- where- tt = _timerTimeoutTime conn- backend = _backend conn- asyncObj = _asyncObj backend- loopLock = _loopLock backend- loop = _evLoop backend- tmr = _timerObj conn----------------------------------------------------------------------------------tickleTimeout :: Connection -> Int -> IO ()-tickleTimeout conn = modifyTimeout conn . max----------------------------------------------------------------------------------waitForLock :: Bool -- ^ True = wait for read, False = wait for write- -> Connection- -> IO ()-waitForLock readLock conn = do- dbg "start waitForLock"-- withMVar looplock $ \_ -> do- act <- readIORef active- if act- then dbg "read watcher already active, skipping"- else do- dbg "starting watcher, sending async"- tryTakeMVar lock- evIoStart lp io- writeIORef active True- evAsyncSend lp async-- dbg "waitForLock: waiting for mvar"- takeMVar lock- dbg "waitForLock: took mvar"-- where- dbg s = debug $ "Libev.recvData(" ++ show (_rawSocket conn) ++ "): "- ++ s- io = if readLock- then (_connReadIOObj conn)- else (_connWriteIOObj conn)- bk = _backend conn- active = if readLock- then (_readActive conn)- else (_writeActive conn)- lp = _evLoop bk- looplock = _loopLock bk- async = _asyncObj bk- lock = if readLock- then (_readAvailable conn)- else (_writeAvailable conn)----------------------------------------------------------------------------------sendFile :: Int- -> Connection- -> NetworkSession- -> FilePath- -> Int64- -> Int64- -> IO ()-sendFile defaultTimeout c s fp start sz = do- withMVar lock $ \_ -> do- act <- readIORef $ _writeActive c- when act $ evIoStop loop io- writeIORef (_writeActive c) False- evAsyncSend loop asy--#if defined(HAS_SENDFILE)- case (_listenSocket c) of- ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags)- (closeFd)- (go start sz)- _ -> do- step <- runIteratee $ writeOut defaultTimeout c s- run_ $ enumFilePartial fp (start,start+sz) step-#else- step <- runIteratee $ writeOut defaultTimeout c s-- run_ $ enumFilePartial fp (start,start+sz) step- return ()-#endif-- withMVar lock $ \_ -> do- tryTakeMVar $ _readAvailable c- tryTakeMVar $ _writeAvailable c- evAsyncSend loop asy-- where-#if defined(HAS_SENDFILE)- go off bytes fd- | bytes == 0 = return ()- | otherwise = do- sent <- SF.sendFile (waitForLock False c) sfd fd off bytes- if sent < bytes- then tickleTimeout c defaultTimeout >>- go (off+sent) (bytes-sent) fd- else return ()-- sfd = Fd $ _rawSocket c-#endif- io = _connWriteIOObj c- b = _backend c- loop = _evLoop b- lock = _loopLock b- asy = _asyncObj b----------------------------------------------------------------------------------enumerate :: (MonadIO m)- => Connection- -> NetworkSession- -> Enumerator ByteString m a-enumerate conn session = loop- where- dbg s = debug $ "Libev.enumerate(" ++ show (_socket session)- ++ "): " ++ s-- loop (Continue k) = do- m <- liftIO $ recvData- let s = fromMaybe "" m- sendOne k s- loop x = returnI x-- sendOne k s | S.null s = do- dbg "sending EOF to continuation"- enumEOF $ Continue k-- | otherwise = do- dbg $ "sending " ++ show s ++ " to continuation"- step <- lift $ runIteratee $ k $ Chunks [s]- case step of- (Yield x st) -> do- dbg $ "got yield, remainder is " ++ show st- yield x st- r@(Continue _) -> do- dbg $ "got continue"- loop r- (Error e) -> throwError e-- recvData = Listen.recv (_listenSocket conn)- (waitForLock True conn) session----------------------------------------------------------------------------------writeOut :: (MonadIO m)- => Int- -> Connection- -> NetworkSession- -> Iteratee ByteString m ()-writeOut defaultTimeout conn session = loop- where- loop = continue k-- k EOF = yield () EOF- k (Chunks xs) = do- liftIO $ sendData $ S.concat xs- loop-- sendData = Listen.send (_listenSocket conn)- (tickleTimeout conn defaultTimeout)- (waitForLock False conn)- session--#endif
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -59,10 +59,11 @@ ------------------------------------------------------------------------------ simpleEventLoop :: EventLoop-simpleEventLoop defaultTimeout sockets cap elog handler = do+simpleEventLoop defaultTimeout sockets cap elog initial handler = do loops <- Prelude.mapM (newLoop defaultTimeout sockets handler elog) [0..(cap-1)] + initial debug "simpleEventLoop: waiting for mvars" --wait for all threads to exit
test/snap-server-testsuite.cabal view
@@ -3,10 +3,6 @@ build-type: Simple cabal-version: >= 1.6 -Flag libev- Description: Use libev?- Default: False- Flag portable Description: Compile in cross-platform mode. No platform-specific code or optimizations such as C routines will be used.@@ -45,7 +41,7 @@ old-locale, parallel >= 2 && <4, process,- snap-core >= 0.8.1 && <0.9,+ snap-core >= 0.9 && <0.10, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3,@@ -53,7 +49,7 @@ text >= 0.11 && <0.12, time, tls >= 0.8.2 && <0.9.2,- tls-extra >= 0.4 && <= 0.4.4,+ tls-extra >= 0.4 && <0.4.5, transformers, vector >= 0.7 && <0.10, vector-algorithms >= 0.4 && <0.6,@@ -76,10 +72,6 @@ if !os(windows) build-depends: unix - if flag(libev)- build-depends: hlibev >= 0.2.5 && < 0.5- cpp-options: -DLIBEV- if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10 && <0.11@@ -117,10 +109,10 @@ mtl >= 2 && <3, murmur-hash >= 0.1 && <0.2, old-locale,- parallel >= 2 && <4,+ parallel >= 3.2 && <4, MonadCatchIO-transformers >= 0.2.1 && <0.4, network == 2.3.*,- snap-core >= 0.8.1 && <0.9,+ snap-core >= 0.9 && <0.10, template-haskell, time, transformers,@@ -135,10 +127,6 @@ else build-depends: unix - if flag(libev)- build-depends: hlibev >= 0.2.5 && < 0.3- cpp-options: -DLIBEV- if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10 && <0.11@@ -195,8 +183,8 @@ murmur-hash >= 0.1 && <0.2, network == 2.3.*, old-locale,- parallel >= 2 && <4,- snap-core >= 0.8.1 && <0.9,+ parallel >= 3.2 && <4,+ snap-core >= 0.9 && <0.10, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3,@@ -210,10 +198,6 @@ if !os(windows) build-depends: unix - if flag(libev)- build-depends: hlibev >= 0.2.5 && < 0.3- cpp-options: -DLIBEV- if flag(openssl) cpp-options: -DOPENSSL build-depends: HsOpenSSL >= 0.10 && <0.11@@ -241,5 +225,5 @@ base >= 4 && < 5, network == 2.3.*, http-enumerator >= 0.7.1.6 && <0.8,- tls >= 0.8.2 && <= 0.9.2,+ tls >= 0.8.2 && <0.9.2, criterion >= 0.6 && <0.7
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -152,7 +152,8 @@ testMethodParsing = testCase "server/method parsing" $ Prelude.mapM_ testOneMethod ms where- ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]+ ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT, PATCH+ , Method "COPY", Method "MOVE" ] dummyIter :: Iteratee ByteString IO ()@@ -272,9 +273,11 @@ methodTestText :: Method -> L.ByteString-methodTestText m = L.concat [ (L.pack $ map c2w $ show m)+methodTestText m = L.concat [ mbs m , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ]-+ where+ mbs (Method b) = L.fromChunks [b]+ mbs b = L.pack $ map c2w $ show b sampleRequest2 :: ByteString sampleRequest2 =@@ -944,8 +947,8 @@ m) where- serve = (httpServe 60 [HttpPort "*" port] Nothing "localhost"- Nothing Nothing+ serve = (httpServe 60 [HttpPort "*" port] "localhost"+ Nothing Nothing (const $ return ()) $ runSnap sendFileFoo) `catch` \(_::SomeException) -> return () @@ -970,10 +973,10 @@ bracket (forkIO $ httpServe 20 [HttpPort "*" port]- Nothing "localhost" (Just $ const (return ())) -- dummy logging (Just $ const (return ())) -- dummy logging+ (const $ return ()) (runSnap pongServer)) (killThread) (\tid -> do@@ -1008,11 +1011,11 @@ testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do tid <- forkIO $ httpServe 20- [HttpPort "127.0.0.1" port]- Nothing+ [HttpPort "*" port] "localhost" Nothing Nothing+ (const $ return ()) (runSnap pongServer) waitabit@@ -1050,7 +1053,7 @@ where waitabit = threadDelay $ 2*((10::Int)^(6::Int))- port = 8146+ port = 8149
test/suite/Test/Blackbox.hs view
@@ -64,8 +64,8 @@ -------------------------------------------------------------------------------tests :: Int -> String -> [Test]-tests port name = map (\f -> f False port name) testFunctions+tests :: Int -> [Test]+tests port = map (\f -> f False port "") testFunctions ------------------------------------------------------------------------------@@ -77,35 +77,34 @@ -------------------------------------------------------------------------------ssltests :: String -> Maybe Int -> [Test]-ssltests name = maybe [] httpsTests+ssltests :: Maybe Int -> [Test]+ssltests = maybe [] httpsTests where httpsTests port = map (\f -> f True port sslname) testFunctions- sslname = "ssl/" ++ name+ sslname = "ssl/" ------------------------------------------------------------------------------ startTestServer :: Int -> Maybe Int- -> ConfigBackend -> IO (ThreadId, MVar ())-startTestServer port sslport backend = do- let cfg = setAccessLog- (ConfigFileLog $ "ts-access." ++ show backend ++ ".log") .- setErrorLog- (ConfigFileLog $ "ts-error." ++ show backend ++ ".log") .- setBind "*" .- setPort port .- setBackend backend .- setDefaultTimeout 10 .- setVerbose False $+startTestServer port sslport = do+ let cfg = setAccessLog (ConfigFileLog "ts-access.log") .+ setErrorLog (ConfigFileLog "ts-error.log") .+ setBind "*" .+ setPort port .+ setDefaultTimeout 10 .+ setVerbose False $ defaultConfig - let cfg' = case sslport of- Nothing -> cfg- Just p -> setSSLPort p .- setSSLBind "*" .- setSSLCert "cert.pem" .- setSSLKey "key.pem" $- cfg+ let cfg' = maybe cfg+ (\p ->+ setSSLPort p .+ setSSLBind "*" .+ setSSLCert "cert.pem" .+ setSSLKey "key.pem" .+ setAccessLog (ConfigFileLog "ts-access-ssl.log") .+ setErrorLog (ConfigFileLog "ts-error-ssl.log") $+ cfg)+ sslport mvar <- newEmptyMVar tid <- forkIO $ do@@ -146,7 +145,7 @@ ------------------------------------------------------------------------------ testPong :: Bool -> Int -> String -> Test-testPong ssl port name = testCase (name ++ "/blackbox/pong") $ do+testPong ssl port name = testCase (name ++ "blackbox/pong") $ do doc <- doPong ssl port assertEqual "pong response" "PONG" doc @@ -154,7 +153,7 @@ ------------------------------------------------------------------------------ -- FIXME: waiting on http-enumerator patch for HEAD behaviour -- testHeadPong :: Bool -> Int -> String -> Test--- testHeadPong ssl port name = testCase (name ++ "/blackbox/pong/HEAD") $ do+-- testHeadPong ssl port name = testCase (name ++ "blackbox/pong/HEAD") $ do -- doc <- headPong ssl port -- assertEqual "pong HEAD response" "" doc @@ -163,7 +162,7 @@ testEcho :: Bool -> Int -> String -> Test testEcho ssl port name = plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "/blackbox/echo") $+ testProperty (name ++ "blackbox/echo") $ QC.mapSize (if ssl then min 100 else min 300) $ monadicIO $ forAllM arbitrary prop where@@ -179,7 +178,7 @@ testFileUpload :: Bool -> Int -> String -> Test testFileUpload ssl port name = plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "/blackbox/upload") $+ testProperty (name ++ "blackbox/upload") $ QC.mapSize (if ssl then min 100 else min 300) $ monadicIO $ forAllM arbitrary prop@@ -249,7 +248,7 @@ testRot13 :: Bool -> Int -> String -> Test testRot13 ssl port name = plusTestOptions (slowTestOptions ssl) $- testProperty (name ++ "/blackbox/rot13") $+ testProperty (name ++ "blackbox/rot13") $ monadicIO $ forAllM arbitrary prop where prop txt = do@@ -264,7 +263,7 @@ ------------------------------------------------------------------------------ -- TODO: this one doesn't work w/ SSL testSlowLoris :: Bool -> Int -> String -> Test-testSlowLoris ssl port name = testCase (name ++ "/blackbox/slowloris") $+testSlowLoris ssl port name = testCase (name ++ "blackbox/slowloris") $ if ssl then return () else withSock port go where@@ -294,7 +293,7 @@ -- TODO: doesn't work w/ ssl testBlockingRead :: Bool -> Int -> String -> Test testBlockingRead ssl port name =- testCase (name ++ "/blackbox/testBlockingRead") $+ testCase (name ++ "blackbox/testBlockingRead") $ if ssl then return () else runIt where@@ -324,7 +323,7 @@ -- test server's ability to trap/recover from IO errors testPartial :: Bool -> Int -> String -> Test testPartial ssl port name =- testCase (name ++ "/blackbox/testPartial") $+ testCase (name ++ "blackbox/testPartial") $ if ssl then return () else runIt where@@ -346,7 +345,7 @@ -- TODO: no ssl testBigResponse :: Bool -> Int -> String -> Test testBigResponse ssl port name =- testCase (name ++ "/blackbox/testBigResponse") $+ testCase (name ++ "blackbox/testBigResponse") $ if ssl then return () else runIt where runIt = withSock port $ \sock -> do@@ -441,7 +440,7 @@ -- 2. that "flush" is passed along through a gzip operation. testTimeoutTickle :: Bool -> Int -> String -> Test testTimeoutTickle ssl port name =- testCase (name ++ "/blackbox/timeout/tickle") $ do+ testCase (name ++ "blackbox/timeout/tickle") $ do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle" doc <- liftM (S.concat . L.toChunks) $ fetch uri@@ -452,7 +451,7 @@ ------------------------------------------------------------------------------ testTimeoutBadTickle :: Bool -> Int -> String -> Test testTimeoutBadTickle ssl port name =- testCase (name ++ "/blackbox/timeout/badtickle") $ do+ testCase (name ++ "blackbox/timeout/badtickle") $ do let uri = (if ssl then "https" else "http") ++ "://127.0.0.1:" ++ show port ++ "/timeout/badtickle" expectException $ fetch uri
test/suite/TestSuite.hs view
@@ -20,27 +20,19 @@ import qualified Test.Blackbox ports :: Int -> [Int]-ports sp = [sp..]+ports sp = [sp] #ifdef OPENSSL sslports :: Int -> [Maybe Int]-sslports sp = map Just [(sp + 100)..]+sslports sp = map Just [(sp + 100)] #else sslports :: Int -> [Maybe Int] sslports _ = repeat Nothing #endif -#ifdef LIBEV-backends :: Int -> [(Int,Maybe Int,ConfigBackend)]-backends sp = zip3 (ports sp)- (sslports sp)- [ConfigSimpleBackend, ConfigLibEvBackend]-#else-backends :: Int -> [(Int,Maybe Int,ConfigBackend)]-backends sp = zip3 (ports sp)- (sslports sp)- [ConfigSimpleBackend]-#endif+backends :: Int -> [(Int,Maybe Int)]+backends sp = zip (ports sp)+ (sslports sp) getStartPort :: IO Int getStartPort = (liftM read (getEnv "STARTPORT") >>= evaluate)@@ -51,8 +43,8 @@ main = withSocketsDo $ do sp <- getStartPort let bends = backends sp- tinfos <- forM bends $ \(port,sslport,b) ->- Test.Blackbox.startTestServer port sslport b+ tinfos <- forM bends $ \(port,sslport) ->+ Test.Blackbox.startTestServer port sslport defaultMain (tests ++ concatMap blackbox bends) `finally` do mapM_ killThread $ map fst tinfos@@ -68,11 +60,9 @@ , testGroup "Snap.Internal.Http.Server.TimeoutManager.Tests" Snap.Internal.Http.Server.TimeoutManager.Tests.tests ]- blackbox (port, sslport, b) =- [ testGroup ("Test.Blackbox " ++ backendName)- $ Test.Blackbox.tests port backendName- , testGroup ("Test.Blackbox SSL " ++ backendName)- $ Test.Blackbox.ssltests backendName sslport+ blackbox (port, sslport) =+ [ testGroup ("Test.Blackbox")+ $ Test.Blackbox.tests port+ , testGroup ("Test.Blackbox SSL")+ $ Test.Blackbox.ssltests sslport ]- where- backendName = show b