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 @@ -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 diff --git a/ReadInt.hs b/ReadInt.hs new file mode 100644 --- /dev/null +++ b/ReadInt.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns #-} + +-- Copyright : Erik de Castro Lopo +-- 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"# + diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -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] diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -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 . +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