de74144...master · typeable/wai

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

since splitsnapshots

unifiedsplit

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

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8− stack-def:

9− BUILD: stack

10− stack-lts-6:

11− BUILD: stack

12− STACK_YAML: stack-lts-6.yaml

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

14− stack-lts-9:

15− BUILD: stack

16− STACK_YAML: stack-lts-9.yaml

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

18 stack-lts-11:

8 stack-lts-11:

19 BUILD: stack

9 BUILD: stack

20 STACK_YAML: stack-lts-11.yaml

10 STACK_YAML: stack-lts-11.yaml

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

23 BUILD: stack

13 BUILD: stack

24 STACK_YAML: stack-lts-12.yaml

14 STACK_YAML: stack-lts-12.yaml

25 ARGS: "--resolver lts-12"

15 ARGS: "--resolver lts-12"

26− stack-lts-13:

16+ stack-lts-14:

27 BUILD: stack

17 BUILD: stack

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

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

29− cabal-7.10.3:

19+ stack-nightly:

30− BUILD: cabal

20+ BUILD: stack

31− GHCVER: 7.10.3

21+ STACK_YAML: stack-nightly.yaml

32− CABALVER: 1.22

22+ ARGS: "--resolver nightly"

33− cabal-8.0.2:

34− BUILD: cabal

35− GHCVER: 8.0.2

36− CABALVER: 1.24

37 cabal-8.2.2:

23 cabal-8.2.2:

38 BUILD: cabal

24 BUILD: cabal

39 GHCVER: 8.4.4

25 GHCVER: 8.4.4

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

42 BUILD: cabal

28 BUILD: cabal

43 GHCVER: 8.4.4

29 GHCVER: 8.4.4

44 CABALVER: 2.2

30 CABALVER: 2.2

45− cabal-8.6.4:

31+ cabal-8.6.5:

46 BUILD: cabal

32 BUILD: cabal

47− GHCVER: 8.6.4

33+ GHCVER: 8.6.5

48 CABALVER: 2.4

34 CABALVER: 2.4

49 maxParallel: 6

35 maxParallel: 6

50 steps:

36 steps:

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

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

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8− stack-def:

9− BUILD: stack

10− stack-lts-6:

11− BUILD: stack

12− STACK_YAML: stack-lts-6.yaml

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

14− stack-lts-9:

15− BUILD: stack

16− STACK_YAML: stack-lts-9.yaml

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

18 stack-lts-11:

8 stack-lts-11:

19 BUILD: stack

9 BUILD: stack

20 STACK_YAML: stack-lts-11.yaml

10 STACK_YAML: stack-lts-11.yaml

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

23 BUILD: stack

13 BUILD: stack

24 STACK_YAML: stack-lts-12.yaml

14 STACK_YAML: stack-lts-12.yaml

25 ARGS: "--resolver lts-12"

15 ARGS: "--resolver lts-12"

26− stack-lts-13:

16+ stack-lts-14:

27 BUILD: stack

17 BUILD: stack

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

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

29 maxParallel: 3

19 maxParallel: 3

30 steps:

20 steps:

31 - script: |

21 - script: |

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

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

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8− stack-lts-13:

8+ stack-lts-14:

9 BUILD: stack

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

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

11 maxParallel: 3

12 steps:

13 - bash: |

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

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

17 stack setup $ARGS > /dev/null

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

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

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

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

20 env:

21 env:

21 OS_NAME: ${{ parameters.os }}

22 OS_NAME: ${{ parameters.os }}

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

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

.gitignore+1

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

9cabal.sandbox.config

10.stack-work/

11*~

12+stack*.yaml.lock

auto-update/ChangeLog.md+5

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

1# ChangeLog for auto-update

2

3+## 0.1.6

4+

5+* Add control of activation on leading vs. trailing edges for Control.Debounce

6+ [#756](https://github.com/yesodweb/wai/pull/756)

7+

3## 0.1.5

8## 0.1.5

4

9

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

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

auto-update/Control/Debounce.hs+19−53

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

11-- printString <- 'mkDebounce' 'defaultDebounceSettings'

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

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

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

14-- }

15-- }

15-- @

16-- @

16--

17--

@@ -25,70 +26,35 @@

25-- @since 0.1.2

26-- @since 0.1.2

26module Control.Debounce

27module Control.Debounce

27 ( -- * Type

28 ( -- * Type

28− DebounceSettings

29+ DI.DebounceSettings

29 , defaultDebounceSettings

30 , defaultDebounceSettings

30 -- * Accessors

31 -- * Accessors

31− , debounceFreq

32+ , DI.debounceFreq

32− , debounceAction

33+ , DI.debounceAction

34+ , DI.debounceEdge

35+ , DI.leadingEdge

36+ , DI.trailingEdge

33 -- * Creation

37 -- * Creation

34 , mkDebounce

38 , mkDebounce

35 ) where

39 ) where

36

40

37−import Control.Concurrent (forkIO, threadDelay)

41+import Control.Concurrent (newEmptyMVar, threadDelay)

38−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)

42+import qualified Control.Debounce.Internal as DI

39−import Control.Exception (SomeException, handle, mask_)

40−import Control.Monad (forever, void)

41−

42−-- | Settings to control how debouncing should work.

43−--

44−-- This should be constructed using 'defaultDebounceSettings' and record

45−-- update syntax, e.g.:

46−--

47−-- @

48−-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }

49−-- @

50−--

51−-- @since 0.1.2

52−data DebounceSettings = DebounceSettings

53− { debounceFreq :: Int

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

55− -- action.

56− --

57− -- Default: 1 second (1000000)

58− --

59− -- @since 0.1.2

60− , debounceAction :: IO ()

61− -- ^ Action to be performed.

62− --

63− -- Note: all exceptions thrown by this action will be silently discarded.

64− --

65− -- Default: does nothing.

66− --

67− -- @since 0.1.2

68− }

69

43

70-- | Default value for creating a 'DebounceSettings'.

44-- | Default value for creating a 'DebounceSettings'.

71--

45--

72-- @since 0.1.2

46-- @since 0.1.2

73−defaultDebounceSettings :: DebounceSettings

47+defaultDebounceSettings :: DI.DebounceSettings

74−defaultDebounceSettings = DebounceSettings

48+defaultDebounceSettings = DI.DebounceSettings

75− { debounceFreq = 1000000

49+ { DI.debounceFreq = 1000000

76− , debounceAction = return ()

50+ , DI.debounceAction = return ()

51+ , DI.debounceEdge = DI.leadingEdge

77 }

52 }

78

53

79−-- | Generate an action which will trigger the debounced action to be

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

80−-- performed. The action will either be performed immediately, or after the

81−-- current cooldown period has expired.

82--

55--

83-- @since 0.1.2

56-- @since 0.1.2

84−mkDebounce :: DebounceSettings -> IO (IO ())

57+mkDebounce :: DI.DebounceSettings -> IO (IO ())

85−mkDebounce (DebounceSettings freq action) = do

58+mkDebounce settings = do

86− baton <- newEmptyMVar

59+ baton <- newEmptyMVar

87− mask_ $ void $ forkIO $ forever $ do

60+ DI.mkDebounceInternal baton threadDelay settings

88− takeMVar baton

89− ignoreExc action

90− threadDelay freq

91− return $ void $ tryPutMVar baton ()

92−

93−ignoreExc :: IO () -> IO ()

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

auto-update/Control/Debounce/Internal.hsnew file+98

@@ -0,0 +1,98 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

2+

3+-- | Unstable API which exposes internals for testing.

4+module Control.Debounce.Internal (

5+ DebounceSettings(..)

6+ , DebounceEdge(..)

7+ , leadingEdge

8+ , trailingEdge

9+ , mkDebounceInternal

10+ ) where

11+

12+import Control.Concurrent (forkIO)

13+import Control.Concurrent.MVar (takeMVar, tryPutMVar, tryTakeMVar, MVar)

14+import Control.Exception (SomeException, handle, mask_)

15+import Control.Monad (forever, void)

16+

17+-- | Settings to control how debouncing should work.

18+--

19+-- This should be constructed using 'defaultDebounceSettings' and record

20+-- update syntax, e.g.:

21+--

22+-- @

23+-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }

24+-- @

25+--

26+-- @since 0.1.2

27+data DebounceSettings = DebounceSettings

28+ { debounceFreq :: Int

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

30+ --

31+ -- Default: 1 second (1000000)

32+ --

33+ -- @since 0.1.2

34+ , debounceAction :: IO ()

35+ -- ^ Action to be performed.

36+ --

37+ -- Note: all exceptions thrown by this action will be silently discarded.

38+ --

39+ -- Default: does nothing.

40+ --

41+ -- @since 0.1.2

42+ , debounceEdge :: DebounceEdge

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

44+ -- the timeout.

45+ --

46+ -- Default: 'trailingEdge'.

47+ --

48+ -- @since 0.1.6

49+ }

50+

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

52+-- edge of the timeout.

53+--

54+-- @since 0.1.6

55+data DebounceEdge =

56+ Leading

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.

60+ | Trailing

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.

63+ deriving (Show, Eq)

64+

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+

81+mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())

82+mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do

83+ mask_ $ void $ forkIO $ forever $ do

84+ takeMVar baton

85+ case edge of

86+ Leading -> do

87+ ignoreExc action

88+ delayFn freq

89+ Trailing -> do

90+ delayFn freq

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

92+ void $ tryTakeMVar baton

93+ ignoreExc action

94+

95+ return $ void $ tryPutMVar baton ()

96+

97+ignoreExc :: IO () -> IO ()

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

auto-update/auto-update.cabal+11−9

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

1name: auto-update

2−version: 0.1.5

2+version: 0.1.6

3synopsis: Efficiently run periodic, on-demand actions

4description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.

5homepage: https://github.com/yesodweb/wai

@@ -17,6 +17,7 @@ library

17 ghc-options: -Wall

18 exposed-modules: Control.AutoUpdate

19 Control.Debounce

20+ Control.Debounce.Internal

20 Control.Reaper

21 Control.Reaper

21 other-modules: Control.AutoUpdate.Util

22 other-modules: Control.AutoUpdate.Util

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

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

@@ -26,11 +27,12 @@ library

26

27

27-- Test suite is currently not robust enough, gives too many false negatives.

28-- Test suite is currently not robust enough, gives too many false negatives.

28

29

29−-- test-suite spec

30+test-suite spec

30−-- main-is: Spec.hs

31+ main-is: Spec.hs

31−-- other-modules: Control.AutoUpdateSpec

32+ other-modules: Control.AutoUpdateSpec

33+ Control.DebounceSpec

32−-- Control.ReaperSpec

34+ Control.ReaperSpec

33−-- hs-source-dirs: test

35+ hs-source-dirs: test

34−-- type: exitcode-stdio-1.0

36+ type: exitcode-stdio-1.0

35−-- build-depends: base, auto-update, hspec

37+ build-depends: base, auto-update, exceptions, hspec, retry, HUnit

36−-- default-language: Haskell2010

38+ default-language: Haskell2010

auto-update/test/Control/AutoUpdateSpec.hs+26−25

@@ -1,34 +1,35 @@

1module Control.AutoUpdateSpec (spec) where

2

3−import Test.Hspec

3+import Control.AutoUpdate

4−import Test.Hspec.QuickCheck

5−import Data.IORef

6import Control.Concurrent (threadDelay)

4import Control.Concurrent (threadDelay)

7import Control.Monad (replicateM_, forM_)

5import Control.Monad (replicateM_, forM_)

8−import Control.AutoUpdate

6+import Data.IORef

7+import Test.Hspec

8+import Test.Hspec.QuickCheck

9

10spec :: Spec

11−spec = do

11+spec = return ()

12+ -- do

12− prop "incrementer" $ \st' -> do

13+ -- prop "incrementer" $ \st' -> do

13− let st = abs st' `mod` 10000

14+ -- let st = abs st' `mod` 10000

14− ref <- newIORef 0

15+ -- ref <- newIORef 0

15− next <- mkAutoUpdate defaultUpdateSettings

16+ -- next <- mkAutoUpdate defaultUpdateSettings

16− { updateAction = atomicModifyIORef ref $ \i ->

17+ -- { updateAction = atomicModifyIORef ref $ \i ->

17− let i' = succ i in i' `seq` (i', i')

18+ -- let i' = succ i in i' `seq` (i', i')

18− , updateSpawnThreshold = st

19+ -- , updateSpawnThreshold = st

19− , updateFreq = 10000

20+ -- , updateFreq = 10000

20− }

21+ -- }

21

22

22− forM_ [1..st + 1] $ \i -> do

23+ -- forM_ [1..st + 1] $ \i -> do

23− j <- next

24+ -- j <- next

24− j `shouldBe` i

25+ -- j `shouldBe` i

25

26

26− replicateM_ 50 $ do

27+ -- replicateM_ 50 $ do

27− i <- next

28+ -- i <- next

28− i `shouldBe` st + 2

29+ -- i `shouldBe` st + 2

29

30

30− threadDelay 60000

31+ -- threadDelay 60000

31− last1 <- readIORef ref

32+ -- last1 <- readIORef ref

32− threadDelay 20000

33+ -- threadDelay 20000

33− last2 <- readIORef ref

34+ -- last2 <- readIORef ref

34− last2 `shouldBe` last1

35+ -- last2 `shouldBe` last1

auto-update/test/Control/DebounceSpec.hsnew file+120

@@ -0,0 +1,120 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

2+module Control.DebounceSpec (spec) where

3+

4+import Control.Concurrent

5+import Control.Debounce

6+import qualified Control.Debounce.Internal as DI

7+import Control.Monad

8+import Control.Monad.Catch

9+import Control.Retry

10+import Data.IORef

11+import Test.HUnit.Lang

12+import Test.Hspec

13+

14+spec :: Spec

15+spec = describe "mkDebounce" $ do

16+ describe "Leading edge" $ do

17+ it "works for a single event" $ do

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

19+

20+ debounced

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

22+

23+ returnFromWait

24+ pause

25+ readIORef ref >>= (`shouldBe` 1)

26+

27+ -- Try another round

28+ debounced

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

30+

31+ returnFromWait

32+ pause

33+ readIORef ref >>= (`shouldBe` 2)

34+

35+ it "works for multiple events" $ do

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

37+

38+ debounced

39+ waitForBatonToBeTaken baton

40+ debounced

41+ pause

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

43+

44+ returnFromWait

45+ pause

46+ readIORef ref >>= (`shouldBe` 2)

47+

48+ describe "Trailing edge" $ do

49+ it "works for a single event" $ do

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

51+

52+ debounced

53+ pause

54+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)

55+

56+ returnFromWait

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

58+

59+ -- Try another round

60+ debounced

61+ pause

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

63+

64+ returnFromWait

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

66+

67+ it "works for multiple events" $ do

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

69+

70+ debounced

71+ waitForBatonToBeTaken baton

72+ debounced

73+ pause

74+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)

75+

76+ returnFromWait

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

78+

79+

80+-- | Make a controllable delay function

81+getWaitAction :: IO (p -> IO (), IO ())

82+getWaitAction = do

83+ waitVar <- newEmptyMVar

84+ let waitAction _ = takeMVar waitVar

85+ let returnFromWait = putMVar waitVar ()

86+ return (waitAction, returnFromWait)

87+

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

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

90+getDebounce edge = do

91+ ref :: IORef Int <- newIORef 0

92+ let action = modifyIORef ref (+ 1)

93+

94+ (waitAction, returnFromWait) <- getWaitAction

95+

96+ baton <- newEmptyMVar

97+

98+ debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings {

99+ debounceFreq = 5000000 -- unused

100+ , debounceAction = action

101+ , debounceEdge = edge

102+ }

103+

104+ return (ref, debounced, baton, returnFromWait)

105+

106+-- | Pause briefly (100ms)

107+pause :: IO ()

108+pause = threadDelay 100000

109+

110+waitForBatonToBeTaken :: MVar () -> IO ()

111+waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing)

112+

113+-- | Wait up to n seconds for an action to complete without throwing an HUnitFailure

114+waitUntil :: Int -> IO a -> IO ()

115+waitUntil n action = recovering policy [handler] (\_status -> void action)

116+ where policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds

117+ handler _status = Handler (\(HUnitFailure {}) -> return True)

118+

119+main :: IO ()

120+main = hspec spec

auto-update/test/Control/ReaperSpec.hs+29−27

@@ -1,37 +1,39 @@

1module Control.ReaperSpec (spec) where

2

3−import Control.Reaper

4import Control.Concurrent

3import Control.Concurrent

4+import Control.Reaper

5+import Data.IORef

5import Test.Hspec

6import Test.Hspec

6import Test.Hspec.QuickCheck

7import Test.Hspec.QuickCheck

7−import Data.IORef

8

9−type Item = (Int, IORef Int)

10−

11−action = mkListAction $ \(i, ref) -> do

12− modifyIORef ref succ

13− return $ if i > 1

14− then Just (pred i, ref)

15− else Nothing

16

9

17spec :: Spec

10spec :: Spec

11+spec = return ()

18−spec = prop "works" $ \is -> do

12+-- prop "works" $ \is -> do

19− reaper <- mkReaper defaultReaperSettings

13+-- reaper <- mkReaper defaultReaperSettings

20− { reaperAction = action

14+-- { reaperAction = action

21− , reaperDelay = 1000

15+-- , reaperDelay = 1000

22− }

16+-- }

17+

18+-- let mkTestCase i = do

19+-- ref <- newIORef 0

20+-- let expected = (abs i `mod` 10) + 1

21+-- reaperAdd reaper (expected, ref)

22+-- return (expected, ref)

23+-- testCases <- mapM mkTestCase is

24+

25+-- let test (expected, ref) = do

26+-- actual <- readIORef ref

27+-- actual `shouldBe` (expected :: Int)

28+-- threadDelay 100000

29+-- mapM_ test testCases

30+-- [] <- reaperRead reaper

31+-- return ()

23

32

24− let mkTestCase i = do

33+-- type Item = (Int, IORef Int)

25− ref <- newIORef 0

26− let expected = (abs i `mod` 10) + 1

27− reaperAdd reaper (expected, ref)

28− return (expected, ref)

29− testCases <- mapM mkTestCase is

30

34

31− let test (expected, ref) = do

35+-- action = mkListAction $ \(i, ref) -> do

32− actual <- readIORef ref

36+-- modifyIORef ref succ

33− actual `shouldBe` (expected :: Int)

34− threadDelay 100000

35− mapM_ test testCases

36− [] <- reaperRead reaper

37− return ()

37+-- return $ if i > 1

38+-- then Just (pred i, ref)

39+-- else Nothing

stack-lts-11.yaml+3−6

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

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

18- http2-2.0.0

19- network-byte-order-0.1.1.0

20+- tls-1.5.3

21+- tls-session-manager-0.0.4

22+- x509-1.7.5

20nix:

23nix:

21 enable: false

24 enable: false

22 packages:

25 packages:

23 - fcgi

26 - fcgi

24 - zlib

27 - zlib

25−image:

26− containers:

27− - base: "fpco/pid1"

28− name: "yesodweb/warp"

29− executables:

30− - warp

stack-lts-12.yaml+3−6

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

18 packages:

19 - fcgi

20 - zlib

21−image:

22− containers:

23− - base: "fpco/pid1"

24− name: "yesodweb/warp"

25− executables:

26− - warp

27extra-deps:

21extra-deps:

28- http2-2.0.0

22- http2-2.0.0

29- network-byte-order-0.1.1.0

23- network-byte-order-0.1.1.0

24+- tls-1.5.3

25+- tls-session-manager-0.0.4

26+- x509-1.7.5

stack-lts-6.yamldeleted−35

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

1−resolver: lts-6.35

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−extra-deps:

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

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

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

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

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

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

20−- basement-0.0.7@rev:0

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

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

23−- http2-2.0.0

24−- network-byte-order-0.1.1.0

25−nix:

26− enable: false

27− packages:

28− - fcgi

29− - zlib

30−image:

31− containers:

32− - base: "fpco/pid1"

33− name: "yesodweb/warp"

34− executables:

35− - warp

stack-lts-9.yamldeleted−31

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

1−resolver: lts-9.21

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−extra-deps:

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

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

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

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

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

19−- http2-2.0.0

20−- network-byte-order-0.1.1.0

21−nix:

22− enable: false

23− packages:

24− - fcgi

25− - zlib

26−image:

27− containers:

28− - base: "fpco/pid1"

29− name: "yesodweb/warp"

30− executables:

31− - warp

stack-nightly.yamlnew file+20

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

1+resolver: nightly-2020-01-08

2+packages:

3+- ./auto-update

4+- ./mime-types

5+- ./wai

6+- ./wai-extra

7+- ./warp

8+- ./warp-tls

9+- ./wai-app-static

10+- ./wai-websockets

11+- ./wai-conduit

12+- ./time-manager

13+flags:

14+ wai-extra:

15+ build-example: true

16+nix:

17+ enable: false

18+ packages:

19+ - fcgi

20+ - zlib

stack.yaml+3−7

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

1−resolver: lts-13.14

1+resolver: lts-14.22

2packages:

3- ./auto-update

4- ./mime-types

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

18 packages:

19 - fcgi

20 - zlib

21−image:

22− containers:

23− - base: "fpco/pid1"

24− name: "yesodweb/warp"

25− executables:

26− - warp

27extra-deps:

21extra-deps:

28- http2-2.0.0

22- http2-2.0.0

29- network-byte-order-0.1.1.0

23- network-byte-order-0.1.1.0

24+- tls-1.5.3

25+- tls-session-manager-0.0.4

wai-app-static/ChangeLog.md+10

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

1+# wai-app-static changelog

2+

3+## 3.1.7.1

4+

5+* Update the test suite too

6+

7+## 3.1.7

8+

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

10+

1## 3.1.6.3

11## 3.1.6.3

2

12

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

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

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

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

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

165 -- with an ETag header.

166 --

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

167+ -- RFC7232 (HTTP 1.1):

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

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

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

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

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

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

171− -- new file being sent anyway.

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

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

173+ -- > If-None-Match.

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

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

173

175

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

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

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

243 response :: StaticResponse -> IO W.ResponseReceived

245 response :: StaticResponse -> IO W.ResponseReceived

244 response (FileResponse file ch) = do

246 response (FileResponse file ch) = do

245 mimetype <- ssGetMimeType ss file

247 mimetype <- ssGetMimeType ss file

246− let filesize = fileGetSize file

248+ -- let filesize = fileGetSize file

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

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

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

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

249 -- range requests into account

251 -- range requests into account

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

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

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

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

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

269

271

270− sendResponse $ W.responseLBS H.status301

272+ sendResponse $ W.responseLBS H.status302

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

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

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

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

273 ] "Redirect"

275 ] "Redirect"

274

276

275 response (RawRedirect path) =

277 response (RawRedirect path) =

276− sendResponse $ W.responseLBS H.status301

278+ sendResponse $ W.responseLBS H.status302

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

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

278 , ("Location", path)

280 , ("Location", path)

279 ] "Redirect"

281 ] "Redirect"

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

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

39 }

40

41#if MIN_VERSION_optparse_applicative(0, 10, 0)

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

42option' = option auto

43option' = option auto

43#else

44#else

44option' = option

45option' = option

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

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

64

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

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

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

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

68

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

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

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

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

7

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

9import Codec.Compression.GZip (compress)

10−import Control.Applicative

11import Data.ByteString.Unsafe (unsafePackAddressLen)

10import Data.ByteString.Unsafe (unsafePackAddressLen)

12import Data.Either (lefts, rights)

11import Data.Either (lefts, rights)

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

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

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

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

59toPieces = mapM toPiece

60

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

62+--

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

62type Pieces = [Piece]

64type Pieces = [Piece]

63

65

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

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

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

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

57 assertStatus 200 =<<

58 request (setRawPathInfo defRequest path)

59

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

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

61 assertStatus 404 =<<

62 request (setRawPathInfo defRequest "doesNotExist")

63

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

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

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

66− assertStatus 301 req

66+ assertStatus 302 req

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

68

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

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

71 }

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

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

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

74 req <- request (setRawPathInfo defRequest path)

75− assertStatus 301 req

75+ assertStatus 302 req

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

77

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

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

131 assertStatus 304 req

132 assertNoHeader "Cache-Control" req

133

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

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

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

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

137− assertStatus 301 req

137+ assertStatus 302 req

138 assertHeader "Location" "/a/" req

139

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

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

144 inTempDirectory $ fileServerAppWithSettings settings $ do

145 liftIO $ touch "foo/index.html"

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

147− assertStatus 301 req

147+ assertStatus 302 req

148 assertHeader "Location" "/foo/" req

149

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

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

158 "urlMapApp: only works at subPath"

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

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

161− assertStatus 301 req

161+ assertStatus 302 req

162 assertHeader "Location" "/subPath/" req

163

164 context "with defaultWebAppSettings" $ do

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

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

1name: wai-app-static

2−version: 3.1.6.3

2+version: 3.1.7.1

3license: MIT

4license-file: LICENSE

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

@@ -49,7 +49,7 @@ library

49 , filepath

50 , wai-extra >= 3.0 && < 3.1

51 , optparse-applicative >= 0.7

52− , warp >= 3.0.11 && < 3.3

52+ , warp >= 3.0.11 && < 3.4

53

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

55 WaiAppStatic.Storage.Filesystem

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

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

17import Control.Monad (unless)

18import Network.HTTP.Types

19import Data.ByteString.Builder (Builder)

20−import Data.IORef

21import qualified Data.Conduit.List as CL

20import qualified Data.Conduit.List as CL

22

21

23-- | Stream the request body.

22-- | Stream the request body.

24--

23--

25-- Since 3.0.0

24-- Since 3.0.0

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

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

27sourceRequestBody req =

26sourceRequestBody req =

28 loop

27 loop

29 where

28 where

30− go = liftIO (requestBody req)

29+ go = liftIO (getRequestBodyChunk req)

31

30

32 loop = do

31 loop = do

33 bs <- go

32 bs <- go

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

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

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

39--

38--

40-- Since 3.0.0

39-- Since 3.0.0

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

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

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

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

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

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

44 case mbuilder of

43 case mbuilder of

45 Chunk b -> send b

44 Chunk b -> send b

46 Flush -> flush)

45 Flush -> flush)

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

50--

49--

51-- Since 3.0.0

50-- Since 3.0.0

52responseRawSource :: (MonadIO m, MonadIO n)

51responseRawSource :: (MonadIO m, MonadIO n)

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

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

54 -> Response

53 -> Response

55 -> Response

54 -> Response

56responseRawSource app =

55responseRawSource app =

wai-extra/ChangeLog.md+16

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

1# Changelog for wai-extra

2

3+## 3.0.29.1

4+

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

6+

7+## 3.0.29

8+

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

10+

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+

3## 3.0.26.1

19## 3.0.26.1

4

20

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

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

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

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

5 headers:

6

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

8+

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

8-}

10-}

9module Network.Wai.EventSource (

11module Network.Wai.EventSource (

10 ServerEvent(..),

12 ServerEvent(..),

11 eventSourceAppChan,

13 eventSourceAppChan,

12− eventSourceAppIO

14+ eventSourceAppIO,

15+ eventStreamAppRaw

13 ) where

16 ) where

14

17

15import Data.Function (fix)

18import Data.Function (fix)

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

39 case eventToBuilder se of

42 case eventToBuilder se of

40 Nothing -> return ()

43 Nothing -> return ()

41 Just b -> sendChunk b >> flush >> loop

44 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 @@

1{-# 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 -}

3

4{-|

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

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

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

89-- if gzip is supported.

90--

91-- 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'.

92gzip :: GzipSettings -> Middleware

95gzip :: GzipSettings -> Middleware

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

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

94 case res of

97 case res of

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

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

14 , OutputFormat (..)

15 , OutputFormatter

16 , OutputFormatterWithDetails

17+ , OutputFormatterWithDetailsAndHeaders

17 , Destination (..)

18 , Destination (..)

18 , Callback

19 , Callback

19 , IPAddrSource (..)

20 , IPAddrSource (..)

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

49import Network.Wai.Header (contentLength)

50import Network.Wai.Header (contentLength)

50import Data.Text.Encoding (decodeUtf8')

51import Data.Text.Encoding (decodeUtf8')

51

52

53+data OutputFormat

52−data OutputFormat = Apache IPAddrSource

54+ = Apache IPAddrSource

53− | Detailed Bool -- ^ use colors?

55+ | Detailed Bool -- ^ use colors?

54− | CustomOutputFormat OutputFormatter

56+ | CustomOutputFormat OutputFormatter

55− | CustomOutputFormatWithDetails OutputFormatterWithDetails

57+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

58+ | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

56

59

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

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

61+

58−type OutputFormatterWithDetails =

62+type OutputFormatterWithDetails

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

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

60

89

61data Destination = Handle Handle

90data Destination = Handle Handle

62 | Logger LoggerSet

91 | Logger LoggerSet

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

108 CustomOutputFormatWithDetails formatter -> do

137 CustomOutputFormatWithDetails formatter -> do

109 getdate <- getDateGetter flusher

138 getdate <- getDateGetter flusher

110 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

139 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

140+ CustomOutputFormatWithDetailsAndHeaders formatter -> do

141+ getdate <- getDateGetter flusher

142+ return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

111

143

112apacheMiddleware :: ApacheLoggerActions -> Middleware

144apacheMiddleware :: ApacheLoggerActions -> Middleware

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

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

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

138 readIORef builderIO

170 readIORef builderIO

139 return rspRcv

171 return rspRcv

140

172

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

141-- | Production request logger middleware.

191-- | Production request logger middleware.

142--

192--

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

193-- 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 @@

1{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE CPP #-}

3

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

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

5+ ( formatAsJSON

6+ , formatAsJSONWithHeaders

7+ ) where

5

8

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

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

7import Data.ByteString.Lazy (toStrict)

10import Data.ByteString.Lazy (toStrict)

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

40 , "time" .= decodeUtf8With lenientDecode date

43 , "time" .= decodeUtf8With lenientDecode date

41 ]) <> "\n"

44 ]) <> "\n"

42

45

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+

43word32ToHostAddress :: Word32 -> Text

70word32ToHostAddress :: Word32 -> Text

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

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

45

72

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

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

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

91 hToJ hd = headerToJSON hd

118 hToJ hd = headerToJSON hd

92

119

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+

93headerToJSON :: Header -> Value

126headerToJSON :: Header -> Value

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

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

95

128

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

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

169--

170-- as the following example demonstrates.

171--

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.

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

174--

175-- @

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

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

99data SRequest = SRequest

100 { simpleRequest :: Request

101 , simpleRequestBody :: L.ByteString

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

103+ --

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

105+ -- in 'simpleRequest'.

102 }

106 }

103data SResponse = SResponse

107data SResponse = SResponse

104 { simpleStatus :: H.Status

108 { simpleStatus :: H.Status

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

106 , simpleBody :: L.ByteString

110 , simpleBody :: L.ByteString

107 }

111 }

108 deriving (Show, Eq)

112 deriving (Show, Eq)

113+

109request :: Request -> Session SResponse

114request :: Request -> Session SResponse

110−request = srequest . flip SRequest L.empty

115+request req = do

116+ app <- ask

117+ req' <- addCookiesToRequest req

118+ response <- liftIO $ do

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

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

121+ readIORef ref

122+ extractSetCookieFromSResponse response

111

123

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

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

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

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

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

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

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

167 return response

179 return response

168

180

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

182+-- 'L.ByteString'.

169srequest :: SRequest -> Session SResponse

183srequest :: SRequest -> Session SResponse

170srequest (SRequest req bod) = do

184srequest (SRequest req bod) = do

171− app <- ask

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

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

186+ request $

173− let req' = req

187+ req

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

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

175− case bss of

189+ case bss of

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

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

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

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

178− }

192+ }

179− req'' <- addCookiesToRequest req'

180− response <- liftIO $ do

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

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

183− readIORef ref

184− extractSetCookieFromSResponse response

185

193

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

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

187runResponse ref res = do

195runResponse ref res = do

wai-extra/example/Main.hs+11

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

37 Nothing

38 [string8 . show $ time]

39

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+

40main :: IO ()

51main :: IO ()

41main = do

52main = do

42 chan <- newChan

53 chan <- newChan

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

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

3

4import Control.Monad (void)

5

6+import qualified Data.IORef as IORef

7+

6import qualified Data.Text.Encoding as TE

8import qualified Data.Text.Encoding as TE

7

9

8import Data.Time.Calendar (fromGregorian)

10import Data.Time.Calendar (fromGregorian)

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

53 it "sets rawQueryString to empty string" $ do

55 it "sets rawQueryString to empty string" $ do

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

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

55

57

58+ describe "srequest" $ do

59+

60+ let echoApp req respond = do

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

62+ let reqHeaders = requestHeaders req

63+ respond $

64+ responseLBS

65+ status200

66+ reqHeaders

67+ reqBody

68+

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

70+ sresp <- flip runSession echoApp $

71+ srequest $ SRequest defaultRequest "request body"

72+ simpleBody sresp `shouldBe` "request body"

73+

56 describe "request" $ do

74 describe "request" $ do

57

75

58− let simpleApp _req respond =

76+ let echoApp req respond = do

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

78+ let reqHeaders = requestHeaders req

59 respond $

79 respond $

60 responseLBS

80 responseLBS

61 status200

81 status200

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

82+ reqHeaders

63− "simple"

83+ reqBody

64

84

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

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

66− sresp <- runSession (request defaultRequest) simpleApp

86+ sresp <- runSession (request defaultRequest) echoApp

67 simpleStatus sresp `shouldBe` status200

87 simpleStatus sresp `shouldBe` status200

68

88

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

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

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

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

92+ sresp <- flip runSession echoApp $

93+ request $

70− sresp <- runSession (request defaultRequest) simpleApp

94+ defaultRequest

95+ { requestBody = getBodyChunk

96+ }

71− simpleBody sresp `shouldBe` "simple"

97+ simpleBody sresp `shouldBe` "request body"

72−

98+

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

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

100+ sresp <- flip runSession echoApp $

101+ request $

74− sresp <- runSession (request defaultRequest) simpleApp

102+ defaultRequest

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

104+ }

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

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

76

106

77 let cookieApp req respond =

107 let cookieApp req respond =

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

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

1Name: wai-extra

2−Version: 3.0.26.1

2+Version: 3.0.29.1

3Synopsis: Provides some basic WAI handlers and middleware.

4description:

5 Provides basic WAI handler and middleware functionality:

@@ -87,7 +87,7 @@ flag build-example

87 default: False

88

89Library

90− Build-Depends: base >= 4.6 && < 5

90+ Build-Depends: base >= 4.8 && < 5

91 , bytestring >= 0.10.4

92 , wai >= 3.0.3.0 && < 3.3

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

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

99 , text >= 0.7

100 , case-insensitive >= 0.2

101 , data-default-class

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

102+ , fast-logger >= 2.4.5

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

103+ , wai-logger >= 2.3.2

104 , ansi-terminal

105 , resourcet >= 0.4.6 && < 1.3

106 , void >= 0.5

wai-http2-extra/Network/Wai/Middleware/Push/Referer.hs+4−2

@@ -120,10 +120,12 @@ pushOnReferer settings@Settings{..} app req sendResponse = do

120 when (isNothing mauth

121 || requestHeaderHost req == mauth) $ do

122 when (path /= refPath) $ do -- just in case

123+ let !path' = BS.copy path

124+ !refPath' = BS.copy refPath

123− mpp <- makePushPromise refPath path file

125+ mpp <- makePushPromise refPath' path' file

124 case mpp of

126 case mpp of

125 Nothing -> return ()

127 Nothing -> return ()

126− Just pp -> reaperAdd reaper (refPath,pp)

128+ Just pp -> reaperAdd reaper (refPath',pp)

127 ps -> do

129 ps -> do

128 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

130 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

129 setHTTP2Data req (Just h2d)

131 setHTTP2Data req (Just h2d)

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

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

1Name: wai-http2-extra

2−Version: 0.1.0

2+Version: 0.1.2

3Synopsis: WAI utilities for HTTP/2

4License: MIT

5License-file: LICENSE

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

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

9Category: Web

10Build-Type: Simple

11−Cabal-Version: >=1.8

11+Cabal-Version: >=1.10

12Stability: Stable

13Description: WAI utilities for HTTP/2

14

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

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

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

26 Ghc-Options: -Wall

27+ if impl(ghc >= 8)

28+ default-extensions: Strict StrictData

29+ default-language: Haskell2010

27

30

28Test-Suite doctest

31Test-Suite doctest

29 Type: exitcode-stdio-1.0

32 Type: exitcode-stdio-1.0

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

32 Main-Is: doctests.hs

35 Main-Is: doctests.hs

33 Build-Depends: base

36 Build-Depends: base

34 , doctest >= 0.10.1

37 , doctest >= 0.10.1

38+ if impl(ghc >= 8)

39+ default-extensions: Strict StrictData

40+ default-language: Haskell2010

41+

35Source-Repository head

42Source-Repository head

36 Type: git

43 Type: git

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

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

8nearby to check out the functions we use.

9

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

11+> {-# LANGUAGE CPP #-}

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

11> import Data.Char (isPunctuation, isSpace)

13> import Data.Char (isPunctuation, isSpace)

12> import Data.Monoid (mappend)

14> import Data.Monoid (mappend)

13> import Data.Text (Text)

15> import Data.Text (Text)

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

99

101

100> application state pending = do

102> application state pending = do

101> conn <- WS.acceptRequest pending

103> conn <- WS.acceptRequest pending

104+#if __GLASGOW_HASKELL__ >= 806

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

106+#else

102> WS.forkPingThread conn 30

107> WS.forkPingThread conn 30

108+#endif

103

109

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

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

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

106

112

107> msg <- WS.receiveData conn

113> msg <- WS.receiveData conn

wai-websockets/wai-websockets.cabal+1

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

45 , text

46 , file-embed

47 , http-types

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

48 else

49 else

49 buildable: False

50 buildable: False

50

51

warp-tls/ChangeLog.md+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+

1## 3.2.6

23## 3.2.6

2

24

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

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

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

54import Data.Typeable (Typeable)

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

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

57+import Network.Socket (gracefulClose)

58+#endif

56import Network.Socket.ByteString (sendAll)

59import Network.Socket.ByteString (sendAll)

57import qualified Network.TLS as TLS

60import qualified Network.TLS as TLS

58import qualified Crypto.PubKey.DH as DH

61import qualified Crypto.PubKey.DH as DH

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

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

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

279 runSettingsConnectionMakerSecure set get app

282 runSettingsConnectionMakerSecure set get app

280 where

283 where

281− get = getter tlsset sock params

284+ get = getter tlsset set sock params

282 params = def { -- TLS.ServerParams

285 params = def { -- TLS.ServerParams

283 TLS.serverWantClientCert = tlsWantClientCert

286 TLS.serverWantClientCert = tlsWantClientCert

284 , TLS.serverCACertificates = []

287 , TLS.serverCACertificates = []

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

319

322

320----------------------------------------------------------------

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

321

324

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

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

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

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

324#if WINDOWS

327#if WINDOWS

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

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

326#else

329#else

327 (s, sa) <- accept sock

330 (s, sa) <- accept sock

328#endif

331#endif

329 setSocketCloseOnExec s

332 setSocketCloseOnExec s

330− return (mkConn tlsset s params, sa)

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

331

334

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

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

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

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

334 where

337 where

335 switch = do

338 switch = do

336 firstBS <- safeRecv s 4096

339 firstBS <- safeRecv s 4096

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

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

338− httpOverTls tlsset s firstBS params

341+ httpOverTls tlsset set s firstBS params

339 else

342 else

340− plainHTTP tlsset s firstBS

343+ plainHTTP tlsset set s firstBS

341

344

342----------------------------------------------------------------

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

343

346

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

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

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

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

346 recvN <- makePlainReceiveN s bs0

349 recvN <- makePlainReceiveN s bs0

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

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

348 TLS.contextHookSetLogging ctx tlsLogging

351 TLS.contextHookSetLogging ctx tlsLogging

349 TLS.handshake ctx

352 TLS.handshake ctx

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

354+ isH2 <- I.newIORef h2

350 writeBuf <- allocateBuffer bufferSize

355 writeBuf <- allocateBuffer bufferSize

351 -- Creating a cache for leftover input data.

356 -- Creating a cache for leftover input data.

352 ref <- I.newIORef ""

357 ref <- I.newIORef ""

353 tls <- getTLSinfo ctx

358 tls <- getTLSinfo ctx

354− return (conn ctx writeBuf ref, tls)

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

355 where

360 where

356 backend recvN = TLS.Backend {

361 backend recvN = TLS.Backend {

357 TLS.backendFlush = return ()

362 TLS.backendFlush = return ()

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

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

365+#else

358 , TLS.backendClose = close s

366 , TLS.backendClose = close s

367+#endif

359 , TLS.backendSend = sendAll' s

368 , TLS.backendSend = sendAll' s

360 , TLS.backendRecv = recvN

369 , TLS.backendRecv = recvN

361 }

370 }

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

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

363 throwIO ConnectionClosedByPeer

372 throwIO ConnectionClosedByPeer

364− conn ctx writeBuf ref = Connection {

373+ conn ctx writeBuf ref isH2 = Connection {

365 connSendMany = TLS.sendData ctx . L.fromChunks

374 connSendMany = TLS.sendData ctx . L.fromChunks

366 , connSendAll = sendall

375 , connSendAll = sendall

367 , connSendFile = sendfile

376 , connSendFile = sendfile

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

371 , connRecvBuf = recvBuf ref

380 , connRecvBuf = recvBuf ref

372 , connWriteBuffer = writeBuf

381 , connWriteBuffer = writeBuf

373 , connBufferSize = bufferSize

382 , connBufferSize = bufferSize

383+ , connHTTP2 = isH2

374 }

384 }

375 where

385 where

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

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

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

458#if MIN_VERSION_tls(1,5,0)

468#if MIN_VERSION_tls(1,5,0)

459 TLS.TLS13 -> (3,4)

469 TLS.TLS13 -> (3,4)

460#endif

470#endif

471+ clientCert <- TLS.getClientCertificateChain ctx

461 return TLS {

472 return TLS {

462 tlsMajorVersion = major

473 tlsMajorVersion = major

463 , tlsMinorVersion = minor

474 , tlsMinorVersion = minor

464 , tlsNegotiatedProtocol = proto

475 , tlsNegotiatedProtocol = proto

465 , tlsChiperID = TLS.cipherID infoCipher

476 , tlsChiperID = TLS.cipherID infoCipher

477+ , tlsClientCertificate = clientCert

466 }

478 }

467

479

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

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

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

470

482

471----------------------------------------------------------------

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

472

484

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

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

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

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

475 AllowInsecure -> do

487 AllowInsecure -> do

476− conn' <- socketConnection s

488+ conn' <- socketConnection set s

477 cachedRef <- I.newIORef bs0

489 cachedRef <- I.newIORef bs0

478 let conn'' = conn'

490 let conn'' = conn'

479 { connRecv = recvPlain cachedRef (connRecv conn')

491 { connRecv = recvPlain cachedRef (connRecv conn')

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

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

1Name: warp-tls

2−Version: 3.2.6

2+Version: 3.2.11

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

4License: MIT

5License-file: LICENSE

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

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

19

20Library

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

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

22 , bytestring >= 0.9

23 , wai >= 3.2 && < 3.3

24− , warp >= 3.2.17 && < 3.3

24+ , warp >= 3.3.6 && < 3.4

25 , data-default-class >= 0.0.1

26− , tls >= 1.3.10

26+ , tls >= 1.5.3

27 , cryptonite >= 0.12

28 , network >= 2.2.1

29 , streaming-commons

30− , tls-session-manager >= 0.0.0.1

30+ , tls-session-manager >= 0.0.4

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

32 ghc-options: -Wall

33 if os(windows)

warp/ChangeLog.md+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+

1## 3.3.0

50## 3.3.0

2

51

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

52* 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)

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

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

6 `HTTP2Data -> TrailersMaker`.

55 `HTTP2Data -> TrailersMaker`.

7

56

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

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

72 , setLogger

73 , setServerPushLogger

74 , setGracefulShutdownTimeout

75+ , setGracefulCloseTimeout1

76+ , setGracefulCloseTimeout2

77+ , setMaxTotalHeaderLength

75 -- ** Getters

78 -- ** Getters

76 , getPort

79 , getPort

77 , getHost

80 , getHost

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

79 , getOnClose

82 , getOnClose

80 , getOnException

83 , getOnException

81 , getGracefulShutdownTimeout

84 , getGracefulShutdownTimeout

85+ , getGracefulCloseTimeout1

86+ , getGracefulCloseTimeout2

82 -- ** Exception handler

87 -- ** Exception handler

83 , defaultOnException

88 , defaultOnException

84 , defaultShouldDisplayException

89 , defaultShouldDisplayException

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

93 , pauseTimeout

98 , pauseTimeout

94 , FileInfo(..)

99 , FileInfo(..)

95 , getFileInfo

100 , getFileInfo

101+ , clientCertificate

96 , withApplication

102 , withApplication

97 , withApplicationSettings

103 , withApplicationSettings

98 , testWithApplication

104 , testWithApplication

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

121import Control.Exception (SomeException, throwIO)

127import Control.Exception (SomeException, throwIO)

122import Data.Streaming.Network (HostPreference)

128import Data.Streaming.Network (HostPreference)

123import qualified Data.Vault.Lazy as Vault

129import qualified Data.Vault.Lazy as Vault

130+import Data.X509

124import qualified Network.HTTP.Types as H

131import qualified Network.HTTP.Types as H

125import Network.Socket (SockAddr)

132import Network.Socket (SockAddr)

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

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

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

378--

385--

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

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

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

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

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

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

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

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

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

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

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

430 -> Settings -> Settings

437 -> Settings -> Settings

431setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

432

439

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

441+--

442+-- Since 3.3.8

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

444+setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445+ { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446+

433-- | Explicitly pause the slowloris timeout.

447-- | Explicitly pause the slowloris timeout.

434--

448--

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

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

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

457-- Since 3.1.10

471-- Since 3.1.10

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

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

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

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

474+

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

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

477+-- Default: 0.

478+--

479+-- Since 3.3.5

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

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

482+

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

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

485+--

486+-- Since 3.3.5

487+getGracefulCloseTimeout1 :: Settings -> Int

488+getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489+

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

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

492+-- Default: 2000.

493+--

494+-- Since 3.3.5

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

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

497+

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

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

500+--

501+-- Since 3.3.5

502+getGracefulCloseTimeout2 :: Settings -> Int

503+getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504+

505+-- | Getting information of client certificate.

506+--

507+-- Since 3.3.5

508+clientCertificate :: Request -> Maybe CertificateChain

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

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

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

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

35

36conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders -> IndexedHeader

37+ -> H.ResponseHeaders

38+ -> IndexedHeader -- ^ Response

39+ -> IndexedHeader -- ^ Request

38 -> RspFileInfo

40 -> RspFileInfo

39−conditionalRequest finfo hs0 reqidx = case condition of

41+conditionalRequest finfo hs0 rspidx reqidx = case condition of

40 nobody@(WithoutBody _) -> nobody

42 nobody@(WithoutBody _) -> nobody

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

44+ !hasLM = isJust $ rspidx ! fromEnum ResLastModified

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

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

42− addContentHeaders hs0 off len size

43 in WithBody s hs off len

46 in WithBody s hs off len

44 where

47 where

45 !mtime = I.fileInfoTime finfo

48 !mtime = I.fileInfoTime finfo

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

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

6

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

8

9+import qualified Data.IORef as I

9import qualified Control.Exception as E

10import qualified Control.Exception as E

10import qualified Network.HTTP2.Server as H2

11import qualified Network.HTTP2.Server as H2

11import Network.Socket (SockAddr)

12import Network.Socket (SockAddr)

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

23

24

24----------------------------------------------------------------

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

25

26

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

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

27−http2 conn ii addr settings readN app =

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

28 H2.run conf http2server

29 H2.run conf http2server

29 where

30 where

30 conf = H2.Config {

31 conf = H2.Config {

31 confWriteBuffer = connWriteBuffer conn

32 confWriteBuffer = connWriteBuffer conn

32 , confBufferSize = connBufferSize conn

33 , confBufferSize = connBufferSize conn

33− , confSendAll = connSendAll conn

34+ , confSendAll = send

34 , confReadN = readN

35 , confReadN = readN

35 , confPositionReadMaker = pReadMaker ii

36 , confPositionReadMaker = pReadMaker ii

36 }

37 }

37

38

38 http2server h2req aux response = do

39 http2server h2req aux response = do

39 req <- toWAIRequest h2req aux

40 req <- toWAIRequest h2req aux

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

41+ ref <- I.newIORef Nothing

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

41 h2rsp <- fromResponse settings ii req rsp

43 h2rsp <- fromResponse settings ii req rsp

42 pps <- fromPushPromises ii req

44 pps <- fromPushPromises ii req

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

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

46+ _ <- 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

54 return ResponseReceived

47 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

55 return ()

64 return ()

56

65

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

58 where

67 where

59 !hdr = H2.requestHeaders h2req

68 !hdr = H2.requestHeaders h2req

60 !bdy = H2.getRequestBodyChunk h2req

69 !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)

15

16pReadMaker :: InternalInfo -> PositionReadMaker

17pReadMaker ii path = do

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

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

19+ case mfd of

19− return (pread fd, Refresher refresh)

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

21+ Nothing -> do

22+ fd <- openFile path

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

20 where

24 where

21 pread :: Fd -> PositionRead

25 pread :: Fd -> PositionRead

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

26 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

22

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

24import Network.Wai.Handler.Warp.Imports

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

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

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

27import Network.Wai.Handler.Warp.Types

28

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

30

31----------------------------------------------------------------

32

33toRequest :: 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

35 ref <- newIORef Nothing

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

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

37

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

39 -> IORef (Maybe HTTP2Data)

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

42 where

43 !req = Request {

44 requestMethod = colonMethod

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

48 , rawQueryString = query

49 , queryString = H.parseQuery query

50 , requestHeaders = headers

51− , isSecure = True

51+ , isSecure = isTransportSecure transport

52 , remoteHost = addr

53 , requestBody = body

54 , vault = vaultValue

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

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

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

86+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

86 Vault.empty

87 Vault.empty

87

88

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

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

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

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

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

73 Right finfo -> do

74 let reqidx = indexRequestHeader reqhdr

75+ rspidx = indexResponseHeader rsphdr

75− case conditionalRequest finfo rsphdr reqidx of

76+ case conditionalRequest finfo rsphdr rspidx reqidx of

76 WithoutBody s -> return $ responseNoBody s rsphdr

77 WithoutBody s -> return $ responseNoBody s rsphdr

77 WithBody s rsphdr' off bytes -> do

78 WithBody s rsphdr' off bytes -> do

78 let !off' = fromIntegral off

79 let !off' = fromIntegral off

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

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

69data ResponseHeaderIndex = ResContentLength

70 | ResServer

71 | ResDate

72+ | ResLastModified

72 deriving (Enum,Bounded)

73 deriving (Enum,Bounded)

73

74

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

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

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

79responseKeyIndex hn = case BS.length bs of

80responseKeyIndex hn = case BS.length bs of

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

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

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

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

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

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

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

83 _ -> -1

85 _ -> -1

84 where

86 where

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

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

17import Foreign.ForeignPtr (withForeignPtr)

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

19import GHC.Conc (threadWaitRead)

20+import qualified GHC.IO.Exception as E

20−import Network.Socket (Socket, fdSocket)

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

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

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

22

29

23import Network.Wai.Handler.Warp.Buffer

30import Network.Wai.Handler.Warp.Buffer

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

89 siz' = siz - len

96 siz' = siz - len

90 loop bss' siz'

97 loop bss' siz'

91

98

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

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

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

92receive :: Socket -> BufferPool -> Recv

102receive :: Socket -> BufferPool -> Recv

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

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

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

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

105+ withFdSocket sock $ \fd -> do

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

95 fd <- fdSocket sock

107 fd <- fdSocket sock

96#else

108#else

97 let fd = fdSocket sock

109 let fd = fdSocket sock

98#endif

110#endif

99 let size' = fromIntegral size

111 let size' = fromIntegral size

100 fromIntegral <$> receiveloop fd ptr size'

112 fromIntegral <$> receiveloop fd ptr size'

113+ where

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

115+ handler e

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

117+ | otherwise = E.throwIO e

101

118

102receiveBuf :: Socket -> RecvBuf

119receiveBuf :: Socket -> RecvBuf

103receiveBuf sock buf0 siz0 = do

120receiveBuf 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)

105 fd <- fdSocket sock

124 fd <- fdSocket sock

106#else

125#else

107 let fd = fdSocket sock

126 let fd = fdSocket sock

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

134 else

153 else

135 return bytes

154 return bytes

136

155

156+#ifndef mingw32_HOST_OS

137-- fixme: the type of the return value

157-- fixme: the type of the return value

138foreign import ccall unsafe "recv"

158foreign import ccall unsafe "recv"

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

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

160+#endif

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

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

9 , headerLines

10 , pauseTimeoutKey

11 , getFileInfoKey

12+ , getClientCertificateKey

12 , NoKeepAliveRequest (..)

13 , NoKeepAliveRequest (..)

13 ) where

14 ) where

14

15

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

21import qualified Data.IORef as I

22import qualified Data.IORef as I

22import Data.Typeable (Typeable)

23import Data.Typeable (Typeable)

23import qualified Data.Vault.Lazy as Vault

24import qualified Data.Vault.Lazy as Vault

25+import Data.X509

24import qualified Network.HTTP.Types as H

26import qualified Network.HTTP.Types as H

25import Network.Socket (SockAddr)

27import Network.Socket (SockAddr)

26import Network.Wai

28import Network.Wai

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

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

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

37import Network.Wai.Handler.Warp.ReadInt

39import Network.Wai.Handler.Warp.ReadInt

38import Network.Wai.Handler.Warp.RequestHeader

40import Network.Wai.Handler.Warp.RequestHeader

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

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

40−

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

42−

43−-- FIXME come up with good values here

44−maxTotalHeaderLength :: Int

45−maxTotalHeaderLength = 50 * 1024

46

42

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

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

48

44

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

55 -> Timeout.Handle

51 -> Timeout.Handle

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

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

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

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

54+ -> Transport

58 -> IO (Request

55 -> IO (Request

59 ,Maybe (I.IORef Int)

56 ,Maybe (I.IORef Int)

60 ,IndexedHeader

57 ,IndexedHeader

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

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

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

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

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

66

63

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

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

68− hdrlines <- headerLines firstRequest src

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

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

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

70 let idxhdr = indexRequestHeader hdr

67 let idxhdr = indexRequestHeader hdr

71 expect = idxhdr ! fromEnum ReqExpect

68 expect = idxhdr ! fromEnum ReqExpect

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

75 rawPath = if settingsNoParsePath settings then unparsedPath else path

72 rawPath = if settingsNoParsePath settings then unparsedPath else path

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

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

77 $ Vault.insert getFileInfoKey (getFileInfo ii)

74 $ Vault.insert getFileInfoKey (getFileInfo ii)

75+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

78 Vault.empty

76 Vault.empty

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

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

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

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

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

89 , rawQueryString = query

87 , rawQueryString = query

90 , queryString = H.parseQuery query

88 , queryString = H.parseQuery query

91 , requestHeaders = hdr

89 , requestHeaders = hdr

92− , isSecure = False

90+ , isSecure = isTransportSecure transport

93 , remoteHost = addr

91 , remoteHost = addr

94 , requestBody = rbody'

92 , requestBody = rbody'

95 , vault = vaultValue

93 , vault = vaultValue

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

103

101

104----------------------------------------------------------------

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

105

103

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

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

107−headerLines firstRequest src = do

105+headerLines maxTotalHeaderLength firstRequest src = do

108 bs <- readSource src

106 bs <- readSource src

109 if S.null bs

107 if S.null bs

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

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

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

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

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

113 -- the Run module for more details.

111 -- the Run module for more details.

114 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

112 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

116

114

117data NoKeepAliveRequest = NoKeepAliveRequest

115data NoKeepAliveRequest = NoKeepAliveRequest

118 deriving (Show, Typeable)

116 deriving (Show, Typeable)

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

222close = throwIO IncompleteHeaders

220close = throwIO IncompleteHeaders

223-}

221-}

224

222

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

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

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

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

227 -- Too many bytes

225 -- Too many bytes

228 | len > maxTotalHeaderLength = throwIO OverLargeHeader

226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

229 | otherwise = push' mnl

227 | otherwise = push' mnl

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

251 push' Nothing = do

249 push' Nothing = do

252 bst <- readSource' src

250 bst <- readSource' src

253 when (S.null bst) $ throwIO IncompleteHeaders

251 when (S.null bst) $ throwIO IncompleteHeaders

254− push src status bst

252+ push maxTotalHeaderLength src status bst

255 where

253 where

256 len' = len + bsLen

254 len' = len + bsLen

257 prepend' = S.append bs

255 prepend' = S.append bs

258 status = THStatus len' lines prepend'

256 status = THStatus len' lines prepend'

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

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

261 where

259 where

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

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

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

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

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

276 in if start < bsLen then

274 in if start < bsLen then

277 -- more bytes in this chunk, push again

275 -- more bytes in this chunk, push again

278 let bs'' = SU.unsafeDrop start bs

276 let bs'' = SU.unsafeDrop start bs

279− in push src status bs''

277+ in push maxTotalHeaderLength src status bs''

280 else do

278 else do

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

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

282 bst <- readSource' src

280 bst <- readSource' src

283 when (S.null bs) $ throwIO IncompleteHeaders

281 when (S.null bs) $ throwIO IncompleteHeaders

284− push src status bst

282+ push maxTotalHeaderLength src status bst

285 where

283 where

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

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

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

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

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

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

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

300getFileInfoKey = unsafePerformIO Vault.newKey

298getFileInfoKey = unsafePerformIO Vault.newKey

301{-# NOINLINE getFileInfoKey #-}

299{-# NOINLINE getFileInfoKey #-}

300+

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

302+getClientCertificateKey = unsafePerformIO Vault.newKey

303+{-# NOINLINE getClientCertificateKey #-}

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

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

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

117 --

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

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

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

120 case ms of

121 Nothing -> return ()

122 Just realStatus -> logger req realStatus mlen

123 T.tickle th

124 return ret

125 else do

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

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

127 logger req s Nothing

128 T.tickle th

129 return isPersist

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

196 -> H.HttpVersion

197 -> H.Status

198 -> H.ResponseHeaders

199+ -> IndexedHeader -- Response

199 -> Rsp

200 -> Rsp

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

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

201

202

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

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

203

204

204−sendRsp conn _ ver s hs RspNoBody = do

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

205 -- Not adding Content-Length.

206 -- Not adding Content-Length.

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

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

207 composeHeader ver s hs >>= connSendAll conn

208 composeHeader ver s hs >>= connSendAll conn

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

209

210

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

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

211

212

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

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

213 header <- composeHeaderBuilder ver s hs needsChunked

214 header <- composeHeaderBuilder ver s hs needsChunked

214 let hdrBdy

215 let hdrBdy

215 | needsChunked = header <> chunkedTransferEncoding body

216 | needsChunked = header <> chunkedTransferEncoding body

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

222

223

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

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

224

225

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

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

226 header <- composeHeaderBuilder ver s hs needsChunked

227 header <- composeHeaderBuilder ver s hs needsChunked

227 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

228 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

228 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

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

246

247

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

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

248

249

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

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

250 withApp recv send

251 withApp recv send

251 return (Nothing, Nothing)

252 return (Nothing, Nothing)

252 where

253 where

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

260

261

261-- Sophisticated WAI applications.

262-- Sophisticated WAI applications.

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

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

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

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

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

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

265 where

266 where

266 beg = filePartOffset part

267 beg = filePartOffset part

267 len = filePartByteCount part

268 len = filePartByteCount part

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

271

272

272-- Simple WAI applications.

273-- Simple WAI applications.

273-- Status is ignored

274-- Status is ignored

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

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

275 efinfo <- E.try $ getFileInfo ii path

276 efinfo <- E.try $ getFileInfo ii path

276 case efinfo of

277 case efinfo of

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

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

278#ifdef WARP_DEBUG

279#ifdef WARP_DEBUG

279 print _ex >>

280 print _ex >>

280#endif

281#endif

281− sendRspFile404 conn ii ver hs0

282+ sendRspFile404 conn ii ver hs0 rspidxhdr

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

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

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

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

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

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

285

286

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

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

287

288

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

290 -> H.HttpVersion

291 -> H.HttpVersion

291 -> H.Status

292 -> H.Status

292 -> H.ResponseHeaders

293 -> H.ResponseHeaders

294+ -> IndexedHeader

293 -> FilePath

295 -> FilePath

294 -> Integer

296 -> Integer

295 -> Integer

297 -> Integer

296 -> Bool

298 -> Bool

297 -> IO ()

299 -> IO ()

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

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

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

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

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

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

301 | otherwise = do

303 | otherwise = do

302 lheader <- composeHeader ver s hs

304 lheader <- composeHeader ver s hs

303 (mfd, fresher) <- getFd ii path

305 (mfd, fresher) <- getFd ii path

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

310 -> InternalInfo

312 -> InternalInfo

311 -> H.HttpVersion

313 -> H.HttpVersion

312 -> H.ResponseHeaders

314 -> H.ResponseHeaders

315+ -> IndexedHeader

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

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

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

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

315 where

318 where

316 s = H.notFound404

319 s = H.notFound404

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

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

warp/Network/Wai/Handler/Warp/Run.hs+52−32

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

6{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

9+{-# LANGUAGE ViewPatterns #-}

9{-# OPTIONS_GHC -fno-warn-deprecations #-}

10{-# OPTIONS_GHC -fno-warn-deprecations #-}

10

11

11module Network.Wai.Handler.Warp.Run where

12module Network.Wai.Handler.Warp.Run where

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

16import Control.Exception as E

17import Control.Exception as E

17import qualified Data.ByteString as S

18import qualified Data.ByteString as S

18import Data.Char (chr)

19import Data.Char (chr)

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

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

20import Data.Streaming.Network (bindPortTCP)

21import Data.Streaming.Network (bindPortTCP)

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

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

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

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

23import qualified Network.HTTP2 as H2

24import qualified Network.HTTP2 as H2

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

25import 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

25import qualified Network.Socket.ByteString as Sock

29import qualified Network.Socket.ByteString as Sock

26import Network.Wai

30import Network.Wai

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

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

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

54#endif

58#endif

55

59

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

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

57−socketConnection :: Socket -> IO Connection

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

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

63+socketConnection set s = do

64+#else

58−socketConnection s = do

65+socketConnection _ s = do

66+#endif

59 bufferPool <- newBufferPool

67 bufferPool <- newBufferPool

60 writeBuf <- allocateBuffer bufferSize

68 writeBuf <- allocateBuffer bufferSize

61 let sendall = Sock.sendAll s

69 let sendall = Sock.sendAll s

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

62 return Connection {

71 return Connection {

63 connSendMany = Sock.sendMany s

72 connSendMany = Sock.sendMany s

64 , connSendAll = sendall

73 , connSendAll = sendall

65 , connSendFile = sendFile s writeBuf bufferSize sendall

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

66 , connClose = close s

85 , connClose = close s

86+#endif

67 , connFree = freeBuffer writeBuf

87 , connFree = freeBuffer writeBuf

68 , connRecv = receive s bufferPool

88 , connRecv = receive s bufferPool

69 , connRecvBuf = receiveBuf s

89 , connRecvBuf = receiveBuf s

70 , connWriteBuffer = writeBuf

90 , connWriteBuffer = writeBuf

71 , connBufferSize = bufferSize

91 , connBufferSize = bufferSize

92+ , connHTTP2 = isH2

72 }

93 }

73

94

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

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

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

130 setSocketCloseOnExec s

151 setSocketCloseOnExec s

131 -- NoDelay causes an error for AF_UNIX.

152 -- NoDelay causes an error for AF_UNIX.

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

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

133− conn <- socketConnection s

154+ conn <- socketConnection set s

134 return (conn, sa)

155 return (conn, sa)

135

156

136 closeListenSocket = close socket

157 closeListenSocket = close socket

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

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

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

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

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

267 -- exceptions are thrown.

288 -- exceptions are thrown.

268− handle (settingsOnException set Nothing) .

289+ handle (settingsOnException set Nothing) $

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

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

271− withClosedRef $ \ref ->

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

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

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

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

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

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

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

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

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

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

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

281 -- fact that async exceptions are still masked.

299 -- fact that async exceptions are still masked.

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

300+ bracket mkConn cleanUp (serve unmask)

283 where

301 where

284− withClosedRef inner = newIORef False >>= inner

285−

286− closeConn ref conn = do

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

288− unless isClosed $ connClose conn

289−

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

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

291

303

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

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

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

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

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

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

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

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

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

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

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

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

299 -- allow async exceptions.

309 -- allow async exceptions.

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

305 -- above ensures the connection is closed.

315 -- above ensures the connection is closed.

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

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

307 where

317 where

308− register = T.registerKillThread (timeoutManager ii)

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

309− (closeConn ref conn)

310 cancel = T.cancel

319 cancel = T.cancel

311

320

312 onOpen adr = increase counter >> settingsOnOpen set adr

321 onOpen adr = increase counter >> settingsOnOpen set adr

@@ -333,23 +342,35 @@ serveConnection conn ii th origAddr transport settings app = do

333 istatus <- newIORef False

342 istatus <- newIORef False

334 if settingsHTTP2Enabled settings && h2 then do

343 if settingsHTTP2Enabled settings && h2 then do

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

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

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

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

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

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

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

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

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

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

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

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

337 -- fixme: origAddr

354 -- fixme: origAddr

338 checkTLS

355 checkTLS

356+ setConnHTTP2 conn True

339− http2 conn ii origAddr settings recvN app

357+ http2 conn transport ii origAddr settings recvN sendBS app

340 else do

358 else do

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

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

342 writeIORef istatus True

360 writeIORef istatus True

343 leftoverSource src bs

361 leftoverSource src bs

344 addr <- getProxyProtocolAddr src

362 addr <- getProxyProtocolAddr src

345 http1 True addr istatus src `E.catch` \e ->

363 http1 True addr istatus src `E.catch` \e ->

346− case fromException e of

364+ case () of

365+ ()

347− -- See comment below referencing

366+ -- See comment below referencing

348− -- https://github.com/yesodweb/wai/issues/618

367+ -- https://github.com/yesodweb/wai/issues/618

349− Just NoKeepAliveRequest -> return ()

368+ | Just NoKeepAliveRequest <- fromException e -> return ()

350− Nothing -> do

369+ -- No valid request

370+ | Just (BadFirstLine _) <- fromException e -> return ()

371+ | otherwise -> do

351− _ <- sendErrorResponse (dummyreq addr) istatus e

372+ _ <- sendErrorResponse (dummyreq addr) istatus e

352− throwIO e

373+ throwIO e

353

374

354 where

375 where

355 getProxyProtocolAddr src =

376 getProxyProtocolAddr src =

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

408 errorResponse e = settingsOnExceptionResponse settings e

429 errorResponse e = settingsOnExceptionResponse settings e

409

430

410 http1 firstRequest addr istatus src = do

431 http1 firstRequest addr istatus src = do

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

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

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

413 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

433 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

414 `E.catch` \e -> do

434 `E.catch` \e -> do

415 settingsOnException settings (Just req) e

435 settingsOnException settings (Just req) e

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

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

76 --

77 -- Since 2.0.3

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

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

80+ -- to close a listen socket.

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

82+ --

83+ -- Default: no action

84+ --

85+ -- Since 3.0.1

79 , settingsServerName :: ByteString

86 , settingsServerName :: ByteString

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

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

81 --

88 --

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

87 , settingsProxyProtocol :: ProxyProtocol

94 , settingsProxyProtocol :: ProxyProtocol

88 -- ^ Specify usage of the PROXY protocol.

95 -- ^ Specify usage of the PROXY protocol.

89 --

96 --

90− -- Since 3.0.5.

97+ -- Since 3.0.5

91 , settingsSlowlorisSize :: Int

98 , settingsSlowlorisSize :: Int

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

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

93 --

100 --

94− -- Since 3.1.2.

101+ -- Since 3.1.2

95 , settingsHTTP2Enabled :: Bool

102 , settingsHTTP2Enabled :: Bool

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

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

97 --

104 --

98− -- Since 3.1.7.

105+ -- Since 3.1.7

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

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

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

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

101 --

108 --

102− -- Since 3.X.X.

109+ -- Since 3.1.10

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

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

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

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

105 --

112 --

106− -- Since 3.X.X.

113+ -- Since 3.2.7

107 , settingsGracefulShutdownTimeout :: Maybe Int

114 , settingsGracefulShutdownTimeout :: Maybe Int

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

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

109 -- a graceful shutdown of the web server.

116 -- a graceful shutdown of the web server.

110 --

117 --

111 -- Since 3.2.8

118 -- Since 3.2.8

119+ , settingsGracefulCloseTimeout1 :: Int

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

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

122+ -- Default: 0.

123+ --

124+ -- Since 3.3.5

125+ , settingsGracefulCloseTimeout2 :: Int

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

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

128+ -- Default: 2000.

129+ --

130+ -- Since 3.3.5

131+ , settingsMaxTotalHeaderLength :: Int

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

133+ --

134+ -- Since 3.3.8

112 }

135 }

113

136

114-- | Specify usage of the PROXY protocol.

137-- | Specify usage of the PROXY protocol.

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

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

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

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

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

147 , settingsGracefulShutdownTimeout = Nothing

170 , settingsGracefulShutdownTimeout = Nothing

171+ , settingsGracefulCloseTimeout1 = 0

172+ , settingsGracefulCloseTimeout2 = 2000

173+ , settingsMaxTotalHeaderLength = 50 * 1024

148 }

174 }

149

175

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

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

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

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

8import qualified Data.ByteString as S

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

10import Data.Typeable (Typeable)

11+import Data.X509

11import Foreign.Ptr (Ptr)

12import Foreign.Ptr (Ptr)

12import System.Posix.Types (Fd)

13import System.Posix.Types (Fd)

13import qualified System.TimeManager as T

14import qualified System.TimeManager as T

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

122 , connWriteBuffer :: Buffer

123 , connWriteBuffer :: Buffer

123 -- | The size of the write buffer.

124 -- | The size of the write buffer.

124 , connBufferSize :: BufSize

125 , connBufferSize :: BufSize

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

127+ , connHTTP2 :: IORef Bool

125 }

128 }

126

129

130+getConnHTTP2 :: Connection -> IO Bool

131+getConnHTTP2 conn = readIORef (connHTTP2 conn)

132+

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

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

135+

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

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

128

137

129data InternalInfo = InternalInfo {

138data InternalInfo = InternalInfo {

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

171 , tlsMinorVersion :: Int

180 , tlsMinorVersion :: Int

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

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

173 , tlsChiperID :: Word16

182 , tlsChiperID :: Word16

183+ , tlsClientCertificate :: Maybe CertificateChain

174 } -- ^ Encrypted channel: TLS or SSL

184 } -- ^ Encrypted channel: TLS or SSL

175

185

176isTransportSecure :: Transport -> Bool

186isTransportSecure :: Transport -> Bool

warp/test/FileSpec.hs+1−1

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

21 let WithBody s hs off len = ans

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

23 ans' = WithBody s hs' off len

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

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

25

26spec :: Spec

27spec = do

warp/test/RequestSpec.hs+11−7

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

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

8import Network.Wai.Handler.Warp.Request

9import Network.Wai.Handler.Warp.Types

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

10import Test.Hspec

11import Test.Hspec

11import Test.Hspec.QuickCheck

12import Test.Hspec.QuickCheck

12import qualified Data.ByteString as S

13import qualified Data.ByteString as S

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

17main :: IO ()

18main :: IO ()

18main = hspec spec

19main = hspec spec

19

20

21+defaultMaxTotalHeaderLength :: Int

22+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23+

20spec :: Spec

24spec :: Spec

21spec = do

25spec = do

22 describe "headerLines" $ do

26 describe "headerLines" $ do

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

63 describe "headerLines" $ do

67 describe "headerLines" $ do

64 it "can handle a nomarl case" $ do

68 it "can handle a nomarl case" $ do

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

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

66− x <- headerLines True src

70+ x <- headerLines defaultMaxTotalHeaderLength True src

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

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

68

72

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

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

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

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

71− x <- headerLines True src

75+ x <- headerLines defaultMaxTotalHeaderLength True src

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

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

73

77

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

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

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

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

76− x <- headerLines True src

80+ x <- headerLines defaultMaxTotalHeaderLength True src

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

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

78

82

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

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

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

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

81− x <- headerLines True src

85+ x <- headerLines defaultMaxTotalHeaderLength True src

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

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

83

87

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

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

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

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

86− x <- headerLines True src

90+ x <- headerLines defaultMaxTotalHeaderLength True src

87 x `shouldBe` []

91 x `shouldBe` []

88− y <- headerLines True src

92+ y <- headerLines defaultMaxTotalHeaderLength True src

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

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

90

94

91 where

95 where

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

111 writeIORef ref z

115 writeIORef ref z

112 return y

116 return y

113 src' <- mkSource src

117 src' <- mkSource src

114− res <- headerLines True src'

118+ res <- headerLines defaultMaxTotalHeaderLength True src'

115 return (res, src')

119 return (res, src')

116

120

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

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

warp/test/ResponseSpec.hs+11−15

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

10import Network.Wai hiding (responseHeaders)

11import Network.Wai.Handler.Warp

12import Network.Wai.Handler.Warp.Response

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

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

14import Test.Hspec

15

16main :: IO ()

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

20 -> String -- ^ expected output

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

22 -> Spec

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

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

24− handle <- connectTo port

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

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

26− msWrite handle "Range: bytes="

25+ msWrite ms "Range: bytes="

27− msWrite handle range

26+ msWrite ms range

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

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

29 threadDelay 10000

28 threadDelay 10000

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

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

31− msClose handle

32 last bss `shouldBe` out

30 last bss `shouldBe` out

33 let hs = mapMaybe toHeader bss

31 let hs = mapMaybe toHeader bss

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

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

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

46 -> Integer -- ^ byte count

44 -> Integer -- ^ byte count

47 -> String -- ^ expected output

45 -> String -- ^ expected output

48 -> Spec

46 -> Spec

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

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

50− handle <- connectTo port

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

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

52 threadDelay 10000

49 threadDelay 10000

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

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

54− msClose handle

55 out `shouldBe` last bss

51 out `shouldBe` last bss

56 let hs = mapMaybe toHeader bss

52 let hs = mapMaybe toHeader bss

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

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

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

87 it "discards empty lines" $ do

83 it "discards empty lines" $ do

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

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

89

85

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

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

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

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

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

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

93

89

warp/test/RunSpec.hs+38−47

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

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3

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

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

5

6import Control.Concurrent (forkIO, killThread, threadDelay)

7import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

@@ -37,7 +37,7 @@ type CounterApplication = Counter -> Application

37

38data MySocket = MySocket

39 { msSocket :: !Socket

40− , _msBuffer :: !(I.IORef ByteString)

40+ , msBuffer :: !(I.IORef ByteString)

41 }

42

43msWrite :: MySocket -> ByteString -> IO ()

@@ -70,9 +70,16 @@ msClose :: MySocket -> IO ()

70msClose = Network.Socket.close . msSocket

71

72connectTo :: Int -> IO MySocket

73−connectTo port = MySocket

73+connectTo port = do

74− <$> (fst <$> getSocketTCP "127.0.0.1" port)

74+ s <- fst <$> getSocketTCP "127.0.0.1" port

75− <*> I.newIORef mempty

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

76

83

77incr :: MonadIO m => Counter -> m ()

84incr :: MonadIO m => Counter -> m ()

78incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

85incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

@@ -150,8 +157,7 @@ runTest :: Int -- ^ expected number of requests

150 -> IO ()

157 -> IO ()

151runTest expected app chunks = do

158runTest expected app chunks = do

152 ref <- I.newIORef (Right 0)

159 ref <- I.newIORef (Right 0)

153− withApp defaultSettings (app ref) $ \port -> do

160+ withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

154− ms <- connectTo port

155 forM_ chunks $ \chunk -> msWrite ms chunk

161 forM_ chunks $ \chunk -> msWrite ms chunk

156 _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

162 _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

157 res <- I.readIORef ref

163 res <- I.readIORef ref

@@ -168,10 +174,9 @@ runTerminateTest :: InvalidRequest

168runTerminateTest expected input = do

174runTerminateTest expected input = do

169 ref <- I.newIORef Nothing

175 ref <- I.newIORef Nothing

170 let onExc _ = I.writeIORef ref . Just

176 let onExc _ = I.writeIORef ref . Just

171− withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

177+ withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

172− handle <- connectTo port

173− msWrite handle input

178+ msWrite ms input

174− msClose handle

179+ msClose ms -- explicitly

175 threadDelay 1000

180 threadDelay 1000

176 res <- I.readIORef ref

181 res <- I.readIORef ref

177 show res `shouldBe` show (Just expected)

182 show res `shouldBe` show (Just expected)

@@ -242,13 +247,11 @@ spec = do

242 let app req f = do

247 let app req f = do

243 liftIO $ I.writeIORef iheaders $ requestHeaders req

248 liftIO $ I.writeIORef iheaders $ requestHeaders req

244 f $ responseLBS status200 [] ""

249 f $ responseLBS status200 [] ""

245− withApp defaultSettings app $ \port -> do

250+ withApp defaultSettings app $ withMySocket $ \ms -> do

246− handle <- connectTo port

247 let input = S.concat

251 let input = S.concat

248 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

249 ]

253 ]

250− msWrite handle input

254+ msWrite ms input

251− msClose handle

252 threadDelay 1000

255 threadDelay 1000

253 headers <- I.readIORef iheaders

256 headers <- I.readIORef iheaders

254 headers `shouldBe`

257 headers `shouldBe`

@@ -259,13 +262,11 @@ spec = do

259 let app req f = do

262 let app req f = do

260 liftIO $ I.writeIORef iheaders $ requestHeaders req

263 liftIO $ I.writeIORef iheaders $ requestHeaders req

261 f $ responseLBS status200 [] ""

264 f $ responseLBS status200 [] ""

262− withApp defaultSettings app $ \port -> do

265+ withApp defaultSettings app $ withMySocket $ \ms -> do

263− handle <- connectTo port

264 let input = S.concat

266 let input = S.concat

265 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

266 ]

268 ]

267− msWrite handle input

269+ msWrite ms input

268− msClose handle

269 threadDelay 1000

270 threadDelay 1000

270 headers <- I.readIORef iheaders

271 headers <- I.readIORef iheaders

271 headers `shouldBe`

272 headers `shouldBe`

@@ -281,16 +282,14 @@ spec = do

281 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

282 atomically $ modifyTVar countVar (+ 1)

283 atomically $ modifyTVar countVar (+ 1)

283 f $ responseLBS status200 [] ""

284 f $ responseLBS status200 [] ""

284− withApp defaultSettings app $ \port -> do

285+ withApp defaultSettings app $ withMySocket $ \ms -> do

285− handle <- connectTo port

286 let input = S.concat

287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

288 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

289 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

290 , "b\r\nHello World\r\n0\r\n\r\n"

291 ]

292− msWrite handle input

292+ msWrite ms input

293− msClose handle

294 atomically $ do

293 atomically $ do

295 count <- readTVar countVar

294 count <- readTVar countVar

296 check $ count == 2

295 check $ count == 2

@@ -307,14 +306,12 @@ spec = do

307 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

308 atomically $ modifyTVar countVar (+ 1)

307 atomically $ modifyTVar countVar (+ 1)

309 f $ responseLBS status200 [] ""

308 f $ responseLBS status200 [] ""

310− withApp defaultSettings app $ \port -> do

309+ withApp defaultSettings app $ withMySocket $ \ms -> do

311− handle <- connectTo port

312 let input = concat $ replicate 2 $

310 let input = concat $ replicate 2 $

313 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

314 (replicate 50 "5\r\n12345\r\n") ++

312 (replicate 50 "5\r\n12345\r\n") ++

315 ["0\r\n\r\n"]

313 ["0\r\n\r\n"]

316− mapM_ (msWrite handle) input

314+ mapM_ (msWrite ms) input

317− msClose handle

318 atomically $ do

315 atomically $ do

319 count <- readTVar countVar

316 count <- readTVar countVar

320 check $ count == 2

317 check $ count == 2

@@ -330,16 +327,14 @@ spec = do

330 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

331 atomically $ modifyTVar countVar (+ 1)

328 atomically $ modifyTVar countVar (+ 1)

332 f $ responseLBS status200 [] ""

329 f $ responseLBS status200 [] ""

333− withApp defaultSettings app $ \port -> do

330+ withApp defaultSettings app $ withMySocket $ \ms -> do

334− handle <- connectTo port

335 let input = S.concat

331 let input = S.concat

336 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

337 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

333 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

338 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

334 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

339 , "b\r\nHello World\r\n0\r\n\r\n"

335 , "b\r\nHello World\r\n0\r\n\r\n"

340 ]

336 ]

341− mapM_ (msWrite handle) $ map S.singleton $ S.unpack input

337+ mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

342− msClose handle

343 atomically $ do

338 atomically $ do

344 count <- readTVar countVar

339 count <- readTVar countVar

345 check $ count == 2

340 check $ count == 2

@@ -360,20 +355,18 @@ spec = do

360 E.throwIO (e :: E.SomeException)

355 E.throwIO (e :: E.SomeException)

361 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

362 f $ responseLBS status200 [] ""

357 f $ responseLBS status200 [] ""

363− withApp (setTimeout 1 defaultSettings) app $ \port -> do

358+ withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

364 let bs1 = S.replicate 2048 88

359 let bs1 = S.replicate 2048 88

365 bs2 = "This is short"

360 bs2 = "This is short"

366 bs = S.append bs1 bs2

361 bs = S.append bs1 bs2

367− handle <- connectTo port

368− msWrite handle "POST / HTTP/1.1\r\n"

362+ msWrite ms "POST / HTTP/1.1\r\n"

369− msWrite handle "content-length: "

363+ msWrite ms "content-length: "

370− msWrite handle $ S8.pack $ show $ S.length bs

364+ msWrite ms $ S8.pack $ show $ S.length bs

371− msWrite handle "\r\n\r\n"

365+ msWrite ms "\r\n\r\n"

372 threadDelay 100000

366 threadDelay 100000

373− msWrite handle bs1

367+ msWrite ms bs1

374 threadDelay 100000

368 threadDelay 100000

375− msWrite handle bs2

369+ msWrite ms bs2

376− msClose handle

377 threadDelay 5000000

370 threadDelay 5000000

378 front <- I.readIORef ifront

371 front <- I.readIORef ifront

379 S.concat (front []) `shouldBe` bs

372 S.concat (front []) `shouldBe` bs

@@ -389,8 +382,7 @@ spec = do

389 loop

382 loop

390 loop

383 loop

391 doubleBS = S.concatMap $ \w -> S.pack [w, w]

384 doubleBS = S.concatMap $ \w -> S.pack [w, w]

392− withApp defaultSettings app $ \port -> do

385+ withApp defaultSettings app $ withMySocket $ \ms -> do

393− ms <- connectTo port

394 msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

386 msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

395 timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

387 timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

396 msWrite ms "67890"

388 msWrite ms "67890"

@@ -418,15 +410,14 @@ spec = do

418 atomically $ modifyTVar countVar (+ 1)

410 atomically $ modifyTVar countVar (+ 1)

419 loop

411 loop

420 loop

412 loop

421− withApp defaultSettings app $ \port -> do

413+ withApp defaultSettings app $ withMySocket $ \ms -> 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"

414+ msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

424 threadDelay 10000

415 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"

426 atomically $ do

417 atomically $ do

427 count <- readTVar countVar

418 count <- readTVar countVar

428 check $ count >= 1

419 check $ count >= 1

429− bs <- safeRecv sock 4096

420+ bs <- safeRecv (msSocket ms) 4096 -- must not use msRead

430 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

431

422

432 it "streaming response with length" $ do

423 it "streaming response with length" $ do

warp/warp.cabal+4−1

@@ -1,5 +1,5 @@

1Name: warp

2−Version: 3.2.28

2+Version: 3.3.9

3Synopsis: A fast, light-weight web server for WAI applications.

4License: MIT

5License-file: LICENSE

@@ -56,6 +56,7 @@ Library

56 , vault >= 0.3

57 , wai >= 3.2 && < 3.3

58 , word8

59+ , x509

59 if impl(ghc < 8)

60 if impl(ghc < 8)

60 Build-Depends: semigroups

61 Build-Depends: semigroups

61 if flag(network-bytestring)

62 if flag(network-bytestring)

@@ -211,6 +212,7 @@ Test-Suite spec

211 , vault

212 , vault

212 , wai >= 3.2 && < 3.3

213 , wai >= 3.2 && < 3.3

213 , word8

214 , word8

215+ , x509

214 -- Build-Tool-Depends: hspec-discover:hspec-discover

216 -- Build-Tool-Depends: hspec-discover:hspec-discover

215 if impl(ghc < 8)

217 if impl(ghc < 8)

216 Build-Depends: semigroups

218 Build-Depends: semigroups

@@ -249,6 +251,7 @@ Benchmark parser

249 , network

251 , network

250 , time-manager

252 , time-manager

251 , unix-compat

253 , unix-compat

254+ , x509

252 if impl(ghc < 8)

255 if impl(ghc < 8)

253 Build-Depends: semigroups

256 Build-Depends: semigroups

254

257