warp 2.0.3.4 → 2.1.0
raw patch · 10 files changed
+241/−75 lines, 10 filesdep ~basedep ~wai
Dependency ranges changed: base, wai
Files
- Network/Wai/Handler/Warp.hs +109/−0
- Network/Wai/Handler/Warp/Header.hs +2/−4
- Network/Wai/Handler/Warp/Internal.hs +5/−0
- Network/Wai/Handler/Warp/Request.hs +11/−8
- Network/Wai/Handler/Warp/Response.hs +45/−18
- Network/Wai/Handler/Warp/Run.hs +16/−12
- Network/Wai/Handler/Warp/Settings.hs +20/−6
- test/RequestSpec.hs +2/−2
- test/RunSpec.hs +25/−22
- warp.cabal +6/−3
Network/Wai/Handler/Warp.hs view
@@ -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 }
Network/Wai/Handler/Warp/Header.hs view
@@ -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 ----------------------------------------------------------------
+ Network/Wai/Handler/Warp/Internal.hs view
@@ -0,0 +1,5 @@+module Network.Wai.Handler.Warp.Internal+ ( Settings (..)+ ) where++import Network.Wai.Handler.Warp.Settings (Settings (..))
Network/Wai/Handler/Warp/Request.hs view
@@ -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:)
Network/Wai/Handler/Warp/Response.hs view
@@ -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 ----------------------------------------------------------------
Network/Wai/Handler/Warp/Run.hs view
@@ -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
Network/Wai/Handler/Warp/Settings.hs view
@@ -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" #-}
test/RequestSpec.hs view
@@ -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" $
test/RunSpec.hs view
@@ -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")
warp.cabal view
@@ -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