diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -36,6 +36,9 @@ , settingsTimeout , settingsIntercept , settingsManager + -- * Connection + , Connection (..) + , runSettingsConnection -- * Datatypes , Port , InvalidRequest (..) @@ -46,7 +49,6 @@ , sendResponse , registerKillThread , bindPort - , enumSocket , pause , resume , T.cancel @@ -86,17 +88,18 @@ import Data.Typeable (Typeable) -import Data.Enumerator (($$), (>>==)) -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.Enumerator.Binary as EB -import Blaze.ByteString.Builder.Enumerator (builderToByteString) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Blaze (builderToByteString) +import Control.Exception.Lifted (throwIO) import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Blaze.ByteString.Builder (copyByteString, Builder, toLazyByteString, toByteStringIO) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow) -import Data.Monoid (mappend, mconcat) +import Data.Monoid (mappend, mempty) import Network.Sendfile import qualified System.PosixCompat.Files as P @@ -106,7 +109,7 @@ import Timeout (Manager, registerKillThread, pause, resume) import Data.Word (Word8) import Data.List (foldl') -import Control.Monad (forever) +import Control.Monad (forever, when) import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import System.IO (hPutStrLn, stderr) @@ -117,15 +120,47 @@ import Network.Socket (withSocketsDo) #endif -#ifndef MEGA import Data.Version (showVersion) import qualified Paths_warp -warpVersion = showVersion Paths_warp.version -#else -warpVersion = "0.4.6" -#endif + warpVersion :: String +warpVersion = showVersion Paths_warp.version +-- | +-- +-- In order to provide slowloris protection, Warp provides timeout handlers. We +-- follow these rules: +-- +-- * A timeout is created when a connection is opened. +-- +-- * When all request headers are read, the timeout is tickled. +-- +-- * Every time at least 2048 bytes of the request body are read, the timeout +-- is tickled. +-- +-- * The timeout is paused while executing user code. This will apply to both +-- the application itself, and a ResponseSource response. The timeout is +-- resumed as soon as we return from user code. +-- +-- * Every time data is successfully sent to the client, the timeout is tickled. +data Connection = Connection + { connSendMany :: [B.ByteString] -> IO () + , connSendAll :: B.ByteString -> IO () + , connSendFile :: FilePath -> Integer -> Integer -> IO () -> IO () -- ^ offset, length + , connClose :: IO () + , connRecv :: IO B.ByteString + } + +socketConnection :: Socket -> Connection +socketConnection s = Connection + { connSendMany = Sock.sendMany s + , connSendAll = Sock.sendAll s + , connSendFile = \fp off len act -> sendfile s fp (PartOfFile off len) act + , connClose = sClose s + , connRecv = Sock.recv s bytesPerRead + } + + bindPort :: Int -> String -> IO Socket bindPort p s = do let hints = defaultHints { addrFlags = [AI_PASSIVE @@ -185,48 +220,66 @@ -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO () runSettingsSocket set socket app = do + runSettingsConnection set getter app + where + getter = do + (conn, sa) <- accept socket + return (socketConnection conn, sa) + +runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () +runSettingsConnection set getConn app = do let onE = settingsOnException set port = settingsPort set tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return $ settingsManager set forever $ do - (conn, sa) <- accept socket + (conn, addr) <- getConn _ <- forkIO $ do th <- T.registerKillThread tm - serveConnection set th onE port app conn sa + serveConnection set th onE port app conn addr T.cancel th return () serveConnection :: Settings -> T.Handle -> (SomeException -> IO ()) - -> Port -> Application -> Socket -> SockAddr -> IO () + -> Port -> Application -> Connection -> SockAddr -> IO () serveConnection settings th onException port app conn remoteHost' = do catch (finally - (E.run_ $ fromClient $$ serveConnection') - (sClose conn)) + (runResourceT serveConnection') + (connClose conn)) onException where - fromClient = enumSocket th bytesPerRead conn + serveConnection' :: ResourceT IO () serveConnection' = do - (len, env) <- parseRequest port remoteHost' + fromClient <- C.bufferSource $ C.Source $ return $ connSource conn th + serveConnection'' fromClient + + serveConnection'' fromClient = do + env <- parseRequest port remoteHost' fromClient case settingsIntercept settings env of Nothing -> do -- Let the application run for as long as it wants liftIO $ T.pause th - res <- E.joinI $ EB.isolate len $$ app env + res <- app env + + -- flush the rest of the request body + requestBody env C.$$ CL.sinkNull + liftIO $ T.resume th - keepAlive <- liftIO $ sendResponse th env conn res - if keepAlive then serveConnection' else return () + keepAlive <- sendResponse th env conn res + if keepAlive then serveConnection'' fromClient else return () Just intercept -> do liftIO $ T.pause th - intercept conn + intercept fromClient conn -parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request) -parseRequest port remoteHost' = do - headers' <- takeHeaders - parseRequest' port headers' remoteHost' +parseRequest :: Port -> SockAddr + -> C.BufferedSource IO S.ByteString + -> ResourceT IO Request +parseRequest port remoteHost' src = do + headers' <- src C.$$ takeHeaders + parseRequest' port headers' remoteHost' src -- FIXME come up with good values here bytesPerRead, maxTotalHeaderLength :: Int @@ -238,7 +291,6 @@ | BadFirstLine String | NonHttp | IncompleteHeaders - | ConnectionClosedByPeer | OverLargeHeader deriving (Show, Typeable, Eq) instance Exception InvalidRequest @@ -247,9 +299,10 @@ parseRequest' :: Port -> [ByteString] -> SockAddr - -> E.Iteratee S.ByteString IO (Integer, Request) -parseRequest' _ [] _ = E.throwError $ NotEnoughLines [] -parseRequest' port (firstLine:otherLines) remoteHost' = do + -> C.BufferedSource IO S.ByteString + -> ResourceT IO Request +parseRequest' _ [] _ _ = throwIO $ NotEnoughLines [] +parseRequest' port (firstLine:otherLines) remoteHost' src = do (method, rpath', gets, httpversion) <- parseFirst firstLine let (host',rpath) = if S.null rpath' @@ -266,19 +319,25 @@ let serverName' = takeUntil 58 host -- ':' -- FIXME isolate takes an Integer instead of Int or Int64. If this is a -- performance penalty, we may need our own version. - return (len, Request - { requestMethod = method - , httpVersion = httpversion - , pathInfo = H.decodePathSegments rpath - , rawPathInfo = rpath - , rawQueryString = gets - , queryString = H.parseQuery gets - , serverName = serverName' - , serverPort = port - , requestHeaders = heads - , isSecure = False - , remoteHost = remoteHost' - }) + rbody <- C.prepareSource $ + if len == 0 + then mempty + else src C.$= CB.isolate len + return Request + { requestMethod = method + , httpVersion = httpversion + , pathInfo = H.decodePathSegments rpath + , rawPathInfo = rpath + , rawQueryString = gets + , queryString = H.parseQuery gets + , serverName = serverName' + , serverPort = port + , requestHeaders = heads + , isSecure = False + , remoteHost = remoteHost' + , requestBody = C.Source $ return rbody + , vault = mempty + } takeUntil :: Word8 -> ByteString -> ByteString @@ -289,7 +348,7 @@ {-# INLINE takeUntil #-} parseFirst :: ByteString - -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, H.HttpVersion) + -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion) parseFirst s = case S.split 32 s of -- ' ' [method, query, http'] -> do @@ -301,8 +360,8 @@ "1.1" -> H.http11 _ -> H.http10 in return (method, rpath, qstring, hv) - else E.throwError NonHttp - _ -> E.throwError $ BadFirstLine $ B.unpack s + else throwIO NonHttp + _ -> throwIO $ BadFirstLine $ B.unpack s {-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder @@ -360,8 +419,8 @@ H.statusCode s >= 200 && requestMethod req /= "HEAD" sendResponse :: T.Handle - -> Request -> Socket -> Response -> IO Bool -sendResponse th req socket r = sendResponse' r + -> Request -> Connection -> Response -> ResourceT IO Bool +sendResponse th req conn r = sendResponse' r where version = httpVersion req isPersist = checkPersist req @@ -370,8 +429,8 @@ isKeepAlive hs = isPersist && (isChunked' || hasLength hs) hasLength hs = lookup "content-length" hs /= Nothing - sendResponse' :: Response -> IO Bool - sendResponse' (ResponseFile s hs fp mpart) = do + sendResponse' :: Response -> ResourceT IO Bool + sendResponse' (ResponseFile s hs fp mpart) = liftIO $ do (lengthyHeaders, cl) <- case (readInt `fmap` lookup "content-length" hs, mpart) of (Just cl, _) -> return (hs, cl) @@ -381,32 +440,28 @@ (Nothing, Just part) -> do let cl = filePartByteCount part return $ addClToHeaders cl - Sock.sendMany socket $ L.toChunks $ toLazyByteString $ + connSendMany conn $ L.toChunks $ toLazyByteString $ headers version s lengthyHeaders False + T.tickle th + if not (hasBody s req) then return isPersist else do case mpart of - Nothing -> sendfile socket fp PartOfFile { - rangeOffset = 0 - , rangeLength = cl - } (T.tickle th) - Just part -> sendfile socket fp PartOfFile { - rangeOffset = filePartOffset part - , rangeLength = filePartByteCount part - } (T.tickle th) + Nothing -> connSendFile conn fp 0 cl (T.tickle th) + Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th) T.tickle th return isPersist where addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl) sendResponse' (ResponseBuilder s hs b) - | hasBody s req = do + | hasBody s req = liftIO $ do toByteStringIO (\bs -> do - Sock.sendAll socket bs + connSendAll conn bs T.tickle th) body return (isKeepAlive hs) - | otherwise = do - Sock.sendMany socket + | otherwise = liftIO $ do + connSendMany conn $ L.toChunks $ toLazyByteString $ headers' False @@ -421,33 +476,35 @@ `mappend` chunkedTransferTerminator else (headers' False) `mappend` b - sendResponse' (ResponseEnumerator res) = res enumResponse + sendResponse' (ResponseSource s hs body) = + response where - enumResponse s hs = response True - where - headers' = headers version s hs - -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope) - response _ | not (hasBody s req) = do - liftIO $ Sock.sendMany socket - $ L.toChunks $ toLazyByteString - $ headers' False - return (checkPersist req) - response _ = chunk' - $ E.enumList 1 [headers' needsChunked'] - $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString - $$ (iterSocket th socket >> return (isKeepAlive hs)) - where - needsChunked' = needsChunked hs - chunk' i = if needsChunked' - then E.joinI $ chunk $$ i - else i - chunk :: E.Enumeratee Builder Builder IO Bool - chunk = E.checkDone $ E.continue . step - step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return - step k (E.Chunks []) = E.continue $ step k - step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk - step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk + headers' = headers version s hs + -- FIXME perhaps alloca a buffer per thread and reuse that in all + -- functions below. Should lessen greatly the GC burden (I hope) + response + | not (hasBody s req) = liftIO $ do + connSendMany conn + $ L.toChunks $ toLazyByteString + $ headers' False + T.tickle th + return (checkPersist req) + | otherwise = do + let src = + CL.sourceList [headers' needsChunked'] `mappend` + (if needsChunked' then body C.$= chunk else body) + src C.$$ builderToByteString C.=$ connSink conn th + return $ isKeepAlive hs + needsChunked' = needsChunked hs + chunk :: C.Conduit Builder IO Builder + chunk = C.Conduit $ return $ C.PreparedConduit + { C.conduitPush = push + , C.conduitClose = close + } + push x = return $ C.Producing [chunkedTransferEncoding x] + close = return [chunkedTransferTerminator] + parseHeaderNoAttr :: ByteString -> H.Header parseHeaderNoAttr s = let (k, rest) = S.breakByte 58 s -- ':' @@ -458,38 +515,39 @@ else rest in (CI.mk k, rest') -enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a -enumSocket th len socket = - inner - where - inner (E.Continue k) = do - bs <- liftIO $ Sock.recv socket len - liftIO $ T.tickle th +connSource :: Connection -> T.Handle -> C.PreparedSource IO ByteString +connSource Connection { connRecv = recv } th = C.PreparedSource + { C.sourcePull = do + bs <- liftIO recv if S.null bs - then E.continue k - else k (E.Chunks [bs]) >>== inner - inner step = E.returnI step ------- The functions below are not warp-specific and could be split out into a ---separate package. + then return C.Closed + else do + when (S.length bs >= 2048) $ liftIO $ T.tickle th + return (C.Open bs) + , C.sourceClose = return () + } -iterSocket :: T.Handle - -> Socket - -> E.Iteratee B.ByteString IO () -iterSocket th sock = - E.continue step +-- | Use 'connSendAll' to send this data while respecting timeout rules. +connSink :: Connection -> T.Handle -> C.Sink B.ByteString IO () +connSink Connection { connSendAll = send } th = C.Sink $ return $ C.SinkData + { C.sinkPush = push + , C.sinkClose = close + } where + close = liftIO (T.resume th) + push x = do + liftIO $ T.resume th + liftIO $ send x + liftIO $ T.pause th + return $ C.Processing -- We pause timeouts before passing control back to user code. This ensures -- that a timeout will only ever be executed when Warp is in control. We -- also make sure to resume the timeout after the completion of user code -- so that we can kill idle connections. - step E.EOF = liftIO (T.resume th) >> E.yield () E.EOF - step (E.Chunks []) = E.continue step - step (E.Chunks xs) = do - liftIO $ T.resume th - liftIO $ Sock.sendMany sock xs - liftIO $ T.pause th - E.continue step +------ The functions below are not warp-specific and could be split out into a +--separate package. + -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create a 'Settings' value, use 'defaultSettings' @@ -501,7 +559,7 @@ , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: * , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 - , settingsIntercept :: Request -> Maybe (Socket -> E.Iteratee S.ByteString IO ()) + , settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Connection -> ResourceT IO ()) , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' } @@ -528,69 +586,63 @@ go' (Just ThreadKilled) = False go' _ = True -takeHeaders :: E.Iteratee ByteString IO [ByteString] -takeHeaders = do - !x <- forceHead ConnectionClosedByPeer - takeHeaders' 0 id id x - -{-# INLINE takeHeaders #-} +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] -takeHeaders' :: Int - -> ([ByteString] -> [ByteString]) - -> ([ByteString] -> [ByteString]) - -> ByteString - -> E.Iteratee S.ByteString IO [ByteString] -takeHeaders' !len _ _ _ | len > maxTotalHeaderLength = E.throwError OverLargeHeader -takeHeaders' !len !lines !prepend !bs = do - let !bsLen = {-# SCC "takeHeaders'.bsLen" #-} S.length bs - !mnl = {-# SCC "takeHeaders'.mnl" #-} S.elemIndex 10 bs - case mnl of - -- no newline. prepend entire bs to next line - !Nothing -> {-# SCC "takeHeaders'.noNewline" #-} do - let !len' = len + bsLen - !more <- forceHead IncompleteHeaders - takeHeaders' len' lines (prepend . (:) bs) more - Just !nl -> {-# SCC "takeHeaders'.newline" #-} do - let !end = nl - !start = nl + 1 - !line = {-# SCC "takeHeaders'.line" #-} - if end > 0 - -- line data included in this chunk - then S.concat $! prepend [SU.unsafeTake (checkCR bs end) bs] - --then S.concat $! prepend [SU.unsafeTake (end-1) bs] - -- no line data in this chunk (all in prepend, or empty line) - else S.concat $! prepend [] - if S.null line - -- no more headers - then {-# SCC "takeHeaders'.noMoreHeaders" #-} do - let !lines' = {-# SCC "takeHeaders'.noMoreHeaders.lines'" #-} lines [] - if start < bsLen - then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do - let !rest = {-# SCC "takeHeaders'.noMoreHeaders.yield.rest" #-} SU.unsafeDrop start bs - E.yield lines' $! E.Chunks [rest] - else return lines' +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + BSEndoList -- previously parsed lines + BSEndo -- bytestrings to be prepended - -- more headers - else {-# SCC "takeHeaders'.moreHeaders" #-} do - let !len' = len + start - !lines' = {-# SCC "takeHeaders.lines'" #-} lines . (:) line - !more <- {-# SCC "takeHeaders'.more" #-} - if start < bsLen - then return $! SU.unsafeDrop start bs - else forceHead IncompleteHeaders - {-# SCC "takeHeaders'.takeMore" #-} takeHeaders' len' lines' id more -{-# INLINE takeHeaders' #-} +takeHeaders :: C.Sink ByteString IO [ByteString] +takeHeaders = + C.sinkState (THStatus 0 id id) takeHeadersPush close + where + close _ = throwIO IncompleteHeaders +{-# INLINE takeHeaders #-} -forceHead :: InvalidRequest -> E.Iteratee ByteString IO ByteString -forceHead err = do - !mx <- EL.head - case mx of - !Nothing -> E.throwError err - Just !x -> return x -{-# INLINE forceHead #-} +takeHeadersPush :: THStatus + -> ByteString + -> ResourceT IO (THStatus, C.SinkResult ByteString [ByteString]) +takeHeadersPush (THStatus len _ _ ) _ + | len > maxTotalHeaderLength = throwIO OverLargeHeader +takeHeadersPush (THStatus len lines prepend) bs = + case mnl of + -- no newline. prepend entire bs to next line + Nothing -> do + let len' = len + bsLen + return (THStatus len' lines (prepend . S.append bs), C.Processing) + Just nl -> do + let end = nl + start = nl + 1 + line = prepend (if end > 0 + then SU.unsafeTake (checkCR bs end) bs + else S.empty) + if S.null line + -- no more headers + then do + let lines' = lines [] + if start < bsLen + then do + let rest = SU.unsafeDrop start bs + return (undefined, C.Done (Just rest) lines') + else return (undefined, C.Done Nothing lines') + -- more headers + else do + let len' = len + start + lines' = lines . (:) line + if start < bsLen + then do + let more = SU.unsafeDrop start bs + takeHeadersPush (THStatus len' lines' id) more + else return (THStatus len' lines' id, C.Processing) + where + bsLen = S.length bs + mnl = S.elemIndex 10 bs +{-# INLINE takeHeadersPush #-} checkCR :: ByteString -> Int -> Int -checkCR bs pos = +checkCR bs pos = let !p = pos - 1 in if '\r' == B.index bs p then p diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} +import Network.Wai +import Network.Wai.Handler.Warp +import qualified Data.IORef as I +import Control.Monad.IO.Class (MonadIO, liftIO) +import Network.HTTP.Types +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Monad (forM_) + +import System.IO (hFlush) +import System.IO.Unsafe (unsafePerformIO) +import Data.ByteString (ByteString, hPutStr, hGetSome) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Network (connectTo, PortID (PortNumber)) + +import Test.Hspec.Monadic +import Test.Hspec.HUnit () +import Test.HUnit + +import Data.Conduit (($$)) +import qualified Data.Conduit.List + +type Counter = I.IORef (Either String Int) +type CounterApplication = Counter -> Application + +incr :: MonadIO m => Counter -> m () +incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount -> + ((case ecount of + Left s -> Left s + Right i -> Right $ i + 1), ()) + +err :: (MonadIO m, Show a) => Counter -> a -> m () +err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg + +readBody :: CounterApplication +readBody icount req = do + body <- requestBody req $$ Data.Conduit.List.consume + case () of + () + | pathInfo req == ["hello"] && L.fromChunks body /= "Hello" + -> err icount ("Invalid hello" :: String, body) + | requestMethod req == "GET" && L.fromChunks body /= "" + -> err icount ("Invalid GET" :: String, body) + | not $ requestMethod req `elem` ["GET", "POST"] + -> err icount ("Invalid request method (readBody)" :: String, requestMethod req) + | otherwise -> incr icount + return $ responseLBS status200 [] "Read the body" + +ignoreBody :: CounterApplication +ignoreBody icount req = do + if (requestMethod req `elem` ["GET", "POST"]) + then incr icount + else err icount ("Invalid request method" :: String, requestMethod req) + return $ responseLBS status200 [] "Ignored the body" + +nextPort :: I.IORef Int +nextPort = unsafePerformIO $ I.newIORef 5000 + +getPort :: IO Int +getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p) + +runTest :: Int -- ^ expected number of requests + -> CounterApplication + -> [ByteString] -- ^ chunks to send + -> IO () +runTest expected app chunks = do + port <- getPort + ref <- I.newIORef (Right 0) + tid <- forkIO $ run port $ app ref + threadDelay 1000 + handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port + forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle + _ <- hGetSome handle 4096 + threadDelay 1000 + killThread tid + res <- I.readIORef ref + case res of + Left s -> error s + Right i -> i @?= expected + +singleGet :: ByteString +singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" + +singlePostHello :: ByteString +singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello" + +main :: IO () +main = hspecX $ do + describe "non-pipelining" $ do + it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet + it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet + it "has body, read" $ runTest 2 readBody + [ singlePostHello + , singleGet + ] + it "has body, ignore" $ runTest 2 ignoreBody + [ singlePostHello + , singleGet + ] + describe "pipelining" $ do + it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet] + it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet] + it "has body, read" $ runTest 2 readBody $ return $ S.concat + [ singlePostHello + , singleGet + ] + it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat + [ singlePostHello + , singleGet + ] diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 0.4.6.3 +Version: 1.0.0 Synopsis: A fast, light-weight web server for WAI applications. License: BSD3 License-file: LICENSE @@ -8,9 +8,10 @@ Homepage: http://github.com/yesodweb/wai Category: Web, Yesod Build-Type: Simple -Cabal-Version: >=1.6 +Cabal-Version: >=1.8 Stability: Stable Description: The premier WAI handler. For more information, see . +extra-source-files: test/main.hs flag network-bytestring Default: False @@ -18,10 +19,11 @@ Library Build-Depends: base >= 3 && < 5 , bytestring >= 0.9.1.4 && < 0.10 - , wai >= 0.4 && < 0.5 - , blaze-builder-enumerator >= 0.2 && < 0.3 + , wai >= 1.0 && < 1.1 , transformers >= 0.2.2 && < 0.3 - , enumerator >= 0.4.8 && < 0.5 + , conduit + , blaze-builder-conduit >= 0.0.1 && < 0.1 + , lifted-base >= 0.1 && < 0.2 , blaze-builder >= 0.2.1.4 && < 0.4 , simple-sendfile >= 0.1 && < 0.3 , http-types >= 0.6 && < 0.7 @@ -38,6 +40,23 @@ ghc-options: -Wall if os(windows) Cpp-options: -DWINDOWS + +test-suite test + main-is: main.hs + hs-source-dirs: test + type: exitcode-stdio-1.0 + + ghc-options: -Wall + build-depends: base >= 4 && < 5 + , HUnit + , hspec + , bytestring + , warp + , conduit + , network + , http-types + , transformers + , wai source-repository head type: git