08fa25c · typeable/wai

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

compare with master

unifiedsplit

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

15import Network.Socket (getAddrInfo, addrAddress)

16import System.Environment (getEnvironment)

17import Data.Maybe (fromMaybe)

18+import Control.Exception (mask)

18import qualified Data.ByteString.Char8 as B

19import qualified Data.ByteString.Char8 as B

19import qualified Data.ByteString.Lazy as L

20import qualified Data.ByteString.Lazy as L

20import Control.Arrow ((***))

21import Control.Arrow ((***))

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

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

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

27import Data.Conduit.Blaze (builderToByteStringFlush)

28import Data.Conduit.Blaze (builderToByteStringFlush)

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

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

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

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

31import System.IO (Handle)

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

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

34import qualified Data.CaseInsensitive as CI

35import Data.Monoid (mappend)

36import Data.Conduit

37−import qualified Data.Conduit.List as CL

38

37

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

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

40safeRead d s =

39safeRead d s =

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

95 case addrs of

94 case addrs of

96 a:_ -> addrAddress a

95 a:_ -> addrAddress a

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

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

98− runResourceT $ withInternalState $ \internalState -> do

97+ mask $ \restore -> do

99 let env = Request

98 let env = Request

100 { requestMethod = rmethod

99 { requestMethod = rmethod

101 , rawPathInfo = B.pack pinfo

100 , rawPathInfo = B.pack pinfo

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

109 , requestBody = inputH contentLength

108 , requestBody = inputH contentLength

110 , vault = mempty

109 , vault = mempty

111 , requestBodyLength = KnownLength $ fromIntegral contentLength

110 , requestBodyLength = KnownLength $ fromIntegral contentLength

112− , resourceInternalState = internalState

113 }

111 }

114 -- FIXME worry about exception?

112 -- FIXME worry about exception?

115− res <- app env

113+ res <- restore $ app env

116 case (xsendfile, res) of

114 case (xsendfile, res) of

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

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

119 _ -> do

117 _ -> do

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

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

119+ wb $ \b ->

120+ let src = do

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

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

122− `mappend` b

122+ b

123− src $$ builderSink

123+ in src $$ builderSink

124 where

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

126 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

85 Just m

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

87 _ -> return res

88− _ -> return $ compressE set env res

88+ _ -> return $ compressE set res

89 else return res

90 where

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

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

125 safe _ = '_'

126

127compressE :: GzipSettings

128− -> Request

129 -> Response

128 -> Response

130 -> Response

129 -> Response

131−compressE set req res =

130+compressE set res =

132 case lookup "content-type" hs of

131 case lookup "content-type" hs of

133 Just m | gzipCheckMime set m ->

132 Just m | gzipCheckMime set m ->

134 let hs' = fixHeaders hs

133 let hs' = fixHeaders hs

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

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

135+ b C.$= builderToByteStringFlush

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

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

138 _ -> res

139 where

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

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

141

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

143-- different length after gzip compression.

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

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

19import Network.Wai.Internal

20import Data.ByteString (ByteString)

21import qualified Data.ByteString.Char8 as B8

22−import Blaze.ByteString.Builder (copyByteString)

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

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

24import Data.Monoid (mappend)

25import Control.Monad (join)

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

27import qualified Data.ByteString as S

28import qualified Data.Conduit as C

29import qualified Data.Conduit.List as CL

30+import Data.CaseInsensitive (CI)

31+import Network.HTTP.Types (Status)

30

32

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

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

32--

34--

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

52 $ requestHeaders env

54 $ requestHeaders env

53 }

55 }

54 res <- app env'

56 res <- app env'

55− case callback of

57+ return $ case callback of

56− Nothing -> return res

58+ Nothing -> res

57 Just c -> go c res

59 Just c -> go c res

58 where

60 where

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

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

60 case checkJSON hs of

62 case checkJSON hs of

61− Nothing -> return r

63+ Nothing -> r

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

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

63 copyByteString c

65 copyByteString c

64 `mappend` fromChar '('

66 `mappend` fromChar '('

65 `mappend` b

67 `mappend` b

66 `mappend` fromChar ')'

68 `mappend` fromChar ')'

67 go c r =

69 go c r =

68 case checkJSON hs of

70 case checkJSON hs of

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

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

70− Nothing -> return r

72+ Nothing -> r

71 where

73 where

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

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

73

75

74 checkJSON hs =

76 checkJSON hs =

75 case lookup "Content-Type" hs of

77 case lookup "Content-Type" hs of

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

79 _ -> Nothing

81 _ -> Nothing

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

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

81

83

82− addCallback cb s hs b =

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 =

83− return $ ResponseSource s hs $

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

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

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

85 `mappend` b

92 `mappend` b

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

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

87

94

88changeVal :: Eq a

95changeVal :: Eq a

89 => a

96 => a

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

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

26import System.Log.FastLogger

27import Network.HTTP.Types as H

28import Data.Maybe (fromMaybe)

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

29

30

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

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

31import qualified Data.ByteString.Lazy as LBS

32import qualified Data.ByteString.Lazy as LBS

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

262 allPostParams body =

263 allPostParams body =

263 case getRequestBodyType req of

264 case getRequestBodyType req of

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

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

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

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

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

266

268

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

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

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

270 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

51import Data.Either (partitionEithers)

52import Control.Monad (when, unless)

53import 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)

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

56import Data.Void (Void)

57

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

169parseRequestBody s r =

170 case getRequestBodyType r of

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

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

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

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

173

174

174sinkRequestBody :: InternalState

175sinkRequestBody :: InternalState

175 -> BackEnd y

176 -> BackEnd y

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

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

15import qualified Data.Text as TS

16import qualified Data.Text.Encoding as TE

17import Control.Arrow

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

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

19

20import Network.Wai.Middleware.Jsonp

21import Network.Wai.Middleware.Gzip

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

121parseRequestBody' sink (SRequest req bod) =

122 case getRequestBodyType req of

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

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

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

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

125

126

126caseParseRequestBody :: Assertion

127caseParseRequestBody :: Assertion

127caseParseRequestBody =

128caseParseRequestBody =

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

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

46 ResponseSource _ hs _

47 | not $ isHtml hs -> return res

48 _ -> do

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

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

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

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

52 let fixEnc src =

53 if isEnc then

54 src $= decompressFlush (WindowBits 31)

55 else src

56− return $ ResponseSource s headers''

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

57 $ fixEnc (body $= builderToByteStringFlush)

58 $= insideHead

59 $= CL.map (fmap fromByteString)

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

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

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

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

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

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

31import Data.Map (Map)

30import Data.Map (Map)

32import qualified Data.Map as Map

31import qualified Data.Map as Map

33import Data.ByteString (ByteString)

32import Data.ByteString (ByteString)

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

86 , requestBody = mempty

85 , requestBody = mempty

87 , vault = mempty

86 , vault = mempty

88 , requestBodyLength = KnownLength 0

87 , requestBodyLength = KnownLength 0

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

90 }

88 }

91

89

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

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

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

112srequest :: SRequest -> Session SResponse

110srequest :: SRequest -> Session SResponse

113srequest (SRequest req bod) = do

111srequest (SRequest req bod) = do

114 app <- ask

112 app <- ask

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

116− let req' = req

113+ let req' = req

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

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

118− , resourceInternalState = internalState

119− }

115+ }

120− res <- app req'

121− sres <- runResponse req' res

116+ liftIO $ app req' >>= runResponse

122− -- FIXME cookie processing

117+ -- FIXME cookie processing

123− return sres

118+ --return sres

124−

119+

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

120+runResponse :: Response -> IO SResponse

126−runResponse req res = do

121+runResponse res = do

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

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

128 return $ SResponse s h $ L.fromChunks bss

123 return $ SResponse s h $ L.fromChunks bss

129 where

124 where

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

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

131 toBuilder (C.Chunk builder) = builder

126 toBuilder (C.Chunk builder) = builder

132 toBuilder C.Flush = flush

127 toBuilder C.Flush = flush

133

128

wai-test/wai-test.cabal−1

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

27 , http-types >= 0.7

28 , case-insensitive >= 0.2

29 , network

30− , resourcet

31 exposed-modules: Network.Wai.Test

30 exposed-modules: Network.Wai.Test

32 ghc-options: -Wall

31 ghc-options: -Wall

33

32

wai/Network/Wai.hs+16−21

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

50 , requestBody

51 , vault

52 , requestBodyLength

53− , resourceInternalState

54 -- ** Response

53 -- ** Response

55 , Response

54 , Response

56 , responseFile

55 , responseFile

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

62 , Middleware

61 , Middleware

63 , FilePart (..)

62 , FilePart (..)

64 , RequestBodyLength (..)

63 , RequestBodyLength (..)

64+ , WithSource

65 -- ** Helper functions

66 , responseToSource

67 , responseStatus

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

69

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

71import Blaze.ByteString.Builder (fromByteString)

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

73import qualified Data.ByteString as B

72import qualified Data.ByteString as B

74import qualified Data.ByteString.Lazy as L

73import qualified Data.ByteString.Lazy as L

75import Data.ByteString.Lazy.Char8 ()

74import Data.ByteString.Lazy.Char8 ()

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

78import qualified Data.Conduit.List as CL

77import qualified Data.Conduit.List as CL

79import qualified Network.HTTP.Types as H

78import qualified Network.HTTP.Types as H

80import Network.Wai.Internal

79import Network.Wai.Internal

80+import qualified System.IO as IO

81

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

83responseFile = ResponseFile

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

86responseBuilder = ResponseBuilder

87

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

89−responseSource = ResponseSource

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

90

91responseStatus :: Response -> H.Status

92responseStatus rsp =

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

95 ResponseBuilder s _ _ -> s

96 ResponseSource s _ _ -> s

97

98−responseToSource :: Request

98+responseToSource :: Response

99− -> Response

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

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

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

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

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

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

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

102+ (s, h, \f -> IO.withFile fp IO.ReadMode $ \handle -> f $ sourceFilePart handle part 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) =

103+responseToSource (ResponseFile s h fp Nothing) =

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

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

108− where

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

110−responseToSource _ (ResponseBuilder s h b) =

105+responseToSource (ResponseBuilder s h b) =

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

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

112−

107+

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

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

114−sourceFilePart (FilePart offset count) fp =

109+sourceFilePart handle (FilePart offset count) =

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

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

116

111

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

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

118responseLBS s h = ResponseBuilder s h . fromLazyByteString

113responseLBS s h = ResponseBuilder s h . fromLazyByteString

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

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

1{-# OPTIONS_HADDOCK not-home #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE CPP #-}

4+{-# LANGUAGE RankNTypes #-}

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

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

5-- given for stability of these interfaces.

6-- given for stability of these interfaces.

6module Network.Wai.Internal where

7module Network.Wai.Internal where

7

8

8import Blaze.ByteString.Builder (Builder)

9import Blaze.ByteString.Builder (Builder)

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

10import qualified Data.ByteString as B

11import qualified Data.Conduit as C

12import Data.Text (Text)

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

58 --

59 -- Since 1.4.0

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

66 }

61 }

67 deriving (Typeable)

62 deriving (Typeable)

68

63

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

92data Response

87data Response

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

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

94 | ResponseBuilder H.Status H.ResponseHeaders Builder

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

96 deriving Typeable

91 deriving Typeable

97

92

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

94+

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

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

99-- not be known.

96-- not be known.

100--

97--

wai/wai.cabal+1−2

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

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

21 , bytestring >= 0.9.1.4

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

23− , conduit >= 0.5 && < 1.1

23+ , conduit >= 1.0.8 && < 1.1

24 , network >= 2.2.1.5

25 , http-types >= 0.7

26 , text >= 0.7

27 , transformers >= 0.2.2

28 , vault >= 0.1 && < 0.4

29− , resourcet >= 0.4.7

30 Exposed-modules: Network.Wai

29 Exposed-modules: Network.Wai

31 Network.Wai.Internal

30 Network.Wai.Internal

32 ghc-options: -Wall

31 ghc-options: -Wall

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

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

32 , settingsIntercept

33 , settingsManager

34 , settingsFdCacheDuration

35− , settingsResourceTPerRequest

36 , settingsBeforeMainLoop

35 , settingsBeforeMainLoop

37 , settingsServerName

36 , settingsServerName

38 -- ** Data types

37 -- ** Data types

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

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

25import Network.Wai.Handler.Warp.Types

26import Prelude hiding (lines)

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

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

29

28

30-- FIXME come up with good values here

29-- FIXME come up with good values here

31maxTotalHeaderLength :: Int

30maxTotalHeaderLength :: Int

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

34parseRequest

33parseRequest

35 :: Connection

34 :: Connection

36 -> Timeout.Handle

35 -> Timeout.Handle

37− -> Res.InternalState

38 -> SockAddr

36 -> SockAddr

39 -> Source IO ByteString

37 -> Source IO ByteString

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

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

41−parseRequest conn timeoutHandle internalState remoteHost' src1 = do

39+parseRequest conn timeoutHandle remoteHost' src1 = do

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

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

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

41+ parseRequest' conn timeoutHandle headers' remoteHost' src2

44

42

45handleExpect :: Connection

43handleExpect :: Connection

46 -> H.HttpVersion

44 -> H.HttpVersion

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

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

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

60parseRequest' :: Connection

58parseRequest' :: Connection

61 -> Timeout.Handle

59 -> Timeout.Handle

62− -> Res.InternalState

63 -> [ByteString]

60 -> [ByteString]

64 -> SockAddr

61 -> SockAddr

65 -> ResumableSource IO ByteString -- FIXME was buffered

62 -> ResumableSource IO ByteString -- FIXME was buffered

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

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

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

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

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

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

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

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

70 let rpath

67 let rpath

71 | S.null rpath' = "/"

68 | S.null rpath' = "/"

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

116 then ChunkedBody

113 then ChunkedBody

117 else KnownLength $ fromIntegral len0

114 else KnownLength $ fromIntegral len0

118#endif

115#endif

119− , resourceInternalState = internalState

120 }, getSource)

116 }, getSource)

121

117

122{-# INLINE takeUntil #-}

118{-# INLINE takeUntil #-}

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

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

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE TupleSections #-}

4+{-# LANGUAGE RankNTypes #-}

4

5

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

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

6 sendResponse

7 sendResponse

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

35----------------------------------------------------------------

36----------------------------------------------------------------

36

37

37sendResponse :: Settings

38sendResponse :: Settings

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

39+ -> Cleaner -> Request -> Connection

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

41+ -> Response

39 -> IO Bool

42 -> IO Bool

40

43

41----------------------------------------------------------------

44----------------------------------------------------------------

42

45

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

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

44− headerAndLength >>= sendResponse'

47+ restore $ headerAndLength >>= sendResponse'

45 where

48 where

46 hs = addAccept hs0

49 hs = addAccept hs0

47 th = threadHandle cleaner

50 th = threadHandle cleaner

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

95 (isPersist,_) = infoFromRequest req

98 (isPersist,_) = infoFromRequest req

96

99

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

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

98− sendResponse settings cleaner req conn notFound

101+ sendResponse settings cleaner req conn restore notFound

99 where

102 where

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

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

101

104

102----------------------------------------------------------------

105----------------------------------------------------------------

103

106

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

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

105− | hasBody s req = liftIO $ do

108+ | hasBody s req = restore $ do

106 header <- composeHeaderBuilder settings version s hs needsChunked

109 header <- composeHeaderBuilder settings version s hs needsChunked

107 let body

110 let body

108 | needsChunked = header `mappend` chunkedTransferEncoding b

111 | needsChunked = header `mappend` chunkedTransferEncoding b

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

112 connSendAll conn bs

115 connSendAll conn bs

113 T.tickle th

116 T.tickle th

114 return isKeepAlive

117 return isKeepAlive

115− | otherwise = liftIO $ do

118+ | otherwise = restore $ do

116 composeHeader settings version s hs >>= connSendAll conn

119 composeHeader settings version s hs >>= connSendAll conn

117 T.tickle th

120 T.tickle th

118 return isPersist

121 return isPersist

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

124

127

125----------------------------------------------------------------

128----------------------------------------------------------------

126

129

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

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

128− | hasBody s req = do

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

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

132 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

131 src $$ builderToByteString =$ connSink conn th

134 src $$ builderToByteString =$ connSink conn th

132 return isKeepAlive

135 return isKeepAlive

133− | otherwise = liftIO $ do

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

134 composeHeader settings version s hs >>= connSendAll conn

137 composeHeader settings version s hs >>= connSendAll conn

135 T.tickle th

138 T.tickle th

136 return isPersist

139 return isPersist

137 where

140 where

138 th = threadHandle cleaner

141 th = threadHandle cleaner

139− body =

142+ cbody bodyFlush =

143+ if needsChunked then body $= chunk else body

144+ where

145+ body =

140− mapOutput (\x -> case x of

146+ mapOutput (\x -> case x of

141− Flush -> flush

147+ Flush -> flush

142− Chunk builder -> builder)

148+ Chunk builder -> builder)

143− bodyFlush

149+ bodyFlush

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

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

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

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

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

147 chunk :: Conduit Builder IO Builder

152 chunk :: Conduit Builder IO Builder

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

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

7import Control.Exception

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

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

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

11import Data.ByteString (ByteString)

10import Data.ByteString (ByteString)

12import qualified Data.ByteString as S

11import qualified Data.ByteString as S

13import Data.Conduit

12import Data.Conduit

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

232 -> Cleaner

231 -> Cleaner

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

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

234serveConnection timeoutHandle settings cleaner app conn remoteHost' =

233serveConnection timeoutHandle settings cleaner app conn remoteHost' =

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

234+ serveConnection'' $ connSource conn th

236 where

235 where

237− innerRunResourceT env f

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

239− { resourceInternalState = is'

240− }

241− | otherwise = f env

242 th = threadHandle cleaner

236 th = threadHandle cleaner

243

237

244− serveConnection'' fromClient internalState = do

238+ serveConnection'' fromClient = do

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

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

246 case settingsIntercept settings env of

240 case settingsIntercept settings env of

247 Nothing -> do

241 Nothing -> do

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

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

249 liftIO $ T.pause th

243 liftIO $ T.pause th

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

251− res <- app env'

252

244

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

253 liftIO $ T.resume th

250 liftIO $ T.resume th

254− sendResponse settings cleaner env' conn res

251+ sendResponse settings cleaner env conn restore res

255

252

256 -- flush the rest of the request body

253 -- flush the rest of the request body

257 requestBody env $$ CL.sinkNull

254 requestBody env $$ CL.sinkNull

258 ResumableSource fromClient' _ <- liftIO getSource

255 ResumableSource fromClient' _ <- liftIO getSource

259

256

260− when keepAlive $ serveConnection'' fromClient' internalState

257+ when keepAlive $ serveConnection'' fromClient'

261 Just intercept -> do

258 Just intercept -> do

262 liftIO $ T.pause th

259 liftIO $ T.pause th

263 ResumableSource fromClient' _ <- liftIO getSource

260 ResumableSource fromClient' _ <- liftIO getSource

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

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

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

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

30 , 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@.

36 , settingsBeforeMainLoop :: IO ()

31 , settingsBeforeMainLoop :: IO ()

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

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

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

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

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

62 , settingsIntercept = const Nothing

57 , settingsIntercept = const Nothing

63 , settingsManager = Nothing

58 , settingsManager = Nothing

64 , settingsFdCacheDuration = 10

59 , settingsFdCacheDuration = 10

65− , settingsResourceTPerRequest = True

66 , settingsBeforeMainLoop = return ()

60 , settingsBeforeMainLoop = return ()

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

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

68 }

62 }

warp/warp.cabal−1

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

44 , void

45 , wai >= 2.0 && < 2.1

46 , http-attoparsec

47− , resourcet

48 if flag(network-bytestring)

47 if flag(network-bytestring)

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

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

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

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