diff --git a/README.SNAP.md b/README.SNAP.md --- a/README.SNAP.md +++ b/README.SNAP.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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.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 diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -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 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,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 diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Http/Server/Backend.hs b/src/Snap/Internal/Http/Server/Backend.hs --- a/src/Snap/Internal/Http/Server/Backend.hs +++ b/src/Snap/Internal/Http/Server/Backend.hs @@ -51,6 +51,7 @@ -> [ListenSocket] -- ^ list of ports -> Int -- ^ number of capabilities -> (ByteString -> IO ()) -- ^ error log + -> IO () -- ^ initialisation function -> SessionHandler -- ^ session handler -> IO () diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -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 + + diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs deleted file mode 100644 --- a/src/Snap/Internal/Http/Server/LibevBackend.hs +++ /dev/null @@ -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 diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs b/src/Snap/Internal/Http/Server/SimpleBackend.hs --- a/src/Snap/Internal/Http/Server/SimpleBackend.hs +++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs @@ -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 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 @@ -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 diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -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 diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs --- a/test/suite/Test/Blackbox.hs +++ b/test/suite/Test/Blackbox.hs @@ -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 diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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