17f92cd...master · typeable/wai

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

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

55 vmImage: ${{ parameters.vmImage }}

66 strategy:

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

188 stack-lts-11:

199 BUILD: stack

2010 STACK_YAML: stack-lts-11.yaml

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

2313 BUILD: stack

2414 STACK_YAML: stack-lts-12.yaml

2515 ARGS: "--resolver lts-12"

26− stack-lts-13:

16+ stack-lts-14:

2717 BUILD: stack

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

29− cabal-7.10.3:

30− BUILD: cabal

31− GHCVER: 7.10.3

32− CABALVER: 1.22

33− cabal-8.0.2:

34− BUILD: cabal

35− GHCVER: 8.0.2

36− CABALVER: 1.24

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

19+ stack-nightly:

20+ BUILD: stack

21+ STACK_YAML: stack-nightly.yaml

22+ ARGS: "--resolver nightly"

3723 cabal-8.2.2:

3824 BUILD: cabal

3925 GHCVER: 8.4.4

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

4228 BUILD: cabal

4329 GHCVER: 8.4.4

4430 CABALVER: 2.2

45− cabal-8.6.4:

31+ cabal-8.6.5:

4632 BUILD: cabal

47− GHCVER: 8.6.4

33+ GHCVER: 8.6.5

4834 CABALVER: 2.4

4935 maxParallel: 6

5036 steps:

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

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

55 vmImage: ${{ parameters.vmImage }}

66 strategy:

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

188 stack-lts-11:

199 BUILD: stack

2010 STACK_YAML: stack-lts-11.yaml

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

2313 BUILD: stack

2414 STACK_YAML: stack-lts-12.yaml

2515 ARGS: "--resolver lts-12"

26− stack-lts-13:

16+ stack-lts-14:

2717 BUILD: stack

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

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

2919 maxParallel: 3

3020 steps:

3121 - script: |

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

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

55 vmImage: ${{ parameters.vmImage }}

66 strategy:

77 matrix:

8− stack-lts-13:

8+ stack-lts-14:

99 BUILD: stack

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

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

1111 maxParallel: 3

1212 steps:

1313 - bash: |

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

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

1717 stack setup $ARGS > /dev/null

1818 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

2021 env:

2122 OS_NAME: ${{ parameters.os }}

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

.gitignore+1

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

99cabal.sandbox.config

1010.stack-work/

1111*~

12+stack*.yaml.lock

auto-update/Control/Debounce.hs+4−3

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

1111-- printString <- 'mkDebounce' 'defaultDebounceSettings'

1212-- { 'debounceAction' = putStrLn "Running action"

1313-- , 'debounceFreq' = 5000000 -- 5 seconds

14−-- , 'debounceEdge' = 'Trailing' -- Trigger on the trailing edge

14+-- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge

1515-- }

1616-- @

1717--

@@ -32,7 +32,8 @@ module Control.Debounce

3232 , DI.debounceFreq

3333 , DI.debounceAction

3434 , DI.debounceEdge

35− , DI.DebounceEdge(..)

35+ , DI.leadingEdge

36+ , DI.trailingEdge

3637 -- * Creation

3738 , mkDebounce

3839 ) where

@@ -47,7 +48,7 @@ defaultDebounceSettings :: DI.DebounceSettings

4748defaultDebounceSettings = DI.DebounceSettings

4849 { DI.debounceFreq = 1000000

4950 , DI.debounceAction = return ()

50− , DI.debounceEdge = DI.Leading

51+ , DI.debounceEdge = DI.leadingEdge

5152 }

5253

5354-- | Generate an action which will trigger the debounced action to be performed.

auto-update/Control/Debounce/Internal.hs+35−28

@@ -4,14 +4,15 @@

44module Control.Debounce.Internal (

55 DebounceSettings(..)

66 , DebounceEdge(..)

7+ , leadingEdge

8+ , trailingEdge

79 , mkDebounceInternal

810 ) where

911

1012import Control.Concurrent (forkIO)

1113import Control.Concurrent.MVar (takeMVar, tryPutMVar, tryTakeMVar, MVar)

1214import Control.Exception (SomeException, handle, mask_)

13−import Control.Monad (forever, void, when)

14−import Data.Maybe (isJust)

15+import Control.Monad (forever, void)

1516

1617-- | Settings to control how debouncing should work.

1718--

@@ -25,8 +26,7 @@ import Data.Maybe (isJust)

2526-- @since 0.1.2

2627data DebounceSettings = DebounceSettings

2728 { debounceFreq :: Int

28− -- ^ Microseconds lag required between subsequence calls to the debounced

29− -- action.

29+ -- ^ Length of the debounce timeout period in microseconds.

3030 --

3131 -- Default: 1 second (1000000)

3232 --

@@ -43,49 +43,56 @@ data DebounceSettings = DebounceSettings

4343 -- ^ Whether to perform the action on the leading edge or trailing edge of

4444 -- the timeout.

4545 --

46− -- Default: Leading.

46+ -- Default: 'trailingEdge'.

4747 --

4848 -- @since 0.1.6

4949 }

5050

51−-- | Setting to control whether the action happens at the leading or trailing

51+-- | Setting to control whether the action happens at the leading and/or trailing

5252-- edge of the timeout.

5353--

5454-- @since 0.1.6

5555data DebounceEdge =

5656 Leading

57− -- ^ The action will either be performed immediately, or after the current cooldown period has expired.

57+ -- ^ Perform the action immediately, and then begin a cooldown period.

58+ -- If the trigger happens again during the cooldown, wait until the end of the cooldown

59+ -- and then perform the action again, then enter a new cooldown period.

5860 | Trailing

59− -- ^ The action will be performed at the end of the current cooldown period.

60− | LeadingAndTrailing

61− -- ^ The action is performed on the leading edge. It's also performed on the trailing edge if

62− -- the debounced function was invoked again during the cooldown.

61+ -- ^ Start a cooldown period and perform the action when the period ends. If another trigger

62+ -- happens during the cooldown, it has no effect.

6363 deriving (Show, Eq)

6464

65+

66+-- | Perform the action immediately, and then begin a cooldown period.

67+-- If the trigger happens again during the cooldown, wait until the end of the cooldown

68+-- and then perform the action again, then enter a new cooldown period.

69+--

70+-- @since 0.1.6

71+leadingEdge :: DebounceEdge

72+leadingEdge = Leading

73+

74+-- | Start a cooldown period and perform the action when the period ends. If another trigger

75+-- happens during the cooldown, it has no effect.

76+--

77+-- @since 0.1.6

78+trailingEdge :: DebounceEdge

79+trailingEdge = Trailing

80+

6581mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())

6682mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do

6783 mask_ $ void $ forkIO $ forever $ do

6884 takeMVar baton

6985 case edge of

70− Leading -> ignoreExc action >> runDelay False

71− LeadingAndTrailing -> ignoreExc action >> runDelay False

72− Trailing -> runDelay True

73−

74− return $ void $ tryPutMVar baton ()

75−

76− where runDelay hasDelayedInitialActivation = do

86+ Leading -> do

87+ ignoreExc action

88+ delayFn freq

89+ Trailing -> do

7790 delayFn freq

91+ -- Empty the baton of any other activations during the interval

92+ void $ tryTakeMVar baton

93+ ignoreExc action

7894

79− case edge of

80− Trailing -> do

81− firedDuringInterval <- isJust <$> tryTakeMVar baton

82− when (firedDuringInterval || hasDelayedInitialActivation) $ ignoreExc action

83− Leading ->

84− -- We already fired at the beginning of the interval so do nothing

85− return ()

86− LeadingAndTrailing -> do

87− firedDuringInterval <- isJust <$> tryTakeMVar baton

88− when firedDuringInterval $ ignoreExc action

95+ return $ void $ tryPutMVar baton ()

8996

9097ignoreExc :: IO () -> IO ()

9198ignoreExc = handle $ \(_ :: SomeException) -> return ()

auto-update/test/Control/DebounceSpec.hs+5−36

@@ -15,7 +15,7 @@ spec :: Spec

1515spec = describe "mkDebounce" $ do

1616 describe "Leading edge" $ do

1717 it "works for a single event" $ do

18− (ref, debounced, baton, returnFromWait) <- getDebounce Leading

18+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge

1919

2020 debounced

2121 waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)

@@ -33,7 +33,7 @@ spec = describe "mkDebounce" $ do

3333 readIORef ref >>= (`shouldBe` 2)

3434

3535 it "works for multiple events" $ do

36− (ref, debounced, baton, returnFromWait) <- getDebounce Leading

36+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge

3737

3838 debounced

3939 waitForBatonToBeTaken baton

@@ -47,7 +47,7 @@ spec = describe "mkDebounce" $ do

4747

4848 describe "Trailing edge" $ do

4949 it "works for a single event" $ do

50− (ref, debounced, baton, returnFromWait) <- getDebounce Trailing

50+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge

5151

5252 debounced

5353 pause

@@ -65,7 +65,7 @@ spec = describe "mkDebounce" $ do

6565 waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)

6666

6767 it "works for multiple events" $ do

68− (ref, debounced, baton, returnFromWait) <- getDebounce Trailing

68+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge

6969

7070 debounced

7171 waitForBatonToBeTaken baton

@@ -76,37 +76,6 @@ spec = describe "mkDebounce" $ do

7676 returnFromWait

7777 waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)

7878

79− describe "Leading or trailing edge" $ do

80− it "works for a single event" $ do

81− (ref, debounced, baton, returnFromWait) <- getDebounce LeadingAndTrailing

82−

83− debounced

84− waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)

85−

86− returnFromWait

87− pause

88− readIORef ref >>= (`shouldBe` 1)

89−

90− -- Try another round

91− debounced

92− waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)

93−

94− returnFromWait

95− pause

96− readIORef ref >>= (`shouldBe` 2)

97−

98− it "works for multiple events" $ do

99− (ref, debounced, baton, returnFromWait) <- getDebounce LeadingAndTrailing

100−

101− debounced

102− waitForBatonToBeTaken baton

103− debounced

104−

105− waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)

106−

107− returnFromWait

108− waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)

109−

11079

11180-- | Make a controllable delay function

11281getWaitAction :: IO (p -> IO (), IO ())

@@ -117,7 +86,7 @@ getWaitAction = do

11786 return (waitAction, returnFromWait)

11887

11988-- | Get a debounce system with access to the internals for testing

120−getDebounce :: DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())

89+getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())

12190getDebounce edge = do

12291 ref :: IORef Int <- newIORef 0

12392 let action = modifyIORef ref (+ 1)

stack-lts-11.yaml+3−6

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

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

1818- http2-2.0.0

1919- network-byte-order-0.1.1.0

20+- tls-1.5.3

21+- tls-session-manager-0.0.4

22+- x509-1.7.5

2023nix:

2124 enable: false

2225 packages:

2326 - fcgi

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

1818 packages:

1919 - fcgi

2020 - zlib

21−image:

22− containers:

23− - base: "fpco/pid1"

24− name: "yesodweb/warp"

25− executables:

26− - warp

2721extra-deps:

2822- http2-2.0.0

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

22packages:

33- ./auto-update

44- ./mime-types

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

1818 packages:

1919 - fcgi

2020 - zlib

21−image:

22− containers:

23− - base: "fpco/pid1"

24− name: "yesodweb/warp"

25− executables:

26− - warp

2721extra-deps:

2822- http2-2.0.0

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

111## 3.1.6.3

212

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

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

165165 -- with an ETag header.

166166 --

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

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

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

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

171− -- new file being sent anyway.

167+ -- RFC7232 (HTTP 1.1):

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

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

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

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.

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

173175

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

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

243245 response :: StaticResponse -> IO W.ResponseReceived

244246 response (FileResponse file ch) = do

245247 mimetype <- ssGetMimeType ss file

246− let filesize = fileGetSize file

248+ -- let filesize = fileGetSize file

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

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

249251 -- range requests into account

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

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

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

269271

270− sendResponse $ W.responseLBS H.status301

272+ sendResponse $ W.responseLBS H.status302

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

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

273275 ] "Redirect"

274276

275277 response (RawRedirect path) =

276− sendResponse $ W.responseLBS H.status301

278+ sendResponse $ W.responseLBS H.status302

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

278280 , ("Location", path)

279281 ] "Redirect"

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

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

3939 }

4040

4141#if MIN_VERSION_optparse_applicative(0, 10, 0)

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

4243option' = option auto

4344#else

4445option' = option

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

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

6464

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

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

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

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

6868

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

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

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

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

77

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

99import Codec.Compression.GZip (compress)

10−import Control.Applicative

1110import Data.ByteString.Unsafe (unsafePackAddressLen)

1211import Data.Either (lefts, rights)

1312import GHC.Exts (Int(..))

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

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

5959toPieces = mapM toPiece

6060

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

62+--

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

6264type Pieces = [Piece]

6365

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

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

@@ -57,22 +57,22 @@ spec = do

5757 assertStatus 200 =<<

5858 request (setRawPathInfo defRequest path)

5959

60− it "404 for non-existant files" $ webApp $

60+ it "404 for non-existent files" $ webApp $

6161 assertStatus 404 =<<

6262 request (setRawPathInfo defRequest "doesNotExist")

6363

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

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

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

66− assertStatus 301 req

66+ assertStatus 302 req

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

6868

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

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

7171 }

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

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

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

7474 req <- request (setRawPathInfo defRequest path)

75− assertStatus 301 req

75+ assertStatus 302 req

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

7777

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

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

131131 assertStatus 304 req

132132 assertNoHeader "Cache-Control" req

133133

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

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

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

137− assertStatus 301 req

137+ assertStatus 302 req

138138 assertHeader "Location" "/a/" req

139139

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

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

144144 inTempDirectory $ fileServerAppWithSettings settings $ do

145145 liftIO $ touch "foo/index.html"

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

147− assertStatus 301 req

147+ assertStatus 302 req

148148 assertHeader "Location" "/foo/" req

149149

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

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

158158 "urlMapApp: only works at subPath"

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

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

161− assertStatus 301 req

161+ assertStatus 302 req

162162 assertHeader "Location" "/subPath/" req

163163

164164 context "with defaultWebAppSettings" $ do

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

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

11name: wai-app-static

2−version: 3.1.6.3

2+version: 3.1.7.1

33license: MIT

44license-file: LICENSE

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

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

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

1717import Control.Monad (unless)

1818import Network.HTTP.Types

1919import Data.ByteString.Builder (Builder)

20−import Data.IORef

2120import qualified Data.Conduit.List as CL

2221

2322-- | Stream the request body.

2423--

2524-- Since 3.0.0

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

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

2726sourceRequestBody req =

2827 loop

2928 where

30− go = liftIO (requestBody req)

29+ go = liftIO (getRequestBodyChunk req)

3130

3231 loop = do

3332 bs <- go

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

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

3938--

4039-- Since 3.0.0

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

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

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

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

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

4443 case mbuilder of

4544 Chunk b -> send b

4645 Flush -> flush)

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

5049--

5150-- Since 3.0.0

5251responseRawSource :: (MonadIO m, MonadIO n)

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

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

5453 -> Response

5554 -> Response

5655responseRawSource app =

wai-extra/ChangeLog.md+16

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

11# Changelog for wai-extra

22

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+

11+## 3.0.28

12+

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

14+

15+## 3.0.27

16+

17+* Add custom request log formatter which includes response headers [#762](https://github.com/yesodweb/wai/pull/762)

18+

319## 3.0.26.1

420

521* When available, supply the response size to custom loggers

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

@@ -5,11 +5,14 @@

55 headers:

66

77 > [ ("X-Accel-Buffering", "no"), ("Cache-Control", "no-cache")]

8+

9+ There is a small example using these functions in the @example@ directory.

810-}

911module Network.Wai.EventSource (

1012 ServerEvent(..),

1113 eventSourceAppChan,

12− eventSourceAppIO

14+ eventSourceAppIO,

15+ eventStreamAppRaw

1316 ) where

1417

1518import Data.Function (fix)

@@ -39,3 +42,18 @@ eventSourceAppIO src _ sendResponse =

3942 case eventToBuilder se of

4043 Nothing -> return ()

4144 Just b -> sendChunk b >> flush >> loop

45+

46+-- | Make a new WAI EventSource application with a handler that emits events.

47+--

48+-- @since 3.0.28

49+eventStreamAppRaw :: ((ServerEvent -> IO()) -> IO () -> IO ()) -> Application

50+eventStreamAppRaw handler _ sendResponse =

51+ sendResponse $ responseStream

52+ status200

53+ [(hContentType, "text/event-stream")]

54+ $ \sendChunk flush -> handler (sendEvent sendChunk) flush

55+ where

56+ sendEvent sendChunk event =

57+ case eventToBuilder event of

58+ Nothing -> return ()

59+ Just b -> sendChunk b

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

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

11{-# LANGUAGE CPP #-}

2−{- code adapted by Mathias Billman originaly from Chris Smith https://github.com/cdsmith/gloss-web -}

2+{- code adapted by Mathias Billman originally from Chris Smith https://github.com/cdsmith/gloss-web -}

33

44{-|

55 Internal module, usually you don't need to use it.

wai-extra/Network/Wai/Middleware/Gzip.hs+3

@@ -89,6 +89,9 @@ defaultCheckMime bs =

8989-- if gzip is supported.

9090--

9191-- File responses will be compressed according to the 'GzipFiles' setting.

92+--

93+-- Will only be applied based on the 'gzipCheckMime' setting. For default

94+-- behavior, see 'defaultCheckMime'.

9295gzip :: GzipSettings -> Middleware

9396gzip set app env sendResponse = app env $ \res ->

9497 case res of

wai-extra/Network/Wai/Middleware/RequestLogger.hs+56−6

@@ -14,6 +14,7 @@ module Network.Wai.Middleware.RequestLogger

1414 , OutputFormat (..)

1515 , OutputFormatter

1616 , OutputFormatterWithDetails

17+ , OutputFormatterWithDetailsAndHeaders

1718 , Destination (..)

1819 , Callback

1920 , IPAddrSource (..)

@@ -49,14 +50,42 @@ import Network.Wai.Middleware.RequestLogger.Internal

4950import Network.Wai.Header (contentLength)

5051import Data.Text.Encoding (decodeUtf8')

5152

52−data OutputFormat = Apache IPAddrSource

53− | Detailed Bool -- ^ use colors?

54− | CustomOutputFormat OutputFormatter

55− | CustomOutputFormatWithDetails OutputFormatterWithDetails

53+data OutputFormat

54+ = Apache IPAddrSource

55+ | Detailed Bool -- ^ use colors?

56+ | CustomOutputFormat OutputFormatter

57+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

58+ | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

5659

5760type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr

58−type OutputFormatterWithDetails =

59− ZonedDate -> Request -> Status -> Maybe Integer -> NominalDiffTime -> [S8.ByteString] -> B.Builder -> LogStr

61+

62+type OutputFormatterWithDetails

63+ = ZonedDate

64+ -> Request

65+ -> Status

66+ -> Maybe Integer

67+ -> NominalDiffTime

68+ -> [S8.ByteString]

69+ -> B.Builder

70+ -> LogStr

71+

72+-- | Same as @OutputFormatterWithDetails@ but with response headers included

73+--

74+-- This is useful if you wish to include arbitrary application data in your

75+-- logs, e.g., an authenticated user ID, which you would set in a response

76+-- header in your application and retrieve in the log formatter.

77+--

78+-- @since 3.0.27

79+type OutputFormatterWithDetailsAndHeaders

80+ = ZonedDate -- ^ When the log message was generated

81+ -> Request -- ^ The WAI request

82+ -> Status -- ^ HTTP status code

83+ -> Maybe Integer -- ^ Response size

84+ -> NominalDiffTime -- ^ Duration of the request

85+ -> [S8.ByteString] -- ^ The request body

86+ -> B.Builder -- ^ Raw response

87+ -> [Header] -- ^ The response headers

88+ -> LogStr

6089

6190data Destination = Handle Handle

6291 | Logger LoggerSet

@@ -108,6 +137,9 @@ mkRequestLogger RequestLoggerSettings{..} = do

108137 CustomOutputFormatWithDetails formatter -> do

109138 getdate <- getDateGetter flusher

110139 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

140+ CustomOutputFormatWithDetailsAndHeaders formatter -> do

141+ getdate <- getDateGetter flusher

142+ return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

111143

112144apacheMiddleware :: ApacheLoggerActions -> Middleware

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

@@ -138,6 +170,24 @@ customMiddlewareWithDetails cb getdate formatter app req sendResponse = do

138170 readIORef builderIO

139171 return rspRcv

140172

173+customMiddlewareWithDetailsAndHeaders :: Callback -> IO ZonedDate -> OutputFormatterWithDetailsAndHeaders -> Middleware

174+customMiddlewareWithDetailsAndHeaders cb getdate formatter app req sendResponse = do

175+ (req', reqBody) <- getRequestBody req

176+ t0 <- getCurrentTime

177+ app req' $ \res -> do

178+ t1 <- getCurrentTime

179+ date <- liftIO getdate

180+ let msize = contentLength (responseHeaders res)

181+ builderIO <- newIORef $ B.byteString ""

182+ res' <- recordChunks builderIO res

183+ rspRcv <- sendResponse res'

184+ _ <- do

185+ rawResponse <- readIORef builderIO

186+ let status = responseStatus res'

187+ duration = t1 `diffUTCTime` t0

188+ resHeaders = responseHeaders res'

189+ liftIO . cb $ formatter date req' status msize duration reqBody rawResponse resHeaders

190+ return rspRcv

141191-- | Production request logger middleware.

142192--

143193-- This uses the 'Apache' logging format, and takes IP addresses for clients from

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

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

11{-# LANGUAGE RecordWildCards #-}

22{-# LANGUAGE CPP #-}

33

4−module Network.Wai.Middleware.RequestLogger.JSON (formatAsJSON) where

4+module Network.Wai.Middleware.RequestLogger.JSON

5+ ( formatAsJSON

6+ , formatAsJSONWithHeaders

7+ ) where

58

69import qualified Data.ByteString.Builder as BB (toLazyByteString)

710import Data.ByteString.Lazy (toStrict)

@@ -40,6 +43,30 @@ formatAsJSON date req status responseSize duration reqBody response =

4043 , "time" .= decodeUtf8With lenientDecode date

4144 ]) <> "\n"

4245

46+-- | Same as @formatAsJSON@ but with response headers included

47+--

48+-- This is useful for passing arbitrary data from your application out to the

49+-- WAI layer for it to be logged, but you may need to be careful to

50+-- subsequently redact any headers which may contain sensitive data.

51+--

52+-- @since 3.0.27

53+formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders

54+formatAsJSONWithHeaders date req status resSize duration reqBody res resHeaders =

55+ toLogStr (encode $

56+ object

57+ [ "request" .= requestToJSON duration req reqBody

58+ , "response" .= object

59+ [ "status" .= statusCode status

60+ , "size" .= resSize

61+ , "headers" .= responseHeadersToJSON resHeaders

62+ , "body" .=

63+ if statusCode status >= 400

64+ then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ res

65+ else Nothing

66+ ]

67+ , "time" .= decodeUtf8With lenientDecode date

68+ ]) <> "\n"

69+

4370word32ToHostAddress :: Word32 -> Text

4471word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress

4572

@@ -90,6 +117,12 @@ requestHeadersToJSON = toJSON . map hToJ where

90117 hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)

91118 hToJ hd = headerToJSON hd

92119

120+responseHeadersToJSON :: [Header] -> Value

121+responseHeadersToJSON = toJSON . map hToJ where

122+ -- Redact cookies

123+ hToJ ("Set-Cookie", _) = toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)

124+ hToJ hd = headerToJSON hd

125+

93126headerToJSON :: Header -> Value

94127headerToJSON (headerName, header) = toJSON (decodeUtf8With lenientDecode . original $ headerName, decodeUtf8With lenientDecode header)

95128

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

@@ -169,7 +169,7 @@ import Control.Applicative

169169--

170170-- as the following example demonstrates.

171171--

172−-- Old versions of the libary could only handle path pieces, not queries.

172+-- Old versions of the library could only handle path pieces, not queries.

173173-- This could have been supplied to 'rewritePure'.

174174--

175175-- @

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

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

9999data SRequest = SRequest

100100 { simpleRequest :: Request

101101 , 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'.

102106 }

103107data SResponse = SResponse

104108 { simpleStatus :: H.Status

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

106110 , simpleBody :: L.ByteString

107111 }

108112 deriving (Show, Eq)

113+

109114request :: 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

111123

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

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

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

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

167179 return response

168180

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

182+-- 'L.ByteString'.

169183srequest :: SRequest -> Session SResponse

170184srequest (SRequest req bod) = do

171− app <- ask

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

173− let req' = req

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

175− case bss of

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

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

178− }

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

186+ request $

187+ req

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

189+ case bss of

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

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

192+ }

185193

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

187195runResponse ref res = do

wai-extra/example/Main.hs+11

@@ -37,6 +37,17 @@ eventIO = do

3737 Nothing

3838 [string8 . show $ time]

3939

40+eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO ()

41+eventRaw = handle 0

42+ where

43+ handle counter emit flush = do

44+ threadDelay 1000000

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

46+ Nothing

47+ [string8 . show $ counter]

48+ _ <- flush

49+ handle (counter + 1) emit flush

50+

4051main :: IO ()

4152main = do

4253 chan <- newChan

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

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

33

44import Control.Monad (void)

55

6+import qualified Data.IORef as IORef

7+

68import qualified Data.Text.Encoding as TE

79

810import Data.Time.Calendar (fromGregorian)

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

5355 it "sets rawQueryString to empty string" $ do

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

5557

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+

5674 describe "request" $ do

5775

58− let simpleApp _req respond =

76+ let echoApp req respond = do

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

78+ let reqHeaders = requestHeaders req

5979 respond $

6080 responseLBS

6181 status200

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

63− "simple"

82+ reqHeaders

83+ reqBody

6484

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

66− sresp <- runSession (request defaultRequest) simpleApp

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

86+ sresp <- runSession (request defaultRequest) echoApp

6787 simpleStatus sresp `shouldBe` status200

6888

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

70− sresp <- runSession (request defaultRequest) simpleApp

71− simpleBody sresp `shouldBe` "simple"

72−

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

74− sresp <- runSession (request defaultRequest) simpleApp

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 $

94+ defaultRequest

95+ { requestBody = getBodyChunk

96+ }

97+ simpleBody sresp `shouldBe` "request body"

98+

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

100+ sresp <- flip runSession echoApp $

101+ request $

102+ defaultRequest

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

104+ }

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

76106

77107 let cookieApp req respond =

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

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

11Name: wai-extra

2−Version: 3.0.26.1

2+Version: 3.0.29.1

33Synopsis: Provides some basic WAI handlers and middleware.

44description:

55 Provides basic WAI handler and middleware functionality:

@@ -99,8 +99,8 @@ Library

9999 , text >= 0.7

100100 , case-insensitive >= 0.2

101101 , data-default-class

102− , fast-logger >= 2.4.5 && < 2.5

103− , wai-logger >= 2.3.2 && < 2.4

102+ , fast-logger >= 2.4.5

103+ , wai-logger >= 2.3.2

104104 , ansi-terminal

105105 , resourcet >= 0.4.6 && < 1.3

106106 , void >= 0.5

wai-http2-extra/wai-http2-extra.cabal+9−2

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

11Name: wai-http2-extra

2−Version: 0.1.1

2+Version: 0.1.2

33Synopsis: WAI utilities for HTTP/2

44License: MIT

55License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: kazu@iij.ad.jp

88Homepage: http://github.com/yesodweb/wai

99Category: Web

1010Build-Type: Simple

11−Cabal-Version: >=1.8

11+Cabal-Version: >=1.10

1212Stability: Stable

1313Description: WAI utilities for HTTP/2

1414

@@ -24,6 +24,9 @@ Library

2424 Exposed-modules: Network.Wai.Middleware.Push.Referer

2525 Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap

2626 Ghc-Options: -Wall

27+ if impl(ghc >= 8)

28+ default-extensions: Strict StrictData

29+ default-language: Haskell2010

2730

2831Test-Suite doctest

2932 Type: exitcode-stdio-1.0

@@ -32,6 +35,10 @@ Test-Suite doctest

3235 Main-Is: doctests.hs

3336 Build-Depends: base

3437 , doctest >= 0.10.1

38+ if impl(ghc >= 8)

39+ default-extensions: Strict StrictData

40+ default-language: Haskell2010

41+

3542Source-Repository head

3643 Type: git

3744 Location: git://github.com/yesodweb/wai.git

wai-websockets/server.lhs+7−1

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

88nearby to check out the functions we use.

99

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

11+> {-# LANGUAGE CPP #-}

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

1113> import Data.Char (isPunctuation, isSpace)

1214> import Data.Monoid (mappend)

1315> import Data.Text (Text)

@@ -99,9 +101,13 @@ stays alive on some browsers.

99101

100102> application state pending = do

101103> conn <- WS.acceptRequest pending

104+#if __GLASGOW_HASKELL__ >= 806

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

106+#else

102107> WS.forkPingThread conn 30

108+#endif

103109

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

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

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

106112

107113> msg <- WS.receiveData conn

wai-websockets/wai-websockets.cabal+1

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

4545 , text

4646 , file-embed

4747 , http-types

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

4849 else

4950 buildable: False

5051

warp-tls/ChangeLog.md+22

@@ -1,3 +1,25 @@

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+

15+## 3.2.8

16+

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

18+

19+## 3.2.7

20+

21+* Relaxing version constraint.

22+

123## 3.2.6

224

325* Using the Strict and StrictData language extensions for GHC >8.

warp-tls/Network/Wai/Handler/WarpTLS.hs+27−15

@@ -53,6 +53,9 @@ import qualified Data.IORef as I

5353import Data.Streaming.Network (bindPortTCP, safeRecv)

5454import Data.Typeable (Typeable)

5555import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)

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

57+import Network.Socket (gracefulClose)

58+#endif

5659import Network.Socket.ByteString (sendAll)

5760import qualified Network.TLS as TLS

5861import qualified Crypto.PubKey.DH as DH

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

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

279282 runSettingsConnectionMakerSecure set get app

280283 where

281− get = getter tlsset sock params

284+ get = getter tlsset set sock params

282285 params = def { -- TLS.ServerParams

283286 TLS.serverWantClientCert = tlsWantClientCert

284287 , TLS.serverCACertificates = []

@@ -319,49 +322,55 @@ alpn xs

319322

320323----------------------------------------------------------------

321324

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

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

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

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

324327#if WINDOWS

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

326329#else

327330 (s, sa) <- accept sock

328331#endif

329332 setSocketCloseOnExec s

330− return (mkConn tlsset s params, sa)

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

331334

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

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

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

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

334337 where

335338 switch = do

336339 firstBS <- safeRecv s 4096

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

338− httpOverTls tlsset s firstBS params

341+ httpOverTls tlsset set s firstBS params

339342 else

340− plainHTTP tlsset s firstBS

343+ plainHTTP tlsset set s firstBS

341344

342345----------------------------------------------------------------

343346

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

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

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

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

346349 recvN <- makePlainReceiveN s bs0

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

348351 TLS.contextHookSetLogging ctx tlsLogging

349352 TLS.handshake ctx

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

354+ isH2 <- I.newIORef h2

350355 writeBuf <- allocateBuffer bufferSize

351356 -- Creating a cache for leftover input data.

352357 ref <- I.newIORef ""

353358 tls <- getTLSinfo ctx

354− return (conn ctx writeBuf ref, tls)

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

355360 where

356361 backend recvN = TLS.Backend {

357362 TLS.backendFlush = return ()

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

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

365+#else

358366 , TLS.backendClose = close s

367+#endif

359368 , TLS.backendSend = sendAll' s

360369 , TLS.backendRecv = recvN

361370 }

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

363372 throwIO ConnectionClosedByPeer

364− conn ctx writeBuf ref = Connection {

373+ conn ctx writeBuf ref isH2 = Connection {

365374 connSendMany = TLS.sendData ctx . L.fromChunks

366375 , connSendAll = sendall

367376 , connSendFile = sendfile

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

371380 , connRecvBuf = recvBuf ref

372381 , connWriteBuffer = writeBuf

373382 , connBufferSize = bufferSize

383+ , connHTTP2 = isH2

374384 }

375385 where

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

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

458468#if MIN_VERSION_tls(1,5,0)

459469 TLS.TLS13 -> (3,4)

460470#endif

471+ clientCert <- TLS.getClientCertificateChain ctx

461472 return TLS {

462473 tlsMajorVersion = major

463474 , tlsMinorVersion = minor

464475 , tlsNegotiatedProtocol = proto

465476 , tlsChiperID = TLS.cipherID infoCipher

477+ , tlsClientCertificate = clientCert

466478 }

467479

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

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

470482

471483----------------------------------------------------------------

472484

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

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

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

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

475487 AllowInsecure -> do

476− conn' <- socketConnection s

488+ conn' <- socketConnection set s

477489 cachedRef <- I.newIORef bs0

478490 let conn'' = conn'

479491 { connRecv = recvPlain cachedRef (connRecv conn')

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

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

11Name: warp-tls

2−Version: 3.2.7

2+Version: 3.2.11

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

44License: MIT

55License-file: LICENSE

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

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

1919

2020Library

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

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

2222 , bytestring >= 0.9

2323 , wai >= 3.2 && < 3.3

24− , warp >= 3.2.17 && < 3.4

24+ , warp >= 3.3.6 && < 3.4

2525 , data-default-class >= 0.0.1

26− , tls >= 1.3.10

26+ , tls >= 1.5.3

2727 , cryptonite >= 0.12

2828 , network >= 2.2.1

2929 , streaming-commons

30− , tls-session-manager >= 0.0.0.1

30+ , tls-session-manager >= 0.0.4

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

3232 ghc-options: -Wall

3333 if os(windows)

warp/ChangeLog.md+50−1

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

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+

31+## 3.3.4

32+

33+* Setting isSecure of HTTP/2 correctly.

34+

35+## 3.3.3

36+

37+* Calling setOnException in HTTP/2.

38+ [#771](https://github.com/yesodweb/wai/pull/771)

39+

40+## 3.3.2

41+

42+* Fixing a bug of HTTP/2 without fd cache.

43+

44+## 3.3.1

45+

46+* Using gracefullClose of network 3.1.1 or later if available.

47+* If the first line of an HTTP request is really invalid,

48+ don't send an error response

49+

150## 3.3.0

251

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

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

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

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

655 `HTTP2Data -> TrailersMaker`.

756

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

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

7272 , setLogger

7373 , setServerPushLogger

7474 , setGracefulShutdownTimeout

75+ , setGracefulCloseTimeout1

76+ , setGracefulCloseTimeout2

77+ , setMaxTotalHeaderLength

7578 -- ** Getters

7679 , getPort

7780 , getHost

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

7982 , getOnClose

8083 , getOnException

8184 , getGracefulShutdownTimeout

85+ , getGracefulCloseTimeout1

86+ , getGracefulCloseTimeout2

8287 -- ** Exception handler

8388 , defaultOnException

8489 , defaultShouldDisplayException

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

9398 , pauseTimeout

9499 , FileInfo(..)

95100 , getFileInfo

101+ , clientCertificate

96102 , withApplication

97103 , withApplicationSettings

98104 , testWithApplication

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

121127import Control.Exception (SomeException, throwIO)

122128import Data.Streaming.Network (HostPreference)

123129import qualified Data.Vault.Lazy as Vault

130+import Data.X509

124131import qualified Network.HTTP.Types as H

125132import Network.Socket (SockAddr)

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

@@ -378,7 +385,7 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }

378385--

379386-- WARNING: This is contrary to the PROXY protocol specification and

380387-- using it can indicate a security problem with your

381−-- architecture if the web server is directly accessable

388+-- architecture if the web server is directly accessible

382389-- to the public, since it would allow easy IP address

383390-- spoofing. However, it can be useful in some cases,

384391-- such as if a load balancer health check uses regular

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

430437 -> Settings -> Settings

431438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

432439

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+

433447-- | Explicitly pause the slowloris timeout.

434448--

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

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

457471-- Since 3.1.10

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

459473getFileInfo = 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

3434----------------------------------------------------------------

3535

3636conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders -> IndexedHeader

37+ -> H.ResponseHeaders

38+ -> IndexedHeader -- ^ Response

39+ -> IndexedHeader -- ^ Request

3840 -> RspFileInfo

39−conditionalRequest finfo hs0 reqidx = case condition of

41+conditionalRequest finfo hs0 rspidx reqidx = case condition of

4042 nobody@(WithoutBody _) -> nobody

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

42− addContentHeaders hs0 off len size

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

44+ !hasLM = isJust $ rspidx ! fromEnum ResLastModified

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

4346 in WithBody s hs off len

4447 where

4548 !mtime = I.fileInfoTime finfo

warp/Network/Wai/Handler/Warp/HTTP2.hs+25−16

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

66

77module Network.Wai.Handler.Warp.HTTP2 (http2) where

88

9+import qualified Data.IORef as I

910import qualified Control.Exception as E

1011import qualified Network.HTTP2.Server as H2

1112import Network.Socket (SockAddr)

@@ -23,38 +24,46 @@ import Network.Wai.Handler.Warp.Types

2324

2425----------------------------------------------------------------

2526

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

27−http2 conn ii addr settings readN app =

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

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

2829 H2.run conf http2server

2930 where

3031 conf = H2.Config {

3132 confWriteBuffer = connWriteBuffer conn

3233 , confBufferSize = connBufferSize conn

33− , confSendAll = connSendAll conn

34+ , confSendAll = send

3435 , confReadN = readN

3536 , confPositionReadMaker = pReadMaker ii

3637 }

3738

3839 http2server h2req aux response = do

3940 req <- toWAIRequest h2req aux

40− ResponseReceived <- app req $ \rsp -> do

41+ ref <- I.newIORef Nothing

42+ eResponseReceived <- E.try $ app req $ \rsp -> do

4143 h2rsp <- fromResponse settings ii req rsp

4244 pps <- fromPushPromises ii req

43− ex <- E.try $ response h2rsp pps

44− case ex of

45− Right () -> do

46− logResponse h2rsp req

47− mapM_ (logPushPromise req) pps

48− Left e@(E.SomeException _)

49− -- killed by the local worker manager

50− | Just E.ThreadKilled <- E.fromException e -> return ()

51− -- killed by the local timeout manager

52− | Just T.TimeoutThread <- E.fromException e -> return ()

53− | otherwise -> S.settingsOnException settings (Just req) e

45+ I.writeIORef ref $ Just (h2rsp, pps)

46+ _ <- response h2rsp pps

5447 return ResponseReceived

48+ case eResponseReceived of

49+ Right ResponseReceived -> do

50+ Just (h2rsp, pps) <- I.readIORef ref

51+ logResponse h2rsp req

52+ mapM_ (logPushPromise req) pps

53+ Left e@(E.SomeException _)

54+ -- killed by the local worker manager

55+ | Just E.ThreadKilled <- E.fromException e -> return ()

56+ -- killed by the local timeout manager

57+ | Just T.TimeoutThread <- E.fromException e -> return ()

58+ | otherwise -> do

59+ S.settingsOnException settings (Just req) e

60+ let ersp = S.settingsOnExceptionResponse settings e

61+ h2rsp' <- fromResponse settings ii req ersp

62+ _ <- response h2rsp' []

63+ logResponse h2rsp' req

5564 return ()

5665

57− toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th

66+ toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport

5867 where

5968 !hdr = H2.requestHeaders h2req

6069 !bdy = H2.getRequestBodyChunk h2req

warp/Network/Wai/Handler/Warp/HTTP2/File.hs+6−2

@@ -15,8 +15,12 @@ import Network.Wai.Handler.Warp.SendFile (positionRead)

1515

1616pReadMaker :: InternalInfo -> PositionReadMaker

1717pReadMaker ii path = do

18− (Just fd, refresh) <- getFd ii path

19− return (pread fd, Refresher refresh)

18+ (mfd, refresh) <- getFd ii path

19+ case mfd of

20+ Just fd -> return (pread fd, Refresher refresh)

21+ Nothing -> do

22+ fd <- openFile path

23+ return (pread fd, Closer $ closeFile fd)

2024 where

2125 pread :: Fd -> PositionRead

2226 pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'

warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+7−6

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

2222

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

2424import Network.Wai.Handler.Warp.Imports

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

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

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

2727import Network.Wai.Handler.Warp.Types

2828

29−type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> IO Request

29+type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request

3030

3131----------------------------------------------------------------

3232

3333toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq

34−toRequest ii settings addr ht bodylen body th = do

34+toRequest ii settings addr ht bodylen body th transport = do

3535 ref <- newIORef Nothing

36− toRequest' ii settings addr ref ht bodylen body th

36+ toRequest' ii settings addr ref ht bodylen body th transport

3737

3838toRequest' :: InternalInfo -> S.Settings -> SockAddr

3939 -> IORef (Maybe HTTP2Data)

4040 -> ToReq

41−toRequest' ii settings addr ref (reqths,reqvt) bodylen body th = return req

41+toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req

4242 where

4343 !req = Request {

4444 requestMethod = colonMethod

@@ -48,7 +48,7 @@ toRequest' ii settings addr ref (reqths,reqvt) bodylen body th = return req

4848 , rawQueryString = query

4949 , queryString = H.parseQuery query

5050 , requestHeaders = headers

51− , isSecure = True

51+ , isSecure = isTransportSecure transport

5252 , remoteHost = addr

5353 , requestBody = body

5454 , vault = vaultValue

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

8383 $ Vault.insert setHTTP2DataKey (writeIORef ref)

8484 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

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

86+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

8687 Vault.empty

8788

8889getHTTP2DataKey :: 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

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

7373 Right finfo -> do

7474 let reqidx = indexRequestHeader reqhdr

75− case conditionalRequest finfo rsphdr reqidx of

75+ rspidx = indexResponseHeader rsphdr

76+ case conditionalRequest finfo rsphdr rspidx reqidx of

7677 WithoutBody s -> return $ responseNoBody s rsphdr

7778 WithBody s rsphdr' off bytes -> do

7879 let !off' = fromIntegral off

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

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

6969data ResponseHeaderIndex = ResContentLength

7070 | ResServer

7171 | ResDate

72+ | ResLastModified

7273 deriving (Enum,Bounded)

7374

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

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

7980responseKeyIndex hn = case BS.length bs of

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

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

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

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

8385 _ -> -1

8486 where

warp/Network/Wai/Handler/Warp/Recv.hs+25−4

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

1717import Foreign.ForeignPtr (withForeignPtr)

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

1919import GHC.Conc (threadWaitRead)

20−import Network.Socket (Socket, fdSocket)

20+import qualified GHC.IO.Exception as E

21+import Network.Socket (Socket)

22+import qualified System.IO.Error as E

23+#if MIN_VERSION_network(3,1,0)

24+import Network.Socket (withFdSocket)

25+#else

26+import Network.Socket (fdSocket)

27+#endif

2128import System.Posix.Types (Fd(..))

2229

2330import Network.Wai.Handler.Warp.Buffer

@@ -89,19 +96,31 @@ spell init0 siz0 recv recvBuf

8996 siz' = siz - len

9097 loop bss' siz'

9198

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.

92102receive :: Socket -> BufferPool -> Recv

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

94−#if MIN_VERSION_network(3,0,0)

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

104+#if MIN_VERSION_network(3,1,0)

105+ withFdSocket sock $ \fd -> do

106+#elif MIN_VERSION_network(3,0,0)

95107 fd <- fdSocket sock

96108#else

97109 let fd = fdSocket sock

98110#endif

99111 let size' = fromIntegral size

100112 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

101118

102119receiveBuf :: Socket -> RecvBuf

103120receiveBuf sock buf0 siz0 = do

104−#if MIN_VERSION_network(3,0,0)

121+#if MIN_VERSION_network(3,1,0)

122+ withFdSocket sock $ \fd -> do

123+#elif MIN_VERSION_network(3,0,0)

105124 fd <- fdSocket sock

106125#else

107126 let fd = fdSocket sock

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

134153 else

135154 return bytes

136155

156+#ifndef mingw32_HOST_OS

137157-- fixme: the type of the return value

138158foreign import ccall unsafe "recv"

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

160+#endif

warp/Network/Wai/Handler/Warp/Request.hs+21−19

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

99 , headerLines

1010 , pauseTimeoutKey

1111 , getFileInfoKey

12+ , getClientCertificateKey

1213 , NoKeepAliveRequest (..)

1314 ) where

1415

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

2122import qualified Data.IORef as I

2223import Data.Typeable (Typeable)

2324import qualified Data.Vault.Lazy as Vault

25+import Data.X509

2426import qualified Network.HTTP.Types as H

2527import Network.Socket (SockAddr)

2628import Network.Wai

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

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

3739import Network.Wai.Handler.Warp.ReadInt

3840import Network.Wai.Handler.Warp.RequestHeader

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

40−

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

42−

43−-- FIXME come up with good values here

44−maxTotalHeaderLength :: Int

45−maxTotalHeaderLength = 50 * 1024

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

4642

4743----------------------------------------------------------------

4844

@@ -55,6 +51,7 @@ recvRequest :: Bool -- ^ first request on this connection?

5551 -> Timeout.Handle

5652 -> SockAddr -- ^ Peer's address.

5753 -> Source -- ^ Where HTTP request comes from.

54+ -> Transport

5855 -> IO (Request

5956 ,Maybe (I.IORef Int)

6057 ,IndexedHeader

@@ -64,8 +61,8 @@ recvRequest :: Bool -- ^ first request on this connection?

6461 -- 'IndexedHeader' of HTTP request for internal use,

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

6663

67−recvRequest firstRequest settings conn ii th addr src = do

68− hdrlines <- headerLines firstRequest src

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

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

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

7067 let idxhdr = indexRequestHeader hdr

7168 expect = idxhdr ! fromEnum ReqExpect

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

7572 rawPath = if settingsNoParsePath settings then unparsedPath else path

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

7774 $ Vault.insert getFileInfoKey (getFileInfo ii)

75+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

7876 Vault.empty

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

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

@@ -89,7 +87,7 @@ recvRequest firstRequest settings conn ii th addr src = do

8987 , rawQueryString = query

9088 , queryString = H.parseQuery query

9189 , requestHeaders = hdr

92− , isSecure = False

90+ , isSecure = isTransportSecure transport

9391 , remoteHost = addr

9492 , requestBody = rbody'

9593 , vault = vaultValue

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

103101

104102----------------------------------------------------------------

105103

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

107−headerLines firstRequest src = do

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

105+headerLines maxTotalHeaderLength firstRequest src = do

108106 bs <- readSource src

109107 if S.null bs

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

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

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

113111 -- the Run module for more details.

114112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

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

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

116114

117115data NoKeepAliveRequest = NoKeepAliveRequest

118116 deriving (Show, Typeable)

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

222220close = throwIO IncompleteHeaders

223221-}

224222

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

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

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

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

227225 -- Too many bytes

228226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

229227 | otherwise = push' mnl

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

251249 push' Nothing = do

252250 bst <- readSource' src

253251 when (S.null bst) $ throwIO IncompleteHeaders

254− push src status bst

252+ push maxTotalHeaderLength src status bst

255253 where

256254 len' = len + bsLen

257255 prepend' = S.append bs

258256 status = THStatus len' lines prepend'

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

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

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

261259 where

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

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

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

276274 in if start < bsLen then

277275 -- more bytes in this chunk, push again

278276 let bs'' = SU.unsafeDrop start bs

279− in push src status bs''

277+ in push maxTotalHeaderLength src status bs''

280278 else do

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

282280 bst <- readSource' src

283281 when (S.null bs) $ throwIO IncompleteHeaders

284− push src status bst

282+ push maxTotalHeaderLength src status bst

285283 where

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

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

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

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

300298getFileInfoKey = unsafePerformIO Vault.newKey

301299{-# 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

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

117117 --

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

120120 case ms of

121121 Nothing -> return ()

122122 Just realStatus -> logger req realStatus mlen

123123 T.tickle th

124124 return ret

125125 else do

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

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

127127 logger req s Nothing

128128 T.tickle th

129129 return isPersist

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

196196 -> H.HttpVersion

197197 -> H.Status

198198 -> H.ResponseHeaders

199+ -> IndexedHeader -- Response

199200 -> Rsp

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

201202

202203----------------------------------------------------------------

203204

204−sendRsp conn _ ver s hs RspNoBody = do

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

205206 -- Not adding Content-Length.

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

207208 composeHeader ver s hs >>= connSendAll conn

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

209210

210211----------------------------------------------------------------

211212

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

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

213214 header <- composeHeaderBuilder ver s hs needsChunked

214215 let hdrBdy

215216 | needsChunked = header <> chunkedTransferEncoding body

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

222223

223224----------------------------------------------------------------

224225

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

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

226227 header <- composeHeaderBuilder ver s hs needsChunked

227228 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

228229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

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

246247

247248----------------------------------------------------------------

248249

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

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

250251 withApp recv send

251252 return (Nothing, Nothing)

252253 where

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

260261

261262-- Sophisticated WAI applications.

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

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

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

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

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

265266 where

266267 beg = filePartOffset part

267268 len = filePartByteCount part

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

271272

272273-- Simple WAI applications.

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

275276 efinfo <- E.try $ getFileInfo ii path

276277 case efinfo of

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

278279#ifdef WARP_DEBUG

279280 print _ex >>

280281#endif

281− sendRspFile404 conn ii ver hs0

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

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

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

282+ sendRspFile404 conn ii ver hs0 rspidxhdr

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

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

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

285286

286287----------------------------------------------------------------

287288

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

290291 -> H.HttpVersion

291292 -> H.Status

292293 -> H.ResponseHeaders

294+ -> IndexedHeader

293295 -> FilePath

294296 -> Integer

295297 -> Integer

296298 -> Bool

297299 -> IO ()

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

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

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

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

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

301303 | otherwise = do

302304 lheader <- composeHeader ver s hs

303305 (mfd, fresher) <- getFd ii path

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

310312 -> InternalInfo

311313 -> H.HttpVersion

312314 -> H.ResponseHeaders

315+ -> IndexedHeader

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

315318 where

316319 s = H.notFound404

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

warp/Network/Wai/Handler/Warp/Run.hs+41−25

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

1717import Control.Exception as E

1818import qualified Data.ByteString as S

1919import Data.Char (chr)

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

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

2121import Data.Streaming.Network (bindPortTCP)

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

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

2424import qualified Network.HTTP2 as H2

2525import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

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

27+import Network.Socket (gracefulClose)

28+#endif

2629import qualified Network.Socket.ByteString as Sock

2730import Network.Wai

2831import Network.Wai.Internal (ResponseReceived (ResponseReceived))

@@ -55,21 +58,38 @@ import Network.Socket (fdSocket)

5558#endif

5659

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

58−socketConnection :: Socket -> IO Connection

59−socketConnection s = do

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

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

63+socketConnection set s = do

64+#else

65+socketConnection _ s = do

66+#endif

6067 bufferPool <- newBufferPool

6168 writeBuf <- allocateBuffer bufferSize

6269 let sendall = Sock.sendAll s

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

6371 return Connection {

6472 connSendMany = Sock.sendMany s

6573 , connSendAll = sendall

6674 , connSendFile = sendFile s writeBuf bufferSize sendall

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

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

84+#else

6785 , connClose = close s

86+#endif

6887 , connFree = freeBuffer writeBuf

6988 , connRecv = receive s bufferPool

7089 , connRecvBuf = receiveBuf s

7190 , connWriteBuffer = writeBuf

7291 , connBufferSize = bufferSize

92+ , connHTTP2 = isH2

7393 }

7494

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

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

131151 setSocketCloseOnExec s

132152 -- NoDelay causes an error for AF_UNIX.

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

134− conn <- socketConnection s

154+ conn <- socketConnection set s

135155 return (conn, sa)

136156

137157 closeListenSocket = close socket

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

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

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

268288 -- exceptions are thrown.

269− handle (settingsOnException set Nothing) .

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

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

272− withClosedRef $ \ref ->

289+ handle (settingsOnException set Nothing) $

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

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

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

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

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

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

282299 -- fact that async exceptions are still masked.

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

300+ bracket mkConn cleanUp (serve unmask)

284301 where

285− withClosedRef inner = newIORef False >>= inner

286−

287− closeConn ref conn = do

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

289− unless isClosed $ connClose conn

290−

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

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

292303

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

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

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

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

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

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

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

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

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

300309 -- allow async exceptions.

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

306315 -- above ensures the connection is closed.

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

308317 where

309− register = T.registerKillThread (timeoutManager ii)

310− (closeConn ref conn)

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

311319 cancel = T.cancel

312320

313321 onOpen adr = increase counter >> settingsOnOpen set adr

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

334342 istatus <- newIORef False

335343 if settingsHTTP2Enabled settings && h2 then do

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

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

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

338354 -- fixme: origAddr

339355 checkTLS

340− http2 conn ii origAddr settings recvN app

356+ setConnHTTP2 conn True

357+ http2 conn transport ii origAddr settings recvN sendBS app

341358 else do

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

343360 writeIORef istatus True

@@ -412,8 +429,7 @@ serveConnection conn ii th origAddr transport settings app = do

412429 errorResponse e = settingsOnExceptionResponse settings e

413430

414431 http1 firstRequest addr istatus src = do

415− (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src

416− let req = req' { isSecure = isTransportSecure transport }

432+ (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport

417433 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

418434 `E.catch` \e -> do

419435 settingsOnException settings (Just req) e

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

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

7676 --

7777 -- Since 2.0.3

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

7986 , settingsServerName :: ByteString

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

8188 --

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

8794 , settingsProxyProtocol :: ProxyProtocol

8895 -- ^ Specify usage of the PROXY protocol.

8996 --

90− -- Since 3.0.5.

97+ -- Since 3.0.5

9198 , settingsSlowlorisSize :: Int

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

93100 --

94− -- Since 3.1.2.

101+ -- Since 3.1.2

95102 , settingsHTTP2Enabled :: Bool

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

97104 --

98− -- Since 3.1.7.

105+ -- Since 3.1.7

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

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

101108 --

102− -- Since 3.X.X.

109+ -- Since 3.1.10

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

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

105112 --

106− -- Since 3.X.X.

113+ -- Since 3.2.7

107114 , settingsGracefulShutdownTimeout :: Maybe Int

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

109116 -- a graceful shutdown of the web server.

110117 --

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

112135 }

113136

114137-- | Specify usage of the PROXY protocol.

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

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

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

147170 , settingsGracefulShutdownTimeout = Nothing

171+ , settingsGracefulCloseTimeout1 = 0

172+ , settingsGracefulCloseTimeout2 = 2000

173+ , settingsMaxTotalHeaderLength = 50 * 1024

148174 }

149175

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

88import qualified Data.ByteString as S

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

1010import Data.Typeable (Typeable)

11+import Data.X509

1112import Foreign.Ptr (Ptr)

1213import System.Posix.Types (Fd)

1314import qualified System.TimeManager as T

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

122123 , connWriteBuffer :: Buffer

123124 -- | The size of the write buffer.

124125 , connBufferSize :: BufSize

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

127+ , connHTTP2 :: IORef Bool

125128 }

126129

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+

127136----------------------------------------------------------------

128137

129138data InternalInfo = InternalInfo {

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

171180 , tlsMinorVersion :: Int

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

173182 , tlsChiperID :: Word16

183+ , tlsClientCertificate :: Maybe CertificateChain

174184 } -- ^ Encrypted channel: TLS or SSL

175185

176186isTransportSecure :: Transport -> Bool

warp/test/FileSpec.hs+1−1

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

2121 let WithBody s hs off len = ans

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

2323 ans' = WithBody s hs' off len

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

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

2525

2626spec :: Spec

2727spec = do

warp/test/RequestSpec.hs+11−7

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

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

88import Network.Wai.Handler.Warp.Request

99import Network.Wai.Handler.Warp.Types

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

1011import Test.Hspec

1112import Test.Hspec.QuickCheck

1213import qualified Data.ByteString as S

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

1718main :: IO ()

1819main = hspec spec

1920

21+defaultMaxTotalHeaderLength :: Int

22+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23+

2024spec :: Spec

2125spec = do

2226 describe "headerLines" $ do

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

6367 describe "headerLines" $ do

6468 it "can handle a nomarl case" $ do

6569 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

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

6872

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

7074 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

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

7377

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

7579 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

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

7882

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

8084 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

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

8387

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

8589 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

8791 x `shouldBe` []

88− y <- headerLines True src

92+ y <- headerLines defaultMaxTotalHeaderLength True src

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

9094

9195 where

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

111115 writeIORef ref z

112116 return y

113117 src' <- mkSource src

114− res <- headerLines True src'

118+ res <- headerLines defaultMaxTotalHeaderLength True src'

115119 return (res, src')

116120

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

warp/test/ResponseSpec.hs+11−15

@@ -10,7 +10,7 @@ import Network.HTTP.Types

1010import Network.Wai hiding (responseHeaders)

1111import Network.Wai.Handler.Warp

1212import Network.Wai.Handler.Warp.Response

13−import RunSpec (withApp, msClose, msWrite, msRead, connectTo)

13+import RunSpec (withApp, msWrite, msRead, withMySocket)

1414import Test.Hspec

1515

1616main :: IO ()

@@ -20,15 +20,13 @@ testRange :: S.ByteString -- ^ range value

2020 -> String -- ^ expected output

2121 -> Maybe String -- ^ expected content-range value

2222 -> Spec

23−testRange range out crange = it title $ withApp defaultSettings app $ \port -> do

24− handle <- connectTo port

25− msWrite handle "GET / HTTP/1.0\r\n"

26− msWrite handle "Range: bytes="

27− msWrite handle range

28− msWrite handle "\r\n\r\n"

23+testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

24+ msWrite ms "GET / HTTP/1.0\r\n"

25+ msWrite ms "Range: bytes="

26+ msWrite ms range

27+ msWrite ms "\r\n\r\n"

2928 threadDelay 10000

30− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead handle 1024

31− msClose handle

29+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

3230 last bss `shouldBe` out

3331 let hs = mapMaybe toHeader bss

3432 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

@@ -46,12 +44,10 @@ testPartial :: Integer -- ^ file size

4644 -> Integer -- ^ byte count

4745 -> String -- ^ expected output

4846 -> Spec

49−testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do

50− handle <- connectTo port

51− msWrite handle "GET / HTTP/1.0\r\n\r\n"

47+testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

48+ msWrite ms "GET / HTTP/1.0\r\n\r\n"

5249 threadDelay 10000

53− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead handle 1024

54− msClose handle

50+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

5551 out `shouldBe` last bss

5652 let hs = mapMaybe toHeader bss

5753 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

@@ -87,7 +83,7 @@ spec = do

8783 it "discards empty lines" $ do

8884 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

8985

90− context "when sanitizing single occurences of \n" $ do

86+ context "when sanitizing single occurrences of \n" $ do

9187 it "replaces \n with \r\n" $ do

9288 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

9389

warp/test/RunSpec.hs+38−47

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

11{-# LANGUAGE OverloadedStrings #-}

22{-# LANGUAGE ScopedTypeVariables #-}

33

4−module RunSpec (main, spec, withApp, connectTo, MySocket, msWrite, msRead, msClose) where

4+module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where

55

66import Control.Concurrent (forkIO, killThread, threadDelay)

77import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

@@ -37,7 +37,7 @@ type CounterApplication = Counter -> Application

3737

3838data MySocket = MySocket

3939 { msSocket :: !Socket

40− , _msBuffer :: !(I.IORef ByteString)

40+ , msBuffer :: !(I.IORef ByteString)

4141 }

4242

4343msWrite :: MySocket -> ByteString -> IO ()

@@ -70,9 +70,16 @@ msClose :: MySocket -> IO ()

7070msClose = Network.Socket.close . msSocket

7171

7272connectTo :: Int -> IO MySocket

73−connectTo port = MySocket

74− <$> (fst <$> getSocketTCP "127.0.0.1" port)

75− <*> I.newIORef mempty

73+connectTo port = do

74+ s <- fst <$> getSocketTCP "127.0.0.1" port

75+ ref <- I.newIORef mempty

76+ return MySocket {

77+ msSocket = s

78+ , msBuffer = ref

79+ }

80+

81+withMySocket :: (MySocket -> IO a) -> Int -> IO a

82+withMySocket body port = bracket (connectTo port) msClose body

7683

7784incr :: MonadIO m => Counter -> m ()

7885incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

@@ -150,8 +157,7 @@ runTest :: Int -- ^ expected number of requests

150157 -> IO ()

151158runTest expected app chunks = do

152159 ref <- I.newIORef (Right 0)

153− withApp defaultSettings (app ref) $ \port -> do

154− ms <- connectTo port

160+ withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

155161 forM_ chunks $ \chunk -> msWrite ms chunk

156162 _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

157163 res <- I.readIORef ref

@@ -168,10 +174,9 @@ runTerminateTest :: InvalidRequest

168174runTerminateTest expected input = do

169175 ref <- I.newIORef Nothing

170176 let onExc _ = I.writeIORef ref . Just

171− withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

172− handle <- connectTo port

173− msWrite handle input

174− msClose handle

177+ withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

178+ msWrite ms input

179+ msClose ms -- explicitly

175180 threadDelay 1000

176181 res <- I.readIORef ref

177182 show res `shouldBe` show (Just expected)

@@ -242,13 +247,11 @@ spec = do

242247 let app req f = do

243248 liftIO $ I.writeIORef iheaders $ requestHeaders req

244249 f $ responseLBS status200 [] ""

245− withApp defaultSettings app $ \port -> do

246− handle <- connectTo port

250+ withApp defaultSettings app $ withMySocket $ \ms -> do

247251 let input = S.concat

248252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

249253 ]

250− msWrite handle input

251− msClose handle

254+ msWrite ms input

252255 threadDelay 1000

253256 headers <- I.readIORef iheaders

254257 headers `shouldBe`

@@ -259,13 +262,11 @@ spec = do

259262 let app req f = do

260263 liftIO $ I.writeIORef iheaders $ requestHeaders req

261264 f $ responseLBS status200 [] ""

262− withApp defaultSettings app $ \port -> do

263− handle <- connectTo port

265+ withApp defaultSettings app $ withMySocket $ \ms -> do

264266 let input = S.concat

265267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

266268 ]

267− msWrite handle input

268− msClose handle

269+ msWrite ms input

269270 threadDelay 1000

270271 headers <- I.readIORef iheaders

271272 headers `shouldBe`

@@ -281,16 +282,14 @@ spec = do

281282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

282283 atomically $ modifyTVar countVar (+ 1)

283284 f $ responseLBS status200 [] ""

284− withApp defaultSettings app $ \port -> do

285− handle <- connectTo port

285+ withApp defaultSettings app $ withMySocket $ \ms -> do

286286 let input = S.concat

287287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

288288 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

289289 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

290290 , "b\r\nHello World\r\n0\r\n\r\n"

291291 ]

292− msWrite handle input

293− msClose handle

292+ msWrite ms input

294293 atomically $ do

295294 count <- readTVar countVar

296295 check $ count == 2

@@ -307,14 +306,12 @@ spec = do

307306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

308307 atomically $ modifyTVar countVar (+ 1)

309308 f $ responseLBS status200 [] ""

310− withApp defaultSettings app $ \port -> do

311− handle <- connectTo port

309+ withApp defaultSettings app $ withMySocket $ \ms -> do

312310 let input = concat $ replicate 2 $

313311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

314312 (replicate 50 "5\r\n12345\r\n") ++

315313 ["0\r\n\r\n"]

316− mapM_ (msWrite handle) input

317− msClose handle

314+ mapM_ (msWrite ms) input

318315 atomically $ do

319316 count <- readTVar countVar

320317 check $ count == 2

@@ -330,16 +327,14 @@ spec = do

330327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

331328 atomically $ modifyTVar countVar (+ 1)

332329 f $ responseLBS status200 [] ""

333− withApp defaultSettings app $ \port -> do

334− handle <- connectTo port

330+ withApp defaultSettings app $ withMySocket $ \ms -> do

335331 let input = S.concat

336332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

337333 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

338334 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

339335 , "b\r\nHello World\r\n0\r\n\r\n"

340336 ]

341− mapM_ (msWrite handle) $ map S.singleton $ S.unpack input

342− msClose handle

337+ mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

343338 atomically $ do

344339 count <- readTVar countVar

345340 check $ count == 2

@@ -360,20 +355,18 @@ spec = do

360355 E.throwIO (e :: E.SomeException)

361356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

362357 f $ responseLBS status200 [] ""

363− withApp (setTimeout 1 defaultSettings) app $ \port -> do

358+ withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

364359 let bs1 = S.replicate 2048 88

365360 bs2 = "This is short"

366361 bs = S.append bs1 bs2

367− handle <- connectTo port

368− msWrite handle "POST / HTTP/1.1\r\n"

369− msWrite handle "content-length: "

370− msWrite handle $ S8.pack $ show $ S.length bs

371− msWrite handle "\r\n\r\n"

362+ msWrite ms "POST / HTTP/1.1\r\n"

363+ msWrite ms "content-length: "

364+ msWrite ms $ S8.pack $ show $ S.length bs

365+ msWrite ms "\r\n\r\n"

372366 threadDelay 100000

373− msWrite handle bs1

367+ msWrite ms bs1

374368 threadDelay 100000

375− msWrite handle bs2

376− msClose handle

369+ msWrite ms bs2

377370 threadDelay 5000000

378371 front <- I.readIORef ifront

379372 S.concat (front []) `shouldBe` bs

@@ -389,8 +382,7 @@ spec = do

389382 loop

390383 loop

391384 doubleBS = S.concatMap $ \w -> S.pack [w, w]

392− withApp defaultSettings app $ \port -> do

393− ms <- connectTo port

385+ withApp defaultSettings app $ withMySocket $ \ms -> do

394386 msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

395387 timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

396388 msWrite ms "67890"

@@ -418,15 +410,14 @@ spec = do

418410 atomically $ modifyTVar countVar (+ 1)

419411 loop

420412 loop

421− withApp defaultSettings app $ \port -> do

422− (sock, _addr) <- getSocketTCP "127.0.0.1" port

423− sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

413+ withApp defaultSettings app $ withMySocket $ \ms -> do

414+ msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

424415 threadDelay 10000

425− sendAll sock "5\r\nhello\r\n0\r\n\r\n"

416+ msWrite ms "5\r\nhello\r\n0\r\n\r\n"

426417 atomically $ do

427418 count <- readTVar countVar

428419 check $ count >= 1

429− bs <- safeRecv sock 4096

420+ bs <- safeRecv (msSocket ms) 4096 -- must not use msRead

430421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

431422

432423 it "streaming response with length" $ do

warp/warp.cabal+4−1

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

11Name: warp

2−Version: 3.3.0

2+Version: 3.3.9

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

44License: MIT

55License-file: LICENSE

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

5656 , vault >= 0.3

5757 , wai >= 3.2 && < 3.3

5858 , word8

59+ , x509

5960 if impl(ghc < 8)

6061 Build-Depends: semigroups

6162 if flag(network-bytestring)

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

211212 , vault

212213 , wai >= 3.2 && < 3.3

213214 , word8

215+ , x509

214216 -- Build-Tool-Depends: hspec-discover:hspec-discover

215217 if impl(ghc < 8)

216218 Build-Depends: semigroups

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

249251 , network

250252 , time-manager

251253 , unix-compat

254+ , x509

252255 if impl(ghc < 8)

253256 Build-Depends: semigroups

254257