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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} --------------------------------------------------------- -- @@ -25,7 +26,21 @@ -- * Settings , Settings , defaultSettings + -- ** Setters + , setPort + , setHost + , setOnException + , setOnExceptionResponse + , setOnOpen + , setOnClose + , setTimeout + , setIntercept + , setManager + , setFdCacheDuration + , setBeforeMainLoop + , setNoParsePath -- ** Accessors + -- | Note: these accessors are deprecated, please use the @set@ versions instead. , settingsPort , settingsHost , settingsOnException @@ -77,3 +92,97 @@ import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types +import Control.Exception (SomeException) +import Network.Wai (Request, Response) +import Network.Socket (SockAddr) +import Data.Conduit (Source) +import Data.ByteString (ByteString) + +-- | Port to listen on. Default value: 3000 +-- +-- Since 2.1.0 +setPort :: Int -> Settings -> Settings +setPort x y = y { settingsPort = x } + +-- | Interface to bind to. Default value: HostIPv4 +-- +-- Since 2.1.0 +setHost :: HostPreference -> Settings -> Settings +setHost x y = y { settingsHost = x } + +-- | 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. +-- +-- Since 2.1.0 +setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings +setOnException x y = y { settingsOnException = x } + +-- | A function to create `Response` when an exception occurs. +-- +-- Default: 500, text/plain, \"Something went wrong\" +-- +-- Since 2.1.0 +setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings +setOnExceptionResponse x y = y { settingsOnExceptionResponse = x } + +-- | What to do when a connection is open. When 'False' is returned, the +-- connection is closed immediately. Otherwise, the connection is going on. +-- Default: always returns 'True'. +-- +-- Since 2.1.0 +setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings +setOnOpen x y = y { settingsOnOpen = x } + +-- | What to do when a connection is close. Default: do nothing. +-- +-- Since 2.1.0 +setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings +setOnClose x y = y { settingsOnClose = x } + +-- | Timeout value in seconds. Default value: 30 +-- +-- Since 2.1.0 +setTimeout :: Int -> Settings -> Settings +setTimeout x y = y { settingsTimeout = x } + +-- | Register some intercept handler to deal with specific requests. Prime use +-- case: websockets. +-- +-- Default: always return @Nothing@. +-- +-- Since 2.1.0 +setIntercept :: (Request -> IO (Maybe (Source IO ByteString -> Connection -> IO ()))) + -> Settings -> Settings +setIntercept x y = y { settingsIntercept = x } + +-- | Use an existing timeout manager instead of spawning a new one. If used, +-- 'settingsTimeout' is ignored. +-- +-- Since 2.1.0 +setManager :: Manager -> Settings -> Settings +setManager x y = y { settingsManager = Just x } + +-- | Cache duratoin time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 10 +setFdCacheDuration :: Int -> Settings -> Settings +setFdCacheDuration x y = y { settingsFdCacheDuration = x } + +-- | Code to run after the listening socket is ready but before entering +-- the main event loop. Useful for signaling to tests that they can start +-- running, or to drop permissions after binding to a restricted port. +-- +-- Default: do nothing. +-- +-- Since 2.1.0 +setBeforeMainLoop :: IO () -> Settings -> Settings +setBeforeMainLoop x y = y { settingsBeforeMainLoop = x } + +-- | Perform no parsing on the rawPathInfo. +-- +-- This is useful for writing HTTP proxies. +-- +-- Default: False +-- +-- Since 2.1.0 +setNoParsePath :: Bool -> Settings -> Settings +setNoParsePath x y = y { settingsNoParsePath = x } diff --git a/Network/Wai/Handler/Warp/Header.hs b/Network/Wai/Handler/Warp/Header.hs --- a/Network/Wai/Handler/Warp/Header.hs +++ b/Network/Wai/Handler/Warp/Header.hs @@ -49,19 +49,17 @@ indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex -idxServer, idxDate :: Int +idxServer :: Int --idxContentLength = 0 idxServer = 1 -idxDate = 2 -- | The size for 'IndexedHeader' for HTTP Response. responseMaxIndex :: Int -responseMaxIndex = 2 +responseMaxIndex = 1 responseKeyIndex :: HeaderName -> Int responseKeyIndex "content-length" = idxContentLength responseKeyIndex "server" = idxServer -responseKeyIndex "date" = idxDate responseKeyIndex _ = -1 ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/Internal.hs b/Network/Wai/Handler/Warp/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Internal.hs @@ -0,0 +1,5 @@ +module Network.Wai.Handler.Warp.Internal + ( Settings (..) + ) where + +import Network.Wai.Handler.Warp.Settings (Settings (..)) diff --git a/Network/Wai/Handler/Warp/Request.hs b/Network/Wai/Handler/Warp/Request.hs --- a/Network/Wai/Handler/Warp/Request.hs +++ b/Network/Wai/Handler/Warp/Request.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Request ( recvRequest @@ -49,13 +50,15 @@ -> Source IO ByteString -- ^ Where HTTP request comes from. -> IO (Request ,IndexedHeader - ,IO (ResumableSource IO ByteString)) -- ^ + ,IO (ResumableSource IO ByteString) + ,Maybe ByteString) -- ^ -- 'Request' passed to 'Application', - -- 'IndexedHeader' of HTTP request for internal use, and - -- leftover source (i.e. body and other HTTP reqeusts in HTTP pipelining). + -- 'IndexedHeader' of HTTP request for internal use, + -- leftover source (i.e. body and other HTTP reqeusts in HTTP pipelining), + -- leftovers from request header parsing (used for raw responses) recvRequest settings conn ii addr src0 = do - (src, hdrlines) <- src0 $$+ headerLines + (src, (leftover', hdrlines)) <- src0 $$+ headerLines (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr expect = idxhdr ! idxExpect @@ -79,13 +82,13 @@ , requestHeaderHost = idxhdr ! idxHost , requestHeaderRange = idxhdr ! idxRange } - return (req, idxhdr, getSource) + return (req, idxhdr, getSource, leftover') where th = threadHandle ii ---------------------------------------------------------------- -headerLines :: Sink ByteString IO [ByteString] +headerLines :: Sink ByteString IO (Maybe ByteString, [ByteString]) headerLines = await >>= maybe (throwIO (NotEnoughLines [])) (push (THStatus 0 id id)) @@ -161,7 +164,7 @@ close :: Sink ByteString IO a close = throwIO IncompleteHeaders -push :: THStatus -> ByteString -> Sink ByteString IO [ByteString] +push :: THStatus -> ByteString -> Sink ByteString IO (Maybe ByteString, [ByteString]) push (THStatus len lines prepend) bs -- Too many bytes | len > maxTotalHeaderLength = throwIO OverLargeHeader @@ -205,7 +208,7 @@ Just (SU.unsafeDrop start bs) else Nothing - in maybe (return ()) leftover rest >> return lines' + in maybe (return ()) leftover rest >> return (rest, lines') -- more headers | otherwise = let len' = len + start lines' = lines . (line:) diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -18,9 +18,12 @@ import Control.Monad.IO.Class (liftIO) import Data.Array ((!)) import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Control.Monad (unless) import qualified Data.ByteString.Char8 as B (pack) import qualified Data.CaseInsensitive as CI import Data.Conduit +import qualified Data.Conduit.List as CL import Data.Conduit.Blaze (unsafeBuilderToByteString) import Data.Function (on) import Data.List (deleteBy) @@ -150,16 +153,17 @@ -> (forall a. IO a -> IO a) -- ^ Restore masking state. -> Request -- ^ HTTP request. -> IndexedHeader -- ^ Indexed header of HTTP request. + -> Maybe ByteString -- ^ leftovers from header parsing -> Response -- ^ HTTP response including status code and response header. -> IO Bool -- ^ Returing True if the connection is persistent. -sendResponse conn ii restore req reqidxhdr response = restore $ do +sendResponse conn ii restore req reqidxhdr leftover' response = do hs <- addServerAndDate hs0 if hasBody s req then do - sendRsp conn ver s hs rsp + sendRsp conn ver s hs restore rsp T.tickle th return ret else do - sendResponseNoBody conn ver s hs response + sendResponseNoBody conn ver s hs restore response T.tickle th return isPersist where @@ -169,7 +173,7 @@ rspidxhdr = indexResponseHeader hs0 th = threadHandle ii dc = dateCacher ii - addServerAndDate = addDate dc rspidxhdr . addServer rspidxhdr + addServerAndDate = addDate dc . addServer rspidxhdr mRange = reqidxhdr ! idxRange reqinfo@(isPersist,_) = infoFromRequest req reqidxhdr (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr reqinfo @@ -177,16 +181,19 @@ ResponseFile _ _ path mPart -> RspFile path mPart mRange (T.tickle th) ResponseBuilder _ _ b -> RspBuilder b needsChunked ResponseSource _ _ fb -> RspSource fb needsChunked th + ResponseRaw raw _ -> RspRaw raw leftover' ret = case response of ResponseFile _ _ _ _ -> isPersist ResponseBuilder _ _ _ -> isKeepAlive ResponseSource _ _ _ -> isKeepAlive + ResponseRaw _ _ -> False ---------------------------------------------------------------- data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) (IO ()) | RspBuilder Builder Bool | RspSource (forall b. WithSource IO (Flush Builder) b) Bool T.Handle + | RspRaw (forall b. WithRawApp b) (Maybe ByteString) ---------------------------------------------------------------- @@ -194,12 +201,13 @@ -> H.HttpVersion -> H.Status -> H.ResponseHeaders + -> (forall a. IO a -> IO a) -- ^ restore -> Rsp -> IO () -sendRsp conn ver s0 hs0 (RspFile path mPart mRange hook) = do +sendRsp conn ver s0 hs0 restore (RspFile path mPart mRange hook) = restore $ do ex <- fileRange s0 hs path mPart mRange case ex of - Left _ -> sendRsp conn ver s2 hs2 (RspBuilder body True) + Left _ -> sendRsp conn ver s2 hs2 id (RspBuilder body True) Right (s, hs1, beg, len) -> do lheader <- composeHeader ver s hs1 connSendFile conn path beg len hook [lheader] @@ -211,7 +219,7 @@ ---------------------------------------------------------------- -sendRsp conn ver s hs (RspBuilder body needsChunked) = do +sendRsp conn ver s hs restore (RspBuilder body needsChunked) = restore $ do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy | needsChunked = header <> chunkedTransferEncoding body @@ -223,7 +231,8 @@ ---------------------------------------------------------------- -sendRsp conn ver s hs (RspSource withBodyFlush needsChunked th) = withBodyFlush $ \bodyFlush -> do +sendRsp conn ver s hs restore (RspSource withBodyFlush needsChunked th) = + withBodyFlush $ \bodyFlush -> restore $ do header <- composeHeaderBuilder ver s hs needsChunked let src = yield header >> cbody bodyFlush buffer <- toBlazeBuffer (connBuffer conn) (connBufferSize conn) @@ -240,17 +249,37 @@ ---------------------------------------------------------------- +sendRsp conn _ _ _ restore (RspRaw withApp mbs) = + withApp $ \app -> restore $ app src sink + where + sink = CL.mapM_ (connSendAll conn) + src = do + maybe (return ()) yield mbs + loop + where + loop = do + bs <- liftIO $ connRecv conn + unless (S.null bs) $ yield bs >> loop + +---------------------------------------------------------------- + sendResponseNoBody :: Connection -> H.HttpVersion -> H.Status -> H.ResponseHeaders + -> (forall a. IO a -> IO a) -- ^ restore -> Response -> IO () -sendResponseNoBody conn ver s hs (ResponseSource _ _ withBodyFlush) = +sendResponseNoBody conn ver s hs restore (ResponseSource _ _ withBodyFlush) = withBodyFlush $ \_bodyFlush -> - composeHeader ver s hs >>= connSendAll conn -sendResponseNoBody conn ver s hs _ = - composeHeader ver s hs >>= connSendAll conn + restore $ composeHeader ver s hs >>= connSendAll conn +sendResponseNoBody conn ver s hs restore (ResponseRaw withRaw _) = + withRaw $ \_raw -> + restore $ composeHeader ver s hs >>= connSendAll conn +sendResponseNoBody conn ver s hs restore ResponseBuilder{} = + restore $ composeHeader ver s hs >>= connSendAll conn +sendResponseNoBody conn ver s hs restore ResponseFile{} = + restore $ composeHeader ver s hs >>= connSendAll conn ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -347,12 +376,10 @@ ( '/' : showInt total "")) -addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders -addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of - Nothing -> do - gmtdate <- D.getDate dc - return $ (H.hDate, gmtdate) : hdrs - Just _ -> return hdrs +addDate :: D.DateCache -> H.ResponseHeaders -> IO H.ResponseHeaders +addDate dc hdrs = do + gmtdate <- D.getDate dc + return $ (H.hDate, gmtdate) : hdrs ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where @@ -66,7 +67,7 @@ run :: Port -> Application -> IO () run p = runSettings defaultSettings { settingsPort = p } --- | Run an 'Applicatoin' with the given 'Settings'. +-- | Run an 'Application' with the given 'Settings'. runSettings :: Settings -> Application -> IO () #if WINDOWS runSettings set app = withSocketsDo $ do @@ -185,10 +186,11 @@ handle (onE Nothing) . -- Call the user-supplied code for connection open and close events - bracket_ onOpen onClose $ + bracket (onOpen addr) (const $ onClose addr) $ \goingon -> -- Actually serve this connection. - serveConnection conn ii addr set app + -- onnClose above ensures the termination of the connection. + when goingon $ serveConnection conn ii addr set app where -- FIXME: only IOEception is caught. What about other exceptions? getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do @@ -230,15 +232,16 @@ sendErrorResponse istatus e = do status <- readIORef istatus when status $ void $ mask $ \restore -> - sendResponse conn ii restore dummyreq defaultIndexRequestHeader (errorResponse e) + sendResponse conn ii restore dummyreq defaultIndexRequestHeader Nothing (errorResponse e) dummyreq = defaultRequest { remoteHost = addr } errorResponse e = settingsOnExceptionResponse settings e recvSendLoop istatus fromClient = do - (req, idxhdr, getSource) <- recvRequest settings conn ii addr fromClient - case settingsIntercept settings req of + (req, idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient + intercept' <- settingsIntercept settings req + case intercept' of Nothing -> do -- Let the application run for as long as it wants T.pause th @@ -253,7 +256,7 @@ -- send more meaningful error messages to the user. -- However, it may affect performance. writeIORef istatus False - sendResponse conn ii restore req idxhdr res + sendResponse conn ii restore req idxhdr leftover' res -- We just send a Response and it takes a time to -- receive a Request again. If we immediately call recv, @@ -264,12 +267,13 @@ -- This improves performance at least when -- the number of cores is small. Conc.yield - -- flush the rest of the request body - requestBody req $$ CL.sinkNull - ResumableSource fromClient' _ <- getSource - T.resume th - when keepAlive $ recvSendLoop istatus fromClient' + when keepAlive $ do + -- flush the rest of the request body + requestBody req $$ CL.sinkNull + ResumableSource fromClient' _ <- getSource + T.resume th + recvSendLoop istatus fromClient' Just intercept -> do T.pause th ResumableSource fromClient' _ <- getSource diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -9,6 +9,7 @@ import Data.Conduit.Network (HostPreference (HostIPv4)) import GHC.IO.Exception (IOErrorType(..)) import qualified Network.HTTP.Types as H +import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types @@ -31,10 +32,10 @@ -- Default: 500, text/plain, \"Something went wrong\" -- -- Since 2.0.3 - , settingsOnOpen :: IO () -- ^ What to do when a connection is open. Default: do nothing. - , settingsOnClose :: IO () -- ^ What to do when a connection is close. Default: do nothing. + , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'. + , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing. , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 - , settingsIntercept :: Request -> Maybe (Source IO S.ByteString -> Connection -> IO ()) + , settingsIntercept :: Request -> IO (Maybe (Source IO S.ByteString -> Connection -> IO ())) , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' , settingsFdCacheDuration :: Int -- ^ Cache duratoin time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 10 , settingsBeforeMainLoop :: IO () @@ -63,10 +64,10 @@ , settingsHost = HostIPv4 , settingsOnException = defaultExceptionHandler , settingsOnExceptionResponse = defaultExceptionResponse - , settingsOnOpen = return () - , settingsOnClose = return () + , settingsOnOpen = const $ return True + , settingsOnClose = const $ return () , settingsTimeout = 30 - , settingsIntercept = const Nothing + , settingsIntercept = const (return Nothing) , settingsManager = Nothing , settingsFdCacheDuration = 10 , settingsBeforeMainLoop = return () @@ -101,3 +102,16 @@ -- | Default implementation of 'settingsOnExceptionResponse' for the debugging purpose. 500, text/plain, a showed exception. exceptionResponseForDebug :: SomeException -> Response exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] (L8.pack $ "Exception: " ++ show e) + +{-# DEPRECATED settingsPort "Use setPort instead" #-} +{-# DEPRECATED settingsHost "Use setHost instead" #-} +{-# DEPRECATED settingsOnException "Use setOnException instead" #-} +{-# DEPRECATED settingsOnExceptionResponse "Use setOnExceptionResponse instead" #-} +{-# DEPRECATED settingsOnOpen "Use setOnOpen instead" #-} +{-# DEPRECATED settingsOnClose "Use setOnClose instead" #-} +{-# DEPRECATED settingsTimeout "Use setTimeout instead" #-} +{-# DEPRECATED settingsIntercept "Use setIntercept instead" #-} +{-# DEPRECATED settingsManager "Use setManager instead" #-} +{-# DEPRECATED settingsFdCacheDuration "Use setFdCacheDuration instead" #-} +{-# DEPRECATED settingsBeforeMainLoop "Use setBeforeMainLoop instead" #-} +{-# DEPRECATED settingsNoParsePath "Use setNoParsePath instead" #-} diff --git a/test/RequestSpec.hs b/test/RequestSpec.hs --- a/test/RequestSpec.hs +++ b/test/RequestSpec.hs @@ -23,9 +23,9 @@ spec = do describe "headerLines" $ do it "takes until blank" $ - blankSafe >>= (`shouldBe` ["foo", "bar", "baz"]) + blankSafe >>= (`shouldBe` (Nothing, ["foo", "bar", "baz"])) it "ignored leading whitespace in bodies" $ - whiteSafe >>= (`shouldBe` ["foo", "bar", "baz"]) + whiteSafe >>= (`shouldBe` (Just " hi there", ["foo", "bar", "baz"])) it "throws OverLargeHeader when too many" $ tooMany `shouldThrow` overLargeHeader it "throws OverLargeHeader when too large" $ diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -11,7 +11,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import Data.Conduit (($$)) +import Data.Conduit (($$), (=$)) import qualified Data.Conduit.List import qualified Data.IORef as I import Network (connectTo, PortID (PortNumber)) @@ -25,7 +25,6 @@ import Control.Exception.Lifted (bracket, try, IOException, onException) import Data.Conduit.Network (bindPort) import Network.Socket (sClose) -import qualified Network.HTTP as HTTP main :: IO () main = hspec spec @@ -87,11 +86,11 @@ withApp settings app f = do port <- getPort baton <- newEmptyMVar + let settings' = setPort port + $ setBeforeMainLoop (putMVar baton ()) + settings bracket - (forkIO $ runSettings settings - { settingsPort = port - , settingsBeforeMainLoop = putMVar baton () - } app `onException` putMVar baton ()) + (forkIO $ runSettings settings' app `onException` putMVar baton ()) killThread (const $ takeMVar baton >> f port) @@ -118,9 +117,8 @@ -> IO () runTerminateTest expected input = do ref <- I.newIORef Nothing - withApp defaultSettings - { settingsOnException = \_ e -> I.writeIORef ref $ Just e - } dummyApp $ \port -> do + let onExc _ = I.writeIORef ref . Just + withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port hPutStr handle input hFlush handle @@ -277,7 +275,7 @@ I.atomicModifyIORef ifront (\front -> (front . ("threadDelay interrupted":), ())) liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) return $ responseLBS status200 [] "" - withApp defaultSettings { settingsTimeout = 1 } app $ \port -> do + withApp (setTimeout 1 defaultSettings) app $ \port -> do let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2 @@ -294,15 +292,20 @@ threadDelay 5000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs - - it "only one date and server header" $ do - let app _ = return $ responseLBS status200 - [ ("server", "server") - , ("date", "date") - ] "" - withApp defaultSettings app $ \port -> do - Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port) - map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrServer res) - `shouldBe` ["server"] - map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrDate res) - `shouldBe` ["date"] + describe "raw body" $ do + it "works" $ do + let app _req = do + let backup = responseLBS status200 [] "Not raw" + return $ flip responseRaw backup $ \src sink -> + src + $$ Data.Conduit.List.map doubleBS + =$ sink + doubleBS = S.concatMap $ \w -> S.pack [w, w] + withApp defaultSettings app $ \port -> do + handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port + hPutStr handle "POST / HTTP/1.1\r\n\r\n12345" + hFlush handle + timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455") + hPutStr handle "67890" + hFlush handle + timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900") diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 2.0.3.4 +Version: 2.1.0 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -15,6 +15,8 @@ . Changelog . + [2.1.0] The @onOpen@ and @onClose@ settings now provide the @SockAddr@ of the client, and @onOpen@ can return a @Bool@ which will close the connection. The @responseRaw@ response has been added, which provides a more elegant way to handle WebSockets than the previous @settingsIntercept@. The old settings accessors have been deprecated in favor of new setters, which will allow settings changes to be made in the future without breaking backwards compatibility. + . [2.0.0] ResourceT is not used anymore. Request and Response is now abstract data types. To use their constructors, Internal module should be imported. . [1.3.9] Support for byte range requests. @@ -45,7 +47,7 @@ , transformers >= 0.2.2 && < 0.4 , unix-compat >= 0.2 , void - , wai >= 2.0 && < 2.1 + , wai >= 2.1 && < 2.2 if flag(network-bytestring) Build-Depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 @@ -54,6 +56,7 @@ Exposed-modules: Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Buffer Network.Wai.Handler.Warp.Timeout + Network.Wai.Handler.Warp.Internal Other-modules: Network.Wai.Handler.Warp.Conduit Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache @@ -125,7 +128,7 @@ , transformers >= 0.2.2 && < 0.4 , unix-compat >= 0.2 , void - , wai >= 2.0 && < 2.1 + , wai , network , HUnit , QuickCheck