diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -2,5 +2,6 @@ Gregory Collins Shu-yu Guo Carl Howells +John Lenz James Sanders -Jacob Stanley +Jacob Stanley diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS) +Copyright (c) 2010, Google, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.SNAP.md b/README.SNAP.md --- a/README.SNAP.md +++ b/README.SNAP.md @@ -1,10 +1,9 @@ Snap Framework -------------- -This is the first developer prerelease of the Snap framework. Snap is a simple -and fast web development framework and server written in Haskell. For more -information or to download the latest version, you can visit the Snap project -website at http://snapframework.com/. +Snap is a simple and fast web development framework and server written in +Haskell. For more information or to download the latest version, you can visit +the Snap project website at http://snapframework.com/. Snap Status and Features @@ -23,8 +22,8 @@ bind Haskell functionality to XML tags without getting PHP-style tag soup all over your pants -Snap currently only runs on Unix platforms; it has been tested on Linux and Mac -OSX Snow Leopard. +Snap is currently only officially supported on Unix platforms; it has been +tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. Snap Philosophy @@ -41,17 +40,3 @@ * Excellent documentation * Robustness and high test coverage - - -Snap Roadmap ------------- - -Where are we going? - -1. First prerelease: HTTP server, monad, template system - -2. Second prerelease: component system with a collection of useful stock -modules (called "Snaplets") for things like user and session management, -caching, an administrative interface, etc. - -3. Third prerelease: where we figure out what to do about data access diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,9 @@ Snap Framework HTTP Server Library ---------------------------------- -This is the first developer prerelease of the Snap Framework HTTP Server -library. For more information about Snap, read the `README.SNAP.md` or visit -the Snap project website at http://www.snapframework.com/. +This is the Snap Framework HTTP Server library. For more information about +Snap, read the `README.SNAP.md` or visit the Snap project website at +http://www.snapframework.com/. The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web server library written in Haskell. Together with the `snap-core` library upon @@ -29,10 +29,16 @@ To build the Snap HTTP server, you need to `cabal install` the `snap-core` library (which should have come with this package). -The snap-server library can optionally use the +### 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 +[gnutls](http://www.gnu.org/software/gnutls/) library. + + ## Building snap-server The snap-server library is built using [Cabal](http://www.haskell.org/cabal/) @@ -40,13 +46,19 @@ cabal install -for the "stock" version of Snap or +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 -for the libev-based backend. +And if you would like SSL support, pass the `gnutls` flag to `cabal install`: + cabal install -fgnutls +Note that the "`-flibev`" and "`-fgnutls`" 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 @@ -59,39 +71,16 @@ ## Building the testsuite -Snap is still in its very early stages, so most of the "action" (and a big -chunk of the code) right now is centred on the test suite. Snap aims for 100% -test coverage, and we're trying hard to stick to that. - -To build the test suite, `cd` into the `test/` directory and run +The `snap-server` has a fairly comprehensive test suite. To build and run it, +`cd` into the `test/` directory and run - $ cabal configure # for the stock backend - $ cabal configure -flibev # for the libev backend + $ cabal configure # for the stock backend, or.. + $ cabal configure -flibev # for the libev backend, and/or.. + $ cabal configure -fgnutls # for the SSL backend $ cabal build From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh - The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. - -The test `cabal` project also builds an executable called "pongserver" which is -a test HTTP server, hardcoded to run on port 8000: - - $ ./dist/build/pongserver/pongserver +RTS -A4M -N4 -qg0 -qb -g1 - -(Those are the RTS settings that give me the highest performance on my -quad-core Linux box running GHC 6.12.1, your mileage may vary.) - -This server just outputs "PONG" but it is a complete example of an HTTP -application (FIXME: currently this isn't true, we need to make pongserver run -in the still-incomplete Snap monad): - - $ curl -i http://localhost:8000 - HTTP/1.1 200 OK - Content-Length: 4 - Date: Sun, 14 Mar 2010 03:17:45 GMT - Server: Snap/0.pre-1 - - PONG 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.2.16.2 +version: 0.3.0 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: This is the first developer prerelease of the Snap framework. Snap is a @@ -87,7 +87,11 @@ optimizations such as C routines will be used. Default: False +Flag gnutls + Description: Enable https support using the libgnutls library. + Default: False + Library hs-source-dirs: src @@ -101,13 +105,20 @@ Data.Concurrent.HashMap.Internal, Paths_snap_server, Snap.Internal.Http.Parser, - Snap.Internal.Http.Server, - Snap.Internal.Http.Server.Date + Snap.Internal.Http.Server, + Snap.Internal.Http.Server.Date, + Snap.Internal.Http.Server.Backend, + Snap.Internal.Http.Server.ListenHelpers, + Snap.Internal.Http.Server.GnuTLS, + Snap.Internal.Http.Server.HttpPort, + Snap.Internal.Http.Server.TimeoutTable, + Snap.Internal.Http.Server.SimpleBackend, + Snap.Internal.Http.Server.LibevBackend build-depends: array >= 0.2 && <0.4, attoparsec >= 0.8.1 && < 0.9, - attoparsec-iteratee >= 0.1.1 && <0.2, + attoparsec-enumerator >= 0.2.0.1 && < 0.3, base >= 4 && < 5, binary >=0.5 && <0.6, bytestring, @@ -117,19 +128,22 @@ containers, directory-tree, dlist >= 0.5 && < 0.6, + enumerator == 0.4.*, filepath, - iteratee >= 0.3.1 && <0.4, - monads-fd < 0.1.0.3, + MonadCatchIO-transformers >= 0.2.1 && < 0.3, + mtl == 2.0.*, murmur-hash >= 0.1 && < 0.2, - network == 2.2.1.*, + network >= 2.3 && <2.4, old-locale, - snap-core == 0.2.16.*, + snap-core >= 0.3 && <0.4, template-haskell, time, transformers, - unix-compat, + utf8-string, + unix-compat == 0.2.*, vector >= 0.7 && <0.8, - vector-algorithms >= 0.3.4 && <0.4 + vector-algorithms >= 0.4 && <0.5, + PSQueue >= 1.1 && <1.2 if flag(portable) || os(windows) cpp-options: -DPORTABLE @@ -138,14 +152,12 @@ if flag(libev) build-depends: hlibev >= 0.2.8 && < 0.3 - other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV - else - other-modules: Snap.Internal.Http.Server.TimeoutTable - build-depends: network-bytestring >= 0.1.2 && < 0.2, - PSQueue >= 1.1 && <1.2 - other-modules: Snap.Internal.Http.Server.SimpleBackend + if flag(gnutls) + extra-libraries: gnutls + cpp-options: -DGNUTLS + c-sources: src/Snap/Internal/Http/Server/gnutls_helpers.c if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE diff --git a/src/Data/Concurrent/HashMap.hs b/src/Data/Concurrent/HashMap.hs --- a/src/Data/Concurrent/HashMap.hs +++ b/src/Data/Concurrent/HashMap.hs @@ -92,9 +92,10 @@ where f mv = withMVar mv (return . IM.null) + new' :: Eq k => Int -- ^ number of locks to use - -> (k -> Word) -- ^ hash function + -> (k -> Word) -- ^ hash function -> IO (HashMap k v) new' numLocks hashFunc = do vector <- V.replicateM (fromEnum n) (newMVar IM.empty) @@ -123,7 +124,6 @@ submap = V.unsafeIndex (_maps ht) (fromEnum bucket) - delete :: (Eq k) => k -> HashMap k v -> IO () delete key ht = modifyMVar_ submap $ \m -> @@ -171,8 +171,6 @@ -- helper functions ------------------------------------------------------------------------------ - - -- nicked this technique from Data.IntMap shiftRL :: Word -> Int -> Word @@ -233,7 +231,7 @@ m' = maybe m (const $ delSubmap hashcode key m) oldV m'' = insSubmap hashcode key value m' b = isJust oldV - + defaultNumberOfLocks :: Int defaultNumberOfLocks = 8 * numCapabilities 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 @@ -1,35 +1,115 @@ --- | The Snap HTTP server is a high performance, epoll-enabled, iteratee-based --- web server library written in Haskell. Together with the @snap-core@ library --- upon which it depends, it provides a clean and efficient Haskell programming --- interface to the HTTP protocol. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + +The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web +server library written in Haskell. Together with the @snap-core@ library upon +which it depends, it provides a clean and efficient Haskell programming +interface to the HTTP protocol. + +-} + module Snap.Http.Server -( - httpServe -, snapServerVersion -) where + ( simpleHttpServe + , httpServe + , quickHttpServe + , snapServerVersion + , setUnicodeLocale + , module Snap.Http.Server.Config + ) where +import Control.Monad +import Control.Monad.CatchIO import Data.ByteString (ByteString) -import Snap.Types +import Data.Char +import Data.List +import Data.Maybe +import Prelude hiding (catch) +import Snap.Http.Server.Config import qualified Snap.Internal.Http.Server as Int +import Snap.Types +import Snap.Util.GZip +#ifndef PORTABLE +import System.Posix.Env +#endif +import System.IO ------------------------------------------------------------------------------ +-- | A short string describing the Snap server version snapServerVersion :: ByteString snapServerVersion = Int.snapServerVersion ------------------------------------------------------------------------------ --- | Starts serving HTTP requests on the given port using the given handler. +-- | Starts serving HTTP requests using the given handler. Uses only the basic +-- settings from the given config; error handling and compression are ignored. -- This function never returns; to shut down the HTTP server, kill the -- controlling thread. -httpServe :: ByteString -- ^ bind address, or \"*\" for all - -> Int -- ^ port to bind to - -> ByteString -- ^ local hostname (server name) - -> Maybe FilePath -- ^ path to the (optional) access log - -> Maybe FilePath -- ^ path to the (optional) error log - -> Snap () -- ^ handler procedure - -> IO () -httpServe bindAddress bindPort localHostname alog elog handler = - Int.httpServe bindAddress bindPort localHostname alog elog handler' +simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO () +simpleHttpServe config handler = do + setUnicodeLocale $ fromJust $ getLocale conf + Int.httpServe (map listenToInt $ getListen conf) + (fmap backendToInt $ getBackend conf) + (fromJust $ getHostname conf) + (fromJust $ getAccessLog conf) + (fromJust $ getErrorLog conf) + (runSnap handler) where - handler' = runSnap handler + conf = completeConfig config + listenToInt (ListenHttp b p) = Int.HttpPort b p + listenToInt (ListenHttps b p c k) = Int.HttpsPort b p c k + backendToInt ConfigSimpleBackend = Int.EventLoopSimple + backendToInt ConfigLibEvBackend = Int.EventLoopLibEv + + +------------------------------------------------------------------------------ +-- | Starts serving HTTP requests using the given handler, with settings from +-- the 'Config' passed in. This function never returns; to shut down the HTTP +-- server, kill the controlling thread. +httpServe :: Config Snap () -> Snap () -> IO () +httpServe config handler = do + mapM_ (output . ("Listening on "++) . show) $ getListen conf + serve handler `finally` output "\nShutting down..." + where + conf = completeConfig config + output = when (fromJust $ getVerbose conf) . hPutStrLn stderr + serve = simpleHttpServe config . compress . catch500 + catch500 = flip catch $ fromJust $ getErrorHandler conf + compress = if fromJust $ getCompression conf then withCompression else id + + +------------------------------------------------------------------------------ +-- | Starts serving HTTP using the given handler. The configuration is read +-- from the options given on the command-line, as returned by +-- 'commandLineConfig'. This function never returns; to shut down the HTTP +-- server, kill the controlling thread. +quickHttpServe :: Snap () -> IO () +quickHttpServe m = commandLineConfig emptyConfig >>= \c -> httpServe c m + + +------------------------------------------------------------------------------ +-- | Given a string like \"en_US\", this sets the locale to \"en_US.UTF-8\". +-- This doesn't work on Windows. +setUnicodeLocale :: String -> IO () +setUnicodeLocale lang = +#ifndef PORTABLE + mapM_ (\k -> setEnv k (lang ++ ".UTF-8") True) + [ "LANG" + , "LC_CTYPE" + , "LC_NUMERIC" + , "LC_TIME" + , "LC_COLLATE" + , "LC_MONETARY" + , "LC_MESSAGES" + , "LC_PAPER" + , "LC_NAME" + , "LC_ADDRESS" + , "LC_TELEPHONE" + , "LC_MEASUREMENT" + , "LC_IDENTIFICATION" + , "LC_ALL" ] +#else + return () +#endif 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,123 +1,518 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| + +This module exports the 'Config' datatype which represents partially-specified +configurations of \"serve\" functions which run 'Snap' actions in 'IO'. + +-} + module Snap.Http.Server.Config - ( Config(..) - , readConfigFromCmdLineArgs + ( Config + , ConfigListen(..) + , ConfigBackend(..) + , emptyConfig + , defaultConfig + , completeConfig + , commandLineConfig + + , getHostname + , getListen + , getAccessLog + , getErrorLog + , getLocale + , getBackend + , getCompression + , getVerbose + , getErrorHandler + , getOther + + , setHostname + , addListen + , setAccessLog + , setErrorLog + , setLocale + , setBackend + , setCompression + , setVerbose + , setErrorHandler + , setOther ) where +import Control.Exception (SomeException) +import Control.Monad +import qualified Data.ByteString.UTF8 as U +import qualified Data.ByteString.Char8 as B import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Internal (c2w) -import Data.ByteString.Char8 () -import Data.Maybe +import Data.Char +import Data.List import Data.Monoid +import Prelude hiding (catch) +import Snap.Types +import Snap.Iteratee ((>==>), enumBS) import System.Console.GetOpt -import System.Environment +import System.Environment hiding (getEnv) +#ifndef PORTABLE +import System.Posix.Env +#endif import System.Exit import System.IO -data Config = Config - { localHostname :: !ByteString - , bindAddress :: !ByteString - , listenPort :: !Int - , accessLog :: !(Maybe FilePath) - , errorLog :: !(Maybe FilePath) - } deriving (Show) +------------------------------------------------------------------------------ +-- | A data type to store the bind address and port to listen on. +-- +-- For SSL support, it also stores the path to the certificate in PEM format +-- and the path to the private key in PEM format +data ConfigListen = ListenHttp ByteString Int + | ListenHttps ByteString Int FilePath FilePath -data Flag = Flag - { flagLocalHost :: Maybe String - , flagBindAddress :: Maybe String - , flagPort :: Maybe Int - , flagAccessLog :: Maybe String - , flagErrorLog :: Maybe String - , flagUsage :: Bool +instance Show ConfigListen where + show (ListenHttp b p) = "http(" ++ show b ++ ":" ++ show p ++ ")" + show (ListenHttps b p c k) = "https(" ++ show b ++ ":" ++ show p ++ + ", cert = " ++ show c ++ + ", key = " ++ show k ++ ")" + + +------------------------------------------------------------------------------ +-- | A data type to record which backend event loop should be used when +-- serving data. +data ConfigBackend = ConfigSimpleBackend + | ConfigLibEvBackend + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- | 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 9000 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 MonadSnap m => Config m a = Config + { hostname :: Maybe ByteString + -- ^ The name of the server + , listen :: [ConfigListen] + -- ^ The local interfaces to listen on + , accessLog :: Maybe (Maybe FilePath) + -- ^ The path to the access log + , errorLog :: Maybe (Maybe FilePath) + -- ^ The path to the error log + , locale :: Maybe String + -- ^ The locale to use + , backend :: Maybe ConfigBackend + -- ^ The backend to use + , compression :: Maybe Bool + -- ^ Whether to use compression + , verbose :: Maybe Bool + -- ^ Whether to write server status updates to stderr + , errorHandler :: Maybe (SomeException -> m ()) + -- ^ A MonadSnap action to handle 500 errors + , other :: Maybe a + -- ^ This is for any other state needed to initialize a custom server } -instance Monoid Flag where - mempty = Flag Nothing Nothing Nothing Nothing Nothing False - (Flag a1 b1 c1 d1 e1 f1) `mappend` (Flag a2 b2 c2 d2 e2 f2) = - Flag (getLast $ Last a1 `mappend` Last a2) - (getLast $ Last b1 `mappend` Last b2) - (getLast $ Last c1 `mappend` Last c2) - (getLast $ Last d1 `mappend` Last d2) - (getLast $ Last e1 `mappend` Last e2) - (f1 || f2) +------------------------------------------------------------------------------ +instance MonadSnap m => Show (Config m a) where + show c = "Config {" ++ concat (intersperse ", " $ filter (/="") $ map ($c) + [ showM "hostname" . hostname + , showL "listen" . listen + , showM "accessLog" . accessLog + , showM "errorLog" . errorLog + , showM "locale" . locale + , showM "backend" . backend + , showM "compression" . compression + , showM "verbose" . verbose + , showM "errorHandler" . fmap (const ()) . errorHandler + ]) ++ "}" + where + showM s = maybe "" ((++) (s ++ " = ") . show) + showL s l = s ++ " = " ++ show l -flagLH :: String -> Flag -flagLH s = mempty { flagLocalHost = Just s } -flagBA :: String -> Flag -flagBA s = mempty { flagBindAddress = Just s } +------------------------------------------------------------------------------ +-- | Returns a completely empty 'Config'. Equivalent to 'mempty' from +-- 'Config''s 'Monoid' instance. +emptyConfig :: MonadSnap m => Config m a +emptyConfig = mempty -flagPt :: String -> Flag -flagPt p = mempty { flagPort = Just (read p) } -flagAL :: String -> Flag -flagAL s = mempty { flagAccessLog = Just s } +------------------------------------------------------------------------------ +instance MonadSnap m => Monoid (Config m a) where + mempty = Config + { hostname = Nothing + , listen = [] + , accessLog = Nothing + , errorLog = Nothing + , locale = Nothing + , backend = Nothing + , compression = Nothing + , verbose = Nothing + , errorHandler = Nothing + , other = Nothing + } -flagEL :: String -> Flag -flagEL s = mempty { flagErrorLog = Just s } + a `mappend` b = Config + { hostname = (hostname b) `mplus` (hostname a) + , listen = (listen b) ++ (listen a) + , accessLog = (accessLog b) `mplus` (accessLog a) + , errorLog = (errorLog b) `mplus` (errorLog a) + , locale = (locale b) `mplus` (locale a) + , backend = (backend b) `mplus` (backend a) + , compression = (compression b) `mplus` (compression a) + , verbose = (verbose b) `mplus` (verbose a) + , errorHandler = (errorHandler b) `mplus` (errorHandler a) + , other = (other b) `mplus` (other a) + } -flagHelp :: Flag -flagHelp = mempty { flagUsage = True } -fromStr :: String -> ByteString -fromStr = B.pack . map c2w +------------------------------------------------------------------------------ +-- | These are the default values for all the fields in 'Config'. +-- +-- > hostname = "localhost" +-- > listen = [] +-- > accessLog = "log/access.log" +-- > errorLog = "log/error.log" +-- > locale = "en_US" +-- > backend = Nothing (the backend is selected based on compile options) +-- > compression = True +-- > verbose = True +-- > errorHandler = prints the error message +-- +defaultConfig :: MonadSnap m => Config m a +defaultConfig = Config + { hostname = Just "localhost" + , listen = [] + , accessLog = Just $ Just "log/access.log" + , errorLog = Just $ Just "log/error.log" + , locale = Just "en_US" + , backend = Nothing + , compression = Just True + , verbose = Just True + , errorHandler = Just $ \e -> do + let err = U.fromString $ show e + msg = mappend "A web handler threw an exception. Details:\n" err + finishWith $ setContentType "text/plain; charset=utf-8" + . setContentLength (fromIntegral $ B.length msg) + . setResponseStatus 500 "Internal Server Error" + . modifyResponseBody (>==> enumBS msg) + $ emptyResponse + , other = Nothing + } -flags2config :: Flag -> Config -flags2config (Flag a b c d e _) = - Config (maybe "localhost" fromStr a) - (maybe "*" fromStr b) - (fromMaybe 8888 c) - d - e +------------------------------------------------------------------------------ +-- | Completes a partial 'Config' by filling in the unspecified values with +-- the default values from 'defaultConfig'. Also, if no listeners are +-- specified, adds a http listener on 0.0.0.0:8000 +completeConfig :: MonadSnap m => Config m a -> Config m a +completeConfig c = case listen c' of + [] -> addListen (ListenHttp "0.0.0.0" 8000) c' + _ -> c' + where c' = mappend defaultConfig c -options :: [OptDescr Flag] -options = - [ Option "l" ["localHostname"] - (ReqArg flagLH "STR") - "local hostname, default 'localhost'" - , Option "p" ["listenPort"] - (ReqArg flagPt "NUM") - "port to listen on, default 8888" - , Option "b" ["bindAddress"] - (ReqArg flagBA "STR") - "address to bind to, default '*'" - , Option "a" ["accessLog"] - (ReqArg flagAL "STR") - "access log in the 'combined' format, optional" - , Option "e" ["errorLog"] - (ReqArg flagEL "STR") - "error log, optional" - , Option "h" ["help"] - (NoArg flagHelp) - "display this usage statement" ] +------------------------------------------------------------------------------ +-- | A data structure used during command-line option parsing +-- +-- The Config data type allows a list of listen ports, but the command line +-- options only allow one http and one https listener. This data structure +-- is used during option parsing +data MonadSnap m => OptionData m a = OptionData + { config :: Config m a + , bind :: Maybe ByteString + , port :: Maybe Int + , sslbind :: Maybe ByteString + , sslport :: Maybe Int + , sslcert :: Maybe FilePath + , sslkey :: Maybe FilePath + } -readConfigFromCmdLineArgs :: String -- ^ application description, e.g. - -- \"Foo applet v0.2\" - -> IO Config -readConfigFromCmdLineArgs appName = do - argv <- getArgs - progName <- getProgName - case getOpt Permute options argv of - (f,_,[] ) -> withFlags progName f - (_,_,errs) -> bombout progName errs +------------------------------------------------------------------------------ +instance MonadSnap m => Monoid (OptionData m a) where + mempty = OptionData + { config = mempty + , bind = Nothing + , port = Nothing + , sslbind = Nothing + , sslport = Nothing + , sslcert = Nothing + , sslkey = Nothing + } + + a `mappend` b = OptionData + { config = (config b) `mappend` (config a) + , bind = (bind b) `mplus` (bind a) + , port = (port b) `mplus` (port a) + , sslbind = (sslbind b) `mplus` (sslbind a) + , sslport = (sslport b) `mplus` (sslport a) + , sslcert = (sslcert b) `mplus` (sslcert a) + , sslkey = (sslkey b) `mplus` (sslkey a) + } + + +------------------------------------------------------------------------------ +-- | These are the default values for the options +defaultOptions :: MonadSnap m => OptionData m a +defaultOptions = OptionData + { config = defaultConfig + , bind = Just "0.0.0.0" + , port = Just 8000 + , sslbind = Just "0.0.0.0" + , sslport = Nothing + , sslcert = Just "cert.pem" + , sslkey = Just "key.pem" + } + + +------------------------------------------------------------------------------ +-- | Convert options to config +optionsToConfig :: MonadSnap m => OptionData m a -> Config m a +optionsToConfig o = mconcat $ [config o] ++ http ++ https + where lhttp = maybe2 [] ListenHttp (bind o) (port o) + lhttps = maybe4 [] ListenHttps (sslbind o) + (sslport o) + (sslcert o) + (sslkey o) + http = map (flip addListen mempty) lhttp + https = map (flip addListen mempty) lhttps + + maybe2 _ f (Just a) (Just b) = [f a b] + maybe2 d _ _ _ = d + maybe4 _ f (Just a) (Just b) (Just c) (Just d) = [f a b c d] + maybe4 d _ _ _ _ _ = d + + +------------------------------------------------------------------------------ +-- | Convert config to options +configToOptions :: MonadSnap m => Config m a -> OptionData m a +configToOptions c = OptionData + { config = c + , bind = Nothing + , port = Nothing + , sslbind = Nothing + , sslport = Nothing + , sslcert = Nothing + , sslkey = Nothing + } + + +------------------------------------------------------------------------------ +-- | A description of the command-line options accepted by +-- 'commandLineConfig'. +-- +-- The 'OptionData' parameter is just for specifying any default values which +-- are to override those in 'defaultOptions'. This is so the usage message can +-- accurately inform the user what the default values for the options are. In +-- most cases, you will probably just end up passing 'mempty' for this +-- parameter. +-- +-- The return type is a list of options describing @'Maybe' ('OptionData' m)@ +-- as opposed to @'OptionData' m@, because if the @--help@ option is given, +-- the set of command-line options no longer describe a config, but an action +-- (printing out the usage message). +options :: MonadSnap m + => OptionData m a + -> [OptDescr (Maybe (OptionData m a))] +options defaults = + [ Option [] ["hostname"] + (ReqArg (Just . setConfig setHostname . U.fromString) "NAME") + $ "local hostname" ++ defaultC getHostname + , Option ['b'] ["address"] + (ReqArg (\s -> Just $ mempty { bind = Just $ U.fromString 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 $ U.fromString 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 $ read s}) "PATH") + $ "path to ssl certificate in PEM format" ++ defaultO sslcert + , Option [] ["ssl-key"] + (ReqArg (\s -> Just $ mempty { sslkey = Just $ read s}) "PATH") + $ "path to ssl private key in PEM format" ++ defaultO sslkey + , Option [] ["access-log"] + (ReqArg (Just . setConfig setAccessLog . Just) "PATH") + $ "access log" ++ (defaultC $ join . getAccessLog) + , Option [] ["error-log"] + (ReqArg (Just . setConfig setErrorLog . Just) "PATH") + $ "error log" ++ (defaultC $ join . getErrorLog) + , Option [] ["no-access-log"] + (NoArg $ Just $ setConfig setErrorLog Nothing) + $ "don't have an access log" + , Option [] ["no-error-log"] + (NoArg $ Just $ setConfig setAccessLog Nothing) + $ "don't have an error log" + , Option ['c'] ["compression"] + (NoArg $ Just $ setConfig setCompression True) + $ "use gzip compression on responses" + , Option [] ["no-compression"] + (NoArg $ Just $ setConfig setCompression False) + $ "serve responses uncompressed" + , Option ['v'] ["verbose"] + (NoArg $ Just $ setConfig setVerbose True) + $ "print server status updates to stderr" + , Option ['q'] ["quiet"] + (NoArg $ Just $ setConfig setVerbose False) + $ "do not print anything to stderr" + , Option ['h'] ["help"] + (NoArg Nothing) + $ "display this help and exit" + ] where - bombout progName errs = do - let hdr = appName ++ "\n\nUsage: " ++ progName ++ " [OPTIONS]" - let msg = concat errs ++ usageInfo hdr options + setConfig f c = configToOptions $ f c mempty + conf = completeConfig $ config defaults + opts = mappend defaultOptions defaults + defaultC f = maybe "" ((", default " ++) . show) $ f conf + defaultO f = maybe ", default off" ((", default " ++) . show) $ f opts + + +------------------------------------------------------------------------------ +-- | This returns a 'Config' gotten from parsing the options specified on the +-- command-line. +-- +-- The 'Config' parameter is just for specifying any default values which are +-- to override those in 'defaultConfig'. This is so the usage message can +-- accurately inform the user what the default values for the options are. In +-- most cases, you will probably just end up passing 'mempty' for this +-- parameter. +-- +-- On Unix systems, the locale is read from the @LANG@ environment variable. +commandLineConfig :: MonadSnap m => Config m a -> IO (Config m a) +commandLineConfig defaults = do + args <- getArgs + prog <- getProgName + + result <- either (usage prog) return $ case getOpt Permute opts args of + (f, _, [] ) -> maybe (Left []) Right $ fmap mconcat $ sequence f + (_, _, errs) -> Left errs + + let result' = optionsToConfig $ mappend defaultOptions result + +#ifndef PORTABLE + lang <- getEnv "LANG" + return $ mconcat [defaults, result', mempty {locale = fmap upToUtf8 lang}] +#else + return $ mconcat [defaults, result'] +#endif + + where + opts = options $ configToOptions defaults + usage prog errs = do + let hdr = "Usage:\n " ++ prog ++ " [OPTION...]\n\nOptions:" + let msg = concat errs ++ usageInfo hdr opts hPutStrLn stderr msg exitFailure + upToUtf8 = takeWhile $ \c -> isAlpha c || '_' == c - withFlags progName fs = do - let f = mconcat fs - if flagUsage f - then bombout progName [] - else return $ flags2config f + +------------------------------------------------------------------------------ +getHostname :: MonadSnap m => Config m a -> Maybe ByteString +getHostname = hostname + + +------------------------------------------------------------------------------ +getListen :: MonadSnap m => Config m a -> [ConfigListen] +getListen = listen + + +------------------------------------------------------------------------------ +getAccessLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath) +getAccessLog = accessLog + + +------------------------------------------------------------------------------ +getErrorLog :: MonadSnap m => Config m a -> Maybe (Maybe FilePath) +getErrorLog = errorLog + + +------------------------------------------------------------------------------ +getLocale :: MonadSnap m => Config m a -> Maybe String +getLocale = locale + + +------------------------------------------------------------------------------ +getBackend :: MonadSnap m => Config m a -> Maybe ConfigBackend +getBackend = backend + +------------------------------------------------------------------------------ +getCompression :: MonadSnap m => Config m a -> Maybe Bool +getCompression = compression + + +------------------------------------------------------------------------------ +getVerbose :: MonadSnap m => Config m a -> Maybe Bool +getVerbose = verbose + + +------------------------------------------------------------------------------ +getErrorHandler :: MonadSnap m => Config m a -> Maybe (SomeException -> m ()) +getErrorHandler = errorHandler + + +------------------------------------------------------------------------------ +getOther :: MonadSnap m => Config m a -> Maybe a +getOther = other + + +------------------------------------------------------------------------------ +setHostname :: MonadSnap m => ByteString -> Config m a -> Config m a +setHostname a m = m {hostname = Just a} + + +------------------------------------------------------------------------------ +addListen :: MonadSnap m => ConfigListen -> Config m a -> Config m a +addListen a m = m {listen = a : listen m} + + +------------------------------------------------------------------------------ +setAccessLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a +setAccessLog a m = m {accessLog = Just a} + + +------------------------------------------------------------------------------ +setErrorLog :: MonadSnap m => Maybe FilePath -> Config m a -> Config m a +setErrorLog a m = m {errorLog = Just a} + + +------------------------------------------------------------------------------ +setLocale :: MonadSnap m => String -> Config m a -> Config m a +setLocale a m = m {locale = Just a} + + +------------------------------------------------------------------------------ +setBackend :: MonadSnap m => ConfigBackend -> Config m a -> Config m a +setBackend a m = m { backend = Just a} + + +------------------------------------------------------------------------------ +setCompression :: MonadSnap m => Bool -> Config m a -> Config m a +setCompression a m = m {compression = Just a} + + +------------------------------------------------------------------------------ +setVerbose :: MonadSnap m => Bool -> Config m a -> Config m a +setVerbose a m = m {verbose = Just a} + + +------------------------------------------------------------------------------ +setErrorHandler :: MonadSnap m => (SomeException -> m ()) -> Config m a + -> Config m a +setErrorHandler a m = m {errorHandler = Just a} + + +------------------------------------------------------------------------------ +setOther :: MonadSnap m => a -> Config m a -> Config m a +setOther a m = m {other = Just a} 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 @@ -8,7 +8,7 @@ ( IRequest(..) , parseRequest , readChunkedTransferEncoding - , parserToIteratee + , iterParser , parseCookie , parseUrlEncoded , writeChunkedTransferEncoding @@ -20,9 +20,9 @@ import Control.Applicative import Control.Arrow (second) import Control.Monad (liftM) -import "monads-fd" Control.Monad.Trans +import Control.Monad.Trans import Data.Attoparsec hiding (many, Result(..)) -import Data.Attoparsec.Iteratee +import Data.Attoparsec.Enumerator import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -34,17 +34,18 @@ import qualified Data.DList as D import Data.List (foldl') import Data.Int -import Data.Iteratee.WrappedByteString import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes) import qualified Data.Vector.Unboxed as Vec import Data.Vector.Unboxed (Vector) import Data.Word (Word8, Word64) -import Prelude hiding (take, takeWhile) +import Prelude hiding (head, take, takeWhile) ------------------------------------------------------------------------------ -import Snap.Internal.Http.Types hiding (Enumerator) -import Snap.Iteratee hiding (take, foldl', filter) +import Snap.Internal.Http.Types +import Snap.Internal.Debug +import Snap.Internal.Iteratee.Debug +import Snap.Iteratee hiding (map, take) ------------------------------------------------------------------------------ @@ -70,18 +71,17 @@ ------------------------------------------------------------------------------ -parseRequest :: (Monad m) => Iteratee m (Maybe IRequest) -parseRequest = parserToIteratee pRequest +parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest) +parseRequest = iterParser pRequest ------------------------------------------------------------------------------ -readChunkedTransferEncoding :: (Monad m) => - Iteratee m a - -> m (Iteratee m a) -readChunkedTransferEncoding iter = do - i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk) - iter - return i +readChunkedTransferEncoding :: (MonadIO m) => + Enumeratee ByteString ByteString m a +readChunkedTransferEncoding = + chunkParserToEnumeratee $ + iterateeDebugWrapper "pGetTransferChunk" $ + iterParser pGetTransferChunk ------------------------------------------------------------------------------ @@ -108,6 +108,8 @@ -- chunked transfer-encoding. Example usage: -- -- +-- > FIXME this text is now wrong +-- -- > > (writeChunkedTransferEncoding -- > (enumLBS (L.fromChunks ["foo","bar","quux"])) -- > stream2stream) >>= @@ -116,98 +118,91 @@ -- > -- > Chunk "a\r\nfoobarquux\r\n0\r\n\r\n" Empty -- -writeChunkedTransferEncoding :: Enumerator IO a -writeChunkedTransferEncoding it = do - let out = wrap it - return out +writeChunkedTransferEncoding :: Enumeratee ByteString ByteString IO a +writeChunkedTransferEncoding = checkDone start where - wrap iter = bufIt (0,D.empty) iter + start = bufIt 0 D.empty bufSiz = 16284 sendOut :: DList ByteString - -> Iteratee IO a - -> IO (Iteratee IO a) - sendOut dl iter = do + -> (Stream ByteString -> Iteratee ByteString IO a) + -> Iteratee ByteString IO (Step ByteString IO a) + sendOut dl k = do let chunks = D.toList dl let bs = L.fromChunks chunks let n = L.length bs if n == 0 - then return iter + then return $ Continue k else do let o = L.concat [ L.fromChunks [ toHex (toEnum . fromEnum $ n) , "\r\n" ] , bs , "\r\n" ] - enumLBS o iter + lift $ runIteratee $ enumLBS o (Continue k) - bufIt (n,dl) iter = IterateeG $ \s -> do - case s of - (EOF Nothing) -> do - i' <- sendOut dl iter - j <- liftM liftI $ runIter i' (Chunk (WrapBS "0\r\n\r\n")) - runIter j (EOF Nothing) - (EOF e) -> return $ Cont undefined e + bufIt :: Int + -> DList ByteString + -> (Stream ByteString -> Iteratee ByteString IO a) + -> Iteratee ByteString IO (Step ByteString IO a) + bufIt n dl k = do + mbS <- head + case mbS of + Nothing -> do + step <- sendOut dl k + step' <- lift $ runIteratee $ enumBS "0\r\n\r\n" step + lift $ runIteratee $ enumEOF step' - (Chunk (WrapBS x)) -> do - let m = S.length x + (Just s) -> do + let m = S.length s - if m == 0 - then return $ Cont (bufIt (n,dl) iter) Nothing - else do - let n' = m + n - let dl' = D.snoc dl x + if m == 0 + then bufIt n dl k + else do + let n' = m + n + let dl' = D.snoc dl s - if n' > bufSiz - then do - i' <- sendOut dl' iter - return $ Cont (bufIt (0,D.empty) i') Nothing - else return $ Cont (bufIt (n',dl') iter) Nothing + if n' > bufSiz + then do + step <- sendOut dl' k + checkDone start step + else bufIt n' dl' k ------------------------------------------------------------------------------ -chunkParserToEnumerator :: (Monad m) => - Iteratee m (Maybe ByteString) - -> Iteratee m a - -> m (Iteratee m a) -chunkParserToEnumerator getChunk client = return $ do +chunkParserToEnumeratee :: (MonadIO m) => + Iteratee ByteString m (Maybe ByteString) + -> Enumeratee ByteString ByteString m a +chunkParserToEnumeratee getChunk client = do + debug $ "chunkParserToEnumeratee: getting chunk" mbB <- getChunk - maybe (finishIt client) (sendBS client) mbB + debug $ "chunkParserToEnumeratee: getChunk was " ++ show mbB + mbX <- peek + debug $ "chunkParserToEnumeratee: .. and peek is " ++ show mbX - where - sendBS iter s = do - v <- lift $ runIter iter (Chunk $ toWrap $ L.fromChunks [s]) - case v of - (Done _ (EOF (Just e))) -> throwErr e - - (Done x _) -> return x - - (Cont _ (Just e)) -> throwErr e - - (Cont k Nothing) -> joinIM $ - chunkParserToEnumerator getChunk k - - finishIt iter = do - e <- lift $ sendEof iter + maybe finishIt sendBS mbB - case e of - Left x -> throwErr x - Right x -> return x + where + whatWasReturn (Continue _) = "continue" + whatWasReturn (Yield _ z) = "yield, with remainder " ++ show z + whatWasReturn (Error e) = "error, with " ++ show e - sendEof iter = do - v <- runIter iter (EOF Nothing) + sendBS s = do + step' <- lift $ runIteratee $ enumBS s client + debug $ "chunkParserToEnumeratee: after sending " + ++ show s ++ ", return was " + ++ whatWasReturn step' + mbX <- peek + debug $ "chunkParserToEnumeratee: .. and peek is " ++ show mbX + chunkParserToEnumeratee getChunk step' - return $ case v of - (Done _ (EOF (Just e))) -> Left e - (Done x _) -> Right x - (Cont _ (Just e)) -> Left e - (Cont _ _) -> Left $ Err $ "divergent iteratee" + finishIt = lift $ runIteratee $ enumEOF client ------------------------------------------------------------------------------ @@ -252,7 +247,8 @@ ------------------------------------------------------------------------------ -- | Parser for the internal request data type. pRequest :: Parser (Maybe IRequest) -pRequest = (Just <$> pRequest') <|> (endOfInput *> pure Nothing) +pRequest = (Just <$> pRequest') <|> + (option "" crlf *> endOfInput *> pure Nothing) ------------------------------------------------------------------------------ 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 @@ -9,7 +9,6 @@ ------------------------------------------------------------------------------ import Control.Arrow (first, second) import Control.Monad.State.Strict -import Control.Concurrent.MVar import Control.Exception import Data.Char import Data.CIByteString @@ -22,7 +21,6 @@ import qualified Data.ByteString.Nums.Careless.Int as Cvt import Data.Int import Data.IORef -import Data.Iteratee.WrappedByteString (unWrap) import Data.List (foldl') import qualified Data.Map as Map import Data.Maybe (fromJust, catMaybes, fromMaybe) @@ -38,21 +36,21 @@ import Text.Show.ByteString hiding (runPut) ------------------------------------------------------------------------------ import System.FastLogger -import Snap.Internal.Http.Types hiding (Enumerator) +import Snap.Internal.Http.Types +import Snap.Internal.Debug import Snap.Internal.Http.Parser import Snap.Internal.Http.Server.Date + +import Snap.Internal.Http.Server.Backend +import Snap.Internal.Http.Server.HttpPort +import qualified Snap.Internal.Http.Server.GnuTLS as TLS +import Snap.Internal.Http.Server.SimpleBackend +import Snap.Internal.Http.Server.LibevBackend + import Snap.Internal.Iteratee.Debug -import Snap.Iteratee hiding (foldl', head, take, FileOffset) +import Snap.Iteratee hiding (head, take, map) import qualified Snap.Iteratee as I -#ifdef LIBEV -import qualified Snap.Internal.Http.Server.LibevBackend as Backend -import Snap.Internal.Http.Server.LibevBackend (debug) -#else -import qualified Snap.Internal.Http.Server.SimpleBackend as Backend -import Snap.Internal.Http.Server.SimpleBackend (debug) -#endif - import qualified Paths_snap_server as V @@ -66,17 +64,41 @@ -- hidden inside the Snap monad type ServerHandler = (ByteString -> IO ()) -> Request - -> Iteratee IO (Request,Response) + -> Iteratee ByteString IO (Request,Response) -type ServerMonad = StateT ServerState (Iteratee IO) +------------------------------------------------------------------------------ +type ServerMonad = StateT ServerState (Iteratee ByteString IO) + + +------------------------------------------------------------------------------ +data ListenPort = + -- (bind address, port) + HttpPort ByteString Int | + -- (bind address, port, path to certificate, path to key) + HttpsPort ByteString Int FilePath FilePath + + +------------------------------------------------------------------------------ +data EventLoopType = EventLoopSimple + | EventLoopLibEv + deriving (Prelude.Show) + + +------------------------------------------------------------------------------ +defaultEvType :: EventLoopType +#ifdef LIBEV +defaultEvType = EventLoopLibEv +#else +defaultEvType = EventLoopSimple +#endif + + +------------------------------------------------------------------------------ data ServerState = ServerState { _forceConnectionClose :: Bool , _localHostname :: ByteString - , _localAddress :: ByteString - , _localPort :: Int - , _remoteAddr :: ByteString - , _remotePort :: Int + , _sessionPort :: SessionInfo , _logAccess :: Request -> Response -> IO () , _logError :: ByteString -> IO () } @@ -84,17 +106,14 @@ ------------------------------------------------------------------------------ runServerMonad :: ByteString -- ^ local host name - -> ByteString -- ^ local ip address - -> Int -- ^ local port - -> ByteString -- ^ remote ip address - -> Int -- ^ remote port + -> SessionInfo -- ^ session port information -> (Request -> Response -> IO ()) -- ^ access log function -> (ByteString -> IO ()) -- ^ error log function -> ServerMonad a -- ^ monadic action to run - -> Iteratee IO a -runServerMonad lh lip lp rip rp la le m = evalStateT m st + -> Iteratee ByteString IO a +runServerMonad lh s la le m = evalStateT m st where - st = ServerState False lh lip lp rip rp la le + st = ServerState False lh s la le ------------------------------------------------------------------------------ @@ -102,50 +121,56 @@ ------------------------------------------------------------------------------ -httpServe :: ByteString -- ^ bind address, or \"*\" for all - -> Int -- ^ port to bind to - -> ByteString -- ^ local hostname (server name) - -> Maybe FilePath -- ^ path to the access log - -> Maybe FilePath -- ^ path to the error log - -> ServerHandler -- ^ handler procedure +httpServe :: [ListenPort] -- ^ ports to listen on + -> Maybe EventLoopType -- ^ Specify a given event loop, + -- otherwise a default is picked + -> ByteString -- ^ local hostname (server name) + -> Maybe FilePath -- ^ path to the access log + -> Maybe FilePath -- ^ path to the error log + -> ServerHandler -- ^ handler procedure -> IO () -httpServe bindAddress bindPort localHostname alogPath elogPath handler = +httpServe ports mevType localHostname alogPath elogPath handler = withLoggers alogPath elogPath (\(alog, elog) -> spawnAll alog elog) where -------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do + + let evType = maybe defaultEvType id mevType + logE elog $ S.concat [ "Server.httpServe: START (" - , Backend.name, ")"] - let n = numCapabilities - bracket (spawn n) - (\xs -> do - logE elog "Server.httpServe: SHUTDOWN" - Prelude.mapM_ (Backend.stop . fst) xs - logE elog "Server.httpServe: BACKEND STOPPED") - (runAll alog elog) + , toBS $ Prelude.show evType, ")"] + let isHttps p = case p of { (HttpsPort _ _ _ _) -> True; _ -> False;} + let initHttps = foldr (\p b -> b || isHttps p) False ports + if initHttps + then TLS.initTLS + else return () + + nports <- mapM bindPort ports + + (runEventLoop evType nports numCapabilities (logE elog) $ + runHTTP alog elog handler localHostname) `finally` do + + logE elog "Server.httpServe: SHUTDOWN" + + if initHttps + then TLS.stopTLS + else return () + + logE elog "Server.httpServe: BACKEND STOPPED" + -------------------------------------------------------------------------- - runAll alog elog xs = {-# SCC "httpServe/runAll" #-} do - tids <- Prelude.mapM f $ xs `zip` [0..] - Prelude.mapM_ (takeMVar . snd) xs `catch` \ (e::SomeException) -> do - mapM killThread tids - throwIO e - where - f ((backend,mvar),cpu) = forkOnIO cpu $ do - labelMe $ map w2c $ S.unpack $ - S.concat ["accThread ", l2s $ show cpu] - (try $ goooo alog elog backend cpu) :: IO (Either SomeException ()) - putMVar mvar () + bindPort (HttpPort baddr port) = bindHttp baddr port + bindPort (HttpsPort baddr port cert key) = + TLS.bindHttps baddr port cert key -------------------------------------------------------------------------- - goooo alog elog backend cpu = - {-# SCC "httpServe/goooo" #-} - let loop = go alog elog backend cpu >> loop - in loop + runEventLoop EventLoopSimple = simpleEventLoop + runEventLoop EventLoopLibEv = libEvEventLoop -------------------------------------------------------------------------- @@ -162,71 +187,6 @@ maybe (return ()) stopLogger elog) - -------------------------------------------------------------------------- - labelMe :: String -> IO () - labelMe s = do - tid <- myThreadId - labelThread tid s - - - -------------------------------------------------------------------------- - spawn n = do - sock <- Backend.bindIt bindAddress bindPort - backends <- mapM (Backend.new sock) $ [0..(n-1)] - mvars <- replicateM n newEmptyMVar - - return (backends `zip` mvars) - - - -------------------------------------------------------------------------- - runOne alog elog backend cpu = - Backend.withConnection backend cpu $ \conn -> - {-# SCC "httpServe/runOne" #-} do - debug "Server.httpServe.runOne: entered" - let readEnd = Backend.getReadEnd conn - let writeEnd = Backend.getWriteEnd conn - - let raddr = Backend.getRemoteAddr conn - let rport = Backend.getRemotePort conn - let laddr = Backend.getLocalAddr conn - let lport = Backend.getLocalPort conn - - runHTTP localHostname laddr lport raddr rport - alog elog readEnd writeEnd - (Backend.sendFile conn) - (Backend.tickleTimeout conn) handler - - debug "Server.httpServe.runHTTP: finished" - - - -------------------------------------------------------------------------- - go alog elog backend cpu = runOne alog elog backend cpu - `catches` - [ Handler $ \(_ :: Backend.TimeoutException) -> return () - - , Handler $ \(e :: AsyncException) -> do - logE elog $ - S.concat [ "Server.httpServe.go: got async exception, " - , "terminating: ", bshow e ] - throwIO e - - , Handler $ \(e :: Backend.BackendTerminatedException) -> do - logE elog $ - S.concat ["Server.httpServe.go: got backend terminated, " - , "waiting for cleanup" ] - throwIO e - - , Handler $ \(e :: IOException) -> do - logE elog $ - S.concat [ "Server.httpServe.go: got io exception: " - , bshow e ] - - , Handler $ \(e :: SomeException) -> do - logE elog $ - S.concat [ "Server.httpServe.go: got someexception: " - , bshow e ] ] - - ------------------------------------------------------------------------------ debugE :: (MonadIO m) => ByteString -> m () debugE s = debug $ "Server: " ++ (map w2c $ S.unpack s) @@ -272,40 +232,40 @@ ------------------------------------------------------------------------------ -runHTTP :: ByteString -- ^ local host name - -> ByteString -- ^ local ip address - -> Int -- ^ local port - -> ByteString -- ^ remote ip address - -> Int -- ^ remote port - -> Maybe Logger -- ^ access logger +runHTTP :: Maybe Logger -- ^ access logger -> Maybe Logger -- ^ error logger - -> Enumerator IO () -- ^ read end of socket - -> Iteratee IO () -- ^ write end of socket + -> ServerHandler -- ^ handler procedure + -> ByteString -- ^ local host name + -> SessionInfo -- ^ session port information + -> Enumerator ByteString IO () -- ^ read end of socket + -> Iteratee ByteString IO () -- ^ write end of socket -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end -> IO () -- ^ timeout tickler - -> ServerHandler -- ^ handler procedure -> IO () -runHTTP lh lip lp rip rp alog elog - readEnd writeEnd onSendFile tickle handler = +runHTTP alog elog handler lh sinfo readEnd writeEnd onSendFile tickle = go `catches` [ Handler $ \(e :: AsyncException) -> do throwIO e - , Handler $ \(_ :: Backend.TimeoutException) -> return () - , Handler $ \(e :: SomeException) -> logE elog $ S.concat [ logPrefix , bshow e ] ] where - logPrefix = S.concat [ "[", rip, "]: error: " ] + logPrefix = S.concat [ "[", remoteAddress sinfo, "]: error: " ] go = do buf <- mkIterateeBuffer - let iter1 = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $ + let iter1 = runServerMonad lh sinfo (logA alog) (logE elog) $ httpSession writeEnd buf onSendFile tickle handler let iter = iterateeDebugWrapper "httpSession iteratee" iter1 - readEnd iter >>= run + + debug "runHTTP/go: prepping iteratee for start" + + step <- liftIO $ runIteratee iter + + debug "runHTTP/go: running..." + run_ $ readEnd step debug "runHTTP/go: finished" @@ -331,7 +291,7 @@ ------------------------------------------------------------------------------ -- | Runs an HTTP session. -httpSession :: Iteratee IO () -- ^ write end of socket +httpSession :: Iteratee ByteString IO () -- ^ write end of socket -> ForeignPtr CChar -- ^ iteratee buffer -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile continuation @@ -340,12 +300,15 @@ -> ServerMonad () httpSession writeEnd' ibuf onSendFile tickle handler = do - writeEnd1 <- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd' + let writeEnd1 = I.unsafeBufferIterateeWithBuffer ibuf writeEnd' + let writeEndI = iterateeDebugWrapper "writeEnd" writeEnd1 - let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd1 + -- everything downstream expects a Step here + writeEnd <- liftIO $ runIteratee writeEndI liftIO $ debug "Server.httpSession: entered" mreq <- receiveRequest + liftIO $ debug "Server.httpSession: receiveRequest finished" -- successfully got a request, so restart timer liftIO tickle @@ -376,15 +339,24 @@ liftIO $ debug "Server.httpSession: handled, skipping request body" - srqEnum <- liftIO $ readIORef $ rqBody req' - let (SomeEnumerator rqEnum) = srqEnum - lift $ joinIM - $ rqEnum (iterateeDebugWrapper "httpSession/skipToEof" skipToEof) + if rspTransformingRqBody rsp + then liftIO $ debug $ + "Server.httpSession: not skipping " ++ + "request body, transforming." + else do + srqEnum <- liftIO $ readIORef $ rqBody req' + let (SomeEnumerator rqEnum) = srqEnum + + skipStep <- liftIO $ runIteratee $ iterateeDebugWrapper + "httpSession/skipToEof" skipToEof + lift $ rqEnum skipStep + liftIO $ debug $ "Server.httpSession: request body skipped, " ++ "sending response" date <- liftIO getDateString - let ins = Map.insert "Date" [date] . Map.insert "Server" sERVER_HEADER + let ins = Map.insert "Date" [date] . + Map.insert "Server" sERVER_HEADER let rsp' = updateHeaders ins rsp (bytesSent,_) <- sendResponse req rsp' writeEnd onSendFile @@ -409,7 +381,7 @@ ------------------------------------------------------------------------------ checkExpect100Continue :: Request - -> Iteratee IO () + -> Step ByteString IO () -> ServerMonad () checkExpect100Continue req writeEnd = do let mbEx = getHeaders "Expect" req @@ -427,14 +399,17 @@ putAscii '.' showp minor putByteString " 100 Continue\r\n\r\n" - iter <- liftIO $ enumLBS hl writeEnd - liftIO $ run iter + liftIO $ runIteratee $ (enumLBS hl >==> enumEOF) writeEnd + return () ------------------------------------------------------------------------------ receiveRequest :: ServerMonad (Maybe Request) receiveRequest = do - mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift parseRequest + debug "receiveRequest: entered" + mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $ + iterateeDebugWrapper "parseRequest" parseRequest + debug "receiveRequest: parseRequest returned" case mreq of (Just ireq) -> do @@ -449,8 +424,8 @@ where -------------------------------------------------------------------------- - -- check: did the client specify "transfer-encoding: chunked"? then we have - -- to honor that. + -- check: did the client specify "transfer-encoding: chunked"? then we + -- have to honor that. -- -- otherwise: check content-length header. if set: only take N bytes from -- the read end of the socket @@ -458,43 +433,48 @@ -- if no content-length and no chunked encoding, enumerate the entire -- socket and close afterwards setEnumerator :: Request -> ServerMonad () - setEnumerator req = - {-# SCC "receiveRequest/setEnumerator" #-} + setEnumerator req = {-# SCC "receiveRequest/setEnumerator" #-} do if isChunked then do liftIO $ debug $ "receiveRequest/setEnumerator: " ++ "input in chunked encoding" - let e = readChunkedTransferEncoding + let e = joinI . readChunkedTransferEncoding liftIO $ writeIORef (rqBody req) (SomeEnumerator e) - else maybe noContentLength hasContentLength mbCL + else maybe (noContentLength req) hasContentLength mbCL where isChunked = maybe False ((== ["chunked"]) . map toCI) (Map.lookup "transfer-encoding" hdrs) - hasContentLength :: Int -> ServerMonad () - hasContentLength l = do + hasContentLength :: Int64 -> ServerMonad () + hasContentLength len = do liftIO $ debug $ "receiveRequest/setEnumerator: " ++ - "request had content-length " ++ Prelude.show l + "request had content-length " ++ Prelude.show len liftIO $ writeIORef (rqBody req) (SomeEnumerator e) liftIO $ debug "receiveRequest/setEnumerator: body enumerator set" where - e :: Enumerator IO a - e it = return $ joinI $ I.take l $ - iterateeDebugWrapper "rqBody iterator" it - - noContentLength :: ServerMonad () - noContentLength = do - liftIO $ debug ("receiveRequest/setEnumerator: " ++ - "request did NOT have content-length") + e :: Enumerator ByteString IO a + e st = do + st' <- lift $ + runIteratee $ + iterateeDebugWrapper "rqBody iterator" $ + returnI st - -- FIXME: should we not just read everything? - let e = return . joinI . I.take 0 + joinI $ takeExactly len st' - liftIO $ writeIORef (rqBody req) (SomeEnumerator e) - liftIO $ debug "receiveRequest/setEnumerator: body enumerator set" + noContentLength :: Request -> ServerMonad () + noContentLength rq = liftIO $ do + debug ("receiveRequest/setEnumerator: " ++ + "request did NOT have content-length") + let enum = SomeEnumerator $ + if rqMethod rq == POST || rqMethod rq == PUT + then returnI + else iterateeDebugWrapper "noContentLength" . + joinI . I.take 0 + writeIORef (rqBody rq) enum + debug "receiveRequest/setEnumerator: body enumerator set" hdrs = rqHeaders req @@ -521,47 +501,53 @@ liftIO $ debug "parseForm: reading POST body" senum <- liftIO $ readIORef $ rqBody req let (SomeEnumerator enum) = senum - let i = joinI $ takeNoMoreThan maximumPOSTBodySize stream2stream - iter <- liftIO $ enum i - body <- liftM unWrap $ lift iter + consumeStep <- liftIO $ runIteratee consume + step <- liftIO $ + runIteratee $ + joinI $ takeNoMoreThan maximumPOSTBodySize consumeStep + body <- liftM S.concat $ lift $ enum step let newParams = parseUrlEncoded body liftIO $ debug "parseForm: stuffing 'enumBS body' into request" - let e = enumBS body >. enumEof + let e = enumBS body >==> I.joinI . I.take 0 - liftIO $ writeIORef (rqBody req) $ SomeEnumerator $ - e . iterateeDebugWrapper "regurgitate body" + let e' = \st -> do + let ii = iterateeDebugWrapper "regurgitate body" (returnI st) + st' <- lift $ runIteratee ii + e st' + liftIO $ writeIORef (rqBody req) $ SomeEnumerator e' return $ req { rqParams = rqParams req `mappend` newParams } -------------------------------------------------------------------------- toRequest (IRequest method uri version kvps) = {-# SCC "receiveRequest/toRequest" #-} do - localAddr <- gets _localAddress - localPort <- gets _localPort - remoteAddr <- gets _remoteAddr - remotePort <- gets _remotePort - localHostname <- gets _localHostname + localAddr <- gets $ localAddress . _sessionPort + lport <- gets $ localPort . _sessionPort + remoteAddr <- gets $ remoteAddress . _sessionPort + rport <- gets $ remotePort . _sessionPort + localHostname <- gets $ _localHostname + secure <- gets $ isSecure . _sessionPort let (serverName, serverPort) = fromMaybe - (localHostname, localPort) + (localHostname, lport) (liftM (parseHost . head) (Map.lookup "host" hdrs)) -- will override in "setEnumerator" - enum <- liftIO $ newIORef $ SomeEnumerator return + enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "") return $ Request serverName serverPort remoteAddr - remotePort + rport localAddr - localPort + lport localHostname - isSecure + secure hdrs enum mbContentLength @@ -583,8 +569,6 @@ f (a,s') = if a == c2w '/' then s' else s mbS = S.uncons s - isSecure = False - hdrs = toHeaders kvps mbContentLength = liftM (Cvt.int . head) $ @@ -611,8 +595,9 @@ -- Response must be well-formed here sendResponse :: forall a . Request -> Response - -> Iteratee IO a - -> (FilePath -> Int64 -> Int64 -> IO a) + -> Step ByteString IO a -- ^ iteratee write end + -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on + -- sendfile -> ServerMonad (Int64, a) sendResponse req rsp' writeEnd onSendFile = do rsp <- fixupResponse rsp' @@ -625,32 +610,52 @@ (SendFile f (Just (st,_))) -> lift $ whenSendFile headerString rsp f st + debug "sendResponse: response sent" + return $! (bs,x) where -------------------------------------------------------------------------- whenEnum :: ByteString -> Response - -> (forall x . Enumerator IO x) - -> Iteratee IO (a,Int64) + -> (forall x . Enumerator ByteString IO x) + -> Iteratee ByteString IO (a,Int64) whenEnum hs rsp e = do + -- "enum" here has to be run in the context of the READ iteratee, even + -- though it's writing to the output, because we may be transforming + -- the input. That's why we check if we're transforming the request + -- body here, and if not, send EOF to the write end; so that it + -- doesn't join up with the read iteratee and try to get more data + -- from the socket. let enum = if rspTransformingRqBody rsp - then enumBS hs >. e - else enumBS hs >. e >. enumEof + then enumBS hs >==> e + else enumBS hs >==> e >==> (joinI . I.take 0) let hl = fromIntegral $ S.length hs debug $ "sendResponse: whenEnum: enumerating bytes" - (x,bs) <- joinIM $ enum (countBytes writeEnd) - debug $ "sendResponse: whenEnum: " ++ Prelude.show bs ++ " bytes enumerated" + outstep <- lift $ runIteratee $ + iterateeDebugWrapper "countBytes writeEnd" $ + countBytes $ returnI writeEnd + (x,bs) <- enum outstep + debug $ "sendResponse: whenEnum: " ++ Prelude.show bs ++ + " bytes enumerated" + return (x, bs-hl) -------------------------------------------------------------------------- + whenSendFile :: ByteString -- ^ headers + -> Response + -> FilePath -- ^ file to send + -> Int64 -- ^ start byte offset + -> Iteratee ByteString IO (a,Int64) whenSendFile hs r f start = do - -- guaranteed to have a content length here. - joinIM $ (enumBS hs >. enumEof) writeEnd + -- Guaranteed to have a content length here. Sending EOF through to + -- the write end guarantees that we flush the buffer before we send + -- the file with sendfile(). + lift $ runIteratee $ (enumBS hs >==> enumEOF) writeEnd let !cl = fromJust $ rspContentLength r x <- liftIO $ onSendFile f start cl @@ -687,7 +692,10 @@ let r' = setHeader "Transfer-Encoding" "chunked" r let origE = rspBodyToEnum $ rspBody r - let e i = writeChunkedTransferEncoding i >>= origE + let e i = do + step <- lift $ runIteratee $ joinI $ + writeChunkedTransferEncoding i + origE step return $ r' { rspBody = Enum e } @@ -712,8 +720,11 @@ return $ r' { rspBody = b } where - i :: forall z . Enumerator IO z -> Enumerator IO z - i enum iter = enum (joinI $ takeExactly cl iter) + i :: forall z . Enumerator ByteString IO z + -> Enumerator ByteString IO z + i enum step = do + step' <- lift $ runIteratee $ joinI $ takeExactly cl step + enum step' -------------------------------------------------------------------------- @@ -778,8 +789,8 @@ putByteString "\r\n" putHdrs $ headers r putByteString "\r\n" - + ------------------------------------------------------------------------------ checkConnectionClose :: (Int, Int) -> Headers -> ServerMonad () checkConnectionClose ver hdrs = @@ -818,5 +829,3 @@ ------------------------------------------------------------------------------ toBS :: String -> ByteString toBS = S.pack . map c2w - - diff --git a/src/Snap/Internal/Http/Server/Backend.hs b/src/Snap/Internal/Http/Server/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/Backend.hs @@ -0,0 +1,93 @@ +module Snap.Internal.Http.Server.Backend where + +{- + +The server backend is made up of two APIs. + ++ The ListenSocket class abstracts the reading and writing from the network. + We have seperate implementations of ListenSocket for http and https. + ++ The EventLoop function is the interface to accept on the socket. + The EventLoop function will listen on the ports, and for each accepted + connection it wil call the SessionHandler. + +-} + +import Data.ByteString (ByteString) +import Foreign +import Foreign.C +import Network.Socket (Socket) +import Snap.Iteratee (Iteratee, Enumerator) + + +------------------------------------------------------------------------------ +data SessionInfo = SessionInfo + { localAddress :: ByteString + , localPort :: Int + , remoteAddress :: ByteString + , remotePort :: Int + , isSecure :: Bool + } + + +------------------------------------------------------------------------------ +type SessionHandler = + SessionInfo -- ^ session port information + -> Enumerator ByteString IO () -- ^ read end of socket + -> Iteratee ByteString IO () -- ^ write end of socket + -> (FilePath -> Int64 -> Int64 -> IO ()) -- ^ sendfile end + -> IO () -- ^ timeout tickler + -> IO () + + +------------------------------------------------------------------------------ +type EventLoop = [ListenSocket] -- ^ list of ports + -> Int -- ^ number of capabilities + -> (ByteString -> IO ()) -- ^ error log + -> SessionHandler -- ^ session handler + -> IO () + + +{- For performance reasons, we do not implement this as a class +class ListenSocket a where + data ListenSocketSession a :: * + + listenSocket :: a -> Socket + isSecure :: a -> Bool + + closePort :: a -> IO () + + createSession :: a + -> Int -- ^ recv buffer size + -> CInt -- ^ network socket + -> IO () -- ^ action to block waiting for handshake + -> IO (ListenSocketSession a) + + endSession :: a -> ListenSocketSession a -> IO () + + recv :: a + -> IO () -- ^ action to block waiting for data + -> ListenSocketSession a -- ^ session + -> IO (Maybe ByteString) + + send :: a + -> IO () -- ^ action to tickle the timeout + -> IO () -- ^ action to block waiting for data + -> ListenSocketSession a -- ^ session + -> ByteString -- ^ data to send + -> IO () +-} + + +------------------------------------------------------------------------------ +data ListenSocket = ListenHttp Socket + | ListenHttps Socket (Ptr Word) (Ptr Word) + + +------------------------------------------------------------------------------ +data NetworkSession = NetworkSession + { _socket :: CInt + , _session :: Ptr Word + , _recvBuffer :: Ptr CChar + , _recvLen :: CSize + } diff --git a/src/Snap/Internal/Http/Server/Date.hs b/src/Snap/Internal/Http/Server/Date.hs --- a/src/Snap/Internal/Http/Server/Date.hs +++ b/src/Snap/Internal/Http/Server/Date.hs @@ -14,12 +14,7 @@ import Data.Maybe import Foreign.C.Types import System.IO.Unsafe - -#ifndef PORTABLE -import System.Posix.Time -#else -import Data.Time.Clock.POSIX -#endif +import System.PosixCompat.Time import Snap.Internal.Http.Types (formatHttpTime, formatLogTime) @@ -60,15 +55,6 @@ putMVar th t return d - - -#ifdef PORTABLE ------------------------------------------------------------------------------- -epochTime :: IO CTime -epochTime = do - t <- getPOSIXTime - return $ fromInteger $ truncate t -#endif ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Http/Server/GnuTLS.hs b/src/Snap/Internal/Http/Server/GnuTLS.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/GnuTLS.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +module Snap.Internal.Http.Server.GnuTLS + ( GnuTLSException(..) + , initTLS + , stopTLS + , bindHttps + , freePort + , createSession + , endSession + , recv + , send + ) where + + +------------------------------------------------------------------------------ +import Control.Exception +import Data.ByteString (ByteString) +import Data.Dynamic +import Foreign.C + +import Snap.Internal.Http.Server.Backend + +#ifdef GNUTLS +import Control.Monad (liftM) +import qualified Data.ByteString as B +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (w2c) +import Foreign +import qualified Network.Socket as Socket +#endif + + +------------------------------------------------------------------------------ +data GnuTLSException = GnuTLSException String + deriving (Show, Typeable) +instance Exception GnuTLSException + +#ifndef GNUTLS + +initTLS :: IO () +initTLS = throwIO $ GnuTLSException "TLS is not supported" + +stopTLS :: IO () +stopTLS = return () + +bindHttps :: ByteString -> Int -> FilePath -> FilePath -> IO ListenSocket +bindHttps _ _ _ _ = throwIO $ GnuTLSException "TLS is not supported" + +freePort :: ListenSocket -> IO () +freePort _ = return () + +createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession +createSession _ _ _ _ = throwIO $ GnuTLSException "TLS is not supported" + +endSession :: NetworkSession -> IO () +endSession _ = return () + +send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () +send _ _ _ _ = return () + +recv :: IO b -> NetworkSession -> IO (Maybe ByteString) +recv _ _ = throwIO $ GnuTLSException "TLS is not supported" + +#else + + +------------------------------------------------------------------------------- +-- | Init +initTLS :: IO () +initTLS = gnutls_set_threading_helper >> + throwErrorIf "TLS init" gnutls_global_init + + +------------------------------------------------------------------------------- +stopTLS :: IO () +stopTLS = gnutls_global_deinit + + +------------------------------------------------------------------------------- +-- | Binds ssl port +bindHttps :: ByteString + -> Int + -> FilePath + -> FilePath + -> IO ListenSocket +bindHttps bindAddress bindPort cert key = do + sock <- Socket.socket Socket.AF_INET Socket.Stream 0 + addr <- getHostAddr bindPort bindAddress + Socket.setSocketOption sock Socket.ReuseAddr 1 + Socket.bindSocket sock addr + Socket.listen sock 150 + + creds <- loadCredentials cert key + dh <- regenerateDHParam creds + + return $ ListenHttps sock (castPtr creds) (castPtr dh) + + +------------------------------------------------------------------------------- +loadCredentials :: FilePath --- ^ Path to certificate + -> FilePath --- ^ Path to key + -> IO (Ptr GnuTLSCredentials) +loadCredentials cert key = alloca $ \cPtr -> do + throwErrorIf "TLS allocate" $ gnutls_certificate_allocate_credentials cPtr + creds <- peek cPtr + + withCString cert $ \certstr -> withCString key $ \keystr -> + throwErrorIf "TLS set Certificate" $ + gnutls_certificate_set_x509_key_file + creds certstr keystr gnutls_x509_fmt_pem + + return creds + + +------------------------------------------------------------------------------- +regenerateDHParam :: Ptr GnuTLSCredentials -> IO (Ptr GnuTLSDHParam) +regenerateDHParam creds = alloca $ \dhptr -> do + throwErrorIf "TLS allocate" $ gnutls_dh_params_init dhptr + dh <- peek dhptr + throwErrorIf "TLS DHParm" $ gnutls_dh_params_generate2 dh 1024 + gnutls_certificate_set_dh_params creds dh + return dh + + +------------------------------------------------------------------------------- +freePort :: ListenSocket -> IO () +freePort (ListenHttps _ creds dh) = do + gnutls_certificate_free_credentials $ castPtr creds + gnutls_dh_params_deinit $ castPtr dh +freePort _ = return () + + +------------------------------------------------------------------------------- +createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession +createSession (ListenHttps _ creds _) recvSize socket on_block = + alloca $ \sPtr -> do + throwErrorIf "TLS alloacte" $ gnutls_init sPtr 1 + session <- peek sPtr + throwErrorIf "TLS session" $ + gnutls_credentials_set session 1 $ castPtr creds + throwErrorIf "TLS session" $ gnutls_set_default_priority session + gnutls_certificate_send_x509_rdn_sequence session 1 + gnutls_session_enable_compatibility_mode session + + buffer <- mallocBytes $ fromIntegral recvSize + let s = NetworkSession socket (castPtr session) buffer $ + fromIntegral recvSize + + gnutls_transport_set_ptr session $ intPtrToPtr $ fromIntegral $ socket + + handshake s on_block + + return s +createSession _ _ _ _ = error "Invalid socket" + + +------------------------------------------------------------------------------- +endSession :: NetworkSession -> IO () +endSession (NetworkSession _ session buffer _) = do + throwErrorIf "TLS bye" $ gnutls_bye (castPtr session) 1 `finally` do + gnutls_deinit $ castPtr session + free buffer + + +------------------------------------------------------------------------------- +handshake :: NetworkSession -> IO () -> IO () +handshake s@(NetworkSession { _session = session}) on_block = do + rc <- gnutls_handshake $ castPtr session + case rc of + x | x >= 0 -> return () + | isIntrCode x -> handshake s on_block + | isAgainCode x -> on_block >> handshake s on_block + | otherwise -> throwError "TLS handshake" rc + + +------------------------------------------------------------------------------- +send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () +send tickleTimeout onBlock (NetworkSession { _session = session}) bs = + unsafeUseAsCStringLen bs $ uncurry loop + where + loop ptr len = do + sent <- gnutls_record_send (castPtr session) ptr $ fromIntegral len + let sent' = fromIntegral sent + case sent' of + x | x == 0 || x == len -> return () + | x > 0 && x < len -> tickleTimeout >> + loop (plusPtr ptr sent') (len - sent') + | isIntrCode x -> loop ptr len + | isAgainCode x -> onBlock >> loop ptr len + | otherwise -> throwError "TLS send" $ + fromIntegral sent' + + +------------------------------------------------------------------------------ +-- | I originally wrote recv to use mallocBytes and unsafePackCStringFinalizer +-- to achieve zero-copy. The downside to that method is we might waste memory +-- if a malicious adversary only sends us a few bytes, since the entire buffer +-- won't be freed until the ByteString is collected. Thus I use +-- packCStringLen which makes a copy. Perhaps in the future the recv function +-- could be changed to use unsafePackCStringFinalizer if the buffer is at +-- least 3/4 full and packCStringLen otherwise or something like that +recv :: IO b -> NetworkSession -> IO (Maybe ByteString) +recv onBlock (NetworkSession _ session recvBuf recvLen) = loop + where + loop = do + size <- gnutls_record_recv (castPtr session) recvBuf recvLen + let size' = fromIntegral size + case size' of + x | x == 0 -> return Nothing + | x > 0 -> liftM Just $ B.packCStringLen (recvBuf, x) + | isIntrCode x -> loop + | isAgainCode x -> onBlock >> loop + | otherwise -> (throwError "TLS recv" $ fromIntegral size') + >> return Nothing + + +------------------------------------------------------------------------------ +throwError :: String -> ReturnCode -> IO () +throwError prefix rc = gnutls_strerror rc >>= + peekCString >>= + throwIO . GnuTLSException . (prefix'++) + where + prefix' = prefix ++ "<" ++ show rc ++ ">: " + + +------------------------------------------------------------------------------ +throwErrorIf :: String -> IO ReturnCode -> IO () +throwErrorIf prefix action = do + rc <- action + if (rc < 0) + then throwError prefix rc + else return () + + +------------------------------------------------------------------------------ +isAgainCode :: (Integral a) => a -> Bool +isAgainCode x = (fromIntegral x) == (-28 :: Int) + + +------------------------------------------------------------------------------ +isIntrCode :: (Integral a) => a -> Bool +isIntrCode x = (fromIntegral x) == (-52 :: Int) + + +------------------------------------------------------------------------------ +getHostAddr :: Int + -> ByteString + -> IO Socket.SockAddr +getHostAddr p s = do + h <- if s == "*" + then return Socket.iNADDR_ANY + else Socket.inet_addr (map w2c . B.unpack $ s) + + return $ Socket.SockAddrInet (fromIntegral p) h + +-- Types + +newtype ReturnCode = ReturnCode CInt + deriving (Show, Eq, Ord, Num, Real, Enum, Integral) + +data GnuTLSCredentials +data GnuTLSSession +data GnuTLSDHParam + +-- Global init/errors + +foreign import ccall safe "gnutls_set_threading_helper" + gnutls_set_threading_helper :: IO () + +foreign import ccall safe "gnutls/gnutls.h gnutls_global_init" + gnutls_global_init :: IO ReturnCode + +foreign import ccall safe "gnutls/gnutls.h gnutls_global_deinit" + gnutls_global_deinit :: IO () + +foreign import ccall safe "gnutls/gnutls.h gnutls_strerror" + gnutls_strerror :: ReturnCode -> IO CString + +-- Sessions. All functions here except handshake and bye just +-- allocate memory or update members of structures, so they are ok with +-- unsafe ccall. + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_init" + gnutls_init :: Ptr (Ptr GnuTLSSession) -> CInt -> IO ReturnCode + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_deinit" + gnutls_deinit :: Ptr GnuTLSSession -> IO () + +foreign import ccall safe "gnutls/gnutls.h gnutls_handshake" + gnutls_handshake :: Ptr GnuTLSSession -> IO ReturnCode + +foreign import ccall safe "gnutls/gnutls.h gnutls_bye" + gnutls_bye :: Ptr GnuTLSSession -> CInt -> IO ReturnCode + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_set_default_priority" + gnutls_set_default_priority :: Ptr GnuTLSSession -> IO ReturnCode + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_session_enable_compatibility_mode" + gnutls_session_enable_compatibility_mode :: Ptr GnuTLSSession -> IO () + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_certificate_send_x509_rdn_sequence" + gnutls_certificate_send_x509_rdn_sequence :: Ptr GnuTLSSession -> CInt -> IO () + +-- Certificates. Perhaps these could be unsafe but they are not performance critical, +-- since they are called only once during server startup. + +foreign import ccall safe "gnutls/gnutls.h gnutls_certificate_allocate_credentials" + gnutls_certificate_allocate_credentials :: Ptr (Ptr GnuTLSCredentials) -> IO ReturnCode + +foreign import ccall safe "gnutls/gnutls.h gnutls_certificate_free_credentials" + gnutls_certificate_free_credentials :: Ptr GnuTLSCredentials -> IO () + +gnutls_x509_fmt_pem :: CInt +gnutls_x509_fmt_pem = 1 + +foreign import ccall safe "gnutls/gnutls.h gnutls_certificate_set_x509_key_file" + gnutls_certificate_set_x509_key_file :: Ptr GnuTLSCredentials -> CString -> CString -> CInt -> IO ReturnCode + + +-- Credentials. This is ok as unsafe because it just sets members in the session structure. + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_credentials_set" + gnutls_credentials_set :: Ptr GnuTLSSession -> CInt -> Ptr a -> IO ReturnCode + +-- Records. These are marked unsafe because they are very performance critical. Since +-- we are using non-blocking sockets send and recv will not block. + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_transport_set_ptr" + gnutls_transport_set_ptr :: Ptr GnuTLSSession -> Ptr a -> IO () + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_record_recv" + gnutls_record_recv :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize + +foreign import ccall unsafe "gnutls/gnutls.h gnutls_record_send" + gnutls_record_send :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize + +-- DHParam. Perhaps these could be unsafe but they are not performance critical. + +foreign import ccall safe "gnutls/gnutls.h gnutls_dh_params_init" + gnutls_dh_params_init :: Ptr (Ptr GnuTLSDHParam) -> IO ReturnCode + +foreign import ccall safe "gnutls/gnutls.h gnutls_dh_params_deinit" + gnutls_dh_params_deinit :: Ptr GnuTLSDHParam -> IO () + +foreign import ccall safe "gnutls/gnutls.h gnutls_dh_params_generate2" + gnutls_dh_params_generate2 :: Ptr GnuTLSDHParam -> CUInt -> IO ReturnCode + +foreign import ccall safe "gnutls/gnutls.h gnutls_certificate_set_dh_params" + gnutls_certificate_set_dh_params :: Ptr GnuTLSCredentials -> Ptr GnuTLSDHParam -> IO () + +#endif diff --git a/src/Snap/Internal/Http/Server/HttpPort.hs b/src/Snap/Internal/Http/Server/HttpPort.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/HttpPort.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +module Snap.Internal.Http.Server.HttpPort + ( bindHttp + , createSession + , endSession + , recv + , send + ) where + + +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Internal (w2c) +import Foreign +import Foreign.C +import Network.Socket hiding (recv, send) + +#ifdef PORTABLE +import qualified Network.Socket.ByteString as SB +#else +import Control.Monad (liftM) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +#endif + +import Snap.Internal.Http.Server.Backend + + +------------------------------------------------------------------------------ +bindHttp :: ByteString -> Int -> IO ListenSocket +bindHttp bindAddr bindPort = do + sock <- socket AF_INET Stream 0 + addr <- getHostAddr bindPort bindAddr + setSocketOption sock ReuseAddr 1 + bindSocket sock addr + listen sock 150 + return $ ListenHttp sock + + +------------------------------------------------------------------------------ +getHostAddr :: Int + -> ByteString + -> IO SockAddr +getHostAddr p s = do + h <- if s == "*" + then return iNADDR_ANY + else inet_addr (map w2c . B.unpack $ s) + + return $ SockAddrInet (fromIntegral p) h + + +------------------------------------------------------------------------------ +createSession :: Int -> CInt -> IO () -> IO NetworkSession +createSession buffSize s _ = do + buffer <- mallocBytes $ fromIntegral buffSize + return $ NetworkSession s nullPtr buffer $ fromIntegral buffSize + + +------------------------------------------------------------------------------ +endSession :: NetworkSession -> IO () +endSession (NetworkSession {_recvBuffer = buff}) = free buff + +#ifdef PORTABLE + +------------------------------------------------------------------------------ +recv :: Socket -> IO () -> NetworkSession -> IO (Maybe ByteString) +recv sock _ (NetworkSession { _recvLen = s }) = do + bs <- SB.recv sock (fromIntegral s) + if B.null bs + then return Nothing + else return $ Just bs + + +------------------------------------------------------------------------------ +send :: Socket -> IO () -> IO () -> NetworkSession -> ByteString -> IO () +send sock tickle _ _ bs = SB.sendAll sock bs >> tickle + +#else + +------------------------------------------------------------------------------ +recv :: IO () -> NetworkSession -> IO (Maybe ByteString) +recv onBlock (NetworkSession s _ buff buffSize) = do + sz <- throwErrnoIfMinus1RetryMayBlock + "recv" + (c_read s buff buffSize) + onBlock + if sz == 0 + then return Nothing + else liftM Just $ B.packCStringLen (buff, fromIntegral sz) + + +------------------------------------------------------------------------------ +send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () +send tickleTimeout onBlock (NetworkSession s _ _ _) bs = + unsafeUseAsCStringLen bs $ uncurry loop + where loop ptr len = do + sent <- throwErrnoIfMinus1RetryMayBlock + "send" + (c_write s ptr $ fromIntegral len) + onBlock + + let sent' = fromIntegral sent + if sent' < len + then tickleTimeout >> loop (plusPtr ptr sent') (len - sent') + else return () + + +------------------------------------------------------------------------------ +foreign import ccall unsafe "unistd.h read" c_read + :: CInt -> Ptr a -> CSize -> IO (CSize) +foreign import ccall unsafe "unistd.h write" c_write + :: CInt -> Ptr a -> CSize -> IO (CSize) + +#endif diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs --- a/src/Snap/Internal/Http/Server/LibevBackend.hs +++ b/src/Snap/Internal/Http/Server/LibevBackend.hs @@ -8,46 +8,43 @@ {-# LANGUAGE PackageImports #-} module Snap.Internal.Http.Server.LibevBackend - ( Backend - , BackendTerminatedException(..) - , Connection - , TimeoutException(..) - , name - , debug - , bindIt - , new - , stop - , withConnection - , sendFile - , tickleTimeout - , getReadEnd - , getWriteEnd - , getRemoteAddr - , getRemotePort - , getLocalAddr - , getLocalPort + ( 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 +import Control.Concurrent hiding (yield) import Control.Exception import Control.Monad -import "monads-fd" Control.Monad.Trans +import Control.Monad.Trans import Data.ByteString (ByteString) -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString.Unsafe as B -import qualified Data.ByteString as B +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString as S +import Data.Maybe import Data.IORef -import Data.Iteratee.WrappedByteString import Data.Typeable import Foreign hiding (new) -import Foreign.C.Error import Foreign.C.Types -import GHC.Conc (forkOnIO, numCapabilities) +import GHC.Conc (forkOnIO) import Network.Libev import Network.Socket import Prelude hiding (catch) @@ -56,9 +53,11 @@ -- FIXME: should be HashSet, make that later. import qualified Data.Concurrent.HashMap as H import Data.Concurrent.HashMap (HashMap) -import Snap.Iteratee +import Snap.Iteratee hiding (map) import Snap.Internal.Debug import Snap.Internal.Http.Server.Date +import Snap.Internal.Http.Server.Backend +import qualified Snap.Internal.Http.Server.ListenHelpers as Listen #if defined(HAS_SENDFILE) import qualified System.SendFile as SF @@ -66,13 +65,13 @@ import System.Posix.Types (Fd(..)) #endif + +------------------------------------------------------------------------------ data Backend = Backend - { _acceptSocket :: !Socket - , _acceptFd :: !CInt - , _connectionQueue :: !(Chan CInt) + { _acceptSockets :: [ListenSocket] , _evLoop :: !EvLoopPtr - , _acceptIOCallback :: !(FunPtr IoCallback) - , _acceptIOObj :: !EvIoPtr + , _acceptIOCallbacks :: ![MVar (FunPtr IoCallback)] + , _acceptIOObjs :: ![EvIoPtr] , _mutexCallbacks :: !(FunPtr MutexCallback, FunPtr MutexCallback) , _loopLock :: !(MVar ()) , _asyncCb :: !(FunPtr AsyncCallback) @@ -81,18 +80,16 @@ , _killObj :: !EvAsyncPtr , _connectionThreads :: !(HashMap ThreadId Connection) , _backendCPU :: !Int - , _backendFreed :: !(MVar ()) + , _loopExit :: !(MVar ()) } +------------------------------------------------------------------------------ data Connection = Connection { _backend :: !Backend - , _socket :: !Socket - , _socketFd :: !CInt - , _remoteAddr :: !ByteString - , _remotePort :: !Int - , _localAddr :: !ByteString - , _localPort :: !Int + , _listenSocket :: !ListenSocket + , _rawSocket :: !CInt + , _sessionInfo :: !SessionInfo , _readAvailable :: !(MVar ()) , _writeAvailable :: !(MVar ()) , _timerObj :: !EvTimerPtr @@ -104,75 +101,29 @@ , _connReadIOCallback :: !(FunPtr IoCallback) , _connWriteIOObj :: !EvIoPtr , _connWriteIOCallback :: !(FunPtr IoCallback) - , _connThread :: !(MVar ThreadId) + , _connThread :: !(ThreadId) } -{-# INLINE name #-} -name :: ByteString -name = "libev" - -sendFile :: Connection -> FilePath -> Int64 -> Int64 -> IO () -sendFile c 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) - bracket (openFd fp ReadOnly Nothing defaultFileFlags) - (closeFd) - (go start sz) -#else - enumFilePartial fp (start,start+sz) (getWriteEnd c) >>= run - 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 sfd fd off bytes - if sent < bytes - then tickleTimeout c >> go (off+sent) (bytes-sent) fd - else return () - - sfd = Fd $ _socketFd c -#endif - io = _connWriteIOObj c - b = _backend c - loop = _evLoop b - lock = _loopLock b - asy = _asyncObj b - +------------------------------------------------------------------------------ +libEvEventLoop :: EventLoop +libEvEventLoop sockets cap elog handler = do + backends <- Prelude.mapM (newLoop sockets handler elog) [0..(cap-1)] -bindIt :: ByteString -- ^ bind address, or \"*\" for all - -> Int -- ^ port to bind to - -> IO (Socket,CInt) -bindIt bindAddress bindPort = do - sock <- socket AF_INET Stream 0 - addr <- getHostAddr bindPort bindAddress - setSocketOption sock ReuseAddr 1 - bindSocket sock addr - listen sock 150 - let sockFd = fdSocket sock - c_setnonblocking sockFd - return (sock, sockFd) + debug "libevEventLoop: waiting for loop exit" + Prelude.mapM_ (takeMVar . _loopExit) backends `finally` do + debug "libevEventLoop: stopping all backends" + mapM stop backends + mapM Listen.closeSocket sockets -new :: (Socket,CInt) -- ^ value you got from bindIt - -> Int -- ^ cpu - -> IO Backend -new (sock,sockFd) cpu = do - connq <- newChan - +------------------------------------------------------------------------------ +newLoop :: [ListenSocket] -- ^ value you got from bindIt + -> SessionHandler -- ^ handler + -> (ByteString -> IO ()) -- ^ error logger + -> Int -- ^ cpu + -> IO Backend +newLoop 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 @@ -201,12 +152,9 @@ evAsyncInit killObj killCB evAsyncStart lp killObj - -- setup the accept callback; this watches for read readiness on the listen - -- port - accCB <- mkIoCallback $ acceptCallback sockFd connq - accIO <- mkEvIo - evIoInit accIO accCB sockFd ev_read - evIoStart lp accIO + -- create the ios for the accept callbacks + accMVars <- forM sockets $ \_ -> newEmptyMVar + accIOs <- forM sockets $ \_ -> mkEvIo -- thread set stuff connSet <- H.new (H.hashString . show) @@ -214,12 +162,10 @@ -- freed gets stuffed with () when all resources are released. freed <- newEmptyMVar - let b = Backend sock - sockFd - connq + let b = Backend sockets lp - accCB - accIO + accMVars + accIOs (mc1,mc2) looplock asyncCB @@ -230,12 +176,21 @@ 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 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 $ "Backend.new: loop spawned" + debug $ "LibEv.newLoop: loop spawned" return b +------------------------------------------------------------------------------ -- | Run evLoop in a thread loopThread :: Backend -> IO () loopThread backend = do @@ -246,29 +201,44 @@ cleanup = block $ do debug $ "loopThread: cleaning up" ignoreException $ freeBackend backend - putMVar (_backendFreed backend) () + putMVar (_loopExit backend) () lock = _loopLock backend loop = _evLoop backend go = takeMVar lock >> block (evLoop loop 0) -acceptCallback :: CInt -> Chan CInt -> IoCallback -acceptCallback accFd chan _loopPtr _ioPtr _ = do +------------------------------------------------------------------------------ +acceptCallback :: Backend + -> SessionHandler + -> (ByteString -> IO ()) + -> Int + -> ListenSocket + -> IoCallback +acceptCallback back handler elog cpu sock _loopPtr _ioPtr _ = do debug "inside acceptCallback" - r <- c_accept accFd + 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 "Backend.acceptCallback:c_accept()" + -1 -> debugErrno "Libev.acceptCallback:c_accept()" fd -> do debug $ "acceptCallback: accept()ed fd, writing to chan " ++ show fd - writeChan chan fd + forkOnIO cpu $ (go r `catches` cleanup) + return () + where + go = runSession back handler sock + cleanup = [ Handler $ \(_ :: TimeoutException) -> 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 @@ -279,6 +249,7 @@ writeIORef active False +------------------------------------------------------------------------------ ioWriteCallback :: CInt -> IORef Bool -> MVar () -> IoCallback ioWriteCallback fd active wa _loopPtr _ioPtr _ = do -- send notifications to the worker thread @@ -289,78 +260,72 @@ writeIORef active False +------------------------------------------------------------------------------ stop :: Backend -> IO () stop b = ignoreException $ do - debug $ "Backend.stop" + debug $ "Libev.stop" -- 1. take the loop lock -- 2. shut down the accept() callback - -- 3. stuff a poison pill (a bunch of -1 values should do) down the - -- connection queue so that withConnection knows to throw an exception - -- back up to its caller - -- 4. call evUnloop and wake up the loop using evAsyncSend - -- 5. release the loop lock, the main loop thread should then free/clean + -- 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) - -- 6. wait for the loop thread to signal it has cleaned up and exited withMVar lock $ \_ -> do - evIoStop loop acceptObj - replicateM_ (numCapabilities*2) $ writeChan connQ (-1) + forM acceptObjs $ evIoStop loop evUnloop loop evunloop_all evAsyncSend loop killObj - debug $ "accepting threads killed, unloop sent, waiting for completion" - takeMVar $ _backendFreed b - where loop = _evLoop b - acceptObj = _acceptIOObj b + acceptObjs = _acceptIOObjs b killObj = _killObj b lock = _loopLock b - connQ = _connectionQueue b - +------------------------------------------------------------------------------ getAddr :: SockAddr -> IO (ByteString, Int) getAddr addr = case addr of SockAddrInet p ha -> do - s <- liftM (B.pack . map c2w) (inet_ntoa ha) + s <- liftM (S.pack . map c2w) (inet_ntoa ha) return (s, fromIntegral p) a -> throwIO $ AddressNotSupportedException (show a) --- | throw a timeout exception to the handling thread -- it'll clean up --- everything +------------------------------------------------------------------------------ +-- | 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? - -> MVar ThreadId -- ^ thread to kill + -> ThreadId -- ^ thread to kill -> TimerCallback -timerCallback loop tmr ioref tmv _ _ _ = do - debug "Backend.timerCallback: entered" +timerCallback loop tmr ioref tid _ _ _ = do + debug "Libev.timerCallback: entered" now <- getCurrentDateTime whenToDie <- readIORef ioref if whenToDie <= now then do - debug "Backend.timerCallback: killing thread" - tid <- readMVar tmv + debug "Libev.timerCallback: killing thread" throwTo tid TimeoutException else do - debug $ "Backend.timerCallback: now=" ++ show now + 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 +------------------------------------------------------------------------------ +-- | If you already hold the loop lock, you are entitled to destroy a +-- connection destroyConnection :: Connection -> IO () destroyConnection conn = do - debug "Backend.destroyConnection: closing socket and killing connection" + debug "Libev.destroyConnection: closing socket and killing connection" c_close fd -- stop and free timer object @@ -381,7 +346,7 @@ backend = _backend conn loop = _evLoop backend - fd = _socketFd conn + fd = _rawSocket conn ioWrObj = _connWriteIOObj conn ioWrCb = _connWriteIOCallback conn ioRdObj = _connReadIOObj conn @@ -390,12 +355,13 @@ timerCb = _timerCallback conn +------------------------------------------------------------------------------ freeConnection :: Connection -> IO () freeConnection conn = ignoreException $ do withMVar loopLock $ \_ -> block $ do - debug $ "freeConnection (" ++ show fd ++ ")" + debug $ "freeConnection (" ++ show (_rawSocket conn) ++ ")" destroyConnection conn - tid <- readMVar $ _connThread conn + let tid = _connThread conn -- remove the thread id from the backend set H.delete tid $ _connectionThreads backend @@ -408,13 +374,14 @@ loop = _evLoop backend loopLock = _loopLock backend asyncObj = _asyncObj backend - fd = _socketFd conn +------------------------------------------------------------------------------ ignoreException :: IO () -> IO () ignoreException = handle (\(_::SomeException) -> return ()) +------------------------------------------------------------------------------ freeBackend :: Backend -> IO () freeBackend backend = ignoreException $ block $ do -- note: we only get here after an unloop, so we have the loop lock @@ -425,7 +392,7 @@ let nthreads = Prelude.length tset - debug $ "Backend.freeBackend: killing active connection threads" + debug $ "Libev.freeBackend: killing active connection threads" Prelude.mapM_ (destroyConnection . snd) tset @@ -434,12 +401,13 @@ Prelude.mapM_ (killThread . fst) tset Prelude.mapM_ (killThread . fst) tset - debug $ "Backend.freeBackend: " ++ show nthreads ++ " thread(s) killed" - debug $ "Backend.freeBackend: destroying libev resources" + debug $ "Libev.freeBackend: " ++ show nthreads ++ " thread(s) killed" + debug $ "Libev.freeBackend: destroying libev resources" - freeEvIo acceptObj - freeIoCallback acceptCb - c_close fd + mapM freeEvIo acceptObjs + forM acceptCbs $ \x -> do + acceptCb <- readMVar x + freeIoCallback acceptCb evAsyncStop loop asyncObj freeEvAsync asyncObj @@ -453,12 +421,11 @@ freeMutexCallback mcb2 evLoopDestroy loop - debug $ "Backend.freeBackend: resources destroyed" + debug $ "Libev.freeBackend: resources destroyed" where - fd = _acceptFd backend - acceptObj = _acceptIOObj backend - acceptCb = _acceptIOCallback backend + acceptObjs = _acceptIOObjs backend + acceptCbs = _acceptIOCallbacks backend asyncObj = _asyncObj backend asyncCb = _asyncCb backend killObj = _killObj backend @@ -467,116 +434,111 @@ loop = _evLoop backend +------------------------------------------------------------------------------ -- | Note: proc gets run in the background -withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () -withConnection backend cpu proc = go - where - threadProc conn = (do - x <- blocked - debug $ "withConnection/threadProc: we are blocked? " ++ show x - proc conn) `finally` freeConnection conn - - go = do - debug $ "withConnection: reading from chan" - fd <- readChan $ _connectionQueue backend - debug $ "withConnection: got fd " ++ show fd - - -- if fd < 0 throw an exception here (because this only happens if stop - -- is called) - when (fd < 0) $ throwIO BackendTerminatedException - - sock <- mkSocket fd AF_INET Stream 0 Connected - peerName <- getPeerName sock - sockName <- getSocketName sock +runSession :: Backend + -> SessionHandler + -> ListenSocket + -> CInt + -> IO () +runSession 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 + -- set_linger fd + c_setnonblocking fd - (remoteAddr, remotePort) <- getAddr peerName - (localAddr, localPort) <- getAddr sockName + (raddr, rport) <- getAddr peerName + (laddr, lport) <- getAddr sockName - let lp = _evLoop backend + 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 () + -- 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 - thrmv <- newEmptyMVar - now <- getCurrentDateTime - timeoutTime <- newIORef $ now + 20 - tcb <- mkTimerCallback $ timerCallback lp - tmr - timeoutTime - thrmv - -- 20 second timeout - evTimerInit tmr tcb 0 20.0 + ----------------- + -- setup timer -- + ----------------- + tmr <- mkEvTimer + now <- getCurrentDateTime + timeoutTime <- newIORef $ now + 20 + tcb <- mkTimerCallback $ timerCallback lp + tmr + timeoutTime + tid + -- 20 second timeout + evTimerInit tmr tcb 0 20.0 - readActive <- newIORef True - writeActive <- newIORef True - - evioRead <- mkEvIo - ioReadCb <- mkIoCallback $ ioReadCallback fd readActive ra + readActive <- newIORef True + writeActive <- newIORef True - evioWrite <- mkEvIo - ioWriteCb <- mkIoCallback $ ioWriteCallback fd writeActive wa + evioRead <- mkEvIo + ioReadCb <- mkIoCallback $ ioReadCallback fd readActive ra - evIoInit evioRead ioReadCb fd ev_read - evIoInit evioWrite ioWriteCb fd ev_write + evioWrite <- mkEvIo + ioWriteCb <- mkIoCallback $ ioWriteCallback fd writeActive wa - -- take ev_loop lock, start timer and io watchers - withMVar (_loopLock backend) $ \_ -> do - evTimerAgain lp tmr - evIoStart lp evioRead - evIoStart lp evioWrite + evIoInit evioRead ioReadCb fd ev_read + evIoInit evioWrite ioWriteCb fd ev_write - -- wakeup the loop thread so that these new watchers get - -- registered next time through the loop - evAsyncSend lp $ _asyncObj backend + -- take ev_loop lock, start timer and io watchers + withMVar (_loopLock backend) $ \_ -> do + evTimerAgain lp tmr + evIoStart lp evioRead + evIoStart lp evioWrite - let conn = Connection backend - sock - fd - remoteAddr - remotePort - localAddr - localPort - ra - wa - tmr - tcb - timeoutTime - readActive - writeActive - evioRead - ioReadCb - evioWrite - ioWriteCb - thrmv + -- 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 - tid <- forkOnIO cpu $ threadProc conn + bracket (Listen.createSession lsock bLOCKSIZE fd $ + waitForLock True conn) + (\session -> block $ do + debug "runSession: thread killed, closing socket" - H.update tid conn (_connectionThreads backend) - putMVar thrmv tid + eatException $ Listen.endSession lsock session + eatException $ freeConnection conn + ) + (\session -> do H.update tid conn (_connectionThreads backend) + handler sinfo + (enumerate conn session) + (writeOut conn session) + (sendFile conn session) + (tickleTimeout conn) + ) -data BackendTerminatedException = BackendTerminatedException - deriving (Typeable) - -instance Show BackendTerminatedException where - show BackendTerminatedException = "Backend terminated" - -instance Exception BackendTerminatedException - +------------------------------------------------------------------------------ +eatException :: IO a -> IO () +eatException act = (act >> return ()) `catch` \(_::SomeException) -> return () +------------------------------------------------------------------------------ data AddressNotSupportedException = AddressNotSupportedException String deriving (Typeable) @@ -586,33 +548,8 @@ instance Exception AddressNotSupportedException -getRemoteAddr :: Connection -> ByteString -getRemoteAddr = _remoteAddr - -getRemotePort :: Connection -> Int -getRemotePort = _remotePort - -getLocalAddr :: Connection -> ByteString -getLocalAddr = _localAddr - -getLocalPort :: Connection -> Int -getLocalPort = _localPort - ------------------------------------------------------------------------------ --- fixme: new function name -getHostAddr :: Int - -> ByteString - -> IO SockAddr -getHostAddr p s = do - h <- if s == "*" - then return iNADDR_ANY - else inet_addr (map w2c . B.unpack $ s) - - return $ SockAddrInet (fromIntegral p) h - - - bLOCKSIZE :: Int bLOCKSIZE = 8192 @@ -620,10 +557,12 @@ -- 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. +-- 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) @@ -632,149 +571,157 @@ instance Exception TimeoutException + +------------------------------------------------------------------------------ tickleTimeout :: Connection -> IO () tickleTimeout conn = do - debug "Backend.tickleTimeout" + debug "Libev.tickleTimeout" now <- getCurrentDateTime writeIORef (_timerTimeoutTime conn) (now + 30) -recvData :: Connection -> Int -> IO ByteString -recvData conn n = do - dbg "entered" - allocaBytes n $ \cstr -> do - sz <- throwErrnoIfMinus1RetryMayBlock - "recvData" - (c_read fd cstr (toEnum n)) - waitForLock - - -- we got activity, but don't do restart timer due to the - -- slowloris attack +------------------------------------------------------------------------------ +waitForLock :: Bool -- ^ True = wait for read, False = wait for write + -> Connection + -> IO () +waitForLock readLock conn = do + dbg "start waitForLock" - dbg $ "sz returned " ++ show sz + 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 - if sz == 0 - then return "" - else B.packCStringLen ((castPtr cstr),(fromEnum sz)) + dbg "waitForLock: waiting for mvar" + takeMVar lock + dbg "waitForLock: took mvar" where - io = _connReadIOObj conn + dbg s = debug $ "Libev.recvData(" ++ show (_rawSocket conn) ++ "): " + ++ s + io = if readLock + then (_connReadIOObj conn) + else (_connWriteIOObj conn) bk = _backend conn - active = _readActive conn + active = if readLock + then (_readActive conn) + else (_writeActive conn) lp = _evLoop bk looplock = _loopLock bk async = _asyncObj bk - - dbg s = debug $ "Backend.recvData(" ++ show (_socketFd conn) ++ "): " ++ s - - fd = _socketFd conn - lock = _readAvailable conn - waitForLock = 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" + lock = if readLock + then (_readAvailable conn) + else (_writeAvailable conn) -sendData :: Connection -> ByteString -> IO () -sendData conn bs = do - let len = B.length bs - dbg $ "entered w/ " ++ show len ++ " bytes" - written <- B.unsafeUseAsCString bs $ \cstr -> - throwErrnoIfMinus1RetryMayBlock - "sendData" - (c_write fd cstr (toEnum len)) - waitForLock - - -- we got activity, so restart timer - tickleTimeout conn +------------------------------------------------------------------------------ +sendFile :: Connection -> NetworkSession -> FilePath -> Int64 -> Int64 + -> IO () +sendFile 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 - let n = fromEnum written - let last10 = B.drop (n-10) $ B.take n bs +#if defined(HAS_SENDFILE) + case (_listenSocket c) of + ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags) + (closeFd) + (go start sz) + _ -> do + step <- runIteratee $ writeOut c s + run_ $ enumFilePartial fp (start,start+sz) step +#else + step <- runIteratee $ writeOut c s - dbg $ "wrote " ++ show written ++ " bytes, last 10='" ++ show last10 ++ "'" + run_ $ enumFilePartial fp (start,start+sz) step + return () +#endif - if n < len - then do - dbg $ "short write, need to write " ++ show (len-n) ++ " more bytes" - sendData conn $ B.drop n bs - else return () + withMVar lock $ \_ -> do + tryTakeMVar $ _readAvailable c + tryTakeMVar $ _writeAvailable c + evAsyncSend loop asy where - io = _connWriteIOObj conn - bk = _backend conn - active = _writeActive conn - lp = _evLoop bk - looplock = _loopLock bk - async = _asyncObj bk - - dbg s = debug $ "Backend.sendData(" ++ show (_socketFd conn) ++ "): " ++ s - fd = _socketFd conn - lock = _writeAvailable conn - waitForLock = do - dbg "waitForLock: starting" - withMVar looplock $ \_ -> do - act <- readIORef active - if act - then dbg "write watcher already running, skipping" - else do - dbg "starting watcher, sending async event" - tryTakeMVar lock - evIoStart lp io - writeIORef active True - evAsyncSend lp async +#if defined(HAS_SENDFILE) + go off bytes fd + | bytes == 0 = return () + | otherwise = do + sent <- SF.sendFile sfd fd off bytes + if sent < bytes + then tickleTimeout c >> go (off+sent) (bytes-sent) fd + else return () - dbg "waitForLock: taking mvar" - takeMVar lock - dbg "waitForLock: took mvar" + sfd = Fd $ _rawSocket c +#endif + io = _connWriteIOObj c + b = _backend c + loop = _evLoop b + lock = _loopLock b + asy = _asyncObj b -getReadEnd :: Connection -> Enumerator IO a -getReadEnd = enumerate - +------------------------------------------------------------------------------ +enumerate :: (MonadIO m) + => Connection + -> NetworkSession + -> Enumerator ByteString m a +enumerate conn session = loop + where + dbg s = debug $ "Libev.enumerate(" ++ show (_socket session) + ++ "): " ++ s -getWriteEnd :: Connection -> Iteratee IO () -getWriteEnd = writeOut + 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 -enumerate :: (MonadIO m) => Connection -> Enumerator m a -enumerate = loop - where - loop conn f = do - s <- liftIO $ recvData conn bLOCKSIZE - sendOne conn f s + | 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 - sendOne conn f s = do - v <- runIter f (if B.null s - then EOF Nothing - else Chunk $ WrapBS s) - case v of - r@(Done _ _) -> return $ liftI r - (Cont k Nothing) -> loop conn k - (Cont _ (Just e)) -> return $ throwErr e + recvData = Listen.recv (_listenSocket conn) + (waitForLock True conn) session -writeOut :: (MonadIO m) => Connection -> Iteratee m () -writeOut conn = IterateeG out +------------------------------------------------------------------------------ +writeOut :: (MonadIO m) + => Connection + -> NetworkSession + -> Iteratee ByteString m () +writeOut conn session = loop where - out c@(EOF _) = return $ Done () c - - out (Chunk s) = do - let x = unWrap s + loop = continue k - liftIO $ sendData conn x + k EOF = yield () EOF + k (Chunks xs) = do + liftIO $ sendData $ S.concat xs + loop - return $ Cont (writeOut conn) Nothing + sendData = Listen.send (_listenSocket conn) + (tickleTimeout conn) + (waitForLock False conn) + session +#endif diff --git a/src/Snap/Internal/Http/Server/ListenHelpers.hs b/src/Snap/Internal/Http/Server/ListenHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/ListenHelpers.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +module Snap.Internal.Http.Server.ListenHelpers where + + +------------------------------------------------------------------------------ +import Data.ByteString (ByteString) +import Foreign.C +import Network.Socket (Socket, sClose) +import Snap.Internal.Http.Server.Backend +import qualified Snap.Internal.Http.Server.HttpPort as Http +import qualified Snap.Internal.Http.Server.GnuTLS as TLS + + +------------------------------------------------------------------------------ +listenSocket :: ListenSocket -> Socket +listenSocket (ListenHttp s) = s +listenSocket (ListenHttps s _ _) = s + + +------------------------------------------------------------------------------ +isSecure :: ListenSocket -> Bool +isSecure (ListenHttp _) = False +isSecure (ListenHttps _ _ _) = True + + +------------------------------------------------------------------------------ +closeSocket :: ListenSocket -> IO () +closeSocket (ListenHttp s) = sClose s +closeSocket p@(ListenHttps s _ _) = do TLS.freePort p + sClose s + + +------------------------------------------------------------------------------ +createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession +createSession (ListenHttp _) = Http.createSession +createSession p@(ListenHttps _ _ _) = TLS.createSession p + + +------------------------------------------------------------------------------ +endSession :: ListenSocket -> NetworkSession -> IO () +endSession (ListenHttp _) = Http.endSession +endSession (ListenHttps _ _ _) = TLS.endSession + + +#ifdef PORTABLE + + +-- For portable builds, we can't call read/write directly so we need the +-- original haskell socket to use with network-bytestring package. +-- Only the simple backend creates sockets in haskell so the following +-- functions only work with the simple backend. + + +------------------------------------------------------------------------------ +recv :: ListenSocket -> Socket -> IO () -> NetworkSession + -> IO (Maybe ByteString) +recv (ListenHttp _) s = Http.recv s +recv (ListenHttps _ _ _) _ = TLS.recv + + +------------------------------------------------------------------------------ +send :: ListenSocket -> Socket -> IO () -> IO () -> NetworkSession + -> ByteString -> IO () +send (ListenHttp _) s = Http.send s +send (ListenHttps _ _ _) _ = TLS.send + + +#else + + +------------------------------------------------------------------------------ +recv :: ListenSocket -> IO () -> NetworkSession -> IO (Maybe ByteString) +recv (ListenHttp _) = Http.recv +recv (ListenHttps _ _ _) = TLS.recv + + +------------------------------------------------------------------------------ +send :: ListenSocket -> IO () -> IO () -> NetworkSession -> ByteString + -> IO () +send (ListenHttp _) = Http.send +send (ListenHttps _ _ _) = TLS.send + +#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 @@ -8,42 +8,26 @@ {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.SimpleBackend - ( Backend - , BackendTerminatedException(..) - , Connection - , TimeoutException(..) - , name - , debug - , bindIt - , new - , stop - , withConnection - , sendFile - , tickleTimeout - , getReadEnd - , getWriteEnd - , getRemoteAddr - , getRemotePort - , getLocalAddr - , getLocalPort + ( simpleEventLoop ) where + ------------------------------------------------------------------------------ -import "monads-fd" Control.Monad.Trans +import Control.Monad.Trans -import Control.Concurrent +import Control.Concurrent hiding (yield) import Control.Exception import Control.Monad import Data.ByteString (ByteString) -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.ByteString as B -import Data.Iteratee.WrappedByteString +import qualified Data.ByteString as S +import Data.ByteString.Internal (c2w) +import Data.Maybe import Data.Typeable import Data.Word import Foreign hiding (new) +import Foreign.C import GHC.Conc (labelThread, forkOnIO) import Network.Socket -import qualified Network.Socket.ByteString as SB import Prelude hiding (catch) ------------------------------------------------------------------------------ import Data.Concurrent.HashMap (hashString) @@ -51,7 +35,9 @@ import Snap.Internal.Http.Server.Date import qualified Snap.Internal.Http.Server.TimeoutTable as TT import Snap.Internal.Http.Server.TimeoutTable (TimeoutTable) -import Snap.Iteratee hiding (foldl') +import Snap.Internal.Http.Server.Backend +import qualified Snap.Internal.Http.Server.ListenHelpers as Listen +import Snap.Iteratee hiding (map) #if defined(HAS_SENDFILE) import qualified System.SendFile as SF @@ -60,129 +46,97 @@ #endif -data BackendTerminatedException = BackendTerminatedException - deriving (Typeable) - -instance Show BackendTerminatedException where - show (BackendTerminatedException) = "Backend terminated" - -instance Exception BackendTerminatedException - - ------------------------------------------------------------------------------ -type QueueElem = Maybe (Socket,SockAddr) - -data Backend = Backend - { _acceptSocket :: !Socket - , _acceptThread :: !ThreadId +-- | For each cpu, we store: +-- * A list of accept threads, one per port. +-- * One timeout table and one timeout thread. +-- These timeout the session threads. +-- * An mvar to signal when the timeout thread is shutdown +data EventLoopCpu = EventLoopCpu + { _boundCpu :: Int + , _acceptThreads :: [ThreadId] , _timeoutTable :: TimeoutTable - , _timeoutThread :: !(MVar ThreadId) - , _connectionQueue :: !(Chan QueueElem) + , _timeoutThread :: ThreadId + , _exitMVar :: !(MVar ()) } -data Connection = Connection - { _backend :: Backend - , _socket :: Socket - , _remoteAddr :: ByteString - , _remotePort :: Int - , _localAddr :: ByteString - , _localPort :: Int - , _connTid :: MVar ThreadId - , _threadHash :: MVar Word - } +------------------------------------------------------------------------------ +simpleEventLoop :: EventLoop +simpleEventLoop sockets cap elog handler = do + loops <- Prelude.mapM (newLoop sockets handler elog) [0..(cap-1)] -{-# INLINE name #-} -name :: ByteString -name = "simple" + debug "simpleEventLoop: waiting for mvars" + --wait for all threads to exit + Prelude.mapM_ (takeMVar . _exitMVar) loops `finally` do + debug "simpleEventLoop: killing all threads" + mapM stopLoop loops + mapM Listen.closeSocket sockets -sendFile :: Connection -> FilePath -> Int64 -> Int64 -> IO () -#if defined(HAS_SENDFILE) -sendFile c fp start sz = do - bracket (openFd fp ReadOnly Nothing defaultFileFlags) - (closeFd) - (go start sz) - where - go off bytes fd - | bytes == 0 = return () - | otherwise = do - sent <- SF.sendFile sfd fd off bytes - if sent < bytes - then tickleTimeout c >> go (off+sent) (bytes-sent) fd - else return () - sfd = Fd . fdSocket $ _socket c -#else -sendFile c fp start sz = do - -- no need to count bytes - enumFilePartial fp (start,start+sz) (getWriteEnd c) >>= run - return () -#endif +------------------------------------------------------------------------------ +newLoop :: [ListenSocket] + -> SessionHandler + -> (S.ByteString -> IO ()) + -> Int + -> IO EventLoopCpu +newLoop sockets handler elog cpu = do + tt <- TT.new + exit <- newEmptyMVar + accThreads <- forM sockets $ \p -> forkOnIO cpu $ + acceptThread handler tt elog cpu p + tid <- forkOnIO cpu $ timeoutThread tt exit + return $ EventLoopCpu cpu accThreads tt tid exit -bindIt :: ByteString -- ^ bind address, or \"*\" for all - -> Int -- ^ port to bind to - -> IO Socket -bindIt bindAddress bindPort = do - sock <- socket AF_INET Stream 0 - addr <- getHostAddr bindPort bindAddress - setSocketOption sock ReuseAddr 1 - bindSocket sock addr - listen sock 150 - return sock +------------------------------------------------------------------------------ +stopLoop :: EventLoopCpu -> IO () +stopLoop loop = block $ do + Prelude.mapM_ killThread $ _acceptThreads loop + killThread $ _timeoutThread loop -acceptThread :: Socket -> Chan QueueElem -> IO () -acceptThread sock connq = loop `finally` cleanup + +------------------------------------------------------------------------------ +acceptThread :: SessionHandler + -> TimeoutTable + -> (S.ByteString -> IO ()) + -> Int + -> ListenSocket + -> IO () +acceptThread handler tt elog cpu sock = loop where loop = do debug $ "acceptThread: calling accept()" - s@(_,addr) <- accept sock + (s,addr) <- accept $ Listen.listenSocket sock debug $ "acceptThread: accepted connection from remote: " ++ show addr - debug $ "acceptThread: queueing" - writeChan connq $ Just s + forkOnIO cpu (go s addr `catches` cleanup) loop - cleanup = block $ do - debug $ "acceptThread: cleanup, closing socket and notifying " - ++ "chan listeners" - sClose sock - replicateM 10 $ writeChan connq Nothing - - -new :: Socket -- ^ value you got from bindIt - -> Int - -> IO Backend -new sock cpu = do - debug $ "Backend.new: listening" - - tt <- TT.new - t <- newEmptyMVar - connq <- newChan - accThread <- forkOnIO cpu $ acceptThread sock connq - - let b = Backend sock accThread tt t connq - - tid <- forkIO $ timeoutThread b - putMVar t tid + go = runSession handler tt sock - return b + cleanup = + [ + Handler $ \(e :: SomeException) -> elog + $ S.concat [ "SimpleBackend.acceptThread: " + , S.pack . map c2w $ show e] + ] -timeoutThread :: Backend -> IO () -timeoutThread backend = do - loop `catch` (\(_::SomeException) -> killAll) +------------------------------------------------------------------------------ +timeoutThread :: TimeoutTable -> MVar () -> IO () +timeoutThread table exitMVar = do + go `catch` (\(_::SomeException) -> killAll) + putMVar exitMVar () where - table = _timeoutTable backend - - loop = do + go = do debug "timeoutThread: waiting for activity on thread table" TT.waitForActivity table debug "timeoutThread: woke up, killing old connections" killTooOld - loop + go killTooOld = do @@ -197,23 +151,7 @@ TT.killAll table -stop :: Backend -> IO () -stop backend = do - debug $ "Backend.stop: killing accept thread" - killThread acthr - - debug $ "Backend.stop: killing timeout thread" - - -- kill timeout thread; timeout thread handler will stop all of the running - -- connection threads - readMVar tthr >>= killThread - debug $ "Backend.stop: exiting.." - - where - acthr = _acceptThread backend - tthr = _timeoutThread backend - - +------------------------------------------------------------------------------ data AddressNotSupportedException = AddressNotSupportedException String deriving (Typeable) @@ -223,27 +161,21 @@ instance Exception AddressNotSupportedException -withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO () -withConnection backend cpu proc = do - debug $ "Backend.withConnection: reading from chan" - - qelem <- readChan $ _connectionQueue backend - when (qelem == Nothing) $ do - debug $ "Backend.withConnection: channel terminated, throwing " - ++ "BackendTerminatedException" - throwIO BackendTerminatedException - - let (Just (sock,addr)) = qelem +------------------------------------------------------------------------------ +runSession :: SessionHandler -> TimeoutTable -> ListenSocket -> Socket + -> SockAddr -> IO () +runSession handler tt lsock sock addr = do let fd = fdSocket sock + curId <- myThreadId - debug $ "Backend.withConnection: dequeued connection from remote: " - ++ show addr + debug $ "Backend.withConnection: running session: " ++ show addr + labelThread curId $ "connHndl " ++ show fd - (port,host) <- + (rport,rhost) <- case addr of SockAddrInet p h -> do h' <- inet_ntoa h - return (fromIntegral p, B.pack $ map c2w h') + return (fromIntegral p, S.pack $ map c2w h') x -> throwIO $ AddressNotSupportedException $ show x laddr <- getSocketName sock @@ -252,165 +184,172 @@ case laddr of SockAddrInet p h -> do h' <- inet_ntoa h - return (fromIntegral p, B.pack $ map c2w h') + return (fromIntegral p, S.pack $ map c2w h') x -> throwIO $ AddressNotSupportedException $ show x - tmvar <- newEmptyMVar - thrhash <- newEmptyMVar - - let c = Connection backend sock host port lhost lport tmvar thrhash - - tid <- forkOnIO cpu $ do - labelMe $ "connHndl " ++ show fd - bracket (return c) - (\_ -> block $ do - debug "thread killed, closing socket" - thr <- readMVar tmvar - thash <- readMVar thrhash - - -- remove thread from timeout table - TT.delete thash thr $ _timeoutTable backend + let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock + let curHash = hashString $ show curId + let timeout = tickleTimeout tt curId curHash - eatException $ shutdown sock ShutdownBoth - eatException $ sClose sock - ) - proc + timeout - putMVar tmvar tid - putMVar thrhash $ hashString $ show tid - tickleTimeout c - return () + bracket (Listen.createSession lsock 8192 fd + (threadWaitRead $ fromIntegral fd)) + (\session -> block $ do + debug "thread killed, closing socket" + -- remove thread from timeout table + TT.delete curHash curId tt -labelMe :: String -> IO () -labelMe s = do - tid <- myThreadId - labelThread tid s + eatException $ Listen.endSession lsock session + eatException $ shutdown sock ShutdownBoth + eatException $ sClose sock + ) + (\s -> let writeEnd = writeOut lsock s sock timeout + in handler sinfo + (enumerate lsock s sock) + writeEnd + (sendFile lsock timeout fd writeEnd) + timeout + ) +------------------------------------------------------------------------------ eatException :: IO a -> IO () eatException act = (act >> return ()) `catch` \(_::SomeException) -> return () -getReadEnd :: Connection -> Enumerator IO a -getReadEnd = enumerate - -getWriteEnd :: Connection -> Iteratee IO () -getWriteEnd = writeOut - - -getRemoteAddr :: Connection -> ByteString -getRemoteAddr = _remoteAddr - -getRemotePort :: Connection -> Int -getRemotePort = _remotePort - -getLocalAddr :: Connection -> ByteString -getLocalAddr = _localAddr - -getLocalPort :: Connection -> Int -getLocalPort = _localPort - ------------------------------------------------------------------------------ -getHostAddr :: Int - -> ByteString - -> IO SockAddr -getHostAddr p s = do - h <- if s == "*" - then return iNADDR_ANY - else inet_addr (map w2c . B.unpack $ s) - - return $ SockAddrInet (fromIntegral p) h - - - -data TimeoutException = TimeoutException - deriving (Typeable) - -instance Show TimeoutException where - show TimeoutException = "timeout" +sendFile :: ListenSocket + -> IO () + -> CInt + -> Iteratee ByteString IO () + -> FilePath + -> Int64 + -> Int64 + -> IO () +#if defined(HAS_SENDFILE) +sendFile lsock tickle sock writeEnd fp start sz = + case lsock of + ListenHttp _ -> bracket (openFd fp ReadOnly Nothing defaultFileFlags) + (closeFd) + (go start sz) + _ -> do + step <- runIteratee writeEnd + run_ $ enumFilePartial fp (start,start+sz) step + where + go off bytes fd + | bytes == 0 = return () + | otherwise = do + sent <- SF.sendFile sfd fd off bytes + if sent < bytes + then tickle >> go (off+sent) (bytes-sent) fd + else return () -instance Exception TimeoutException + sfd = Fd sock +#else +sendFile _ _ _ writeEnd fp start sz = do + -- no need to count bytes + step <- runIteratee writeEnd + run_ $ enumFilePartial fp (start,start+sz) step + return () +#endif -tickleTimeout :: Connection -> IO () -tickleTimeout conn = do +------------------------------------------------------------------------------ +tickleTimeout :: TimeoutTable -> ThreadId -> Word -> IO () +tickleTimeout table tid thash = do debug "Backend.tickleTimeout" now <- getCurrentDateTime - tid <- readMVar $ _connTid conn - thash <- readMVar $ _threadHash conn - TT.insert thash tid now table - where - table = _timeoutTable $ _backend conn - -_cancelTimeout :: Connection -> IO () -_cancelTimeout conn = do - debug "Backend.cancelTimeout" - - tid <- readMVar $ _connTid conn - thash <- readMVar $ _threadHash conn - - TT.delete thash tid table - +------------------------------------------------------------------------------ +enumerate :: (MonadIO m) + => ListenSocket + -> NetworkSession + -> Socket + -> Enumerator ByteString m a +enumerate port session sock = loop where - table = _timeoutTable $ _backend conn - - -timeoutRecv :: Connection -> Int -> IO ByteString -timeoutRecv conn n = do - let sock = _socket conn - SB.recv sock n + dbg s = debug $ "SimpleBackend.enumerate(" ++ show (_socket session) + ++ "): " ++ s + loop (Continue k) = do + dbg "reading from socket" + s <- liftIO $ timeoutRecv + case s of + Nothing -> do + dbg "got EOF from socket" + sendOne k "" + Just s' -> do + dbg $ "got " ++ Prelude.show (S.length s') + ++ " bytes from read end" + sendOne k s' -timeoutSend :: Connection -> ByteString -> IO () -timeoutSend conn s = do - let len = B.length s - debug $ "Backend.timeoutSend: entered w/ " ++ show len ++ " bytes" - let sock = _socket conn - SB.sendAll sock s - debug $ "Backend.timeoutSend: sent all" - tickleTimeout conn + loop x = returnI x -bLOCKSIZE :: Int -bLOCKSIZE = 8192 - + sendOne k s | S.null s = do + dbg "sending EOF to continuation" + enumEOF $ Continue k -enumerate :: (MonadIO m) => Connection -> Enumerator m a -enumerate = loop - where - loop conn f = do - debug $ "Backend.enumerate: reading from socket" - s <- liftIO $ timeoutRecv conn bLOCKSIZE - debug $ "Backend.enumerate: got " ++ Prelude.show (B.length s) - ++ " bytes from read end" - sendOne conn f s + | 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 - sendOne conn f s = do - v <- runIter f (if B.null s - then EOF Nothing - else Chunk $ WrapBS s) - case v of - r@(Done _ _) -> return $ liftI r - (Cont k Nothing) -> loop conn k - (Cont _ (Just e)) -> return $ throwErr e + fd = fdSocket sock +#ifdef PORTABLE + timeoutRecv = Listen.recv port sock (threadWaitRead $ + fromIntegral fd) session +#else + timeoutRecv = Listen.recv port (threadWaitRead $ + fromIntegral fd) session +#endif -writeOut :: (MonadIO m) => Connection -> Iteratee m () -writeOut conn = IterateeG out +------------------------------------------------------------------------------ +writeOut :: (MonadIO m) + => ListenSocket + -> NetworkSession + -> Socket + -> IO () + -> Iteratee ByteString m () +writeOut port session sock tickle = loop where - out c@(EOF _) = return $ Done () c - - out (Chunk s) = do - let x = unWrap s + dbg s = debug $ "SimpleBackend.writeOut(" ++ show (_socket session) + ++ "): " ++ s - ee <- liftIO $ ((try $ timeoutSend conn x) - :: IO (Either SomeException ())) + loop = continue k + k EOF = yield () EOF + k (Chunks xs) = do + let s = S.concat xs + let n = S.length s + dbg $ "got chunk with " ++ show n ++ " bytes" + ee <- liftIO $ try $ timeoutSend s case ee of - (Left e) -> return $ Done () (EOF $ Just $ Err $ show e) - (Right _) -> return $ Cont (writeOut conn) Nothing + (Left (e::SomeException)) -> do + dbg $ "timeoutSend got error " ++ show e + throwError e + (Right _) -> do + let last10 = S.drop (n-10) s + dbg $ "wrote " ++ show n ++ " bytes, last 10=" ++ show last10 + loop + fd = fdSocket sock +#ifdef PORTABLE + timeoutSend = Listen.send port sock tickle + (threadWaitWrite $ fromIntegral fd) session +#else + timeoutSend = Listen.send port tickle + (threadWaitWrite $ fromIntegral fd) session +#endif diff --git a/src/Snap/Internal/Http/Server/TimeoutTable.hs b/src/Snap/Internal/Http/Server/TimeoutTable.hs --- a/src/Snap/Internal/Http/Server/TimeoutTable.hs +++ b/src/Snap/Internal/Http/Server/TimeoutTable.hs @@ -13,6 +13,7 @@ ) where + ------------------------------------------------------------------------------ import Control.Concurrent import Control.Monad @@ -29,23 +30,28 @@ import Data.Concurrent.HashMap (nextHighestPowerOf2) +------------------------------------------------------------------------------ type TT = PSQ ThreadId CTime +------------------------------------------------------------------------------ data TimeoutTable = TimeoutTable { _maps :: !(Vector (MVar TT)) , _activity :: !(MVar ()) } +------------------------------------------------------------------------------ defaultNumberOfLocks :: Word defaultNumberOfLocks = nextHighestPowerOf2 $ toEnum $ 8 * numCapabilities +------------------------------------------------------------------------------ hashToBucket :: Word -> Word hashToBucket x = x .&. (defaultNumberOfLocks-1) +------------------------------------------------------------------------------ new :: IO TimeoutTable new = do vector <- V.replicateM (fromEnum defaultNumberOfLocks) (newMVar PSQ.empty) @@ -53,12 +59,14 @@ return $ TimeoutTable vector act +------------------------------------------------------------------------------ null :: TimeoutTable -> IO Bool null (TimeoutTable maps _) = do nulls <- V.mapM (\mv -> withMVar mv $ return . PSQ.null) maps return $ V.and nulls +------------------------------------------------------------------------------ insert :: Word -> ThreadId -> CTime -> TimeoutTable -> IO () insert thash tid time (TimeoutTable maps act) = do modifyMVar_ psqMv $ \psq -> do @@ -73,6 +81,7 @@ psqMv = V.unsafeIndex maps $ fromEnum bucket +------------------------------------------------------------------------------ delete :: Word -> ThreadId -> TimeoutTable -> IO () delete thash tid (TimeoutTable maps act) = do modifyMVar_ psqMv $ \psq -> do @@ -87,6 +96,7 @@ psqMv = V.unsafeIndex maps $ fromEnum bucket +------------------------------------------------------------------------------ killAll :: TimeoutTable -> IO () killAll (TimeoutTable maps _) = do V.mapM_ k maps @@ -97,6 +107,7 @@ return PSQ.empty +------------------------------------------------------------------------------ killOlderThan :: CTime -> TimeoutTable -> IO () killOlderThan time (TimeoutTable maps _) = do V.mapM_ processPSQ maps @@ -116,6 +127,7 @@ mmin +------------------------------------------------------------------------------ waitForActivity :: TimeoutTable -> IO () waitForActivity t@(TimeoutTable _ act) = do takeMVar act diff --git a/src/Snap/Internal/Http/Server/gnutls_helpers.c b/src/Snap/Internal/Http/Server/gnutls_helpers.c new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Http/Server/gnutls_helpers.c @@ -0,0 +1,17 @@ +#include +#include +#include +#include +GCRY_THREAD_OPTION_PTHREAD_IMPL; + +/* See http://www.gnu.org/software/gnutls/manual/html_node/Multi_002dthreaded-applications.html */ + +static int threading_init = 0; + +void gnutls_set_threading_helper() +{ + if (!threading_init) { + gcry_control (GCRYCTL_SET_THREAD_CBS, &gcry_threads_pthread); + threading_init = 1; + } +} diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs --- a/src/System/FastLogger.hs +++ b/src/System/FastLogger.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module System.FastLogger +module System.FastLogger ( Logger , timestampedLogEntry , combinedLogEntry @@ -11,6 +11,8 @@ , stopLogger ) where + +------------------------------------------------------------------------------ import Control.Concurrent import Control.Exception import Control.Monad @@ -32,6 +34,7 @@ import Snap.Internal.Http.Server.Date +------------------------------------------------------------------------------ -- | Holds the state for a logger. data Logger = Logger { _queuedMessages :: !(IORef (DList ByteString)) @@ -40,6 +43,7 @@ , _loggingThread :: !(MVar ThreadId) } +------------------------------------------------------------------------------ -- | Creates a new logger, logging to the given file. If the file argument is -- \"-\", then log to stdout; if it's \"stderr\" then we log to stderr, -- otherwise we log to a regular file in append mode. The file is closed and @@ -57,6 +61,8 @@ return lg + +------------------------------------------------------------------------------ -- | Prepares a log message with the time prepended. timestampedLogEntry :: ByteString -> IO ByteString timestampedLogEntry msg = do @@ -69,6 +75,7 @@ putByteString msg +------------------------------------------------------------------------------ -- | Prepares a log message in \"combined\" format. combinedLogEntry :: ByteString -- ^ remote host -> Maybe ByteString -- ^ remote user @@ -81,7 +88,7 @@ -> ByteString -- ^ user agent (up to you to ensure -- there are no quotes in here) -> IO ByteString -combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !userAgent = do +combinedLogEntry !host !mbUser !req !status !mbNumBytes !mbReferer !ua = do let user = fromMaybe "-" mbUser let numBytes = maybe "-" (\s -> strict $ show s) mbNumBytes let referer = maybe "-" (\s -> S.concat ["\"", s, "\""]) mbReferer @@ -89,21 +96,21 @@ timeStr <- getLogDateString let !p = [ host - , " - " - , user - , " [" - , timeStr - , "] \"" - , req - , "\" " - , strict $ show status - , " " - , numBytes - , " " - , referer - , " \"" - , userAgent - , "\"" ] + , " - " + , user + , " [" + , timeStr + , "] \"" + , req + , "\" " + , strict $ show status + , " " + , numBytes + , " " + , referer + , " \"" + , ua + , "\"" ] let !output = S.concat p @@ -114,6 +121,7 @@ strict = S.concat . L.toChunks +------------------------------------------------------------------------------ -- | Sends out a log message verbatim with a newline appended. Note: -- if you want a fancy log message you'll have to format it yourself -- (or use 'combinedLogEntry'). @@ -124,6 +132,7 @@ tryPutMVar (_dataWaiting lg) () >> return () +------------------------------------------------------------------------------ loggingThread :: Logger -> IO () loggingThread (Logger queue notifier filePath _) = do initialize >>= go @@ -196,6 +205,7 @@ loop d +------------------------------------------------------------------------------ -- | Kills a logger thread, causing any unwritten contents to be -- flushed out to disk stopLogger :: Logger -> IO () diff --git a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs --- a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs +++ b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs @@ -3,38 +3,49 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} -module Snap.Internal.Http.Parser.Benchmark +module Snap.Internal.Http.Parser.Benchmark ( benchmarks ) where +import qualified Control.Exception as E +import "monads-fd" Control.Monad.Identity import Criterion.Main hiding (run) -import Snap.Internal.Http.Parser +import Data.Attoparsec hiding (Result(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S -import qualified Snap.Iteratee as SI -import qualified Control.Exception as E -import Data.Attoparsec hiding (Result(..)) +import qualified Data.ByteString.Lazy.Char8 as L +import Snap.Internal.Http.Parser import Snap.Internal.Http.Parser.Data -import "monads-fd" Control.Monad.Identity -import Data.Iteratee -import Data.Iteratee.WrappedByteString -import Snap.Iteratee hiding (take, foldl', filter) -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Snap.Iteratee as SI +import Snap.Iteratee hiding (take) parseGet :: IO () -parseGet = SI.enumBS parseGetData parseRequest >>= SI.run >> return () +parseGet = do + step <- runIteratee parseRequest + run_ $ enumBS parseGetData step + return () + parseChunked :: IO () parseChunked = do - c <- toChunked parseChunkedData - i <- SI.enumLBS c (readChunkedTransferEncoding stream2stream) - f <- SI.run i - return () + sstep <- runIteratee stream2stream + c <- toChunked parseChunkedData + cstep <- runIteratee $ readChunkedTransferEncoding sstep + let i = enumBS c cstep + f <- run_ i + return () -- utils -toChunked lbs = writeChunkedTransferEncoding stream2stream >>= - enumLBS lbs >>= run >>= return . fromWrap +toChunked :: L.ByteString -> IO ByteString +toChunked lbs = do + sstep <- runIteratee stream2stream + cstep <- runIteratee $ joinI $ writeChunkedTransferEncoding sstep + run_ $ enumLBS lbs cstep benchmarks = bgroup "parser" [ bench "firefoxget" $ whnfIO parseGet , bench "readChunkedTransferEncoding" $ whnfIO parseChunked ] + + +stream2stream :: (Monad m) => Iteratee ByteString m ByteString +stream2stream = liftM S.concat consume diff --git a/test/common/Test/Common/TestHandler.hs b/test/common/Test/Common/TestHandler.hs --- a/test/common/Test/Common/TestHandler.hs +++ b/test/common/Test/Common/TestHandler.hs @@ -5,18 +5,17 @@ import Control.Monad +import Control.Monad.Trans import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Data.Iteratee.WrappedByteString import Data.Maybe import Snap.Iteratee hiding (Enumerator) +import qualified Snap.Iteratee as I import Snap.Types -import Snap.Http.Server import Snap.Util.FileServe import Snap.Util.GZip -import Snap.Internal.Iteratee.Debug import Test.Common.Rot13 (rot13) @@ -32,20 +31,23 @@ echoHandler :: Snap () -echoHandler = transformRequestBody return +echoHandler = transformRequestBody returnI rot13Handler :: Snap () -rot13Handler = transformRequestBody $ return . f +rot13Handler = transformRequestBody f where - f i = IterateeG $ \ch -> do - case ch of - (EOF _) -> runIter i ch - (Chunk (WrapBS s)) -> do - i' <- liftM liftI $ runIter i $ Chunk $ WrapBS $ rot13 s - return $ Cont (f i') Nothing + f origStep = do + mbX <- I.head + maybe (enumEOF origStep) + (feedStep origStep) + mbX + feedStep origStep x = do + step <- lift $ runIteratee $ enumBS (rot13 x) origStep + f step + bigResponseHandler :: Snap () bigResponseHandler = do let sz = 4000000 @@ -71,4 +73,3 @@ , ("bigresponse" , bigResponseHandler ) , ("respcode/:code" , responseHandler ) ] - diff --git a/test/pongserver/Main.hs b/test/pongserver/Main.hs --- a/test/pongserver/Main.hs +++ b/test/pongserver/Main.hs @@ -2,15 +2,15 @@ module Main where import Control.Concurrent +import Control.Exception (finally) import Snap.Iteratee import Snap.Types import Snap.Http.Server -import Snap.Util.GZip + -- FIXME: need better primitives for output pongServer :: Snap () -pongServer = withCompression $ - modifyResponse $ setResponseBody (enumBS "PONG") . +pongServer = modifyResponse $ setResponseBody (enumBS "PONG") . setContentType "text/plain" . setContentLength 4 @@ -25,7 +25,8 @@ return () where - go m = do - httpServe "*" 3000 "localhost" (Just "foo.log") Nothing pongServer - --httpServe "*" 3000 "localhost" Nothing Nothing pongServer - putMVar m () + go m = httpServe config pongServer `finally` putMVar m () + config = addListen (ListenHttp "*" 8000) $ + setErrorLog Nothing $ + setAccessLog Nothing $ + setCompression False $ emptyConfig 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 @@ -12,6 +12,10 @@ optimizations such as C routines will be used. Default: False +Flag gnutls + Description: Enable https support using the libgnutls library. + Default: False + Executable testsuite hs-source-dirs: suite common ../src main-is: TestSuite.hs @@ -20,48 +24,50 @@ QuickCheck >= 2, array >= 0.3 && <0.4, attoparsec >= 0.8.1 && < 0.9, - attoparsec-iteratee >= 0.1.1 && <0.2, + attoparsec-enumerator >= 0.2.0.1 && < 0.3, base >= 4 && < 5, binary >= 0.5 && < 0.6, bytestring, bytestring-nums >= 0.3.1 && < 0.4, bytestring-show >= 0.3.2 && < 0.4, containers, + directory, directory-tree, dlist >= 0.5 && < 0.6, + enumerator == 0.4.*, filepath, haskell98, - HTTP >= 4000.0.9 && < 4001, + http-enumerator >= 0.2.1.5 && <0.3, HUnit >= 1.2 && < 2, - monads-fd < 0.1.0.3, + monads-fd >= 0.1.0.4 && <0.2, murmur-hash >= 0.1 && < 0.2, - network == 2.2.1.7, - network-bytestring >= 0.1.2 && < 0.2, + network == 2.3.*, old-locale, parallel > 2, - iteratee >= 0.3.1 && < 0.4, - snap-core >= 0.2.12 && <0.3, + process, + snap-core >= 0.3 && <0.4, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, time, transformers, + utf8-string >= 0.3.6 && <0.4, vector >= 0.7 && <0.8, - vector-algorithms >= 0.3.4 && <0.4 + vector-algorithms >= 0.4 && <0.5, + PSQueue >= 1.1 && <1.2 if !os(windows) build-depends: unix if flag(libev) build-depends: hlibev >= 0.2.5 && < 0.3 - other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV - else - build-depends: network-bytestring >= 0.1.2 && < 0.2, - PSQueue >= 1.1 && <1.2 - other-modules: Snap.Internal.Http.Server.SimpleBackend + if flag(gnutls) + extra-libraries: gnutls + cpp-options: -DGNUTLS + c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c if flag(portable) || os(windows) cpp-options: -DPORTABLE @@ -79,7 +85,7 @@ QuickCheck >= 2, array >= 0.3 && <0.4, attoparsec >= 0.8.1 && < 0.9, - attoparsec-iteratee >= 0.1.1 && <0.2, + attoparsec-enumerator >= 0.2.0.1 && < 0.3, base >= 4 && < 5, bytestring, bytestring-nums >= 0.3.1 && < 0.4, @@ -88,25 +94,25 @@ containers, directory-tree, dlist >= 0.5 && < 0.6, + enumerator == 0.4.*, filepath, haskell98, HUnit >= 1.2 && < 2, - monads-fd < 0.1.0.3, + monads-fd >= 0.1.0.4 && <0.2, old-locale, parallel > 2, - iteratee >= 0.3.1 && < 0.4, MonadCatchIO-transformers >= 0.2.1 && < 0.3, murmur-hash >= 0.1 && < 0.2, - network == 2.2.1.7, - network-bytestring >= 0.1.2 && < 0.2, - snap-core >= 0.2.12 && <0.3, + network == 2.3.*, + snap-core >= 0.3 && <0.4, template-haskell, time, transformers, - unix-compat, + unix-compat == 0.2.*, + utf8-string >= 0.3.6 && <0.4, vector >= 0.7 && <0.8, - vector-algorithms >= 0.3.4 && <0.4 - + vector-algorithms >= 0.4 && <0.5, + PSQueue >= 1.1 && <1.2 if flag(portable) || os(windows) cpp-options: -DPORTABLE @@ -115,13 +121,12 @@ if flag(libev) build-depends: hlibev >= 0.2.5 && < 0.3 - other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV - else - build-depends: network-bytestring >= 0.1.2 && < 0.2, - PSQueue >= 1.1 && <1.2 - other-modules: Snap.Internal.Http.Server.SimpleBackend + if flag(gnutls) + extra-libraries: gnutls + cpp-options: -DGNUTLS + c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE @@ -157,7 +162,7 @@ QuickCheck >= 2, array >= 0.3 && <0.4, attoparsec >= 0.8.1 && < 0.9, - attoparsec-iteratee >= 0.1.1 && <0.2, + attoparsec-enumerator >= 0.2.0.1 && < 0.3, base >= 4 && < 5, binary >= 0.5 && < 0.6, bytestring, @@ -166,41 +171,39 @@ containers, directory-tree, dlist >= 0.5 && < 0.6, + enumerator == 0.4.*, filepath, haskell98, - HTTP >= 4000.0.9 && < 4001, HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, - monads-fd < 0.1.0.3, + monads-fd >= 0.1.0.4 && <0.2, murmur-hash >= 0.1 && < 0.2, - network == 2.2.1.7, - network-bytestring >= 0.1.2 && < 0.2, + network == 2.3.*, old-locale, parallel > 2, - iteratee >= 0.3.1 && < 0.4, - snap-core >= 0.2.12 && <0.3, + snap-core >= 0.3 && <0.4, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, time, transformers, + utf8-string >= 0.3.6 && <0.4, vector >= 0.7 && <0.8, - vector-algorithms >= 0.3.4 && <0.4 - + vector-algorithms >= 0.4 && <0.5, + PSQueue >= 1.1 && <1.2 if !os(windows) build-depends: unix if flag(libev) build-depends: hlibev >= 0.2.5 && < 0.3 - other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV - else - build-depends: network-bytestring >= 0.1.2 && < 0.2, - PSQueue >= 1.1 && <1.2 - other-modules: Snap.Internal.Http.Server.SimpleBackend + if flag(gnutls) + extra-libraries: gnutls + cpp-options: -DGNUTLS + c-sources: ../src/Snap/Internal/Http/Server/gnutls_helpers.c if flag(portable) || os(windows) cpp-options: -DPORTABLE @@ -215,6 +218,6 @@ main-is: Benchmark.hs build-depends: base >= 4 && < 5, - network == 2.2.1.7, - HTTP >= 4000.0.9 && < 4001, + network == 2.3.*, + http-enumerator >= 0.2.1.3 && <0.3, criterion >= 0.5 && <0.6 diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs b/test/suite/Snap/Internal/Http/Parser/Tests.hs --- a/test/suite/Snap/Internal/Http/Parser/Tests.hs +++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs @@ -8,20 +8,17 @@ import qualified Control.Exception as E import Control.Exception hiding (try, assert) import Control.Monad -import Control.Monad.Identity import Control.Parallel.Strategies import Data.Attoparsec hiding (Result(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w) -import Data.IORef -import Data.Iteratee.WrappedByteString import Data.List import qualified Data.Map as Map import Data.Maybe (isNothing) import Data.Monoid -import Test.Framework +import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck @@ -31,8 +28,9 @@ import Text.Printf import Snap.Internal.Http.Parser -import Snap.Internal.Http.Types hiding (Enumerator) -import Snap.Iteratee hiding (foldl') +import Snap.Internal.Http.Types +import Snap.Internal.Debug +import Snap.Iteratee hiding (map, sequence) import qualified Snap.Iteratee as I import Snap.Test.Common() @@ -42,14 +40,11 @@ , testCookie , testChunked , testBothChunked - , testBothChunkedBuffered1 , testBothChunkedPipelined , testBothChunkedEmpty , testP2I , testNull , testPartial - , testIterateeError - , testIterateeError2 , testParseError , testFormEncoded ] @@ -58,16 +53,16 @@ emptyParser = option "foo" $ string "bar" testShow :: Test -testShow = testCase "show" $ do +testShow = testCase "parser/show" $ do let i = IRequest GET "/" (1,1) [] let !b = show i `using` rdeepseq return $ b `seq` () testP2I :: Test -testP2I = testCase "parserToIteratee" $ do - i <- enumBS "z" (parserToIteratee emptyParser) - l <- run i +testP2I = testCase "parser/iterParser" $ do + i <- liftM (enumBS "z") $ runIteratee (iterParser emptyParser) + l <- run_ i assertEqual "should be foo" "foo" l @@ -79,45 +74,25 @@ testNull :: Test -testNull = testCase "short parse" $ do - f <- run (parseRequest) +testNull = testCase "parser/shortParse" $ do + f <- run_ (parseRequest) assertBool "should be Nothing" $ isNothing f testPartial :: Test -testPartial = testCase "partial parse" $ do - i <- enumBS "GET / " parseRequest - f <- E.try $ run i +testPartial = testCase "parser/partial" $ do + i <- liftM (enumBS "GET / ") $ runIteratee parseRequest + f <- E.try $ run_ i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x testParseError :: Test -testParseError = testCase "parse error" $ do - i <- enumBS "ZZZZZZZZZZ" parseRequest - f <- E.try $ run i - - case f of (Left e) -> forceErr e - (Right x) -> assertFailure $ "expected exception, got " ++ show x - - -introduceError :: (Monad m) => Enumerator m a -introduceError iter = return $ IterateeG $ \_ -> - runIter iter (EOF (Just (Err "EOF"))) - -testIterateeError :: Test -testIterateeError = testCase "iteratee error" $ do - i <- liftM liftI $ runIter parseRequest (EOF (Just (Err "foo"))) - f <- E.try $ run i - - case f of (Left e) -> forceErr e - (Right x) -> assertFailure $ "expected exception, got " ++ show x - -testIterateeError2 :: Test -testIterateeError2 = testCase "iteratee error 2" $ do - i <- (enumBS "GET / " >. introduceError) parseRequest - f <- E.try $ run i +testParseError = testCase "parser/error" $ do + step <- runIteratee parseRequest + let i = enumBS "ZZZZZZZZZZ" step + f <- E.try $ run_ i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x @@ -133,103 +108,54 @@ f l = L.concat $ (map toChunk l ++ ["0\r\n\r\n"]) + -- | ensure that running the 'readChunkedTransferEncoding' iteratee against -- 'transferEncodingChunked' returns the original string testChunked :: Test -testChunked = testProperty "chunked transfer encoding" prop_chunked +testChunked = testProperty "parser/chunkedTransferEncoding" $ + monadicIO $ forAllM arbitrary prop_chunked where - prop_chunked :: L.ByteString -> Bool - prop_chunked s = runIdentity (run iter) == s + prop_chunked s = do + QC.run $ debug "==============================" + QC.run $ debug $ "input is " ++ show s + QC.run $ debug $ "chunked is " ++ show chunked + QC.run $ debug "------------------------------" + sstep <- QC.run $ runIteratee $ stream2stream + step <- QC.run $ runIteratee $ + joinI $ readChunkedTransferEncoding sstep + + out <- QC.run $ run_ $ enum step + + QC.assert $ s == out + QC.run $ debug "==============================\n" + where - enum = enumLBS (transferEncodingChunked s) + chunked = (transferEncodingChunked s) + enum = enumLBS chunked - iter :: Iteratee Identity L.ByteString - iter = runIdentity $ do - i <- (readChunkedTransferEncoding stream2stream) >>= enum - return $ liftM fromWrap i testBothChunked :: Test -testBothChunked = testProperty "chunk . unchunk == id" $ +testBothChunked = testProperty "parser/invertChunked" $ monadicIO $ forAllM arbitrary prop where prop s = do - it <- QC.run $ writeChunkedTransferEncoding stream2stream + sstep <- QC.run $ runIteratee stream2stream + let it = joinI $ writeChunkedTransferEncoding sstep - bs <- QC.run $ - enumBS s it - >>= run >>= return . unWrap + bs <- QC.run $ runIteratee it >>= run_ . enumLBS s - let enum = enumBS bs + let enum = enumLBS bs - iter <- do - i <- (readChunkedTransferEncoding stream2stream) >>= enum - return $ liftM unWrap i + x <- QC.run $ + runIteratee (joinI $ readChunkedTransferEncoding sstep) >>= + run_ . enum - x <- run iter QC.assert $ s == x -testBothChunkedBuffered1 :: Test -testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered2" $ - monadicIO prop - where - prop = do - sz <- QC.pick (choose (1000,4000)) - s' <- QC.pick $ resize sz arbitrary - ntimes <- QC.pick (choose (4,7)) - let e = enumLBS s' - let n = fromEnum $ L.length s' - - let enum = foldl' (>.) (enumBS "") (replicate ntimes e) - - (bufi,_) <- QC.run $ bufferIteratee stream2stream - iter' <- QC.run $ writeChunkedTransferEncoding bufi - let iter = I.joinI $ I.take n iter' - let iters = replicate ntimes iter - - let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t) - mempty - iters - - bs <- QC.run $ enum mothra - >>= run >>= return . unWrap - - - ---------------------------------------------------------------------- - -- 2nd pass, cancellation - let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s - (inputIter2,esc) <- QC.run $ bufferIteratee stream2stream - QC.run $ writeIORef esc True - - iter2' <- QC.run $ writeChunkedTransferEncoding inputIter2 - let iter2 = I.joinI $ I.take n iter2' - let iters2 = replicate ntimes iter2 - - let mothra2 = foldM (\s it -> it >>= \t -> return $ s `mappend` t) - mempty - iters2 - - - bs2 <- QC.run $ enum mothra2 - >>= run >>= return . unWrap - - - let e2 = enumBS bs2 - iters' <- QC.run $ - replicateM ntimes $ - readChunkedTransferEncoding stream2stream - let godzilla2 = sequence $ map (>>= pcrlf) iters' - outiter2 <- QC.run $ e2 godzilla2 - x2 <- QC.run $ liftM (map unWrap) $ run outiter2 - - QC.assert $ - (map (L.fromChunks . (:[])) x2) == (replicate ntimes s') - - - testBothChunkedPipelined :: Test -testBothChunkedPipelined = testProperty "testBothChunkedPipelined" $ +testBothChunkedPipelined = testProperty "parser/testBothChunkedPipelined" $ monadicIO prop where prop = do @@ -241,11 +167,13 @@ let e = enumLBS s' let n = fromEnum $ L.length s' - let enum = foldl' (>.) (enumBS "") (replicate ntimes e) + let enum = foldl' (>==>) (enumBS "") (replicate ntimes e) - (bufi,_) <- QC.run $ bufferIteratee stream2stream + bufi <- QC.run $ + unsafeBufferIteratee copyingStream2Stream >>= runIteratee - iter' <- QC.run $ writeChunkedTransferEncoding bufi + iter' <- QC.run $ runIteratee $ joinI $ + writeChunkedTransferEncoding bufi let iter = I.joinI $ I.take n iter' let iters = replicate ntimes iter @@ -253,29 +181,27 @@ mempty iters - bs <- QC.run $ enum mothra - >>= run >>= return . unWrap + bs <- QC.run $ runIteratee mothra >>= run_ . enum let e2 = enumBS bs - let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s + let pcrlf = \s -> iterParser $ string "\r\n" >> return s - iters <- QC.run $ - replicateM ntimes $ - readChunkedTransferEncoding stream2stream - let godzilla = sequence $ map (>>= pcrlf) iters + sstep <- QC.run $ runIteratee stream2stream - iter <- QC.run $ e2 godzilla + let iters' = replicate ntimes $ joinI $ + readChunkedTransferEncoding sstep + let godzilla = sequence $ map (>>= pcrlf) iters' - x <- QC.run $ liftM (map unWrap) $ run iter + x <- QC.run $ runIteratee godzilla >>= run_ . e2 QC.assert $ - (map (L.fromChunks . (:[])) x) == (replicate ntimes s') + x == (replicate ntimes s') testBothChunkedEmpty :: Test -testBothChunkedEmpty = testCase "testBothChunkedEmpty" prop +testBothChunkedEmpty = testCase "parser/testBothChunkedEmpty" prop where prop = do let s' = "" @@ -283,38 +209,40 @@ let n = fromEnum $ L.length s' let ntimes = 5 - let enum = foldl' (>.) (enumBS "") (replicate ntimes e) + let enum = foldl' (>==>) (enumBS "") (replicate ntimes e) - iter' <- writeChunkedTransferEncoding stream2stream - let iter = I.joinI $ I.take n iter' + sstep <- runIteratee stream2stream - let iters = replicate ntimes iter + step <- runIteratee $ + joinI $ + writeChunkedTransferEncoding sstep + iter <- liftM returnI $ runIteratee $ joinI $ I.take n step + + let iters = replicate ntimes (iter :: Iteratee ByteString IO L.ByteString) let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t) mempty iters - bs <- enum mothra - >>= run >>= return . unWrap - - let e2 = enumBS bs + mothraStep <- runIteratee mothra + bs <- run_ $ enum mothraStep - let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s + let e2 = enumLBS bs - iters <- replicateM ntimes $ - readChunkedTransferEncoding stream2stream - let godzilla = sequence $ map (>>= pcrlf) iters + let pcrlf = \s -> iterParser $ string "\r\n" >> return s - iter <- e2 godzilla + let iters' = replicate ntimes $ joinI $ + readChunkedTransferEncoding sstep + godzilla <- runIteratee $ sequence $ map (>>= pcrlf) iters' - x <- liftM (map unWrap) $ run iter + x <- run_ $ e2 godzilla assertBool "empty chunked transfer" $ - (map (L.fromChunks . (:[])) x) == (replicate ntimes s') + x == (replicate ntimes s') testCookie :: Test testCookie = - testCase "parseCookie" $ do + testCase "parser/parseCookie" $ do assertEqual "cookie parsing" (Just [cv]) cv2 where @@ -330,10 +258,23 @@ testFormEncoded :: Test -testFormEncoded = testCase "formEncoded" $ do +testFormEncoded = testCase "parser/formEncoded" $ do let bs = "foo1=bar1&foo2=bar2+baz2&foo3=foo%20bar" let mp = parseUrlEncoded bs assertEqual "foo1" (Just ["bar1"] ) $ Map.lookup "foo1" mp assertEqual "foo2" (Just ["bar2 baz2"]) $ Map.lookup "foo2" mp assertEqual "foo3" (Just ["foo bar"] ) $ Map.lookup "foo3" mp + + +copyingStream2Stream :: (Monad m) => Iteratee ByteString m ByteString +copyingStream2Stream = go [] + where + go l = do + mbx <- I.head + maybe (return $ S.concat $ reverse l) + (\x -> let !z = S.copy x in go (z:l)) + mbx + +stream2stream :: (Monad m) => Iteratee ByteString m L.ByteString +stream2stream = liftM L.fromChunks consume 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 @@ -2,16 +2,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE DeriveDataTypeable #-} module Snap.Internal.Http.Server.Tests ( tests ) where import Control.Concurrent -import Control.Exception ( try +import Control.Exception ( catch + , try , throwIO , bracket , finally - , SomeException ) + , SomeException + , Exception ) import Control.Monad import "monads-fd" Control.Monad.Trans import qualified Data.ByteString.Char8 as S @@ -22,16 +25,14 @@ import Data.Char import Data.Int import Data.IORef -import Data.Iteratee.WrappedByteString import qualified Data.Map as Map import Data.Maybe (fromJust) -import Data.Monoid import Data.Time.Calendar import Data.Time.Clock -import Data.Word -import qualified Network.HTTP as HTTP +import Data.Typeable +import qualified Network.HTTP.Enumerator as HTTP import qualified Network.Socket.ByteString as N -import Prelude hiding (take) +import Prelude hiding (catch, take) import qualified Prelude import System.Timeout import Test.Framework @@ -43,15 +44,15 @@ import Snap.Internal.Debug import Snap.Internal.Http.Types import Snap.Internal.Http.Server -import Snap.Iteratee +import qualified Snap.Iteratee as I +import Snap.Iteratee hiding (map) +import Snap.Internal.Http.Server.Backend import Snap.Test.Common import Snap.Types -#ifdef LIBEV -import qualified Snap.Internal.Http.Server.LibevBackend as Backend -#else -import qualified Snap.Internal.Http.Server.SimpleBackend as Backend -#endif +data TestException = TestException + deriving (Show, Typeable) +instance Exception TestException tests :: [Test] @@ -80,10 +81,7 @@ testTrivials :: Test testTrivials = testCase "server/trivials" $ do let !v = Svr.snapServerVersion - let !s1 = show Backend.BackendTerminatedException - let !s2 = show Backend.TimeoutException - - return $! v `seq` s1 `seq` s2 `seq` () + return $! v `seq` () ------------------------------------------------------------------------------ -- HTTP request tests @@ -139,38 +137,36 @@ ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ] -copyingStream2stream :: Iteratee IO (WrappedByteString Word8) -copyingStream2stream = IterateeG (step mempty) - where - step acc (Chunk (WrapBS ls)) - | S.null ls = return $ Cont (IterateeG (step acc)) Nothing - | otherwise = do - let !ls' = S.copy ls - let !bs' = WrapBS $! ls' - return $ Cont (IterateeG (step (acc `mappend` bs'))) - Nothing - step acc str = return $ Done acc str - - mkRequest :: ByteString -> IO Request mkRequest s = do - iter <- enumBS s $ liftM fromJust $ rsm receiveRequest - run iter + step <- runIteratee $ liftM fromJust $ rsm receiveRequest + let iter = enumBS s step + run_ iter +testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString) +testReceiveRequest = do + r <- liftM fromJust $ rsm receiveRequest + se <- liftIO $ readIORef (rqBody r) + let (SomeEnumerator e) = se + it <- liftM e $ lift $ runIteratee copyingStream2Stream + b <- it + return (r,b) + + +testReceiveRequestIter :: ByteString + -> IO (Iteratee ByteString IO (Request,L.ByteString)) +testReceiveRequestIter req = + liftM (enumBS req) $ runIteratee testReceiveRequest + + testHttpRequest1 :: Test testHttpRequest1 = testCase "server/HttpRequest1" $ do - iter <- enumBS sampleRequest $ - do - r <- liftM fromJust $ rsm receiveRequest - se <- liftIO $ readIORef (rqBody r) - let (SomeEnumerator e) = se - b <- liftM fromWrap $ joinIM $ e copyingStream2stream - return (r,b) + iter <- testReceiveRequestIter sampleRequest - (req,body) <- run iter + (req,body) <- run_ iter assertEqual "not secure" False $ rqIsSecure req @@ -205,20 +201,17 @@ testMultiRequest :: Test testMultiRequest = testCase "server/MultiRequest" $ do - iter <- (enumBS sampleRequest >. enumBS sampleRequest) $ - do - r1 <- liftM fromJust $ rsm receiveRequest - se1 <- liftIO $ readIORef (rqBody r1) - let (SomeEnumerator e1) = se1 - b1 <- liftM fromWrap $ joinIM $ e1 copyingStream2stream - r2 <- liftM fromJust $ rsm receiveRequest - se2 <- liftIO $ readIORef (rqBody r2) - let (SomeEnumerator e2) = se2 - b2 <- liftM fromWrap $ joinIM $ e2 copyingStream2stream - return (r1,b1,r2,b2) + let clientIter = do + (r1,b1) <- testReceiveRequest + (r2,b2) <- testReceiveRequest - (req1,body1,req2,body2) <- run iter + return (r1,b1,r2,b2) + iter <- liftM (enumBS sampleRequest >==> enumBS sampleRequest) $ + runIteratee clientIter + + (req1,body1,req2,body2) <- run_ iter + assertEqual "parse body 1" "0123456789" body1 assertEqual "parse body 2" "0123456789" body2 @@ -234,8 +227,9 @@ testOneMethod :: Method -> IO () testOneMethod m = do - iter <- enumLBS txt $ liftM fromJust $ rsm receiveRequest - req <- run iter + step <- runIteratee $ liftM fromJust $ rsm receiveRequest + let iter = enumLBS txt step + req <- run_ iter assertEqual "method" m $ rqMethod req @@ -256,9 +250,10 @@ testPartialParse :: Test testPartialParse = testCase "server/short" $ do - iter <- enumBS sampleShortRequest $ liftM fromJust $ rsm receiveRequest + step <- runIteratee $ liftM fromJust $ rsm receiveRequest + let iter = enumBS sampleShortRequest step - expectException $ run iter + expectException $ run_ iter methodTestText :: Method -> L.ByteString @@ -278,19 +273,11 @@ , "0123\r\n" , "0\r\n\r\n" ] - testHttpRequest2 :: Test testHttpRequest2 = testCase "server/HttpRequest2" $ do - iter <- enumBS sampleRequest2 $ - do - r <- liftM fromJust $ rsm receiveRequest - se <- liftIO $ readIORef (rqBody r) - let (SomeEnumerator e) = se - b <- liftM fromWrap $ joinIM $ e copyingStream2stream - return (r,b) - - (_,body) <- run iter + iter <- testReceiveRequestIter sampleRequest2 + (_,body) <- run_ iter assertEqual "parse body" "01234567890123" body @@ -298,15 +285,8 @@ testHttpRequest3 :: Test testHttpRequest3 = testCase "server/HttpRequest3" $ do - iter <- enumBS sampleRequest3 $ - do - r <- liftM fromJust $ rsm receiveRequest - se <- liftIO $ readIORef (rqBody r) - let (SomeEnumerator e) = se - b <- liftM fromWrap $ joinIM $ e copyingStream2stream - return (r,b) - - (req,body) <- run iter + iter <- testReceiveRequestIter sampleRequest3 + (req,body) <- run_ iter assertEqual "no cookies" [] $ rqCookies req @@ -331,15 +311,8 @@ testHttpRequest3' :: Test testHttpRequest3' = testCase "server/HttpRequest3'" $ do - iter <- enumBS sampleRequest3' $ - do - r <- liftM fromJust $ rsm receiveRequest - se <- liftIO $ readIORef (rqBody r) - let (SomeEnumerator e) = se - b <- liftM fromWrap $ joinIM $ e copyingStream2stream - return (r,b) - - (req,body) <- run iter + iter <- testReceiveRequestIter sampleRequest3' + (req,body) <- run_ iter assertEqual "post param 1" (rqParam "postparam1" req) @@ -383,8 +356,8 @@ -rsm :: ServerMonad a -> Iteratee IO a -rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1" 58382 alog elog +rsm :: ServerMonad a -> Iteratee ByteString IO a +rsm = runServerMonad "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58382 False) alog elog where alog = const . const . return $ () elog = const $ return () @@ -392,15 +365,12 @@ testHttpResponse1 :: Test testHttpResponse1 = testCase "server/HttpResponse1" $ do - let onSendFile = \f start sz -> - enumFilePartial f (start,start+sz) copyingStream2stream - >>= run - - req <- mkRequest sampleRequest + sstep <- runIteratee copyingStream2Stream + req <- mkRequest sampleRequest - b <- run $ rsm $ - sendResponse req rsp1 copyingStream2stream onSendFile >>= - return . fromWrap . snd + b <- run_ $ rsm $ + sendResponse req rsp1 sstep testOnSendFile >>= + return . snd assertEqual "http response" (L.concat [ "HTTP/1.0 600 Test\r\n" @@ -413,21 +383,24 @@ rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ setContentLength 10 $ setResponseStatus 600 "Test" $ - modifyResponseBody (>. (enumBS "0123456789")) $ - setResponseBody return $ + modifyResponseBody (>==> (enumBS "0123456789")) $ + setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } -testHttpResponse2 :: Test -testHttpResponse2 = testCase "server/HttpResponse2" $ do - let onSendFile = \f st sz -> - enumFilePartial f (st,st+sz) copyingStream2stream >>= run - req <- mkRequest sampleRequest +testOnSendFile :: FilePath -> Int64 -> Int64 -> IO L.ByteString +testOnSendFile f st sz = do + sstep <- runIteratee copyingStream2Stream + run_ $ enumFilePartial f (st,st+sz) sstep - b2 <- run $ rsm $ - sendResponse req rsp2 copyingStream2stream onSendFile >>= - return . fromWrap . snd +testHttpResponse2 :: Test +testHttpResponse2 = testCase "server/HttpResponse2" $ do + sstep <- runIteratee copyingStream2Stream + req <- mkRequest sampleRequest + b2 <- run_ $ rsm $ + sendResponse req rsp2 sstep testOnSendFile >>= + return . snd assertEqual "http response" (L.concat [ "HTTP/1.0 600 Test\r\n" @@ -439,22 +412,20 @@ rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ setContentLength 10 $ setResponseStatus 600 "Test" $ - modifyResponseBody (>. (enumBS "0123456789")) $ - setResponseBody return $ + modifyResponseBody (>==> (enumBS "0123456789")) $ + setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = rsp1 { rspContentLength = Nothing } testHttpResponse3 :: Test testHttpResponse3 = testCase "server/HttpResponse3" $ do - let onSendFile = \f st sz -> - enumFilePartial f (st,st+sz) copyingStream2stream >>= run - - req <- mkRequest sampleRequest + sstep <- runIteratee copyingStream2Stream + req <- mkRequest sampleRequest - b3 <- run $ rsm $ - sendResponse req rsp3 copyingStream2stream onSendFile >>= - return . fromWrap . snd + b3 <- run_ $ rsm $ + sendResponse req rsp3 sstep testOnSendFile >>= + return . snd assertEqual "http response" b3 $ L.concat [ "HTTP/1.1 600 Test\r\n" @@ -471,8 +442,8 @@ rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ setContentLength 10 $ setResponseStatus 600 "Test" $ - modifyResponseBody (>. (enumBS "0123456789")) $ - setResponseBody return $ + modifyResponseBody (>==> (enumBS "0123456789")) $ + setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = rsp1 { rspContentLength = Nothing } rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) }) @@ -480,14 +451,13 @@ testHttpResponse4 :: Test testHttpResponse4 = testCase "server/HttpResponse4" $ do - let onSendFile = \f st sz -> - enumFilePartial f (st,st+sz) copyingStream2stream >>= run + sstep <- runIteratee copyingStream2Stream req <- mkRequest sampleRequest - b <- run $ rsm $ - sendResponse req rsp1 copyingStream2stream onSendFile >>= - return . fromWrap . snd + b <- run_ $ rsm $ + sendResponse req rsp1 sstep testOnSendFile >>= + return . snd assertEqual "http response" (L.concat [ "HTTP/1.0 304 Test\r\n" @@ -499,20 +469,17 @@ emptyResponse { rspHttpVersion = (1,0) } --- httpServe "127.0.0.1" 8080 "localhost" pongServer - - echoServer :: (ByteString -> IO ()) -> Request - -> Iteratee IO (Request,Response) + -> Iteratee ByteString IO (Request,Response) echoServer _ req = do se <- liftIO $ readIORef (rqBody req) let (SomeEnumerator enum) = se - let i = joinIM $ enum copyingStream2stream - b <- liftM fromWrap i + i <- liftM enum $ lift $ runIteratee copyingStream2Stream + b <- i let cl = L.length b - liftIO $ writeIORef (rqBody req) (SomeEnumerator $ return . joinI . take 0) + liftIO $ writeIORef (rqBody req) (SomeEnumerator $ joinI . I.take 0) return (req, rsp b cl) where rsp s cl = emptyResponse { rspBody = Enum $ enumLBS s @@ -529,15 +496,15 @@ testHttp1 :: Test -testHttp1 = testCase "server/http session" $ do - let enumBody = enumBS sampleRequest >. enumBS sampleRequest2 +testHttp1 = testCase "server/httpSession" $ do + let enumBody = enumBS sampleRequest >==> enumBS sampleRequest2 ref <- newIORef "" let (iter,onSendFile) = mkIter ref - runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384 - Nothing Nothing enumBody iter onSendFile (return ()) echoServer + runHTTP Nothing Nothing echoServer "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) + enumBody iter onSendFile (return ()) s <- readIORef ref @@ -561,18 +528,25 @@ _ -> False + when (not ok) $ do + putStrLn "server/httpSession fail!!!! got:" + LC.putStrLn s + assertBool "pipelined responses" ok mkIter :: IORef L.ByteString - -> (Iteratee IO (), FilePath -> Int64 -> Int64 -> IO ()) + -> (Iteratee ByteString IO (), FilePath -> Int64 -> Int64 -> IO ()) mkIter ref = (iter, \f st sz -> onF f st sz iter) where iter = do - x <- copyingStream2stream - liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x) + x <- copyingStream2Stream + liftIO $ modifyIORef ref $ \s -> L.append s x - onF f st sz i = enumFilePartial f (st,st+sz) i >>= run + onF f st sz i = do + step <- runIteratee i + let it = enumFilePartial f (st,st+sz) step + run_ it testChunkOn1_0 :: Test @@ -583,8 +557,8 @@ let (iter,onSendFile) = mkIter ref done <- newEmptyMVar - forkIO (runHTTP "localhost" "127.0.0.1" 80 "127.0.0.1" 58384 - Nothing Nothing enumBody iter onSendFile (return ()) f + forkIO (runHTTP Nothing Nothing f "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) + enumBody iter onSendFile (return ()) `finally` putMVar done ()) takeMVar done @@ -620,7 +594,7 @@ testHttp2 :: Test testHttp2 = testCase "server/connection: close" $ do - let enumBody = enumBS sampleRequest4 >. enumBS sampleRequest2 + let enumBody = enumBS sampleRequest4 >==> enumBS sampleRequest2 ref <- newIORef "" @@ -628,18 +602,15 @@ done <- newEmptyMVar - forkIO (runHTTP "localhost" - "127.0.0.1" - 80 - "127.0.0.1" - 58384 - Nothing + forkIO (runHTTP Nothing Nothing + echoServer2 + "localhost" + (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile - (return ()) - echoServer2 `finally` putMVar done ()) + (return ()) `finally` putMVar done ()) takeMVar done @@ -665,25 +636,22 @@ testHttp100 :: Test -testHttp100 = testCase "server/Expect: 100-continue" $ do +testHttp100 = testCase "server/expect100" $ do let enumBody = enumBS sampleRequestExpectContinue ref <- newIORef "" let (iter,onSendFile) = mkIter ref - runHTTP "localhost" - "127.0.0.1" - 80 - "127.0.0.1" - 58384 - Nothing + runHTTP Nothing Nothing + echoServer2 + "localhost" + (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (return ()) - echoServer2 s <- readIORef ref @@ -703,6 +671,10 @@ _ -> False + when (not ok) $ do + putStrLn "expect100 fail! got:" + LC.putStrLn s + assertBool "100 Continue" ok @@ -714,18 +686,15 @@ let (iter,onSendFile) = mkIter ref - runHTTP "localhost" - "127.0.0.1" - 80 - "127.0.0.1" - 58384 - Nothing + runHTTP Nothing Nothing + echoServer2 + "localhost" + (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (return ()) - echoServer2 s <- readIORef ref @@ -759,46 +728,48 @@ testSendFile :: Test testSendFile = testCase "server/sendFile" $ do - bracket (forkIO $ httpServe "*" port "localhost" - Nothing Nothing - $ runSnap sendFileFoo) + bracket (forkIO serve) (killThread) (\tid -> do - m <- timeout (120 * seconds) $ go tid + m <- timeout (120 * seconds) $ go tid maybe (assertFailure "timeout") (const $ return ()) m) where + serve = (httpServe [HttpPort "*" port] Nothing "localhost" + Nothing Nothing + $ runSnap sendFileFoo) + `catch` \(_::SomeException) -> return () + go tid = do waitabit - - rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8123/") - doc <- HTTP.getResponseBody rsp - + + doc <- HTTP.simpleHttp "http://localhost:8123/" + killThread tid waitabit - + assertEqual "sendFile" "FOO\n" doc waitabit = threadDelay $ ((10::Int)^(6::Int)) port = 8123 - + testServerStartupShutdown :: Test testServerStartupShutdown = testCase "server/startup/shutdown" $ do bracket (forkIO $ - httpServe "*" - port + httpServe [HttpPort "*" port] + Nothing "localhost" (Just "test-access.log") (Just "test-error.log") (runSnap pongServer)) (killThread) (\tid -> do - m <- timeout (120 * seconds) $ go tid + m <- timeout (120 * seconds) $ go tid maybe (assertFailure "timeout") (const $ return ()) m) @@ -806,17 +777,18 @@ where go tid = do + debug $ "testServerStartupShutdown: waiting a bit" waitabit - - rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/") - doc <- HTTP.getResponseBody rsp + debug $ "testServerStartupShutdown: sending http request" + doc <- HTTP.simpleHttp "http://localhost:8145/" assertEqual "server" "PONG" doc + debug $ "testServerStartupShutdown: killing thread" killThread tid + debug $ "testServerStartupShutdown: kill signal sent to thread" waitabit - expectException $ HTTP.simpleHTTP - $ HTTP.getRequest "http://localhost:8145/" + expectException $ HTTP.simpleHttp "http://localhost:8145/" return () waitabit = threadDelay $ 2*((10::Int)^(6::Int)) @@ -827,8 +799,8 @@ testServerShutdownWithOpenConns :: Test testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do tid <- forkIO $ - httpServe "127.0.0.1" - port + httpServe [HttpPort "127.0.0.1" port] + Nothing "localhost" Nothing Nothing @@ -850,7 +822,7 @@ N.sendAll sock "Connection: close\r\n\r\n" resp <- recvAll sock - when (S.null resp) $ throwIO Backend.BackendTerminatedException + when (S.null resp) $ throwIO TestException let s = S.unpack $ Prelude.head $ ditchHeaders $ S.lines resp debug $ "got HTTP response " ++ s ++ ", we shouldn't be here...." @@ -875,3 +847,13 @@ seconds :: Int seconds = (10::Int) ^ (6::Int) + + +copyingStream2Stream :: (Monad m) => Iteratee ByteString m L.ByteString +copyingStream2Stream = go [] + where + go l = do + mbx <- I.head + maybe (return $ L.fromChunks $ reverse l) + (\x -> let !z = S.copy x in go (z:l)) + mbx 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 @@ -4,22 +4,20 @@ module Test.Blackbox ( tests + , ssltests , startTestServer ) where - +------------------------------------------------------------------------------ import Control.Concurrent +import Control.Exception (SomeException, catch) import Control.Monad -import Control.Monad.CatchIO -import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S -import qualified Data.DList as D +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L import Data.Int -import Data.Maybe (fromJust) -import qualified Network.HTTP as HTTP -import qualified Network.URI as URI -import Network.Socket +import qualified Network.HTTP.Enumerator as HTTP import qualified Network.Socket.ByteString as N -import Prelude hiding (take) +import Prelude hiding (catch, take) import System.Timeout import Test.Framework import Test.Framework.Providers.HUnit @@ -28,116 +26,147 @@ import Test.QuickCheck import qualified Test.QuickCheck.Monadic as QC import Test.QuickCheck.Monadic hiding (run, assert) - +------------------------------------------------------------------------------ import Snap.Http.Server import Snap.Test.Common - import Test.Common.Rot13 import Test.Common.TestHandler +------------------------------------------------------------------------------ +testFunctions :: [Bool -> Int -> String -> Test] +testFunctions = [ testPong +-- FIXME: waiting on http-enumerator patch for HEAD behaviour +-- , testHeadPong + , testEcho + , testRot13 + , testSlowLoris + , testBlockingRead + , testBigResponse + , testPartial + ] -tests :: Int -> [Test] -tests port = map ($ port) [ testPong - , testHeadPong - , testEcho - , testRot13 - , testSlowLoris - , testBlockingRead - , testBigResponse - , testPartial ] +------------------------------------------------------------------------------ +tests :: Int -> String -> [Test] +tests port name = map (\f -> f False port name) testFunctions -startTestServer :: IO (ThreadId,Int) -startTestServer = do - tid <- forkIO $ - httpServe "*" - port - "localhost" - (Just "ts-access.log") - (Just "ts-error.log") - testHandler - waitabit - return $ (tid, port) +------------------------------------------------------------------------------ +ssltests :: String -> Maybe Int -> [Test] +ssltests name = maybe [] httpsTests + where httpsTests port = map (\f -> f True port sslname) testFunctions + sslname = "ssl/" ++ name - where - port = 8199 +------------------------------------------------------------------------------ +startTestServer :: Int + -> Maybe Int + -> ConfigBackend + -> IO (ThreadId, MVar ()) +startTestServer port sslport backend = do + let cfg = setAccessLog (Just $ "ts-access." ++ show backend ++ ".log") . + setErrorLog (Just $ "ts-error." ++ show backend ++ ".log") . + addListen (ListenHttp "*" port) . + setBackend backend . + setVerbose False $ + defaultConfig + let cfg' = case sslport of + Nothing -> cfg + Just p -> addListen + (ListenHttps "*" p "cert.pem" "key.pem") + cfg -doPong :: Int -> IO String -doPong port = do - rsp <- HTTP.simpleHTTP $ - HTTP.getRequest $ - "http://localhost:" ++ show port ++ "/pong" + mvar <- newEmptyMVar + tid <- forkIO $ do + (httpServe cfg' testHandler) + `catch` \(_::SomeException) -> return () + putMVar mvar () + waitabit - HTTP.getResponseBody rsp + return (tid,mvar) -headPong :: Int -> IO String -headPong port = do - let req = (HTTP.getRequest $ - "http://localhost:" ++ show port ++ "/pong") - { HTTP.rqMethod = HTTP.HEAD } +------------------------------------------------------------------------------ +doPong :: Bool -> Int -> IO ByteString +doPong ssl port = do + let uri = (if ssl then "https" else "http") + ++ "://localhost:" ++ show port ++ "/pong" - rsp <- HTTP.simpleHTTP req + rsp <- HTTP.simpleHttp uri + return $ S.concat $ L.toChunks rsp - HTTP.getResponseBody rsp +------------------------------------------------------------------------------ +-- FIXME: waiting on http-enumerator patch for HEAD behaviour +-- headPong :: Bool -> Int -> IO ByteString +-- headPong ssl port = do +-- let uri = (if ssl then "https" else "http") +-- ++ "://localhost:" ++ show port ++ "/echo" -testPong :: Int -> Test -testPong port = testCase "blackbox/pong" $ do - doc <- doPong port +-- req0 <- HTTP.parseUrl uri + +-- let req = req0 { HTTP.method = "HEAD" } +-- rsp <- HTTP.httpLbs req +-- return $ S.concat $ L.toChunks $ HTTP.responseBody rsp + +------------------------------------------------------------------------------ +testPong :: Bool -> Int -> String -> Test +testPong ssl port name = testCase (name ++ "/blackbox/pong") $ do + doc <- doPong ssl port assertEqual "pong response" "PONG" doc -testHeadPong :: Int -> Test -testHeadPong port = testCase "blackbox/pong/HEAD" $ do - doc <- headPong port - assertEqual "pong HEAD response" "" doc +------------------------------------------------------------------------------ +-- FIXME: waiting on http-enumerator patch for HEAD behaviour +-- testHeadPong :: Bool -> Int -> String -> Test +-- testHeadPong ssl port name = testCase (name ++ "/blackbox/pong/HEAD") $ do +-- doc <- headPong ssl port +-- assertEqual "pong HEAD response" "" doc -testEcho :: Int -> Test -testEcho port = testProperty "blackbox/echo" $ - monadicIO $ forAllM arbitrary prop +------------------------------------------------------------------------------ +testEcho :: Bool -> Int -> String -> Test +testEcho ssl port name = testProperty (name ++ "/blackbox/echo") $ + monadicIO $ forAllM arbitrary prop where prop txt = do - let uri = fromJust $ - URI.parseURI $ - "http://localhost:" ++ show port ++ "/echo" - - let len = S.length txt + let uri = (if ssl then "https" else "http") + ++ "://localhost:" ++ show port ++ "/echo" - let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString - let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req' + req0 <- QC.run $ HTTP.parseUrl uri + let req = req0 { HTTP.requestBody = txt + , HTTP.method = "POST" } - rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody = (txt::S.ByteString) } - doc <- QC.run $ HTTP.getResponseBody rsp + rsp <- QC.run $ HTTP.httpLbs req + let doc = HTTP.responseBody rsp QC.assert $ txt == doc -testRot13 :: Int -> Test -testRot13 port = testProperty "blackbox/rot13" $ - monadicIO $ forAllM arbitrary prop +------------------------------------------------------------------------------ +testRot13 :: Bool -> Int -> String -> Test +testRot13 ssl port name = testProperty (name ++ "/blackbox/rot13") $ + monadicIO $ forAllM arbitrary prop where prop txt = do - let uri = fromJust $ - URI.parseURI $ - "http://localhost:" ++ show port ++ "/rot13" - - let len = S.length txt + let uri = (if ssl then "https" else "http") + ++ "://localhost:" ++ show port ++ "/rot13" - let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString - let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req' + req0 <- QC.run $ HTTP.parseUrl uri + let req = req0 { HTTP.requestBody = L.fromChunks [txt] + , HTTP.method = "POST" } - rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody = (txt::S.ByteString) } - doc <- QC.run $ HTTP.getResponseBody rsp + rsp <- QC.run $ HTTP.httpLbs req + let doc = S.concat $ L.toChunks $ HTTP.responseBody rsp QC.assert $ txt == rot13 doc -testSlowLoris :: Int -> Test -testSlowLoris port = testCase "blackbox/slowloris" $ withSock port go +------------------------------------------------------------------------------ +-- TODO: this one doesn't work w/ SSL +testSlowLoris :: Bool -> Int -> String -> Test +testSlowLoris ssl port name = testCase (name ++ "/blackbox/slowloris") $ + if ssl then return () else withSock port go where go sock = do @@ -162,15 +191,20 @@ loris sock -testBlockingRead :: Int -> Test -testBlockingRead port = testCase "blackbox/testBlockingRead" $ - withSock port $ \sock -> do - m <- timeout (60*seconds) $ go sock - maybe (assertFailure "timeout") - (const $ return ()) - m +------------------------------------------------------------------------------ +-- TODO: doesn't work w/ ssl +testBlockingRead :: Bool -> Int -> String -> Test +testBlockingRead ssl port name = + testCase (name ++ "/blackbox/testBlockingRead") $ + if ssl then return () else runIt where + runIt = withSock port $ \sock -> do + m <- timeout (60*seconds) $ go sock + maybe (assertFailure "timeout") + (const $ return ()) + m + go sock = do N.sendAll sock "GET /" waitabit @@ -186,33 +220,42 @@ assertEqual "pong response" "PONG" s +------------------------------------------------------------------------------ +-- TODO: no ssl here -- test server's ability to trap/recover from IO errors -testPartial :: Int -> Test -testPartial port = testCase "blackbox/testPartial" $ do - m <- timeout (60*seconds) go - maybe (assertFailure "timeout") - (const $ return ()) - m - +testPartial :: Bool -> Int -> String -> Test +testPartial ssl port name = + testCase (name ++ "/blackbox/testPartial") $ + if ssl then return () else runIt where + runIt = do + m <- timeout (60*seconds) go + maybe (assertFailure "timeout") + (const $ return ()) + m + go = do withSock port $ \sock -> N.sendAll sock "GET /pong HTTP/1.1\r\n" - doc <- doPong port + doc <- doPong ssl port assertEqual "pong response" "PONG" doc -testBigResponse :: Int -> Test -testBigResponse port = testCase "blackbox/testBigResponse" $ - withSock port $ \sock -> do - m <- timeout (120*seconds) $ go sock - maybe (assertFailure "timeout") - (const $ return ()) - m - +------------------------------------------------------------------------------ +-- TODO: no ssl +testBigResponse :: Bool -> Int -> String -> Test +testBigResponse ssl port name = + testCase (name ++ "/blackbox/testBigResponse") $ + if ssl then return () else runIt where + runIt = withSock port $ \sock -> do + m <- timeout (120*seconds) $ go sock + maybe (assertFailure "timeout") + (const $ return ()) + m + go sock = do N.sendAll sock "GET /bigresponse HTTP/1.1\r\n" N.sendAll sock "Host: 127.0.0.1\r\n" @@ -232,5 +275,6 @@ waitabit = threadDelay $ 2*seconds +------------------------------------------------------------------------------ seconds :: Int seconds = (10::Int) ^ (6::Int) diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -1,8 +1,14 @@ +{-# LANGUAGE CPP #-} + module Main where +import Control.Exception import Control.Concurrent (killThread) +import Control.Concurrent.MVar +import Control.Monad +import qualified Network.HTTP.Enumerator as HTTP import Test.Framework (defaultMain, testGroup) - +import Snap.Http.Server.Config import qualified Data.Concurrent.HashMap.Tests @@ -10,19 +16,47 @@ import qualified Snap.Internal.Http.Server.Tests import qualified Test.Blackbox +ports :: [Int] +ports = [8195..] + +#ifdef GNUTLS +sslports :: [Maybe Int] +sslports = map Just [8295..] +#else +sslports :: [Maybe Int] +sslports = repeat Nothing +#endif + +#ifdef LIBEV +backends :: [(Int,Maybe Int,ConfigBackend)] +backends = zip3 ports sslports [ConfigSimpleBackend, ConfigLibEvBackend] +#else +backends :: [(Int,Maybe Int,ConfigBackend)] +backends = zip3 ports sslports [ConfigSimpleBackend] +#endif + main :: IO () -main = do - (tid,pt) <- Test.Blackbox.startTestServer - defaultMain $ tests pt - killThread tid +main = HTTP.withHttpEnumerator $ do + tinfos <- forM backends $ \(port,sslport,b) -> + Test.Blackbox.startTestServer port sslport b - where tests pt = + defaultMain (tests ++ concatMap blackbox backends) `finally` do + mapM_ killThread $ map fst tinfos + mapM_ takeMVar $ map snd tinfos + + where tests = [ testGroup "Data.Concurrent.HashMap.Tests" Data.Concurrent.HashMap.Tests.tests , testGroup "Snap.Internal.Http.Parser.Tests" Snap.Internal.Http.Parser.Tests.tests , testGroup "Snap.Internal.Http.Server.Tests" Snap.Internal.Http.Server.Tests.tests - , testGroup "Test.Blackbox" - $ Test.Blackbox.tests pt ] + blackbox (port, sslport, b) = + [ testGroup ("Test.Blackbox " ++ backendName) + $ Test.Blackbox.tests port backendName + , testGroup ("Test.Blackbox SSL " ++ backendName) + $ Test.Blackbox.ssltests backendName sslport + ] + where + backendName = show b diff --git a/test/testserver/Main.hs b/test/testserver/Main.hs --- a/test/testserver/Main.hs +++ b/test/testserver/Main.hs @@ -5,6 +5,7 @@ module Main where import Control.Concurrent +import Control.Exception (finally) import Snap.Http.Server import Test.Common.TestHandler @@ -31,8 +32,5 @@ return () where - go m = do - httpServe "*" 3000 "localhost" (Just "ts-access.log") - (Just "ts-error.log") testHandler - putMVar m () + go m = quickHttpServe testHandler `finally` putMVar m ()