warp 1.0.0.1 → 1.1.0
raw patch · 4 files changed
+411/−92 lines, 4 filesdep +HUnitdep +ghc-primdep +hspecdep ~basedep ~blaze-builder-conduitdep ~bytestring
Dependencies added: HUnit, ghc-prim, hspec, warp
Dependency ranges changed: base, blaze-builder-conduit, bytestring, conduit, http-types, network, transformers, wai
Files
- Network/Wai/Handler/Warp.hs +208/−88
- ReadInt.hs +58/−0
- test/main.hs +121/−0
- warp.cabal +24/−4
Network/Wai/Handler/Warp.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- -- Module : Network.Wai.Handler.Warp@@ -36,6 +38,8 @@ , settingsTimeout , settingsIntercept , settingsManager+ -- ** Data types+ , HostPreference (..) -- * Connection , Connection (..) , runSettingsConnection@@ -81,23 +85,22 @@ ( bracket, finally, Exception, SomeException, catch , fromException, AsyncException (ThreadKilled) , bracketOnError+ , IOException ) import Control.Concurrent (forkIO)-import qualified Data.Char as C-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust) import Data.Typeable (Typeable) 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)+ (copyByteString, Builder, toLazyByteString, toByteStringIO, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow) import Data.Monoid (mappend, mempty) import Network.Sendfile@@ -113,6 +116,9 @@ import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import System.IO (hPutStrLn, stderr)+import ReadInt (readInt64)+import qualified Data.IORef as I+import Data.String (IsString (..)) #if WINDOWS import Control.Concurrent (threadDelay)@@ -161,29 +167,46 @@ } -bindPort :: Int -> String -> IO Socket+bindPort :: Int -> HostPreference -> IO Socket bindPort p s = do let hints = defaultHints { addrFlags = [AI_PASSIVE , AI_NUMERICSERV , AI_NUMERICHOST] , addrSocketType = Stream }- host = if s == "*" then Nothing else Just s+ host =+ case s of+ Host s' -> Just s'+ _ -> Nothing port = Just . show $ p addrs <- getAddrInfo (Just hints) host port -- Choose an IPv6 socket if exists. This ensures the socket can -- handle both IPv4 and IPv6 if v6only is false.- let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs- addr = if null addrs' then head addrs else head addrs'- bracketOnError- (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))- (sClose)- (\sock -> do- setSocketOption sock ReuseAddr 1- bindSocket sock (addrAddress addr)- listen sock maxListenQueue- return sock- )+ let addrs4 = filter (\x -> addrFamily x /= AF_INET6) addrs+ addrs6 = filter (\x -> addrFamily x == AF_INET6) addrs+ addrs' =+ case s of+ HostIPv4 -> addrs4 ++ addrs6+ HostIPv6 -> addrs6 ++ addrs4+ _ -> addrs + tryAddrs (addr1:rest@(_:_)) = + catch+ (theBody addr1) + (\(_ :: IOException) -> tryAddrs rest)+ tryAddrs (addr1:[]) = theBody addr1+ tryAddrs _ = error "bindPort: addrs is empty"+ theBody addr = + bracketOnError+ (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))+ (sClose)+ (\sock -> do+ setSocketOption sock ReuseAddr 1+ bindSocket sock (addrAddress addr)+ listen sock maxListenQueue+ return sock+ )+ tryAddrs addrs'+ -- | Run an 'Application' on the given port. This calls 'runSettings' with -- 'defaultSettings'. run :: Port -> Application -> IO ()@@ -207,7 +230,7 @@ bracket (bindPort (settingsPort set) (settingsHost set)) sClose .- (flip (runSettingsSocket set))+ flip (runSettingsSocket set) #endif type Port = Int@@ -219,7 +242,7 @@ -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO ()-runSettingsSocket set socket app = do+runSettingsSocket set socket app = runSettingsConnection set getter app where getter = do@@ -244,7 +267,7 @@ -> T.Handle -> (SomeException -> IO ()) -> Port -> Application -> Connection -> SockAddr -> IO ()-serveConnection settings th onException port app conn remoteHost' = do+serveConnection settings th onException port app conn remoteHost' = catch (finally (runResourceT serveConnection')@@ -253,11 +276,11 @@ where serveConnection' :: ResourceT IO () serveConnection' = do- fromClient <- C.bufferSource $ C.Source $ return $ connSource conn th+ fromClient <- C.bufferSource $ connSource conn th serveConnection'' fromClient serveConnection'' fromClient = do- env <- parseRequest port remoteHost' fromClient+ env <- parseRequest conn port remoteHost' fromClient case settingsIntercept settings env of Nothing -> do -- Let the application run for as long as it wants@@ -269,17 +292,17 @@ liftIO $ T.resume th keepAlive <- sendResponse th env conn res- if keepAlive then serveConnection'' fromClient else return ()+ when keepAlive $ serveConnection'' fromClient Just intercept -> do liftIO $ T.pause th intercept fromClient conn -parseRequest :: Port -> SockAddr+parseRequest :: Connection -> Port -> SockAddr -> C.BufferedSource IO S.ByteString -> ResourceT IO Request-parseRequest port remoteHost' src = do+parseRequest conn port remoteHost' src = do headers' <- src C.$$ takeHeaders- parseRequest' port headers' remoteHost' src+ parseRequest' conn port headers' remoteHost' src -- FIXME come up with good values here bytesPerRead, maxTotalHeaderLength :: Int@@ -295,34 +318,94 @@ deriving (Show, Typeable, Eq) instance Exception InvalidRequest +handleExpect :: Connection+ -> H.HttpVersion+ -> ([H.Header] -> [H.Header])+ -> [H.Header]+ -> IO [H.Header]+handleExpect _ _ front [] = return $ front []+handleExpect conn hv front (("expect", "100-continue"):rest) = do+ connSendAll conn $+ if hv == H.http11+ then "HTTP/1.1 100 Continue\r\n\r\n"+ else "HTTP/1.0 100 Continue\r\n\r\n"+ return $ front rest+handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs+ -- | Parse a set of header lines and body into a 'Request'.-parseRequest' :: Port+parseRequest' :: Connection+ -> Port -> [ByteString] -> SockAddr -> C.BufferedSource IO S.ByteString -> ResourceT IO Request-parseRequest' _ [] _ _ = throwIO $ NotEnoughLines []-parseRequest' port (firstLine:otherLines) remoteHost' src = do+parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []+parseRequest' conn port (firstLine:otherLines) remoteHost' src = do (method, rpath', gets, httpversion) <- parseFirst firstLine- let (host',rpath) =- if S.null rpath'- then ("","/")- else if "http://" `S.isPrefixOf` rpath'- then S.breakByte 47 $ S.drop 7 rpath' -- '/'- else ("", rpath')- let heads = map parseHeaderNoAttr otherLines+ let (host',rpath)+ | S.null rpath' = ("", "/")+ | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'+ | otherwise = ("", rpath')+ heads <- liftIO+ $ handleExpect conn httpversion id+ (map parseHeaderNoAttr otherLines) let host = fromMaybe host' $ lookup "host" heads- let len =+ let len0 = case lookup "content-length" heads of Nothing -> 0- Just bs -> fromIntegral $ B.foldl' (\i c -> i * 10 + C.digitToInt c) 0 $ B.takeWhile C.isDigit bs+ Just bs -> readInt bs 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.- rbody <- C.prepareSource $- if len == 0- then mempty- else src C.$= CB.isolate len+ rbody <-+ if len0 == 0+ then return mempty+ else do+ -- We can't use the standard isolate, as its counter is not+ -- kept in a mutable variable.+ lenRef <- liftIO $ I.newIORef len0+ let isolate = C.Conduit push close+ push bs = do+ len <- liftIO $ I.readIORef lenRef+ let (a, b) = S.splitAt len bs+ len' = len - S.length a+ liftIO $ I.writeIORef lenRef len'+ return $ if len' == 0+ then C.Finished (if S.null b then Nothing else Just b) (if S.null a then [] else [a])+ else C.Producing isolate [a]+ close = return []++ -- Make sure that we don't connect to the source after the+ -- isolate conduit closes.+ --+ -- Here's the issue: we fuse our buffered request body with+ -- an isolate conduit which ensures no more than X bytes+ -- are read. Suppose we read all X bytes, and then we call+ -- requestBody again. What happens?+ --+ -- Previously, we would try to read one more chunk from the+ -- buffered source. This is inherent to conduit: we+ -- wouldn't know that the isolate Conduit isn't accepting+ -- more data until after we've pushed some data to it. This+ -- results in hanging, since there's no data available on+ -- the wire.+ --+ -- Instead, we add a wrapper that checks if the request+ -- body has already been depleted before making that first+ -- pull.+ --+ -- Possible optimization: do away with the Conduit+ -- entirely. However, this may be less efficient overall,+ -- as we'd now have to check the BufferedSource status on+ -- each call. Worth looking into.++ wrap src' = C.Source+ { C.sourcePull = do+ len <- liftIO $ I.readIORef lenRef+ if len <= 0+ then return C.Closed+ else C.sourcePull src'+ , C.sourceClose = return ()+ }+ return $ wrap $ src C.$= isolate return Request { requestMethod = method , httpVersion = httpversion@@ -335,7 +418,7 @@ , requestHeaders = heads , isSecure = False , remoteHost = remoteHost'- , requestBody = C.Source $ return rbody+ , requestBody = rbody , vault = mempty } @@ -349,7 +432,7 @@ parseFirst :: ByteString -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)-parseFirst s = +parseFirst s = case S.split 32 s of -- ' ' [method, query, http'] -> do let (hfirst, hsecond) = B.splitAt 5 http'@@ -375,8 +458,8 @@ headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-} let !start = httpBuilder- `mappend` (copyByteString $- case httpversion of+ `mappend` copyByteString+ (case httpversion of H.HttpVersion 1 1 -> "1.1" _ -> "1.0") `mappend` spaceBuilder@@ -415,7 +498,7 @@ isChunked = (==) H.http11 hasBody :: H.Status -> Request -> Bool-hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&+hasBody s req = s /= H.Status 204 "" && s /= H.status304 && H.statusCode s >= 200 && requestMethod req /= "HEAD" sendResponse :: T.Handle@@ -427,7 +510,7 @@ isChunked' = isChunked version needsChunked hs = isChunked' && not (hasLength hs) isKeepAlive hs = isPersist && (isChunked' || hasLength hs)- hasLength hs = lookup "content-length" hs /= Nothing+ hasLength hs = isJust $ lookup "content-length" hs sendResponse' :: Response -> ResourceT IO Bool sendResponse' (ResponseFile s hs fp mpart) = liftIO $ do@@ -471,14 +554,17 @@ headers' = headers version s hs needsChunked' = needsChunked hs body = if needsChunked'- then (headers' needsChunked')+ then headers' needsChunked' `mappend` chunkedTransferEncoding b `mappend` chunkedTransferTerminator- else (headers' False) `mappend` b+ else headers' False `mappend` b - sendResponse' (ResponseSource s hs body) =+ sendResponse' (ResponseSource s hs bodyFlush) = response where+ body = fmap (\x -> case x of+ C.Flush -> flush+ C.Chunk builder -> builder) bodyFlush 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)@@ -497,12 +583,13 @@ return $ isKeepAlive hs needsChunked' = needsChunked hs chunk :: C.Conduit Builder IO Builder- chunk = C.Conduit $ return $ C.PreparedConduit+ chunk = C.Conduit { C.conduitPush = push , C.conduitClose = close } - push x = return $ C.Producing [chunkedTransferEncoding x]+ conduit = C.Conduit push close+ push x = return $ C.Producing conduit [chunkedTransferEncoding x] close = return [chunkedTransferTerminator] parseHeaderNoAttr :: ByteString -> H.Header@@ -515,31 +602,33 @@ else rest in (CI.mk k, rest') -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 return C.Closed- else do- when (S.length bs >= 2048) $ liftIO $ T.tickle th- return (C.Open bs)- , C.sourceClose = return ()- }+connSource :: Connection -> T.Handle -> C.Source IO ByteString+connSource Connection { connRecv = recv } th =+ src+ where+ src = C.Source+ { C.sourcePull = do+ bs <- liftIO recv+ if S.null bs+ then return C.Closed+ else do+ when (S.length bs >= 2048) $ liftIO $ T.tickle th+ return (C.Open src bs)+ , C.sourceClose = return ()+ } -- | 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- }+connSink Connection { connSendAll = send } th =+ C.SinkData push close where close = liftIO (T.resume th) push x = do- liftIO $ T.resume th- liftIO $ send x- liftIO $ T.pause th- return $ C.Processing+ liftIO $ do+ T.resume th+ send x+ T.pause th+ return (C.Processing push close) -- 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@@ -556,26 +645,57 @@ -- > defaultSettings { settingsTimeout = 20 } data Settings = Settings { settingsPort :: Int -- ^ Port to listen on. Default value: 3000- , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *+ , settingsHost :: HostPreference -- ^ Default value: HostIPv4 , 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 (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' } +-- | Which host to bind.+--+-- Note: The @IsString@ instance recognizes the following special values:+--+-- * @*@ means @HostAny@+--+-- * @*4@ means @HostIPv4@+--+-- * @*6@ means @HostIPv6@+data HostPreference =+ HostAny+ | HostIPv4+ | HostIPv6+ | Host String+ deriving (Show, Eq, Ord)++instance IsString HostPreference where+ -- The funny code coming up is to get around some irritating warnings from+ -- GHC. I should be able to just write:+ {-+ fromString "*" = HostAny+ fromString "*4" = HostIPv4+ fromString "*6" = HostIPv6+ -}+ fromString s'@('*':s) =+ case s of+ [] -> HostAny+ ['4'] -> HostIPv4+ ['6'] -> HostIPv6+ _ -> Host s'+ fromString s = Host s+ -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings defaultSettings = Settings { settingsPort = 3000- , settingsHost = "*"+ , settingsHost = HostIPv4 , settingsOnException = \e -> case fromException e of Just x -> go x Nothing ->- if go' $ fromException e- then hPutStrLn stderr $ show e- else return ()+ when (go' $ fromException e) $+ hPutStrLn stderr $ show e , settingsTimeout = 30 , settingsIntercept = const Nothing , settingsManager = Nothing@@ -603,7 +723,7 @@ takeHeadersPush :: THStatus -> ByteString- -> ResourceT IO (THStatus, C.SinkResult ByteString [ByteString])+ -> ResourceT IO (C.SinkStateResult THStatus ByteString [ByteString]) takeHeadersPush (THStatus len _ _ ) _ | len > maxTotalHeaderLength = throwIO OverLargeHeader takeHeadersPush (THStatus len lines prepend) bs =@@ -611,7 +731,7 @@ -- no newline. prepend entire bs to next line Nothing -> do let len' = len + bsLen- return (THStatus len' lines (prepend . S.append bs), C.Processing)+ return $ C.StateProcessing $ THStatus len' lines (prepend . S.append bs) Just nl -> do let end = nl start = nl + 1@@ -625,8 +745,8 @@ 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')+ return $ C.StateDone (Just rest) lines'+ else return $ C.StateDone Nothing lines' -- more headers else do let len' = len + start@@ -635,7 +755,7 @@ then do let more = SU.unsafeDrop start bs takeHeadersPush (THStatus len' lines' id) more- else return (THStatus len' lines' id, C.Processing)+ else return $ C.StateProcessing $ THStatus len' lines' id where bsLen = S.length bs mnl = S.elemIndex 10 bs@@ -649,10 +769,10 @@ else pos {-# INLINE checkCR #-} --- Note: This function produces garbage on invalid input. But serving an--- invalid content-length is a bad idea, mkay?-readInt :: S.ByteString -> Integer-readInt = S.foldl' (\x w -> x * 10 + fromIntegral w - 48) 0+readInt :: Integral a => ByteString -> a+readInt bs = fromIntegral $ readInt64 bs+{-# INLINE readInt #-}+ -- | Call the inner function with a timeout manager. withManager :: Int -- ^ timeout in microseconds
+ ReadInt.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns #-}++-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3++module ReadInt (readInt64) where++-- This function lives in its own file because the MagicHash pragma interacts+-- poorly with the CPP pragma.++import Data.ByteString (ByteString)+import Data.Int (Int64)+import GHC.Prim+import GHC.Types++import qualified Data.ByteString.Char8 as B+import qualified Data.Char as C++-- This function is used to parse the Content-Length field of HTTP headers and+-- is a performance hot spot. It should only be replaced with something+-- significantly and provably faster.+--+-- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we+-- use Int64 here and then make a generic 'readInt' that allows conversion to+-- Int and Integer.++readInt64 :: ByteString -> Int64+readInt64 bs =+ B.foldl' (\i c -> i * 10 + fromIntegral (mhDigitToInt c)) 0+ $ B.takeWhile C.isDigit bs+{- NOINLINE readInt64MH #-}++data Table = Table !Addr#++{- NOINLINE mhDigitToInt #-}+mhDigitToInt :: Char -> Int+mhDigitToInt (C# i) = I# (word2Int# (indexWord8OffAddr# addr (ord# i)))+ where+ !(Table addr) = table+ table :: Table+ table = Table+ "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+ \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#+
+ test/main.hs view
@@ -0,0 +1,121 @@+{-# 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"++doubleConnect :: CounterApplication+doubleConnect icount req = do+ _ <- requestBody req $$ Data.Conduit.List.consume+ _ <- requestBody req $$ Data.Conduit.List.consume+ incr icount+ return $ responseLBS status200 [] "double connect"++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+ ]+ describe "no hanging" $ do+ it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello+ it "double connect" $ runTest 1 doubleConnect [singlePostHello]
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 1.0.0.1+Version: 1.1.0 Synopsis: A fast, light-weight web server for WAI applications. License: BSD3 License-file: LICENSE@@ -11,6 +11,7 @@ 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,16 +19,17 @@ Library Build-Depends: base >= 3 && < 5 , bytestring >= 0.9.1.4 && < 0.10- , wai >= 1.0 && < 1.1+ , wai >= 1.1 && < 1.2 , transformers >= 0.2.2 && < 0.3- , conduit < 0.2- , blaze-builder-conduit >= 0.0.1 && < 0.1+ , conduit >= 0.2+ , blaze-builder-conduit >= 0.2 && < 0.3 , 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 , case-insensitive >= 0.2 , unix-compat >= 0.2+ , ghc-prim if flag(network-bytestring) build-depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4@@ -35,10 +37,28 @@ build-depends: network >= 2.3 && < 2.4 Exposed-modules: Network.Wai.Handler.Warp Other-modules: Timeout+ ReadInt Paths_warp 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