warp 0.4.6.3 → 1.0.0
raw patch · 3 files changed
+360/−178 lines, 3 filesdep +HUnitdep +blaze-builder-conduitdep +conduitdep −blaze-builder-enumeratordep −enumeratordep ~basedep ~bytestringdep ~http-types
Dependencies added: HUnit, blaze-builder-conduit, conduit, hspec, lifted-base, warp
Dependencies removed: blaze-builder-enumerator, enumerator
Dependency ranges changed: base, bytestring, http-types, network, transformers, wai
Files
- Network/Wai/Handler/Warp.hs +225/−173
- test/main.hs +111/−0
- warp.cabal +24/−5
Network/Wai/Handler/Warp.hs view
@@ -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
+ test/main.hs view
@@ -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+ ]
warp.cabal view
@@ -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 <http://steve.vinoski.net/blog/2011/05/01/warp-a-haskell-web-server/>.+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