efe040c · typeable/wai

sources.txt+1

compare with master

unifiedsplit

@@ -9,4 +9,5 @@

9./wai-frontend-monadcgi

10./wai-websockets

11./wai-eventsource

12+./wai-conduit

12./mime-types

13./mime-types

wai-app-static/Network/Wai/Application/Static.hs+13−13

@@ -193,35 +193,35 @@ staticApp :: StaticSettings -> W.Application

193staticApp set req = staticAppPieces set (W.pathInfo req) req

194

195staticAppPieces :: StaticSettings -> [Text] -> W.Application

196−staticAppPieces _ _ req

196+staticAppPieces _ _ req sendResponse

197− | W.requestMethod req /= "GET" = return $ W.responseLBS

197+ | W.requestMethod req /= "GET" = sendResponse $ W.responseLBS

198 H.status405

199 [("Content-Type", "text/plain")]

200 "Only GET is supported"

201−staticAppPieces _ [".hidden", "folder.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")]

201+staticAppPieces _ [".hidden", "folder.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")]

202−staticAppPieces _ [".hidden", "haskell.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")]

202+staticAppPieces _ [".hidden", "haskell.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")]

203−staticAppPieces ss rawPieces req = liftIO $ do

203+staticAppPieces ss rawPieces req sendResponse = liftIO $ do

204 case toPieces rawPieces of

205 Just pieces -> checkPieces ss pieces req >>= response

206− Nothing -> return $ W.responseLBS H.status403

206+ Nothing -> sendResponse $ W.responseLBS H.status403

207 [ ("Content-Type", "text/plain")

208 ] "Forbidden"

209 where

210− response :: StaticResponse -> IO W.Response

210+ response :: StaticResponse -> IO W.ResponseReceived

211 response (FileResponse file ch) = do

212 mimetype <- ssGetMimeType ss file

213 let filesize = fileGetSize file

214 let headers = ("Content-Type", mimetype)

215 : ("Content-Length", S8.pack $ show filesize)

216 : ch

217− return $ fileToResponse file H.status200 headers

217+ sendResponse $ fileToResponse file H.status200 headers

218

219 response NotModified =

220− return $ W.responseLBS H.status304 [] ""

220+ sendResponse $ W.responseLBS H.status304 [] ""

221

222 response (SendContent mt lbs) = do

223 -- TODO: set caching headers

224− return $ W.responseLBS H.status200

224+ sendResponse $ W.responseLBS H.status200

225 [ ("Content-Type", mt)

226 -- TODO: set Content-Length

227 ] lbs

@@ -232,13 +232,13 @@ staticAppPieces ss rawPieces req = liftIO $ do

232 Just hash -> replace "etag" (Just hash) (W.queryString req)

233 Nothing -> remove "etag" (W.queryString req)

234

235− return $ W.responseLBS H.status301

235+ sendResponse $ W.responseLBS H.status301

236 [ ("Content-Type", "text/plain")

237 , ("Location", S8.append loc $ H.renderQuery True qString)

238 ] "Redirect"

239

240− response NotFound = return $ W.responseLBS H.status404

240+ response NotFound = sendResponse $ W.responseLBS H.status404

241 [ ("Content-Type", "text/plain")

242 ] "File not found"

243

244− response (WaiResponse r) = return r

244+ response (WaiResponse r) = sendResponse r

wai-app-static/wai-app-static.cabal+9−8

@@ -1,5 +1,5 @@

1name: wai-app-static

2−version: 2.0.1

2+version: 3.0.0

3license: MIT

4license-file: LICENSE

5author: Michael Snoyman <michael@snoyman.com>

@@ -24,7 +24,7 @@ Flag print

24

25library

26 build-depends: base >= 4 && < 5

27− , wai >= 2.0 && < 2.2

27+ , wai >= 3.0 && < 3.1

28 , bytestring >= 0.9.1.4

29 , http-types >= 0.7

30 , transformers >= 0.2.2

@@ -39,7 +39,6 @@ library

39 , base64-bytestring >= 0.1

40 , byteable

41 , cryptohash >= 0.11

42− , cryptohash-conduit >= 0.1.0

43 , system-filepath >= 0.4

42 , system-filepath >= 0.4

44 , system-fileio >= 0.3

43 , system-fileio >= 0.3

45 , http-date

44 , http-date

@@ -50,9 +49,11 @@ library

50 , template-haskell >= 2.7

49 , template-haskell >= 2.7

51 , zlib >= 0.5

50 , zlib >= 0.5

52 , filepath

51 , filepath

53− , wai-extra >= 2.0 && < 2.2

52+ , wai-extra >= 3.0 && < 3.1

54 , optparse-applicative >= 0.7

53 , optparse-applicative >= 0.7

55− , warp >= 2.0 && < 2.2

54+ , warp >= 3.0 && < 3.1

55+ -- Used exclusively for hashFile function

56+ , cryptohash-conduit

56

57

57 exposed-modules: Network.Wai.Application.Static

58 exposed-modules: Network.Wai.Application.Static

58 WaiAppStatic.Storage.Filesystem

59 WaiAppStatic.Storage.Filesystem

@@ -73,7 +74,7 @@ Executable warp

73 Main-is: warp-static.hs

74 Main-is: warp-static.hs

74 hs-source-dirs: app

75 hs-source-dirs: app

75 Build-depends: base >= 4 && < 5

76 Build-depends: base >= 4 && < 5

76− , wai-app-static >= 2.0 && < 2.1

77+ , wai-app-static

77 , directory >= 1.0

78 , directory >= 1.0

78 , containers >= 0.2

79 , containers >= 0.2

79 , bytestring >= 0.9.1.4

80 , bytestring >= 0.9.1.4

@@ -91,8 +92,8 @@ test-suite runtests

91 , time

92 , time

92 , old-locale

93 , old-locale

93 , http-date

94 , http-date

94− , wai-app-static >= 1.3

95+ , wai-app-static

95− , wai-test

96+ , wai-extra

96 , wai

97 , wai

97 , http-types

98 , http-types

98 , network

99 , network

wai-conduit/LICENSEnew file+20

@@ -0,0 +1,20 @@

2+

3+Permission is hereby granted, free of charge, to any person obtaining

4+a copy of this software and associated documentation files (the

5+"Software"), to deal in the Software without restriction, including

6+without limitation the rights to use, copy, modify, merge, publish,

7+distribute, sublicense, and/or sell copies of the Software, and to

8+permit persons to whom the Software is furnished to do so, subject to

9+the following conditions:

10+

11+The above copyright notice and this permission notice shall be included

12+in all copies or substantial portions of the Software.

13+

14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.

17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY

18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,

19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE

20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

wai-conduit/Network/Wai/Conduit.hsnew file+67

@@ -0,0 +1,67 @@

1+-- | A light-weight wrapper around @Network.Wai@ to provide easy conduit support.

2+module Network.Wai.Conduit

3+ ( -- * Request body

4+ sourceRequestBody

5+ -- * Response body

6+ , responseSource

7+ , responseRawSource

8+ -- * Re-export

9+ , module Network.Wai

10+ ) where

11+

12+import Network.Wai

13+import Data.Conduit

14+import Control.Monad.IO.Class (MonadIO, liftIO)

15+import Data.ByteString (ByteString)

16+import qualified Data.ByteString as S

17+import Control.Monad (unless)

18+import Network.HTTP.Types

19+import Blaze.ByteString.Builder (Builder)

20+import Data.IORef

21+import qualified Data.Conduit.List as CL

22+

23+-- | Stream the request body.

24+--

25+-- Since 3.0.0

26+sourceRequestBody :: MonadIO m => Request -> Source m ByteString

27+sourceRequestBody req =

28+ loop

29+ where

30+ go = liftIO (requestBody req)

31+

32+ loop = do

33+ bs <- go

34+ unless (S.null bs) $ do

35+ yield bs

36+ loop

37+

38+-- | Create an HTTP response out of a @Source@.

39+--

40+-- Since 3.0.0

41+responseSource :: Status -> ResponseHeaders -> Source IO (Flush Builder) -> Response

42+responseSource s hs src = responseStream s hs $ \send flush ->

43+ src $$ CL.mapM_ (\mbuilder ->

44+ case mbuilder of

45+ Chunk b -> send b

46+ Flush -> flush)

47+

48+-- | Create a raw response using a @Source@ and @Sink@ to represent the input

49+-- and output, respectively.

50+--

51+-- Since 3.0.0

52+responseRawSource :: (MonadIO m, MonadIO n)

53+ => (Source m ByteString -> Sink ByteString n () -> IO ())

54+ -> Response

55+ -> Response

56+responseRawSource app backup =

57+ responseRaw app' backup

58+ where

59+ app' recv send =

60+ app src sink

61+ where

62+ src = do

63+ bs <- liftIO recv

64+ unless (S.null bs) $ do

65+ yield bs

66+ src

67+ sink = CL.mapM_ $ liftIO . send

wai-conduit/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

wai-conduit/wai-conduit.cabalnew file+24

@@ -0,0 +1,24 @@

1+name: wai-conduit

2+version: 3.0.0

3+synopsis: conduit wrappers for WAI

4+description: Since version 3.0.0, WAI has no built-in streaming data abstraction.

5+ This library provides similar functionality to what existed in WAI 2.x.

6+homepage: https://github.com/yesodweb/wai

7+license: MIT

8+license-file: LICENSE

9+author: Michael Snoyman

10+maintainer: michael@snoyman.com

11+category: Web, Conduit

12+build-type: Simple

13+cabal-version: >=1.10

14+

15+library

16+ exposed-modules: Network.Wai.Conduit

17+ build-depends: base >= 4 && < 5

18+ , wai >= 3.0 && < 3.1

19+ , conduit

20+ , transformers

21+ , bytestring

22+ , http-types

23+ , blaze-builder

24+ default-language: Haskell2010

wai-eventsource/src/Network/Wai/EventSource.hsdeleted−67

@@ -1,67 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-|

3− A WAI adapter to the HTML5 Server-Sent Events API.

4−-}

5−module Network.Wai.EventSource (

6− ServerEvent(..),

7− eventSourceAppChan,

8− eventSourceAppSource,

9− eventSourceAppIO,

10− sourceToSource

11− ) where

12−

13−import Blaze.ByteString.Builder (Builder)

14−import Control.Concurrent.Chan (Chan, dupChan, readChan)

15−import Control.Monad.IO.Class (liftIO)

16−import Data.Conduit

17−import qualified Data.Conduit.List as CL

18−import Network.HTTP.Types (status200)

19−import Network.Wai (Application, Response, responseSource)

20−

21−import Network.Wai.EventSource.EventStream

22−

23−-- | Make a new WAI EventSource application reading events from

24−-- the given channel.

25−eventSourceAppChan :: Chan ServerEvent -> Application

26−eventSourceAppChan chan _ = do

27− chan' <- liftIO $ dupChan chan

28− return $ response chanToSource chan'

29−

30−-- | Make a new WAI EventSource application reading events from

31−-- the given source.

32−eventSourceAppSource :: Source IO ServerEvent -> Application

33−eventSourceAppSource src _ = return $ response sourceToSource src

34−

35−-- | Make a new WAI EventSource application reading events from

36−-- the given IO action.

37−eventSourceAppIO :: IO ServerEvent -> Application

38−eventSourceAppIO act _ = return $ response ioToSource act

39−

40−response :: (a -> Source IO (Flush Builder)) -> a -> Response

41−response f a = responseSource status200 [("Content-Type", "text/event-stream")] $ f a

42−

43−chanToSource :: Chan ServerEvent -> Source IO (Flush Builder)

44−chanToSource = ioToSource . readChan

45−

46−ioToSource :: IO ServerEvent -> Source IO (Flush Builder)

47−ioToSource act =

48− loop

49− where

50− loop = do

51− x <- liftIO act

52− case eventToBuilder x of

53− Nothing -> return ()

54− Just y -> do

55− yield $ Chunk y

56− yield Flush

57− loop

58−

59−-- | Convert a ServerEvent source into a Builder source of serialized

60−-- events.

61−sourceToSource :: Monad m => Source m ServerEvent -> Source m (Flush Builder)

62−sourceToSource src = src $= CL.concatMap eventToFlushBuilder

63− where

64− eventToFlushBuilder event =

65− case eventToBuilder event of

66− Nothing -> []

67− Just x -> [Chunk x, Flush]

wai-eventsource/wai-eventsource.cabal+4−21

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

1Name: wai-eventsource

2−Version: 2.0.0.2

2+Version: 3.0.0

3−Synopsis: WAI support for server-sent events

3+Synopsis: WAI support for server-sent events (deprecated)

4−Description: WAI support for server-sent events

4+Description: Since WAI 3.0, this code has been merged into wai-extra.

5License: MIT

6Author: Chris Smith, Mathias Biilmann Christensen

7Maintainer: greg@gregweber.info

@@ -13,21 +13,4 @@ homepage: http://www.yesodweb.com/book/web-application-interface

13license-file: LICENSE

14

15Library

16− Build-depends:

16+ build-depends: wai >= 3.0

17− base >= 4.3 && < 5

18− , bytestring >= 0.9.1.4

19− , blaze-builder >= 0.3 && < 0.4

20− , conduit >= 0.5 && < 1.2

21− , http-types >= 0.7

22− , wai >= 2.0 && < 2.2

23− , transformers

24−

25− ghc-options: -Wall

26− hs-source-dirs: src

27− exposed-modules:

28− Network.Wai.EventSource

29− Network.Wai.EventSource.EventStream

30−

31−source-repository head

32− type: git

33− location: git://github.com/yesodweb/wai.git

wai-extra/Network/Wai/EventSource.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-|

3+ A WAI adapter to the HTML5 Server-Sent Events API.

4+-}

5+module Network.Wai.EventSource (

6+ ServerEvent(..),

7+ eventSourceAppChan,

8+ eventSourceAppIO

9+ ) where

10+

11+import Blaze.ByteString.Builder (Builder)

12+import Data.Function (fix)

13+import Control.Concurrent.Chan (Chan, dupChan, readChan)

14+import Control.Monad.IO.Class (liftIO)

15+import Network.HTTP.Types (status200)

16+import Network.Wai (Application, Response, responseStream)

17+

18+import Network.Wai.EventSource.EventStream

19+

20+-- | Make a new WAI EventSource application reading events from

21+-- the given channel.

22+eventSourceAppChan :: Chan ServerEvent -> Application

23+eventSourceAppChan chan req sendResponse = do

24+ chan' <- liftIO $ dupChan chan

25+ eventSourceAppIO (readChan chan') req sendResponse

26+

27+-- | Make a new WAI EventSource application reading events from

28+-- the given IO action.

29+eventSourceAppIO :: IO ServerEvent -> Application

30+eventSourceAppIO src _ sendResponse =

31+ sendResponse $ responseStream

32+ status200

33+ [("Content-Type", "text/event-stream")]

34+ $ \sendChunk flush -> fix $ \loop -> do

35+ se <- src

36+ case eventToBuilder se of

37+ Nothing -> return ()

38+ Just b -> sendChunk b >> flush >> loop

wai-eventsource/src/Network/Wai/EventSource/EventStream.hs → wai-extra/Network/Wai/EventSource/EventStream.hsrenamed

The content is the same.

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

@@ -13,8 +13,8 @@ module Network.Wai.Handler.CGI

13import Network.Wai

14import Network.Wai.Internal

15import Network.Socket (getAddrInfo, addrAddress)

16+import Data.IORef

16import Data.Maybe (fromMaybe)

17import Data.Maybe (fromMaybe)

17−import Control.Exception (mask)

18import qualified Data.ByteString.Char8 as B

19import qualified Data.ByteString.Lazy as L

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

@@ -22,17 +22,17 @@ import Data.Char (toLower)

22import qualified System.IO

23import qualified Data.String as String

24import Data.Monoid (mconcat, mempty)

25−import Blaze.ByteString.Builder (fromByteString, toLazyByteString)

25+import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush)

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

27−import Data.Conduit.Blaze (builderToByteStringFlush)

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

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

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

30import System.IO (Handle)

28import System.IO (Handle)

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

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

32import qualified Network.HTTP.Types as H

30import qualified Network.HTTP.Types as H

33import qualified Data.CaseInsensitive as CI

31import qualified Data.CaseInsensitive as CI

34import Data.Monoid (mappend)

32import Data.Monoid (mappend)

35−import Data.Conduit

33+import qualified Data.Streaming.Blaze as Blaze

34+import Data.Function (fix)

35+import Control.Monad (unless, void)

36

37#if WINDOWS

38import System.Environment (getEnvironment)

@@ -76,7 +76,7 @@ runSendfile sf app = do

76-- stick with 'run' or 'runSendfile'.

77runGeneric

78 :: [(String, String)] -- ^ all variables

79− -> (Int -> Source IO B.ByteString) -- ^ responseBody of input

79+ -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input

80 -> (B.ByteString -> IO ()) -- ^ destination for output

81 -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?

82 -> Application

@@ -98,40 +98,48 @@ runGeneric vars inputH outputH xsendfile app = do

98 "https" -> True

99 _ -> False

100 addrs <- getAddrInfo Nothing (Just remoteHost') Nothing

101+ requestBody' <- inputH contentLength

101 let addr =

102 let addr =

102 case addrs of

103 case addrs of

103 a:_ -> addrAddress a

104 a:_ -> addrAddress a

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

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

105− mask $ \restore -> do

106− let reqHeaders = map (cleanupVarName *** B.pack) vars

106+ reqHeaders = map (cleanupVarName *** B.pack) vars

107− env = Request

107+ env = Request

108− { requestMethod = rmethod

108+ { requestMethod = rmethod

109− , rawPathInfo = B.pack pinfo

109+ , rawPathInfo = B.pack pinfo

110− , pathInfo = H.decodePathSegments $ B.pack pinfo

110+ , pathInfo = H.decodePathSegments $ B.pack pinfo

111− , rawQueryString = B.pack qstring

111+ , rawQueryString = B.pack qstring

112− , queryString = H.parseQuery $ B.pack qstring

112+ , queryString = H.parseQuery $ B.pack qstring

113− , requestHeaders = reqHeaders

113+ , requestHeaders = reqHeaders

114− , isSecure = isSecure'

114+ , isSecure = isSecure'

115− , remoteHost = addr

115+ , remoteHost = addr

116− , httpVersion = H.http11 -- FIXME

116+ , httpVersion = H.http11 -- FIXME

117− , requestBody = inputH contentLength

117+ , requestBody = requestBody'

118− , vault = mempty

118+ , vault = mempty

119− , requestBodyLength = KnownLength $ fromIntegral contentLength

119+ , requestBodyLength = KnownLength $ fromIntegral contentLength

120− , requestHeaderHost = lookup "host" reqHeaders

120+ , requestHeaderHost = lookup "host" reqHeaders

121− , requestHeaderRange = lookup "range" reqHeaders

121+ , requestHeaderRange = lookup "range" reqHeaders

122− }

122+ }

123− -- FIXME worry about exception?

123+ void $ app env $ \res ->

124− res <- restore $ app env

125 case (xsendfile, res) of

124 case (xsendfile, res) of

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

125+ (Just sf, ResponseFile s hs fp Nothing) -> do

127− restore $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp

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

127+ return ResponseReceived

128 _ -> do

129− let (s, hs, wb) = responseToSource res

129+ let (s, hs, wb) = responseToStream res

130+ (blazeRecv, blazeFinish) <- Blaze.newBlazeRecv Blaze.defaultStrategy

130− wb $ \b ->

131+ wb $ \b -> do

131− let src = do

132+ let sendBuilder builder = do

133+ popper <- blazeRecv builder

134+ fix $ \loop -> do

135+ bs <- popper

136+ unless (B.null bs) $ do

137+ outputH bs

138+ loop

132− yield (Chunk $ headers s hs `mappend` fromChar '\n')

139+ sendBuilder $ headers s hs `mappend` fromChar '\n'

133− b

140+ b sendBuilder (sendBuilder flush)

134− in src $$ builderSink

141+ blazeFinish >>= maybe (return ()) outputH

142+ return ResponseReceived

135 where

143 where

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

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

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

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

@@ -153,13 +161,6 @@ runGeneric vars inputH outputH xsendfile app = do

153 , fromByteString sf

161 , fromByteString sf

154 , fromByteString " not supported"

162 , fromByteString " not supported"

155 ]

163 ]

156− bsSink = await >>= maybe (return ()) push

157− push (Chunk bs) = do

158− liftIO $ outputH bs

159− bsSink

160− -- FIXME actually flush?

161− push Flush = bsSink

162− builderSink = builderToByteStringFlush =$ bsSink

163 fixHeaders h =

164 fixHeaders h =

164 case lookup "content-type" h of

165 case lookup "content-type" h of

165 Nothing -> ("Content-Type", "text/html; charset=utf-8") : h

166 Nothing -> ("Content-Type", "text/html; charset=utf-8") : h

@@ -178,19 +179,19 @@ cleanupVarName s =

178 helper' (x:rest) = toLower x : helper' rest

179 helper' (x:rest) = toLower x : helper' rest

179 helper' [] = []

180 helper' [] = []

180

181

181−requestBodyHandle :: Handle -> Int -> Source IO B.ByteString

182+requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString)

182requestBodyHandle h = requestBodyFunc $ \i -> do

183requestBodyHandle h = requestBodyFunc $ \i -> do

183 bs <- B.hGet h i

184 bs <- B.hGet h i

184 return $ if B.null bs then Nothing else Just bs

185 return $ if B.null bs then Nothing else Just bs

185

186

186−requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source IO B.ByteString

187+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString)

187−requestBodyFunc get =

188+requestBodyFunc get count0 = do

188− loop

189+ ref <- newIORef count0

189− where

190+ return $ do

190− loop 0 = return ()

191+ count <- readIORef ref

191− loop count = do

192+ if count <= 0

193+ then return B.empty

194+ else do

192− mbs <- liftIO $ get $ min count defaultChunkSize

195+ mbs <- get $ min count defaultChunkSize

193− let count' = count - maybe 0 B.length mbs

196+ writeIORef ref $ count - maybe 0 B.length mbs

194− case mbs of

197+ return $ fromMaybe B.empty mbs

195− Nothing -> return ()

196− Just bs -> yield bs >> loop count'

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

@@ -4,17 +4,12 @@

4module Network.Wai.Middleware.Autohead (autohead) where

5

6import Network.Wai

7−import Network.Wai.Internal

8import Data.Monoid (mempty)

7import Data.Monoid (mempty)

9

8

10autohead :: Middleware

9autohead :: Middleware

11−autohead app req

10+autohead app req sendResponse

12− | requestMethod req == "HEAD" = do

13− res <- app req { requestMethod = "GET" }

11+ | requestMethod req == "HEAD" = app req { requestMethod = "GET" } $ \res -> do

14− let go (ResponseFile s hs _ _) = ResponseBuilder s hs mempty

12+ let (s, hs, _) = responseToStream res

15− go (ResponseBuilder s hs _) = ResponseBuilder s hs mempty

13+ sendResponse $ responseBuilder s hs mempty

16− go (ResponseSource s hs _) = ResponseBuilder s hs mempty

17− go (ResponseRaw raw r) = ResponseRaw raw (go r)

18− return (go res)

19− | otherwise = app req

14+ | otherwise = app req sendResponse

20

15

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

@@ -14,10 +14,10 @@ cleanPath :: ([Text] -> Either B.ByteString [Text])

14 -> B.ByteString

15 -> ([Text] -> Application)

16 -> Application

17−cleanPath splitter prefix app env =

17+cleanPath splitter prefix app env sendResponse =

18 case splitter $ pathInfo env of

19− Right pieces -> app pieces env

19+ Right pieces -> app pieces env sendResponse

20− Left p -> return

20+ Left p -> sendResponse

21 $ responseLBS status301

22 [("Location", mconcat [prefix, p, suffix])]

23 $ L.empty

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

@@ -28,20 +28,23 @@ import Network.Wai

28import Data.Maybe (fromMaybe, isJust)

29import qualified Data.ByteString.Char8 as S8

30import qualified Data.ByteString as S

31−import Data.Default

31+import Data.Default.Class

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

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

34import Control.Monad.Trans.Resource (runResourceT)

35import System.Directory (doesFileExist, createDirectoryIfMissing)

36−import qualified Data.Conduit as C

37−import qualified Data.Conduit.Zlib as CZ

38−import qualified Data.Conduit.Binary as CB

39−import qualified Data.Conduit.List as CL

40−import Data.Conduit.Blaze (builderToByteStringFlush)

41import Blaze.ByteString.Builder (fromByteString)

36import Blaze.ByteString.Builder (fromByteString)

42import Control.Exception (try, SomeException)

37import Control.Exception (try, SomeException)

43import qualified Data.Set as Set

38import qualified Data.Set as Set

44import Network.Wai.Internal

39import Network.Wai.Internal

40+import qualified Data.Streaming.Blaze as B

41+import qualified Data.Streaming.Zlib as Z

42+import qualified Blaze.ByteString.Builder as Blaze

43+import Control.Monad (unless)

44+import Data.Function (fix)

45+import Control.Exception (throwIO)

46+import qualified System.IO as IO

47+import Data.ByteString.Lazy.Internal (defaultChunkSize)

45

48

46data GzipSettings = GzipSettings

49data GzipSettings = GzipSettings

47 { gzipFiles :: GzipFiles

50 { gzipFiles :: GzipFiles

@@ -74,20 +77,19 @@ defaultCheckMime bs =

74--

77--

75-- * Only compress if the response is above a certain size.

78-- * Only compress if the response is above a certain size.

76gzip :: GzipSettings -> Middleware

79gzip :: GzipSettings -> Middleware

77−gzip set app env = do

80+gzip set app env sendResponse = app env $ \res ->

78− res <- app env

79 case res of

81 case res of

80− ResponseFile{} | gzipFiles set == GzipIgnore -> return res

82+ ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res

81 _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)

83 _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)

82 then

84 then

83 case (res, gzipFiles set) of

85 case (res, gzipFiles set) of

84 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->

86 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->

85 case lookup "content-type" hs of

87 case lookup "content-type" hs of

86 Just m

88 Just m

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

89+ | gzipCheckMime set m -> compressFile s hs file cache sendResponse

88− _ -> return res

90+ _ -> sendResponse res

89− _ -> return $ compressE set res

91+ _ -> compressE set res sendResponse

90− else return res

92+ else sendResponse res

91 where

93 where

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

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

93 `fmap` lookup "Accept-Encoding" (requestHeaders env)

95 `fmap` lookup "Accept-Encoding" (requestHeaders env)

@@ -95,22 +97,38 @@ gzip set app env = do

95 isMSIE6 = "MSIE 6" `S.isInfixOf` ua

97 isMSIE6 = "MSIE 6" `S.isInfixOf` ua

96 isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res

98 isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res

97

99

98−compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response

100+compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a

99−compressFile s hs file cache = do

101+compressFile s hs file cache sendResponse = do

100 e <- doesFileExist tmpfile

102 e <- doesFileExist tmpfile

101 if e

103 if e

102 then onSucc

104 then onSucc

103 else do

105 else do

104 createDirectoryIfMissing True cache

106 createDirectoryIfMissing True cache

105− x <-

107+ x <- try $

106− try $ runResourceT $ CB.sourceFile file

108+ IO.withBinaryFile file IO.ReadMode $ \inH ->

107− C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile

109+ IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do

110+ deflate <- Z.initDeflate 7 $ Z.WindowBits 31

111+ -- FIXME this code should write to a temporary file, then

112+ -- rename to the final file

113+ let goPopper popper = fix $ \loop -> do

114+ res <- popper

115+ case res of

116+ Z.PRDone -> return ()

117+ Z.PRNext bs -> do

118+ S.hPut outH bs

119+ loop

120+ Z.PRError e -> throwIO e

121+ fix $ \loop -> do

122+ bs <- S.hGetSome inH defaultChunkSize

123+ unless (S.null bs) $ do

124+ Z.feedDeflate deflate bs >>= goPopper

125+ loop

126+ goPopper $ Z.finishDeflate deflate

108− either onErr (const onSucc) x

127+ either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!

109 where

128 where

110− onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing

129+ onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing

111

130

112− onErr :: SomeException -> IO Response

113− onErr = const $ return $ ResponseFile s hs file Nothing -- FIXME log the error message

131+ onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message

114

132

115 tmpfile = cache ++ '/' : map safe file

133 tmpfile = cache ++ '/' : map safe file

116 safe c

134 safe c

@@ -123,18 +141,42 @@ compressFile s hs file cache = do

123

141

124compressE :: GzipSettings

142compressE :: GzipSettings

125 -> Response

143 -> Response

126− -> Response

144+ -> (Response -> IO a)

145+ -> IO a

127−compressE set res =

146+compressE set res sendResponse =

128 case lookup "content-type" hs of

147 case lookup "content-type" hs of

129 Just m | gzipCheckMime set m ->

148 Just m | gzipCheckMime set m ->

130 let hs' = fixHeaders hs

149 let hs' = fixHeaders hs

131− in ResponseSource s hs' $ \f -> wb $ \b -> f $

150+ in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do

132− b C.$= builderToByteStringFlush

151+ (blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy

133− C.$= CZ.compressFlush 1 (CZ.WindowBits 31)

152+ deflate <- Z.initDeflate 1 (Z.WindowBits 31)

153+ let sendBuilder builder = do

154+ popper <- blazeRecv builder

155+ fix $ \loop -> do

156+ bs <- popper

157+ unless (S.null bs) $ do

158+ sendBS bs

159+ loop

160+ sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper

161+ flushBuilder = do

162+ sendBuilder Blaze.flush

163+ deflatePopper $ Z.flushDeflate deflate

164+ flush

165+ deflatePopper popper = fix $ \loop -> do

166+ res <- popper

167+ case res of

168+ Z.PRDone -> return ()

169+ Z.PRNext bs' -> do

134− C.$= CL.map (fmap fromByteString)

170+ sendChunk $ fromByteString bs'

171+ loop

172+ Z.PRError e -> throwIO e

173+

174+ body sendBuilder flushBuilder

175+ sendBuilder Blaze.flush

176+ deflatePopper $ Z.finishDeflate deflate

135− _ -> res

177+ _ -> sendResponse res

136 where

178 where

137− (s, hs, wb) = responseToSource res

179+ (s, hs, wb) = responseToStream res

138

180

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

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

140-- different length after gzip compression.

182-- different length after gzip compression.

wai-extra/Network/Wai/Middleware/HttpAuth.hs+4−4

@@ -32,12 +32,12 @@ type CheckCreds = ByteString

32basicAuth :: CheckCreds

33 -> AuthSettings

34 -> Middleware

35−basicAuth checkCreds AuthSettings {..} app req = do

35+basicAuth checkCreds AuthSettings {..} app req sendResponse = do

36 isProtected <- authIsProtected req

37 allowed <- if isProtected then check else return True

38 if allowed

39− then app req

39+ then app req sendResponse

40− else authOnNoAuth authRealm req

40+ else authOnNoAuth authRealm req sendResponse

41 where

42 check =

43 case lookup "Authorization" $ requestHeaders req of

@@ -83,7 +83,7 @@ data AuthSettings = AuthSettings

83instance IsString AuthSettings where

84 fromString s = AuthSettings

85 { authRealm = fromString s

86− , authOnNoAuth = \realm _req -> return $ responseLBS

86+ , authOnNoAuth = \realm _req f -> f $ responseLBS

87 status401

88 [ ("Content-Type", "text/plain")

89 , ("WWW-Authenticate", S.concat

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

@@ -25,7 +25,6 @@ import Data.Monoid (mappend)

25import Control.Monad (join)

26import Data.Maybe (fromMaybe)

27import qualified Data.ByteString as S

28−import qualified Data.Conduit as C

29import Data.CaseInsensitive (CI)

28import Data.CaseInsensitive (CI)

30import Network.HTTP.Types (Status)

29import Network.HTTP.Types (Status)

31

30

@@ -37,7 +36,7 @@ import Network.HTTP.Types (Status)

37-- having a content type of \"text\/javascript\" and calling the specified

36-- having a content type of \"text\/javascript\" and calling the specified

38-- callback function.

37-- callback function.

39jsonp :: Middleware

38jsonp :: Middleware

40−jsonp app env = do

39+jsonp app env sendResponse = do

41 let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env

40 let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env

42 let callback :: Maybe B8.ByteString

41 let callback :: Maybe B8.ByteString

43 callback =

42 callback =

@@ -52,15 +51,15 @@ jsonp app env = do

52 "application/json"

51 "application/json"

53 $ requestHeaders env

52 $ requestHeaders env

54 }

53 }

55− res <- app env'

54+ app env' $ \res ->

56− return $ case callback of

55+ case callback of

57− Nothing -> res

56+ Nothing -> sendResponse res

58− Just c -> go c res

57+ Just c -> go c res

59 where

58 where

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

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

61− case checkJSON hs of

60+ sendResponse $ case checkJSON hs of

62 Nothing -> r

61 Nothing -> r

63− Just hs' -> ResponseBuilder s hs' $

62+ Just hs' -> responseBuilder s hs' $

64 copyByteString c

63 copyByteString c

65 `mappend` fromChar '('

64 `mappend` fromChar '('

66 `mappend` b

65 `mappend` b

@@ -68,9 +67,9 @@ jsonp app env = do

68 go c r =

67 go c r =

69 case checkJSON hs of

68 case checkJSON hs of

70 Just hs' -> addCallback c s hs' wb

69 Just hs' -> addCallback c s hs' wb

71− Nothing -> r

70+ Nothing -> sendResponse r

72 where

71 where

73− (s, hs, wb) = responseToSource r

72+ (s, hs, wb) = responseToStream r

74

73

75 checkJSON hs =

74 checkJSON hs =

76 case lookup "Content-Type" hs of

75 case lookup "Content-Type" hs of

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

80 _ -> Nothing

79 _ -> Nothing

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

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

82

81

83− addCallback :: ByteString

84− -> Status

85− -> [(CI ByteString, ByteString)]

86− -> (forall b. WithSource IO (C.Flush Builder) b)

87− -> Response

88 addCallback cb s hs wb =

82 addCallback cb s hs wb =

89− ResponseSource s hs $ \f -> wb $ \b -> f $

83+ wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do

90− C.yield (C.Chunk $ copyByteString cb `mappend` fromChar '(')

84+ sendChunk $ copyByteString cb `mappend` fromChar '('

91− `mappend` b

85+ body sendChunk flush

92− `mappend` C.yield (C.Chunk $ fromChar ')')

86+ sendChunk $ fromChar ')'

93

87

94changeVal :: Eq a

88changeVal :: Eq a

95 => a

89 => a

wai-extra/Network/Wai/Middleware/MethodOverridePost.hs+13−10

@@ -10,9 +10,9 @@ module Network.Wai.Middleware.MethodOverridePost

10

11import Network.Wai

12import Network.HTTP.Types (parseQuery)

13−import Data.Monoid (mconcat)

13+import Data.Monoid (mconcat, mempty)

14−import Data.Conduit.Lazy (lazyConsume)

14+import Data.IORef

15−import Data.Conduit.List (sourceList)

15+import Data.ByteString.Lazy (toChunks)

16

17-- | Allows overriding of the HTTP request method via the _method post string parameter.

18--

@@ -26,13 +26,16 @@ import Data.Conduit.List (sourceList)

26-- * This middleware only applies when the initial request method is POST.

27--

28methodOverridePost :: Middleware

29+methodOverridePost app req send =

29−methodOverridePost app req = case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of

30+ case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of

30− ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app

31+ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send

31− _ -> app req

32+ _ -> app req send

32

33

33setPost :: Request -> IO Request

34setPost :: Request -> IO Request

34setPost req = do

35setPost req = do

35− body <- lazyConsume (requestBody req)

36+ body <- (mconcat . toChunks) `fmap` lazyRequestBody req

37+ ref <- newIORef body

38+ let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)

36− case parseQuery (mconcat body) of

39+ case parseQuery body of

37− (("_method", Just newmethod):_) -> return $ req {requestBody = sourceList body, requestMethod = newmethod}

40+ (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod}

38− _ -> return $ req {requestBody = sourceList body}

41+ _ -> return $ req {requestBody = rb}

wai-extra/Network/Wai/Middleware/RequestLogger.hs+36−34

@@ -34,14 +34,11 @@ import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, ge

34import qualified Data.ByteString.Lazy as LBS

35import qualified Data.ByteString.Char8 as S8

36

37−import qualified Data.Conduit as C

38−import qualified Data.Conduit.List as CL

39−

40import System.Console.ANSI

37import System.Console.ANSI

41import Data.IORef.Lifted

38import Data.IORef.Lifted

42import System.IO.Unsafe

39import System.IO.Unsafe

43

40

44−import Data.Default (Default (def))

41+import Data.Default.Class (Default (def))

45import Network.Wai.Logger

42import Network.Wai.Logger

46import Network.Wai.Middleware.RequestLogger.Internal

43import Network.Wai.Middleware.RequestLogger.Internal

47

44

@@ -96,23 +93,21 @@ mkRequestLogger RequestLoggerSettings{..} = do

96 return $ customMiddleware callback getdate formatter

93 return $ customMiddleware callback getdate formatter

97

94

98apacheMiddleware :: ApacheLoggerActions -> Middleware

95apacheMiddleware :: ApacheLoggerActions -> Middleware

99−apacheMiddleware ala app req = do

96+apacheMiddleware ala app req sendResponse = app req $ \res -> do

100− res <- app req

101 let msize = lookup "content-length" (responseHeaders res) >>= readInt'

97 let msize = lookup "content-length" (responseHeaders res) >>= readInt'

102 readInt' bs =

98 readInt' bs =

103 case S8.readInteger bs of

99 case S8.readInteger bs of

104 Just (i, "") -> Just i

100 Just (i, "") -> Just i

105 _ -> Nothing

101 _ -> Nothing

106 apacheLogger ala req (responseStatus res) msize

102 apacheLogger ala req (responseStatus res) msize

107− return res

103+ sendResponse res

108

104

109customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware

105customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware

110−customMiddleware cb getdate formatter app req = do

106+customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do

111− res <- app req

112 date <- liftIO getdate

107 date <- liftIO getdate

113 -- We use Nothing for the response size since we generally don't know it

108 -- We use Nothing for the response size since we generally don't know it

114 liftIO $ cb $ formatter date req (responseStatus res) Nothing

109 liftIO $ cb $ formatter date req (responseStatus res) Nothing

115− return res

110+ sendResponse res

116

111

117-- | Production request logger middleware.

112-- | Production request logger middleware.

118-- Implemented on top of "logCallback", but prints to 'stdout'

113-- Implemented on top of "logCallback", but prints to 'stdout'

@@ -186,13 +181,18 @@ ansiColor color bs = [

186detailedMiddleware' :: Callback

181detailedMiddleware' :: Callback

187 -> IO (BS.ByteString -> [BS.ByteString])

182 -> IO (BS.ByteString -> [BS.ByteString])

188 -> Middleware

183 -> Middleware

189−detailedMiddleware' cb getAddColor app req = do

184+detailedMiddleware' cb getAddColor app req sendResponse = do

190 let mlen = lookup "content-length" (requestHeaders req) >>= readInt

185 let mlen = lookup "content-length" (requestHeaders req) >>= readInt

191 (req', body) <-

186 (req', body) <-

192 case mlen of

187 case mlen of

193 -- log the request body if it is small

188 -- log the request body if it is small

194 Just len | len <= 2048 -> do

189 Just len | len <= 2048 -> do

190+ let loop front = do

195− body <- requestBody req C.$$ CL.consume

191+ bs <- requestBody req

192+ if S8.null bs

193+ then return $ front []

194+ else loop $ front . (bs:)

195+ body <- loop id

196 -- logging the body here consumes it, so fill it back up

197 -- obviously not efficient, but this is the development logger

198 --

@@ -204,14 +204,10 @@ detailedMiddleware' cb getAddColor app req = do

204 -- implementation ensures that each chunk is only returned

205 -- once.

206 ichunks <- newIORef body

207− let rbody = do

207+ let rbody = atomicModifyIORef ichunks $ \chunks ->

208− chunks <- readIORef ichunks

209 case chunks of

208 case chunks of

210− [] -> return ()

209+ [] -> ([], S8.empty)

211− x:xs -> do

210+ x:y -> (y, x)

212− writeIORef ichunks xs

213− C.yield x

214− rbody

215 let req' = req { requestBody = rbody }

211 let req' = req { requestBody = rbody }

216 return (req', body)

212 return (req', body)

217 _ -> return (req, [])

213 _ -> return (req, [])

@@ -237,20 +233,20 @@ detailedMiddleware' cb getAddColor app req = do

237 , "\n"

233 , "\n"

238 ]

234 ]

239

235

240− rsp <- app req'

236+ app req' $ \rsp -> do

241−

237+

242− -- log the status of the response

238+ -- log the status of the response

243− -- this is color coordinated with the request logging

239+ -- this is color coordinated with the request logging

244− -- also includes the request path to connect it to the request

240+ -- also includes the request path to connect it to the request

245− liftIO $ cb $ mconcat $ map toLogStr $

241+ liftIO $ cb $ mconcat $ map toLogStr $

246− addColor "Status: " ++ statusBS rsp ++

242+ addColor "Status: " ++ statusBS rsp ++

247− [ " "

243+ [ " "

248− , msgBS rsp

244+ , msgBS rsp

249− , ". "

245+ , ". "

250− , rawPathInfo req -- if you need help matching the 2 logging statements

246+ , rawPathInfo req -- if you need help matching the 2 logging statements

251− , "\n"

247+ , "\n"

252− ]

248+ ]

253− return rsp

249+ sendResponse rsp

254 where

250 where

255 paramsToBS prefix params =

251 paramsToBS prefix params =

256 if null params then ""

252 if null params then ""

@@ -259,7 +255,13 @@ detailedMiddleware' cb getAddColor app req = do

259 allPostParams body =

255 allPostParams body =

260 case getRequestBodyType req of

256 case getRequestBodyType req of

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

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

258+ Just rbt -> do

259+ ichunks <- newIORef body

260+ let rbody = atomicModifyIORef ichunks $ \chunks ->

261+ case chunks of

262+ [] -> ([], S8.empty)

263+ x:y -> (y, x)

262− Just rbt -> CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt

264+ sinkRequestBody lbsBackEnd rbt rbody

263

265

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

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

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

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

wai-extra/Network/Wai/Middleware/Rewrite.hs+2−2

@@ -13,10 +13,10 @@ import Network.HTTP.Types as H

13

14-- | rewrite based on your own conversion rules

15rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware

16−rewrite convert app req = do

16+rewrite convert app req sendResponse = do

17 newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)

18 let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo

19− app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo }

19+ app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } sendResponse

20

21-- | rewrite based on your own conversion rules

22-- Example convert function:

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

@@ -20,10 +20,10 @@ redirectWWW home =

20 redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)

21

22redirectIf :: Text -> (Request -> Bool) -> Application -> Application

23−redirectIf home cond app req =

23+redirectIf home cond app req sendResponse =

24 if cond req

25− then return $ redirectTo $ TE.encodeUtf8 home

25+ then sendResponse $ redirectTo $ TE.encodeUtf8 home

26− else app req

26+ else app req sendResponse

27

28redirectTo :: BS.ByteString -> Response

29redirectTo location = responseLBS H.status301

wai-extra/Network/Wai/Parse.hs+164−107

@@ -12,7 +12,6 @@ module Network.Wai.Parse

12 , RequestBodyType (..)

13 , getRequestBodyType

14 , sinkRequestBody

15− , conduitRequestBody

16 , BackEnd

15 , BackEnd

17 , lbsBackEnd

16 , lbsBackEnd

18 , tempFileBackEnd

17 , tempFileBackEnd

@@ -38,22 +37,14 @@ import qualified Data.ByteString.Char8 as S8

38import Data.Word (Word8)

37import Data.Word (Word8)

39import Data.Maybe (fromMaybe)

38import Data.Maybe (fromMaybe)

40import Data.List (sortBy)

39import Data.List (sortBy)

41−import Data.Function (on)

40+import Data.Function (on, fix)

42import System.Directory (removeFile, getTemporaryDirectory)

41import System.Directory (removeFile, getTemporaryDirectory)

43import System.IO (hClose, openBinaryTempFile)

42import System.IO (hClose, openBinaryTempFile)

44import Network.Wai

43import Network.Wai

45−import Data.Conduit

46−import Data.Conduit.Internal ()

47−import qualified Data.Conduit.List as CL

48−import qualified Data.Conduit.Binary as CB

49−import Control.Monad.IO.Class (liftIO)

50import qualified Network.HTTP.Types as H

44import qualified Network.HTTP.Types as H

51−import Data.Either (partitionEithers)

52import Control.Monad (when, unless)

45import Control.Monad (when, unless)

53−import Control.Monad.Trans.Class (lift)

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

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

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

47+import Data.IORef

56−import Data.Void (Void)

57

48

58breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

49breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

59breakDiscard w s =

50breakDiscard w s =

@@ -85,15 +76,22 @@ parseHttpAccept = map fst

85 _ -> 1.0

76 _ -> 1.0

86

77

87-- | Store uploaded files in memory

78-- | Store uploaded files in memory

88−lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteString

79+lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString

89−lbsBackEnd _ _ = fmap L.fromChunks CL.consume

80+lbsBackEnd _ _ popper =

81+ loop id

82+ where

83+ loop front = do

84+ bs <- popper

85+ if S.null bs

86+ then return $ L.fromChunks $ front []

87+ else loop $ front . (bs:)

90

88

91-- | Save uploaded files on disk as temporary files

89-- | Save uploaded files on disk as temporary files

92--

90--

93-- Note: starting with version 2.0, removal of temp files is registered with

91-- Note: starting with version 2.0, removal of temp files is registered with

94-- the provided @InternalState@. It is the responsibility of the caller to

92-- the provided @InternalState@. It is the responsibility of the caller to

95-- ensure that this @InternalState@ gets cleaned up.

93-- ensure that this @InternalState@ gets cleaned up.

96−tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> Sink S.ByteString IO FilePath

94+tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath

97tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

95tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

98

96

99-- | Same as 'tempFileSink', but use configurable temp folders and patterns.

97-- | Same as 'tempFileSink', but use configurable temp folders and patterns.

@@ -102,14 +100,19 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory

102 -> InternalState

100 -> InternalState

103 -> ignored1

101 -> ignored1

104 -> ignored2

102 -> ignored2

105− -> Sink S.ByteString IO FilePath

103+ -> IO S.ByteString

104+ -> IO FilePath

106−tempFileBackEndOpts getTmpDir pattern internalState _ _ = do

105+tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do

107 (key, (fp, h)) <- flip runInternalState internalState $ allocate (do

106 (key, (fp, h)) <- flip runInternalState internalState $ allocate (do

108 tempDir <- getTmpDir

107 tempDir <- getTmpDir

109 openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)

108 openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)

110 _ <- runInternalState (register $ removeFile fp) internalState

109 _ <- runInternalState (register $ removeFile fp) internalState

111− CB.sinkHandle h

110+ fix $ \loop -> do

111+ bs <- popper

112+ unless (S.null bs) $ do

113+ S.hPut h bs

114+ loop

112− lift $ release key

115+ release key

113 return fp

116 return fp

114

117

115-- | Information on an uploaded file.

118-- | Information on an uploaded file.

@@ -126,11 +129,12 @@ type Param = (S.ByteString, S.ByteString)

126-- | Post parameter name and associated file information.

129-- | Post parameter name and associated file information.

127type File y = (S.ByteString, FileInfo y)

130type File y = (S.ByteString, FileInfo y)

128

131

129−-- | A file uploading backend. Takes the parameter name, file name, and content

132+-- | A file uploading backend. Takes the parameter name, file name, and a

130−-- type, and returns a `Sink` for storing the contents.

133+-- stream of data.

131type BackEnd a = S.ByteString -- ^ parameter name

134type BackEnd a = S.ByteString -- ^ parameter name

132 -> FileInfo ()

135 -> FileInfo ()

133− -> Sink S.ByteString IO a

136+ -> IO S.ByteString

137+ -> IO a

134

138

135data RequestBodyType = UrlEncoded | Multipart S.ByteString

139data RequestBodyType = UrlEncoded | Multipart S.ByteString

136

140

@@ -173,60 +177,99 @@ parseRequestBody :: BackEnd y

173parseRequestBody s r =

177parseRequestBody s r =

174 case getRequestBodyType r of

178 case getRequestBodyType r of

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

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

176− Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume

180+ Just rbt -> sinkRequestBody s rbt (requestBody r)

177

181

178sinkRequestBody :: BackEnd y

182sinkRequestBody :: BackEnd y

179 -> RequestBodyType

183 -> RequestBodyType

184+ -> IO S.ByteString

180− -> Sink S.ByteString IO ([Param], [File y])

185+ -> IO ([Param], [File y])

186+sinkRequestBody s r body = do

187+ ref <- newIORef (id, id)

188+ let add x = atomicModifyIORef ref $ \(y, z) ->

189+ case x of

190+ Left y' -> ((y . (y':), z), ())

191+ Right z' -> ((y, z . (z':)), ())

181−sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume

192+ conduitRequestBody s r body add

193+ (x, y) <- readIORef ref

194+ return (x [], y [])

182

195

183conduitRequestBody :: BackEnd y

196conduitRequestBody :: BackEnd y

184 -> RequestBodyType

197 -> RequestBodyType

198+ -> IO S.ByteString

185− -> Conduit S.ByteString IO (Either Param (File y))

199+ -> (Either Param (File y) -> IO ())

200+ -> IO ()

186−conduitRequestBody _ UrlEncoded = do

201+conduitRequestBody _ UrlEncoded rbody add = do

187 -- NOTE: in general, url-encoded data will be in a single chunk.

202 -- NOTE: in general, url-encoded data will be in a single chunk.

188 -- Therefore, I'm optimizing for the usual case by sticking with

203 -- Therefore, I'm optimizing for the usual case by sticking with

189 -- strict byte strings here.

204 -- strict byte strings here.

190− bs <- CL.consume

205+ let loop front = do

206+ bs <- rbody

207+ if S.null bs

208+ then return $ S.concat $ front []

209+ else loop $ front . (bs:)

210+ bs <- loop id

191− mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs

211+ mapM_ (add . Left) $ H.parseSimpleQuery bs

192−conduitRequestBody backend (Multipart bound) =

212+conduitRequestBody backend (Multipart bound) rbody add =

193− parsePieces backend $ S8.pack "--" `S.append` bound

213+ parsePieces backend (S8.pack "--" `S.append` bound) rbody add

194−

214+

195−takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)

215+takeLine :: Source -> IO (Maybe S.ByteString)

196−takeLine =

216+takeLine src =

197 go id

217 go id

198 where

218 where

219+ go front = do

220+ bs <- readSource src

221+ if S.null bs

199− go front = await >>= maybe (close front) (push front)

222+ then close front

223+ else push front bs

200

224

201− close front = leftover (front S.empty) >> return Nothing

225+ close front = leftover src (front S.empty) >> return Nothing

202 push front bs = do

226 push front bs = do

203 let (x, y) = S.break (== 10) $ front bs -- LF

227 let (x, y) = S.break (== 10) $ front bs -- LF

204 in if S.null y

228 in if S.null y

205 then go $ S.append x

229 then go $ S.append x

206 else do

230 else do

207− when (S.length y > 1) $ leftover $ S.drop 1 y

231+ when (S.length y > 1) $ leftover src $ S.drop 1 y

208 return $ Just $ killCR x

232 return $ Just $ killCR x

209

233

210−takeLines :: Consumer S.ByteString IO [S.ByteString]

234+takeLines :: Source -> IO [S.ByteString]

211−takeLines = do

235+takeLines src = do

212− res <- takeLine

236+ res <- takeLine src

213 case res of

237 case res of

214 Nothing -> return []

238 Nothing -> return []

215 Just l

239 Just l

216 | S.null l -> return []

240 | S.null l -> return []

217 | otherwise -> do

241 | otherwise -> do

218− ls <- takeLines

242+ ls <- takeLines src

219 return $ l : ls

243 return $ l : ls

220

244

245+data Source = Source (IO S.ByteString) (IORef S.ByteString)

246+

247+mkSource :: IO S.ByteString -> IO Source

248+mkSource f = do

249+ ref <- newIORef S.empty

250+ return $ Source f ref

251+

252+readSource :: Source -> IO S.ByteString

253+readSource (Source f ref) = do

254+ bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs)

255+ if S.null bs

256+ then f

257+ else return bs

258+

259+leftover :: Source -> S.ByteString -> IO ()

260+leftover (Source _ ref) bs = writeIORef ref bs

261+

221parsePieces :: BackEnd y

262parsePieces :: BackEnd y

222 -> S.ByteString

263 -> S.ByteString

264+ -> IO S.ByteString

223− -> ConduitM S.ByteString (Either Param (File y)) IO ()

265+ -> (Either Param (File y) -> IO ())

266+ -> IO ()

224−parsePieces sink bound =

267+parsePieces sink bound rbody add =

225− loop

268+ mkSource rbody >>= loop

226 where

269 where

227− loop = do

270+ loop src = do

228− _boundLine <- takeLine

271+ _boundLine <- takeLine src

229− res' <- takeLines

272+ res' <- takeLines src

230 unless (null res') $ do

273 unless (null res') $ do

231 let ls' = map parsePair res'

274 let ls' = map parsePair res'

232 let x = do

275 let x = do

@@ -239,23 +282,23 @@ parsePieces sink bound =

239 Just (mct, name, Just filename) -> do

282 Just (mct, name, Just filename) -> do

240 let ct = fromMaybe "application/octet-stream" mct

283 let ct = fromMaybe "application/octet-stream" mct

241 fi0 = FileInfo filename ct ()

284 fi0 = FileInfo filename ct ()

242− (wasFound, y) <- sinkTillBound' bound name fi0 sink

285+ (wasFound, y) <- sinkTillBound' bound name fi0 sink src

243− yield $ Right (name, fi0 { fileContent = y })

286+ add $ Right (name, fi0 { fileContent = y })

244− when wasFound loop

287+ when wasFound (loop src)

245 Just (_ct, name, Nothing) -> do

288 Just (_ct, name, Nothing) -> do

246 let seed = id

289 let seed = id

247 let iter front bs = return $ front . (:) bs

290 let iter front bs = return $ front . (:) bs

248− (wasFound, front) <- sinkTillBound bound iter seed

291+ (wasFound, front) <- sinkTillBound bound iter seed src

249 let bs = S.concat $ front []

292 let bs = S.concat $ front []

250 let x' = (name, bs)

293 let x' = (name, bs)

251− yield $ Left x'

294+ add $ Left x'

252− when wasFound loop

295+ when wasFound (loop src)

253 _ -> do

296 _ -> do

254 -- ignore this part

297 -- ignore this part

255 let seed = ()

298 let seed = ()

256 iter () _ = return ()

299 iter () _ = return ()

257− (wasFound, ()) <- sinkTillBound bound iter seed

300+ (wasFound, ()) <- sinkTillBound bound iter seed src

258− when wasFound loop

301+ when wasFound (loop src)

259 where

302 where

260 contDisp = S8.pack "Content-Disposition"

303 contDisp = S8.pack "Content-Disposition"

261 contType = S8.pack "Content-Type"

304 contType = S8.pack "Content-Type"

@@ -295,64 +338,78 @@ sinkTillBound' :: S.ByteString

295 -> S.ByteString

338 -> S.ByteString

296 -> FileInfo ()

339 -> FileInfo ()

297 -> BackEnd y

340 -> BackEnd y

341+ -> Source

298− -> ConduitM S.ByteString o IO (Bool, y)

342+ -> IO (Bool, y)

299−sinkTillBound' bound name fi sink =

343+sinkTillBound' bound name fi sink src = do

300− ConduitM $ anyOutput $

344+ (next, final) <- wrapTillBound bound src

301− conduitTillBound bound >+> withUpstream (fix $ sink name fi)

345+ y <- sink name fi next

302− where

346+ b <- final

303− fix :: Sink S8.ByteString IO y -> Pipe Void S8.ByteString Void Bool IO y

347+ return (b, y)

304− fix p = ignoreTerm >+> injectLeftovers (unConduitM p)

348+

305− ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)

349+data WTB = WTBWorking (S.ByteString -> S.ByteString)

306− await' = NeedInput (return . Just) (const $ return Nothing)

350+ | WTBDone Bool

307− yield' = HaveOutput (return ()) (return ())

308−

309− anyOutput p = p >+> dropInput

310− dropInput = NeedInput (const dropInput) return

311−

312−conduitTillBound :: Monad m

313− => S.ByteString -- bound

351+wrapTillBound :: S.ByteString -- ^ bound

314− -> Pipe S.ByteString S.ByteString S.ByteString () m Bool

352+ -> Source

315−conduitTillBound bound =

353+ -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found

316− unConduitM $

354+wrapTillBound bound src = do

317− go id

355+ ref <- newIORef $ WTBWorking id

356+ return (go ref, final ref)

318 where

357 where

319− go front = await >>= maybe (close front) (push front)

358+ final ref = do

320− close front = do

359+ x <- readIORef ref

321− let bs = front S.empty

360+ case x of

361+ WTBWorking _ -> error "wrapTillBound did not finish"

362+ WTBDone y -> return y

363+

364+ go ref = do

365+ state <- readIORef ref

366+ case state of

367+ WTBDone _ -> return S.empty

368+ WTBWorking front -> do

369+ bs <- readSource src

322− unless (S.null bs) $ yield bs

370+ if S.null bs

323− return False

371+ then do

372+ writeIORef ref $ WTBDone False

324− push front bs' = do

373+ return $ front bs

325− let bs = front bs'

374+ else push $ front bs

375+ where

376+ push bs =

326− case findBound bound bs of

377+ case findBound bound bs of

327− FoundBound before after -> do

378+ FoundBound before after -> do

328− let before' = killCRLF before

379+ let before' = killCRLF before

329− yield before'

330− leftover after

380+ leftover src after

331− return True

381+ writeIORef ref $ WTBDone True

382+ return before'

332− NoBound -> do

383+ NoBound -> do

333− -- don't emit newlines, in case it's part of a bound

384+ -- don't emit newlines, in case it's part of a bound

334− let (toEmit, front') =

385+ let (toEmit, front') =

335− if not (S8.null bs) && S8.last bs `elem` "\r\n"

386+ if not (S8.null bs) && S8.last bs `elem` "\r\n"

336− then let (x, y) = S.splitAt (S.length bs - 2) bs

387+ then let (x, y) = S.splitAt (S.length bs - 2) bs

337− in (x, S.append y)

388+ in (x, S.append y)

338− else (bs, id)

389+ else (bs, id)

390+ writeIORef ref $ WTBWorking front'

339− yield toEmit

391+ if S.null toEmit

340− go front'

392+ then go ref

393+ else return toEmit

341− PartialBound -> go $ S.append bs

394+ PartialBound -> do

395+ writeIORef ref $ WTBWorking $ S.append bs

396+ go ref

342

397

343sinkTillBound :: S.ByteString

398sinkTillBound :: S.ByteString

344 -> (x -> S.ByteString -> IO x)

399 -> (x -> S.ByteString -> IO x)

345 -> x

400 -> x

401+ -> Source

346− -> Consumer S.ByteString IO (Bool, x)

402+ -> IO (Bool, x)

347−sinkTillBound bound iter seed0 =

403+sinkTillBound bound iter seed0 src = do

348− ConduitM $

404+ (next, final) <- wrapTillBound bound src

349− (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0))

405+ let loop seed = do

350− where

406+ bs <- next

351− iter' a b = liftIO $ iter a b

407+ if S.null bs

352− ij (ConduitM p) = ignoreTerm >+> injectLeftovers p

408+ then return seed

353− ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)

409+ else iter seed bs >>= loop

354− await' = NeedInput (return . Just) (const $ return Nothing)

410+ seed <- loop seed0

355− yield' = HaveOutput (return ()) (return ())

411+ b <- final

412+ return (b, seed)

356

413

357parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]

414parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]

358parseAttrs = map go . S.split 59 -- semicolon

415parseAttrs = map go . S.split 59 -- semicolon

wai-test/Network/Wai/Test.hs → wai-extra/Network/Wai/Test.hsrenamed+26−13

@@ -24,6 +24,7 @@ module Network.Wai.Test

24 ) where

25

26import Network.Wai

27+import Network.Wai.Internal (ResponseReceived (ResponseReceived))

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

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

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

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

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

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

@@ -35,8 +36,7 @@ import Data.Map (Map)

35import qualified Data.Map as Map

36import qualified Data.Map as Map

36import Data.ByteString (ByteString)

37import Data.ByteString (ByteString)

37import qualified Data.ByteString.Char8 as S8

38import qualified Data.ByteString.Char8 as S8

38−import Data.Conduit.Blaze (builderToByteString)

39−import Blaze.ByteString.Builder (flush)

39+import Blaze.ByteString.Builder (toLazyByteString)

40import qualified Blaze.ByteString.Builder as B

41import qualified Data.ByteString.Lazy as L

42import qualified Data.ByteString.Lazy.Char8 as L8

@@ -45,8 +45,8 @@ import Data.CaseInsensitive (CI)

45import qualified Data.ByteString as S

46import qualified Data.Text as T

47import qualified Data.Text.Encoding as TE

48−import qualified Data.Conduit as C

48+import Data.IORef

49−import qualified Data.Conduit.List as CL

49+import Data.Monoid (mempty, mappend)

50

51type Session = ReaderT Application (StateT ClientState IO)

52

@@ -96,21 +96,34 @@ setRawPathInfo r rawPinfo =

96srequest :: SRequest -> Session SResponse

97srequest (SRequest req bod) = do

98 app <- ask

99+ refChunks <- liftIO $ newIORef $ L.toChunks bod

99 let req' = req

100 let req' = req

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

101+ { requestBody = atomicModifyIORef refChunks $ \bss ->

102+ case bss of

103+ [] -> ([], S.empty)

104+ x:y -> (y, x)

101 }

105 }

102− liftIO $ app req' >>= runResponse

106+ liftIO $ do

107+ ref <- newIORef $ error "runResponse gave no result"

108+ ResponseReceived <- app req' (runResponse ref)

109+ readIORef ref

103 -- FIXME cookie processing

110 -- FIXME cookie processing

104 --return sres

111 --return sres

105

112

106−runResponse :: Response -> IO SResponse

113+runResponse :: IORef SResponse -> Response -> IO ResponseReceived

107−runResponse res = do

114+runResponse ref res = do

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

115+ refBuilder <- newIORef mempty

109− return $ SResponse s h $ L.fromChunks bss

116+ let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ())

117+ withBody $ \body -> body add (return ())

118+ builder <- readIORef refBuilder

119+ let lbs = toLazyByteString builder

120+ len = L.length lbs

121+ -- Force evaluation of the body to have exceptions thrown at the right

122+ -- time.

123+ seq len $ writeIORef ref $ SResponse s h $ toLazyByteString builder

124+ return ResponseReceived

110 where

125 where

111− (s, h, withBody) = responseToSource res

126+ (s, h, withBody) = responseToStream res

112− toBuilder (C.Chunk builder) = builder

113− toBuilder C.Flush = flush

114

127

115assertBool :: String -> Bool -> Session ()

128assertBool :: String -> Bool -> Session ()

116assertBool s b = unless b $ assertFailure s

129assertBool s b = unless b $ assertFailure s

wai-extra/Network/Wai/UrlMap.hs+6−5

@@ -1,4 +1,5 @@

1{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}

2+{-# LANGUAGE ExistentialQuantification #-}

2{- | This module gives you a way to mount applications under sub-URIs.

3{- | This module gives you a way to mount applications under sub-URIs.

3For example:

4For example:

4

5

@@ -83,14 +84,14 @@ instance ToApplication Application where

83 toApplication = id

84 toApplication = id

84

85

85instance ToApplication UrlMap where

86instance ToApplication UrlMap where

86− toApplication urlMap = \req ->

87+ toApplication urlMap req sendResponse =

87 case try (pathInfo req) (unUrlMap urlMap) of

88 case try (pathInfo req) (unUrlMap urlMap) of

88 Just (newPath, app) ->

89 Just (newPath, app) ->

89− app $ req { pathInfo = newPath

90+ app (req { pathInfo = newPath

90− , rawPathInfo = makeRaw newPath

91+ , rawPathInfo = makeRaw newPath

91− }

92+ }) sendResponse

92 Nothing ->

93 Nothing ->

93− return $ responseLBS

94+ sendResponse $ responseLBS

94 status404

95 status404

95 [("content-type", "text/plain")]

96 [("content-type", "text/plain")]

96 "Not found\n"

97 "Not found\n"

wai-eventsource/src/Main.hs → wai-extra/app/Main.hsrenamed

The content is the same.

wai-eventsource/static/index.html → wai-extra/app/index.htmlrenamed

The content is the same.

wai-test/test/Network/Wai/TestSpec.hs → wai-extra/test/Network/Wai/TestSpec.hsrenamed

The content is the same.

wai-test/test/Spec.hs → wai-extra/test/Spec.hsrenamed

The content is the same.

wai-extra/test/WaiExtraTest.hs+25−22

@@ -30,9 +30,6 @@ import Network.Wai.Middleware.AcceptOverride

30import Network.Wai.Middleware.RequestLogger

31import Codec.Compression.GZip (decompress)

32

33−import qualified Data.Conduit as C

34−import qualified Data.Conduit.List as CL

35−import Data.Conduit.Binary (sourceHandle)

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

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

37import Data.Maybe (fromMaybe)

34import Data.Maybe (fromMaybe)

38import Network.HTTP.Types (parseSimpleQuery, status200)

35import Network.HTTP.Types (parseSimpleQuery, status200)

@@ -128,7 +125,13 @@ parseRequestBody' :: BackEnd file

128parseRequestBody' sink (SRequest req bod) =

125parseRequestBody' sink (SRequest req bod) =

129 case getRequestBodyType req of

126 case getRequestBodyType req of

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

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

128+ Just rbt -> do

129+ ref <- I.newIORef $ L.toChunks bod

130+ let rb = I.atomicModifyIORef ref $ \chunks ->

131+ case chunks of

132+ [] -> ([], S.empty)

133+ x:y -> (y, x)

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

134+ sinkRequestBody sink rbt rb

132

135

133caseParseRequestBody :: Assertion

136caseParseRequestBody :: Assertion

134caseParseRequestBody =

137caseParseRequestBody =

@@ -295,7 +298,7 @@ caseTakeLine = do

295-}

298-}

296

299

297jsonpApp :: Application

300jsonpApp :: Application

298−jsonpApp = jsonp $ const $ return $ responseLBS

301+jsonpApp = jsonp $ \_ f -> f $ responseLBS

299 status200

302 status200

300 [("Content-Type", "application/json")]

303 [("Content-Type", "application/json")]

301 "{\"foo\":\"bar\"}"

304 "{\"foo\":\"bar\"}"

@@ -324,7 +327,7 @@ caseJsonp = flip runSession jsonpApp $ do

324 assertBody "{\"foo\":\"bar\"}" sres3

327 assertBody "{\"foo\":\"bar\"}" sres3

325

328

326gzipApp :: Application

329gzipApp :: Application

327−gzipApp = gzip def $ const $ return $ responseLBS status200

330+gzipApp = gzip def $ \_ f -> f $ responseLBS status200

328 [("Content-Type", "text/plain")]

331 [("Content-Type", "text/plain")]

329 "test"

332 "test"

330

333

@@ -332,7 +335,7 @@ gzipApp = gzip def $ const $ return $ responseLBS status200

332-- that the compression is skipped based on the presence of

335-- that the compression is skipped based on the presence of

333-- the Content-Encoding header.

336-- the Content-Encoding header.

334gzipPrecompressedApp :: Application

337gzipPrecompressedApp :: Application

335−gzipPrecompressedApp = gzip def $ const $ return $ responseLBS status200

338+gzipPrecompressedApp = gzip def $ \_ f -> f $ responseLBS status200

336 [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]

339 [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]

337 "test"

340 "test"

338

341

@@ -380,8 +383,8 @@ caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do

380 assertBody "test" sres1 -- the body is not actually compressed

383 assertBody "test" sres1 -- the body is not actually compressed

381

384

382vhostApp1, vhostApp2, vhostApp :: Application

385vhostApp1, vhostApp2, vhostApp :: Application

383−vhostApp1 = const $ return $ responseLBS status200 [] "app1"

386+vhostApp1 _ f = f $ responseLBS status200 [] "app1"

384−vhostApp2 = const $ return $ responseLBS status200 [] "app2"

387+vhostApp2 _ f = f $ responseLBS status200 [] "app2"

385vhostApp = vhost

388vhostApp = vhost

386 [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)

389 [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)

387 ]

390 ]

@@ -400,7 +403,7 @@ caseVhost = flip runSession vhostApp $ do

400 assertBody "app2" sres2

403 assertBody "app2" sres2

401

404

402autoheadApp :: Application

405autoheadApp :: Application

403−autoheadApp = autohead $ const $ return $ responseLBS status200

406+autoheadApp = autohead $ \_ f -> f $ responseLBS status200

404 [("Foo", "Bar")] "body"

407 [("Foo", "Bar")] "body"

405

408

406caseAutohead :: Assertion

409caseAutohead :: Assertion

@@ -418,7 +421,7 @@ caseAutohead = flip runSession autoheadApp $ do

418 assertBody "" sres2

421 assertBody "" sres2

419

422

420moApp :: Application

423moApp :: Application

421−moApp = methodOverride $ \req -> return $ responseLBS status200

424+moApp = methodOverride $ \req f -> f $ responseLBS status200

422 [("Method", requestMethod req)] ""

425 [("Method", requestMethod req)] ""

423

426

424caseMethodOverride :: Assertion

427caseMethodOverride :: Assertion

@@ -442,7 +445,7 @@ caseMethodOverride = flip runSession moApp $ do

442 assertHeader "Method" "PUT" sres3

445 assertHeader "Method" "PUT" sres3

443

446

444mopApp :: Application

447mopApp :: Application

445−mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""

448+mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] ""

446

449

447caseMethodOverridePost :: Assertion

450caseMethodOverridePost :: Assertion

448caseMethodOverridePost = flip runSession mopApp $ do

451caseMethodOverridePost = flip runSession mopApp $ do

@@ -468,7 +471,7 @@ caseMethodOverridePost = flip runSession mopApp $ do

468 assertHeader "Method" "POST" sres4

471 assertHeader "Method" "POST" sres4

469

472

470aoApp :: Application

473aoApp :: Application

471−aoApp = acceptOverride $ \req -> return $ responseLBS status200

474+aoApp = acceptOverride $ \req f -> f $ responseLBS status200

472 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""

475 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""

473

476

474caseAcceptOverride :: Assertion

477caseAcceptOverride :: Assertion

@@ -520,7 +523,7 @@ dalvikHelper includeLength = do

520 case getRequestBodyType request' of

523 case getRequestBodyType request' of

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

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

522 Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->

525 Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->

523− sourceHandle h C.$$ sinkRequestBody lbsBackEnd rbt

526+ sinkRequestBody lbsBackEnd rbt $ S.hGetSome h 2048

524 lookup "scannedTime" params @?= Just "1.298590056748E9"

527 lookup "scannedTime" params @?= Just "1.298590056748E9"

525 lookup "geoLong" params @?= Just "0"

528 lookup "geoLong" params @?= Just "0"

526 lookup "geoLat" params @?= Just "0"

529 lookup "geoLat" params @?= Just "0"

@@ -548,15 +551,15 @@ caseDebugRequestBody = do

548 postOutput = T.pack $ "POST / :: \nStatus: 200 OK. /\n"

551 postOutput = T.pack $ "POST / :: \nStatus: 200 OK. /\n"

549 getOutput params' = T.pack $ "GET /location :: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

552 getOutput params' = T.pack $ "GET /location :: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

550

553

551− debugApp output' req = do

554+ debugApp output' req send = do

552− iactual <- liftIO $ I.newIORef mempty

555+ iactual <- I.newIORef mempty

553− middleware <- liftIO $ mkRequestLogger def

556+ middleware <- mkRequestLogger def

554 { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)

557 { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)

555 , outputFormat = Detailed False

558 , outputFormat = Detailed False

556 }

559 }

557− res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req

560+ res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send

558− actual <- liftIO $ I.readIORef iactual

561+ actual <- I.readIORef iactual

559− liftIO $ assertEqual "debug" output $ logToBs actual

562+ assertEqual "debug" output $ logToBs actual

560 return res

563 return res

561 where

564 where

562 output = TE.encodeUtf8 $ T.toStrict output'

565 output = TE.encodeUtf8 $ T.toStrict output'

@@ -578,8 +581,8 @@ urlMapTestApp = mapUrls $

578

581

579 where

582 where

580 trivialApp :: S.ByteString -> Application

583 trivialApp :: S.ByteString -> Application

581− trivialApp name req =

584+ trivialApp name req f =

582− return $

585+ f $

583 responseLBS

586 responseLBS

584 status200

587 status200

585 [ ("content-type", "text/plain")

588 [ ("content-type", "text/plain")

wai-extra/wai-extra.cabal+19−11

@@ -1,5 +1,5 @@

1Name: wai-extra

2−Version: 2.1.1.2

2+Version: 3.0.0

3Synopsis: Provides some basic WAI handlers and middleware.

4Description: The goal here is to provide common features without many dependencies.

5License: MIT

@@ -22,7 +22,7 @@ extra-source-files:

22Library

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

24 , bytestring >= 0.9.1.4

25− , wai >= 2.1 && < 2.2

25+ , wai >= 3.0 && < 3.1

26 , old-locale >= 1.0.0.2 && < 1.1

27 , time >= 1.1.4

28 , network >= 2.2.1.5

@@ -32,13 +32,9 @@ Library

32 , http-types >= 0.7

33 , text >= 0.7

34 , case-insensitive >= 0.2

35− , data-default

35+ , data-default-class

36 , fast-logger >= 2.1 && < 2.2

37 , wai-logger >= 2.0 && < 2.2

38− , conduit >= 1.0 && < 1.2

39− , conduit-extra >= 0.1 && < 1.2

40− , zlib-conduit >= 0.5 && < 1.2

41− , blaze-builder-conduit >= 0.5 && < 1.2

42 , ansi-terminal

38 , ansi-terminal

43 , resourcet >= 0.4.6 && < 1.2

39 , resourcet >= 0.4.6 && < 1.2

44 , void >= 0.5

40 , void >= 0.5

@@ -47,6 +43,8 @@ Library

47 , base64-bytestring

43 , base64-bytestring

48 , word8

44 , word8

49 , lifted-base >= 0.1.2

45 , lifted-base >= 0.1.2

46+ , deepseq

47+ , streaming-commons

50

48

51 if os(windows)

49 if os(windows)

52 cpp-options: -DWINDOWS

50 cpp-options: -DWINDOWS

@@ -68,6 +66,9 @@ Library

68 Network.Wai.Middleware.HttpAuth

66 Network.Wai.Middleware.HttpAuth

69 Network.Wai.Parse

67 Network.Wai.Parse

70 Network.Wai.UrlMap

68 Network.Wai.UrlMap

69+ Network.Wai.Test

70+ Network.Wai.EventSource

71+ Network.Wai.EventSource.EventStream

71 other-modules: Network.Wai.Middleware.RequestLogger.Internal

72 other-modules: Network.Wai.Middleware.RequestLogger.Internal

72 ghc-options: -Wall

73 ghc-options: -Wall

73

74

@@ -79,7 +80,6 @@ test-suite tests

79

80

80 build-depends: base >= 4 && < 5

81 build-depends: base >= 4 && < 5

81 , wai-extra

82 , wai-extra

82− , wai-test >= 1.3

83 , hspec >= 1.3

84 , HUnit

85

@@ -90,15 +90,23 @@ test-suite tests

90 , text

91 , bytestring

92 , directory

93− , zlib-bindings

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

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

95 , data-default

94 , data-default

96− , conduit

97 , fast-logger >= 2.1

95 , fast-logger >= 2.1

98 , resourcet

96 , resourcet

99− , conduit-extra

100 ghc-options: -Wall

97 ghc-options: -Wall

101

98

99+test-suite spec

100+ type: exitcode-stdio-1.0

101+ hs-source-dirs: test

102+ main-is: Spec.hs

103+ other-modules: Network.Wai.TestSpec

104+ build-depends: base >= 4 && < 5

105+ , wai-extra

106+ , wai

107+ , hspec >= 1.3

108+ ghc-options: -Wall -Werror

109+

102source-repository head

110source-repository head

103 type: git

111 type: git

104 location: git://github.com/yesodweb/wai.git

112 location: git://github.com/yesodweb/wai.git

wai-frontend-monadcgi/Network/Wai/Frontend/MonadCGI.hs+3−5

@@ -10,8 +10,6 @@ import Network.HTTP.Types (Status (..))

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

11import Data.CaseInsensitive (original)

12

13−import Data.Conduit.Lazy (lazyConsume)

14−

15import qualified Data.Map as Map

13import qualified Data.Map as Map

16import qualified Data.ByteString.Lazy as BS

14import qualified Data.ByteString.Lazy as BS

17import qualified Data.ByteString.Char8 as S8

15import qualified Data.ByteString.Char8 as S8

@@ -32,8 +30,8 @@ cgiToAppGeneric :: Monad m

32 => (m (Headers, CGIResult) -> IO (Headers, CGIResult))

30 => (m (Headers, CGIResult) -> IO (Headers, CGIResult))

33 -> CGIT m CGIResult

31 -> CGIT m CGIResult

34 -> Application

32 -> Application

35−cgiToAppGeneric toIO cgi env = do

33+cgiToAppGeneric toIO cgi env sendResponse = do

36− input <- fmap BS.fromChunks $ lazyConsume $ requestBody env

34+ input <- lazyRequestBody env

37 let vars = map (first fixVarName . go) (requestHeaders env)

35 let vars = map (first fixVarName . go) (requestHeaders env)

38 ++ getCgiVars env

36 ++ getCgiVars env

39 (inputs, body') = decodeInput vars input

37 (inputs, body') = decodeInput vars input

@@ -51,7 +49,7 @@ cgiToAppGeneric toIO cgi env = do

51 let status' = case lookup (fromString "Status") headers' of

49 let status' = case lookup (fromString "Status") headers' of

52 Nothing -> 200

50 Nothing -> 200

53 Just s -> safeRead 200 $ S8.unpack s

51 Just s -> safeRead 200 $ S8.unpack s

54− return $ responseLBS (Status status' S8.empty) headers' output

52+ sendResponse $ responseLBS (Status status' S8.empty) headers' output

55 where

53 where

56 go (x, y) = (S8.unpack $ original x, S8.unpack y)

54 go (x, y) = (S8.unpack $ original x, S8.unpack y)

57

55

wai-frontend-monadcgi/wai-frontend-monadcgi.cabal+2−4

@@ -1,5 +1,5 @@

1name: wai-frontend-monadcgi

2−version: 2.0.0.2

2+version: 3.0.0

3license: MIT

4license-file: LICENSE

5author: Michael Snoyman <michael@snoyman.com>

@@ -16,12 +16,10 @@ library

16 , bytestring

17 , containers >= 0.2

18 , cgi

19− , conduit >= 0.5 && < 1.2

20− , conduit-extra

21 , http-types

19 , http-types

22 , transformers

20 , transformers

23 , case-insensitive

21 , case-insensitive

24− , wai >= 2.0 && < 2.2

22+ , wai >= 3.0 && < 3.1

25 exposed-modules: Network.Wai.Frontend.MonadCGI

23 exposed-modules: Network.Wai.Frontend.MonadCGI

26 ghc-options: -Wall

24 ghc-options: -Wall

27

25

wai-handler-fastcgi/wai-handler-fastcgi.cabal+3−3

@@ -1,5 +1,5 @@

1name: wai-handler-fastcgi

2−version: 2.0.0.1

2+version: 3.0.0

3license: MIT

4license-file: LICENSE

5author: Michael Snoyman <michael@snoyman.com>

@@ -15,8 +15,8 @@ description: Calls out to the libfcgi C library.

15

16library

17 build-depends: base >= 4 && < 5

18− , wai >= 2.0 && < 2.2

18+ , wai >= 3.0 && < 3.1

19− , wai-extra >= 2.0 && < 2.2

19+ , wai-extra >= 3.0 && < 3.1

20 , bytestring >= 0.9.1.4

21 exposed-modules: Network.Wai.Handler.FastCGI

22 ghc-options: -Wall

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

@@ -12,84 +12,134 @@ import Network.Wai.Internal

12import Network.HTTP.Types

13import qualified Network.Wai.Handler.Warp as Warp

14import Data.IORef

15+import Data.Monoid (mappend)

15import Control.Concurrent (forkIO, threadDelay)

16import Control.Concurrent (forkIO, threadDelay)

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

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

18+import Control.Monad (unless)

19+import Control.Exception (throwIO)

20+import Data.Function (fix)

17import qualified Data.ByteString as S

21import qualified Data.ByteString as S

18−import Blaze.ByteString.Builder (fromByteString)

22+import Blaze.ByteString.Builder (fromByteString, Builder, flush)

23+import qualified Blaze.ByteString.Builder as Blaze

19#if WINDOWS

24#if WINDOWS

20import Foreign

25import Foreign

21import Foreign.C.String

26import Foreign.C.String

22#else

27#else

23−import System.Cmd (rawSystem)

28+import System.Process (rawSystem)

24#endif

29#endif

25−import Data.Conduit.Zlib (decompressFlush, WindowBits (WindowBits))

30+import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)

26−import Data.Conduit.Blaze (builderToByteStringFlush)

27−import Data.Conduit

28−import qualified Data.Conduit.List as CL

31+import qualified Data.Streaming.Zlib as Z

29

32

30ping :: IORef Bool -> Middleware

33ping :: IORef Bool -> Middleware

31−ping var app req

34+ping var app req sendResponse

32 | pathInfo req == ["_ping"] = do

35 | pathInfo req == ["_ping"] = do

33 liftIO $ writeIORef var True

36 liftIO $ writeIORef var True

34− return $ responseLBS status200 [] ""

37+ sendResponse $ responseLBS status200 [] ""

35− | otherwise = do

38+ | otherwise = app req $ \res -> do

36− res <- app req

37 let isHtml hs =

39 let isHtml hs =

38 case lookup "content-type" hs of

40 case lookup "content-type" hs of

39 Just ct -> "text/html" `S.isPrefixOf` ct

41 Just ct -> "text/html" `S.isPrefixOf` ct

40 Nothing -> False

42 Nothing -> False

41− case res of

43+ if isHtml $ responseHeaders res

42− ResponseFile _ hs _ _

43− | not $ isHtml hs -> return res

44− ResponseBuilder _ hs _

45− | not $ isHtml hs -> return res

46− ResponseSource _ hs _

47− | not $ isHtml hs -> return res

48− _ -> do

44+ then do

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

45+ let (s, hs, withBody) = responseToStream res

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

46+ (isEnc, headers') = fixHeaders id hs

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

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

52− let fixEnc src =

48+ withBody $ \body ->

49+ sendResponse $ responseStream s headers'' $ \sendChunk flush ->

50+ addInsideHead sendChunk flush $ \sendChunk' flush' ->

53− if isEnc then

51+ if isEnc

54− src $= decompressFlush (WindowBits 31)

52+ then decode sendChunk' flush' body

55− else src

53+ else body sendChunk' flush'

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

54+ else sendResponse res

57− $ fixEnc (body $= builderToByteStringFlush)

55+

58− $= insideHead

56+decode :: (Builder -> IO ()) -> IO ()

59− $= CL.map (fmap fromByteString)

57+ -> StreamingBody

58+ -> IO ()

59+decode sendInner flushInner streamingBody = do

60+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

61+ inflate <- Z.initInflate $ Z.WindowBits 31

62+ let send builder = blazeRecv builder >>= goBuilderPopper

63+ goBuilderPopper popper = fix $ \loop -> do

64+ bs <- popper

65+ unless (S.null bs) $ do

66+ Z.feedInflate inflate bs >>= goZlibPopper

67+ loop

68+ goZlibPopper popper = fix $ \loop -> do

69+ res <- popper

70+ case res of

71+ Z.PRDone -> return ()

72+ Z.PRNext bs -> do

73+ sendInner $ fromByteString bs

74+ loop

75+ Z.PRError e -> throwIO e

76+ streamingBody send (send flush)

77+ mbs <- blazeFinish

78+ case mbs of

79+ Nothing -> return ()

80+ Just bs -> Z.feedInflate inflate bs >>= goZlibPopper

81+ Z.finishInflate inflate >>= sendInner . fromByteString

60

82

61toInsert :: S.ByteString

83toInsert :: S.ByteString

62toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping\",false);x.send();},60000)</script>"

84toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping\",false);x.send();},60000)</script>"

63

85

64−insideHead :: Conduit (Flush S.ByteString) IO (Flush S.ByteString)

86+addInsideHead :: (Builder -> IO ())

65−insideHead =

87+ -> IO ()

88+ -> StreamingBody

89+ -> IO ()

90+addInsideHead sendInner flushInner streamingBody = do

91+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

66− loop' (S.empty, whole)

92+ ref <- newIORef $ Just (S.empty, whole)

93+ streamingBody (inner blazeRecv ref) (flush blazeRecv ref)

94+ state <- readIORef ref

95+ mbs <- blazeFinish

96+ held <- case mbs of

97+ Nothing -> return state

98+ Just bs -> push state bs

99+ case state of

100+ Nothing -> return ()

101+ Just (held, _) -> sendInner $ fromByteString held `mappend` fromByteString toInsert

67 where

102 where

68− loop' state = await >>= maybe (close state) (push' state)

69 whole = "<head>"

103 whole = "<head>"

70− push' state (Chunk x) = push state x

71− push' state Flush = yield Flush >> loop' state

72

104

105+ flush blazeRecv ref = inner blazeRecv ref Blaze.flush

106+

107+ inner blazeRecv ref builder = do

108+ state0 <- readIORef ref

109+ popper <- blazeRecv builder

110+ let loop state = do

111+ bs <- popper

112+ if S.null bs

113+ then writeIORef ref state

114+ else push state bs >>= loop

115+ loop state0

116+

117+ push Nothing x = sendInner (fromByteString x) >> return Nothing

73− push (held, atFront) x

118+ push (Just (held, atFront)) x

74 | atFront `S.isPrefixOf` x = do

119 | atFront `S.isPrefixOf` x = do

75 let y = S.drop (S.length atFront) x

120 let y = S.drop (S.length atFront) x

76− mapM_ (yield . Chunk) [held, atFront, toInsert, y]

121+ sendInner $ fromByteString held

77− CL.map id

122+ `mappend` fromByteString atFront

123+ `mappend` fromByteString toInsert

124+ `mappend` fromByteString y

125+ return Nothing

78 | whole `S.isInfixOf` x = do

126 | whole `S.isInfixOf` x = do

79 let (before, rest) = S.breakSubstring whole x

127 let (before, rest) = S.breakSubstring whole x

80 let after = S.drop (S.length whole) rest

128 let after = S.drop (S.length whole) rest

81− mapM_ (yield . Chunk) [held, before, whole, toInsert, after]

129+ sendInner $ fromByteString held

82− CL.map id

130+ `mappend` fromByteString before

131+ `mappend` fromByteString whole

132+ `mappend` fromByteString toInsert

133+ `mappend` fromByteString after

134+ return Nothing

83 | x `S.isPrefixOf` atFront = do

135 | x `S.isPrefixOf` atFront = do

84 let held' = held `S.append` x

136 let held' = held `S.append` x

85 atFront' = S.drop (S.length x) atFront

137 atFront' = S.drop (S.length x) atFront

86− loop' (held', atFront')

138+ return $ Just (held', atFront')

87 | otherwise = do

139 | otherwise = do

88 let (held', atFront', x') = getOverlap whole x

140 let (held', atFront', x') = getOverlap whole x

89− mapM_ (yield . Chunk) [held, x']

141+ sendInner $ fromByteString held `mappend` fromByteString x'

90− loop' (held', atFront')

142+ return $ Just (held', atFront')

91−

92− close (held, _) = mapM_ yield [Chunk held, Chunk toInsert]

93

143

94getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)

144getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)

95getOverlap whole x =

145getOverlap whole x =

@@ -138,11 +188,11 @@ runUrl = runUrlPort 4587

138runUrlPort :: Int -> String -> Application -> IO ()

188runUrlPort :: Int -> String -> Application -> IO ()

139runUrlPort port url app = do

189runUrlPort port url app = do

140 x <- newIORef True

190 x <- newIORef True

141− _ <- forkIO $ Warp.runSettings Warp.defaultSettings

191+ _ <- forkIO $ Warp.runSettings

142− { Warp.settingsPort = port

192+ ( Warp.setPort port

143− , Warp.settingsOnException = (\_ _ -> return ())

193+ $ Warp.setOnException (\_ _ -> return ())

144− , Warp.settingsHost = "*4"

194+ $ Warp.setHost "*4" Warp.defaultSettings)

145− } $ ping x app

195+ $ ping x app

146 launch port url

196 launch port url

147 loop x

197 loop x

148

198

wai-handler-launch/test.hs+1−1

@@ -4,4 +4,4 @@ import Network.HTTP.Types

4import Network.Wai.Handler.Launch

5import Network.Wai.Middleware.Gzip

6

7−main = runUrl "FIXME" $ gzip True $ \_ -> return $ responseLBS status200 [("Content-Type", "text/html; charset=utf8")] "<html><head></head><body>HELLO THERE"

7+main = runUrl "FIXME" $ gzip def $ \_ f -> f $ responseLBS status200 [("Content-Type", "text/html; charset=utf8")] "<html><head></head><body>HELLO THERE"

wai-handler-launch/wai-handler-launch.cabal+4−7

@@ -1,5 +1,5 @@

1Name: wai-handler-launch

2−Version: 2.0.1.3

2+Version: 3.0.0

3Synopsis: Launch a web app in the default browser.

4Description: This handles cross-platform launching and inserts Javascript code to ping the server. When the server no longer receives pings, it shuts down.

5License: MIT

@@ -13,16 +13,13 @@ Cabal-version: >=1.6

13Library

14 Exposed-modules: Network.Wai.Handler.Launch

15 build-depends: base >= 4 && < 5

16− , wai >= 2.0 && < 2.2

16+ , wai >= 3.0 && < 3.1

17− , warp >= 2.0 && < 2.2

17+ , warp >= 3.0 && < 3.1

18 , http-types >= 0.7

19 , transformers >= 0.2.2

20 , bytestring >= 0.9.1.4

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

22− , conduit >= 0.5 && < 1.2

22+ , streaming-commons

23− , conduit-extra >= 0.0 && < 1.2

24− , blaze-builder-conduit >= 0.5 && < 1.2

25− , zlib-conduit >= 0.5 && < 1.2

26

23

27 if os(windows)

24 if os(windows)

28 c-sources: windows.c

25 c-sources: windows.c

wai-handler-webkit/wai-handler-webkit.cabal+3−3

@@ -1,5 +1,5 @@

1name: wai-handler-webkit

2−version: 2.0.0.2

2+version: 3.0.0

3license: MIT

4license-file: LICENSE

5author: Michael Snoyman <michael@snoyman.com>

@@ -16,8 +16,8 @@ homepage: https://github.com/yesodweb/wai/tree/master/wai-handler-webkit

16

17library

18 build-depends: base >= 4 && < 5

19− , wai >= 2.0 && < 2.2

19+ , wai >= 3.0 && < 3.1

20− , warp >= 2.0 && < 2.2

20+ , warp >= 3.0 && < 3.1

21 ghc-options: -Wall

22 exposed-modules: Network.Wai.Handler.Webkit

23 c-sources: webkit.cpp

wai-test/READMEdeleted

No changes to the content.

wai-test/wai-test.cabal+4−35

@@ -1,47 +1,16 @@

1name: wai-test

2−version: 2.0.1.3

2+version: 3.0.0

3license: MIT

4license-file: LICENSE

5author: Michael Snoyman <michael@snoyman.com>

6maintainer: Michael Snoyman <michael@snoyman.com>

7−synopsis: Unit test framework (built on HUnit) for WAI applications.

7+synopsis: Unit test framework (built on HUnit) for WAI applications. (deprecated)

8+description: Since WAI 3.0, this code has been merged into wai-extra.

8category: Testing, Web, Yesod

9category: Testing, Web, Yesod

9stability: Stable

10stability: Stable

10cabal-version: >= 1.8

11cabal-version: >= 1.8

11build-type: Simple

12build-type: Simple

12homepage: http://www.yesodweb.com/book/web-application-interface

13homepage: http://www.yesodweb.com/book/web-application-interface

13−description: Unit test framework (built on HUnit) for WAI applications.

14

15library

16− build-depends: base >= 4 && < 5

16+ build-depends: wai >= 3.0

17− , wai >= 2.0 && < 2.2

18− , bytestring >= 0.9.1.4

19− , text >= 0.7

20− , blaze-builder >= 0.2.1.4 && < 0.4

21− , transformers >= 0.2.2

22− , containers >= 0.2

23− , conduit >= 0.5 && < 1.2

24− , conduit-extra

25− , blaze-builder-conduit >= 0.5 && < 1.2

26− , cookie >= 0.2 && < 0.5

27− , http-types >= 0.7

28− , case-insensitive >= 0.2

29− , network

30− , deepseq

31− exposed-modules: Network.Wai.Test

32− ghc-options: -Wall

33−

34−test-suite spec

35− type: exitcode-stdio-1.0

36− hs-source-dirs: test

37− main-is: Spec.hs

38− other-modules: Network.Wai.TestSpec

39− build-depends: base >= 4 && < 5

40− , wai-test

41− , wai

42− , hspec >= 1.3

43− ghc-options: -Wall -Werror

44−

45−source-repository head

46− type: git

47− location: git://github.com/yesodweb/wai.git

wai-websockets/Network/Wai/Handler/WebSockets.hs+9−27

@@ -10,13 +10,10 @@ module Network.Wai.Handler.WebSockets

10import Data.ByteString (ByteString)

11import qualified Data.ByteString.Char8 as BC

12import qualified Data.CaseInsensitive as CI

13−import Data.Conduit

14−import Data.IORef (newIORef, readIORef, writeIORef)

15import Network.HTTP.Types (status500)

13import Network.HTTP.Types (status500)

16import qualified Network.Wai as Wai

14import qualified Network.Wai as Wai

17import qualified Network.WebSockets as WS

15import qualified Network.WebSockets as WS

18import qualified Network.WebSockets.Connection as WS

16import qualified Network.WebSockets.Connection as WS

19−import System.IO.Streams (InputStream, OutputStream)

20import qualified System.IO.Streams as Streams

17import qualified System.IO.Streams as Streams

21

18

22--------------------------------------------------------------------------------

19--------------------------------------------------------------------------------

@@ -29,10 +26,10 @@ websocketsOr :: WS.ConnectionOptions

29 -> WS.ServerApp

26 -> WS.ServerApp

30 -> Wai.Application

27 -> Wai.Application

31 -> Wai.Application

28 -> Wai.Application

32−websocketsOr opts app backup req =

29+websocketsOr opts app backup req sendResponse =

33 case websocketsApp opts app req of

30 case websocketsApp opts app req of

34− Nothing -> backup req

31+ Nothing -> backup req sendResponse

35− Just res -> return res

32+ Just res -> sendResponse res

36

33

37--------------------------------------------------------------------------------

34--------------------------------------------------------------------------------

38websocketsApp :: WS.ConnectionOptions

35websocketsApp :: WS.ConnectionOptions

@@ -61,13 +58,15 @@ getRequestHead req = WS.RequestHead

61runWebSockets :: WS.ConnectionOptions

58runWebSockets :: WS.ConnectionOptions

62 -> WS.RequestHead

59 -> WS.RequestHead

63 -> (WS.PendingConnection -> IO a)

60 -> (WS.PendingConnection -> IO a)

64− -> Source IO ByteString

61+ -> IO ByteString

65− -> Sink ByteString IO ()

62+ -> (ByteString -> IO ())

66 -> IO a

63 -> IO a

67runWebSockets opts req app src sink = do

64runWebSockets opts req app src sink = do

68

65

69− is <- srcToInput src

66+ is <- Streams.makeInputStream $ do

67+ bs <- src

68+ return $ if BC.null bs then Nothing else Just bs

70− os <- sinkToOutput sink >>= Streams.builderStream

69+ os <- Streams.makeOutputStream (maybe (return ()) sink) >>= Streams.builderStream

71

70

72 let pc = WS.PendingConnection

71 let pc = WS.PendingConnection

73 { WS.pendingOptions = opts

72 { WS.pendingOptions = opts

@@ -78,20 +77,3 @@ runWebSockets opts req app src sink = do

78 }

77 }

79

78

80 app pc

79 app pc

81−

82−srcToInput :: Source IO ByteString -> IO (InputStream ByteString)

83−srcToInput src0 = do

84− (rsrc0, ()) <- src0 $$+ return ()

85− ref <- newIORef rsrc0

86− Streams.makeInputStream $ do

87− rsrc <- readIORef ref

88− (rsrc', mbs) <- rsrc $$++ await

89− writeIORef ref rsrc'

90− return mbs

91−

92−sinkToOutput :: Sink ByteString IO () -> IO (OutputStream ByteString)

93−sinkToOutput sink =

94− Streams.makeOutputStream output

95− where

96− output Nothing = return ()

97− output (Just bs) = yield bs $$ sink

wai-websockets/wai-websockets.cabal+2−4

@@ -1,5 +1,5 @@

1Name: wai-websockets

2−Version: 2.1.0.2

2+Version: 3.0.0

3Synopsis: Provide a bridge betweeen WAI and the websockets package.

4License: MIT

5License-file: LICENSE

@@ -19,8 +19,7 @@ flag example

19Library

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

21 , bytestring >= 0.9.1.4

22− , conduit >= 0.5 && < 1.2

23− , wai >= 2.1 && < 2.2

22+ , wai >= 3.0 && < 3.1

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

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

25 , case-insensitive >= 0.2

24 , case-insensitive >= 0.2

26 , network >= 2.2.1.5

25 , network >= 2.2.1.5

@@ -35,7 +34,6 @@ Executable wai-websockets-example

35 if flag(example)

34 if flag(example)

36 buildable: True

35 buildable: True

37 Build-Depends: base >= 3 && < 5

36 Build-Depends: base >= 3 && < 5

38− , conduit

39 , wai-websockets

37 , wai-websockets

40 , websockets

38 , websockets

41 , warp

39 , warp

wai/Network/Wai.hs+63−53

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

39 -- * Types

40 Application

41 , Middleware

42+ , ResponseReceived

42 -- * Request

43 -- * Request

43 , Request

44 , Request

44 , defaultRequest

45 , defaultRequest

@@ -61,36 +62,35 @@ module Network.Wai

61 , lazyRequestBody

62 , lazyRequestBody

62 -- * Response

63 -- * Response

63 , Response

64 , Response

65+ , StreamingBody

64 , FilePart (..)

66 , FilePart (..)

65− , WithSource

66 -- ** Response composers

67 -- ** Response composers

67 , responseFile

68 , responseFile

68 , responseBuilder

69 , responseBuilder

69 , responseLBS

70 , responseLBS

70− , responseSource

71+ , responseStream

71− , responseSourceBracket

72 , responseRaw

73 -- * Response accessors

74 , responseStatus

75 , responseHeaders

76− , responseToSource

76+ , responseToStream

77 ) where

78

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

80import Blaze.ByteString.Builder (fromByteString)

81−import Control.Exception (bracket, bracketOnError)

81+import Control.Monad (unless)

82import qualified Data.ByteString as B

83import qualified Data.ByteString.Lazy as L

84+import qualified Data.ByteString.Lazy.Internal as LI

85+import Data.ByteString.Lazy.Internal (defaultChunkSize)

84import Data.ByteString.Lazy.Char8 ()

86import Data.ByteString.Lazy.Char8 ()

85−import qualified Data.Conduit as C

87+import Data.Function (fix)

86−import qualified Data.Conduit.Binary as CB

87−import Data.Conduit.Lazy (lazyConsume)

88−import qualified Data.Conduit.List as CL

89import Data.Monoid (mempty)

88import Data.Monoid (mempty)

90import qualified Network.HTTP.Types as H

89import qualified Network.HTTP.Types as H

91import Network.Socket (SockAddr (SockAddrInet))

90import Network.Socket (SockAddr (SockAddrInet))

92import Network.Wai.Internal

91import Network.Wai.Internal

93import qualified System.IO as IO

92import qualified System.IO as IO

93+import System.IO.Unsafe (unsafeInterleaveIO)

94

95----------------------------------------------------------------

96

@@ -130,29 +130,11 @@ responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

130responseLBS s h = ResponseBuilder s h . fromLazyByteString

131

132-- | Creating 'Response' from 'C.Source'.

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

133+responseStream :: H.Status

134−responseSource st hs src = ResponseSource st hs ($ src)

135−

136−-- | Creating 'Response' with allocated resource safely released.

137−--

138−-- * The first argument is an action to allocate resource.

139−--

140−-- * The second argument is a function to release the resource.

141−--

142−-- * The third argument is a function to create

143−-- ('H.Status','H.ResponseHeaders','C.Source' 'IO' ('C.Flush' 'Builder'))

144−-- from the resource.

145−responseSourceBracket :: IO a

146− -> (a -> IO ())

147− -> (a -> IO (H.Status

148− ,H.ResponseHeaders

134+ -> H.ResponseHeaders

149− ,C.Source IO (C.Flush Builder)))

135+ -> StreamingBody

150− -> IO Response

136+ -> Response

151−responseSourceBracket setup teardown action =

137+responseStream = ResponseStream

152− bracketOnError setup teardown $ \resource -> do

153− (st,hdr,src) <- action resource

154− return $ ResponseSource st hdr $ \f ->

155− bracket (return resource) teardown (\_ -> f src)

156

138

157-- | Create a response for a raw application. This is useful for \"upgrade\"

139-- | Create a response for a raw application. This is useful for \"upgrade\"

158-- situations such as WebSockets, where an application requests for the server

140-- situations such as WebSockets, where an application requests for the server

@@ -165,10 +147,10 @@ responseSourceBracket setup teardown action =

165-- @responseRaw@, behavior is undefined.

147-- @responseRaw@, behavior is undefined.

166--

148--

167-- Since 2.1.0

149-- Since 2.1.0

168−responseRaw :: (C.Source IO B.ByteString -> C.Sink B.ByteString IO () -> IO ())

150+responseRaw :: (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ())

169 -> Response

151 -> Response

170 -> Response

152 -> Response

171−responseRaw rawApp fallback = ResponseRaw ($ rawApp) fallback

153+responseRaw = ResponseRaw

172

154

173----------------------------------------------------------------

155----------------------------------------------------------------

174

156

@@ -176,36 +158,55 @@ responseRaw rawApp fallback = ResponseRaw ($ rawApp) fallback

176responseStatus :: Response -> H.Status

158responseStatus :: Response -> H.Status

177responseStatus (ResponseFile s _ _ _) = s

159responseStatus (ResponseFile s _ _ _) = s

178responseStatus (ResponseBuilder s _ _ ) = s

160responseStatus (ResponseBuilder s _ _ ) = s

179−responseStatus (ResponseSource s _ _ ) = s

161+responseStatus (ResponseStream s _ _ ) = s

180responseStatus (ResponseRaw _ res ) = responseStatus res

162responseStatus (ResponseRaw _ res ) = responseStatus res

181

163

182-- | Accessing 'H.ResponseHeaders' in 'Response'.

164-- | Accessing 'H.ResponseHeaders' in 'Response'.

183responseHeaders :: Response -> H.ResponseHeaders

165responseHeaders :: Response -> H.ResponseHeaders

184responseHeaders (ResponseFile _ hs _ _) = hs

166responseHeaders (ResponseFile _ hs _ _) = hs

185responseHeaders (ResponseBuilder _ hs _ ) = hs

167responseHeaders (ResponseBuilder _ hs _ ) = hs

186−responseHeaders (ResponseSource _ hs _ ) = hs

168+responseHeaders (ResponseStream _ hs _ ) = hs

187responseHeaders (ResponseRaw _ res) = responseHeaders res

169responseHeaders (ResponseRaw _ res) = responseHeaders res

188

170

189-- | Converting the body information in 'Response' to 'Source'.

171-- | Converting the body information in 'Response' to 'Source'.

190−responseToSource :: Response

172+responseToStream :: Response

173+ -> ( H.Status

191− -> (H.Status, H.ResponseHeaders, WithSource IO (C.Flush Builder) b)

174+ , H.ResponseHeaders

192−responseToSource (ResponseSource s h b) = (s, h, b)

175+ , (StreamingBody -> IO a) -> IO a

176+ )

177+responseToStream (ResponseStream s h b) = (s, h, ($ b))

193−responseToSource (ResponseFile s h fp (Just part)) =

178+responseToStream (ResponseFile s h fp (Just part)) =

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

179+ ( s

180+ , h

181+ , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> withBody $ \sendChunk _flush -> do

182+ IO.hSeek handle IO.AbsoluteSeek $ filePartOffset part

183+ let loop remaining | remaining <= 0 = return ()

184+ loop remaining = do

185+ bs <- B.hGetSome handle defaultChunkSize

186+ unless (B.null bs) $ do

187+ let x = B.take remaining bs

188+ sendChunk $ fromByteString x

189+ loop $ remaining - B.length x

190+ loop $ fromIntegral $ filePartByteCount part

191+ )

195−responseToSource (ResponseFile s h fp Nothing) =

192+responseToStream (ResponseFile s h fp Nothing) =

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

193+ ( s

194+ , h

195+ , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle ->

196+ withBody $ \sendChunk _flush -> fix $ \loop -> do

197+ bs <- B.hGetSome handle defaultChunkSize

198+ unless (B.null bs) $ do

199+ sendChunk $ fromByteString bs

200+ loop

201+ )

197−responseToSource (ResponseBuilder s h b) =

202+responseToStream (ResponseBuilder s h b) =

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

203+ (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b)

199−responseToSource (ResponseRaw _ res) = responseToSource res

204+responseToStream (ResponseRaw _ res) = responseToStream res

200−

201−sourceFilePart :: IO.Handle -> FilePart -> C.Source IO B.ByteString

202−sourceFilePart handle (FilePart offset count _) =

203− CB.sourceHandleRange handle (Just offset) (Just count)

204

205

205----------------------------------------------------------------

206----------------------------------------------------------------

206

207

207-- | The WAI application.

208-- | The WAI application.

208−type Application = Request -> IO Response

209+type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived

209

210

210-- | Middleware is a component that sits between the server and application. It

211-- | Middleware is a component that sits between the server and application. It

211-- can do such tasks as GZIP encoding or response caching. What follows is the

212-- can do such tasks as GZIP encoding or response caching. What follows is the

@@ -237,7 +238,7 @@ defaultRequest = Request

237 , remoteHost = SockAddrInet 0 0

238 , remoteHost = SockAddrInet 0 0

238 , pathInfo = []

239 , pathInfo = []

239 , queryString = []

240 , queryString = []

240− , requestBody = return ()

241+ , requestBody = return B.empty

241 , vault = mempty

242 , vault = mempty

242 , requestBodyLength = KnownLength 0

243 , requestBodyLength = KnownLength 0

243 , requestHeaderHost = Nothing

244 , requestHeaderHost = Nothing

@@ -249,4 +250,13 @@ defaultRequest = Request

249--

250--

250-- Since 1.4.1

251-- Since 1.4.1

251lazyRequestBody :: Request -> IO L.ByteString

252lazyRequestBody :: Request -> IO L.ByteString

252−lazyRequestBody = fmap L.fromChunks . lazyConsume . requestBody

253+lazyRequestBody req =

254+ loop

255+ where

256+ loop = unsafeInterleaveIO $ do

257+ bs <- requestBody req

258+ if B.null bs

259+ then return LI.Empty

260+ else do

261+ bss <- loop

262+ return $ LI.Chunk bs bss

wai/Network/Wai/Internal.hs+23−10

@@ -8,7 +8,6 @@ module Network.Wai.Internal where

8

9import Blaze.ByteString.Builder (Builder)

10import qualified Data.ByteString as B

11−import qualified Data.Conduit as C

12import Data.Text (Text)

11import Data.Text (Text)

13import Data.Typeable (Typeable)

12import Data.Typeable (Typeable)

14import Data.Vault.Lazy (Vault)

13import Data.Vault.Lazy (Vault)

@@ -51,8 +50,9 @@ data Request = Request {

51 , pathInfo :: [Text]

50 , pathInfo :: [Text]

52 -- | Parsed query string information

51 -- | Parsed query string information

53 , queryString :: H.Query

52 , queryString :: H.Query

54− -- | A request body provided as 'Source'.

53+ -- | Get the next chunk of the body. Returns an empty bytestring when the

54+ -- body is fully consumed.

55− , requestBody :: C.Source IO B.ByteString

55+ , requestBody :: IO B.ByteString

56 -- | A location for arbitrary data to be shared by applications and middleware.

57 , vault :: Vault

58 -- | The size of the request body. In the case of a chunked request body,

@@ -84,15 +84,17 @@ data Request = Request {

84data Response

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

86 | ResponseBuilder H.Status H.ResponseHeaders Builder

87− | ResponseSource H.Status H.ResponseHeaders (forall b. WithSource IO (C.Flush Builder) b)

87+ | ResponseStream H.Status H.ResponseHeaders StreamingBody

88− | ResponseRaw (forall b. WithRawApp b) Response

88+ | ResponseRaw (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) Response

89 deriving Typeable

90

91−type RawApp = C.Source IO B.ByteString -> C.Sink B.ByteString IO () -> IO ()

91+-- | Represents a streaming HTTP response body. It's a function of two

92−type WithRawApp b = (RawApp -> IO b) -> IO b

92+-- parameters; the first parameter provides a means of sending another chunk of

93−

93+-- data, and the second parameter provides a means of flushing the data to the

94−-- | Auxiliary type for 'ResponseSource'.

94+-- client.

95−type WithSource m a b = (C.Source m a -> m b) -> m b

95+--

96+-- Since 3.0.0

97+type StreamingBody = (Builder -> IO ()) -> IO () -> IO ()

96

98

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

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

98-- not be known.

100-- not be known.

@@ -108,3 +110,14 @@ data FilePart = FilePart

108 , filePartByteCount :: Integer

110 , filePartByteCount :: Integer

109 , filePartFileSize :: Integer

111 , filePartFileSize :: Integer

110 } deriving Show

112 } deriving Show

113+

114+-- | A special datatype to indicate that the WAI handler has received the

115+-- response. This is to avoid the need for Rank2Types in the definition of

116+-- Application.

117+--

118+-- It is /highly/ advised that only WAI handlers import and use the data

119+-- constructor for this data type.

120+--

121+-- Since 3.0.0

122+data ResponseReceived = ResponseReceived

123+ deriving Typeable

wai/test/Network/WaiSpec.hsnew file+73

@@ -0,0 +1,73 @@

1+module Network.WaiSpec (spec) where

2+

3+import Test.Hspec

4+import Test.Hspec.QuickCheck (prop)

5+import Network.Wai

6+import Network.Wai.Internal (Request (Request))

7+import Data.IORef

8+import Data.Monoid

9+import qualified Data.ByteString as S

10+import qualified Data.ByteString.Lazy as L

11+import Blaze.ByteString.Builder (toByteString, Builder, fromWord8)

12+import Control.Monad (forM_)

13+

14+spec :: Spec

15+spec = do

16+ describe "responseToStream" $ do

17+ let getBody res = do

18+ let (_, _, f) = responseToStream res

19+ f $ \streamingBody -> do

20+ builderRef <- newIORef mempty

21+ let add :: Builder -> IO ()

22+ add b = atomicModifyIORef builderRef $ \builder ->

23+ (builder `mappend` b, ())

24+ flush :: IO ()

25+ flush = return ()

26+ streamingBody add flush

27+ fmap toByteString $ readIORef builderRef

28+ prop "responseLBS" $ \bytes -> do

29+ body <- getBody $ responseLBS undefined undefined $ L.pack bytes

30+ body `shouldBe` S.pack bytes

31+ prop "responseBuilder" $ \bytes -> do

32+ body <- getBody $ responseBuilder undefined undefined

33+ $ mconcat $ map fromWord8 bytes

34+ body `shouldBe` S.pack bytes

35+ prop "responseStream" $ \chunks -> do

36+ body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

37+ forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk

38+ body `shouldBe` S.concat (map S.pack chunks)

39+ it "responseFile total" $ do

40+ let fp = "wai.cabal"

41+ body <- getBody $ responseFile undefined undefined fp Nothing

42+ expected <- S.readFile fp

43+ body `shouldBe` expected

44+ prop "responseFile partial" $ \offset' count' -> do

45+ let fp = "wai.cabal"

46+ totalBS <- S.readFile fp

47+ let total = S.length totalBS

48+ offset = abs offset' `mod` total

49+ count = abs count' `mod` (total - offset)

50+ body <- getBody $ responseFile undefined undefined fp $ Just FilePart

51+ { filePartOffset = fromIntegral offset

52+ , filePartByteCount = fromIntegral count

53+ , filePartFileSize = fromIntegral total

54+ }

55+ let expected = S.take count $ S.drop offset totalBS

56+ body `shouldBe` expected

57+ describe "lazyRequestBody" $ do

58+ prop "works" $ \chunks -> do

59+ ref <- newIORef $ map S.pack $ filter (not . null) chunks

60+ let req = Request

61+ { requestBody = atomicModifyIORef ref $ \bss ->

62+ case bss of

63+ [] -> ([], S.empty)

64+ x:y -> (y, x)

65+ }

66+ body <- lazyRequestBody req

67+ body `shouldBe` L.fromChunks (map S.pack chunks)

68+ it "is lazy" $ do

69+ let req = Request

70+ { requestBody = error "requestBody"

71+ }

72+ _ <- lazyRequestBody req

73+ return ()

wai/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

wai/wai.cabal+19−5

@@ -1,5 +1,5 @@

1Name: wai

2−Version: 2.1.0.3

2+Version: 3.0.0

3Synopsis: Web Application Interface.

4Description: Provides a common protocol for communication between web applications and web servers.

5License: MIT

@@ -9,7 +9,7 @@ Maintainer: michael@snoyman.com

9Homepage: https://github.com/yesodweb/wai

10Category: Web

11Build-Type: Simple

12−Cabal-Version: >=1.6

12+Cabal-Version: >=1.8

13Stability: Stable

14

15Source-repository head

@@ -20,13 +20,27 @@ Library

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

21 , bytestring >= 0.9.1.4

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

23− , conduit >= 1.0.8 && < 1.2

24− , conduit-extra >= 1.0

25 , network >= 2.2.1.5

23 , network >= 2.2.1.5

26 , http-types >= 0.7

24 , http-types >= 0.7

27 , text >= 0.7

25 , text >= 0.7

28− , transformers >= 0.2.2

29 , vault >= 0.3 && < 0.4

26 , vault >= 0.3 && < 0.4

30 Exposed-modules: Network.Wai

27 Exposed-modules: Network.Wai

31 Network.Wai.Internal

28 Network.Wai.Internal

32 ghc-options: -Wall

29 ghc-options: -Wall

30+

31+test-suite test

32+ hs-source-dirs: test

33+ main-is: Spec.hs

34+ type: exitcode-stdio-1.0

35+ ghc-options: -threaded

36+ cpp-options: -DTEST

37+ build-depends: base

38+ , wai

39+ , hspec

40+ , blaze-builder

41+ , bytestring

42+ other-modules: Network.WaiSpec

43+

44+source-repository head

45+ type: git

46+ location: git://github.com/yesodweb/wai.git

warp-tls/Network/Wai/Handler/WarpTLS.hs+48−39

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

@@ -27,32 +26,24 @@ module Network.Wai.Handler.WarpTLS (

27

26

28import qualified Network.TLS as TLS

27import qualified Network.TLS as TLS

29import Network.Wai.Handler.Warp

28import Network.Wai.Handler.Warp

30−import Network.Wai

29+import Network.Wai (Application)

31−import Network.Socket

30+import Network.Socket (Socket, sClose, withSocketsDo)

32import qualified Data.ByteString.Lazy as L

31import qualified Data.ByteString.Lazy as L

33−import Data.Conduit.Binary (sourceFileRange)

34−import Control.Monad.Trans.Resource (runResourceT)

35−import qualified Data.Conduit as C

36−import qualified Data.Conduit.List as CL

37import Control.Exception (bracket, finally, handle)

32import Control.Exception (bracket, finally, handle)

38import qualified Network.TLS.Extra as TLSExtra

33import qualified Network.TLS.Extra as TLSExtra

39import qualified Data.ByteString as B

34import qualified Data.ByteString as B

40−#if MIN_VERSION_conduit(1,1,0)

41−import Data.Streaming.Network (bindPortTCP, acceptSafe)

35+import Data.Streaming.Network (bindPortTCP, acceptSafe, safeRecv)

42−#else

43−import Data.Conduit.Network (bindPort, acceptSafe)

44−#define bindPortTCP bindPort

45−#endif

46import Control.Applicative ((<$>))

36import Control.Applicative ((<$>))

47−import Data.Conduit.Network (sourceSocket, sinkSocket)

48−import Data.Maybe (fromMaybe)

49import qualified Data.IORef as I

37import qualified Data.IORef as I

50import Control.Exception (Exception, throwIO)

38import Control.Exception (Exception, throwIO)

51import Data.Typeable (Typeable)

39import Data.Typeable (Typeable)

52−import Data.Default.Class

40+import Data.Default.Class (def)

53−import qualified Data.Conduit.Binary as CB

54import qualified Crypto.Random.AESCtr

41import qualified Crypto.Random.AESCtr

55−import Network.Wai.Handler.Warp.Buffer

42+import Network.Wai.Handler.Warp.Buffer (allocateBuffer, bufferSize, freeBuffer)

43+import Network.Socket.ByteString (sendAll)

44+import Control.Monad (unless)

45+import Data.ByteString.Lazy.Internal (defaultChunkSize)

46+import qualified System.IO as IO

56

47

57data TLSSettings = TLSSettings

48data TLSSettings = TLSSettings

58 { certFile :: FilePath

49 { certFile :: FilePath

@@ -127,24 +118,35 @@ runTLSSocket TLSSettings {..} set sock app = do

127 where

118 where

128 getter params = do

119 getter params = do

129 (s, sa) <- acceptSafe sock

120 (s, sa) <- acceptSafe sock

130− let mkConn = do

121+ let mkConn :: IO (Connection, Bool)

131− (fromClient, firstBS) <- sourceSocket s C.$$+ CL.peek

122+ mkConn = do

132− let toClient = sinkSocket s

123+ firstBS <- safeRecv s 4096

133− ifromClient <- I.newIORef fromClient

124+ cachedRef <- I.newIORef firstBS

134− let getNext sink = do

125+ let getNext size = do

135− fromClient' <- I.readIORef ifromClient

126+ cached <- I.readIORef cachedRef

136− (fromClient'', bs) <- fromClient' C.$$++ sink

127+ loop cached

137− I.writeIORef ifromClient fromClient''

128+ where

129+ loop bs | B.length bs >= size = do

130+ let (x, y) = B.splitAt size bs

131+ I.writeIORef cachedRef y

132+ return x

133+ loop bs1 = do

134+ bs2 <- safeRecv s 4096

135+ if B.null bs2

136+ then do

137+ -- FIXME does this deserve an exception being thrown?

138+ I.writeIORef cachedRef B.empty

138− return bs

139+ return bs1

139− if maybe False ((== 0x16) . fst) (firstBS >>= B.uncons)

140+ else loop $ B.append bs1 bs2

141+ if not (B.null firstBS) && B.head firstBS == 0x16

140 then do

142 then do

141 gen <- Crypto.Random.AESCtr.makeSystem

143 gen <- Crypto.Random.AESCtr.makeSystem

142 ctx <- TLS.contextNew

144 ctx <- TLS.contextNew

143 TLS.Backend

145 TLS.Backend

144 { TLS.backendFlush = return ()

146 { TLS.backendFlush = return ()

145 , TLS.backendClose = sClose s

147 , TLS.backendClose = sClose s

146− , TLS.backendSend = \bs -> C.yield bs C.$$ toClient

148+ , TLS.backendSend = sendAll s

147− , TLS.backendRecv = getNext . fmap (B.concat . L.toChunks) . CB.take

149+ , TLS.backendRecv = getNext

148 }

150 }

149 params

151 params

150 gen

152 gen

@@ -157,7 +159,16 @@ runTLSSocket TLSSettings {..} set sock app = do

157 , connSendAll = TLS.sendData ctx . L.fromChunks . return

159 , connSendAll = TLS.sendData ctx . L.fromChunks . return

158 , connSendFile = \fp offset len _th headers -> do

160 , connSendFile = \fp offset len _th headers -> do

159 TLS.sendData ctx $ L.fromChunks headers

161 TLS.sendData ctx $ L.fromChunks headers

162+ IO.withBinaryFile fp IO.ReadMode $ \h -> do

163+ IO.hSeek h IO.AbsoluteSeek offset

164+ let loop remaining | remaining <= 0 = return ()

165+ loop remaining = do

166+ bs <- B.hGetSome h defaultChunkSize

167+ unless (B.null bs) $ do

168+ let x = B.take remaining bs

160− runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)

169+ TLS.sendData ctx $ L.fromChunks [x]

170+ loop $ remaining - B.length x

171+ loop $ fromIntegral len

161 , connClose =

172 , connClose =

162 freeBuffer readBuf `finally`

173 freeBuffer readBuf `finally`

163 freeBuffer writeBuf `finally`

174 freeBuffer writeBuf `finally`

@@ -166,12 +177,12 @@ runTLSSocket TLSSettings {..} set sock app = do

166 , connRecv =

177 , connRecv =

167 let onEOF TLS.Error_EOF = return B.empty

178 let onEOF TLS.Error_EOF = return B.empty

168 onEOF e = throwIO e

179 onEOF e = throwIO e

169− go = handle onEOF $ do

180+ go = do

170 x <- TLS.recvData ctx

181 x <- TLS.recvData ctx

171 if B.null x

182 if B.null x

172 then go

183 then go

173 else return x

184 else return x

174− in go

185+ in handle onEOF go

175 , connSendFileOverride = NotOverride

186 , connSendFileOverride = NotOverride

176 , connReadBuffer = readBuf

187 , connReadBuffer = readBuf

177 , connWriteBuffer = writeBuf

188 , connWriteBuffer = writeBuf

@@ -183,13 +194,11 @@ runTLSSocket TLSSettings {..} set sock app = do

183 AllowInsecure -> do

194 AllowInsecure -> do

184 conn' <- socketConnection s

195 conn' <- socketConnection s

185 return (conn'

196 return (conn'

186− { connRecv = getNext $ fmap (fromMaybe B.empty) C.await

197+ { connRecv = getNext 4096

187 }, False)

198 }, False)

188 DenyInsecure lbs -> do

199 DenyInsecure lbs -> do

189− let src = do

190− C.yield "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"

200+ sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"

191− mapM_ C.yield $ L.toChunks lbs

201+ mapM_ (sendAll s) $ L.toChunks lbs

192− src C.$$ sinkSocket s

193 sClose s

202 sClose s

194 throwIO InsecureConnectionDenied

203 throwIO InsecureConnectionDenied

195 return (mkConn, sa)

204 return (mkConn, sa)

@@ -202,7 +211,7 @@ instance Exception WarpTLSException

202runTLS :: TLSSettings -> Settings -> Application -> IO ()

211runTLS :: TLSSettings -> Settings -> Application -> IO ()

203runTLS tset set app = withSocketsDo $

212runTLS tset set app = withSocketsDo $

204 bracket

213 bracket

205− (bindPortTCP (settingsPort set) (settingsHost set))

214+ (bindPortTCP (getPort set) (getHost set))

206 sClose

215 sClose

207 (\sock -> runTLSSocket tset set sock app)

216 (\sock -> runTLSSocket tset set sock app)

208

217

warp-tls/pong.hs+7−7

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

1{-# LANGUAGE OverloadedStrings #-}

2import Network.Wai

3−import Network.Wai.Handler.Warp (defaultSettings, settingsPort)

3+import Network.Wai.Handler.Warp (defaultSettings, setPort)

4import Network.Wai.Handler.WarpTLS

5import Network.HTTP.Types (status200)

6import Blaze.ByteString.Builder (copyByteString)

@@ -15,9 +15,9 @@ main = do

15 --manager <- newManager def

16 runTLS (tlsSettings "certificate.pem" "key.pem")

17 { onInsecure = AllowInsecure

18− } defaultSettings { settingsPort = 3009 } app

18+ } (setPort 3009 defaultSettings) app

19

20−app req = return $

20+app req f = f $

21 case rawPathInfo req of

22 "/builder/withlen" -> builderWithLen

23 "/builder/nolen" -> builderNoLen

@@ -41,18 +41,18 @@ builderNoLen = responseBuilder

41 ]

42 $ copyByteString "PONG"

43

44−sourceWithLen = responseSource

44+sourceWithLen = responseStream

45 status200

46 [ ("Content-Type", "text/plain")

47 , ("Content-Length", "4")

48 ]

49− $ CL.sourceList [C.Chunk $ copyByteString "PONG"]

49+ $ \sendChunk _flush -> sendChunk $ copyByteString "PONG"

50

51−sourceNoLen = responseSource

51+sourceNoLen = responseStream

52 status200

53 [ ("Content-Type", "text/plain")

54 ]

55− $ CL.sourceList [C.Chunk $ copyByteString "PONG"]

55+ $ \sendChunk _flush -> sendChunk $ copyByteString "PONG"

56

57fileWithLen = responseFile

58 status200

warp-tls/pong.txt+1−1

@@ -1 +1 @@

1−PONG

1+PONG

warp-tls/warp-tls.cabal+3−8

@@ -1,5 +1,5 @@

1Name: warp-tls

2−Version: 2.0.5

2+Version: 3.0.0

3Synopsis: HTTP over SSL/TLS support for Warp via the TLS package

4License: MIT

5License-file: LICENSE

@@ -15,18 +15,13 @@ Description: HTTP over SSL/TLS support for Warp via the TLS package.

15Library

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

17 , bytestring >= 0.9

18− , wai >= 2.0 && < 2.2

18+ , wai >= 3.0 && < 3.1

19− , warp >= 2.1.5 && < 2.2

19+ , warp >= 3.0 && < 3.1

20− , transformers >= 0.2

21− , conduit >= 0.5 && < 1.2

22− , conduit-extra

23− , network-conduit >= 0.6 && < 1.2

24 , data-default-class >= 0.0.1

20 , data-default-class >= 0.0.1

25 , tls >= 1.2.1

21 , tls >= 1.2.1

26 , network >= 2.2.1

22 , network >= 2.2.1

27 , cprng-aes >= 0.5.0

23 , cprng-aes >= 0.5.0

28 , streaming-commons

24 , streaming-commons

29− , resourcet

30 Exposed-modules: Network.Wai.Handler.WarpTLS

25 Exposed-modules: Network.Wai.Handler.WarpTLS

31 ghc-options: -Wall

26 ghc-options: -Wall

32

27

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

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

35 , setOnOpen

36 , setOnClose

37 , setTimeout

38− , setIntercept

39 , setManager

38 , setManager

40 , setFdCacheDuration

39 , setFdCacheDuration

41 , setBeforeMainLoop

40 , setBeforeMainLoop

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

52 , settingsOnOpen

51 , settingsOnOpen

53 , settingsOnClose

52 , settingsOnClose

54 , settingsTimeout

53 , settingsTimeout

55− , settingsIntercept

56 , settingsManager

54 , settingsManager

57 , settingsFdCacheDuration

55 , settingsFdCacheDuration

58 , settingsBeforeMainLoop

56 , settingsBeforeMainLoop

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

87 , sendResponse

85 , sendResponse

88 ) where

86 ) where

89

87

90−import Data.Conduit.Network (HostPreference(..))

91import Network.Wai.Handler.Warp.Date

88import Network.Wai.Handler.Warp.Date

92import Network.Wai.Handler.Warp.FdCache

89import Network.Wai.Handler.Warp.FdCache

93import Network.Wai.Handler.Warp.Header

90import Network.Wai.Handler.Warp.Header

@@ -100,8 +97,8 @@ import Network.Wai.Handler.Warp.Types

100import Control.Exception (SomeException)

97import Control.Exception (SomeException)

101import Network.Wai (Request, Response)

98import Network.Wai (Request, Response)

102import Network.Socket (SockAddr)

99import Network.Socket (SockAddr)

103−import Data.Conduit (Source)

104import Data.ByteString (ByteString)

100import Data.ByteString (ByteString)

101+import Data.Streaming.Network (HostPreference)

105

102

106-- | Port to listen on. Default value: 3000

103-- | Port to listen on. Default value: 3000

107--

104--

@@ -151,16 +148,6 @@ setOnClose x y = y { settingsOnClose = x }

151setTimeout :: Int -> Settings -> Settings

148setTimeout :: Int -> Settings -> Settings

152setTimeout x y = y { settingsTimeout = x }

149setTimeout x y = y { settingsTimeout = x }

153

150

154−-- | Register some intercept handler to deal with specific requests. Prime use

155−-- case: websockets.

156−--

157−-- Default: always return @Nothing@.

158−--

159−-- Since 2.1.0

160−setIntercept :: (Request -> IO (Maybe (Source IO ByteString -> Connection -> IO ())))

161− -> Settings -> Settings

162−setIntercept x y = y { settingsIntercept = x }

163−

164-- | Use an existing timeout manager instead of spawning a new one. If used,

151-- | Use an existing timeout manager instead of spawning a new one. If used,

165-- 'settingsTimeout' is ignored.

152-- 'settingsTimeout' is ignored.

166--

153--

warp/Network/Wai/Handler/Warp/Conduit.hs+98−84

@@ -2,17 +2,12 @@ module Network.Wai.Handler.Warp.Conduit where

2

3import Control.Applicative

4import Control.Exception

5−import Control.Monad (unless)

5+import Control.Monad (when, unless)

6−import Control.Monad.IO.Class (MonadIO, liftIO)

7−import Control.Monad.Trans.Class (lift)

8import Data.ByteString (ByteString)

6import Data.ByteString (ByteString)

9import Data.ByteString.Lazy.Char8 (pack)

7import Data.ByteString.Lazy.Char8 (pack)

10import qualified Data.ByteString as S

8import qualified Data.ByteString as S

9+import qualified Data.ByteString.Char8 as S8

11import qualified Data.ByteString.Lazy as L

10import qualified Data.ByteString.Lazy as L

12−import Data.Conduit

13−import qualified Data.Conduit.Binary as CB

14−import Data.Conduit.Internal (ResumableSource (..))

15−import qualified Data.Conduit.List as CL

16import qualified Data.IORef as I

11import qualified Data.IORef as I

17import Data.Word (Word, Word8)

12import Data.Word (Word, Word8)

18import Network.Wai.Handler.Warp.Types

13import Network.Wai.Handler.Warp.Types

@@ -20,22 +15,29 @@ import Network.Wai.Handler.Warp.Types

20----------------------------------------------------------------

15----------------------------------------------------------------

21

16

22-- | Contains a @Source@ and a byte count that is still to be read in.

17-- | Contains a @Source@ and a byte count that is still to be read in.

23−newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource IO ByteString))

18+data ISource = ISource !Source !(I.IORef Int)

19+

20+mkISource :: Source -> Int -> IO ISource

21+mkISource src cnt = do

22+ ref <- I.newIORef cnt

23+ return $! ISource src ref

24

25-- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the

26-- specified number of bytes to be passed downstream. All leftovers should be

27-- retained within the @Source@. If there are not enough bytes available,

28-- throws a @ConnectionClosedByPeer@ exception.

29−ibsIsolate :: IsolatedBSSource -> Source IO ByteString

29+readISource :: ISource -> IO ByteString

30−ibsIsolate ibs@(IsolatedBSSource ref) = do

30+readISource (ISource src ref) = do

31− (count, src) <- liftIO $ I.readIORef ref

31+ count <- I.readIORef ref

32− unless (count == 0) $ do

32+ if count == 0

33− -- Get the next chunk (if available) and the updated source

33+ then return S.empty

34− (src', mbs) <- lift $ src $$++ CL.head

34+ else do

35+

36+ bs <- readSource src

35

37

36 -- If no chunk available, then there aren't enough bytes in the

38 -- If no chunk available, then there aren't enough bytes in the

37 -- stream. Throw a ConnectionClosedByPeer

39 -- stream. Throw a ConnectionClosedByPeer

38− bs <- maybe (liftIO $ throwIO ConnectionClosedByPeer) return mbs

40+ when (S.null bs) $ throwIO ConnectionClosedByPeer

39

41

40 let -- How many of the bytes in this chunk to send downstream

42 let -- How many of the bytes in this chunk to send downstream

41 toSend = min count (S.length bs)

43 toSend = min count (S.length bs)

@@ -48,16 +50,8 @@ ibsIsolate ibs@(IsolatedBSSource ref) = do

48 -- downstream, and then loop on this function for the

50 -- downstream, and then loop on this function for the

49 -- next chunk.

51 -- next chunk.

50 | count' > 0 -> do

52 | count' > 0 -> do

51− liftIO $ I.writeIORef ref (count', src')

53+ I.writeIORef ref count'

52− yield bs

54+ return bs

53− ibsIsolate ibs

54−

55− -- The expected count is the total size of the chunk we

56− -- just read. Send this chunk downstream, and then

57− -- terminate the stream.

58− | count == S.length bs -> do

59− liftIO $ I.writeIORef ref (count', src')

60− yield bs

61

55

62 -- Some of the bytes in this chunk should not be sent

56 -- Some of the bytes in this chunk should not be sent

63 -- downstream. Split up the chunk into the sent and

57 -- downstream. Split up the chunk into the sent and

@@ -65,84 +59,109 @@ ibsIsolate ibs@(IsolatedBSSource ref) = do

65 -- source, and send the rest of the chunk downstream.

59 -- source, and send the rest of the chunk downstream.

66 | otherwise -> do

60 | otherwise -> do

67 let (x, y) = S.splitAt toSend bs

61 let (x, y) = S.splitAt toSend bs

62+ leftoverSource src y

68− liftIO $ I.writeIORef ref (count', fmapResume (yield y >>) src')

63+ assert (count' == 0) $ I.writeIORef ref count'

69− yield x

64+ return x

70

65

71-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not

66-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not

72-- perform any more isolation.

67-- perform any more isolation.

73−ibsDone :: IsolatedBSSource -> IO (ResumableSource IO ByteString)

68+isourceDone :: ISource -> Source

74−ibsDone (IsolatedBSSource ref) = snd <$> I.readIORef ref

69+isourceDone (ISource src _) = src

75

70

76----------------------------------------------------------------

71----------------------------------------------------------------

77

72

73+data CSource = CSource !Source !(I.IORef ChunkState)

74+

78data ChunkState = NeedLen

75data ChunkState = NeedLen

79 | NeedLenNewline

76 | NeedLenNewline

80 | HaveLen Word

77 | HaveLen Word

78+ | DoneChunking

79+ deriving Show

81

80

82bsCRLF :: L.ByteString

81bsCRLF :: L.ByteString

83bsCRLF = pack "\r\n"

82bsCRLF = pack "\r\n"

84

83

85−chunkedSource :: MonadIO m

84+mkCSource :: Source -> IO CSource

86− => I.IORef (ResumableSource m ByteString, ChunkState)

85+mkCSource src = do

87− -> Source m ByteString

86+ ref <- I.newIORef NeedLen

88−chunkedSource ipair = do

87+ return $! CSource src ref

88+

89+readCSource :: CSource -> IO ByteString

90+readCSource (CSource src ref) = do

89− (src, mlen) <- liftIO $ I.readIORef ipair

91+ mlen <- I.readIORef ref

90− go src mlen

92+ go mlen

91 where

93 where

92− go' src front = do

94+ withLen 0 bs = do

93− (src', (len, bs)) <- lift $ src $$++ front getLen

95+ leftoverSource src bs

94− let src''

96+ dropCRLF

95− | S.null bs = src'

97+ yield' S.empty DoneChunking

98+ withLen len bs

99+ | S.null bs = do

100+ -- FIXME should this throw an exception if len > 0?

101+ I.writeIORef ref DoneChunking

102+ return S.empty

96− | otherwise = fmapResume (yield bs >>) src'

103+ | otherwise =

97− go src'' $ HaveLen len

104+ case S.length bs `compare` fromIntegral len of

98−

105+ EQ -> yield' bs NeedLenNewline

106+ LT -> yield' bs $ HaveLen $ len - fromIntegral (S.length bs)

107+ GT -> do

108+ let (x, y) = S.splitAt (fromIntegral len) bs

109+ leftoverSource src y

110+ yield' x NeedLenNewline

111+

112+ yield' bs mlen = do

113+ I.writeIORef ref mlen

114+ return bs

115+

116+ dropCRLF = do

117+ bs <- readSource src

118+ case S.uncons bs of

119+ Nothing -> return ()

120+ Just (13, bs') -> dropLF bs'

121+ Just (10, bs') -> leftoverSource src bs'

122+ Just _ -> leftoverSource src bs

123+

124+ dropLF bs =

125+ case S.uncons bs of

126+ Nothing -> do

127+ bs2 <- readSource' src

128+ unless (S.null bs2) $ dropLF bs2

129+ Just (10, bs') -> leftoverSource src bs'

130+ Just _ -> leftoverSource src bs

131+

99− go src NeedLen = go' src id

132+ go NeedLen = getLen

100− go src NeedLenNewline = go' src (CB.take 2 >>)

133+ go NeedLenNewline = dropCRLF >> getLen

101− go src (HaveLen 0) = do

134+ go (HaveLen 0) = do

102 -- Drop the final CRLF

135 -- Drop the final CRLF

103− (src', ()) <- lift $ src $$++ do

136+ dropCRLF

104− crlf <- CB.take 2

137+ I.writeIORef ref DoneChunking

105− unless (crlf == bsCRLF) $ leftover $ S.concat $ L.toChunks crlf

138+ return S.empty

106− liftIO $ I.writeIORef ipair (src', HaveLen 0)

107− go src (HaveLen len) = do

139+ go (HaveLen len) = do

108− (src', mbs) <- lift $ src $$++ CL.head

140+ bs <- readSource src

109− case mbs of

141+ withLen len bs

110− Nothing -> liftIO $ I.writeIORef ipair (src', HaveLen 0)

142+ go DoneChunking = return S.empty

111− Just bs ->

143+

112− case S.length bs `compare` fromIntegral len of

144+ -- Get the length from the source, and then pass off control to withLen

113− EQ -> yield' src' NeedLenNewline bs

114− LT -> do

115− let mlen = HaveLen $ len - fromIntegral (S.length bs)

116− yield' src' mlen bs

117− GT -> do

118− let (x, y) = S.splitAt (fromIntegral len) bs

119− let src'' = fmapResume (yield y >>) src'

120− yield' src'' NeedLenNewline x

121−

122− yield' src mlen bs = do

123− liftIO $ I.writeIORef ipair (src, mlen)

124− yield bs

125− go src mlen

126−

127− getLen :: Monad m => Sink ByteString m (Word, ByteString)

128 getLen = do

145 getLen = do

129− mbs <- CL.head

146+ bs <- readSource src

130− case mbs of

147+ if S.null bs

148+ then do

149+ I.writeIORef ref $ assert False $ HaveLen 0

131− Nothing -> return (0, S.empty)

150+ return S.empty

132− Just bs -> do

151+ else do

133 (x, y) <-

152 (x, y) <-

134 case S.breakByte 10 bs of

153 case S.breakByte 10 bs of

135 (x, y)

154 (x, y)

136 | S.null y -> do

155 | S.null y -> do

137− mbs2 <- CL.head

156+ bs2 <- readSource' src

138− case mbs2 of

157+ if S.null bs2

139− Nothing -> return (x, y)

158+ then return (x, y)

140− Just bs2 -> return $ S.breakByte 10 $ bs `S.append` bs2

159+ else return $ S.breakByte 10 $ bs `S.append` bs2

141 | otherwise -> return (x, y)

160 | otherwise -> return (x, y)

142 let w =

161 let w =

143 S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0

162 S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0

144 $ S.takeWhile isHexDigit x

163 $ S.takeWhile isHexDigit x

145− return (w, S.drop 1 y)

164+ withLen w $ S.drop 1 y

146

165

147 hexToWord w

166 hexToWord w

148 | w < 58 = w - 48

167 | w < 58 = w - 48

@@ -153,8 +172,3 @@ isHexDigit :: Word8 -> Bool

153isHexDigit w = w >= 48 && w <= 57

172isHexDigit w = w >= 48 && w <= 57

154 || w >= 65 && w <= 70

173 || w >= 65 && w <= 70

155 || w >= 97 && w <= 102

174 || w >= 97 && w <= 102

156−

157−----------------------------------------------------------------

158−

159−fmapResume :: (Source m o1 -> Source m o2) -> ResumableSource m o1 -> ResumableSource m o2

160−fmapResume f (ResumableSource src m) = ResumableSource (f src) m

warp/Network/Wai/Handler/Warp/Request.hs+65−50

@@ -10,14 +10,12 @@ module Network.Wai.Handler.Warp.Request (

10

11import Control.Applicative

12import qualified Control.Concurrent as Conc (yield)

13−import Control.Exception.Lifted (throwIO)

13+import Control.Exception (throwIO)

14−import Control.Monad.IO.Class (liftIO)

15import Data.Array ((!))

14import Data.Array ((!))

16import Data.ByteString (ByteString)

15import Data.ByteString (ByteString)

17import qualified Data.ByteString as S

16import qualified Data.ByteString as S

18import qualified Data.ByteString.Unsafe as SU

17import qualified Data.ByteString.Unsafe as SU

19import qualified Data.CaseInsensitive as CI

18import qualified Data.CaseInsensitive as CI

20−import Data.Conduit

21import qualified Data.IORef as I

19import qualified Data.IORef as I

22import Data.Monoid (mempty)

20import Data.Monoid (mempty)

23import qualified Network.HTTP.Types as H

21import qualified Network.HTTP.Types as H

@@ -32,6 +30,7 @@ import qualified Network.Wai.Handler.Warp.Timeout as Timeout

32import Network.Wai.Handler.Warp.Types

30import Network.Wai.Handler.Warp.Types

33import Network.Wai.Internal

31import Network.Wai.Internal

34import Prelude hiding (lines)

32import Prelude hiding (lines)

33+import Control.Monad (when)

35

34

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

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

37

36

@@ -47,25 +46,22 @@ recvRequest :: Settings

47 -> Connection

46 -> Connection

48 -> InternalInfo

47 -> InternalInfo

49 -> SockAddr -- ^ Peer's address.

48 -> SockAddr -- ^ Peer's address.

50− -> Source IO ByteString -- ^ Where HTTP request comes from.

49+ -> Source -- ^ Where HTTP request comes from.

51 -> IO (Request

50 -> IO (Request

52− ,IndexedHeader

51+ ,IndexedHeader) -- ^

53− ,IO (ResumableSource IO ByteString)

54− ,Maybe ByteString) -- ^

55 -- 'Request' passed to 'Application',

52 -- 'Request' passed to 'Application',

56 -- 'IndexedHeader' of HTTP request for internal use,

53 -- 'IndexedHeader' of HTTP request for internal use,

57− -- leftover source (i.e. body and other HTTP reqeusts in HTTP pipelining),

58− -- leftovers from request header parsing (used for raw responses)

59

54

60−recvRequest settings conn ii addr src0 = do

55+recvRequest settings conn ii addr src = do

61− (src, (leftover', hdrlines)) <- src0 $$+ headerLines

56+ hdrlines <- headerLines src

62 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

57 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

63 let idxhdr = indexRequestHeader hdr

58 let idxhdr = indexRequestHeader hdr

64 expect = idxhdr ! idxExpect

59 expect = idxhdr ! idxExpect

65 cl = idxhdr ! idxContentLength

60 cl = idxhdr ! idxContentLength

66 te = idxhdr ! idxTransferEncoding

61 te = idxhdr ! idxTransferEncoding

67− liftIO $ handleExpect conn httpversion expect

62+ handleExpect conn httpversion expect

68− (rbody, bodyLength, getSource) <- bodyAndSource src cl te

63+ (rbody, bodyLength) <- bodyAndSource src cl te

64+ rbody' <- timeoutBody th rbody

69 let req = Request {

65 let req = Request {

70 requestMethod = method

66 requestMethod = method

71 , httpVersion = httpversion

67 , httpVersion = httpversion

@@ -76,21 +72,24 @@ recvRequest settings conn ii addr src0 = do

76 , requestHeaders = hdr

72 , requestHeaders = hdr

77 , isSecure = False

73 , isSecure = False

78 , remoteHost = addr

74 , remoteHost = addr

79− , requestBody = timeoutBody th rbody

75+ , requestBody = rbody'

80 , vault = mempty

76 , vault = mempty

81 , requestBodyLength = bodyLength

77 , requestBodyLength = bodyLength

82 , requestHeaderHost = idxhdr ! idxHost

78 , requestHeaderHost = idxhdr ! idxHost

83 , requestHeaderRange = idxhdr ! idxRange

79 , requestHeaderRange = idxhdr ! idxRange

84 }

80 }

85− return (req, idxhdr, getSource, leftover')

81+ return (req, idxhdr)

86 where

82 where

87 th = threadHandle ii

83 th = threadHandle ii

88

84

89----------------------------------------------------------------

85----------------------------------------------------------------

90

86

91−headerLines :: Sink ByteString IO (Maybe ByteString, [ByteString])

87+headerLines :: Source -> IO [ByteString]

92−headerLines =

88+headerLines src = do

89+ bs <- readSource src

90+ if S.null bs

93− await >>= maybe (throwIO (NotEnoughLines [])) (push (THStatus 0 id id))

91+ then throwIO $ NotEnoughLines []

92+ else push src (THStatus 0 id id) bs

94

93

95----------------------------------------------------------------

94----------------------------------------------------------------

96

95

@@ -109,19 +108,19 @@ handleExpect _ _ _ = return ()

109

108

110----------------------------------------------------------------

109----------------------------------------------------------------

111

110

112−bodyAndSource :: ResumableSource IO ByteString

111+bodyAndSource :: Source

113− -> Maybe HeaderValue

112+ -> Maybe HeaderValue -- ^ content length

114− -> Maybe HeaderValue

113+ -> Maybe HeaderValue -- ^ transfer-encoding

115− -> IO (Source IO ByteString

114+ -> IO (IO ByteString

116 ,RequestBodyLength

115 ,RequestBodyLength

117− ,IO (ResumableSource IO ByteString))

116+ )

118bodyAndSource src cl te

117bodyAndSource src cl te

119 | chunked = do

118 | chunked = do

120− ref <- I.newIORef (src, NeedLen)

119+ csrc <- mkCSource src

121− return (chunkedSource ref, ChunkedBody, fst <$> I.readIORef ref)

120+ return (readCSource csrc, ChunkedBody)

122 | otherwise = do

121 | otherwise = do

123− ibs <- IsolatedBSSource <$> I.newIORef (len, src)

122+ isrc <- mkISource src len

124− return (ibsIsolate ibs, bodyLen, ibsDone ibs)

123+ return (readISource isrc, bodyLen)

125 where

124 where

126 len = toLength cl

125 len = toLength cl

127 bodyLen = KnownLength $ fromIntegral len

126 bodyLen = KnownLength $ fromIntegral len

@@ -137,17 +136,28 @@ isChunked _ = False

137

136

138----------------------------------------------------------------

137----------------------------------------------------------------

139

138

140−timeoutBody :: Timeout.Handle -> Source IO ByteString -> Source IO ByteString

139+timeoutBody :: Timeout.Handle -> IO ByteString -> IO (IO ByteString)

141timeoutBody timeoutHandle rbody = do

140timeoutBody timeoutHandle rbody = do

141+ isFirstRef <- I.newIORef True

142+

143+ return $ do

144+ isFirst <- I.readIORef isFirstRef

145+

146+ when isFirst $

142− -- Timeout handling was paused after receiving the full request

147+ -- Timeout handling was paused after receiving the full request

143− -- headers. Now we need to resume it to avoid a slowloris

148+ -- headers. Now we need to resume it to avoid a slowloris

144− -- attack during request body sending.

149+ -- attack during request body sending.

145− liftIO $ Timeout.resume timeoutHandle

150+ Timeout.resume timeoutHandle

151+

152+ bs <- rbody

153+

146− -- As soon as we finish receiving the request body, whether

154+ -- As soon as we finish receiving the request body, whether

147− -- because the application is not interested in more bytes, or

155+ -- because the application is not interested in more bytes, or

148− -- because there is no more data available, pause the timeout

156+ -- because there is no more data available, pause the timeout

149− -- handler again.

157+ -- handler again.

150− addCleanup (const $ liftIO $ Timeout.pause timeoutHandle) rbody

158+ when (S.null bs) (Timeout.pause timeoutHandle)

159+

160+ return bs

151

161

152----------------------------------------------------------------

162----------------------------------------------------------------

153

163

@@ -161,11 +171,13 @@ data THStatus = THStatus

161

171

162----------------------------------------------------------------

172----------------------------------------------------------------

163

173

174+{- FIXME

164close :: Sink ByteString IO a

175close :: Sink ByteString IO a

165close = throwIO IncompleteHeaders

176close = throwIO IncompleteHeaders

177+-}

166

178

167−push :: THStatus -> ByteString -> Sink ByteString IO (Maybe ByteString, [ByteString])

179+push :: Source -> THStatus -> ByteString -> IO [ByteString]

168−push (THStatus len lines prepend) bs'

180+push src (THStatus len lines prepend) bs'

169 -- Too many bytes

181 -- Too many bytes

170 | len > maxTotalHeaderLength = throwIO OverLargeHeader

182 | len > maxTotalHeaderLength = throwIO OverLargeHeader

171 | otherwise = push' mnl

183 | otherwise = push' mnl

@@ -187,15 +199,19 @@ push (THStatus len lines prepend) bs'

187 Just (nl, False)

199 Just (nl, False)

188

200

189 {-# INLINE push' #-}

201 {-# INLINE push' #-}

202+ push' :: Maybe (Int, Bool) -> IO [ByteString]

190 -- No newline find in this chunk. Add it to the prepend,

203 -- No newline find in this chunk. Add it to the prepend,

191 -- update the length, and continue processing.

204 -- update the length, and continue processing.

192− push' Nothing = await >>= maybe close (push status)

205+ push' Nothing = do

206+ bs <- readSource' src

207+ when (S.null bs) $ throwIO IncompleteHeaders

208+ push src status bs

193 where

209 where

194 len' = len + bsLen

210 len' = len + bsLen

195 prepend' = S.append bs

211 prepend' = S.append bs

196 status = THStatus len' lines prepend'

212 status = THStatus len' lines prepend'

197 -- Found a newline, but next line continues as a multiline header

213 -- Found a newline, but next line continues as a multiline header

198− push' (Just (end, True)) = push status rest

214+ push' (Just (end, True)) = push src status rest

199 where

215 where

200 rest = S.drop (end + 1) bs

216 rest = S.drop (end + 1) bs

201 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

217 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

@@ -204,12 +220,9 @@ push (THStatus len lines prepend) bs'

204 -- Found a newline at position end.

220 -- Found a newline at position end.

205 push' (Just (end, False))

221 push' (Just (end, False))

206 -- leftover

222 -- leftover

207− | S.null line = let lines' = lines []

223+ | S.null line = do

208− rest = if start < bsLen then

209− Just (SU.unsafeDrop start bs)

224+ when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs)

210− else

225+ return (lines [])

211− Nothing

212− in maybe (return ()) leftover rest >> return (rest, lines')

213 -- more headers

226 -- more headers

214 | otherwise = let len' = len + start

227 | otherwise = let len' = len + start

215 lines' = lines . (line:)

228 lines' = lines . (line:)

@@ -217,10 +230,12 @@ push (THStatus len lines prepend) bs'

217 in if start < bsLen then

230 in if start < bsLen then

218 -- more bytes in this chunk, push again

231 -- more bytes in this chunk, push again

219 let bs'' = SU.unsafeDrop start bs

232 let bs'' = SU.unsafeDrop start bs

220− in push status bs''

233+ in push src status bs''

221− else

234+ else do

222 -- no more bytes in this chunk, ask for more

235 -- no more bytes in this chunk, ask for more

236+ bs <- readSource' src

237+ when (S.null bs) $ throwIO IncompleteHeaders

223− await >>= maybe close (push status)

238+ push src status bs

224 where

239 where

225 start = end + 1 -- start of next chunk

240 start = end + 1 -- start of next chunk

226 line = SU.unsafeTake (checkCR bs end) bs

241 line = SU.unsafeTake (checkCR bs end) bs

warp/Network/Wai/Handler/Warp/Response.hs+46−68

@@ -15,16 +15,13 @@ import Blaze.ByteString.Builder (fromByteString, Builder, flush)

15import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)

16import Control.Applicative

17import Control.Exception

18−import Control.Monad.IO.Class (liftIO)

19import Data.Array ((!))

18import Data.Array ((!))

20import Data.ByteString (ByteString)

19import Data.ByteString (ByteString)

20+import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy, allocBuffer)

21import qualified Data.ByteString as S

22−import Control.Monad (unless)

22+import Control.Monad (unless, when)

23import qualified Data.ByteString.Char8 as B (pack)

24import qualified Data.CaseInsensitive as CI

25−import Data.Conduit

26−import qualified Data.Conduit.List as CL

27−import Data.Conduit.Blaze (unsafeBuilderToByteString)

28import Data.Function (on)

25import Data.Function (on)

29import Data.List (deleteBy)

26import Data.List (deleteBy)

30import Data.Maybe (isJust, listToMaybe)

27import Data.Maybe (isJust, listToMaybe)

@@ -158,20 +155,19 @@ checkPartRange fileSize = checkPart

158

155

159sendResponse :: Connection

156sendResponse :: Connection

160 -> InternalInfo

157 -> InternalInfo

161− -> (forall a. IO a -> IO a) -- ^ Restore masking state.

162 -> Request -- ^ HTTP request.

158 -> Request -- ^ HTTP request.

163 -> IndexedHeader -- ^ Indexed header of HTTP request.

159 -> IndexedHeader -- ^ Indexed header of HTTP request.

164− -> Maybe ByteString -- ^ leftovers from header parsing

160+ -> IO ByteString -- ^ source from client, for raw response

165 -> Response -- ^ HTTP response including status code and response header.

161 -> Response -- ^ HTTP response including status code and response header.

166 -> IO Bool -- ^ Returing True if the connection is persistent.

162 -> IO Bool -- ^ Returing True if the connection is persistent.

167−sendResponse conn ii restore req reqidxhdr leftover' response = do

163+sendResponse conn ii req reqidxhdr src response = do

168 hs <- addServerAndDate hs0

164 hs <- addServerAndDate hs0

169 if hasBody s req then do

165 if hasBody s req then do

170− sendRsp conn ver s hs restore rsp

166+ sendRsp conn ver s hs rsp

171 T.tickle th

167 T.tickle th

172 return ret

168 return ret

173 else do

169 else do

174− sendResponseNoBody conn ver s hs restore response

170+ sendResponseNoBody conn ver s hs

175 T.tickle th

171 T.tickle th

176 return isPersist

172 return isPersist

177 where

173 where

@@ -188,20 +184,20 @@ sendResponse conn ii restore req reqidxhdr leftover' response = do

188 rsp = case response of

184 rsp = case response of

189 ResponseFile _ _ path mPart -> RspFile path mPart mRange (T.tickle th)

185 ResponseFile _ _ path mPart -> RspFile path mPart mRange (T.tickle th)

190 ResponseBuilder _ _ b -> RspBuilder b needsChunked

186 ResponseBuilder _ _ b -> RspBuilder b needsChunked

191− ResponseSource _ _ fb -> RspSource fb needsChunked th

187+ ResponseStream _ _ fb -> RspStream fb needsChunked th

192− ResponseRaw raw _ -> RspRaw raw leftover' (T.tickle th)

188+ ResponseRaw raw _ -> RspRaw raw src (T.tickle th)

193 ret = case response of

189 ret = case response of

194 ResponseFile {} -> isPersist

190 ResponseFile {} -> isPersist

195 ResponseBuilder {} -> isKeepAlive

191 ResponseBuilder {} -> isKeepAlive

196− ResponseSource {} -> isKeepAlive

192+ ResponseStream {} -> isKeepAlive

197 ResponseRaw {} -> False

193 ResponseRaw {} -> False

198

194

199----------------------------------------------------------------

195----------------------------------------------------------------

200

196

201data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) (IO ())

197data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) (IO ())

202 | RspBuilder Builder Bool

198 | RspBuilder Builder Bool

203− | RspSource (forall b. WithSource IO (Flush Builder) b) Bool T.Handle

199+ | RspStream StreamingBody Bool T.Handle

204− | RspRaw (forall b. WithRawApp b) (Maybe ByteString) (IO ())

200+ | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())

205

201

206----------------------------------------------------------------

202----------------------------------------------------------------

207

203

@@ -209,17 +205,16 @@ sendRsp :: Connection

209 -> H.HttpVersion

205 -> H.HttpVersion

210 -> H.Status

206 -> H.Status

211 -> H.ResponseHeaders

207 -> H.ResponseHeaders

212− -> (forall a. IO a -> IO a) -- ^ restore

213 -> Rsp

208 -> Rsp

214 -> IO ()

209 -> IO ()

215−sendRsp conn ver s0 hs0 restore (RspFile path mPart mRange hook) = restore $ do

210+sendRsp conn ver s0 hs0 (RspFile path mPart mRange hook) = do

216 ex <- fileRange s0 hs path mPart mRange

211 ex <- fileRange s0 hs path mPart mRange

217 case ex of

212 case ex of

218 Left _ex ->

213 Left _ex ->

219#ifdef WARP_DEBUG

214#ifdef WARP_DEBUG

220 print _ex >>

215 print _ex >>

221#endif

216#endif

222− sendRsp conn ver s2 hs2 id (RspBuilder body True)

217+ sendRsp conn ver s2 hs2 (RspBuilder body True)

223 Right (s, hs1, beg, len) -> do

218 Right (s, hs1, beg, len) -> do

224 lheader <- composeHeader ver s hs1

219 lheader <- composeHeader ver s hs1

225 connSendFile conn path beg len hook [lheader]

220 connSendFile conn path beg len hook [lheader]

@@ -231,7 +226,7 @@ sendRsp conn ver s0 hs0 restore (RspFile path mPart mRange hook) = restore $ do

231

226

232----------------------------------------------------------------

227----------------------------------------------------------------

233

228

234−sendRsp conn ver s hs restore (RspBuilder body needsChunked) = restore $ do

229+sendRsp conn ver s hs (RspBuilder body needsChunked) = do

235 header <- composeHeaderBuilder ver s hs needsChunked

230 header <- composeHeaderBuilder ver s hs needsChunked

236 let hdrBdy

231 let hdrBdy

237 | needsChunked = header <> chunkedTransferEncoding body

232 | needsChunked = header <> chunkedTransferEncoding body

@@ -243,37 +238,37 @@ sendRsp conn ver s hs restore (RspBuilder body needsChunked) = restore $ do

243

238

244----------------------------------------------------------------

239----------------------------------------------------------------

245

240

246−sendRsp conn ver s hs restore (RspSource withBodyFlush needsChunked th) =

241+sendRsp conn ver s hs (RspStream withBodyFlush needsChunked th) = do

247− withBodyFlush $ \bodyFlush -> restore $ do

248 header <- composeHeaderBuilder ver s hs needsChunked

242 header <- composeHeaderBuilder ver s hs needsChunked

243+ (recv, finish) <- newBlazeRecv $ reuseBufferStrategy

249− buffer <- toBlazeBuffer (connWriteBuffer conn) (connBufferSize conn)

244+ $ toBlazeBuffer (connWriteBuffer conn) (connBufferSize conn)

250− let src = yield header >> cbody bodyFlush

245+ let addChunk builder = do

246+ popper <- recv builder

247+ let loop = do

248+ bs <- popper

249+ unless (S.null bs) $ do

251− src $$ unsafeBuilderToByteString (return buffer) =$ connSink conn th

250+ connSink conn th bs

252− where

251+ loop

253− cbody bodyFlush = if needsChunked then body $= chunk else body

252+ loop

254− where

253+ addChunk'

255− body = mapOutput (\x -> case x of

254+ | needsChunked = addChunk . chunkedTransferEncoding

256− Flush -> flush

255+ | otherwise = addChunk

257− Chunk builder -> builder)

256+ addChunk header

258− bodyFlush

257+ withBodyFlush addChunk' (addChunk' flush)

259− chunk :: Conduit Builder IO Builder

258+ when needsChunked $ addChunk chunkedTransferTerminator

260− chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)

259+ mbs <- finish

260+ maybe (return ()) (connSink conn th) mbs

261

262----------------------------------------------------------------

263

264−sendRsp conn _ _ _ restore (RspRaw withApp mbs tickle) =

264+sendRsp conn _ _ _ (RspRaw withApp src tickle) =

265− withApp $ \app -> restore $ app src sink

265+ withApp recv send

266 where

267− sink = CL.mapM_ (\bs -> connSendAll conn bs >> tickle)

267+ recv = do

268− src = do

268+ bs <- src

269− maybe (return ()) yield mbs

270− loop

271− where

272− loop = do

273− bs <- liftIO $ connRecv conn

274− unless (S.null bs) $ do

269+ unless (S.null bs) tickle

275− liftIO tickle

270+ return bs

276− yield bs >> loop

271+ send bs = connSendAll conn bs >> tickle

277

272

278----------------------------------------------------------------

273----------------------------------------------------------------

279

274

@@ -281,35 +276,18 @@ sendResponseNoBody :: Connection

281 -> H.HttpVersion

276 -> H.HttpVersion

282 -> H.Status

277 -> H.Status

283 -> H.ResponseHeaders

278 -> H.ResponseHeaders

284− -> (forall a. IO a -> IO a) -- ^ restore

285− -> Response

286 -> IO ()

279 -> IO ()

287−sendResponseNoBody conn ver s hs restore (ResponseSource _ _ withBodyFlush) =

288− withBodyFlush $ \_bodyFlush ->

289− restore $ composeHeader ver s hs >>= connSendAll conn

290−sendResponseNoBody conn ver s hs restore (ResponseRaw withRaw _) =

291− withRaw $ \_raw ->

292− restore $ composeHeader ver s hs >>= connSendAll conn

293−sendResponseNoBody conn ver s hs restore ResponseBuilder{} =

294− restore $ composeHeader ver s hs >>= connSendAll conn

295−sendResponseNoBody conn ver s hs restore ResponseFile{} =

296− restore $ composeHeader ver s hs >>= connSendAll conn

280+sendResponseNoBody conn ver s hs = composeHeader ver s hs >>= connSendAll conn

297

281

298----------------------------------------------------------------

282----------------------------------------------------------------

299----------------------------------------------------------------

283----------------------------------------------------------------

300

284

301-- | Use 'connSendAll' to send this data while respecting timeout rules.

285-- | Use 'connSendAll' to send this data while respecting timeout rules.

302−connSink :: Connection -> T.Handle -> Sink ByteString IO ()

286+connSink :: Connection -> T.Handle -> ByteString -> IO ()

303−connSink Connection { connSendAll = send } th = sink

287+connSink Connection { connSendAll = send } th bs = do

304− where

305− sink = await >>= maybe close push

306− close = liftIO (T.resume th)

288+ T.resume th

307− push x = do

308− liftIO $ do

309− T.resume th

310− send x

289+ send bs

311− T.pause th

290+ T.pause th

312− sink

313 -- We pause timeouts before passing control back to user code. This ensures

291 -- We pause timeouts before passing control back to user code. This ensures

314 -- that a timeout will only ever be executed when Warp is in control. We

292 -- that a timeout will only ever be executed when Warp is in control. We

315 -- also make sure to resume the timeout after the completion of user code

293 -- also make sure to resume the timeout after the completion of user code

warp/Network/Wai/Handler/Warp/Run.hs+50−58

@@ -10,22 +10,14 @@ import Control.Concurrent (threadDelay, forkIOWithUnmask)

10import qualified Control.Concurrent as Conc (yield)

11import Control.Exception as E

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

13−import Control.Monad.IO.Class (liftIO)

14import Data.ByteString (ByteString)

13import Data.ByteString (ByteString)

15import qualified Data.ByteString as S

14import qualified Data.ByteString as S

16−import Data.Conduit

17−import Data.Conduit.Internal (ResumableSource (..))

18−import qualified Data.Conduit.List as CL

19−#if MIN_VERSION_conduit(1,1,0)

20import Data.Streaming.Network (bindPortTCP)

15import Data.Streaming.Network (bindPortTCP)

21−#else

22−import Data.Conduit.Network (bindPort)

23−#define bindPortTCP bindPort

24−#endif

25import Network (sClose, Socket)

16import Network (sClose, Socket)

26import Network.Socket (accept, withSocketsDo, SockAddr)

17import Network.Socket (accept, withSocketsDo, SockAddr)

27import qualified Network.Socket.ByteString as Sock

18import qualified Network.Socket.ByteString as Sock

28import Network.Wai

19import Network.Wai

20+import Network.Wai.Internal (ResponseReceived (ResponseReceived))

29import qualified Network.Wai.Handler.Warp.Date as D

21import qualified Network.Wai.Handler.Warp.Date as D

30import qualified Network.Wai.Handler.Warp.FdCache as F

22import qualified Network.Wai.Handler.Warp.FdCache as F

31import Network.Wai.Handler.Warp.Buffer

23import Network.Wai.Handler.Warp.Buffer

@@ -228,7 +220,8 @@ serveConnection :: Connection

228 -> IO ()

220 -> IO ()

229serveConnection conn ii addr isSecure' settings app = do

221serveConnection conn ii addr isSecure' settings app = do

230 istatus <- newIORef False

222 istatus <- newIORef False

231− recvSendLoop istatus (connSource conn th istatus) `E.catch` \e -> do

223+ src <- mkSource (connSource conn th istatus)

224+ recvSendLoop istatus src `E.catch` \e -> do

232 sendErrorResponse istatus e

225 sendErrorResponse istatus e

233 throwIO (e :: SomeException)

226 throwIO (e :: SomeException)

234

227

@@ -237,66 +230,65 @@ serveConnection conn ii addr isSecure' settings app = do

237

230

238 sendErrorResponse istatus e = do

231 sendErrorResponse istatus e = do

239 status <- readIORef istatus

232 status <- readIORef istatus

240− when status $ void $ mask $ \restore ->

233+ when status $ void $

241− sendResponse conn ii restore dummyreq defaultIndexRequestHeader Nothing (errorResponse e)

234+ sendResponse conn ii dummyreq defaultIndexRequestHeader (return S.empty) (errorResponse e)

242

235

243 dummyreq = defaultRequest { remoteHost = addr }

236 dummyreq = defaultRequest { remoteHost = addr }

244

237

245 errorResponse e = settingsOnExceptionResponse settings e

238 errorResponse e = settingsOnExceptionResponse settings e

246

239

247 recvSendLoop istatus fromClient = do

240 recvSendLoop istatus fromClient = do

248− (req', idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient

241+ (req', idxhdr) <- recvRequest settings conn ii addr fromClient

249 let req = req' { isSecure = isSecure' }

242 let req = req' { isSecure = isSecure' }

250− intercept' <- settingsIntercept settings req

251− case intercept' of

252− Nothing -> do

253− -- Let the application run for as long as it wants

243+ -- Let the application run for as long as it wants

254− T.pause th

244+ T.pause th

255

245

256− -- In the event that some scarce resource was acquired during

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

257− -- creating the request, we need to make sure that we don't get

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

258− -- an async exception before calling the ResponseSource.

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

259− keepAlive <- mask $ \restore -> do

249+ keepAliveRef <- newIORef $ error "keepAliveRef not filled"

260− res <- restore $ app req

250+ _ <- app req $ \res -> do

261− T.resume th

251+ T.resume th

262− -- FIXME consider forcing evaluation of the res here to

252+ -- FIXME consider forcing evaluation of the res here to

263− -- send more meaningful error messages to the user.

253+ -- send more meaningful error messages to the user.

264− -- However, it may affect performance.

254+ -- However, it may affect performance.

265− writeIORef istatus False

255+ writeIORef istatus False

266− sendResponse conn ii restore req idxhdr leftover' res

256+ keepAlive <- sendResponse conn ii req idxhdr (readSource fromClient) res

257+ writeIORef keepAliveRef keepAlive

258+ return ResponseReceived

259+ keepAlive <- readIORef keepAliveRef

267

260

268− -- We just send a Response and it takes a time to

261+ -- We just send a Response and it takes a time to

269− -- receive a Request again. If we immediately call recv,

262+ -- receive a Request again. If we immediately call recv,

270− -- it is likely to fail and the IO manager works.

263+ -- it is likely to fail and the IO manager works.

271− -- It is very costy. So, we yield to another Haskell

264+ -- It is very costy. So, we yield to another Haskell

272− -- thread hoping that the next Request will arraive

265+ -- thread hoping that the next Request will arraive

273− -- when this Haskell thread will be re-scheduled.

266+ -- when this Haskell thread will be re-scheduled.

274− -- This improves performance at least when

267+ -- This improves performance at least when

275− -- the number of cores is small.

268+ -- the number of cores is small.

276− Conc.yield

269+ Conc.yield

277

270

278− when keepAlive $ do

271+ when keepAlive $ do

279− -- flush the rest of the request body

272+ -- flush the rest of the request body

280− requestBody req $$ CL.sinkNull

273+ flushBody $ requestBody req

281− ResumableSource fromClient' _ <- getSource

282− T.resume th

274+ T.resume th

283− recvSendLoop istatus fromClient'

275+ recvSendLoop istatus fromClient

284− Just intercept -> do

285− T.pause th

286− ResumableSource fromClient' _ <- getSource

287− intercept fromClient' conn

288

276

289−connSource :: Connection -> T.Handle -> IORef Bool -> Source IO ByteString

277+flushBody :: IO ByteString -> IO ()

290−connSource Connection { connRecv = recv } th istatus = src

278+flushBody src =

279+ loop

291 where

280 where

292− src = do

281+ loop = do

293− bs <- liftIO recv

282+ bs <- src

294− unless (S.null bs) $ do

283+ unless (S.null bs) loop

295− liftIO $ do

284+

285+connSource :: Connection -> T.Handle -> IORef Bool -> IO ByteString

286+connSource Connection { connRecv = recv } th istatus = do

287+ bs <- recv

288+ unless (S.null bs) $ do

296− writeIORef istatus True

289+ writeIORef istatus True

297− when (S.length bs >= 2048) $ T.tickle th

290+ when (S.length bs >= 2048) $ T.tickle th

298− yield bs

291+ return bs

299− src

300

292

301-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

293-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

302setSocketCloseOnExec :: Socket -> IO ()

294setSocketCloseOnExec :: Socket -> IO ()

warp/Network/Wai/Handler/Warp/Settings.hs+1−5

@@ -8,8 +8,7 @@ import Control.Monad (when)

8import qualified Data.ByteString as S

9import qualified Data.Text as T

10import qualified Data.Text.IO as TIO

11−import Data.Conduit

12−import Data.Conduit.Network (HostPreference)

11+import Data.Streaming.Network (HostPreference)

13import GHC.IO.Exception (IOErrorType(..))

12import GHC.IO.Exception (IOErrorType(..))

14import qualified Network.HTTP.Types as H

13import qualified Network.HTTP.Types as H

15import Network.Socket (SockAddr)

14import Network.Socket (SockAddr)

@@ -40,7 +39,6 @@ data Settings = Settings

40 , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.

39 , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.

41 , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing.

40 , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing.

42 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30

41 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30

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

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

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

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

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

46 , settingsBeforeMainLoop :: IO ()

44 , settingsBeforeMainLoop :: IO ()

@@ -72,7 +70,6 @@ defaultSettings = Settings

72 , settingsOnOpen = const $ return True

70 , settingsOnOpen = const $ return True

73 , settingsOnClose = const $ return ()

71 , settingsOnClose = const $ return ()

74 , settingsTimeout = 30

72 , settingsTimeout = 30

75− , settingsIntercept = const (return Nothing)

76 , settingsManager = Nothing

73 , settingsManager = Nothing

77 , settingsFdCacheDuration = 10

74 , settingsFdCacheDuration = 10

78 , settingsBeforeMainLoop = return ()

75 , settingsBeforeMainLoop = return ()

@@ -112,7 +109,6 @@ exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentT

112{-# DEPRECATED settingsOnOpen "Use setOnOpen instead" #-}

109{-# DEPRECATED settingsOnOpen "Use setOnOpen instead" #-}

113{-# DEPRECATED settingsOnClose "Use setOnClose instead" #-}

110{-# DEPRECATED settingsOnClose "Use setOnClose instead" #-}

114{-# DEPRECATED settingsTimeout "Use setTimeout instead" #-}

111{-# DEPRECATED settingsTimeout "Use setTimeout instead" #-}

115−{-# DEPRECATED settingsIntercept "Use setIntercept instead" #-}

116{-# DEPRECATED settingsManager "Use setManager instead" #-}

112{-# DEPRECATED settingsManager "Use setManager instead" #-}

117{-# DEPRECATED settingsFdCacheDuration "Use setFdCacheDuration instead" #-}

113{-# DEPRECATED settingsFdCacheDuration "Use setFdCacheDuration instead" #-}

118{-# DEPRECATED settingsBeforeMainLoop "Use setBeforeMainLoop instead" #-}

114{-# DEPRECATED settingsBeforeMainLoop "Use setBeforeMainLoop instead" #-}

warp/Network/Wai/Handler/Warp/Types.hs+30

@@ -13,6 +13,8 @@ import qualified Network.Wai.Handler.Warp.Date as D

13import qualified Network.Wai.Handler.Warp.FdCache as F

14import qualified Network.Wai.Handler.Warp.Timeout as T

15import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize)

16+import qualified Data.ByteString as S

17+import Data.IORef (IORef, readIORef, writeIORef, newIORef)

16

18

17----------------------------------------------------------------

19----------------------------------------------------------------

18

20

@@ -88,3 +90,31 @@ data InternalInfo = InternalInfo {

88 , fdCacher :: Maybe F.MutableFdCache

90 , fdCacher :: Maybe F.MutableFdCache

89 , dateCacher :: D.DateCache

91 , dateCacher :: D.DateCache

90 }

92 }

93+

94+----------------------------------------------------------------

95+

96+data Source = Source !(IORef ByteString) !(IO ByteString)

97+

98+mkSource :: IO ByteString -> IO Source

99+mkSource func = do

100+ ref <- newIORef S.empty

101+ return $! Source ref func

102+

103+readSource :: Source -> IO ByteString

104+readSource (Source ref func) = do

105+ bs <- readIORef ref

106+ if S.null bs

107+ then func

108+ else do

109+ writeIORef ref S.empty

110+ return bs

111+

112+-- | Read from a Source, ignoring any leftovers.

113+readSource' :: Source -> IO ByteString

114+readSource' (Source _ func) = func

115+

116+leftoverSource :: Source -> ByteString -> IO ()

117+leftoverSource (Source ref _) bs = writeIORef ref bs

118+

119+readLeftoverSource :: Source -> IO ByteString

120+readLeftoverSource (Source ref _) = readIORef ref

warp/test/ConduitSpec.hs+26−12

@@ -2,10 +2,10 @@

2module ConduitSpec (main, spec) where

3

4import Network.Wai.Handler.Warp.Conduit

5−import Data.Conduit

5+import Network.Wai.Handler.Warp.Types

6−import qualified Data.Conduit.List as CL

6+import Control.Monad (replicateM)

7import Test.Hspec

8−import qualified Data.IORef as I

8+import Data.IORef as I

9import qualified Data.ByteString as S

10

11main :: IO ()

@@ -14,19 +14,33 @@ main = hspec spec

14spec :: Spec

15spec = describe "conduit" $ do

16 it "IsolatedBSSource" $ do

17− (rsrc, ()) <- mapM_ yield (map S.singleton [1..50]) $$+ return ()

17+ ref <- newIORef $ map S.singleton [1..50]

18− ibs <- fmap IsolatedBSSource $ I.newIORef (40, rsrc)

18+ src <- mkSource $ do

19− x <- ibsIsolate ibs $$ CL.take 20

19+ x <- readIORef ref

20+ case x of

21+ [] -> return S.empty

22+ y:z -> do

23+ writeIORef ref z

24+ return y

25+ isrc <- mkISource src 40

26+ x <- replicateM 20 $ readISource isrc

20 S.concat x `shouldBe` S.pack [1..20]

27 S.concat x `shouldBe` S.pack [1..20]

21

28

22− y <- ibsIsolate ibs $$ CL.consume

29+ y <- replicateM 40 $ readISource isrc

23 S.concat y `shouldBe` S.pack [21..40]

30 S.concat y `shouldBe` S.pack [21..40]

24

31

25− rsrc' <- ibsDone ibs

32+ z <- replicateM 40 $ readSource src

26− z <- rsrc' $$+- CL.consume

27 S.concat z `shouldBe` S.pack [41..50]

33 S.concat z `shouldBe` S.pack [41..50]

28 it "chunkedSource" $ do

34 it "chunkedSource" $ do

29− (rsrc, ()) <- yield "5\r\n12345\r\n3\r\n678\r\n0\r\nBLAH" $$+ return ()

35+ ref <- newIORef $ "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH"

30− ref <- I.newIORef (rsrc, NeedLen)

36+ src <- mkSource $ do

31− x <- chunkedSource ref $$ CL.consume

37+ x <- readIORef ref

38+ writeIORef ref S.empty

39+ return x

40+ csrc <- mkCSource src

41+

42+ x <- replicateM 15 $ readCSource csrc

32 S.concat x `shouldBe` "12345678"

43 S.concat x `shouldBe` "12345678"

44+

45+ y <- replicateM 15 $ readSource src

46+ S.concat y `shouldBe` "BLAH"

warp/test/ExceptionSpec.hs+8−8

@@ -30,20 +30,20 @@ withTestServer inner = bracket

30 $ \_ -> inner port

31

32testApp :: Application

33−testApp (Network.Wai.Internal.Request {pathInfo = [x]})

33+testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f

34 | x == "statusError" =

35− return $ responseLBS undefined [] "foo"

35+ f $ responseLBS undefined [] "foo"

36 | x == "headersError" =

37− return $ responseLBS ok200 undefined "foo"

37+ f $ responseLBS ok200 undefined "foo"

38 | x == "headerError" =

39− return $ responseLBS ok200 [undefined] "foo"

39+ f $ responseLBS ok200 [undefined] "foo"

40 | x == "bodyError" =

41− return $ responseLBS ok200 [] undefined

41+ f $ responseLBS ok200 [] undefined

42 | x == "ioException" = do

43 void $ fail "ioException"

44− return $ responseLBS ok200 [] "foo"

44+ f $ responseLBS ok200 [] "foo"

45−testApp _ =

45+testApp _ f =

46− return $ responseLBS ok200 [] "foo"

46+ f $ responseLBS ok200 [] "foo"

47

48spec :: Spec

49spec = describe "responds even if there is an exception" $ do

warp/test/RequestSpec.hs+45−16

@@ -4,17 +4,16 @@

4

5module RequestSpec (main, spec) where

6

7−import Data.Conduit

8−import qualified Data.Conduit.Binary as CB

9−import Data.Conduit.List (sourceList)

10import Network.Wai.Handler.Warp.Request

7import Network.Wai.Handler.Warp.Request

11import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)

8import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)

12import Network.Wai.Handler.Warp.Types

9import Network.Wai.Handler.Warp.Types

13import Test.Hspec

10import Test.Hspec

14import Test.Hspec.QuickCheck

11import Test.Hspec.QuickCheck

12+import qualified Data.ByteString as S

15import qualified Data.ByteString.Char8 as S8

13import qualified Data.ByteString.Char8 as S8

16import qualified Data.ByteString.Lazy as L

14import qualified Data.ByteString.Lazy as L

17import qualified Network.HTTP.Types.Header as HH

15import qualified Network.HTTP.Types.Header as HH

16+import Data.IORef

18

17

19main :: IO ()

18main :: IO ()

20main = hspec spec

19main = hspec spec

@@ -23,9 +22,9 @@ spec :: Spec

23spec = do

22spec = do

24 describe "headerLines" $ do

23 describe "headerLines" $ do

25 it "takes until blank" $

24 it "takes until blank" $

26− blankSafe >>= (`shouldBe` (Nothing, ["foo", "bar", "baz"]))

25+ blankSafe >>= (`shouldBe` ("", ["foo", "bar", "baz"]))

27 it "ignored leading whitespace in bodies" $

26 it "ignored leading whitespace in bodies" $

28− whiteSafe >>= (`shouldBe` (Just " hi there", ["foo", "bar", "baz"]))

27+ whiteSafe >>= (`shouldBe` (" hi there", ["foo", "bar", "baz"]))

29 it "throws OverLargeHeader when too many" $

28 it "throws OverLargeHeader when too many" $

30 tooMany `shouldThrow` overLargeHeader

29 tooMany `shouldThrow` overLargeHeader

31 it "throws OverLargeHeader when too large" $

30 it "throws OverLargeHeader when too large" $

@@ -35,8 +34,9 @@ spec = do

35 [ "GET / HTTP/1.1\r\nConnection: Close\r"

34 [ "GET / HTTP/1.1\r\nConnection: Close\r"

36 , "\n\r\n"

35 , "\n\r\n"

37 ]

36 ]

38− (mleftover, actual) <- mapM_ yield chunks $$ headerLines

37+ (actual, src) <- headerLinesList' chunks

39− mleftover `shouldBe` Nothing

38+ leftover <- readLeftoverSource src

39+ leftover `shouldBe` S.empty

40 actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]

41 prop "random chunking" $ \breaks extraS -> do

42 let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra

@@ -47,11 +47,9 @@ spec = do

47 bs1 : loop xs bs2

48 where

49 (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs

50− (leftover, actual) <- mapM_ yield chunks $$ do

50+ (actual, src) <- headerLinesList' chunks

51− (_, actual) <- headerLines

52− x' <- CB.take (length extraS)

51+ leftover <- consumeLen (length extraS) src

53− let x = S8.concat $ L.toChunks x'

52+

54− return (x, actual)

55 actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]

53 actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]

56 leftover `shouldBe` extra

54 leftover `shouldBe` extra

57 describe "parseByteRanges" $ do

55 describe "parseByteRanges" $ do

@@ -63,10 +61,41 @@ spec = do

63 test "foobytes=9500-" Nothing

61 test "foobytes=9500-" Nothing

64 test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1]

62 test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1]

65 where

63 where

66− blankSafe = (sourceList ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ headerLines

64+ blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"]

67− whiteSafe = (sourceList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]) $$ headerLines

65+ whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]

68− tooMany = (sourceList $ repeat "f\n") $$ headerLines

66+ tooMany = headerLinesList $ repeat "f\n"

69− tooLarge = (sourceList $ repeat "f") $$ headerLines

67+ tooLarge = headerLinesList $ repeat "f"

68+

69+headerLinesList orig = do

70+ (res, src) <- headerLinesList' orig

71+ leftover <- readLeftoverSource src

72+ return (leftover, res)

73+

74+headerLinesList' orig = do

75+ ref <- newIORef orig

76+ let src = do

77+ x <- readIORef ref

78+ case x of

79+ [] -> return S.empty

80+ y:z -> do

81+ writeIORef ref z

82+ return y

83+ src' <- mkSource src

84+ res <- headerLines src'

85+ return (res, src')

86+

87+consumeLen len0 src =

88+ loop id len0

89+ where

90+ loop front len

91+ | len <= 0 = return $ S.concat $ front []

92+ | otherwise = do

93+ bs <- readSource src

94+ if S.null bs

95+ then loop front 0

96+ else do

97+ let (x, y) = S.splitAt len bs

98+ loop (front . (x:)) (len - S.length x)

70

99

71overLargeHeader :: Selector InvalidRequest

100overLargeHeader :: Selector InvalidRequest

72overLargeHeader e = e == OverLargeHeader

101overLargeHeader e = e == OverLargeHeader

warp/test/ResponseSpec.hs+2−2

@@ -36,7 +36,7 @@ testRange range out crange = it title $ withApp defaultSettings app $ \port -> d

36 lookup "Content-Range" hs `shouldBe` Just ("bytes " ++ crange)

37 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

38 where

39− app _ = return $ responseFile status200 [] "attic/hex" Nothing

39+ app _ = ($ responseFile status200 [] "attic/hex" Nothing)

40 title = show (range, out, crange)

41 toHeader s =

42 case break (== ':') s of

@@ -60,7 +60,7 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ \po

60 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

61 lookup "Content-Range" hs `shouldBe` Just range

62 where

63− app _ = return $ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size

63+ app _ = ($ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size)

64 title = show (offset, count, out)

65 toHeader s =

66 case break (== ':') s of

warp/test/RunSpec.hs+68−43

@@ -5,15 +5,14 @@

5module RunSpec (main, spec, withApp) where

6

7import Control.Concurrent (forkIO, killThread, threadDelay)

8−import Control.Monad (forM_, replicateM_)

8+import Control.Monad (forM_, replicateM_, unless)

9import System.Timeout (timeout)

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

11import Data.ByteString (ByteString, hPutStr, hGetSome)

12+import qualified Control.Exception as E

12import qualified Data.ByteString as S

13import qualified Data.ByteString as S

13import qualified Data.ByteString.Char8 as S8

14import qualified Data.ByteString.Char8 as S8

14import qualified Data.ByteString.Lazy as L

15import qualified Data.ByteString.Lazy as L

15−import Data.Conduit (($$), (=$))

16−import qualified Data.Conduit.List

17import qualified Data.IORef as I

16import qualified Data.IORef as I

18import Network (connectTo, PortID (PortNumber))

17import Network (connectTo, PortID (PortNumber))

19import Network.HTTP.Types

18import Network.HTTP.Types

@@ -27,8 +26,6 @@ import Control.Exception.Lifted (bracket, try, IOException, onException)

27import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

26import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

28import Network.Socket (sClose)

27import Network.Socket (sClose)

29import qualified Network.HTTP as HTTP

28import qualified Network.HTTP as HTTP

30−import Data.Conduit (Flush (Chunk), ($=))

31−import qualified Data.Conduit.List as CL

32import Blaze.ByteString.Builder (fromByteString)

29import Blaze.ByteString.Builder (fromByteString)

33import Network.Socket.ByteString (sendAll)

30import Network.Socket.ByteString (sendAll)

34

31

@@ -48,8 +45,8 @@ err :: (MonadIO m, Show a) => Counter -> a -> m ()

48err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

45err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

49

46

50readBody :: CounterApplication

47readBody :: CounterApplication

51−readBody icount req = do

48+readBody icount req f = do

52− body <- requestBody req $$ Data.Conduit.List.consume

49+ body <- consumeBody $ requestBody req

53 case () of

50 case () of

54 ()

51 ()

55 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

52 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

@@ -59,21 +56,21 @@ readBody icount req = do

59 | not $ requestMethod req `elem` ["GET", "POST"]

56 | not $ requestMethod req `elem` ["GET", "POST"]

60 -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)

57 -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)

61 | otherwise -> incr icount

58 | otherwise -> incr icount

62− return $ responseLBS status200 [] "Read the body"

59+ f $ responseLBS status200 [] "Read the body"

63

60

64ignoreBody :: CounterApplication

61ignoreBody :: CounterApplication

65−ignoreBody icount req = do

62+ignoreBody icount req f = do

66 if (requestMethod req `elem` ["GET", "POST"])

63 if (requestMethod req `elem` ["GET", "POST"])

67 then incr icount

64 then incr icount

68 else err icount ("Invalid request method" :: String, requestMethod req)

65 else err icount ("Invalid request method" :: String, requestMethod req)

69− return $ responseLBS status200 [] "Ignored the body"

66+ f $ responseLBS status200 [] "Ignored the body"

70

67

71doubleConnect :: CounterApplication

68doubleConnect :: CounterApplication

72−doubleConnect icount req = do

69+doubleConnect icount req f = do

73− _ <- requestBody req $$ Data.Conduit.List.consume

70+ _ <- consumeBody $ requestBody req

74− _ <- requestBody req $$ Data.Conduit.List.consume

71+ _ <- consumeBody $ requestBody req

75 incr icount

72 incr icount

76− return $ responseLBS status200 [] "double connect"

73+ f $ responseLBS status200 [] "double connect"

77

74

78nextPort :: I.IORef Int

75nextPort :: I.IORef Int

79nextPort = unsafePerformIO $ I.newIORef 5000

76nextPort = unsafePerformIO $ I.newIORef 5000

@@ -117,7 +114,7 @@ runTest expected app chunks = do

117 Right i -> i `shouldBe` expected

114 Right i -> i `shouldBe` expected

118

115

119dummyApp :: Application

116dummyApp :: Application

120−dummyApp _ = return $ responseLBS status200 [] "foo"

117+dummyApp _ f = f $ responseLBS status200 [] "foo"

121

118

122runTerminateTest :: InvalidRequest

119runTerminateTest :: InvalidRequest

123 -> ByteString

120 -> ByteString

@@ -197,9 +194,9 @@ spec = do

197 describe "special input" $ do

194 describe "special input" $ do

198 it "multiline headers" $ do

195 it "multiline headers" $ do

199 iheaders <- I.newIORef []

196 iheaders <- I.newIORef []

200− let app req = do

197+ let app req f = do

201 liftIO $ I.writeIORef iheaders $ requestHeaders req

198 liftIO $ I.writeIORef iheaders $ requestHeaders req

202− return $ responseLBS status200 [] ""

199+ f $ responseLBS status200 [] ""

203 withApp defaultSettings app $ \port -> do

200 withApp defaultSettings app $ \port -> do

204 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

201 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

205 let input = S.concat

202 let input = S.concat

@@ -215,9 +212,9 @@ spec = do

215 ]

212 ]

216 it "no space between colon and value" $ do

213 it "no space between colon and value" $ do

217 iheaders <- I.newIORef []

214 iheaders <- I.newIORef []

218− let app req = do

215+ let app req f = do

219 liftIO $ I.writeIORef iheaders $ requestHeaders req

216 liftIO $ I.writeIORef iheaders $ requestHeaders req

220− return $ responseLBS status200 [] ""

217+ f $ responseLBS status200 [] ""

221 withApp defaultSettings app $ \port -> do

218 withApp defaultSettings app $ \port -> do

222 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

219 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

223 let input = S.concat

220 let input = S.concat

@@ -235,10 +232,10 @@ spec = do

235 describe "chunked bodies" $ do

232 describe "chunked bodies" $ do

236 it "works" $ do

233 it "works" $ do

237 ifront <- I.newIORef id

234 ifront <- I.newIORef id

238− let app req = do

235+ let app req f = do

239− bss <- requestBody req $$ Data.Conduit.List.consume

236+ bss <- consumeBody $ requestBody req

240 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

237 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

241− return $ responseLBS status200 [] ""

238+ f $ responseLBS status200 [] ""

242 withApp defaultSettings app $ \port -> do

239 withApp defaultSettings app $ \port -> do

243 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

240 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

244 let input = S.concat

241 let input = S.concat

@@ -258,10 +255,10 @@ spec = do

258 ]

255 ]

259 it "lots of chunks" $ do

256 it "lots of chunks" $ do

260 ifront <- I.newIORef id

257 ifront <- I.newIORef id

261− let app req = do

258+ let app req f = do

262− bss <- requestBody req $$ Data.Conduit.List.consume

259+ bss <- consumeBody $ requestBody req

263− liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

260+ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

264− return $ responseLBS status200 [] ""

261+ f $ responseLBS status200 [] ""

265 withApp defaultSettings app $ \port -> do

262 withApp defaultSettings app $ \port -> do

266 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

263 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

267 let input = concat $ replicate 2 $

264 let input = concat $ replicate 2 $

@@ -270,15 +267,15 @@ spec = do

270 ["0\r\n\r\n"]

267 ["0\r\n\r\n"]

271 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input

268 mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input

272 hClose handle

269 hClose handle

273− threadDelay 1000

270+ threadDelay 100000 -- FIXME why does this delay need to be so high?

274 front <- I.readIORef ifront

271 front <- I.readIORef ifront

275 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

272 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

276 it "in chunks" $ do

273 it "in chunks" $ do

277 ifront <- I.newIORef id

274 ifront <- I.newIORef id

278− let app req = do

275+ let app req f = do

279− bss <- requestBody req $$ Data.Conduit.List.consume

276+ bss <- consumeBody $ requestBody req

280 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

277 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

281− return $ responseLBS status200 [] ""

278+ f $ responseLBS status200 [] ""

282 withApp defaultSettings app $ \port -> do

279 withApp defaultSettings app $ \port -> do

283 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

280 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

284 let input = S.concat

281 let input = S.concat

@@ -297,13 +294,16 @@ spec = do

297 ]

294 ]

298 it "timeout in request body" $ do

295 it "timeout in request body" $ do

299 ifront <- I.newIORef id

296 ifront <- I.newIORef id

300− let app req = do

297+ let app req f = do

301− bss <- (requestBody req $$ Data.Conduit.List.consume) `onException`

298+ bss <- (consumeBody $ requestBody req) `onException`

302 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

299 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

303− liftIO $ threadDelay 4000000 `onException`

300+ liftIO $ threadDelay 4000000 `E.catch` \e -> do

304− I.atomicModifyIORef ifront (\front -> (front . ("threadDelay interrupted":), ()))

301+ I.atomicModifyIORef ifront (\front ->

302+ ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e):)

303+ , ()))

304+ E.throwIO (e :: E.SomeException)

305 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

306− return $ responseLBS status200 [] ""

306+ f $ responseLBS status200 [] ""

307 withApp (setTimeout 1 defaultSettings) app $ \port -> do

308 let bs1 = S.replicate 2048 88

309 bs2 = "This is short"

@@ -323,12 +323,15 @@ spec = do

323 S.concat (front []) `shouldBe` bs

324 describe "raw body" $ do

325 it "works" $ do

326− let app _req = do

326+ let app _req f = do

327 let backup = responseLBS status200 [] "Not raw"

328− return $ flip responseRaw backup $ \src sink ->

328+ f $ flip responseRaw backup $ \src sink -> do

329− src

329+ let loop = do

330− $$ Data.Conduit.List.map doubleBS

330+ bs <- src

331+ unless (S.null bs) $ do

331− =$ sink

332+ sink $ doubleBS bs

333+ loop

334+ loop

332 doubleBS = S.concatMap $ \w -> S.pack [w, w]

335 doubleBS = S.concatMap $ \w -> S.pack [w, w]

333 withApp defaultSettings app $ \port -> do

336 withApp defaultSettings app $ \port -> do

334 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

337 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

@@ -340,7 +343,7 @@ spec = do

340 timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")

343 timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")

341

344

342 it "only one date and server header" $ do

345 it "only one date and server header" $ do

343− let app _ = return $ responseLBS status200

346+ let app _ f = f $ responseLBS status200

344 [ ("server", "server")

347 [ ("server", "server")

345 , ("date", "date")

348 , ("date", "date")

346 ] ""

349 ] ""

@@ -352,8 +355,13 @@ spec = do

352 `shouldBe` ["date"]

355 `shouldBe` ["date"]

353

356

354 it "streaming echo #249" $ do

357 it "streaming echo #249" $ do

355− let app req = return $ responseSource status200 []

358+ let app req f = f $ responseStream status200 [] $ \write _ -> do

359+ let loop = do

356− $ requestBody req $= CL.map (Chunk . fromByteString)

360+ bs <- requestBody req

361+ unless (S.null bs) $ do

362+ write $ fromByteString bs

363+ loop

364+ loop

357 withApp defaultSettings app $ \port -> do

365 withApp defaultSettings app $ \port -> do

358 (socket, _addr) <- getSocketTCP "127.0.0.1" port

366 (socket, _addr) <- getSocketTCP "127.0.0.1" port

359 sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

367 sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

@@ -361,3 +369,20 @@ spec = do

361 sendAll socket "5\r\nhello\r\n0\r\n\r\n"

369 sendAll socket "5\r\nhello\r\n0\r\n\r\n"

362 bs <- safeRecv socket 4096

370 bs <- safeRecv socket 4096

363 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

371 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

372+

373+ it "streaming response with length" $ do

374+ let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do

375+ replicateM_ 4 $ write $ fromByteString "Hello"

376+ withApp defaultSettings app $ \port -> do

377+ Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)

378+ HTTP.rspBody res `shouldBe` "HelloHelloHelloHello"

379+

380+consumeBody :: IO ByteString -> IO [ByteString]

381+consumeBody body =

382+ loop id

383+ where

384+ loop front = do

385+ bs <- body

386+ if S.null bs

387+ then return $ front []

388+ else loop $ front . (bs:)

warp/warp.cabal+2−12

@@ -1,5 +1,5 @@

1Name: warp

2−Version: 2.1.5.2

2+Version: 3.0.0

3Synopsis: A fast, light-weight web server for WAI applications.

4License: MIT

5License-file: LICENSE

@@ -39,20 +39,14 @@ Library

39 Build-Depends: base >= 3 && < 5

40 , array

41 , blaze-builder >= 0.3.3 && < 0.4

42− , blaze-builder-conduit >= 0.5 && < 1.2

43 , bytestring >= 0.9.1.4

42 , bytestring >= 0.9.1.4

44 , case-insensitive >= 0.2

43 , case-insensitive >= 0.2

45− , conduit >= 0.5 && < 1.2

46− , conduit-extra

47 , ghc-prim

44 , ghc-prim

48 , http-types >= 0.7

45 , http-types >= 0.7

49− , lifted-base >= 0.1

50− , network-conduit >= 0.5 && < 1.2

51 , simple-sendfile >= 0.2.7 && < 0.3

46 , simple-sendfile >= 0.2.7 && < 0.3

52− , transformers >= 0.2.2

53 , unix-compat >= 0.2

47 , unix-compat >= 0.2

54 , void

48 , void

55− , wai >= 2.1 && < 2.2

49+ , wai >= 3.0 && < 3.1

56 , text

50 , text

57 , streaming-commons

51 , streaming-commons

58 if flag(network-bytestring)

52 if flag(network-bytestring)

@@ -126,15 +120,12 @@ Test-Suite spec

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

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

127 , array

121 , array

128 , blaze-builder >= 0.3.3 && < 0.4

122 , blaze-builder >= 0.3.3 && < 0.4

129− , blaze-builder-conduit >= 0.5

130 , bytestring >= 0.9.1.4

123 , bytestring >= 0.9.1.4

131 , case-insensitive >= 0.2

124 , case-insensitive >= 0.2

132− , conduit >= 0.5

133 , ghc-prim

125 , ghc-prim

134 , HTTP

126 , HTTP

135 , http-types >= 0.8.4

127 , http-types >= 0.8.4

136 , lifted-base >= 0.1

128 , lifted-base >= 0.1

137− , network-conduit

138 , simple-sendfile >= 0.2.4 && < 0.3

129 , simple-sendfile >= 0.2.4 && < 0.3

139 , transformers >= 0.2.2

130 , transformers >= 0.2.2

140 , unix-compat >= 0.2

131 , unix-compat >= 0.2

@@ -147,7 +138,6 @@ Test-Suite spec

147 , time

138 , time

148 , old-locale

139 , old-locale

149 , text

140 , text

150− , conduit-extra

151 , streaming-commons >= 0.1.1

141 , streaming-commons >= 0.1.1

152 , async

142 , async

153

143