diff --git a/wai/Network/Wai.hs b/wai/Network/Wai.hs index 4d9cbc61f..f1f019ce9 100644 --- a/wai/Network/Wai.hs +++ b/wai/Network/Wai.hs @@ -204,7 +204,7 @@ sourceFilePart handle (FilePart offset count _) = ---------------------------------------------------------------- -- | The WAI application. -type Application = Request -> IO Response +type Application = Request -> (forall b. (Response -> IO b) -> IO b) -- | Middleware is a component that sits between the server and application. It -- can do such tasks as GZIP encoding or response caching. What follows is the diff --git a/warp/Network/Wai/Handler/Warp/Response.hs b/warp/Network/Wai/Handler/Warp/Response.hs index 6c46b3434..39d9de83e 100644 --- a/warp/Network/Wai/Handler/Warp/Response.hs +++ b/warp/Network/Wai/Handler/Warp/Response.hs @@ -16,7 +16,6 @@ import Blaze.ByteString.Builder.Internal (defaultBufferSize) import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Control.Applicative import Control.Exception -import Control.Monad.IO.Class (liftIO) import Data.Array ((!)) import Data.ByteString (ByteString) import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy, allocBuffer) @@ -156,20 +155,19 @@ checkPartRange fileSize = checkPart sendResponse :: Connection -> InternalInfo - -> (forall a. IO a -> IO a) -- ^ Restore masking state. -> Request -- ^ HTTP request. -> IndexedHeader -- ^ Indexed header of HTTP request. -> IO ByteString -- ^ source from client, for raw response -> Response -- ^ HTTP response including status code and response header. -> IO Bool -- ^ Returing True if the connection is persistent. -sendResponse conn ii restore req reqidxhdr src response = do +sendResponse conn ii req reqidxhdr src response = do hs <- addServerAndDate hs0 if hasBody s req then do - sendRsp conn ver s hs restore rsp + sendRsp conn ver s hs rsp T.tickle th return ret else do - sendResponseNoBody conn ver s hs restore response + sendResponseNoBody conn ver s hs response T.tickle th return isPersist where @@ -207,17 +205,16 @@ sendRsp :: Connection -> H.HttpVersion -> H.Status -> H.ResponseHeaders - -> (forall a. IO a -> IO a) -- ^ restore -> Rsp -> IO () -sendRsp conn ver s0 hs0 restore (RspFile path mPart mRange hook) = restore $ do +sendRsp conn ver s0 hs0 (RspFile path mPart mRange hook) = do ex <- fileRange s0 hs path mPart mRange case ex of Left _ex -> #ifdef WARP_DEBUG print _ex >> #endif - sendRsp conn ver s2 hs2 id (RspBuilder body True) + sendRsp conn ver s2 hs2 (RspBuilder body True) Right (s, hs1, beg, len) -> do lheader <- composeHeader ver s hs1 connSendFile conn path beg len hook [lheader] @@ -229,7 +226,7 @@ sendRsp conn ver s0 hs0 restore (RspFile path mPart mRange hook) = restore $ do ---------------------------------------------------------------- -sendRsp conn ver s hs restore (RspBuilder body needsChunked) = restore $ do +sendRsp conn ver s hs (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy | needsChunked = header <> chunkedTransferEncoding body @@ -241,7 +238,7 @@ sendRsp conn ver s hs restore (RspBuilder body needsChunked) = restore $ do ---------------------------------------------------------------- -sendRsp conn ver s hs restore (RspStream withBodyFlush needsChunked th) = do +sendRsp conn ver s hs (RspStream withBodyFlush needsChunked th) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newBlazeRecv $ reuseBufferStrategy $ allocBuffer defaultBufferSize let addChunk builder = do @@ -253,17 +250,16 @@ sendRsp conn ver s hs restore (RspStream withBodyFlush needsChunked th) = do loop loop addChunk header - restore $ do - withBodyFlush $ \mbuilder -> addChunk $ case mbuilder of - Nothing -> flush - Just builder -> chunkedTransferEncoding builder - when needsChunked $ addChunk chunkedTransferTerminator - mbs <- finish - maybe (return ()) (connSink conn th) mbs + withBodyFlush $ \mbuilder -> addChunk $ case mbuilder of + Nothing -> flush + Just builder -> chunkedTransferEncoding builder + when needsChunked $ addChunk chunkedTransferTerminator + mbs <- finish + maybe (return ()) (connSink conn th) mbs ---------------------------------------------------------------- -sendRsp conn _ _ _ restore (RspRaw withApp src tickle) = +sendRsp conn _ _ _ (RspRaw withApp src tickle) = withApp recv send where recv = do @@ -278,23 +274,22 @@ sendResponseNoBody :: Connection -> H.HttpVersion -> H.Status -> H.ResponseHeaders - -> (forall a. IO a -> IO a) -- ^ restore -> Response -> IO () -sendResponseNoBody conn ver s hs restore (ResponseStream _ _ withBodyFlush) = restore $ do +sendResponseNoBody conn ver s hs (ResponseStream _ _ withBodyFlush) = do -- Allow the application to free resources withBodyFlush $ const $ return () composeHeader ver s hs >>= connSendAll conn -sendResponseNoBody conn ver s hs restore (ResponseRaw withRaw _) = restore $ do +sendResponseNoBody conn ver s hs (ResponseRaw withRaw _) = do -- Allow the application to free resources withRaw (return S.empty) (const $ return ()) 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 +sendResponseNoBody conn ver s hs ResponseBuilder{} = + composeHeader ver s hs >>= connSendAll conn +sendResponseNoBody conn ver s hs ResponseFile{} = + composeHeader ver s hs >>= connSendAll conn ---------------------------------------------------------------- ---------------------------------------------------------------- diff --git a/warp/Network/Wai/Handler/Warp/Run.hs b/warp/Network/Wai/Handler/Warp/Run.hs index 42cad02b9..d1f97a681 100644 --- a/warp/Network/Wai/Handler/Warp/Run.hs +++ b/warp/Network/Wai/Handler/Warp/Run.hs @@ -239,8 +239,8 @@ serveConnection conn ii addr isSecure' settings app = do sendErrorResponse istatus e = do status <- readIORef istatus - when status $ void $ mask $ \restore -> - sendResponse conn ii restore dummyreq defaultIndexRequestHeader (return S.empty) (errorResponse e) + when status $ void $ + sendResponse conn ii dummyreq defaultIndexRequestHeader (return S.empty) (errorResponse e) dummyreq = defaultRequest { remoteHost = addr } @@ -255,14 +255,13 @@ serveConnection conn ii addr isSecure' settings app = do -- In the event that some scarce resource was acquired during -- creating the request, we need to make sure that we don't get -- an async exception before calling the ResponseSource. - keepAlive <- mask $ \restore -> do - res <- restore $ app req + keepAlive <- app req $ \res -> do T.resume th -- FIXME consider forcing evaluation of the res here to -- send more meaningful error messages to the user. -- However, it may affect performance. writeIORef istatus False - sendResponse conn ii restore req idxhdr (readSource fromClient) res + sendResponse conn ii req idxhdr (readSource fromClient) res -- We just send a Response and it takes a time to -- receive a Request again. If we immediately call recv, diff --git a/warp/test/ExceptionSpec.hs b/warp/test/ExceptionSpec.hs index e5b12708e..10469a544 100644 --- a/warp/test/ExceptionSpec.hs +++ b/warp/test/ExceptionSpec.hs @@ -30,20 +30,20 @@ withTestServer inner = bracket $ \_ -> inner port testApp :: Application -testApp (Network.Wai.Internal.Request {pathInfo = [x]}) +testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f | x == "statusError" = - return $ responseLBS undefined [] "foo" + f $ responseLBS undefined [] "foo" | x == "headersError" = - return $ responseLBS ok200 undefined "foo" + f $ responseLBS ok200 undefined "foo" | x == "headerError" = - return $ responseLBS ok200 [undefined] "foo" + f $ responseLBS ok200 [undefined] "foo" | x == "bodyError" = - return $ responseLBS ok200 [] undefined + f $ responseLBS ok200 [] undefined | x == "ioException" = do void $ fail "ioException" - return $ responseLBS ok200 [] "foo" -testApp _ = - return $ responseLBS ok200 [] "foo" + f $ responseLBS ok200 [] "foo" +testApp _ f = + f $ responseLBS ok200 [] "foo" spec :: Spec spec = describe "responds even if there is an exception" $ do diff --git a/warp/test/ResponseSpec.hs b/warp/test/ResponseSpec.hs index ae2dab460..771e052c2 100644 --- a/warp/test/ResponseSpec.hs +++ b/warp/test/ResponseSpec.hs @@ -36,7 +36,7 @@ testRange range out crange = it title $ withApp defaultSettings app $ \port -> d lookup "Content-Range" hs `shouldBe` Just ("bytes " ++ crange) lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) where - app _ = return $ responseFile status200 [] "attic/hex" Nothing + app _ = ($ responseFile status200 [] "attic/hex" Nothing) title = show (range, out, crange) toHeader s = case break (== ':') s of @@ -60,7 +60,7 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ \po lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) lookup "Content-Range" hs `shouldBe` Just range where - app _ = return $ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size + app _ = ($ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size) title = show (offset, count, out) toHeader s = case break (== ':') s of diff --git a/warp/test/RunSpec.hs b/warp/test/RunSpec.hs index ddab5784e..10bcd89be 100644 --- a/warp/test/RunSpec.hs +++ b/warp/test/RunSpec.hs @@ -45,7 +45,7 @@ err :: (MonadIO m, Show a) => Counter -> a -> m () err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg readBody :: CounterApplication -readBody icount req = do +readBody icount req f = do body <- consumeBody $ requestBody req case () of () @@ -56,21 +56,21 @@ readBody icount req = do | not $ requestMethod req `elem` ["GET", "POST"] -> err icount ("Invalid request method (readBody)" :: String, requestMethod req) | otherwise -> incr icount - return $ responseLBS status200 [] "Read the body" + f $ responseLBS status200 [] "Read the body" ignoreBody :: CounterApplication -ignoreBody icount req = do +ignoreBody icount req f = 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" + f $ responseLBS status200 [] "Ignored the body" doubleConnect :: CounterApplication -doubleConnect icount req = do +doubleConnect icount req f = do _ <- consumeBody $ requestBody req _ <- consumeBody $ requestBody req incr icount - return $ responseLBS status200 [] "double connect" + f $ responseLBS status200 [] "double connect" nextPort :: I.IORef Int nextPort = unsafePerformIO $ I.newIORef 5000 @@ -113,7 +113,7 @@ runTest expected app chunks = do Right i -> i `shouldBe` expected dummyApp :: Application -dummyApp _ = return $ responseLBS status200 [] "foo" +dummyApp _ f = f $ responseLBS status200 [] "foo" runTerminateTest :: InvalidRequest -> ByteString @@ -193,9 +193,9 @@ spec = do describe "special input" $ do it "multiline headers" $ do iheaders <- I.newIORef [] - let app req = do + let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req - return $ responseLBS status200 [] "" + f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat @@ -211,9 +211,9 @@ spec = do ] it "no space between colon and value" $ do iheaders <- I.newIORef [] - let app req = do + let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req - return $ responseLBS status200 [] "" + f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat @@ -231,10 +231,10 @@ spec = do describe "chunked bodies" $ do it "works" $ do ifront <- I.newIORef id - let app req = do + let app req f = do bss <- consumeBody $ requestBody req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) - return $ responseLBS status200 [] "" + f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat @@ -254,10 +254,10 @@ spec = do ] it "lots of chunks" $ do ifront <- I.newIORef id - let app req = do + let app req f = do bss <- consumeBody $ requestBody req I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) - return $ responseLBS status200 [] "" + f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = concat $ replicate 2 $ @@ -271,10 +271,10 @@ spec = do front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345") it "in chunks" $ do ifront <- I.newIORef id - let app req = do + let app req f = do bss <- consumeBody $ requestBody req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) - return $ responseLBS status200 [] "" + f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat @@ -293,7 +293,7 @@ spec = do ] it "timeout in request body" $ do ifront <- I.newIORef id - let app req = do + let app req f = do bss <- (consumeBody $ requestBody req) `onException` liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ()))) liftIO $ threadDelay 4000000 `E.catch` \e -> do @@ -302,7 +302,7 @@ spec = do , ())) E.throwIO (e :: E.SomeException) liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) - return $ responseLBS status200 [] "" + f $ responseLBS status200 [] "" withApp (setTimeout 1 defaultSettings) app $ \port -> do let bs1 = S.replicate 2048 88 bs2 = "This is short" @@ -322,9 +322,9 @@ spec = do S.concat (front []) `shouldBe` bs describe "raw body" $ do it "works" $ do - let app _req = do + let app _req f = do let backup = responseLBS status200 [] "Not raw" - return $ flip responseRaw backup $ \src sink -> do + f $ flip responseRaw backup $ \src sink -> do let loop = do bs <- src unless (S.null bs) $ do @@ -342,7 +342,7 @@ spec = do timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900") it "only one date and server header" $ do - let app _ = return $ responseLBS status200 + let app _ f = f $ responseLBS status200 [ ("server", "server") , ("date", "date") ] "" @@ -354,7 +354,7 @@ spec = do `shouldBe` ["date"] it "streaming echo #249" $ do - let app req = return $ responseStream status200 [] $ \write -> do + let app req f = f $ responseStream status200 [] $ \write -> do let loop = do bs <- requestBody req unless (S.null bs) $ do