snap-server 0.2.16.2 → 0.3.0
raw patch · 29 files changed
+2733/−1690 lines, 29 filesdep +MonadCatchIO-transformersdep +attoparsec-enumeratordep +enumeratordep −attoparsec-iterateedep −iterateedep −monads-fddep ~networkdep ~snap-coredep ~unix-compat
Dependencies added: MonadCatchIO-transformers, attoparsec-enumerator, enumerator, mtl, utf8-string
Dependencies removed: attoparsec-iteratee, iteratee, monads-fd, network-bytestring
Dependency ranges changed: network, snap-core, unix-compat, vector-algorithms
Files
- CONTRIBUTORS +2/−1
- LICENSE +1/−0
- README.SNAP.md +5/−20
- README.md +23/−34
- snap-server.cabal +28/−16
- src/Data/Concurrent/HashMap.hs +3/−5
- src/Snap/Http/Server.hs +100/−20
- src/Snap/Http/Server/Config.hs +485/−90
- src/Snap/Internal/Http/Parser.hs +73/−77
- src/Snap/Internal/Http/Server.hs +212/−203
- src/Snap/Internal/Http/Server/Backend.hs +93/−0
- src/Snap/Internal/Http/Server/Date.hs +1/−15
- src/Snap/Internal/Http/Server/GnuTLS.hs +357/−0
- src/Snap/Internal/Http/Server/HttpPort.hs +117/−0
- src/Snap/Internal/Http/Server/LibevBackend.hs +335/−388
- src/Snap/Internal/Http/Server/ListenHelpers.hs +84/−0
- src/Snap/Internal/Http/Server/SimpleBackend.hs +218/−279
- src/Snap/Internal/Http/Server/TimeoutTable.hs +12/−0
- src/Snap/Internal/Http/Server/gnutls_helpers.c +17/−0
- src/System/FastLogger.hs +27/−17
- test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs +28/−17
- test/common/Test/Common/TestHandler.hs +13/−12
- test/pongserver/Main.hs +8/−7
- test/snap-server-testsuite.cabal +46/−43
- test/suite/Snap/Internal/Http/Parser/Tests.hs +91/−150
- test/suite/Snap/Internal/Http/Server/Tests.hs +164/−182
- test/suite/Test/Blackbox.hs +146/−102
- test/suite/TestSuite.hs +42/−8
- test/testserver/Main.hs +2/−4
CONTRIBUTORS view
@@ -2,5 +2,6 @@ Gregory Collins <greg@gregorycollins.net> Shu-yu Guo <shu@rfrn.org> Carl Howells <chowells79@gmail.com>+John Lenz <jlenz2@math.uiuc.edu> James Sanders <jimmyjazz14@gmail.com>-Jacob Stanley <jystic@jystic.com>+Jacob Stanley <jacob@stanley.io>
LICENSE view
@@ -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
README.SNAP.md view
@@ -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
README.md view
@@ -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
snap-server.cabal view
@@ -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
src/Data/Concurrent/HashMap.hs view
@@ -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
src/Snap/Http/Server.hs view
@@ -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
src/Snap/Http/Server/Config.hs view
@@ -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}
src/Snap/Internal/Http/Parser.hs view
@@ -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) ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server.hs view
@@ -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--
+ src/Snap/Internal/Http/Server/Backend.hs view
@@ -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+ }
src/Snap/Internal/Http/Server/Date.hs view
@@ -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 ------------------------------------------------------------------------------
+ src/Snap/Internal/Http/Server/GnuTLS.hs view
@@ -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
+ src/Snap/Internal/Http/Server/HttpPort.hs view
@@ -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
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -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
+ src/Snap/Internal/Http/Server/ListenHelpers.hs view
@@ -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
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -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
src/Snap/Internal/Http/Server/TimeoutTable.hs view
@@ -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
+ src/Snap/Internal/Http/Server/gnutls_helpers.c view
@@ -0,0 +1,17 @@+#include <gnutls/gnutls.h>+#include <gcrypt.h>+#include <errno.h>+#include <pthread.h>+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;+ }+}
src/System/FastLogger.hs view
@@ -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 ()
test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs view
@@ -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
test/common/Test/Common/TestHandler.hs view
@@ -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 ) ]-
test/pongserver/Main.hs view
@@ -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
test/snap-server-testsuite.cabal view
@@ -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
test/suite/Snap/Internal/Http/Parser/Tests.hs view
@@ -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
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -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
test/suite/Test/Blackbox.hs view
@@ -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)
test/suite/TestSuite.hs view
@@ -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
test/testserver/Main.hs view
@@ -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 ()