Application uses bracket pattern

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

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
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------

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,

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

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

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