d996501...master · typeable/wai

.azure/azure-linux-template.yml+8−22

since splitsnapshots

unifiedsplit

@@ -5,16 +5,6 @@ jobs:

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8− stack-def:

9− BUILD: stack

10− stack-lts-6:

11− BUILD: stack

12− STACK_YAML: stack-lts-6.yaml

13− ARGS: "--resolver lts-6"

14− stack-lts-9:

15− BUILD: stack

16− STACK_YAML: stack-lts-9.yaml

17− ARGS: "--resolver lts-9"

18 stack-lts-11:

8 stack-lts-11:

19 BUILD: stack

9 BUILD: stack

20 STACK_YAML: stack-lts-11.yaml

10 STACK_YAML: stack-lts-11.yaml

@@ -23,17 +13,13 @@ jobs:

23 BUILD: stack

13 BUILD: stack

24 STACK_YAML: stack-lts-12.yaml

14 STACK_YAML: stack-lts-12.yaml

25 ARGS: "--resolver lts-12"

15 ARGS: "--resolver lts-12"

26− stack-lts-13:

16+ stack-lts-14:

27 BUILD: stack

17 BUILD: stack

28− ARGS: "--resolver lts-13"

18+ ARGS: "--resolver lts-14"

29− cabal-7.10.3:

19+ stack-nightly:

30− BUILD: cabal

20+ BUILD: stack

31− GHCVER: 7.10.3

21+ STACK_YAML: stack-nightly.yaml

32− CABALVER: 1.22

22+ ARGS: "--resolver nightly"

33− cabal-8.0.2:

34− BUILD: cabal

35− GHCVER: 8.0.2

36− CABALVER: 1.24

37 cabal-8.2.2:

23 cabal-8.2.2:

38 BUILD: cabal

24 BUILD: cabal

39 GHCVER: 8.4.4

25 GHCVER: 8.4.4

@@ -42,9 +28,9 @@ jobs:

42 BUILD: cabal

28 BUILD: cabal

43 GHCVER: 8.4.4

29 GHCVER: 8.4.4

44 CABALVER: 2.2

30 CABALVER: 2.2

45− cabal-8.6.4:

31+ cabal-8.6.5:

46 BUILD: cabal

32 BUILD: cabal

47− GHCVER: 8.6.4

33+ GHCVER: 8.6.5

48 CABALVER: 2.4

34 CABALVER: 2.4

49 maxParallel: 6

35 maxParallel: 6

50 steps:

36 steps:

.azure/azure-osx-template.yml+2−12

@@ -5,16 +5,6 @@ jobs:

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8− stack-def:

9− BUILD: stack

10− stack-lts-6:

11− BUILD: stack

12− STACK_YAML: stack-lts-6.yaml

13− ARGS: "--resolver lts-6"

14− stack-lts-9:

15− BUILD: stack

16− STACK_YAML: stack-lts-9.yaml

17− ARGS: "--resolver lts-9"

18 stack-lts-11:

8 stack-lts-11:

19 BUILD: stack

9 BUILD: stack

20 STACK_YAML: stack-lts-11.yaml

10 STACK_YAML: stack-lts-11.yaml

@@ -23,9 +13,9 @@ jobs:

23 BUILD: stack

13 BUILD: stack

24 STACK_YAML: stack-lts-12.yaml

14 STACK_YAML: stack-lts-12.yaml

25 ARGS: "--resolver lts-12"

15 ARGS: "--resolver lts-12"

26− stack-lts-13:

16+ stack-lts-14:

27 BUILD: stack

17 BUILD: stack

28− ARGS: "--resolver lts-13"

18+ ARGS: "--resolver lts-14"

29 maxParallel: 3

19 maxParallel: 3

30 steps:

20 steps:

31 - script: |

21 - script: |

.azure/azure-windows-template.yml+4−3

@@ -5,9 +5,9 @@ jobs:

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8− stack-lts-13:

8+ stack-lts-14:

9 BUILD: stack

10− ARGS: "--resolver lts-13"

10+ ARGS: "--resolver lts-14"

11 maxParallel: 3

12 steps:

13 - bash: |

@@ -16,7 +16,8 @@ jobs:

16 unzip -o /usr/bin/stack.zip -d /usr/bin/

17 stack setup $ARGS > /dev/null

18 stack --install-ghc $ARGS test --bench --only-dependencies

19− stack $ARGS test --bench --no-run-benchmarks

19+ stack $ARGS test --bench --no-run-benchmarks --no-run-tests

20+ stack $ARGS test --bench --no-run-benchmarks --jobs 1 # non-parallel test execution

20 env:

21 env:

21 OS_NAME: ${{ parameters.os }}

22 OS_NAME: ${{ parameters.os }}

22 displayName: 'Installation ${{parameters.os}} & Test'

23 displayName: 'Installation ${{parameters.os}} & Test'

.gitignore+1

@@ -9,3 +9,4 @@ tarballs/

9cabal.sandbox.config

10.stack-work/

11*~

12+stack*.yaml.lock

stack-lts-11.yaml+3−6

@@ -17,14 +17,11 @@ extra-deps:

17- streaming-commons-0.2.1.0@sha256:163af02944f374f316e35257c1afbffefd2c2852a85a151d1ea0ad22152cf28d,4990

18- http2-2.0.0

19- network-byte-order-0.1.1.0

20+- tls-1.5.3

21+- tls-session-manager-0.0.4

22+- x509-1.7.5

20nix:

23nix:

21 enable: false

24 enable: false

22 packages:

25 packages:

23 - fcgi

26 - fcgi

24 - zlib

27 - zlib

25−image:

26− containers:

27− - base: "fpco/pid1"

28− name: "yesodweb/warp"

29− executables:

30− - warp

stack-lts-12.yaml+3−6

@@ -18,12 +18,9 @@ nix:

18 packages:

19 - fcgi

20 - zlib

21−image:

22− containers:

23− - base: "fpco/pid1"

24− name: "yesodweb/warp"

25− executables:

26− - warp

27extra-deps:

21extra-deps:

28- http2-2.0.0

22- http2-2.0.0

29- network-byte-order-0.1.1.0

23- network-byte-order-0.1.1.0

24+- tls-1.5.3

25+- tls-session-manager-0.0.4

26+- x509-1.7.5

stack-lts-6.yamldeleted−35

@@ -1,35 +0,0 @@

1−resolver: lts-6.35

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−extra-deps:

14−- bsb-http-chunked-0.0.0.2@sha256:0571ef33ec5530104503d32eaf24f2d7c221f350e5fc475a6dd8e84311bc0ca1,1792

15−- streaming-commons-0.2.1.0@sha256:163af02944f374f316e35257c1afbffefd2c2852a85a151d1ea0ad22152cf28d,4990

16−- tls-session-manager-0.0.0.2@sha256:e3d3f8a026196df46746a19d3d7d31211b2fca3aefed9074e951b2dcc1b8833c,872

17−- wai-logger-2.3.2@sha256:7f5dbc72c0753bd3e0e73f8f542d9d159d1d70f8ff3a3ec16d0b74b500534fc6,1572

18−- gauge-0.2.3@sha256:ce41cb66ebf730a5050181db0338b1a4b3f76ac71331bf5070089bcd4352ff46,3777

19−- psqueues-0.2.7.0@sha256:189970837d0aae01f48cd2a8aac6ce314191939e118cc0488aee1fb12da1956a,4757

20−- basement-0.0.7@rev:0

21−- http-client-0.5.13.1@rev:0

22−- http-types-0.12.3@rev:0

23−- http2-2.0.0

24−- network-byte-order-0.1.1.0

25−nix:

26− enable: false

27− packages:

28− - fcgi

29− - zlib

30−image:

31− containers:

32− - base: "fpco/pid1"

33− name: "yesodweb/warp"

34− executables:

35− - warp

stack-lts-9.yamldeleted−31

@@ -1,31 +0,0 @@

1−resolver: lts-9.21

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−extra-deps:

14−- bsb-http-chunked-0.0.0.2@sha256:0571ef33ec5530104503d32eaf24f2d7c221f350e5fc475a6dd8e84311bc0ca1,1792

15−- streaming-commons-0.2.1.0@sha256:163af02944f374f316e35257c1afbffefd2c2852a85a151d1ea0ad22152cf28d,4990

16−- wai-logger-2.3.2@sha256:7f5dbc72c0753bd3e0e73f8f542d9d159d1d70f8ff3a3ec16d0b74b500534fc6,1572

17−- http-client-0.5.13.1@rev:0

18−- http-types-0.12.3@rev:0

19−- http2-2.0.0

20−- network-byte-order-0.1.1.0

21−nix:

22− enable: false

23− packages:

24− - fcgi

25− - zlib

26−image:

27− containers:

28− - base: "fpco/pid1"

29− name: "yesodweb/warp"

30− executables:

31− - warp

stack-nightly.yamlnew file+20

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

1+resolver: nightly-2020-01-08

2+packages:

3+- ./auto-update

4+- ./mime-types

5+- ./wai

6+- ./wai-extra

7+- ./warp

8+- ./warp-tls

9+- ./wai-app-static

10+- ./wai-websockets

11+- ./wai-conduit

12+- ./time-manager

13+flags:

14+ wai-extra:

15+ build-example: true

16+nix:

17+ enable: false

18+ packages:

19+ - fcgi

20+ - zlib

stack.yaml+3−7

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

1−resolver: lts-13.14

1+resolver: lts-14.22

2packages:

3- ./auto-update

4- ./mime-types

@@ -18,12 +18,8 @@ nix:

18 packages:

19 - fcgi

20 - zlib

21−image:

22− containers:

23− - base: "fpco/pid1"

24− name: "yesodweb/warp"

25− executables:

26− - warp

27extra-deps:

21extra-deps:

28- http2-2.0.0

22- http2-2.0.0

29- network-byte-order-0.1.1.0

23- network-byte-order-0.1.1.0

24+- tls-1.5.3

25+- tls-session-manager-0.0.4

wai-app-static/ChangeLog.md+10

@@ -1,3 +1,13 @@

1+# wai-app-static changelog

2+

3+## 3.1.7.1

4+

5+* Update the test suite too

6+

7+## 3.1.7

8+

9+* Use 302 instead of 301 redirect, to avoid caching the presence of an index.html file

10+

1## 3.1.6.3

11## 3.1.6.3

2

12

3* The executable warp obeys `-h` option properly for host

13* The executable warp obeys `-h` option properly for host

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

@@ -164,11 +164,13 @@ serveFile StaticSettings {..} req file

164 -- Didn't match, but we have a hash value. Send the file contents

165 -- with an ETag header.

166 --

167− -- Note: It would be arguably better to next check

167+ -- RFC7232 (HTTP 1.1):

168− -- if-modified-since and return a 304 if that indicates a match as

168+ -- > A recipient MUST ignore If-Modified-Since if the request contains an

169− -- well. However, the circumstances under which such a situation

169+ -- > If-None-Match header field; the condition in If-None-Match is

170− -- could arise would be very anomalous, and should likely warrant a

170+ -- > considered to be a more accurate replacement for the condition in

171− -- new file being sent anyway.

171+ -- > If-Modified-Since, and the two are only combined for the sake of

172+ -- > interoperating with older intermediaries that might not implement

173+ -- > If-None-Match.

172 (Just hash, _) -> respond [("ETag", hash)]

174 (Just hash, _) -> respond [("ETag", hash)]

173

175

174 -- No hash value available, fall back to last modified support.

176 -- No hash value available, fall back to last modified support.

@@ -243,7 +245,7 @@ staticAppPieces ss rawPieces req sendResponse = liftIO $ do

243 response :: StaticResponse -> IO W.ResponseReceived

245 response :: StaticResponse -> IO W.ResponseReceived

244 response (FileResponse file ch) = do

246 response (FileResponse file ch) = do

245 mimetype <- ssGetMimeType ss file

247 mimetype <- ssGetMimeType ss file

246− let filesize = fileGetSize file

248+ -- let filesize = fileGetSize file

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

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

248 -- Let Warp provide the content-length, since it takes

250 -- Let Warp provide the content-length, since it takes

249 -- range requests into account

251 -- range requests into account

@@ -267,13 +269,13 @@ staticAppPieces ss rawPieces req sendResponse = liftIO $ do

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

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

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

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

269

271

270− sendResponse $ W.responseLBS H.status301

272+ sendResponse $ W.responseLBS H.status302

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

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

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

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

273 ] "Redirect"

275 ] "Redirect"

274

276

275 response (RawRedirect path) =

277 response (RawRedirect path) =

276− sendResponse $ W.responseLBS H.status301

278+ sendResponse $ W.responseLBS H.status302

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

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

278 , ("Location", path)

280 , ("Location", path)

279 ] "Redirect"

281 ] "Redirect"

wai-app-static/WaiAppStatic/CmdLine.hs+1

@@ -39,6 +39,7 @@ data Args = Args

39 }

40

41#if MIN_VERSION_optparse_applicative(0, 10, 0)

42+option' :: Mod OptionFields Int -> Parser Int

42option' = option auto

43option' = option auto

43#else

44#else

44option' = option

45option' = option

wai-app-static/WaiAppStatic/Listing.hs+1−1

@@ -64,7 +64,7 @@ defaultListing pieces (Folder contents) = do

64

65 -- Add a link to the root of the tree

66 showFolder' :: Bool -> Pieces -> H.Html

67− showFolder' hasTrailingSlash pieces = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces)

67+ showFolder' hasTrailingSlash pieces' = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces')

68

69 showFolder :: Bool -> Pieces -> H.Html

70 showFolder _ [] = "/" -- won't happen

wai-app-static/WaiAppStatic/Storage/Embedded/TH.hs−1

@@ -7,7 +7,6 @@ module WaiAppStatic.Storage.Embedded.TH(

7

8import Data.ByteString.Builder.Extra (byteStringInsert)

9import Codec.Compression.GZip (compress)

10−import Control.Applicative

11import Data.ByteString.Unsafe (unsafePackAddressLen)

10import Data.ByteString.Unsafe (unsafePackAddressLen)

12import Data.Either (lefts, rights)

11import Data.Either (lefts, rights)

13import GHC.Exts (Int(..))

12import GHC.Exts (Int(..))

wai-app-static/WaiAppStatic/Types.hs+2

@@ -59,6 +59,8 @@ toPieces :: [Text] -> Maybe Pieces

59toPieces = mapM toPiece

60

61-- | Request coming from a user. Corresponds to @pathInfo@.

62+--

63+-- The root path is the empty list.

62type Pieces = [Piece]

64type Pieces = [Piece]

63

65

64-- | Values for the max-age component of the cache-control response header.

66-- | Values for the max-age component of the cache-control response header.

wai-app-static/test/WaiAppStaticTest.hs+8−8

@@ -61,18 +61,18 @@ spec = do

61 assertStatus 404 =<<

62 request (setRawPathInfo defRequest "doesNotExist")

63

64− it "301 redirect when multiple slashes" $ webApp $ do

64+ it "302 redirect when multiple slashes" $ webApp $ do

65 req <- request (setRawPathInfo defRequest "a//b/c")

66− assertStatus 301 req

66+ assertStatus 302 req

67 assertHeader "Location" "../../a/b/c" req

68

69 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {

70 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u

71 }

72− it "301 redirect when multiple slashes" $ absoluteApp $

72+ it "302 redirect when multiple slashes" $ absoluteApp $

73 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do

74 req <- request (setRawPathInfo defRequest path)

75− assertStatus 301 req

75+ assertStatus 302 req

76 assertHeader "Location" "http://www.example.com/a/b/c" req

77

78 describe "webApp when requesting a static asset" $ do

@@ -131,10 +131,10 @@ spec = do

131 assertStatus 304 req

132 assertNoHeader "Cache-Control" req

133

134− context "301 redirect to add a trailing slash on directories if missing" $ do

134+ context "302 redirect to add a trailing slash on directories if missing" $ do

135 it "works at the root" $ fileServerApp $ do

136 req <- request (setRawPathInfo defRequest "/a")

137− assertStatus 301 req

137+ assertStatus 302 req

138 assertHeader "Location" "/a/" req

139

140 it "works when an index.html is delivered" $ do

@@ -144,7 +144,7 @@ spec = do

144 inTempDirectory $ fileServerAppWithSettings settings $ do

145 liftIO $ touch "foo/index.html"

146 req <- request (setRawPathInfo defRequest "/foo")

147− assertStatus 301 req

147+ assertStatus 302 req

148 assertHeader "Location" "/foo/" req

149

150 let urlMapApp = flip runSession $ \req send ->

@@ -158,7 +158,7 @@ spec = do

158 "urlMapApp: only works at subPath"

159 it "works with subpath at the root of the file server" $ urlMapApp $ do

160 req <- request (setRawPathInfo defRequest "/subPath")

161− assertStatus 301 req

161+ assertStatus 302 req

162 assertHeader "Location" "/subPath/" req

163

164 context "with defaultWebAppSettings" $ do

wai-app-static/wai-app-static.cabal+1−1

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

1name: wai-app-static

2−version: 3.1.6.3

2+version: 3.1.7.1

3license: MIT

4license-file: LICENSE

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

wai-conduit/Network/Wai/Conduit.hs+5−6

@@ -17,17 +17,16 @@ import qualified Data.ByteString as S

17import Control.Monad (unless)

18import Network.HTTP.Types

19import Data.ByteString.Builder (Builder)

20−import Data.IORef

21import qualified Data.Conduit.List as CL

20import qualified Data.Conduit.List as CL

22

21

23-- | Stream the request body.

22-- | Stream the request body.

24--

23--

25-- Since 3.0.0

24-- Since 3.0.0

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

25+sourceRequestBody :: MonadIO m => Request -> ConduitT () ByteString m ()

27sourceRequestBody req =

26sourceRequestBody req =

28 loop

27 loop

29 where

28 where

30− go = liftIO (requestBody req)

29+ go = liftIO (getRequestBodyChunk req)

31

30

32 loop = do

31 loop = do

33 bs <- go

32 bs <- go

@@ -38,9 +37,9 @@ sourceRequestBody req =

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

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

39--

38--

40-- Since 3.0.0

39-- Since 3.0.0

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

40+responseSource :: Status -> ResponseHeaders -> ConduitT () (Flush Builder) IO () -> Response

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

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

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

42+ runConduit $ src .| CL.mapM_ (\mbuilder ->

44 case mbuilder of

43 case mbuilder of

45 Chunk b -> send b

44 Chunk b -> send b

46 Flush -> flush)

45 Flush -> flush)

@@ -50,7 +49,7 @@ responseSource s hs src = responseStream s hs $ \send flush ->

50--

49--

51-- Since 3.0.0

50-- Since 3.0.0

52responseRawSource :: (MonadIO m, MonadIO n)

51responseRawSource :: (MonadIO m, MonadIO n)

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

52+ => (ConduitT () ByteString m () -> ConduitT ByteString Void n () -> IO ())

54 -> Response

53 -> Response

55 -> Response

54 -> Response

56responseRawSource app =

55responseRawSource app =

wai-extra/ChangeLog.md+8

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

1# Changelog for wai-extra

2

3+## 3.0.29.1

4+

5+* Fix `Network.Wai.Test.request` always sending an empty request body [#794](https://github.com/yesodweb/wai/pull/794)

6+

7+## 3.0.29

8+

9+* Export `Network.Wai.EventSource.eventStreamAppRaw` [#786](https://github.com/yesodweb/wai/pull/786)

10+

3## 3.0.28

11## 3.0.28

4

12

5* Add `Network.Wai.EventSource.eventStreamAppRaw` [#767](https://github.com/yesodweb/wai/pull/767)

13* Add `Network.Wai.EventSource.eventStreamAppRaw` [#767](https://github.com/yesodweb/wai/pull/767)

wai-extra/Network/Wai/EventSource.hs+2−1

@@ -11,7 +11,8 @@

11module Network.Wai.EventSource (

12 ServerEvent(..),

13 eventSourceAppChan,

14− eventSourceAppIO

14+ eventSourceAppIO,

15+ eventStreamAppRaw

15 ) where

16 ) where

16

17

17import Data.Function (fix)

18import Data.Function (fix)

wai-extra/Network/Wai/Test.hs+22−14

@@ -99,6 +99,10 @@ runSession session app = ST.evalStateT (runReaderT session app) initState

99data SRequest = SRequest

100 { simpleRequest :: Request

101 , simpleRequestBody :: L.ByteString

102+ -- ^ Request body that will override the one set in 'simpleRequest'.

103+ --

104+ -- This is usually simpler than setting the body as a stateful IO-action

105+ -- in 'simpleRequest'.

102 }

106 }

103data SResponse = SResponse

107data SResponse = SResponse

104 { simpleStatus :: H.Status

108 { simpleStatus :: H.Status

@@ -106,8 +110,16 @@ data SResponse = SResponse

106 , simpleBody :: L.ByteString

110 , simpleBody :: L.ByteString

107 }

111 }

108 deriving (Show, Eq)

112 deriving (Show, Eq)

113+

109request :: Request -> Session SResponse

114request :: Request -> Session SResponse

110−request = srequest . flip SRequest L.empty

115+request req = do

116+ app <- ask

117+ req' <- addCookiesToRequest req

118+ response <- liftIO $ do

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

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

121+ readIORef ref

122+ extractSetCookieFromSResponse response

111

123

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

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

113setPath :: Request -> S8.ByteString -> Request

125setPath :: Request -> S8.ByteString -> Request

@@ -166,22 +178,18 @@ extractSetCookieFromSResponse response = do

166 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))

178 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))

167 return response

179 return response

168

180

181+-- | Similar to 'request', but allows setting the request body as a plain

182+-- 'L.ByteString'.

169srequest :: SRequest -> Session SResponse

183srequest :: SRequest -> Session SResponse

170srequest (SRequest req bod) = do

184srequest (SRequest req bod) = do

171− app <- ask

172 refChunks <- liftIO $ newIORef $ L.toChunks bod

185 refChunks <- liftIO $ newIORef $ L.toChunks bod

186+ request $

173− let req' = req

187+ req

174− { requestBody = atomicModifyIORef refChunks $ \bss ->

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

175− case bss of

189+ case bss of

176− [] -> ([], S.empty)

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

177− x:y -> (y, x)

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

178− }

192+ }

179− req'' <- addCookiesToRequest req'

180− response <- liftIO $ do

181− ref <- newIORef $ error "runResponse gave no result"

182− ResponseReceived <- app req'' (runResponse ref)

183− readIORef ref

184− extractSetCookieFromSResponse response

185

193

186runResponse :: IORef SResponse -> Response -> IO ResponseReceived

194runResponse :: IORef SResponse -> Response -> IO ResponseReceived

187runResponse ref res = do

195runResponse ref res = do

wai-extra/example/Main.hs+2−2

@@ -42,10 +42,10 @@ eventRaw = handle 0

42 where

43 handle counter emit flush = do

44 threadDelay 1000000

45− emit $ ServerEvent (Just $ string8 "raw")

45+ _ <- emit $ ServerEvent (Just $ string8 "raw")

46 Nothing

47 [string8 . show $ counter]

48− flush

48+ _ <- flush

49 handle (counter + 1) emit flush

50

51main :: IO ()

wai-extra/test/Network/Wai/TestSpec.hs+41−11

@@ -3,6 +3,8 @@ module Network.Wai.TestSpec (main, spec) where

3

4import Control.Monad (void)

5

6+import qualified Data.IORef as IORef

7+

6import qualified Data.Text.Encoding as TE

8import qualified Data.Text.Encoding as TE

7

9

8import Data.Time.Calendar (fromGregorian)

10import Data.Time.Calendar (fromGregorian)

@@ -53,25 +55,53 @@ spec = do

53 it "sets rawQueryString to empty string" $ do

55 it "sets rawQueryString to empty string" $ do

54 rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""

56 rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""

55

57

58+ describe "srequest" $ do

59+

60+ let echoApp req respond = do

61+ reqBody <- L8.fromStrict <$> getRequestBodyChunk req

62+ let reqHeaders = requestHeaders req

63+ respond $

64+ responseLBS

65+ status200

66+ reqHeaders

67+ reqBody

68+

69+ it "returns the response body of an echo app" $ do

70+ sresp <- flip runSession echoApp $

71+ srequest $ SRequest defaultRequest "request body"

72+ simpleBody sresp `shouldBe` "request body"

73+

56 describe "request" $ do

74 describe "request" $ do

57

75

58− let simpleApp _req respond =

76+ let echoApp req respond = do

77+ reqBody <- L8.fromStrict <$> getRequestBodyChunk req

78+ let reqHeaders = requestHeaders req

59 respond $

79 respond $

60 responseLBS

80 responseLBS

61 status200

81 status200

62− [("foo", "bar")]

82+ reqHeaders

63− "simple"

83+ reqBody

64

84

65− it "returns the status code of a simple app on default request" $ do

85+ it "returns the status code of an echo app on default request" $ do

66− sresp <- runSession (request defaultRequest) simpleApp

86+ sresp <- runSession (request defaultRequest) echoApp

67 simpleStatus sresp `shouldBe` status200

87 simpleStatus sresp `shouldBe` status200

68

88

69− it "returns the response body of a simple app on default request" $ do

89+ it "returns the response body of an echo app" $ do

90+ bodyRef <- IORef.newIORef "request body"

91+ let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover)

92+ sresp <- flip runSession echoApp $

93+ request $

70− sresp <- runSession (request defaultRequest) simpleApp

94+ defaultRequest

95+ { requestBody = getBodyChunk

96+ }

71− simpleBody sresp `shouldBe` "simple"

97+ simpleBody sresp `shouldBe` "request body"

72−

98+

73− it "returns the response headers of a simple app on default request" $ do

99+ it "returns the response headers of an echo app" $ do

100+ sresp <- flip runSession echoApp $

101+ request $

74− sresp <- runSession (request defaultRequest) simpleApp

102+ defaultRequest

103+ { requestHeaders = [("foo", "bar")]

104+ }

75 simpleHeaders sresp `shouldBe` [("foo", "bar")]

105 simpleHeaders sresp `shouldBe` [("foo", "bar")]

76

106

77 let cookieApp req respond =

107 let cookieApp req respond =

wai-extra/wai-extra.cabal+1−1

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

1Name: wai-extra

2−Version: 3.0.28

2+Version: 3.0.29.1

3Synopsis: Provides some basic WAI handlers and middleware.

4description:

5 Provides basic WAI handler and middleware functionality:

wai-websockets/server.lhs+6

@@ -8,6 +8,8 @@ this example, keep the [reference](http://jaspervdj.be/websockets/reference)

8nearby to check out the functions we use.

9

10> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}

11+> {-# LANGUAGE CPP #-}

12+> {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- for numClients

11> import Data.Char (isPunctuation, isSpace)

13> import Data.Char (isPunctuation, isSpace)

12> import Data.Monoid (mappend)

14> import Data.Monoid (mappend)

13> import Data.Text (Text)

15> import Data.Text (Text)

@@ -99,7 +101,11 @@ stays alive on some browsers.

99

101

100> application state pending = do

102> application state pending = do

101> conn <- WS.acceptRequest pending

103> conn <- WS.acceptRequest pending

104+#if __GLASGOW_HASKELL__ >= 806

105+> WS.withPingThread conn 30 (return ()) $ do

106+#else

102> WS.forkPingThread conn 30

107> WS.forkPingThread conn 30

108+#endif

103

109

104When a client is successfully connected, we read the first message. This should

110When a client is successfully connected, we read the first message. This should

105be in the format of "Hi! I am Jasper", where Jasper is the requested username.

111be in the format of "Hi! I am Jasper", where Jasper is the requested username.

wai-websockets/wai-websockets.cabal+1

@@ -45,6 +45,7 @@ Executable wai-websockets-example

45 , text

46 , file-embed

47 , http-types

48+ other-modules: Network.Wai.Handler.WebSockets

48 else

49 else

49 buildable: False

50 buildable: False

50

51

warp-tls/ChangeLog.md+14

@@ -1,3 +1,17 @@

1+## 3.2.11

2+

3+* Ignoring an exception from shutdown (gracefulClose).

4+

5+## 3.2.10

6+

7+* Passing client certificate, if any, to Warp

8+ [#783](https://github.com/yesodweb/wai/pull/783)

9+

10+## 3.2.9

11+

12+* Cooperating setGracefulCloseTimeout1 and setGracefulCloseTimeout2 of Warp.

13+ [#782](https://github.com/yesodweb/wai/pull/782)

14+

1## 3.2.8

15## 3.2.8

2

16

3* Using gracefullClose of network 3.1.1 or later if available.

17* Using gracefullClose of network 3.1.1 or later if available.

warp-tls/Network/Wai/Handler/WarpTLS.hs+21−16

@@ -281,7 +281,7 @@ runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager

281runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

282 runSettingsConnectionMakerSecure set get app

283 where

284− get = getter tlsset sock params

284+ get = getter tlsset set sock params

285 params = def { -- TLS.ServerParams

286 TLS.serverWantClientCert = tlsWantClientCert

287 , TLS.serverCACertificates = []

@@ -322,44 +322,46 @@ alpn xs

322

323----------------------------------------------------------------

324

325−getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

325+getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

326−getter tlsset@TLSSettings{..} sock params = do

326+getter tlsset@TLSSettings{..} set sock params = do

327#if WINDOWS

328 (s, sa) <- windowsThreadBlockHack $ accept sock

329#else

330 (s, sa) <- accept sock

331#endif

332 setSocketCloseOnExec s

333− return (mkConn tlsset s params, sa)

333+ return (mkConn tlsset set s params, sa)

334

335−mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)

335+mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)

336−mkConn tlsset s params = switch `onException` close s

336+mkConn tlsset set s params = switch `onException` close s

337 where

338 switch = do

339 firstBS <- safeRecv s 4096

340 if not (S.null firstBS) && S.head firstBS == 0x16 then

341− httpOverTls tlsset s firstBS params

341+ httpOverTls tlsset set s firstBS params

342 else

343− plainHTTP tlsset s firstBS

343+ plainHTTP tlsset set s firstBS

344

345----------------------------------------------------------------

346

347−httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)

347+httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)

348−httpOverTls TLSSettings{..} s bs0 params = do

348+httpOverTls TLSSettings{..} _set s bs0 params = do

349 recvN <- makePlainReceiveN s bs0

350 ctx <- TLS.contextNew (backend recvN) params

351 TLS.contextHookSetLogging ctx tlsLogging

352 TLS.handshake ctx

353+ h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx

354+ isH2 <- I.newIORef h2

353 writeBuf <- allocateBuffer bufferSize

355 writeBuf <- allocateBuffer bufferSize

354 -- Creating a cache for leftover input data.

356 -- Creating a cache for leftover input data.

355 ref <- I.newIORef ""

357 ref <- I.newIORef ""

356 tls <- getTLSinfo ctx

358 tls <- getTLSinfo ctx

357− return (conn ctx writeBuf ref, tls)

359+ return (conn ctx writeBuf ref isH2, tls)

358 where

360 where

359 backend recvN = TLS.Backend {

361 backend recvN = TLS.Backend {

360 TLS.backendFlush = return ()

362 TLS.backendFlush = return ()

361#if MIN_VERSION_network(3,1,1)

363#if MIN_VERSION_network(3,1,1)

362− , TLS.backendClose = gracefulClose s 5000

364+ , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()

363#else

365#else

364 , TLS.backendClose = close s

366 , TLS.backendClose = close s

365#endif

367#endif

@@ -368,7 +370,7 @@ httpOverTls TLSSettings{..} s bs0 params = do

368 }

370 }

369 sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->

371 sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->

370 throwIO ConnectionClosedByPeer

372 throwIO ConnectionClosedByPeer

371− conn ctx writeBuf ref = Connection {

373+ conn ctx writeBuf ref isH2 = Connection {

372 connSendMany = TLS.sendData ctx . L.fromChunks

374 connSendMany = TLS.sendData ctx . L.fromChunks

373 , connSendAll = sendall

375 , connSendAll = sendall

374 , connSendFile = sendfile

376 , connSendFile = sendfile

@@ -378,6 +380,7 @@ httpOverTls TLSSettings{..} s bs0 params = do

378 , connRecvBuf = recvBuf ref

380 , connRecvBuf = recvBuf ref

379 , connWriteBuffer = writeBuf

381 , connWriteBuffer = writeBuf

380 , connBufferSize = bufferSize

382 , connBufferSize = bufferSize

383+ , connHTTP2 = isH2

381 }

384 }

382 where

385 where

383 sendall = TLS.sendData ctx . L.fromChunks . return

386 sendall = TLS.sendData ctx . L.fromChunks . return

@@ -465,11 +468,13 @@ getTLSinfo ctx = do

465#if MIN_VERSION_tls(1,5,0)

468#if MIN_VERSION_tls(1,5,0)

466 TLS.TLS13 -> (3,4)

469 TLS.TLS13 -> (3,4)

467#endif

470#endif

471+ clientCert <- TLS.getClientCertificateChain ctx

468 return TLS {

472 return TLS {

469 tlsMajorVersion = major

473 tlsMajorVersion = major

470 , tlsMinorVersion = minor

474 , tlsMinorVersion = minor

471 , tlsNegotiatedProtocol = proto

475 , tlsNegotiatedProtocol = proto

472 , tlsChiperID = TLS.cipherID infoCipher

476 , tlsChiperID = TLS.cipherID infoCipher

477+ , tlsClientCertificate = clientCert

473 }

478 }

474

479

475tryIO :: IO a -> IO (Either IOException a)

480tryIO :: IO a -> IO (Either IOException a)

@@ -477,10 +482,10 @@ tryIO = try

477

482

478----------------------------------------------------------------

483----------------------------------------------------------------

479

484

480−plainHTTP :: TLSSettings -> Socket -> S.ByteString -> IO (Connection, Transport)

485+plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)

481−plainHTTP TLSSettings{..} s bs0 = case onInsecure of

486+plainHTTP TLSSettings{..} set s bs0 = case onInsecure of

482 AllowInsecure -> do

487 AllowInsecure -> do

483− conn' <- socketConnection s

488+ conn' <- socketConnection set s

484 cachedRef <- I.newIORef bs0

489 cachedRef <- I.newIORef bs0

485 let conn'' = conn'

490 let conn'' = conn'

486 { connRecv = recvPlain cachedRef (connRecv conn')

491 { connRecv = recvPlain cachedRef (connRecv conn')

warp-tls/warp-tls.cabal+5−5

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

1Name: warp-tls

2−Version: 3.2.8

2+Version: 3.2.11

3Synopsis: HTTP over TLS support for Warp via the TLS package

4License: MIT

5License-file: LICENSE

@@ -18,16 +18,16 @@ description: SSLv1 and SSLv2 are obsoleted by IETF.

18extra-source-files: ChangeLog.md README.md

19

20Library

21− Build-Depends: base >= 4.8 && < 5

21+ Build-Depends: base >= 4.10 && < 5

22 , bytestring >= 0.9

23 , wai >= 3.2 && < 3.3

24− , warp >= 3.2.17 && < 3.4

24+ , warp >= 3.3.6 && < 3.4

25 , data-default-class >= 0.0.1

26− , tls >= 1.3.10

26+ , tls >= 1.5.3

27 , cryptonite >= 0.12

28 , network >= 2.2.1

29 , streaming-commons

30− , tls-session-manager >= 0.0.0.1

30+ , tls-session-manager >= 0.0.4

31 Exposed-modules: Network.Wai.Handler.WarpTLS

32 ghc-options: -Wall

33 if os(windows)

warp/ChangeLog.md+31−1

@@ -1,3 +1,33 @@

1+## 3.3.9

2+

3+* Don't insert Last-Modified: if exists.

4+ [#791](https://github.com/yesodweb/wai/pull/791)

5+

6+## 3.3.8

7+

8+* Maximum header size is configurable.

9+ [#781](https://github.com/yesodweb/wai/pull/781)

10+* Ignoring an exception from shutdown (gracefulClose).

11+

12+## 3.3.7

13+

14+* InvalidArgument (Bad file descriptor) is ignored in `receive`.

15+ [#787](https://github.com/yesodweb/wai/pull/787)

16+

17+## 3.3.6

18+

19+* Fixing a bug of thread killed in the case of event source with

20+ HTTP/2 (fixing #692 and #785)

21+* New APIs: clientCertificate to get client's certificate

22+ [#783](https://github.com/yesodweb/wai/pull/783)

23+

24+## 3.3.5

25+

26+* New APIs: setGracefulCloseTimeout1 and setGracefulCloseTimeout2.

27+ For HTTP/1.x, connections are closed immediately by default.

28+ gracefullClose is used for HTTP/2 by default.

29+ [#782](https://github.com/yesodweb/wai/pull/782)

30+

1## 3.3.4

31## 3.3.4

2

32

3* Setting isSecure of HTTP/2 correctly.

33* Setting isSecure of HTTP/2 correctly.

@@ -20,7 +50,7 @@

20## 3.3.0

50## 3.3.0

21

51

22* Switching from the original implementation to HTTP/2 server library.

52* Switching from the original implementation to HTTP/2 server library.

23− [#752](https://github.com/yesodweb/wai/pull/752)

53+ [#754](https://github.com/yesodweb/wai/pull/754)

24* Breaking change: The type of `http2dataTrailers` is now

54* Breaking change: The type of `http2dataTrailers` is now

25 `HTTP2Data -> TrailersMaker`.

55 `HTTP2Data -> TrailersMaker`.

26

56

warp/Network/Wai/Handler/Warp.hs+50

@@ -72,6 +72,9 @@ module Network.Wai.Handler.Warp (

72 , setLogger

73 , setServerPushLogger

74 , setGracefulShutdownTimeout

75+ , setGracefulCloseTimeout1

76+ , setGracefulCloseTimeout2

77+ , setMaxTotalHeaderLength

75 -- ** Getters

78 -- ** Getters

76 , getPort

79 , getPort

77 , getHost

80 , getHost

@@ -79,6 +82,8 @@ module Network.Wai.Handler.Warp (

79 , getOnClose

82 , getOnClose

80 , getOnException

83 , getOnException

81 , getGracefulShutdownTimeout

84 , getGracefulShutdownTimeout

85+ , getGracefulCloseTimeout1

86+ , getGracefulCloseTimeout2

82 -- ** Exception handler

87 -- ** Exception handler

83 , defaultOnException

88 , defaultOnException

84 , defaultShouldDisplayException

89 , defaultShouldDisplayException

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

93 , pauseTimeout

98 , pauseTimeout

94 , FileInfo(..)

99 , FileInfo(..)

95 , getFileInfo

100 , getFileInfo

101+ , clientCertificate

96 , withApplication

102 , withApplication

97 , withApplicationSettings

103 , withApplicationSettings

98 , testWithApplication

104 , testWithApplication

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

121import Control.Exception (SomeException, throwIO)

127import Control.Exception (SomeException, throwIO)

122import Data.Streaming.Network (HostPreference)

128import Data.Streaming.Network (HostPreference)

123import qualified Data.Vault.Lazy as Vault

129import qualified Data.Vault.Lazy as Vault

130+import Data.X509

124import qualified Network.HTTP.Types as H

131import qualified Network.HTTP.Types as H

125import Network.Socket (SockAddr)

132import Network.Socket (SockAddr)

126import Network.Wai (Request, Response, vault)

133import Network.Wai (Request, Response, vault)

@@ -430,6 +437,13 @@ setGracefulShutdownTimeout :: Maybe Int

430 -> Settings -> Settings

437 -> Settings -> Settings

431setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

432

439

440+-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.

441+--

442+-- Since 3.3.8

443+setMaxTotalHeaderLength :: Int -> Settings -> Settings

444+setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445+ { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446+

433-- | Explicitly pause the slowloris timeout.

447-- | Explicitly pause the slowloris timeout.

434--

448--

435-- This is useful for cases where you partially consume a request body. For

449-- This is useful for cases where you partially consume a request body. For

@@ -457,3 +471,39 @@ pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

457-- Since 3.1.10

471-- Since 3.1.10

458getFileInfo :: Request -> FilePath -> IO FileInfo

472getFileInfo :: Request -> FilePath -> IO FileInfo

459getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

473getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

474+

475+-- | A timeout to limit the time (in milliseconds) waiting for

476+-- FIN for HTTP/1.x. 0 means uses immediate close.

477+-- Default: 0.

478+--

479+-- Since 3.3.5

480+setGracefulCloseTimeout1 :: Int -> Settings -> Settings

481+setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }

482+

483+-- | A timeout to limit the time (in milliseconds) waiting for

484+-- FIN for HTTP/1.x. 0 means uses immediate close.

485+--

486+-- Since 3.3.5

487+getGracefulCloseTimeout1 :: Settings -> Int

488+getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489+

490+-- | A timeout to limit the time (in milliseconds) waiting for

491+-- FIN for HTTP/2. 0 means uses immediate close.

492+-- Default: 2000.

493+--

494+-- Since 3.3.5

495+setGracefulCloseTimeout2 :: Int -> Settings -> Settings

496+setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }

497+

498+-- | A timeout to limit the time (in milliseconds) waiting for

499+-- FIN for HTTP/2. 0 means uses immediate close.

500+--

501+-- Since 3.3.5

502+getGracefulCloseTimeout2 :: Settings -> Int

503+getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504+

505+-- | Getting information of client certificate.

506+--

507+-- Since 3.3.5

508+clientCertificate :: Request -> Maybe CertificateChain

509+clientCertificate = join . Vault.lookup getClientCertificateKey . vault

warp/Network/Wai/Handler/Warp/File.hs+7−4

@@ -34,12 +34,15 @@ data RspFileInfo = WithoutBody H.Status

34----------------------------------------------------------------

35

36conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders -> IndexedHeader

37+ -> H.ResponseHeaders

38+ -> IndexedHeader -- ^ Response

39+ -> IndexedHeader -- ^ Request

38 -> RspFileInfo

40 -> RspFileInfo

39−conditionalRequest finfo hs0 reqidx = case condition of

41+conditionalRequest finfo hs0 rspidx reqidx = case condition of

40 nobody@(WithoutBody _) -> nobody

42 nobody@(WithoutBody _) -> nobody

43+ WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size

44+ !hasLM = isJust $ rspidx ! fromEnum ResLastModified

41− WithBody s _ off len -> let !hs = (H.hLastModified,date) :

45+ !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1

42− addContentHeaders hs0 off len size

43 in WithBody s hs off len

46 in WithBody s hs off len

44 where

47 where

45 !mtime = I.fileInfoTime finfo

48 !mtime = I.fileInfoTime finfo

warp/Network/Wai/Handler/Warp/HTTP2.hs+3−3

@@ -24,14 +24,14 @@ import Network.Wai.Handler.Warp.Types

24

25----------------------------------------------------------------

26

27−http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()

27+http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> (ByteString -> IO ()) -> Application -> IO ()

28−http2 conn transport ii addr settings readN app =

28+http2 conn transport ii addr settings readN send app =

29 H2.run conf http2server

30 where

31 conf = H2.Config {

32 confWriteBuffer = connWriteBuffer conn

33 , confBufferSize = connBufferSize conn

34− , confSendAll = connSendAll conn

34+ , confSendAll = send

35 , confReadN = readN

36 , confPositionReadMaker = pReadMaker ii

37 }

warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+2−1

@@ -22,7 +22,7 @@ import qualified System.TimeManager as T

22

23import Network.Wai.Handler.Warp.HTTP2.Types

24import Network.Wai.Handler.Warp.Imports

25−import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey)

25+import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey, getClientCertificateKey)

26import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

27import Network.Wai.Handler.Warp.Types

28

@@ -83,6 +83,7 @@ toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = retur

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

85 $ Vault.insert pauseTimeoutKey (T.pause th)

86+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

86 Vault.empty

87 Vault.empty

87

88

88getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

89getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

warp/Network/Wai/Handler/Warp/HTTP2/Response.hs+2−1

@@ -72,7 +72,8 @@ responseFile _ rsphdr isHead path Nothing ii reqhdr = do

72 Left (_ex :: E.IOException) -> return $ response404 rsphdr

73 Right finfo -> do

74 let reqidx = indexRequestHeader reqhdr

75+ rspidx = indexResponseHeader rsphdr

75− case conditionalRequest finfo rsphdr reqidx of

76+ case conditionalRequest finfo rsphdr rspidx reqidx of

76 WithoutBody s -> return $ responseNoBody s rsphdr

77 WithoutBody s -> return $ responseNoBody s rsphdr

77 WithBody s rsphdr' off bytes -> do

78 WithBody s rsphdr' off bytes -> do

78 let !off' = fromIntegral off

79 let !off' = fromIntegral off

warp/Network/Wai/Handler/Warp/Header.hs+2

@@ -69,6 +69,7 @@ indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex

69data ResponseHeaderIndex = ResContentLength

70 | ResServer

71 | ResDate

72+ | ResLastModified

72 deriving (Enum,Bounded)

73 deriving (Enum,Bounded)

73

74

74-- | The size for 'IndexedHeader' for HTTP Response.

75-- | The size for 'IndexedHeader' for HTTP Response.

@@ -79,6 +80,7 @@ responseKeyIndex :: HeaderName -> Int

79responseKeyIndex hn = case BS.length bs of

80responseKeyIndex hn = case BS.length bs of

80 4 -> if bs == "date" then fromEnum ResDate else -1

81 4 -> if bs == "date" then fromEnum ResDate else -1

81 6 -> if bs == "server" then fromEnum ResServer else -1

82 6 -> if bs == "server" then fromEnum ResServer else -1

83+ 13 -> if bs == "last-modified" then fromEnum ResLastModified else -1

82 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

84 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

83 _ -> -1

85 _ -> -1

84 where

86 where

warp/Network/Wai/Handler/Warp/Recv.hs+13−1

@@ -17,7 +17,9 @@ import Foreign.C.Types

17import Foreign.ForeignPtr (withForeignPtr)

18import Foreign.Ptr (Ptr, castPtr, plusPtr)

19import GHC.Conc (threadWaitRead)

20+import qualified GHC.IO.Exception as E

20import Network.Socket (Socket)

21import Network.Socket (Socket)

22+import qualified System.IO.Error as E

21#if MIN_VERSION_network(3,1,0)

23#if MIN_VERSION_network(3,1,0)

22import Network.Socket (withFdSocket)

24import Network.Socket (withFdSocket)

23#else

25#else

@@ -94,8 +96,11 @@ spell init0 siz0 recv recvBuf

94 siz' = siz - len

96 siz' = siz - len

95 loop bss' siz'

97 loop bss' siz'

96

98

99+-- The timeout manager may close the socket.

100+-- In that case, an error of "Bad file descriptor" occurs.

101+-- We ignores it because we expect TimeoutThread.

97receive :: Socket -> BufferPool -> Recv

102receive :: Socket -> BufferPool -> Recv

98−receive sock pool = withBufferPool pool $ \ (ptr, size) -> do

103+receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do

99#if MIN_VERSION_network(3,1,0)

104#if MIN_VERSION_network(3,1,0)

100 withFdSocket sock $ \fd -> do

105 withFdSocket sock $ \fd -> do

101#elif MIN_VERSION_network(3,0,0)

106#elif MIN_VERSION_network(3,0,0)

@@ -105,6 +110,11 @@ receive sock pool = withBufferPool pool $ \ (ptr, size) -> do

105#endif

110#endif

106 let size' = fromIntegral size

111 let size' = fromIntegral size

107 fromIntegral <$> receiveloop fd ptr size'

112 fromIntegral <$> receiveloop fd ptr size'

113+ where

114+ handler :: E.IOException -> IO ByteString

115+ handler e

116+ | E.ioeGetErrorType e == E.InvalidArgument = return ""

117+ | otherwise = E.throwIO e

108

118

109receiveBuf :: Socket -> RecvBuf

119receiveBuf :: Socket -> RecvBuf

110receiveBuf sock buf0 siz0 = do

120receiveBuf sock buf0 siz0 = do

@@ -143,6 +153,8 @@ receiveloop sock ptr size = do

143 else

153 else

144 return bytes

154 return bytes

145

155

156+#ifndef mingw32_HOST_OS

146-- fixme: the type of the return value

157-- fixme: the type of the return value

147foreign import ccall unsafe "recv"

158foreign import ccall unsafe "recv"

148 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

159 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

160+#endif

warp/Network/Wai/Handler/Warp/Request.hs+18−17

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

9 , headerLines

10 , pauseTimeoutKey

11 , getFileInfoKey

12+ , getClientCertificateKey

12 , NoKeepAliveRequest (..)

13 , NoKeepAliveRequest (..)

13 ) where

14 ) where

14

15

@@ -21,6 +22,7 @@ import qualified Data.CaseInsensitive as CI

21import qualified Data.IORef as I

22import qualified Data.IORef as I

22import Data.Typeable (Typeable)

23import Data.Typeable (Typeable)

23import qualified Data.Vault.Lazy as Vault

24import qualified Data.Vault.Lazy as Vault

25+import Data.X509

24import qualified Network.HTTP.Types as H

26import qualified Network.HTTP.Types as H

25import Network.Socket (SockAddr)

27import Network.Socket (SockAddr)

26import Network.Wai

28import Network.Wai

@@ -36,13 +38,7 @@ import Network.Wai.Handler.Warp.Header

36import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

38import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

37import Network.Wai.Handler.Warp.ReadInt

39import Network.Wai.Handler.Warp.ReadInt

38import Network.Wai.Handler.Warp.RequestHeader

40import Network.Wai.Handler.Warp.RequestHeader

39−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)

41+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)

40−

41−----------------------------------------------------------------

42−

43−-- FIXME come up with good values here

44−maxTotalHeaderLength :: Int

45−maxTotalHeaderLength = 50 * 1024

46

42

47----------------------------------------------------------------

43----------------------------------------------------------------

48

44

@@ -66,7 +62,7 @@ recvRequest :: Bool -- ^ first request on this connection?

66 -- Body producing action used for flushing the request body

62 -- Body producing action used for flushing the request body

67

63

68recvRequest firstRequest settings conn ii th addr src transport = do

64recvRequest firstRequest settings conn ii th addr src transport = do

69− hdrlines <- headerLines firstRequest src

65+ hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src

70 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

66 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

71 let idxhdr = indexRequestHeader hdr

67 let idxhdr = indexRequestHeader hdr

72 expect = idxhdr ! fromEnum ReqExpect

68 expect = idxhdr ! fromEnum ReqExpect

@@ -76,6 +72,7 @@ recvRequest firstRequest settings conn ii th addr src transport = do

76 rawPath = if settingsNoParsePath settings then unparsedPath else path

72 rawPath = if settingsNoParsePath settings then unparsedPath else path

77 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

73 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

78 $ Vault.insert getFileInfoKey (getFileInfo ii)

74 $ Vault.insert getFileInfoKey (getFileInfo ii)

75+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

79 Vault.empty

76 Vault.empty

80 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te

77 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te

81 -- body producing function which will produce '100-continue', if needed

78 -- body producing function which will produce '100-continue', if needed

@@ -104,8 +101,8 @@ recvRequest firstRequest settings conn ii th addr src transport = do

104

101

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

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

106

103

107−headerLines :: Bool -> Source -> IO [ByteString]

104+headerLines :: Int -> Bool -> Source -> IO [ByteString]

108−headerLines firstRequest src = do

105+headerLines maxTotalHeaderLength firstRequest src = do

109 bs <- readSource src

106 bs <- readSource src

110 if S.null bs

107 if S.null bs

111 -- When we're working on a keep-alive connection and trying to

108 -- When we're working on a keep-alive connection and trying to

@@ -113,7 +110,7 @@ headerLines firstRequest src = do

113 -- lack of data as a real exception. See the http1 function in

110 -- lack of data as a real exception. See the http1 function in

114 -- the Run module for more details.

111 -- the Run module for more details.

115 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

116− else push src (THStatus 0 id id) bs

113+ else push maxTotalHeaderLength src (THStatus 0 id id) bs

117

114

118data NoKeepAliveRequest = NoKeepAliveRequest

115data NoKeepAliveRequest = NoKeepAliveRequest

119 deriving (Show, Typeable)

116 deriving (Show, Typeable)

@@ -223,8 +220,8 @@ close :: Sink ByteString IO a

223close = throwIO IncompleteHeaders

220close = throwIO IncompleteHeaders

224-}

221-}

225

222

226−push :: Source -> THStatus -> ByteString -> IO [ByteString]

223+push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]

227−push src (THStatus len lines prepend) bs'

224+push maxTotalHeaderLength src (THStatus len lines prepend) bs'

228 -- Too many bytes

225 -- Too many bytes

229 | len > maxTotalHeaderLength = throwIO OverLargeHeader

226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

230 | otherwise = push' mnl

227 | otherwise = push' mnl

@@ -252,13 +249,13 @@ push src (THStatus len lines prepend) bs'

252 push' Nothing = do

249 push' Nothing = do

253 bst <- readSource' src

250 bst <- readSource' src

254 when (S.null bst) $ throwIO IncompleteHeaders

251 when (S.null bst) $ throwIO IncompleteHeaders

255− push src status bst

252+ push maxTotalHeaderLength src status bst

256 where

253 where

257 len' = len + bsLen

254 len' = len + bsLen

258 prepend' = S.append bs

255 prepend' = S.append bs

259 status = THStatus len' lines prepend'

256 status = THStatus len' lines prepend'

260 -- Found a newline, but next line continues as a multiline header

257 -- Found a newline, but next line continues as a multiline header

261− push' (Just (end, True)) = push src status rest

258+ push' (Just (end, True)) = push maxTotalHeaderLength src status rest

262 where

259 where

263 rest = S.drop (end + 1) bs

260 rest = S.drop (end + 1) bs

264 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

261 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

@@ -277,12 +274,12 @@ push src (THStatus len lines prepend) bs'

277 in if start < bsLen then

274 in if start < bsLen then

278 -- more bytes in this chunk, push again

275 -- more bytes in this chunk, push again

279 let bs'' = SU.unsafeDrop start bs

276 let bs'' = SU.unsafeDrop start bs

280− in push src status bs''

277+ in push maxTotalHeaderLength src status bs''

281 else do

278 else do

282 -- no more bytes in this chunk, ask for more

279 -- no more bytes in this chunk, ask for more

283 bst <- readSource' src

280 bst <- readSource' src

284 when (S.null bs) $ throwIO IncompleteHeaders

281 when (S.null bs) $ throwIO IncompleteHeaders

285− push src status bst

282+ push maxTotalHeaderLength src status bst

286 where

283 where

287 start = end + 1 -- start of next chunk

284 start = end + 1 -- start of next chunk

288 line = SU.unsafeTake (checkCR bs end) bs

285 line = SU.unsafeTake (checkCR bs end) bs

@@ -300,3 +297,7 @@ pauseTimeoutKey = unsafePerformIO Vault.newKey

300getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

297getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

301getFileInfoKey = unsafePerformIO Vault.newKey

298getFileInfoKey = unsafePerformIO Vault.newKey

302{-# NOINLINE getFileInfoKey #-}

299{-# NOINLINE getFileInfoKey #-}

300+

301+getClientCertificateKey :: Vault.Key (Maybe CertificateChain)

302+getClientCertificateKey = unsafePerformIO Vault.newKey

303+{-# NOINLINE getClientCertificateKey #-}

warp/Network/Wai/Handler/Warp/Response.hs+19−16

@@ -116,14 +116,14 @@ sendResponse settings conn ii th req reqidxhdr src response = do

116 -- and status, the response to HEAD is processed here.

117 --

118 -- See definition of rsp below for proper body stripping.

119− (ms, mlen) <- sendRsp conn ii ver s hs rsp

119+ (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp

120 case ms of

121 Nothing -> return ()

122 Just realStatus -> logger req realStatus mlen

123 T.tickle th

124 return ret

125 else do

126− _ <- sendRsp conn ii ver s hs RspNoBody

126+ _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody

127 logger req s Nothing

128 T.tickle th

129 return isPersist

@@ -196,12 +196,13 @@ sendRsp :: Connection

196 -> H.HttpVersion

197 -> H.Status

198 -> H.ResponseHeaders

199+ -> IndexedHeader -- Response

199 -> Rsp

200 -> Rsp

200 -> IO (Maybe H.Status, Maybe Integer)

201 -> IO (Maybe H.Status, Maybe Integer)

201

202

202----------------------------------------------------------------

203----------------------------------------------------------------

203

204

204−sendRsp conn _ ver s hs RspNoBody = do

205+sendRsp conn _ ver s hs _ RspNoBody = do

205 -- Not adding Content-Length.

206 -- Not adding Content-Length.

206 -- User agents treats it as Content-Length: 0.

207 -- User agents treats it as Content-Length: 0.

207 composeHeader ver s hs >>= connSendAll conn

208 composeHeader ver s hs >>= connSendAll conn

@@ -209,7 +210,7 @@ sendRsp conn _ ver s hs RspNoBody = do

209

210

210----------------------------------------------------------------

211----------------------------------------------------------------

211

212

212−sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

213+sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

213 header <- composeHeaderBuilder ver s hs needsChunked

214 header <- composeHeaderBuilder ver s hs needsChunked

214 let hdrBdy

215 let hdrBdy

215 | needsChunked = header <> chunkedTransferEncoding body

216 | needsChunked = header <> chunkedTransferEncoding body

@@ -222,7 +223,7 @@ sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

222

223

223----------------------------------------------------------------

224----------------------------------------------------------------

224

225

225−sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

226+sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

226 header <- composeHeaderBuilder ver s hs needsChunked

227 header <- composeHeaderBuilder ver s hs needsChunked

227 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

228 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

228 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

@@ -246,7 +247,7 @@ sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

246

247

247----------------------------------------------------------------

248----------------------------------------------------------------

248

249

249−sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

250+sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

250 withApp recv send

251 withApp recv send

251 return (Nothing, Nothing)

252 return (Nothing, Nothing)

252 where

253 where

@@ -260,8 +261,8 @@ sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

260

261

261-- Sophisticated WAI applications.

262-- Sophisticated WAI applications.

262-- We respect s0. s0 MUST be a proper value.

263-- We respect s0. s0 MUST be a proper value.

263−sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =

264+sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

264− sendRspFile2XX conn ii ver s0 hs path beg len isHead hook

265+ sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook

265 where

266 where

266 beg = filePartOffset part

267 beg = filePartOffset part

267 len = filePartByteCount part

268 len = filePartByteCount part

@@ -271,17 +272,17 @@ sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =

271

272

272-- Simple WAI applications.

273-- Simple WAI applications.

273-- Status is ignored

274-- Status is ignored

274−sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do

275+sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do

275 efinfo <- E.try $ getFileInfo ii path

276 efinfo <- E.try $ getFileInfo ii path

276 case efinfo of

277 case efinfo of

277 Left (_ex :: E.IOException) ->

278 Left (_ex :: E.IOException) ->

278#ifdef WARP_DEBUG

279#ifdef WARP_DEBUG

279 print _ex >>

280 print _ex >>

280#endif

281#endif

281− sendRspFile404 conn ii ver hs0

282+ sendRspFile404 conn ii ver hs0 rspidxhdr

282− Right finfo -> case conditionalRequest finfo hs0 idxhdr of

283+ Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of

283− WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody

284+ WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody

284− WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook

285+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

285

286

286----------------------------------------------------------------

287----------------------------------------------------------------

287

288

@@ -290,14 +291,15 @@ sendRspFile2XX :: Connection

290 -> H.HttpVersion

291 -> H.HttpVersion

291 -> H.Status

292 -> H.Status

292 -> H.ResponseHeaders

293 -> H.ResponseHeaders

294+ -> IndexedHeader

293 -> FilePath

295 -> FilePath

294 -> Integer

296 -> Integer

295 -> Integer

297 -> Integer

296 -> Bool

298 -> Bool

297 -> IO ()

299 -> IO ()

298 -> IO (Maybe H.Status, Maybe Integer)

300 -> IO (Maybe H.Status, Maybe Integer)

299−sendRspFile2XX conn ii ver s hs path beg len isHead hook

301+sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

300− | isHead = sendRsp conn ii ver s hs RspNoBody

302+ | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody

301 | otherwise = do

303 | otherwise = do

302 lheader <- composeHeader ver s hs

304 lheader <- composeHeader ver s hs

303 (mfd, fresher) <- getFd ii path

305 (mfd, fresher) <- getFd ii path

@@ -310,8 +312,9 @@ sendRspFile404 :: Connection

310 -> InternalInfo

312 -> InternalInfo

311 -> H.HttpVersion

313 -> H.HttpVersion

312 -> H.ResponseHeaders

314 -> H.ResponseHeaders

315+ -> IndexedHeader

313 -> IO (Maybe H.Status, Maybe Integer)

316 -> IO (Maybe H.Status, Maybe Integer)

314−sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)

317+sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)

315 where

318 where

316 s = H.notFound404

319 s = H.notFound404

317 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

320 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

warp/Network/Wai/Handler/Warp/Run.hs+34−24

@@ -17,7 +17,7 @@ import qualified Control.Concurrent as Conc (yield)

17import Control.Exception as E

18import qualified Data.ByteString as S

19import Data.Char (chr)

20−import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')

20+import Data.IORef (IORef, newIORef, readIORef, writeIORef)

21import Data.Streaming.Network (bindPortTCP)

22import Foreign.C.Error (Errno(..), eCONNABORTED)

23import GHC.IO.Exception (IOException(..))

@@ -58,17 +58,29 @@ import Network.Socket (fdSocket)

58#endif

59

60-- | Creating 'Connection' for plain HTTP based on a given socket.

61−socketConnection :: Socket -> IO Connection

61+socketConnection :: Settings -> Socket -> IO Connection

62+#if MIN_VERSION_network(3,1,1)

63+socketConnection set s = do

64+#else

62−socketConnection s = do

65+socketConnection _ s = do

66+#endif

63 bufferPool <- newBufferPool

67 bufferPool <- newBufferPool

64 writeBuf <- allocateBuffer bufferSize

68 writeBuf <- allocateBuffer bufferSize

65 let sendall = Sock.sendAll s

69 let sendall = Sock.sendAll s

70+ isH2 <- newIORef False -- HTTP/1.x

66 return Connection {

71 return Connection {

67 connSendMany = Sock.sendMany s

72 connSendMany = Sock.sendMany s

68 , connSendAll = sendall

73 , connSendAll = sendall

69 , connSendFile = sendFile s writeBuf bufferSize sendall

74 , connSendFile = sendFile s writeBuf bufferSize sendall

70#if MIN_VERSION_network(3,1,1)

75#if MIN_VERSION_network(3,1,1)

71− , connClose = gracefulClose s 5000

76+ , connClose = do

77+ h2 <- readIORef isH2

78+ let tm = if h2 then settingsGracefulCloseTimeout2 set

79+ else settingsGracefulCloseTimeout1 set

80+ if tm == 0 then

81+ close s

82+ else

83+ gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()

72#else

84#else

73 , connClose = close s

85 , connClose = close s

74#endif

86#endif

@@ -77,6 +89,7 @@ socketConnection s = do

77 , connRecvBuf = receiveBuf s

89 , connRecvBuf = receiveBuf s

78 , connWriteBuffer = writeBuf

90 , connWriteBuffer = writeBuf

79 , connBufferSize = bufferSize

91 , connBufferSize = bufferSize

92+ , connHTTP2 = isH2

80 }

93 }

81

94

82-- | Run an 'Application' on the given port.

95-- | Run an 'Application' on the given port.

@@ -138,7 +151,7 @@ runSettingsSocket set socket app = do

138 setSocketCloseOnExec s

151 setSocketCloseOnExec s

139 -- NoDelay causes an error for AF_UNIX.

152 -- NoDelay causes an error for AF_UNIX.

140 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

141− conn <- socketConnection s

154+ conn <- socketConnection set s

142 return (conn, sa)

155 return (conn, sa)

143

156

144 closeListenSocket = close socket

157 closeListenSocket = close socket

@@ -273,10 +286,7 @@ fork :: Settings

273fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

286fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

274 -- Call the user-supplied on exception code if any

287 -- Call the user-supplied on exception code if any

275 -- exceptions are thrown.

288 -- exceptions are thrown.

276− handle (settingsOnException set Nothing) .

289+ handle (settingsOnException set Nothing) $

277− -- Allocate a new IORef indicating whether the connection has been

278− -- closed, to avoid double-freeing a connection

279− withClosedRef $ \ref ->

280 -- Run the connection maker to get a new connection, and ensure

290 -- Run the connection maker to get a new connection, and ensure

281 -- that the connection is closed. If the mkConn call throws an

291 -- that the connection is closed. If the mkConn call throws an

282 -- exception, we will leak the connection. If the mkConn call is

292 -- exception, we will leak the connection. If the mkConn call is

@@ -287,21 +297,13 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

287 -- We grab the connection before registering timeouts since the

297 -- We grab the connection before registering timeouts since the

288 -- timeouts will be useless during connection creation, due to the

298 -- timeouts will be useless during connection creation, due to the

289 -- fact that async exceptions are still masked.

299 -- fact that async exceptions are still masked.

290− bracket mkConn (cleanUp ref) (serve unmask ref)

300+ bracket mkConn cleanUp (serve unmask)

291 where

301 where

292− withClosedRef inner = newIORef False >>= inner

293−

294− closeConn ref conn = do

295− isClosed <- atomicModifyIORef' ref $ \x -> (True, x)

296− unless isClosed $ connClose conn

297−

298− cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn

302+ cleanUp (conn, _) = connClose conn `finally` connFree conn

299

303

300 -- We need to register a timeout handler for this thread, and

304 -- We need to register a timeout handler for this thread, and

301− -- cancel that handler as soon as we exit. We additionally close

305+ -- cancel that handler as soon as we exit.

302− -- the connection immediately in case the child thread catches the

303− -- async exception or performs some long-running cleanup action.

304− serve unmask ref (conn, transport) = bracket register cancel $ \th -> do

306+ serve unmask (conn, transport) = bracket register cancel $ \th -> do

305 -- We now have fully registered a connection close handler in

307 -- We now have fully registered a connection close handler in

306 -- the case of all exceptions, so it is safe to once again

308 -- the case of all exceptions, so it is safe to once again

307 -- allow async exceptions.

309 -- allow async exceptions.

@@ -313,8 +315,7 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

313 -- above ensures the connection is closed.

315 -- above ensures the connection is closed.

314 when goingon $ serveConnection conn ii th addr transport set app

316 when goingon $ serveConnection conn ii th addr transport set app

315 where

317 where

316− register = T.registerKillThread (timeoutManager ii)

318+ register = T.registerKillThread (timeoutManager ii) (connClose conn)

317− (closeConn ref conn)

318 cancel = T.cancel

319 cancel = T.cancel

319

320

320 onOpen adr = increase counter >> settingsOnOpen set adr

321 onOpen adr = increase counter >> settingsOnOpen set adr

@@ -341,10 +342,19 @@ serveConnection conn ii th origAddr transport settings app = do

341 istatus <- newIORef False

342 istatus <- newIORef False

342 if settingsHTTP2Enabled settings && h2 then do

343 if settingsHTTP2Enabled settings && h2 then do

343 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

345+ -- This thread becomes the sender in http2 library.

346+ -- In the case of event source, one request comes and one

347+ -- worker gets busy. But it is likely that the receiver does

348+ -- not receive any data at all while the sender is sending

349+ -- output data from the worker. It's not good enough to tickle

350+ -- the time handler in the receiver only. So, we should tickle

351+ -- the time handler in both the receiver and the sender.

344 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

352 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

353+ sendBS x = connSendAll conn x >> T.tickle th

345 -- fixme: origAddr

354 -- fixme: origAddr

346 checkTLS

355 checkTLS

356+ setConnHTTP2 conn True

347− http2 conn transport ii origAddr settings recvN app

357+ http2 conn transport ii origAddr settings recvN sendBS app

348 else do

358 else do

349 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

350 writeIORef istatus True

360 writeIORef istatus True

warp/Network/Wai/Handler/Warp/Settings.hs+31−5

@@ -76,6 +76,13 @@ data Settings = Settings

76 --

77 -- Since 2.0.3

78 , settingsInstallShutdownHandler :: IO () -> IO ()

79+ -- ^ An action to install a handler (e.g. Unix signal handler)

80+ -- to close a listen socket.

81+ -- The first argument is an action to close the listen socket.

82+ --

83+ -- Default: no action

84+ --

85+ -- Since 3.0.1

79 , settingsServerName :: ByteString

86 , settingsServerName :: ByteString

80 -- ^ Default server name if application does not set one.

87 -- ^ Default server name if application does not set one.

81 --

88 --

@@ -87,28 +94,44 @@ data Settings = Settings

87 , settingsProxyProtocol :: ProxyProtocol

94 , settingsProxyProtocol :: ProxyProtocol

88 -- ^ Specify usage of the PROXY protocol.

95 -- ^ Specify usage of the PROXY protocol.

89 --

96 --

90− -- Since 3.0.5.

97+ -- Since 3.0.5

91 , settingsSlowlorisSize :: Int

98 , settingsSlowlorisSize :: Int

92 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

99 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

93 --

100 --

94− -- Since 3.1.2.

101+ -- Since 3.1.2

95 , settingsHTTP2Enabled :: Bool

102 , settingsHTTP2Enabled :: Bool

96 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

103 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

97 --

104 --

98− -- Since 3.1.7.

105+ -- Since 3.1.7

99 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

106 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

100 -- ^ A log function. Default: no action.

107 -- ^ A log function. Default: no action.

101 --

108 --

102− -- Since 3.X.X.

109+ -- Since 3.1.10

103 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

110 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

104 -- ^ A HTTP/2 server push log function. Default: no action.

111 -- ^ A HTTP/2 server push log function. Default: no action.

105 --

112 --

106− -- Since 3.X.X.

113+ -- Since 3.2.7

107 , settingsGracefulShutdownTimeout :: Maybe Int

114 , settingsGracefulShutdownTimeout :: Maybe Int

108 -- ^ An optional timeout to limit the time (in seconds) waiting for

115 -- ^ An optional timeout to limit the time (in seconds) waiting for

109 -- a graceful shutdown of the web server.

116 -- a graceful shutdown of the web server.

110 --

117 --

111 -- Since 3.2.8

118 -- Since 3.2.8

119+ , settingsGracefulCloseTimeout1 :: Int

120+ -- ^ A timeout to limit the time (in milliseconds) waiting for

121+ -- FIN for HTTP/1.x. 0 means uses immediate close.

122+ -- Default: 0.

123+ --

124+ -- Since 3.3.5

125+ , settingsGracefulCloseTimeout2 :: Int

126+ -- ^ A timeout to limit the time (in milliseconds) waiting for

127+ -- FIN for HTTP/2. 0 means uses immediate close.

128+ -- Default: 2000.

129+ --

130+ -- Since 3.3.5

131+ , settingsMaxTotalHeaderLength :: Int

132+ -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.

133+ --

134+ -- Since 3.3.8

112 }

135 }

113

136

114-- | Specify usage of the PROXY protocol.

137-- | Specify usage of the PROXY protocol.

@@ -145,6 +168,9 @@ defaultSettings = Settings

145 , settingsLogger = \_ _ _ -> return ()

168 , settingsLogger = \_ _ _ -> return ()

146 , settingsServerPushLogger = \_ _ _ -> return ()

169 , settingsServerPushLogger = \_ _ _ -> return ()

147 , settingsGracefulShutdownTimeout = Nothing

170 , settingsGracefulShutdownTimeout = Nothing

171+ , settingsGracefulCloseTimeout1 = 0

172+ , settingsGracefulCloseTimeout2 = 2000

173+ , settingsMaxTotalHeaderLength = 50 * 1024

148 }

174 }

149

175

150-- | Apply the logic provided by 'defaultOnException' to determine if an

176-- | Apply the logic provided by 'defaultOnException' to determine if an

warp/Network/Wai/Handler/Warp/Types.hs+10

@@ -8,6 +8,7 @@ import Control.Exception

8import qualified Data.ByteString as S

9import Data.IORef (IORef, readIORef, writeIORef, newIORef)

10import Data.Typeable (Typeable)

11+import Data.X509

11import Foreign.Ptr (Ptr)

12import Foreign.Ptr (Ptr)

12import System.Posix.Types (Fd)

13import System.Posix.Types (Fd)

13import qualified System.TimeManager as T

14import qualified System.TimeManager as T

@@ -122,8 +123,16 @@ data Connection = Connection {

122 , connWriteBuffer :: Buffer

123 , connWriteBuffer :: Buffer

123 -- | The size of the write buffer.

124 -- | The size of the write buffer.

124 , connBufferSize :: BufSize

125 , connBufferSize :: BufSize

126+ -- | Is this connection HTTP/2?

127+ , connHTTP2 :: IORef Bool

125 }

128 }

126

129

130+getConnHTTP2 :: Connection -> IO Bool

131+getConnHTTP2 conn = readIORef (connHTTP2 conn)

132+

133+setConnHTTP2 :: Connection -> Bool -> IO ()

134+setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b

135+

127----------------------------------------------------------------

136----------------------------------------------------------------

128

137

129data InternalInfo = InternalInfo {

138data InternalInfo = InternalInfo {

@@ -171,6 +180,7 @@ data Transport = TCP -- ^ Plain channel: TCP

171 , tlsMinorVersion :: Int

180 , tlsMinorVersion :: Int

172 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

181 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

173 , tlsChiperID :: Word16

182 , tlsChiperID :: Word16

183+ , tlsClientCertificate :: Maybe CertificateChain

174 } -- ^ Encrypted channel: TLS or SSL

184 } -- ^ Encrypted channel: TLS or SSL

175

185

176isTransportSecure :: Transport -> Bool

186isTransportSecure :: Transport -> Bool

warp/test/FileSpec.hs+1−1

@@ -21,7 +21,7 @@ testFileRange desc reqhs file ans = it desc $ do

21 let WithBody s hs off len = ans

22 hs' = ("Last-Modified",fileInfoDate finfo) : hs

23 ans' = WithBody s hs' off len

24− conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'

24+ conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans'

25

26spec :: Spec

27spec = do

warp/test/RequestSpec.hs+11−7

@@ -7,6 +7,7 @@ module RequestSpec (main, spec) where

7import Network.Wai.Handler.Warp.File (parseByteRanges)

8import Network.Wai.Handler.Warp.Request

9import Network.Wai.Handler.Warp.Types

10+import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings)

10import Test.Hspec

11import Test.Hspec

11import Test.Hspec.QuickCheck

12import Test.Hspec.QuickCheck

12import qualified Data.ByteString as S

13import qualified Data.ByteString as S

@@ -17,6 +18,9 @@ import Data.IORef

17main :: IO ()

18main :: IO ()

18main = hspec spec

19main = hspec spec

19

20

21+defaultMaxTotalHeaderLength :: Int

22+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23+

20spec :: Spec

24spec :: Spec

21spec = do

25spec = do

22 describe "headerLines" $ do

26 describe "headerLines" $ do

@@ -63,29 +67,29 @@ spec = do

63 describe "headerLines" $ do

67 describe "headerLines" $ do

64 it "can handle a nomarl case" $ do

68 it "can handle a nomarl case" $ do

65 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

69 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

66− x <- headerLines True src

70+ x <- headerLines defaultMaxTotalHeaderLength True src

67 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

71 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

68

72

69 it "can handle a nasty case (1)" $ do

73 it "can handle a nasty case (1)" $ do

70 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

74 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

71− x <- headerLines True src

75+ x <- headerLines defaultMaxTotalHeaderLength True src

72 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

76 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

73

77

74 it "can handle a nasty case (1)" $ do

78 it "can handle a nasty case (1)" $ do

75 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

79 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

76− x <- headerLines True src

80+ x <- headerLines defaultMaxTotalHeaderLength True src

77 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

81 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

78

82

79 it "can handle a nasty case (1)" $ do

83 it "can handle a nasty case (1)" $ do

80 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

84 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

81− x <- headerLines True src

85+ x <- headerLines defaultMaxTotalHeaderLength True src

82 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

86 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

83

87

84 it "can handle an illegal case (1)" $ do

88 it "can handle an illegal case (1)" $ do

85 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

89 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

86− x <- headerLines True src

90+ x <- headerLines defaultMaxTotalHeaderLength True src

87 x `shouldBe` []

91 x `shouldBe` []

88− y <- headerLines True src

92+ y <- headerLines defaultMaxTotalHeaderLength True src

89 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

93 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

90

94

91 where

95 where

@@ -111,7 +115,7 @@ headerLinesList' orig = do

111 writeIORef ref z

115 writeIORef ref z

112 return y

116 return y

113 src' <- mkSource src

117 src' <- mkSource src

114− res <- headerLines True src'

118+ res <- headerLines defaultMaxTotalHeaderLength True src'

115 return (res, src')

119 return (res, src')

116

120

117consumeLen :: Int -> Source -> IO S8.ByteString

121consumeLen :: Int -> Source -> IO S8.ByteString

warp/warp.cabal+4−1

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

1Name: warp

2−Version: 3.3.4

2+Version: 3.3.9

3Synopsis: A fast, light-weight web server for WAI applications.

4License: MIT

5License-file: LICENSE

@@ -56,6 +56,7 @@ Library

56 , vault >= 0.3

57 , wai >= 3.2 && < 3.3

58 , word8

59+ , x509

59 if impl(ghc < 8)

60 if impl(ghc < 8)

60 Build-Depends: semigroups

61 Build-Depends: semigroups

61 if flag(network-bytestring)

62 if flag(network-bytestring)

@@ -211,6 +212,7 @@ Test-Suite spec

211 , vault

212 , vault

212 , wai >= 3.2 && < 3.3

213 , wai >= 3.2 && < 3.3

213 , word8

214 , word8

215+ , x509

214 -- Build-Tool-Depends: hspec-discover:hspec-discover

216 -- Build-Tool-Depends: hspec-discover:hspec-discover

215 if impl(ghc < 8)

217 if impl(ghc < 8)

216 Build-Depends: semigroups

218 Build-Depends: semigroups

@@ -249,6 +251,7 @@ Benchmark parser

249 , network

251 , network

250 , time-manager

252 , time-manager

251 , unix-compat

253 , unix-compat

254+ , x509

252 if impl(ghc < 8)

255 if impl(ghc < 8)

253 Build-Depends: semigroups

256 Build-Depends: semigroups

254

257