08fa25c · typeable/wai

wai-extra/Network/Wai/Handler/CGI.hs+10−10

@@ -15,6 +15,7 @@ import Network.Wai.Internal

1515import Network.Socket (getAddrInfo, addrAddress)

1616import System.Environment (getEnvironment)

1717import Data.Maybe (fromMaybe)

18+import Control.Exception (mask)

1819import qualified Data.ByteString.Char8 as B

1920import qualified Data.ByteString.Lazy as L

2021import Control.Arrow ((***))

@@ -26,7 +27,6 @@ import Blaze.ByteString.Builder (fromByteString, toLazyByteString)

2627import Blaze.ByteString.Builder.Char8 (fromChar, fromString)

2728import Data.Conduit.Blaze (builderToByteStringFlush)

2829import Control.Monad.IO.Class (liftIO)

29−import Control.Monad.Trans.Resource (withInternalState)

3030import Data.ByteString.Lazy.Internal (defaultChunkSize)

3131import System.IO (Handle)

3232import Network.HTTP.Types (Status (..))

@@ -34,7 +34,6 @@ import qualified Network.HTTP.Types as H

3434import qualified Data.CaseInsensitive as CI

3535import Data.Monoid (mappend)

3636import Data.Conduit

37−import qualified Data.Conduit.List as CL

3837

3938safeRead :: Read a => a -> String -> a

4039safeRead d s =

@@ -95,7 +94,7 @@ runGeneric vars inputH outputH xsendfile app = do

9594 case addrs of

9695 a:_ -> addrAddress a

9796 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'

98− runResourceT $ withInternalState $ \internalState -> do

97+ mask $ \restore -> do

9998 let env = Request

10099 { requestMethod = rmethod

101100 , rawPathInfo = B.pack pinfo

@@ -109,18 +108,19 @@ runGeneric vars inputH outputH xsendfile app = do

109108 , requestBody = inputH contentLength

110109 , vault = mempty

111110 , requestBodyLength = KnownLength $ fromIntegral contentLength

112− , resourceInternalState = internalState

113111 }

114112 -- FIXME worry about exception?

115− res <- app env

113+ res <- restore $ app env

116114 case (xsendfile, res) of

117115 (Just sf, ResponseFile s hs fp Nothing) ->

118− liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp

116+ restore $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp

119117 _ -> do

120− let (s, hs, b) = responseToSource env res

121− src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n']

122− `mappend` b

123− src $$ builderSink

118+ let (s, hs, wb) = responseToSource res

119+ wb $ \b ->

120+ let src = do

121+ yield (Chunk $ headers s hs `mappend` fromChar '\n')

122+ b

123+ in src $$ builderSink

124124 where

125125 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))

126126 status (Status i m) = (fromByteString "Status", mconcat

wai-extra/Network/Wai/Middleware/Gzip.hs+5−5

@@ -85,7 +85,7 @@ gzip set app env = do

8585 Just m

8686 | gzipCheckMime set m -> liftIO $ compressFile s hs file cache

8787 _ -> return res

88− _ -> return $ compressE set env res

88+ _ -> return $ compressE set res

8989 else return res

9090 where

9191 enc = fromMaybe [] $ (splitCommas . S8.unpack)

@@ -125,19 +125,19 @@ compressFile s hs file cache = do

125125 safe _ = '_'

126126

127127compressE :: GzipSettings

128− -> Request

129128 -> Response

130129 -> Response

131−compressE set req res =

130+compressE set res =

132131 case lookup "content-type" hs of

133132 Just m | gzipCheckMime set m ->

134133 let hs' = fixHeaders hs

135− in ResponseSource s hs' $ b C.$= builderToByteStringFlush

134+ in ResponseSource s hs' $ \f -> wb $ \b -> f $

135+ b C.$= builderToByteStringFlush

136136 C.$= CZ.compressFlush 1 (CZ.WindowBits 31)

137137 C.$= CL.map (fmap fromByteString)

138138 _ -> res

139139 where

140− (s, hs, b) = responseToSource req res

140+ (s, hs, wb) = responseToSource res

141141

142142-- Remove Content-Length header, since we will certainly have a

143143-- different length after gzip compression.

wai-extra/Network/Wai/Middleware/Jsonp.hs+19−12

@@ -19,7 +19,7 @@ import Network.Wai

1919import Network.Wai.Internal

2020import Data.ByteString (ByteString)

2121import qualified Data.ByteString.Char8 as B8

22−import Blaze.ByteString.Builder (copyByteString)

22+import Blaze.ByteString.Builder (Builder, copyByteString)

2323import Blaze.ByteString.Builder.Char8 (fromChar)

2424import Data.Monoid (mappend)

2525import Control.Monad (join)

@@ -27,6 +27,8 @@ import Data.Maybe (fromMaybe)

2727import qualified Data.ByteString as S

2828import qualified Data.Conduit as C

2929import qualified Data.Conduit.List as CL

30+import Data.CaseInsensitive (CI)

31+import Network.HTTP.Types (Status)

3032

3133-- | Wrap json responses in a jsonp callback.

3234--

@@ -52,24 +54,24 @@ jsonp app env = do

5254 $ requestHeaders env

5355 }

5456 res <- app env'

55− case callback of

56− Nothing -> return res

57+ return $ case callback of

58+ Nothing -> res

5759 Just c -> go c res

5860 where

5961 go c r@(ResponseBuilder s hs b) =

6062 case checkJSON hs of

61− Nothing -> return r

62− Just hs' -> return $ ResponseBuilder s hs' $

63+ Nothing -> r

64+ Just hs' -> ResponseBuilder s hs' $

6365 copyByteString c

6466 `mappend` fromChar '('

6567 `mappend` b

6668 `mappend` fromChar ')'

6769 go c r =

6870 case checkJSON hs of

69− Just hs' -> addCallback c s hs' b

70− Nothing -> return r

71+ Just hs' -> addCallback c s hs' wb

72+ Nothing -> r

7173 where

72− (s, hs, b) = responseToSource env r

74+ (s, hs, wb) = responseToSource r

7375

7476 checkJSON hs =

7577 case lookup "Content-Type" hs of

@@ -79,11 +81,16 @@ jsonp app env = do

7981 _ -> Nothing

8082 fixHeaders = changeVal "Content-Type" "text/javascript"

8183

82− addCallback cb s hs b =

83− return $ ResponseSource s hs $

84− CL.sourceList [C.Chunk $ copyByteString cb `mappend` fromChar '(']

84+ addCallback :: ByteString

85+ -> Status

86+ -> [(CI ByteString, ByteString)]

87+ -> (forall b. WithSource IO (C.Flush Builder) b)

88+ -> Response

89+ addCallback cb s hs wb =

90+ ResponseSource s hs $ \f -> wb $ \b -> f $

91+ C.yield (C.Chunk $ copyByteString cb `mappend` fromChar '(')

8592 `mappend` b

86− `mappend` CL.sourceList [C.Chunk $ fromChar ')']

93+ `mappend` C.yield (C.Chunk $ fromChar ')')

8794

8895changeVal :: Eq a

8996 => a

wai-extra/Network/Wai/Middleware/RequestLogger.hs+3−1

@@ -26,6 +26,7 @@ import Network.Wai (Request(..), Middleware, responseStatus, Response)

2626import System.Log.FastLogger

2727import Network.HTTP.Types as H

2828import Data.Maybe (fromMaybe)

29+import Control.Monad.Trans.Resource (withInternalState)

2930

3031import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)

3132import qualified Data.ByteString.Lazy as LBS

@@ -262,7 +263,8 @@ detailedMiddleware' cb getAddColor app req = do

262263 allPostParams body =

263264 case getRequestBodyType req of

264265 Nothing -> return ([], [])

265− Just rbt -> CL.sourceList body C.$$ sinkRequestBody (resourceInternalState req) lbsBackEnd rbt

266+ Just rbt -> C.runResourceT $ withInternalState $ \internalState ->

267+ CL.sourceList body C.$$ sinkRequestBody internalState lbsBackEnd rbt

266268

267269 emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)

268270 emptyGetParam (k, Just v) = (k,v)

wai-extra/Network/Wai/Parse.hs+3−2

@@ -51,7 +51,7 @@ import qualified Network.HTTP.Types as H

5151import Data.Either (partitionEithers)

5252import Control.Monad (when, unless)

5353import Control.Monad.Trans.Class (lift)

54−import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

54+import Control.Monad.Trans.Resource (allocate, release, register, InternalState, withInternalState, runInternalState)

5555import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..))

5656import Data.Void (Void)

5757

@@ -169,7 +169,8 @@ parseRequestBody :: BackEnd y

169169parseRequestBody s r =

170170 case getRequestBodyType r of

171171 Nothing -> return ([], [])

172− Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody (resourceInternalState r) s rbt =$ CL.consume

172+ Just rbt -> runResourceT $ withInternalState $ \internalState ->

173+ fmap partitionEithers $ requestBody r $$ conduitRequestBody internalState s rbt =$ CL.consume

173174

174175sinkRequestBody :: InternalState

175176 -> BackEnd y

wai-extra/test/WaiExtraTest.hs+3−2

@@ -15,7 +15,7 @@ import qualified Data.Text.Lazy as T

1515import qualified Data.Text as TS

1616import qualified Data.Text.Encoding as TE

1717import Control.Arrow

18−import Control.Monad.Trans.Resource (getInternalState)

18+import Control.Monad.Trans.Resource (getInternalState, withInternalState, runResourceT)

1919

2020import Network.Wai.Middleware.Jsonp

2121import Network.Wai.Middleware.Gzip

@@ -121,7 +121,8 @@ parseRequestBody' :: BackEnd L.ByteString

121121parseRequestBody' sink (SRequest req bod) =

122122 case getRequestBodyType req of

123123 Nothing -> return ([], [])

124− Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody (resourceInternalState req) sink rbt

124+ Just rbt -> runResourceT $ withInternalState $ \is ->

125+ CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody is sink rbt

125126

126127caseParseRequestBody :: Assertion

127128caseParseRequestBody =

wai-handler-launch/Network/Wai/Handler/Launch.hs+2−2

@@ -46,14 +46,14 @@ ping var app req

4646 ResponseSource _ hs _

4747 | not $ isHtml hs -> return res

4848 _ -> do

49− let (s, hs, body) = responseToSource req res

49+ let (s, hs, withBody) = responseToSource res

5050 let (isEnc, headers') = fixHeaders id hs

5151 let headers'' = filter (\(x, _) -> x /= "content-length") headers'

5252 let fixEnc src =

5353 if isEnc then

5454 src $= decompressFlush (WindowBits 31)

5555 else src

56− return $ ResponseSource s headers''

56+ return $ ResponseSource s headers'' $ \f -> withBody $ \body -> f

5757 $ fixEnc (body $= builderToByteStringFlush)

5858 $= insideHead

5959 $= CL.map (fmap fromByteString)

wai-test/Network/Wai/Test.hs+11−16

@@ -27,7 +27,6 @@ import qualified Test.HUnit.Base as H

2727import Control.Monad.IO.Class (liftIO)

2828import Control.Monad.Trans.State (StateT, evalStateT)

2929import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)

30−import Control.Monad.Trans.Resource (withInternalState)

3130import Data.Map (Map)

3231import qualified Data.Map as Map

3332import Data.ByteString (ByteString)

@@ -86,7 +85,6 @@ defaultRequest = Request

8685 , requestBody = mempty

8786 , vault = mempty

8887 , requestBodyLength = KnownLength 0

89− , resourceInternalState = error "Network.Wai.Test.defaultRequest: No resourceInternalState provided"

9088 }

9189

9290-- | Set whole path (request path + query string).

@@ -112,22 +110,19 @@ setRawPathInfo r rawPinfo =

112110srequest :: SRequest -> Session SResponse

113111srequest (SRequest req bod) = do

114112 app <- ask

115− liftIO $ C.runResourceT $ withInternalState $ \internalState -> do

116− let req' = req

117− { requestBody = CL.sourceList $ L.toChunks bod

118− , resourceInternalState = internalState

119− }

120− res <- app req'

121− sres <- runResponse req' res

122− -- FIXME cookie processing

123− return sres

124−

125−runResponse :: Request -> Response -> IO SResponse

126−runResponse req res = do

127− bss <- body C.$= CL.map toBuilder C.$= builderToByteString C.$$ CL.consume

113+ let req' = req

114+ { requestBody = CL.sourceList $ L.toChunks bod

115+ }

116+ liftIO $ app req' >>= runResponse

117+ -- FIXME cookie processing

118+ --return sres

119+

120+runResponse :: Response -> IO SResponse

121+runResponse res = do

122+ bss <- withBody $ \body -> body C.$= CL.map toBuilder C.$= builderToByteString C.$$ CL.consume

128123 return $ SResponse s h $ L.fromChunks bss

129124 where

130− (s, h, body) = responseToSource req res

125+ (s, h, withBody) = responseToSource res

131126 toBuilder (C.Chunk builder) = builder

132127 toBuilder C.Flush = flush

133128

wai-test/wai-test.cabal−1

@@ -27,7 +27,6 @@ library

2727 , http-types >= 0.7

2828 , case-insensitive >= 0.2

2929 , network

30− , resourcet

3130 exposed-modules: Network.Wai.Test

3231 ghc-options: -Wall

3332

wai/Network/Wai.hs+16−21

@@ -50,7 +50,6 @@ module Network.Wai

5050 , requestBody

5151 , vault

5252 , requestBodyLength

53− , resourceInternalState

5453 -- ** Response

5554 , Response

5655 , responseFile

@@ -62,6 +61,7 @@ module Network.Wai

6261 , Middleware

6362 , FilePart (..)

6463 , RequestBodyLength (..)

64+ , WithSource

6565 -- ** Helper functions

6666 , responseToSource

6767 , responseStatus

@@ -69,7 +69,6 @@ module Network.Wai

6969

7070import Blaze.ByteString.Builder (Builder, fromLazyByteString)

7171import Blaze.ByteString.Builder (fromByteString)

72−import qualified Control.Monad.Trans.Resource as Res

7372import qualified Data.ByteString as B

7473import qualified Data.ByteString.Lazy as L

7574import Data.ByteString.Lazy.Char8 ()

@@ -78,6 +77,7 @@ import qualified Data.Conduit.Binary as CB

7877import qualified Data.Conduit.List as CL

7978import qualified Network.HTTP.Types as H

8079import Network.Wai.Internal

80+import qualified System.IO as IO

8181

8282responseFile :: H.Status -> H.ResponseHeaders -> FilePath -> Maybe FilePart -> Response

8383responseFile = ResponseFile

@@ -86,7 +86,7 @@ responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

8686responseBuilder = ResponseBuilder

8787

8888responseSource :: H.Status -> H.ResponseHeaders -> C.Source IO (C.Flush Builder) -> Response

89−responseSource = ResponseSource

89+responseSource st hs src = ResponseSource st hs ($ src)

9090

9191responseStatus :: Response -> H.Status

9292responseStatus rsp =

@@ -95,24 +95,19 @@ responseStatus rsp =

9595 ResponseBuilder s _ _ -> s

9696 ResponseSource s _ _ -> s

9797

98−responseToSource :: Request

99− -> Response

100− -> (H.Status, H.ResponseHeaders, C.Source IO (C.Flush Builder))

101−responseToSource _ (ResponseSource s h b) = (s, h, b)

102−responseToSource req (ResponseFile s h fp (Just part)) =

103− (s, h, transRes (sourceFilePart part fp) C.$= CL.map (C.Chunk . fromByteString))

104− where

105− transRes = C.transPipe (flip Res.runInternalState (resourceInternalState req))

106−responseToSource req (ResponseFile s h fp Nothing) =

107− (s, h, transRes (CB.sourceFile fp) C.$= CL.map (C.Chunk . fromByteString))

108− where

109− transRes = C.transPipe (flip Res.runInternalState (resourceInternalState req))

110−responseToSource _ (ResponseBuilder s h b) =

111− (s, h, CL.sourceList [C.Chunk b])

112−

113−sourceFilePart :: C.MonadResource m => FilePart -> FilePath -> C.Source m B.ByteString

114−sourceFilePart (FilePart offset count) fp =

115− CB.sourceFileRange fp (Just offset) (Just count)

98+responseToSource :: Response

99+ -> (H.Status, H.ResponseHeaders, WithSource IO (C.Flush Builder) b)

100+responseToSource (ResponseSource s h b) = (s, h, b)

101+responseToSource (ResponseFile s h fp (Just part)) =

102+ (s, h, \f -> IO.withFile fp IO.ReadMode $ \handle -> f $ sourceFilePart handle part C.$= CL.map (C.Chunk . fromByteString))

103+responseToSource (ResponseFile s h fp Nothing) =

104+ (s, h, \f -> IO.withFile fp IO.ReadMode $ \handle -> f $ CB.sourceHandle handle C.$= CL.map (C.Chunk . fromByteString))

105+responseToSource (ResponseBuilder s h b) =

106+ (s, h, ($ CL.sourceList [C.Chunk b]))

107+

108+sourceFilePart :: IO.Handle -> FilePart -> C.Source IO B.ByteString

109+sourceFilePart handle (FilePart offset count) =

110+ CB.sourceHandleRange handle (Just offset) (Just count)

116111

117112responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

118113responseLBS s h = ResponseBuilder s h . fromLazyByteString

wai/Network/Wai/Internal.hs+4−7

@@ -1,12 +1,12 @@

11{-# OPTIONS_HADDOCK not-home #-}

22{-# LANGUAGE DeriveDataTypeable #-}

33{-# LANGUAGE CPP #-}

4+{-# LANGUAGE RankNTypes #-}

45-- | Internal constructors and helper functions. Note that no guarantees are

56-- given for stability of these interfaces.

67module Network.Wai.Internal where

78

89import Blaze.ByteString.Builder (Builder)

9−import qualified Control.Monad.Trans.Resource as Res

1010import qualified Data.ByteString as B

1111import qualified Data.Conduit as C

1212import Data.Text (Text)

@@ -58,11 +58,6 @@ data Request = Request

5858 --

5959 -- Since 1.4.0

6060 , requestBodyLength :: RequestBodyLength

61− -- | The internal @ResourceT@ state, used for allocating scarce resources

62− -- will in an application.

63− --

64− -- Since 1.5.0

65− , resourceInternalState :: Res.InternalState

6661 }

6762 deriving (Typeable)

6863

@@ -92,9 +87,11 @@ data Request = Request

9287data Response

9388 = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)

9489 | ResponseBuilder H.Status H.ResponseHeaders Builder

95− | ResponseSource H.Status H.ResponseHeaders (C.Source IO (C.Flush Builder))

90+ | ResponseSource H.Status H.ResponseHeaders (forall b. WithSource IO (C.Flush Builder) b)

9691 deriving Typeable

9792

93+type WithSource m a b = (C.Source m a -> m b) -> m b

94+

9895-- | The size of the request body. In the case of chunked bodies, the size will

9996-- not be known.

10097--

wai/wai.cabal+1−2

@@ -20,13 +20,12 @@ Library

2020 Build-Depends: base >= 4 && < 5

2121 , bytestring >= 0.9.1.4

2222 , blaze-builder >= 0.2.1.4 && < 0.4

23− , conduit >= 0.5 && < 1.1

23+ , conduit >= 1.0.8 && < 1.1

2424 , network >= 2.2.1.5

2525 , http-types >= 0.7

2626 , text >= 0.7

2727 , transformers >= 0.2.2

2828 , vault >= 0.1 && < 0.4

29− , resourcet >= 0.4.7

3029 Exposed-modules: Network.Wai

3130 Network.Wai.Internal

3231 ghc-options: -Wall

warp/Network/Wai/Handler/Warp.hs−1

@@ -32,7 +32,6 @@ module Network.Wai.Handler.Warp (

3232 , settingsIntercept

3333 , settingsManager

3434 , settingsFdCacheDuration

35− , settingsResourceTPerRequest

3635 , settingsBeforeMainLoop

3736 , settingsServerName

3837 -- ** Data types

warp/Network/Wai/Handler/Warp/Request.hs+4−8

@@ -25,7 +25,6 @@ import Network.Wai.Handler.Warp.ReadInt

2525import Network.Wai.Handler.Warp.Types

2626import Prelude hiding (lines)

2727import qualified Network.Wai.Handler.Warp.Timeout as Timeout

28−import qualified Control.Monad.Trans.Resource as Res

2928

3029-- FIXME come up with good values here

3130maxTotalHeaderLength :: Int

@@ -34,13 +33,12 @@ maxTotalHeaderLength = 50 * 1024

3433parseRequest

3534 :: Connection

3635 -> Timeout.Handle

37− -> Res.InternalState

3836 -> SockAddr

3937 -> Source IO ByteString

4038 -> IO (Request, IO (ResumableSource IO ByteString))

41−parseRequest conn timeoutHandle internalState remoteHost' src1 = do

39+parseRequest conn timeoutHandle remoteHost' src1 = do

4240 (src2, headers') <- src1 $$+ takeHeaders

43− parseRequest' conn timeoutHandle internalState headers' remoteHost' src2

41+ parseRequest' conn timeoutHandle headers' remoteHost' src2

4442

4543handleExpect :: Connection

4644 -> H.HttpVersion

@@ -59,13 +57,12 @@ handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs

5957-- | Parse a set of header lines and body into a 'Request'.

6058parseRequest' :: Connection

6159 -> Timeout.Handle

62− -> Res.InternalState

6360 -> [ByteString]

6461 -> SockAddr

6562 -> ResumableSource IO ByteString -- FIXME was buffered

6663 -> IO (Request, IO (ResumableSource IO ByteString))

67−parseRequest' _ _ _ [] _ _ = throwIO $ NotEnoughLines []

68−parseRequest' conn timeoutHandle internalState (firstLine:otherLines) remoteHost' src = do

64+parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []

65+parseRequest' conn timeoutHandle (firstLine:otherLines) remoteHost' src = do

6966 (method, rpath', gets, httpversion) <- parseFirst firstLine

7067 let rpath

7168 | S.null rpath' = "/"

@@ -116,7 +113,6 @@ parseRequest' conn timeoutHandle internalState (firstLine:otherLines) remoteHost

116113 then ChunkedBody

117114 else KnownLength $ fromIntegral len0

118115#endif

119− , resourceInternalState = internalState

120116 }, getSource)

121117

122118{-# INLINE takeUntil #-}

warp/Network/Wai/Handler/Warp/Response.hs+22−17

@@ -1,6 +1,7 @@

11{-# LANGUAGE OverloadedStrings #-}

22{-# LANGUAGE ScopedTypeVariables #-}

33{-# LANGUAGE TupleSections #-}

4+{-# LANGUAGE RankNTypes #-}

45

56module Network.Wai.Handler.Warp.Response (

67 sendResponse

@@ -35,13 +36,15 @@ import Numeric (showInt)

3536----------------------------------------------------------------

3637

3738sendResponse :: Settings

38− -> Cleaner -> Request -> Connection -> Response

39+ -> Cleaner -> Request -> Connection

40+ -> (forall a. IO a -> IO a) -- ^ restore masking state

41+ -> Response

3942 -> IO Bool

4043

4144----------------------------------------------------------------

4245

43−sendResponse settings cleaner req conn (ResponseFile s0 hs0 path mpart0) =

44− headerAndLength >>= sendResponse'

46+sendResponse settings cleaner req conn restore (ResponseFile s0 hs0 path mpart0) =

47+ restore $ headerAndLength >>= sendResponse'

4548 where

4649 hs = addAccept hs0

4750 th = threadHandle cleaner

@@ -95,14 +98,14 @@ sendResponse settings cleaner req conn (ResponseFile s0 hs0 path mpart0) =

9598 (isPersist,_) = infoFromRequest req

9699

97100 sendResponse' (Left (_ :: SomeException)) =

98− sendResponse settings cleaner req conn notFound

101+ sendResponse settings cleaner req conn restore notFound

99102 where

100103 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"

101104

102105----------------------------------------------------------------

103106

104−sendResponse settings cleaner req conn (ResponseBuilder s hs b)

105− | hasBody s req = liftIO $ do

107+sendResponse settings cleaner req conn restore (ResponseBuilder s hs b)

108+ | hasBody s req = restore $ do

106109 header <- composeHeaderBuilder settings version s hs needsChunked

107110 let body

108111 | needsChunked = header `mappend` chunkedTransferEncoding b

@@ -112,7 +115,7 @@ sendResponse settings cleaner req conn (ResponseBuilder s hs b)

112115 connSendAll conn bs

113116 T.tickle th

114117 return isKeepAlive

115− | otherwise = liftIO $ do

118+ | otherwise = restore $ do

116119 composeHeader settings version s hs >>= connSendAll conn

117120 T.tickle th

118121 return isPersist

@@ -124,24 +127,26 @@ sendResponse settings cleaner req conn (ResponseBuilder s hs b)

124127

125128----------------------------------------------------------------

126129

127−sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush)

128− | hasBody s req = do

130+sendResponse settings cleaner req conn restore (ResponseSource s hs withBodyFlush)

131+ | hasBody s req = withBodyFlush $ \bodyFlush -> restore $ do

129132 header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked

130− let src = CL.sourceList [header] `mappend` cbody

133+ let src = CL.sourceList [header] `mappend` cbody bodyFlush

131134 src $$ builderToByteString =$ connSink conn th

132135 return isKeepAlive

133− | otherwise = liftIO $ do

136+ | otherwise = withBodyFlush $ \_bodyFlush -> restore $ do -- make sure any cleanup is called

134137 composeHeader settings version s hs >>= connSendAll conn

135138 T.tickle th

136139 return isPersist

137140 where

138141 th = threadHandle cleaner

139− body =

140− mapOutput (\x -> case x of

141− Flush -> flush

142− Chunk builder -> builder)

143− bodyFlush

144− cbody = if needsChunked then body $= chunk else body

142+ cbody bodyFlush =

143+ if needsChunked then body $= chunk else body

144+ where

145+ body =

146+ mapOutput (\x -> case x of

147+ Flush -> flush

148+ Chunk builder -> builder)

149+ bodyFlush

145150 -- FIXME perhaps alloca a buffer per thread and reuse that in all

146151 -- functions below. Should lessen greatly the GC burden (I hope)

147152 chunk :: Conduit Builder IO Builder

warp/Network/Wai/Handler/Warp/Run.hs+10−13

@@ -7,7 +7,6 @@ import Control.Concurrent (threadDelay, forkIOWithUnmask)

77import Control.Exception

88import Control.Monad (forever, when, unless, void)

99import Control.Monad.IO.Class (MonadIO, liftIO)

10−import qualified Control.Monad.Trans.Resource as Res

1110import Data.ByteString (ByteString)

1211import qualified Data.ByteString as S

1312import Data.Conduit

@@ -232,32 +231,30 @@ serveConnection :: T.Handle

232231 -> Cleaner

233232 -> Application -> Connection -> SockAddr-> IO ()

234233serveConnection timeoutHandle settings cleaner app conn remoteHost' =

235− runResourceT $ Res.withInternalState $ serveConnection'' $ connSource conn th

234+ serveConnection'' $ connSource conn th

236235 where

237− innerRunResourceT env f

238− | settingsResourceTPerRequest settings = runResourceT $ Res.withInternalState $ \is' -> f env

239− { resourceInternalState = is'

240− }

241− | otherwise = f env

242236 th = threadHandle cleaner

243237

244− serveConnection'' fromClient internalState = do

245− (env, getSource) <- parseRequest conn timeoutHandle internalState remoteHost' fromClient

238+ serveConnection'' fromClient = do

239+ (env, getSource) <- parseRequest conn timeoutHandle remoteHost' fromClient

246240 case settingsIntercept settings env of

247241 Nothing -> do

248242 -- Let the application run for as long as it wants

249243 liftIO $ T.pause th

250− keepAlive <- innerRunResourceT env $ \env' -> do

251− res <- app env'

252244

245+ -- In the event that some scarce resource was acquired during

246+ -- creating the request, we need to make sure that we don't get

247+ -- an async exception before calling the ResponseSource.

248+ keepAlive <- mask $ \restore -> do

249+ res <- restore $ app env

253250 liftIO $ T.resume th

254− sendResponse settings cleaner env' conn res

251+ sendResponse settings cleaner env conn restore res

255252

256253 -- flush the rest of the request body

257254 requestBody env $$ CL.sinkNull

258255 ResumableSource fromClient' _ <- liftIO getSource

259256

260− when keepAlive $ serveConnection'' fromClient' internalState

257+ when keepAlive $ serveConnection'' fromClient'

261258 Just intercept -> do

262259 liftIO $ T.pause th

263260 ResumableSource fromClient' _ <- liftIO getSource

warp/Network/Wai/Handler/Warp/Settings.hs−6

@@ -28,11 +28,6 @@ data Settings = Settings

2828 , settingsIntercept :: Request -> Maybe (Source IO S.ByteString -> Connection -> IO ())

2929 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'

3030 , settingsFdCacheDuration :: Int -- ^ Cache duratoin time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 10

31− , settingsResourceTPerRequest :: Bool

32− -- ^ If @True@, each request\/response pair will run in a separate

33− -- @ResourceT@. This provides more intuitive behavior for dynamic code,

34− -- but can hinder performance in high-throughput cases. File servers can

35− -- safely set to @False@ for increased performance. Default is @True@.

3631 , settingsBeforeMainLoop :: IO ()

3732 -- ^ Code to run after the listening socket is ready but before entering

3833 -- the main event loop. Useful for signaling to tests that they can start

@@ -62,7 +57,6 @@ defaultSettings = Settings

6257 , settingsIntercept = const Nothing

6358 , settingsManager = Nothing

6459 , settingsFdCacheDuration = 10

65− , settingsResourceTPerRequest = True

6660 , settingsBeforeMainLoop = return ()

6761 , settingsServerName = S8.pack $ "Warp/" ++ warpVersion

6862 }

warp/warp.cabal−1

@@ -44,7 +44,6 @@ Library

4444 , void

4545 , wai >= 2.0 && < 2.1

4646 , http-attoparsec

47− , resourcet

4847 if flag(network-bytestring)

4948 Build-Depends: network >= 2.2.1.5 && < 2.2.3

5049 , network-bytestring >= 0.1.3 && < 0.1.4