25ffdaa..master · typeable/wai

.azure/azure-linux-template.yml+11−28

since splitsnapshots

unifiedsplit

@@ -1,19 +1,10 @@

1jobs:

2- job: ${{ parameters.name }}

3+ timeoutInMinutes: 180

3 pool:

4 pool:

4 vmImage: ${{ parameters.vmImage }}

5 vmImage: ${{ parameters.vmImage }}

5 strategy:

6 strategy:

6 matrix:

7 matrix:

7− stack-def:

8− BUILD: stack

9− stack-lts-6:

10− BUILD: stack

11− STACK_YAML: stack-lts-6.yaml

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

13− stack-lts-9:

14− BUILD: stack

15− STACK_YAML: stack-lts-9.yaml

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

17 stack-lts-11:

8 stack-lts-11:

18 BUILD: stack

9 BUILD: stack

19 STACK_YAML: stack-lts-11.yaml

10 STACK_YAML: stack-lts-11.yaml

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

22 BUILD: stack

13 BUILD: stack

23 STACK_YAML: stack-lts-12.yaml

14 STACK_YAML: stack-lts-12.yaml

24 ARGS: "--resolver lts-12"

15 ARGS: "--resolver lts-12"

25− stack-lts-13:

16+ stack-lts-14:

26 BUILD: stack

17 BUILD: stack

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

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

28− cabal-7.10.3:

19+ stack-nightly:

29− BUILD: cabal

20+ BUILD: stack

30− GHCVER: 7.10.3

21+ STACK_YAML: stack-nightly.yaml

31− CABALVER: 1.22

22+ ARGS: "--resolver nightly"

32− cabal-8.0.2:

33− BUILD: cabal

34− GHCVER: 8.0.2

35− CABALVER: 1.24

36 cabal-8.2.2:

23 cabal-8.2.2:

37 BUILD: cabal

24 BUILD: cabal

38 GHCVER: 8.4.4

25 GHCVER: 8.4.4

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

41 BUILD: cabal

28 BUILD: cabal

42 GHCVER: 8.4.4

29 GHCVER: 8.4.4

43 CABALVER: 2.2

30 CABALVER: 2.2

44− cabal-8.6.4:

31+ cabal-8.6.5:

45 BUILD: cabal

32 BUILD: cabal

46− GHCVER: 8.6.4

33+ GHCVER: 8.6.5

47 CABALVER: 2.4

34 CABALVER: 2.4

48 maxParallel: 6

35 maxParallel: 6

49 steps:

36 steps:

@@ -83,7 +70,7 @@ jobs:

83 for dir in $PACKAGES

70 for dir in $PACKAGES

84 do

71 do

85 cd $dir

72 cd $dir

86− cabal check || [ "$CABALVER" == "1.16" ]

73+ cabal check || [ "$CABALVER" == "1.22" ] # https://github.com/yesodweb/wai/pull/754#issuecomment-504866279

87 cabal sdist

74 cabal sdist

88 PKGVER=$(cabal info . | awk '{print $2;exit}')

75 PKGVER=$(cabal info . | awk '{print $2;exit}')

89 SRC_TGZ=$PKGVER.tar.gz

76 SRC_TGZ=$PKGVER.tar.gz

@@ -92,11 +79,7 @@ jobs:

92 cd "$PKGVER"

79 cd "$PKGVER"

93 cabal configure --enable-tests --ghc-options -O0

80 cabal configure --enable-tests --ghc-options -O0

94 cabal build

81 cabal build

95− if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then

96− cabal test

97− else

98− cabal test --show-details=streaming

82+ cabal test --show-details=streaming

99− fi

100 cd $ORIGDIR

83 cd $ORIGDIR

101 done

84 done

102 ;;

85 ;;

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

@@ -1,19 +1,10 @@

1jobs:

2- job: ${{ parameters.name }}

3+ timeoutInMinutes: 180

3 pool:

4 pool:

4 vmImage: ${{ parameters.vmImage }}

5 vmImage: ${{ parameters.vmImage }}

5 strategy:

6 strategy:

6 matrix:

7 matrix:

7− stack-def:

8− BUILD: stack

9− stack-lts-6:

10− BUILD: stack

11− STACK_YAML: stack-lts-6.yaml

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

13− stack-lts-9:

14− BUILD: stack

15− STACK_YAML: stack-lts-9.yaml

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

17 stack-lts-11:

8 stack-lts-11:

18 BUILD: stack

9 BUILD: stack

19 STACK_YAML: stack-lts-11.yaml

10 STACK_YAML: stack-lts-11.yaml

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

22 BUILD: stack

13 BUILD: stack

23 STACK_YAML: stack-lts-12.yaml

14 STACK_YAML: stack-lts-12.yaml

24 ARGS: "--resolver lts-12"

15 ARGS: "--resolver lts-12"

25− stack-lts-13:

16+ stack-lts-14:

26 BUILD: stack

17 BUILD: stack

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

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

28 maxParallel: 3

19 maxParallel: 3

29 steps:

20 steps:

30 - script: |

21 - script: |

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

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

1jobs:

2- job: ${{ parameters.name }}

3+ timeoutInMinutes: 180

3 pool:

4 pool:

4 vmImage: ${{ parameters.vmImage }}

5 vmImage: ${{ parameters.vmImage }}

5 strategy:

6 strategy:

6 matrix:

7 matrix:

7− stack-lts-13:

8+ stack-lts-14:

8 BUILD: stack

9 BUILD: stack

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

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

10 maxParallel: 3

11 maxParallel: 3

11 steps:

12 steps:

12 - bash: |

13 - bash: |

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

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

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

16 stack setup $ARGS > /dev/null

17 stack setup $ARGS > /dev/null

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

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

18− 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

19 env:

21 env:

20 OS_NAME: ${{ parameters.os }}

22 OS_NAME: ${{ parameters.os }}

21 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+10

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

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+

8+## 0.1.5

9+

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

11+ [#752](https://github.com/yesodweb/wai/pull/752)

12+

3## 0.1.4.1

13## 0.1.4.1

4

14

5* [#693](https://github.com/yesodweb/wai/pull/693):

15* [#693](https://github.com/yesodweb/wai/pull/693):

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+13−9

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

1name: auto-update

2−version: 0.1.4.1

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,18 +17,22 @@ 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

23 default-language: Haskell2010

24 default-language: Haskell2010

25+ if impl(ghc >= 8)

26+ default-extensions: Strict StrictData

24

27

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

26

29

27−-- test-suite spec

30+test-suite spec

28−-- main-is: Spec.hs

31+ main-is: Spec.hs

29−-- other-modules: Control.AutoUpdateSpec

32+ other-modules: Control.AutoUpdateSpec

33+ Control.DebounceSpec

30−-- Control.ReaperSpec

34+ Control.ReaperSpec

31−-- hs-source-dirs: test

35+ hs-source-dirs: test

32−-- type: exitcode-stdio-1.0

36+ type: exitcode-stdio-1.0

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

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

34−-- 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+6−6

@@ -9,19 +9,19 @@ packages:

9- ./wai-app-static

10- ./wai-websockets

11- ./wai-conduit

12+- ./time-manager

12flags:

13flags:

13 wai-extra:

14 wai-extra:

14 build-example: true

15 build-example: true

15extra-deps:

16extra-deps:

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

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

17nix:

23nix:

18 enable: false

24 enable: false

19 packages:

25 packages:

20 - fcgi

26 - fcgi

21 - zlib

27 - zlib

22−image:

23− containers:

24− - base: "fpco/pid1"

25− name: "yesodweb/warp"

26− executables:

27− - warp

stack-lts-12.yaml+7−6

@@ -9,6 +9,7 @@ packages:

9- ./wai-app-static

10- ./wai-websockets

11- ./wai-conduit

12+- ./time-manager

12flags:

13flags:

13 wai-extra:

14 wai-extra:

14 build-example: true

15 build-example: true

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

17 packages:

18 packages:

18 - fcgi

19 - fcgi

19 - zlib

20 - zlib

20−image:

21+extra-deps:

21− containers:

22+- http2-2.0.0

22− - base: "fpco/pid1"

23+- network-byte-order-0.1.1.0

23− name: "yesodweb/warp"

24+- tls-1.5.3

24− executables:

25+- tls-session-manager-0.0.4

25− - warp

26+- x509-1.7.5

stack-lts-6.yamldeleted−31

@@ -1,31 +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−extra-deps:

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

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

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

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

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

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

19−- basement-0.0.7@rev:0

20−- http-client-0.5.13.1@rev: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-lts-9.yamldeleted−27

@@ -1,27 +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−extra-deps:

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

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

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

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

17−nix:

18− enable: false

19− packages:

20− - fcgi

21− - zlib

22−image:

23− containers:

24− - base: "fpco/pid1"

25− name: "yesodweb/warp"

26− executables:

27− - 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+7−7

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

1−resolver: lts-13.14

1+resolver: lts-14.22

2packages:

3- ./auto-update

4- ./mime-types

@@ -9,6 +9,7 @@ packages:

9- ./wai-app-static

10- ./wai-websockets

11- ./wai-conduit

12+- ./time-manager

12flags:

13flags:

13 wai-extra:

14 wai-extra:

14 build-example: true

15 build-example: true

@@ -17,9 +18,8 @@ nix:

17 packages:

18 packages:

18 - fcgi

19 - fcgi

19 - zlib

20 - zlib

20−image:

21+extra-deps:

21− containers:

22+- http2-2.0.0

22− - base: "fpco/pid1"

23+- network-byte-order-0.1.1.0

23− name: "yesodweb/warp"

24+- tls-1.5.3

24− executables:

25+- tls-session-manager-0.0.4

25− - warp

time-manager/LICENSEnew file+20

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

2+

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

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

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

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

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

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

9+the following conditions:

10+

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

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

13+

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

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

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE

18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION

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

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

warp/Network/Wai/Handler/Warp/Timeout.hs → time-manager/System/TimeManager.hsrenamed+2−3

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

3

2

4−module Network.Wai.Handler.Warp.Timeout (

3+module System.TimeManager (

5 -- ** Types

4 -- ** Types

6 Manager

5 Manager

7 , TimeoutAction

6 , TimeoutAction

@@ -115,7 +114,7 @@ instance E.Exception TimeoutThread where

115 toException = E.asyncExceptionToException

114 toException = E.asyncExceptionToException

116 fromException = E.asyncExceptionFromException

115 fromException = E.asyncExceptionFromException

117instance Show TimeoutThread where

116instance Show TimeoutThread where

118− show TimeoutThread = "Thread killed by Warp's timeout reaper"

117+ show TimeoutThread = "Thread killed by timeout manager"

119

118

120----------------------------------------------------------------

119----------------------------------------------------------------

121

120

time-manager/time-manager.cabalnew file+19

@@ -0,0 +1,19 @@

1+Name: time-manager

2+Version: 0.0.0

3+Synopsis: Scalable timer

4+License: MIT

5+License-file: LICENSE

6+Author: Michael Snoyman and Kazu Yamamoto

7+Maintainer: kazu@iij.ad.jp

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

9+Category: System

10+Build-Type: Simple

11+Cabal-Version: >=1.8

12+Stability: Stable

13+Description: Scalable timer functions provided by a timer manager.

14+

15+Library

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

17+ , auto-update

18+ Exposed-modules: System.TimeManager

19+ Ghc-Options: -Wall

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+3−3

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

@@ -102,7 +102,7 @@ test-suite runtests

102 , temporary

103 , mockery

104 -- , containers

105− ghc-options: -Wall

105+ ghc-options: -Wall

106

107source-repository head

108 type: git

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

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

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+

19+## 3.0.26.1

20+

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

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

23+

24+## 3.0.26

25+

26+* Throw 413 for too large payload

27+* Throw 431 for too large headers

28+ [#741](https://github.com/yesodweb/wai/pull/741)

29+

3## 3.0.25

30## 3.0.25

4

31

5* Supporting `network` version 3.0.

32* Supporting `network` version 3.0.

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+60−10

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

@@ -118,8 +150,8 @@ apacheMiddleware ala app req sendResponse = app req $ \res -> do

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

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

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

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

120 date <- liftIO getdate

152 date <- liftIO getdate

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

153+ let msize = contentLength (responseHeaders res)

122− liftIO $ cb $ formatter date req (responseStatus res) Nothing

154+ liftIO $ cb $ formatter date req (responseStatus res) msize

123 sendResponse res

155 sendResponse res

124

156

125customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware

157customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware

@@ -129,15 +161,33 @@ customMiddlewareWithDetails cb getdate formatter app req sendResponse = do

129 app req' $ \res -> do

161 app req' $ \res -> do

130 t1 <- getCurrentTime

162 t1 <- getCurrentTime

131 date <- liftIO getdate

163 date <- liftIO getdate

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

164+ let msize = contentLength (responseHeaders res)

133 builderIO <- newIORef $ B.byteString ""

165 builderIO <- newIORef $ B.byteString ""

134 res' <- recordChunks builderIO res

166 res' <- recordChunks builderIO res

135 rspRcv <- sendResponse res'

167 rspRcv <- sendResponse res'

136 _ <- liftIO . cb .

168 _ <- liftIO . cb .

137− formatter date req' (responseStatus res') Nothing (t1 `diffUTCTime` t0) reqBody =<<

169+ formatter date req' (responseStatus res') msize (t1 `diffUTCTime` t0) reqBody =<<

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/Parse.hs+11−4

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

48#endif

49 ) where

50

51+import qualified Control.Exception as E

51import qualified Data.ByteString as S

52import qualified Data.ByteString as S

52import qualified Data.ByteString.Lazy as L

53import qualified Data.ByteString.Lazy as L

53import qualified Data.ByteString.Char8 as S8

54import qualified Data.ByteString.Char8 as S8

@@ -67,6 +68,7 @@ import Control.Monad (when, unless, guard)

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

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

68import Data.IORef

69import Data.IORef

69import Network.HTTP.Types (hContentType)

70import Network.HTTP.Types (hContentType)

71+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

70import Data.CaseInsensitive (mk)

72import Data.CaseInsensitive (mk)

71

73

72import Prelude hiding (lines)

74import Prelude hiding (lines)

@@ -426,6 +428,8 @@ conduitRequestBodyEx o backend (Multipart bound) rbody add =

426

428

427

429

428-- | Take one header or subheader line.

430-- | Take one header or subheader line.

431+-- Since: 3.0.26

432+-- Throw 431 if headers too large.

429takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)

433takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)

430takeLine maxlen src =

434takeLine maxlen src =

431 go ""

435 go ""

@@ -434,7 +438,8 @@ takeLine maxlen src =

434 bs <- readSource src

438 bs <- readSource src

435 case maxlen of

439 case maxlen of

436 Just maxlen' -> when (S.length front > maxlen') $

440 Just maxlen' -> when (S.length front > maxlen') $

437− error "Header line length exceeds allowed maximum."

441+ E.throwIO $ ConnectionError (UnknownErrorCode 431)

442+ "Request Header Fields Too Large"

438 Nothing -> return ()

443 Nothing -> return ()

439 if S.null bs

444 if S.null bs

440 then close front

445 then close front

@@ -450,7 +455,8 @@ takeLine maxlen src =

450 let res = front `S.append` x

455 let res = front `S.append` x

451 case maxlen of

456 case maxlen of

452 Just maxlen' -> when (S.length res > maxlen') $

457 Just maxlen' -> when (S.length res > maxlen') $

453− error "Header line length exceeds allowed maximum."

458+ E.throwIO $ ConnectionError (UnknownErrorCode 431)

459+ "Request Header Fields Too Large"

454 Nothing -> return ()

460 Nothing -> return ()

455 return $ Just $ killCR $ res

461 return $ Just $ killCR $ res

456

462

@@ -639,8 +645,9 @@ wrapTillBound bound src max' = do

639 cur <- atomicModifyIORef' sref $ \ cur ->

645 cur <- atomicModifyIORef' sref $ \ cur ->

640 let new = cur + fromIntegral (S.length bs) in (new, new)

646 let new = cur + fromIntegral (S.length bs) in (new, new)

641 case max' of

647 case max' of

642− Just max'' | cur > max'' -> error "Maximum size exceeded"

648+ Just max'' | cur > max'' ->

649+ E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"

643− _ -> return ()

650+ _ -> return ()

644 if S.null bs

651 if S.null bs

645 then do

652 then do

646 writeIORef ref $ WTBDone False

653 writeIORef ref $ WTBDone False

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/ParseSpec.hs+14−5

@@ -13,6 +13,7 @@ import qualified Data.ByteString.Lazy as L

13import qualified Data.Text as TS

14import qualified Data.Text.Encoding as TE

15import Control.Monad.Trans.Resource (withInternalState, runResourceT)

16+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

16

17

17import Network.Wai

18import Network.Wai

18import Network.Wai.Test

19import Network.Wai.Test

@@ -94,6 +95,9 @@ caseParseRequestBody = do

94 let expectedfile3 = [("yaml", FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n")]

95 let expectedfile3 = [("yaml", FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n")]

95 let expected3 = (expectedsmap3, expectedfile3)

96 let expected3 = (expectedsmap3, expectedfile3)

96

97

98+ let unknownErrorException c (ConnectionError (UnknownErrorCode code) _) = c == code

99+ unknownErrorException _ _ = False

100+

97

101

98 let def = defaultParseRequestBodyOptions

102 let def = defaultParseRequestBodyOptions

99 it "parsing actual post multipart/form-data" $ do

103 it "parsing actual post multipart/form-data" $ do

@@ -119,17 +123,21 @@ caseParseRequestBody = do

119

123

120 it "exceeding file size" $ do

124 it "exceeding file size" $ do

121 SRequest req4 _bod4 <- toRequest'' ctype3 content3

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

122− (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

126+ (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4)

127+ `shouldThrow` unknownErrorException 413

123

128

124 it "exceeding total file size" $ do

129 it "exceeding total file size" $ do

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

130 SRequest req4 _bod4 <- toRequest'' ctype3 content3

126− (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

131+ (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4)

132+ `shouldThrow` unknownErrorException 413

127 SRequest req5 _bod5 <- toRequest'' ctype3 content5

133 SRequest req5 _bod5 <- toRequest'' ctype3 content5

128− (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5) `shouldThrow` anyErrorCall

134+ (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5)

135+ `shouldThrow` unknownErrorException 413

129

136

130 it "exceeding max parm value size" $ do

137 it "exceeding max parm value size" $ do

131 SRequest req4 _bod4 <- toRequest'' ctype2 content2

138 SRequest req4 _bod4 <- toRequest'' ctype2 content2

132− (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

139+ (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4)

140+ `shouldThrow` unknownErrorException 413

133

141

134 it "exceeding max header lines" $ do

142 it "exceeding max header lines" $ do

135 SRequest req4 _bod4 <- toRequest'' ctype2 content2

143 SRequest req4 _bod4 <- toRequest'' ctype2 content2

@@ -137,7 +145,8 @@ caseParseRequestBody = do

137

145

138 it "exceeding header line size" $ do

146 it "exceeding header line size" $ do

139 SRequest req4 _bod4 <- toRequest'' ctype3 content4

147 SRequest req4 _bod4 <- toRequest'' ctype3 content4

140− (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

148+ (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4)

149+ `shouldThrow` unknownErrorException 431

141

150

142 it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do

151 it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do

143 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

152 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

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+6−4

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

1Name: wai-extra

2−Version: 3.0.25

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

@@ -115,6 +115,7 @@ Library

115 , zlib

116 , aeson

117 , iproute

118+ , http2

118

119

119 if os(windows)

120 if os(windows)

120 cpp-options: -DWINDOWS

121 cpp-options: -DWINDOWS

@@ -202,6 +203,7 @@ test-suite spec

202 , cookie

203 , cookie

203 , time

204 , time

204 , case-insensitive

205 , case-insensitive

206+ , http2

205 ghc-options: -Wall

207 ghc-options: -Wall

206 default-language: Haskell2010

208 default-language: Haskell2010

207

209

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

wai/ChangeLog.md+6

@@ -1,3 +1,9 @@

1+# ChangeLog for wai

2+

3+## 3.2.2.1

4+

5+* Fix missing reexport of `getRequestBodyChunk` [#753](https://github.com/yesodweb/wai/issues/753)

6+

1## 3.2.2

7## 3.2.2

2

8

3* Deprecate `requestBody` in favor of the more clearly named `getRequestBodyChunk`. [#726](https://github.com/yesodweb/wai/pull/726)

9* Deprecate `requestBody` in favor of the more clearly named `getRequestBodyChunk`. [#726](https://github.com/yesodweb/wai/pull/726)

wai/Network/Wai.hs+1

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

53 , remoteHost

54 , pathInfo

55 , queryString

56+ , getRequestBodyChunk

56 , requestBody

57 , requestBody

57 , vault

58 , vault

58 , requestBodyLength

59 , requestBodyLength

wai/wai.cabal+1−2

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

1Name: wai

2−Version: 3.2.2

2+Version: 3.2.2.1

3Synopsis: Web Application Interface.

4Description: Provides a common protocol for communication between web applications and web servers.

5 .

@@ -25,7 +25,6 @@ Library

25 , network >= 2.2.1.5

26 , http-types >= 0.7

27 , text >= 0.7

28− , transformers >= 0.0

29 , vault >= 0.3 && < 0.4

28 , vault >= 0.3 && < 0.4

30 Exposed-modules: Network.Wai

29 Exposed-modules: Network.Wai

31 Network.Wai.Internal

30 Network.Wai.Internal

warp-tls/ChangeLog.md+44−1

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

1−## 3.2.4.1

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+

23+## 3.2.6

24+

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

26+ [#752](https://github.com/yesodweb/wai/pull/752)

27+

28+## 3.2.5

29+

30+* When tls 1.5.0 is available, TLS 1.3 is automatically supported.

31+

32+## 3.2.4.3

33+

34+* Using warp >= 3.2.17.

35+

36+## 3.2.4.2

2

37

3* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640)

38* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640)

4

39

40+## 3.2.4

41+

42+* Using tls-session-manager.

43+

44+## 3.2.3

45+

46+* Stop using obsoleted APIs of network.

47+

5## 3.2.2

48## 3.2.2

6

49

7* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)

50* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)

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+9−6

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

1Name: warp-tls

2−Version: 3.2.4.3

2+Version: 3.2.11

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

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

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

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >=1.6

11+Cabal-Version: >= 1.10

12Stability: Stable

13description: SSLv1 and SSLv2 are obsoleted by IETF.

14 We should use TLS 1.2 (or TLS 1.1 or TLS 1.0 if necessary).

@@ -18,20 +18,23 @@ 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)

34 Cpp-Options: -DWINDOWS

35+ if impl(ghc >= 8)

36+ Default-Extensions: Strict StrictData

37+ Default-Language: Haskell2010

35

38

36

39

37source-repository head

40source-repository head

warp/ChangeLog.md+72

@@ -1,8 +1,80 @@

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+

50+## 3.3.0

51+

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

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

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

55+ `HTTP2Data -> TrailersMaker`.

56+

57+## 3.2.28

58+

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

60+ [#752](https://github.com/yesodweb/wai/pull/752)

61+* System.TimeManager is now in a separate package: time-manager.

62+ [#750](https://github.com/yesodweb/wai/pull/750)

63+* Fixing a bug of ALPN.

64+* Introducing the half closed state for HTTP/2.

65+ [#717](https://github.com/yesodweb/wai/pull/717)

66+

1## 3.2.27

67## 3.2.27

2

68

3* Internally, use `lookupEnv` instead of `getEnvironment` to get the

69* Internally, use `lookupEnv` instead of `getEnvironment` to get the

4 value of the `PORT` environment variable

70 value of the `PORT` environment variable

5 [#736](https://github.com/yesodweb/wai/pull/736)

71 [#736](https://github.com/yesodweb/wai/pull/736)

72+* Throw 413 for too large payload

73+* Throw 431 for too large headers

74+ [#741](https://github.com/yesodweb/wai/pull/741)

75+* Use exception response handler in HTTP/2 & improve connection preservation

76+ in HTTP/1.x if uncaught exceptions are thrown in an `Application`.

77+ [#738](https://github.com/yesodweb/wai/pull/738)

6

78

7## 3.2.26

79## 3.2.26

8

80

warp/Network/Wai/Handler/Warp.hs+52−2

@@ -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,9 +127,11 @@ 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)

134+import System.TimeManager

127

135

128import Network.Wai.Handler.Warp.FileInfoCache

136import Network.Wai.Handler.Warp.FileInfoCache

129import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

137import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

@@ -133,7 +141,6 @@ import Network.Wai.Handler.Warp.Request

133import Network.Wai.Handler.Warp.Response (warpVersion)

141import Network.Wai.Handler.Warp.Response (warpVersion)

134import Network.Wai.Handler.Warp.Run

142import Network.Wai.Handler.Warp.Run

135import Network.Wai.Handler.Warp.Settings

143import Network.Wai.Handler.Warp.Settings

136−import Network.Wai.Handler.Warp.Timeout

137import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

144import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

138import Network.Wai.Handler.Warp.WithApplication

145import Network.Wai.Handler.Warp.WithApplication

139

146

@@ -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/FdCache.hs+18−22

@@ -17,26 +17,24 @@ module Network.Wai.Handler.Warp.FdCache (

17import Control.Exception (bracket)

18import Control.Reaper

19import Data.IORef

20−import Network.Wai.Handler.Warp.MultiMap

20+import Network.Wai.Handler.Warp.MultiMap as MM

21import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)

22#endif

23import System.Posix.Types (Fd)

24

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

26

27−type Hash = Int

28−

29-- | An action to activate a Fd cache entry.

27-- | An action to activate a Fd cache entry.

30type Refresh = IO ()

28type Refresh = IO ()

31

29

32−getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)

30+getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)

33−getFdNothing _ _ = return (Nothing, return ())

31+getFdNothing _ = return (Nothing, return ())

34

32

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

33----------------------------------------------------------------

36

34

37-- | Creating 'MutableFdCache' and executing the action in the second

35-- | Creating 'MutableFdCache' and executing the action in the second

38-- argument. The first argument is a cache duration in second.

36-- argument. The first argument is a cache duration in second.

39−withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

37+withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

40#ifdef WINDOWS

38#ifdef WINDOWS

41withFdCache _ action = action getFdNothing

39withFdCache _ action = action getFdNothing

42#else

40#else

@@ -65,7 +63,7 @@ inactive (MutableStatus ref) = writeIORef ref Inactive

65

63

66----------------------------------------------------------------

64----------------------------------------------------------------

67

65

68−data FdEntry = FdEntry !FilePath !Fd !MutableStatus

66+data FdEntry = FdEntry !Fd !MutableStatus

69

67

70openFile :: FilePath -> IO Fd

68openFile :: FilePath -> IO Fd

71openFile path = do

69openFile path = do

@@ -77,25 +75,23 @@ closeFile :: Fd -> IO ()

77closeFile = closeFd

75closeFile = closeFd

78

76

79newFdEntry :: FilePath -> IO FdEntry

77newFdEntry :: FilePath -> IO FdEntry

80−newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus

78+newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus

81

79

82setFileCloseOnExec :: Fd -> IO ()

80setFileCloseOnExec :: Fd -> IO ()

83setFileCloseOnExec fd = setFdOption fd CloseOnExec True

81setFileCloseOnExec fd = setFdOption fd CloseOnExec True

84

82

85----------------------------------------------------------------

83----------------------------------------------------------------

86

84

87−type FdCache = MMap FdEntry

85+type FdCache = MultiMap FdEntry

88

86

89-- | Mutable Fd cacher.

87-- | Mutable Fd cacher.

90−newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))

88+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))

91

89

92fdCache :: MutableFdCache -> IO FdCache

90fdCache :: MutableFdCache -> IO FdCache

93fdCache (MutableFdCache reaper) = reaperRead reaper

91fdCache (MutableFdCache reaper) = reaperRead reaper

94

92

95−look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)

93+look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)

96−look mfc path key = searchWith key check <$> fdCache mfc

94+look mfc path = MM.lookup path <$> fdCache mfc

97− where

98− check (FdEntry path' _ _) = path == path'

99

95

100----------------------------------------------------------------

96----------------------------------------------------------------

101

97

@@ -116,7 +112,7 @@ clean old = do

116 new <- pruneWith old prune

112 new <- pruneWith old prune

117 return $ merge new

113 return $ merge new

118 where

114 where

119− prune (FdEntry _ fd mst) = status mst >>= act

115+ prune (_,FdEntry fd mst) = status mst >>= act

120 where

116 where

121 act Active = inactive mst >> return True

117 act Active = inactive mst >> return True

122 act Inactive = closeFd fd >> return False

118 act Inactive = closeFd fd >> return False

@@ -126,21 +122,21 @@ clean old = do

126terminate :: MutableFdCache -> IO ()

122terminate :: MutableFdCache -> IO ()

127terminate (MutableFdCache reaper) = do

123terminate (MutableFdCache reaper) = do

128 !t <- reaperStop reaper

124 !t <- reaperStop reaper

129− mapM_ closeIt $ toList t

125+ mapM_ (closeIt . snd) $ toList t

130 where

126 where

131− closeIt (FdEntry _ fd _) = closeFd fd

127+ closeIt (FdEntry fd _) = closeFd fd

132

128

133----------------------------------------------------------------

129----------------------------------------------------------------

134

130

135-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

131-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

136−getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)

132+getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)

137−getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get

133+getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get

138 where

134 where

139 get Nothing = do

135 get Nothing = do

140− ent@(FdEntry _ fd mst) <- newFdEntry path

136+ ent@(FdEntry fd mst) <- newFdEntry path

141− reaperAdd reaper (h, ent)

137+ reaperAdd reaper (path,ent)

142 return (Just fd, refresh mst)

138 return (Just fd, refresh mst)

143− get (Just (FdEntry _ fd mst)) = do

139+ get (Just (FdEntry fd mst)) = do

144 refresh mst

140 refresh mst

145 return (Just fd, refresh mst)

141 return (Just fd, refresh mst)

146#endif

142#endif

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/FileInfoCache.hs+19−22

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

2

3module Network.Wai.Handler.Warp.FileInfoCache (

4 FileInfo(..)

5− , Hash

6 , withFileInfoCache

5 , withFileInfoCache

7 , getInfo -- test purpose only

6 , getInfo -- test purpose only

8 ) where

7 ) where

@@ -18,8 +17,6 @@ import Network.Wai.Handler.Warp.Imports

18

17

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

18----------------------------------------------------------------

20

19

21−type Hash = Int

22−

23-- | File information.

20-- | File information.

24data FileInfo = FileInfo {

21data FileInfo = FileInfo {

25 fileInfoName :: !FilePath

22 fileInfoName :: !FilePath

@@ -29,8 +26,8 @@ data FileInfo = FileInfo {

29 } deriving (Eq, Show)

26 } deriving (Eq, Show)

30

27

31data Entry = Negative | Positive FileInfo

28data Entry = Negative | Positive FileInfo

32−type Cache = HashMap FilePath Entry

29+type Cache = HashMap Entry

33−type FileInfoCache = Reaper Cache (Int,FilePath,Entry)

30+type FileInfoCache = Reaper Cache (FilePath,Entry)

34

31

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

32----------------------------------------------------------------

36

33

@@ -54,29 +51,29 @@ getInfo path = do

54 else

51 else

55 throwIO (userError "FileInfoCache:getInfo")

52 throwIO (userError "FileInfoCache:getInfo")

56

53

57−getInfoNaive :: Hash -> FilePath -> IO FileInfo

54+getInfoNaive :: FilePath -> IO FileInfo

58−getInfoNaive _ = getInfo

55+getInfoNaive = getInfo

59

56

60----------------------------------------------------------------

57----------------------------------------------------------------

61

58

62−getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

59+getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo

63−getAndRegisterInfo reaper@Reaper{..} h path = do

60+getAndRegisterInfo reaper@Reaper{..} path = do

64 cache <- reaperRead

61 cache <- reaperRead

65− case M.lookup h path cache of

62+ case M.lookup path cache of

66 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

63 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

67 Just (Positive x) -> return x

64 Just (Positive x) -> return x

68− Nothing -> positive reaper h path

65+ Nothing -> positive reaper path

69− `E.onException` negative reaper h path

66+ `E.onException` negative reaper path

70

67

71−positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

68+positive :: FileInfoCache -> FilePath -> IO FileInfo

72−positive Reaper{..} h path = do

69+positive Reaper{..} path = do

73 info <- getInfo path

70 info <- getInfo path

74− reaperAdd (h, path, Positive info)

71+ reaperAdd (path, Positive info)

75 return info

72 return info

76

73

77−negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

74+negative :: FileInfoCache -> FilePath -> IO FileInfo

78−negative Reaper{..} h path = do

75+negative Reaper{..} path = do

79− reaperAdd (h, path,Negative)

76+ reaperAdd (path, Negative)

80 throwIO (userError "FileInfoCache:negative")

77 throwIO (userError "FileInfoCache:negative")

81

78

82----------------------------------------------------------------

79----------------------------------------------------------------

@@ -85,7 +82,7 @@ negative Reaper{..} h path = do

85-- and executing the action in the second argument.

82-- and executing the action in the second argument.

86-- The first argument is a cache duration in second.

83-- The first argument is a cache duration in second.

87withFileInfoCache :: Int

84withFileInfoCache :: Int

88− -> ((Hash -> FilePath -> IO FileInfo) -> IO a)

85+ -> ((FilePath -> IO FileInfo) -> IO a)

89 -> IO a

86 -> IO a

90withFileInfoCache 0 action = action getInfoNaive

87withFileInfoCache 0 action = action getInfoNaive

91withFileInfoCache duration action =

88withFileInfoCache duration action =

@@ -93,14 +90,14 @@ withFileInfoCache duration action =

93 terminate

90 terminate

94 (action . getAndRegisterInfo)

91 (action . getAndRegisterInfo)

95

92

96−initialize :: Hash -> IO FileInfoCache

93+initialize :: Int -> IO FileInfoCache

97initialize duration = mkReaper settings

94initialize duration = mkReaper settings

98 where

95 where

99 settings = defaultReaperSettings {

96 settings = defaultReaperSettings {

100 reaperAction = override

97 reaperAction = override

101 , reaperDelay = duration

98 , reaperDelay = duration

102− , reaperCons = \(h,k,v) -> M.insert h k v

99+ , reaperCons = \(path,v) -> M.insert path v

103− , reaperNull = M.null

100+ , reaperNull = M.isEmpty

104 , reaperEmpty = M.empty

101 , reaperEmpty = M.empty

105 }

102 }

106

103

warp/Network/Wai/Handler/Warp/HTTP2.hs+70−54

@@ -1,69 +1,85 @@

1−{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE PatternGuards #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

3

6

4−module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where

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

5

8

6−import Control.Concurrent (forkIO, killThread)

9+import qualified Data.IORef as I

7import qualified Control.Exception as E

10import qualified Control.Exception as E

8−import Network.HTTP2

11+import qualified Network.HTTP2.Server as H2

9import Network.Socket (SockAddr)

12import Network.Socket (SockAddr)

10import Network.Wai

13import Network.Wai

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

15+import qualified System.TimeManager as T

11

16

12−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

17+import Network.Wai.Handler.Warp.HTTP2.File

13−import Network.Wai.Handler.Warp.HTTP2.Manager

18+import Network.Wai.Handler.Warp.HTTP2.PushPromise

14−import Network.Wai.Handler.Warp.HTTP2.Receiver

15import Network.Wai.Handler.Warp.HTTP2.Request

19import Network.Wai.Handler.Warp.HTTP2.Request

16−import Network.Wai.Handler.Warp.HTTP2.Sender

20+import Network.Wai.Handler.Warp.HTTP2.Response

17−import Network.Wai.Handler.Warp.HTTP2.Types

18−import Network.Wai.Handler.Warp.HTTP2.Worker

19import Network.Wai.Handler.Warp.Imports

21import Network.Wai.Handler.Warp.Imports

20−import qualified Network.Wai.Handler.Warp.Settings as S (Settings)

22+import qualified Network.Wai.Handler.Warp.Settings as S

21import Network.Wai.Handler.Warp.Types

23import Network.Wai.Handler.Warp.Types

22

24

23----------------------------------------------------------------

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

24

26

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

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

26−http2 conn ii1 addr transport settings readN app = do

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

27− checkTLS

29+ H2.run conf http2server

28− ok <- checkPreface

29− when ok $ do

30− ctx <- newContext

31− -- Workers, worker manager and timer manager

32− mgr <- start settings

33− let responder = response settings ctx mgr

34− action = worker ctx settings app responder

35− setAction mgr action

36− -- The number of workers is 3.

37− -- This was carefully chosen based on a lot of benchmarks.

38− -- If it is 1, we cannot avoid head-of-line blocking.

39− -- If it is large, huge memory is consumed and many

40− -- context switches happen.

41− replicateM_ 3 $ spawnAction mgr

42− -- Receiver

43− let mkreq = mkRequest ii1 settings addr

44− tid <- forkIO $ frameReceiver ctx mkreq readN

45− -- Sender

46− -- frameSender is the main thread because it ensures to send

47− -- a goway frame.

48− frameSender ctx conn settings mgr `E.finally` do

49− clearContext ctx

50− stop mgr

51− killThread tid

52 where

30 where

53− checkTLS = case transport of

31+ conf = H2.Config {

54− TCP -> return () -- direct

32+ confWriteBuffer = connWriteBuffer conn

55− tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"

33+ , confBufferSize = connBufferSize conn

56− tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

34+ , confSendAll = send

57− checkPreface = do

35+ , confReadN = readN

58− preface <- readN connectionPrefaceLength

36+ , confPositionReadMaker = pReadMaker ii

59− if connectionPreface /= preface then do

37+ }

60− goaway conn ProtocolError "Preface mismatch"

61− return False

62− else

63− return True

64

38

65−-- connClose must not be called here since Run:fork calls it

39+ http2server h2req aux response = do

66−goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()

40+ req <- toWAIRequest h2req aux

67−goaway Connection{..} etype debugmsg = connSendAll bytestream

41+ ref <- I.newIORef Nothing

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

43+ h2rsp <- fromResponse settings ii req rsp

44+ pps <- fromPushPromises ii req

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

46+ _ <- response h2rsp pps

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

64+ return ()

65+

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

67+ where

68+ !hdr = H2.requestHeaders h2req

69+ !bdy = H2.getRequestBodyChunk h2req

70+ !bdylen = H2.requestBodySize h2req

71+ !th = H2.auxTimeHandle aux

72+

73+ logResponse h2rsp req = logger req st msiz

68− where

74+ where

69− bytestream = goawayFrame 0 etype debugmsg

75+ !logger = S.settingsLogger settings

76+ !st = H2.responseStatus h2rsp

77+ !msiz = fromIntegral <$> H2.responseBodySize h2rsp

78+

79+ logPushPromise req pp = logger req path siz

80+ where

81+ !logger = S.settingsServerPushLogger settings

82+ !path = H2.promiseRequestPath pp

83+ !siz = case H2.responseBodySize $ H2.promiseResponse pp of

84+ Nothing -> 0

85+ Just s -> fromIntegral s

warp/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hsdeleted−34

@@ -1,34 +0,0 @@

1−module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where

2−

3−import Network.HTTP2

4−

5−import Network.Wai.Handler.Warp.Imports

6−

7−----------------------------------------------------------------

8−

9−goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString

10−goawayFrame sid etype debugmsg = encodeFrame einfo frame

11− where

12− einfo = encodeInfo id 0

13− frame = GoAwayFrame sid etype debugmsg

14−

15−resetFrame :: ErrorCodeId -> StreamId -> ByteString

16−resetFrame etype sid = encodeFrame einfo frame

17− where

18− einfo = encodeInfo id sid

19− frame = RSTStreamFrame etype

20−

21−settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString

22−settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist

23− where

24− einfo = encodeInfo func 0

25−

26−pingFrame :: ByteString -> ByteString

27−pingFrame bs = encodeFrame einfo $ PingFrame bs

28− where

29− einfo = encodeInfo setAck 0

30−

31−windowUpdateFrame :: StreamId -> WindowSize -> ByteString

32−windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz

33− where

34− einfo = encodeInfo id sid

warp/Network/Wai/Handler/Warp/HTTP2/File.hs+23−150

@@ -1,157 +1,30 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE BangPatterns #-}

4

2

5−module Network.Wai.Handler.Warp.HTTP2.File (

3+module Network.Wai.Handler.Warp.HTTP2.File where

6− RspFileInfo(..)

7− , conditionalRequest

8− , addContentHeadersForFilePart

9− , H.parseByteRanges

10− ) where

11

4

12−import qualified Data.ByteString.Char8 as C8 (pack)

5+import Network.HTTP2.Server

13−import Network.HPACK

14−import Network.HPACK.Token

15−import Network.HTTP.Date

16−import qualified Network.HTTP.Types as H

17−import Network.Wai

18

6

19−import qualified Network.Wai.Handler.Warp.FileInfoCache as I

7+import Network.Wai.Handler.Warp.Types

20−import Network.Wai.Handler.Warp.Imports

21−import Network.Wai.Handler.Warp.PackInt

22

8

23−-- $setup

9+#ifdef WINDOWS

24−-- >>> import Test.QuickCheck

10+pReadMaker :: InternalInfo -> PositionReadMaker

11+pReadMaker _ = defaultPositionReadMaker

12+#else

13+import Network.Wai.Handler.Warp.FdCache

14+import Network.Wai.Handler.Warp.SendFile (positionRead)

25

15

26−----------------------------------------------------------------

16+pReadMaker :: InternalInfo -> PositionReadMaker

27−

17+pReadMaker ii path = do

28−data RspFileInfo = WithoutBody !H.Status

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

29− | WithBody !H.Status !TokenHeaderList !Integer !Integer

19+ case mfd of

30− deriving (Eq,Show)

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

31−

21+ Nothing -> do

32−----------------------------------------------------------------

22+ fd <- openFile path

33−

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

34−conditionalRequest :: I.FileInfo

35− -> TokenHeaderList -- Response

36− -> ValueTable -- Request

37− -> RspFileInfo

38−conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of

39− nobody@(WithoutBody _) -> nobody

40− WithBody s _ off len -> let !hs = (tokenLastModified,date) :

41− addContentHeaders ths0 off len size

42− in WithBody s hs off len

43− where

44− !mcondition = ifmodified reqtbl size mtime

45− <|> ifunmodified reqtbl size mtime

46− <|> ifrange reqtbl size mtime

47− !condition = fromMaybe (unconditional reqtbl size) mcondition

48−

49−----------------------------------------------------------------

50−

51−{-# INLINE ifModifiedSince #-}

52−ifModifiedSince :: ValueTable -> Maybe HTTPDate

53−ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate

54−

55−{-# INLINE ifUnmodifiedSince #-}

56−ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate

57−ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate

58−

59−{-# INLINE ifRange #-}

60−ifRange :: ValueTable -> Maybe HTTPDate

61−ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate

62−

63−----------------------------------------------------------------

64−

65−{-# INLINE ifmodified #-}

66−ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

67−ifmodified reqtbl size mtime = do

68− date <- ifModifiedSince reqtbl

69− return $ if date /= mtime

70− then unconditional reqtbl size

71− else WithoutBody H.notModified304

72−

73−{-# INLINE ifunmodified #-}

74−ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

75−ifunmodified reqtbl size mtime = do

76− date <- ifUnmodifiedSince reqtbl

77− return $ if date == mtime

78− then unconditional reqtbl size

79− else WithoutBody H.preconditionFailed412

80−

81−{-# INLINE ifrange #-}

82−ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

83−ifrange reqtbl size mtime = do

84− date <- ifRange reqtbl

85− rng <- getHeaderValue tokenRange reqtbl

86− return $ if date == mtime

87− then parseRange rng size

88− else WithBody H.ok200 [] 0 size

89−

90−{-# INLINE unconditional #-}

91−unconditional :: ValueTable -> Integer -> RspFileInfo

92−unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of

93− Nothing -> WithBody H.ok200 [] 0 size

94− Just rng -> parseRange rng size

95−

96−----------------------------------------------------------------

97−

98−{-# INLINE parseRange #-}

99−parseRange :: ByteString -> Integer -> RspFileInfo

100−parseRange rng size = case H.parseByteRanges rng of

101− Nothing -> WithoutBody H.requestedRangeNotSatisfiable416

102− Just [] -> WithoutBody H.requestedRangeNotSatisfiable416

103− Just (r:_) -> let (!beg, !end) = checkRange r size

104− !len = end - beg + 1

105− s = if beg == 0 && end == size - 1 then

106− H.ok200

107− else

108− H.partialContent206

109− in WithBody s [] beg len

110−

111−{-# INLINE checkRange #-}

112−checkRange :: H.ByteRange -> Integer -> (Integer, Integer)

113−checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)

114−checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)

115−checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)

116−

117−----------------------------------------------------------------

118−

119−{-# INLINE contentRangeHeader #-}

120−-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'

121−-- for the range specified.

122−contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader

123−contentRangeHeader beg end total = (tokenContentRange, range)

124− where

125− range = C8.pack

126− -- building with ShowS

127− $ 'b' : 'y': 't' : 'e' : 's' : ' '

128− : (if beg > end then ('*':) else

129− showInt beg

130− . ('-' :)

131− . showInt end)

132− ( '/'

133− : showInt total "")

134−

135−{-# INLINE addContentHeaders #-}

136−addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList

137−addContentHeaders ths off len size

138− | len == size = ths'

139− | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size

140− in ctrng:ths'

141− where

142− !lengthBS = packIntegral len

143− !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths

144−

145−{-# INLINE addContentHeadersForFilePart #-}

146−-- |

147−--

148−-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)

149−-- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]

150−-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)

151−-- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]

152−addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList

153−addContentHeadersForFilePart hs part = addContentHeaders hs off len size

154 where

24 where

155− off = filePartOffset part

25+ pread :: Fd -> PositionRead

156− len = filePartByteCount part

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

157− size = filePartFileSize part

27+ where

28+ bytes' = fromIntegral bytes

29+ off' = fromIntegral off

30+#endif

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hsdeleted−130

@@ -1,130 +0,0 @@

1−{-# LANGUAGE OverloadedStrings, BangPatterns #-}

2−{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

3−

4−module Network.Wai.Handler.Warp.HTTP2.HPACK (

5− hpackEncodeHeader

6− , hpackEncodeHeaderLoop

7− , hpackDecodeHeader

8− , just

9− , fixHeaders

10− , addHeader -- testing

11− , deleteUnnecessaryHeaders

12− ) where

13−

14−import qualified Control.Exception as E

15−import Network.HPACK hiding (Buffer)

16−import Network.HPACK.Token

17−import Network.HTTP2

18−

19−import Network.Wai.Handler.Warp.HTTP2.Types

20−import Network.Wai.Handler.Warp.Imports

21−import Network.Wai.Handler.Warp.PackInt

22−import qualified Network.Wai.Handler.Warp.Settings as S

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

24−

25−-- $setup

26−-- >>> :set -XOverloadedStrings

27−

28−----------------------------------------------------------------

29−

30−{-# INLINE addHeader #-}

31−addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList

32−addHeader t "" _ ths

33− | t == tokenServer = filter ((/= tokenServer) . fst) ths

34−addHeader t v tbl ths = case getHeaderValue t tbl of

35− Nothing -> (t,v) : ths

36− _ -> ths

37−

38−fixHeaders :: Context

39− -> Rspn

40− -> InternalInfo

41− -> S.Settings

42− -> IO TokenHeaderList

43−fixHeaders Context{..} rspn ii settings = do

44− date <- getDate ii

45− let !s = rspnStatus rspn

46− !status = packStatus s

47− !defServer = S.settingsServerName settings

48− (!ths0,tbl) = rspnHeaders rspn

49− !ths1 = addHeader tokenServer defServer tbl ths0

50− !ths2 = addHeader tokenDate date tbl ths1

51− !ths3 = (tokenStatus, status) : ths2

52− !ths4 = deleteUnnecessaryHeaders ths3 tbl

53− return ths4

54−

55−deleteUnnecessaryHeaders :: TokenHeaderList -> ValueTable -> TokenHeaderList

56−deleteUnnecessaryHeaders htl0 tbl0 = loop headersToBeRemoved htl0

57− where

58− loop [] thl = thl

59− loop (t:ts) thl = case getHeaderValue t tbl0 of

60− Nothing -> thl

61− _ -> let !thl' = filter ((/= t) . fst) thl

62− in loop ts thl'

63−

64−headersToBeRemoved :: [Token]

65−headersToBeRemoved = [ tokenConnection

66− , tokenTransferEncoding

67− -- Keep-Alive:

68− -- Proxy-Connection:

69− -- Upgrade:

70− ]

71−

72−----------------------------------------------------------------

73−

74−strategy :: EncodeStrategy

75−strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }

76−

77−-- Set-Cookie: contains only one cookie value.

78−-- So, we don't need to split it.

79−hpackEncodeHeader :: Context -> Buffer -> BufSize

80− -> TokenHeaderList

81− -> IO (TokenHeaderList, Int)

82−hpackEncodeHeader Context{..} buf siz ths =

83− encodeTokenHeader buf siz strategy True encodeDynamicTable ths

84−

85−hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize

86− -> TokenHeaderList

87− -> IO (TokenHeaderList, Int)

88−hpackEncodeHeaderLoop Context{..} buf siz hs =

89− encodeTokenHeader buf siz strategy False encodeDynamicTable hs

90−

91−----------------------------------------------------------------

92−

93−hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)

94−hpackDecodeHeader hdrblk Context{..} = do

95− tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl

96− unless (checkRequestHeader vt) $

97− E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

98− return tbl

99− where

100− handl IllegalHeaderName =

101− E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

102− handl _ =

103− E.throwIO $ ConnectionError CompressionError "cannot decompress the header"

104−

105−{-# INLINE checkRequestHeader #-}

106−checkRequestHeader :: ValueTable -> Bool

107−checkRequestHeader reqvt

108− | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme

109− | isJust mStatus = False

110− | isNothing mMethod = False

111− | isNothing mScheme = False

112− | isNothing mPath = False

113− | mPath == Just "" = False

114− | isJust mConnection = False

115− | just mTE (/= "trailers") = False

116− | otherwise = True

117− where

118− mStatus = getHeaderValue tokenStatus reqvt

119− mScheme = getHeaderValue tokenScheme reqvt

120− mPath = getHeaderValue tokenPath reqvt

121− mMethod = getHeaderValue tokenMethod reqvt

122− mConnection = getHeaderValue tokenConnection reqvt

123− mTE = getHeaderValue tokenTE reqvt

124−

125−{-# INLINE just #-}

126−just :: Maybe a -> (a -> Bool) -> Bool

127−just Nothing _ = False

128−just (Just x) p

129− | p x = True

130− | otherwise = False

warp/Network/Wai/Handler/Warp/HTTP2/Manager.hsdeleted−95

@@ -1,95 +0,0 @@

1−{-# LANGUAGE CPP, BangPatterns #-}

2−

3−-- | A thread pool manager.

4−-- The manager has responsibility to spawn and kill

5−-- worker threads.

6−module Network.Wai.Handler.Warp.HTTP2.Manager (

7− Manager

8− , start

9− , setAction

10− , stop

11− , spawnAction

12− , addMyId

13− , deleteMyId

14− ) where

15−

16−import Control.Concurrent

17−import Control.Concurrent.STM

18−import Data.Foldable

19−import Data.IORef

20−import Data.Set (Set)

21−import qualified Data.Set as Set

22−

23−import Network.Wai.Handler.Warp.Imports

24−import Network.Wai.Handler.Warp.Settings

25−import qualified Network.Wai.Handler.Warp.Timeout as T

26−

27−----------------------------------------------------------------

28−

29−type Action = T.Manager -> IO ()

30−

31−data Command = Stop | Spawn | Add ThreadId | Delete ThreadId

32−

33−data Manager = Manager (TQueue Command) (IORef Action)

34−

35−-- | Starting a thread pool manager.

36−-- Its action is initially set to 'return ()' and should be set

37−-- by 'setAction'. This allows that the action can include

38−-- the manager itself.

39−start :: Settings -> IO Manager

40−start set = do

41− q <- newTQueueIO

42− ref <- newIORef (\_ -> return ())

43− timmgr <- T.initialize $ settingsTimeout set * 1000000

44− void $ forkIO $ go q Set.empty ref timmgr

45− return $ Manager q ref

46− where

47− go q !tset0 ref timmgr = do

48− x <- atomically $ readTQueue q

49− case x of

50− Stop -> kill tset0 >> T.killManager timmgr

51− Spawn -> next tset0

52− Add newtid -> let !tset = add newtid tset0

53− in go q tset ref timmgr

54− Delete oldtid -> let !tset = del oldtid tset0

55− in go q tset ref timmgr

56− where

57− next tset = do

58− action <- readIORef ref

59− newtid <- forkIO (action timmgr)

60− let !tset' = add newtid tset

61− go q tset' ref timmgr

62−

63−setAction :: Manager -> Action -> IO ()

64−setAction (Manager _ ref) action = writeIORef ref action

65−

66−stop :: Manager -> IO ()

67−stop (Manager q _) = atomically $ writeTQueue q Stop

68−

69−spawnAction :: Manager -> IO ()

70−spawnAction (Manager q _) = atomically $ writeTQueue q Spawn

71−

72−addMyId :: Manager -> IO ()

73−addMyId (Manager q _) = do

74− tid <- myThreadId

75− atomically $ writeTQueue q $ Add tid

76−

77−deleteMyId :: Manager -> IO ()

78−deleteMyId (Manager q _) = do

79− tid <- myThreadId

80− atomically $ writeTQueue q $ Delete tid

81−

82−----------------------------------------------------------------

83−

84−add :: ThreadId -> Set ThreadId -> Set ThreadId

85−add tid set = set'

86− where

87− !set' = Set.insert tid set

88−

89−del :: ThreadId -> Set ThreadId -> Set ThreadId

90−del tid set = set'

91− where

92− !set' = Set.delete tid set

93−

94−kill :: Set ThreadId -> IO ()

95−kill set = traverse_ killThread set

warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+

5+module Network.Wai.Handler.Warp.HTTP2.PushPromise where

6+

7+import qualified Control.Exception as E

8+import qualified Network.HTTP.Types as H

9+import qualified Network.HTTP2.Server as H2

10+

11+import Network.Wai

12+import Network.Wai.Handler.Warp.FileInfoCache

13+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

14+import Network.Wai.Handler.Warp.HTTP2.Types

15+import Network.Wai.Handler.Warp.Imports

16+import Network.Wai.Handler.Warp.Types

17+

18+fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]

19+fromPushPromises ii req = do

20+ mh2data <- getHTTP2Data req

21+ let pp = case mh2data of

22+ Nothing -> []

23+ Just h2data -> http2dataPushPromise h2data

24+ catMaybes <$> mapM (fromPushPromise ii) pp

25+

26+fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)

27+fromPushPromise ii (PushPromise path file rsphdr w) = do

28+ efinfo <- E.try $ getFileInfo ii file

29+ case efinfo of

30+ Left (_ex :: E.IOException) -> return Nothing

31+ Right finfo -> do

32+ let !siz = fromIntegral $ fileInfoSize finfo

33+ !fileSpec = H2.FileSpec file 0 siz

34+ !rsp = H2.responseFile H.ok200 rsphdr fileSpec

35+ !pp = H2.pushPromise path rsp w

36+ return $ Just pp

warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hsdeleted−398

@@ -1,398 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE BangPatterns #-}

4−{-# LANGUAGE CPP #-}

5−{-# LANGUAGE PatternGuards #-}

6−

7−module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where

8−

9−import Control.Concurrent

10−import Control.Concurrent.STM

11−import qualified Control.Exception as E

12−import qualified Data.ByteString as BS

13−import qualified Data.ByteString.Char8 as C8

14−import Data.IORef

15−import Network.HPACK

16−import Network.HPACK.Token

17−import Network.HTTP2

18−import Network.HTTP2.Priority (toPrecedence, delete, prepare)

19−

20−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

21−import Network.Wai.Handler.Warp.HTTP2.HPACK

22−import Network.Wai.Handler.Warp.HTTP2.Request

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

24−import Network.Wai.Handler.Warp.Imports hiding (delete, insert, readInt)

25−import Network.Wai.Handler.Warp.ReadInt

26−import Network.Wai.Handler.Warp.Types

27−

28−----------------------------------------------------------------

29−

30−frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()

31−frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway

32− where

33− Context{ http2settings

34− , streamTable

35− , concurrency

36− , continued

37− , clientStreamId

38− , inputQ

39− , controlQ

40− } = ctx

41− sendGoaway e

42− | Just (ConnectionError err msg) <- E.fromException e = do

43− csid <- readIORef clientStreamId

44− let !frame = goawayFrame csid err msg

45− enqueueControl controlQ $ CGoaway frame

46− | otherwise = return ()

47−

48− sendReset err sid = do

49− let !frame = resetFrame err sid

50− enqueueControl controlQ $ CFrame frame

51−

52− loop :: Int -> IO ()

53− loop !n

54− | n == 6 = do

55− yield

56− loop 0

57− | otherwise = do

58− hd <- recvN frameHeaderLength

59− if BS.null hd then

60− enqueueControl controlQ CFinish

61− else do

62− cont <- processStreamGuardingError $ decodeFrameHeader hd

63− when cont $ loop (n + 1)

64−

65− processStreamGuardingError (fid, FrameHeader{streamId})

66− | isResponse streamId &&

67− (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =

68− E.throwIO $ ConnectionError ProtocolError "stream id should be odd"

69− processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do

70− mx <- readIORef continued

71− case mx of

72− Nothing -> do

73− -- ignoring unknown frame

74− consume payloadLength

75− return True

76− Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"

77− processStreamGuardingError (FramePushPromise, _) =

78− E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"

79− processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do

80− settings <- readIORef http2settings

81− case checkFrameHeader settings typhdr of

82− Left h2err -> case h2err of

83− StreamError err sid -> do

84− sendReset err sid

85− consume payloadLength

86− return True

87− connErr -> E.throwIO connErr

88− Right _ -> do

89− ex <- E.try $ controlOrStream ftyp header

90− case ex of

91− Left (StreamError err sid) -> do

92− sendReset err sid

93− return True

94− Left connErr -> E.throw connErr

95− Right cont -> return cont

96−

97− controlOrStream ftyp header@FrameHeader{streamId, payloadLength}

98− | isControl streamId = do

99− pl <- recvN payloadLength

100− control ftyp header pl ctx

101− | otherwise = do

102− checkContinued

103− !mstrm <- getStream

104− pl <- recvN payloadLength

105− case mstrm of

106− Nothing -> do

107− -- for h2spec only

108− when (ftyp == FramePriority) $ do

109− PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl

110− checkPriority newpri streamId

111− return True -- just ignore this frame

112− Just strm@Stream{streamState,streamPrecedence} -> do

113− state <- readIORef streamState

114− state' <- stream ftyp header pl ctx state strm

115− case state' of

116− Open (NoBody tbl@(_,reqvt) pri) -> do

117− resetContinued

118− let mcl = readInt <$> getHeaderValue tokenContentLength reqvt

119− when (just mcl (/= (0 :: Int))) $

120− E.throwIO $ StreamError ProtocolError streamId

121− writeIORef streamPrecedence $ toPrecedence pri

122− writeIORef streamState HalfClosed

123− (!req, !ii) <- mkreq tbl (Just 0, return "")

124− atomically $ writeTQueue inputQ $ Input strm req reqvt ii

125− Open (HasBody tbl@(_,reqvt) pri) -> do

126− resetContinued

127− q <- newTQueueIO

128− let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt

129− writeIORef streamPrecedence $ toPrecedence pri

130− bodyLength <- newIORef 0

131− writeIORef streamState $ Open (Body q mcl bodyLength)

132− readQ <- newReadBody q

133− bodySource <- mkSource readQ

134− (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)

135− atomically $ writeTQueue inputQ $ Input strm req reqvt ii

136− s@(Open Continued{}) -> do

137− setContinued

138− writeIORef streamState s

139− s -> do -- Idle, Open Body, HalfClosed, Closed

140− resetContinued

141− writeIORef streamState s

142− return True

143− where

144− setContinued = writeIORef continued (Just streamId)

145− resetContinued = writeIORef continued Nothing

146− checkContinued = do

147− mx <- readIORef continued

148− case mx of

149− Nothing -> return ()

150− Just sid

151− | sid == streamId && ftyp == FrameContinuation -> return ()

152− | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"

153− getStream = do

154− mstrm0 <- search streamTable streamId

155− case mstrm0 of

156− js@(Just strm0) -> do

157− when (ftyp == FrameHeaders) $ do

158− st <- readIORef $ streamState strm0

159− when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed"

160− -- Priority made an idele stream

161− when (isIdle st) $ opened ctx strm0

162− return js

163− Nothing

164− | isResponse streamId -> return Nothing

165− | otherwise -> do

166− csid <- readIORef clientStreamId

167− if streamId <= csid then -- consider the stream closed

168− if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then

169− return Nothing -- will be ignored

170− else

171− E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"

172− else do -- consider the stream idle

173− when (ftyp `notElem` [FrameHeaders,FramePriority]) $

174− E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idel stream: " `BS.append` C8.pack (show ftyp)

175− when (ftyp == FrameHeaders) $ do

176− writeIORef clientStreamId streamId

177− cnt <- readIORef concurrency

178− -- Checking the limitation of concurrency

179− when (cnt >= maxConcurrency) $

180− E.throwIO $ StreamError RefusedStream streamId

181− ws <- initialWindowSize <$> readIORef http2settings

182− newstrm <- newStream streamId (fromIntegral ws)

183− when (ftyp == FrameHeaders) $ opened ctx newstrm

184− insert streamTable streamId newstrm

185− return $ Just newstrm

186−

187− consume = void . recvN

188−

189−maxConcurrency :: Int

190−maxConcurrency = recommendedConcurrency

191−

192−initialFrame :: ByteString

193−initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]

194−

195−----------------------------------------------------------------

196−

197−control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool

198−control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do

199− SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs

200− case checkSettingsList alist of

201− Just x -> E.throwIO x

202− Nothing -> return ()

203− -- HTTP/2 Setting from a browser

204− unless (testAck flags) $ do

205− oldws <- initialWindowSize <$> readIORef http2settings

206− modifyIORef' http2settings $ \old -> updateSettings old alist

207− newws <- initialWindowSize <$> readIORef http2settings

208− let diff = newws - oldws

209− when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable

210− let !frame = settingsFrame setAck []

211− sent <- readIORef firstSettings

212− let !setframe

213− | sent = CSettings frame alist

214− | otherwise = CSettings0 initialFrame frame alist

215− unless sent $ writeIORef firstSettings True

216− enqueueControl controlQ setframe

217− return True

218−

219−control FramePing FrameHeader{flags} bs Context{controlQ} =

220− if testAck flags then

221− return True -- just ignore

222− else do

223− let !frame = pingFrame bs

224− enqueueControl controlQ $ CFrame frame

225− return True

226−

227−control FrameGoAway _ _ Context{controlQ} = do

228− enqueueControl controlQ CFinish

229− return False

230−

231−control FrameWindowUpdate header bs Context{connectionWindow} = do

232− WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

233− !w <- atomically $ do

234− w0 <- readTVar connectionWindow

235− let !w1 = w0 + n

236− writeTVar connectionWindow w1

237− return w1

238− when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"

239− return True

240−

241−control _ _ _ _ =

242− -- must not reach here

243− return False

244−

245−----------------------------------------------------------------

246−

247−{-# INLINE guardIt #-}

248−guardIt :: Either HTTP2Error a -> IO a

249−guardIt x = case x of

250− Left err -> E.throwIO err

251− Right frame -> return frame

252−

253−

254−{-# INLINE checkPriority #-}

255−checkPriority :: Priority -> StreamId -> IO ()

256−checkPriority p me

257− | dep == me = E.throwIO $ StreamError ProtocolError me

258− | otherwise = return ()

259− where

260− dep = streamDependency p

261−

262−stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState

263−stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do

264− HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs

265− pri <- case mp of

266− Nothing -> return defaultPriority

267− Just p -> do

268− checkPriority p streamNumber

269− return p

270− let !endOfStream = testEndStream flags

271− !endOfHeader = testEndHeader flags

272− if endOfHeader then do

273− tbl <- hpackDecodeHeader frag ctx -- fixme

274− return $ if endOfStream then

275− Open (NoBody tbl pri)

276− else

277− Open (HasBody tbl pri)

278− else do

279− let !siz = BS.length frag

280− return $ Open $ Continued [frag] siz 1 endOfStream pri

281−

282−stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do

283− -- trailer is not supported.

284− -- let's read and ignore it.

285− HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs

286− let !endOfStream = testEndStream flags

287− if endOfStream then do

288− atomically $ writeTQueue q ""

289− return HalfClosed

290− else

291− -- we don't support continuation here.

292− E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"

293−

294−stream FrameData

295− header@FrameHeader{flags,payloadLength,streamId}

296− bs

297− Context{controlQ} s@(Open (Body q mcl bodyLength))

298− Stream{streamNumber} = do

299− DataFrame body <- guardIt $ decodeDataFrame header bs

300− let !endOfStream = testEndStream flags

301− len0 <- readIORef bodyLength

302− let !len = len0 + payloadLength

303− writeIORef bodyLength len

304− when (payloadLength /= 0) $ do

305− let !frame1 = windowUpdateFrame 0 payloadLength

306− !frame2 = windowUpdateFrame streamNumber payloadLength

307− !frame = frame1 `BS.append` frame2

308− enqueueControl controlQ $ CFrame frame

309− atomically $ writeTQueue q body

310− if endOfStream then do

311− case mcl of

312− Nothing -> return ()

313− Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId

314− atomically $ writeTQueue q ""

315− return HalfClosed

316− else

317− return s

318−

319−stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do

320− let !endOfHeader = testEndHeader flags

321− !rfrags' = frag : rfrags

322− !siz' = siz + BS.length frag

323− !n' = n + 1

324− when (siz' > 51200) $ -- fixme: hard coding: 50K

325− E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"

326− when (n' > 10) $ -- fixme: hard coding

327− E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"

328− if endOfHeader then do

329− let !hdrblk = BS.concat $ reverse rfrags'

330− tbl <- hpackDecodeHeader hdrblk ctx

331− return $ if endOfStream then

332− Open (NoBody tbl pri)

333− else

334− Open (HasBody tbl pri)

335− else

336− return $ Open $ Continued rfrags' siz' n' endOfStream pri

337−

338−stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do

339− WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

340− !w <- atomically $ do

341− w0 <- readTVar streamWindow

342− let !w1 = w0 + n

343− writeTVar streamWindow w1

344− return w1

345− when (isWindowOverflow w) $

346− E.throwIO $ StreamError FlowControlError streamId

347− return s

348−

349−stream FrameRSTStream header bs ctx _ strm = do

350− RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs

351− let !cc = Reset e

352− closed ctx strm cc

353− return $ Closed cc -- will be written to streamState again

354−

355−stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do

356− PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs

357− checkPriority newpri streamNumber

358− oldpre <- readIORef streamPrecedence

359− let !newpre = toPrecedence newpri

360− writeIORef streamPrecedence newpre

361− if isIdle s then do

362− n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))

363− -- fixme hard coding

364− when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"

365− prepare outputQ streamNumber newpri

366− else do

367− mx <- delete outputQ streamNumber oldpre

368− case mx of

369− Nothing -> return ()

370− Just out -> enqueueOutput outputQ out

371− return s

372−

373−-- this ordering is important

374−stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"

375−stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"

376−-- Ignore frames to streams we have just reset, per section 5.1.

377−stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st

378−stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId

379−stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId

380−

381−----------------------------------------------------------------

382−

383−{-# INLINE newReadBody #-}

384−newReadBody :: TQueue ByteString -> IO (IO ByteString)

385−newReadBody q = do

386− ref <- newIORef False

387− return $ readBody q ref

388−

389−{-# INLINE readBody #-}

390−readBody :: TQueue ByteString -> IORef Bool -> IO ByteString

391−readBody q ref = do

392− eof <- readIORef ref

393− if eof then

394− return ""

395− else do

396− bs <- atomically $ readTQueue q

397− when (bs == "") $ writeIORef ref True

398− return bs

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3

2

4module Network.Wai.Handler.Warp.HTTP2.Request (

3module Network.Wai.Handler.Warp.HTTP2.Request (

5− mkRequest

4+ toRequest

6− , MkReq

7 , getHTTP2Data

5 , getHTTP2Data

8 , setHTTP2Data

6 , setHTTP2Data

9 , modifyHTTP2Data

7 , modifyHTTP2Data

@@ -20,35 +18,37 @@ import Network.Socket (SockAddr)

20import Network.Wai

18import Network.Wai

21import Network.Wai.Internal (Request(..))

19import Network.Wai.Internal (Request(..))

22import System.IO.Unsafe (unsafePerformIO)

20import System.IO.Unsafe (unsafePerformIO)

21+import qualified System.TimeManager as T

23

22

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

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

25−import Network.Wai.Handler.Warp.HashMap (hashByteString)

26import Network.Wai.Handler.Warp.Imports

24import Network.Wai.Handler.Warp.Imports

27−import Network.Wai.Handler.Warp.Request (getFileInfoKey)

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

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

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

29import Network.Wai.Handler.Warp.Types

27import Network.Wai.Handler.Warp.Types

30

28

31−type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)

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

32

30

33−mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq

31+----------------------------------------------------------------

32+

33+toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq

34−mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do

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

35 ref <- newIORef Nothing

36− mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)

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

37

38−mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr

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

39 -> IORef (Maybe HTTP2Data)

40− -> MkReq

40+ -> ToReq

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

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

42 where

43 !req = Request {

44 requestMethod = colonMethod

45− , httpVersion = http2ver

45+ , httpVersion = H.http20

46 , rawPathInfo = rawPath

47 , pathInfo = H.decodePathSegments path

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

@@ -77,13 +77,13 @@ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)

77 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)

78 !path = H.extractPath unparsedPath

79 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

80− !h = hashByteString rawPath

80+ -- fixme: pauseTimeout. th is not available here.

81− -- timeout handler must be overwritten with worker's one.

82− !ii = toInternalInfo ii1 h

83 !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)

81 !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)

84 $ Vault.insert getHTTP2DataKey (readIORef ref)

82 $ Vault.insert getHTTP2DataKey (readIORef ref)

85 $ Vault.insert setHTTP2DataKey (writeIORef ref)

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

86 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

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

86+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

87 Vault.empty

88

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

warp/Network/Wai/Handler/Warp/HTTP2/Response.hsnew file+127

@@ -0,0 +1,127 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE BangPatterns #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+

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

7+ fromResponse

8+ ) where

9+

10+import qualified Control.Exception as E

11+import qualified Data.ByteString.Builder as BB

12+import qualified Network.HTTP.Types as H

13+import qualified Network.HTTP2.Server as H2

14+import Network.Wai hiding (responseFile, responseBuilder, responseStream)

15+import Network.Wai.Internal (Response(..))

16+

17+import Network.Wai.Handler.Warp.File

18+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

19+import Network.Wai.Handler.Warp.HTTP2.Types

20+import Network.Wai.Handler.Warp.Header

21+import qualified Network.Wai.Handler.Warp.Response as R

22+import qualified Network.Wai.Handler.Warp.Settings as S

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

24+

25+----------------------------------------------------------------

26+

27+fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response

28+fromResponse settings ii req rsp = do

29+ date <- getDate ii

30+ h2rsp <- case rsp of

31+ ResponseFile st rsphdr path mpart -> do

32+ let rsphdr' = add date svr rsphdr

33+ responseFile st rsphdr' isHead path mpart ii reqhdr

34+ ResponseBuilder st rsphdr builder -> do

35+ let rsphdr' = add date svr rsphdr

36+ return $ responseBuilder st rsphdr' isHead builder

37+ ResponseStream st rsphdr strmbdy -> do

38+ let rsphdr' = add date svr rsphdr

39+ return $ responseStream st rsphdr' isHead strmbdy

40+ _ -> error "ResponseRaw is not supported in HTTP/2"

41+ mh2data <- getHTTP2Data req

42+ case mh2data of

43+ Nothing -> return h2rsp

44+ Just h2data -> do

45+ let !trailers = http2dataTrailers h2data

46+ return $ H2.setResponseTrailersMaker h2rsp trailers

47+ where

48+ !isHead = requestMethod req == H.methodHead

49+ !reqhdr = requestHeaders req

50+ !svr = S.settingsServerName settings

51+ add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr

52+ -- fixme: not adding svr if already exists

53+

54+----------------------------------------------------------------

55+

56+responseFile :: H.Status -> H.ResponseHeaders -> Bool

57+ -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders

58+ -> IO H2.Response

59+responseFile st rsphdr _ _ _ _ _

60+ | noBody st = return $ responseNoBody st rsphdr

61+

62+responseFile st rsphdr isHead path (Just fp) _ _ =

63+ return $ responseFile2XX st rsphdr isHead fileSpec

64+ where

65+ !off' = fromIntegral $ filePartOffset fp

66+ !bytes' = fromIntegral $ filePartByteCount fp

67+ !fileSpec = H2.FileSpec path off' bytes'

68+

69+responseFile _ rsphdr isHead path Nothing ii reqhdr = do

70+ efinfo <- E.try $ getFileInfo ii path

71+ case efinfo of

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

73+ Right finfo -> do

74+ let reqidx = indexRequestHeader reqhdr

75+ rspidx = indexResponseHeader rsphdr

76+ case conditionalRequest finfo rsphdr rspidx reqidx of

77+ WithoutBody s -> return $ responseNoBody s rsphdr

78+ WithBody s rsphdr' off bytes -> do

79+ let !off' = fromIntegral off

80+ !bytes' = fromIntegral bytes

81+ !fileSpec = H2.FileSpec path off' bytes'

82+ return $ responseFile2XX s rsphdr' isHead fileSpec

83+

84+----------------------------------------------------------------

85+

86+responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response

87+responseFile2XX st rsphdr isHead fileSpec

88+ | isHead = responseNoBody st rsphdr

89+ | otherwise = H2.responseFile st rsphdr fileSpec

90+

91+----------------------------------------------------------------

92+

93+responseBuilder :: H.Status -> H.ResponseHeaders -> Bool

94+ -> BB.Builder

95+ -> H2.Response

96+responseBuilder st rsphdr isHead builder

97+ | noBody st = responseNoBody st rsphdr

98+ | isHead = responseNoBody st rsphdr

99+ | otherwise = H2.responseBuilder st rsphdr builder

100+

101+----------------------------------------------------------------

102+

103+responseStream :: H.Status -> H.ResponseHeaders -> Bool

104+ -> StreamingBody

105+ -> H2.Response

106+responseStream st rsphdr isHead strmbdy

107+ | noBody st = responseNoBody st rsphdr

108+ | isHead = responseNoBody st rsphdr

109+ | otherwise = H2.responseStreaming st rsphdr strmbdy

110+

111+----------------------------------------------------------------

112+

113+responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response

114+responseNoBody st rsphdr = H2.responseNoBody st rsphdr

115+

116+----------------------------------------------------------------

117+

118+response404 :: H.ResponseHeaders -> H2.Response

119+response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body

120+ where

121+ !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr

122+ !body = BB.byteString "File not found"

123+

124+----------------------------------------------------------------

125+

126+noBody :: H.Status -> Bool

127+noBody = not . R.hasBody

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hsdeleted−536

@@ -1,536 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE BangPatterns, CPP #-}

3−{-# LANGUAGE NamedFieldPuns #-}

4−

5−module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where

6−

7−import Control.Concurrent.STM

8−import qualified Control.Exception as E

9−import qualified Data.ByteString as BS

10−import Data.ByteString.Builder (Builder)

11−import qualified Data.ByteString.Builder.Extra as B

12−import Data.IORef

13−import Foreign.Ptr (Ptr, plusPtr)

14−import Foreign.Storable (poke)

15−import Network.HPACK (setLimitForEncoding, toHeaderTable)

16−import Network.HTTP2

17−import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)

18−import Network.Wai

19−

20−#ifdef WINDOWS

21−import qualified System.IO as IO

22−#else

23−import Network.Wai.Handler.Warp.FdCache

24−import Network.Wai.Handler.Warp.SendFile (positionRead)

25−import qualified Network.Wai.Handler.Warp.Timeout as T

26−#endif

27−

28−import Network.Wai.Handler.Warp.Buffer

29−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

30−import Network.Wai.Handler.Warp.HTTP2.HPACK

31−import Network.Wai.Handler.Warp.HTTP2.Manager (Manager)

32−import Network.Wai.Handler.Warp.HTTP2.Types

33−import Network.Wai.Handler.Warp.Imports hiding (readInt)

34−import qualified Network.Wai.Handler.Warp.Settings as S

35−import Network.Wai.Handler.Warp.Types

36−

37−----------------------------------------------------------------

38−

39−data Leftover = LZero

40− | LOne B.BufferWriter

41− | LTwo ByteString B.BufferWriter

42−

43−----------------------------------------------------------------

44−

45−{-# INLINE getStreamWindowSize #-}

46−getStreamWindowSize :: Stream -> IO WindowSize

47−getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow

48−

49−{-# INLINE waitStreamWindowSize #-}

50−waitStreamWindowSize :: Stream -> IO ()

51−waitStreamWindowSize Stream{streamWindow} = atomically $ do

52− w <- readTVar streamWindow

53− check (w > 0)

54−

55−{-# INLINE waitStreaming #-}

56−waitStreaming :: TBQueue a -> IO ()

57−waitStreaming tbq = atomically $ do

58− isEmpty <- isEmptyTBQueue tbq

59− check (not isEmpty)

60−

61−data Switch = C Control

62− | O (StreamId,Precedence,Output)

63− | Flush

64−

65−frameSender :: Context -> Connection -> S.Settings -> Manager -> IO ()

66−frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

67− conn@Connection{connWriteBuffer,connBufferSize,connSendAll}

68− settings mgr = loop 0 `E.catch` ignore

69− where

70− dequeue off = do

71− isEmpty <- isEmptyTQueue controlQ

72− if isEmpty then do

73− w <- readTVar connectionWindow

74− check (w > 0)

75− emp <- isEmptySTM outputQ

76− if emp then

77− if off /= 0 then return Flush else retry

78− else

79− O <$> dequeueSTM outputQ

80− else

81− C <$> readTQueue controlQ

82−

83− loop off = do

84− x <- atomically $ dequeue off

85− case x of

86− C ctl -> do

87− when (off /= 0) $ flushN off

88− off' <- control ctl off

89− when (off' >= 0) $ loop off'

90− O (_,pre,out) -> do

91− let strm = outputStream out

92− writeIORef (streamPrecedence strm) pre

93− off' <- outputOrEnqueueAgain out off

94− case off' of

95− 0 -> loop 0

96− _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding

97− | otherwise -> loop off'

98− Flush -> flushN off >> loop 0

99−

100− control CFinish _ = return (-1)

101− control (CGoaway frame) _ = connSendAll frame >> return (-1)

102− control (CFrame frame) _ = connSendAll frame >> return 0

103− control (CSettings frame alist) _ = do

104− connSendAll frame

105− setLimit alist

106− return 0

107− control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case

108− let !buf = connWriteBuffer `plusPtr` off

109− !off' = off + BS.length frame1 + BS.length frame2

110− buf' <- copy buf frame1

111− void $ copy buf' frame2

112− setLimit alist

113− return off'

114−

115− {-# INLINE setLimit #-}

116− setLimit alist = case lookup SettingsHeaderTableSize alist of

117− Nothing -> return ()

118− Just siz -> setLimitForEncoding siz encodeDynamicTable

119−

120− output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do

121− -- Data frame payload

122− let !buf = connWriteBuffer `plusPtr` off0

123− !siz = connBufferSize - off0

124− Next datPayloadLen mnext <- curr buf siz lim

125− off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D

126− maybeEnqueueNext out mnext

127− return off

128−

129− output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do

130− -- Header frame and Continuation frame

131− let !sid = streamNumber strm

132− !endOfStream = case rspn of

133− RspnNobody _ _ -> True

134− _ -> False

135− ths <- fixHeaders ctx rspn ii settings

136− kvlen <- headerContinue sid ths endOfStream off0

137− off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

138− case rspn of

139− RspnNobody _ _ -> do

140− closed ctx strm Finished

141− return off

142− RspnFile _ _ path mpart -> do

143− -- Data frame payload

144− let payloadOff = off + frameHeaderLength

145− Next datPayloadLen mnext <-

146− fillFileBodyGetNext conn ii payloadOff lim path mpart

147− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

148− maybeEnqueueNext out mnext

149− return off'

150− RspnBuilder _ _ builder -> do

151− -- Data frame payload

152− let payloadOff = off + frameHeaderLength

153− Next datPayloadLen mnext <-

154− fillBuilderBodyGetNext conn ii payloadOff lim builder

155− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

156− maybeEnqueueNext out mnext

157− return off'

158− RspnStreaming _ _ tbq -> do

159− let payloadOff = off + frameHeaderLength

160− Next datPayloadLen mnext <-

161− fillStreamBodyGetNext conn payloadOff lim tbq strm

162− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

163− maybeEnqueueNext out mnext

164− return off'

165−

166− output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do

167− -- Creating a push promise header

168− -- Frame id should be associated stream id from the client.

169− let !sid = streamNumber strm

170− len <- pushPromise pid sid ths off0

171− off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len

172− output out{ outputType = ORspn } off lim

173−

174− output _ _ _ = undefined -- never reach

175−

176− outputOrEnqueueAgain out off = E.handle resetStream $ do

177− state <- readIORef $ streamState strm

178− if isClosed state then

179− return off

180− else case out of

181− Output _ _ _ wait _ OWait -> do

182− -- Checking if all push are done.

183− let out' = out {

184− outputHook = return ()

185− , outputType = ORspn

186− }

187− forkAndEnqueueWhenReady wait outputQ out' mgr

188− return off

189− _ -> case mtbq of

190− Just tbq -> checkStreaming tbq

191− _ -> checkStreamWindowSize

192− where

193− strm = outputStream out

194− mtbq = outputMaybeTBQueue out

195− checkStreaming tbq = do

196− isEmpty <- atomically $ isEmptyTBQueue tbq

197− if isEmpty then do

198− forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr

199− return off

200− else

201− checkStreamWindowSize

202− checkStreamWindowSize = do

203− sws <- getStreamWindowSize strm

204− if sws == 0 then do

205− forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr

206− return off

207− else do

208− cws <- atomically $ readTVar connectionWindow -- not 0

209− let !lim = min cws sws

210− output out off lim

211− resetStream e = do

212− closed ctx strm (ResetByMe e)

213− let !rst = resetFrame InternalError $ streamNumber strm

214− enqueueControl controlQ $ CFrame rst

215− return off

216−

217− {-# INLINE flushN #-}

218− -- Flush the connection buffer to the socket, where the first 'n' bytes of

219− -- the buffer are filled.

220− flushN :: Int -> IO ()

221− flushN n = bufferIO connWriteBuffer n connSendAll

222−

223− headerContinue sid ths endOfStream off = do

224− let !offkv = off + frameHeaderLength

225− let !bufkv = connWriteBuffer `plusPtr` offkv

226− !limkv = connBufferSize - offkv

227− (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths

228− let flag0 = case hs of

229− [] -> setEndHeader defaultFlags

230− _ -> defaultFlags

231− flag = if endOfStream then setEndStream flag0 else flag0

232− let buf = connWriteBuffer `plusPtr` off

233− fillFrameHeader FrameHeaders kvlen sid flag buf

234− continue sid kvlen hs

235−

236− !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength

237− !headerPayloadLim = connBufferSize - frameHeaderLength

238−

239− continue _ kvlen [] = return kvlen

240− continue sid kvlen ths = do

241− flushN $ kvlen + frameHeaderLength

242− -- Now off is 0

243− (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths

244− when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"

245− let flag = case ths' of

246− [] -> setEndHeader defaultFlags

247− _ -> defaultFlags

248− fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer

249− continue sid kvlen' ths'

250−

251− {-# INLINE maybeEnqueueNext #-}

252− -- Re-enqueue the stream in the output queue.

253− maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()

254− maybeEnqueueNext _ Nothing = return ()

255− maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'

256− where

257− !out' = out { outputType = ONext next }

258−

259− {-# INLINE sendHeadersIfNecessary #-}

260− -- Send headers if there is not room for a 1-byte data frame, and return

261− -- the offset of the next frame's first header byte.

262− sendHeadersIfNecessary off

263− -- True if the connection buffer has room for a 1-byte data frame.

264− | off + frameHeaderLength < connBufferSize = return off

265− | otherwise = do

266− flushN off

267− return 0

268−

269− fillDataHeader strm@Stream{streamWindow,streamNumber}

270− off datPayloadLen mnext tell getH2D = do

271− -- Data frame header

272− mh2d <- getH2D

273− let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of

274− Nothing -> ([], True)

275− Just ts -> (ts, null ts)

276− !buf = connWriteBuffer `plusPtr` off

277− !off' = off + frameHeaderLength + datPayloadLen

278− !noMoreBody = isNothing mnext

279− flag | noMoreBody && noTrailers = setEndStream defaultFlags

280− | otherwise = defaultFlags

281− fillFrameHeader FrameData datPayloadLen streamNumber flag buf

282− off'' <- handleEndOfBody noMoreBody off' noTrailers trailers

283− atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

284− atomically $ modifyTVar' streamWindow (subtract datPayloadLen)

285− return off''

286− where

287− handleTrailers True off0 _ = return off0

288− handleTrailers _ off0 trailers = do

289− (ths,_) <- toHeaderTable trailers

290− kvlen <- headerContinue streamNumber ths True off0

291− sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

292− handleEndOfBody True off0 noTrailers trailers = do

293− off1 <- handleTrailers noTrailers off0 trailers

294− void tell

295− closed ctx strm Finished

296− return off1

297− handleEndOfBody False off0 _ _ = return off0

298−

299−

300− pushPromise pid sid ths off = do

301− let !offsid = off + frameHeaderLength

302− !bufsid = connWriteBuffer `plusPtr` offsid

303− poke32 bufsid $ fromIntegral sid

304− let !offkv = offsid + 4

305− !bufkv = connWriteBuffer `plusPtr` offkv

306− !limkv = connBufferSize - offkv

307− (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths

308− let !flag = setEndHeader defaultFlags -- No EndStream flag

309− !buf = connWriteBuffer `plusPtr` off

310− !len = kvlen + 4

311− fillFrameHeader FramePushPromise len pid flag buf

312− return len

313−

314− {-# INLINE fillFrameHeader #-}

315− fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf

316− where

317− hinfo = FrameHeader len flag sid

318−

319− {-# INLINE ignore #-}

320− ignore :: E.SomeException -> IO ()

321− ignore _ = return ()

322−

323−----------------------------------------------------------------

324−

325−{-

326−ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)

327−ResponseBuilder Status ResponseHeaders Builder

328−ResponseStream Status ResponseHeaders StreamingBody

329−ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response

330−-}

331−

332−fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next

333−fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}

334− _ off lim bb = do

335− let datBuf = connWriteBuffer `plusPtr` off

336− room = min (connBufferSize - off) lim

337− (len, signal) <- B.runBuilder bb datBuf room

338− return $ nextForBuilder len signal

339−

340−fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next

341−#ifdef WINDOWS

342−fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

343− _ off lim path mpart = do

344− let datBuf = connWriteBuffer `plusPtr` off

345− room = min (connBufferSize - off) lim

346− (start, bytes) <- fileStartEnd path mpart

347− -- fixme: how to close Handle? GC does it at this moment.

348− hdl <- IO.openBinaryFile path IO.ReadMode

349− IO.hSeek hdl IO.AbsoluteSeek start

350− len <- IO.hGetBufSome hdl datBuf (mini room bytes)

351− let bytes' = bytes - fromIntegral len

352− -- fixme: connWriteBuffer connBufferSize

353− return $ nextForFile len hdl bytes' (return ())

354−#else

355−fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

356− ii off lim path mpart = do

357− (mfd, refresh') <- getFd ii path

358− (fd, refresh) <- case mfd of

359− Nothing -> do

360− fd' <- openFile path

361− th <- T.register (timeoutManager ii) (closeFile fd')

362− return (fd', T.tickle th)

363− Just fd -> return (fd, refresh')

364− let datBuf = connWriteBuffer `plusPtr` off

365− room = min (connBufferSize - off) lim

366− (start, bytes) <- fileStartEnd path mpart

367− len <- positionRead fd datBuf (mini room bytes) start

368− refresh

369− let len' = fromIntegral len

370− return $ nextForFile len fd (start + len') (bytes - len') refresh

371−#endif

372−

373−fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)

374−fileStartEnd _ (Just part) =

375− return (filePartOffset part, filePartByteCount part)

376−fileStartEnd _ _ = error "fileStartEnd"

377−

378−----------------------------------------------------------------

379−

380−fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next

381−fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

382− off lim sq strm = do

383− let datBuf = connWriteBuffer `plusPtr` off

384− room = min (connBufferSize - off) lim

385− (leftover, cont, len) <- runStreamBuilder datBuf room sq

386− return $ nextForStream sq strm leftover cont len

387−

388−----------------------------------------------------------------

389−

390−fillBufBuilder :: Leftover -> DynaNext

391−fillBufBuilder leftover buf0 siz0 lim = do

392− let payloadBuf = buf0 `plusPtr` frameHeaderLength

393− room = min (siz0 - frameHeaderLength) lim

394− case leftover of

395− LZero -> error "fillBufBuilder: LZero"

396− LOne writer -> do

397− (len, signal) <- writer payloadBuf room

398− getNext len signal

399− LTwo bs writer

400− | BS.length bs <= room -> do

401− buf1 <- copy payloadBuf bs

402− let len1 = BS.length bs

403− (len2, signal) <- writer buf1 (room - len1)

404− getNext (len1 + len2) signal

405− | otherwise -> do

406− let (bs1,bs2) = BS.splitAt room bs

407− void $ copy payloadBuf bs1

408− getNext room (B.Chunk bs2 writer)

409− where

410− getNext l s = return $ nextForBuilder l s

411−

412−nextForBuilder :: BytesFilled -> B.Next -> Next

413−nextForBuilder len B.Done

414− = Next len Nothing

415−nextForBuilder len (B.More _ writer)

416− = Next len $ Just (fillBufBuilder (LOne writer))

417−nextForBuilder len (B.Chunk bs writer)

418− = Next len $ Just (fillBufBuilder (LTwo bs writer))

419−

420−----------------------------------------------------------------

421−

422−runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence

423− -> IO (Leftover, Bool, BytesFilled)

424−runStreamBuilder buf0 room0 sq = loop buf0 room0 0

425− where

426− loop !buf !room !total = do

427− mbuilder <- atomically $ tryReadTBQueue sq

428− case mbuilder of

429− Nothing -> return (LZero, True, total)

430− Just (SBuilder builder) -> do

431− (len, signal) <- B.runBuilder builder buf room

432− let !total' = total + len

433− case signal of

434− B.Done -> loop (buf `plusPtr` len) (room - len) total'

435− B.More _ writer -> return (LOne writer, True, total')

436− B.Chunk bs writer -> return (LTwo bs writer, True, total')

437− Just SFlush -> return (LZero, True, total)

438− Just SFinish -> return (LZero, False, total)

439−

440−fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext

441−fillBufStream leftover0 sq strm buf0 siz0 lim0 = do

442− let payloadBuf = buf0 `plusPtr` frameHeaderLength

443− room0 = min (siz0 - frameHeaderLength) lim0

444− case leftover0 of

445− LZero -> do

446− (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq

447− getNext leftover cont len

448− LOne writer -> write writer payloadBuf room0 0

449− LTwo bs writer

450− | BS.length bs <= room0 -> do

451− buf1 <- copy payloadBuf bs

452− let len = BS.length bs

453− write writer buf1 (room0 - len) len

454− | otherwise -> do

455− let (bs1,bs2) = BS.splitAt room0 bs

456− void $ copy payloadBuf bs1

457− getNext (LTwo bs2 writer) True room0

458− where

459− getNext l b r = return $ nextForStream sq strm l b r

460− write writer1 buf room sofar = do

461− (len, signal) <- writer1 buf room

462− case signal of

463− B.Done -> do

464− (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq

465− let !total = sofar + len + extra

466− getNext leftover cont total

467− B.More _ writer -> do

468− let !total = sofar + len

469− getNext (LOne writer) True total

470− B.Chunk bs writer -> do

471− let !total = sofar + len

472− getNext (LTwo bs writer) True total

473−

474−nextForStream :: TBQueue Sequence -> Stream

475− -> Leftover -> Bool -> BytesFilled

476− -> Next

477−nextForStream _ _ _ False len = Next len Nothing

478−nextForStream sq strm leftOrZero True len =

479− Next len $ Just (fillBufStream leftOrZero sq strm)

480−

481−----------------------------------------------------------------

482−

483−#ifdef WINDOWS

484−fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext

485−fillBufFile h bytes refresh buf siz lim = do

486− let payloadBuf = buf `plusPtr` frameHeaderLength

487− room = min (siz - frameHeaderLength) lim

488− len <- IO.hGetBufSome h payloadBuf room

489− refresh

490− let bytes' = bytes - fromIntegral len

491− return $ nextForFile len h bytes' refresh

492−

493−nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next

494−nextForFile 0 _ _ _ = Next 0 Nothing

495−nextForFile len _ 0 _ = Next len Nothing

496−nextForFile len h bytes refresh =

497− Next len $ Just (fillBufFile h bytes refresh)

498−#else

499−fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext

500−fillBufFile fd start bytes refresh buf siz lim = do

501− let payloadBuf = buf `plusPtr` frameHeaderLength

502− room = min (siz - frameHeaderLength) lim

503− len <- positionRead fd payloadBuf (mini room bytes) start

504− let len' = fromIntegral len

505− refresh

506− return $ nextForFile len fd (start + len') (bytes - len') refresh

507−

508−nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next

509−nextForFile 0 _ _ _ _ = Next 0 Nothing

510−nextForFile len _ _ 0 _ = Next len Nothing

511−nextForFile len fd start bytes refresh =

512− Next len $ Just (fillBufFile fd start bytes refresh)

513−#endif

514−

515−{-# INLINE mini #-}

516−mini :: Int -> Integer -> Int

517−mini i n

518− | fromIntegral i < n = i

519− | otherwise = fromIntegral n

520−

521−

522−----------------------------------------------------------------

523−

524−poke32 :: Ptr Word8 -> Word32 -> IO ()

525−poke32 ptr i = do

526− poke ptr w0

527− poke8 ptr 1 w1

528− poke8 ptr 2 w2

529− poke8 ptr 3 w3

530− where

531− w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)

532− w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)

533− w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)

534− w3 = fromIntegral (i .&. 0xff)

535− poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()

536− poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+13−265

@@ -1,282 +1,26 @@

1+{-# LANGUAGE NamedFieldPuns #-}

1−{-# LANGUAGE OverloadedStrings, CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

3+{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE BangPatterns #-}

4

5module Network.Wai.Handler.Warp.HTTP2.Types where

6

7−import Control.Concurrent (forkIO)

8−import Control.Concurrent.STM

9−import Control.Exception (SomeException, bracket)

10import qualified Data.ByteString as BS

7import qualified Data.ByteString as BS

11−import Data.ByteString.Builder (Builder)

12−import Data.IORef

13−import Data.IntMap.Strict (IntMap, IntMap)

14−import qualified Data.IntMap.Strict as M

15−import Network.HPACK hiding (Buffer)

16import qualified Network.HTTP.Types as H

8import qualified Network.HTTP.Types as H

17import Network.HTTP2

9import Network.HTTP2

18−import Network.HTTP2.Priority

10+import qualified Network.HTTP2.Server as H2

19−import Network.Wai (Request, FilePart)

20

11

21−import Network.Wai.Handler.Warp.HTTP2.Manager

22import Network.Wai.Handler.Warp.Imports

12import Network.Wai.Handler.Warp.Imports

23import Network.Wai.Handler.Warp.Types

13import Network.Wai.Handler.Warp.Types

24

14

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

15----------------------------------------------------------------

26

16

27−http2ver :: H.HttpVersion

28−http2ver = H.HttpVersion 2 0

29−

30isHTTP2 :: Transport -> Bool

17isHTTP2 :: Transport -> Bool

31isHTTP2 TCP = False

18isHTTP2 TCP = False

32isHTTP2 tls = useHTTP2

19isHTTP2 tls = useHTTP2

33 where

20 where

34 useHTTP2 = case tlsNegotiatedProtocol tls of

21 useHTTP2 = case tlsNegotiatedProtocol tls of

35 Nothing -> False

22 Nothing -> False

36− Just proto -> "h2-" `BS.isPrefixOf` proto

23+ Just proto -> "h2" `BS.isPrefixOf` proto

37−

38−----------------------------------------------------------------

39−

40−data Input = Input Stream Request ValueTable InternalInfo

41−

42−----------------------------------------------------------------

43−

44−type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next

45−

46−type BytesFilled = Int

47−

48−data Next = Next !BytesFilled (Maybe DynaNext)

49−

50−data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)

51− | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)

52− | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder

53− | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)

54−

55−rspnStatus :: Rspn -> H.Status

56−rspnStatus (RspnNobody s _) = s

57−rspnStatus (RspnStreaming s _ _) = s

58−rspnStatus (RspnBuilder s _ _) = s

59−rspnStatus (RspnFile s _ _ _ ) = s

60−

61−rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)

62−rspnHeaders (RspnNobody _ t) = t

63−rspnHeaders (RspnStreaming _ t _) = t

64−rspnHeaders (RspnBuilder _ t _) = t

65−rspnHeaders (RspnFile _ t _ _ ) = t

66−

67−data Output = Output {

68− outputStream :: !Stream

69− , outputRspn :: !Rspn

70− , outputII :: !InternalInfo

71− , outputHook :: IO () -- OPush: wait for done, O*: telling done

72− , outputH2Data :: IO (Maybe HTTP2Data)

73− , outputType :: !OutputType

74− }

75−

76−data OutputType = ORspn

77− | OWait

78− | OPush !TokenHeaderList !StreamId -- associated stream id from client

79− | ONext !DynaNext

80−

81−outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)

82−outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq

83−outputMaybeTBQueue _ = Nothing

84−

85−data Control = CFinish

86− | CGoaway !ByteString

87− | CFrame !ByteString

88− | CSettings !ByteString !SettingsList

89− | CSettings0 !ByteString !ByteString !SettingsList

90−

91−----------------------------------------------------------------

92−

93−data Sequence = SFinish

94− | SFlush

95− | SBuilder Builder

96−

97−----------------------------------------------------------------

98−

99−-- | The context for HTTP/2 connection.

100−data Context = Context {

101− -- HTTP/2 settings received from a browser

102− http2settings :: !(IORef Settings)

103− , firstSettings :: !(IORef Bool)

104− , streamTable :: !StreamTable

105− , concurrency :: !(IORef Int)

106− , priorityTreeSize :: !(IORef Int)

107− -- | RFC 7540 says "Other frames (from any stream) MUST NOT

108− -- occur between the HEADERS frame and any CONTINUATION

109− -- frames that might follow". This field is used to implement

110− -- this requirement.

111− , continued :: !(IORef (Maybe StreamId))

112− , clientStreamId :: !(IORef StreamId)

113− , serverStreamId :: !(IORef StreamId)

114− , inputQ :: !(TQueue Input)

115− , outputQ :: !(PriorityTree Output)

116− , controlQ :: !(TQueue Control)

117− , encodeDynamicTable :: !DynamicTable

118− , decodeDynamicTable :: !DynamicTable

119− -- the connection window for data from a server to a browser.

120− , connectionWindow :: !(TVar WindowSize)

121− }

122−

123−----------------------------------------------------------------

124−

125−newContext :: IO Context

126−newContext = Context <$> newIORef defaultSettings

127− <*> newIORef False

128− <*> newStreamTable

129− <*> newIORef 0

130− <*> newIORef 0

131− <*> newIORef Nothing

132− <*> newIORef 0

133− <*> newIORef 0

134− <*> newTQueueIO

135− <*> newPriorityTree

136− <*> newTQueueIO

137− <*> newDynamicTableForEncoding defaultDynamicTableSize

138− <*> newDynamicTableForDecoding defaultDynamicTableSize 4096

139− <*> newTVarIO defaultInitialWindowSize

140−

141−clearContext :: Context -> IO ()

142−clearContext _ctx = return ()

143−

144−----------------------------------------------------------------

145−

146−data OpenState =

147− JustOpened

148− | Continued [HeaderBlockFragment]

149− !Int -- Total size

150− !Int -- The number of continuation frames

151− !Bool -- End of stream

152− !Priority

153− | NoBody (TokenHeaderList,ValueTable) !Priority

154− | HasBody (TokenHeaderList,ValueTable) !Priority

155− | Body !(TQueue ByteString)

156− !(Maybe Int) -- received Content-Length

157− -- compared the body length for error checking

158− !(IORef Int) -- actual body length

159−

160−data ClosedCode = Finished

161− | Killed

162− | Reset !ErrorCodeId

163− | ResetByMe SomeException

164− deriving Show

165−

166−data StreamState =

167− Idle

168− | Open !OpenState

169− | HalfClosed

170− | Closed !ClosedCode

171− | Reserved

172−

173−isIdle :: StreamState -> Bool

174−isIdle Idle = True

175−isIdle _ = False

176−

177−isOpen :: StreamState -> Bool

178−isOpen Open{} = True

179−isOpen _ = False

180−

181−isHalfClosed :: StreamState -> Bool

182−isHalfClosed HalfClosed = True

183−isHalfClosed _ = False

184−

185−isClosed :: StreamState -> Bool

186−isClosed Closed{} = True

187−isClosed _ = False

188−

189−instance Show StreamState where

190− show Idle = "Idle"

191− show Open{} = "Open"

192− show HalfClosed = "HalfClosed"

193− show (Closed e) = "Closed: " ++ show e

194− show Reserved = "Reserved"

195−

196−----------------------------------------------------------------

197−

198−data Stream = Stream {

199− streamNumber :: !StreamId

200− , streamState :: !(IORef StreamState)

201− , streamWindow :: !(TVar WindowSize)

202− , streamPrecedence :: !(IORef Precedence)

203− }

204−

205−instance Show Stream where

206− show s = show (streamNumber s)

207−

208−newStream :: StreamId -> WindowSize -> IO Stream

209−newStream sid win = Stream sid <$> newIORef Idle

210− <*> newTVarIO win

211− <*> newIORef defaultPrecedence

212−

213−newPushStream :: Context -> WindowSize -> Precedence -> IO Stream

214−newPushStream Context{serverStreamId} win pre = do

215− sid <- atomicModifyIORef' serverStreamId inc2

216− Stream sid <$> newIORef Reserved

217− <*> newTVarIO win

218− <*> newIORef pre

219− where

220− inc2 x = let !x' = x + 2 in (x', x')

221−

222−----------------------------------------------------------------

223−

224−opened :: Context -> Stream -> IO ()

225−opened Context{concurrency} Stream{streamState} = do

226− atomicModifyIORef' concurrency (\x -> (x+1,()))

227− writeIORef streamState (Open JustOpened)

228−

229−closed :: Context -> Stream -> ClosedCode -> IO ()

230−closed Context{concurrency,streamTable} Stream{streamState,streamNumber} cc = do

231− remove streamTable streamNumber

232− atomicModifyIORef' concurrency (\x -> (x-1,()))

233− writeIORef streamState (Closed cc) -- anyway

234−

235−----------------------------------------------------------------

236−

237−newtype StreamTable = StreamTable (IORef (IntMap Stream))

238−

239−newStreamTable :: IO StreamTable

240−newStreamTable = StreamTable <$> newIORef M.empty

241−

242−insert :: StreamTable -> M.Key -> Stream -> IO ()

243−insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->

244− let !m' = M.insert k v m

245− in (m', ())

246−

247−remove :: StreamTable -> M.Key -> IO ()

248−remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->

249− let !m' = M.delete k m

250− in (m', ())

251−

252−search :: StreamTable -> M.Key -> IO (Maybe Stream)

253−search (StreamTable ref) k = M.lookup k <$> readIORef ref

254−

255−updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()

256−updateAllStreamWindow adst (StreamTable ref) = do

257− strms <- M.elems <$> readIORef ref

258− forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst

259−

260−{-# INLINE forkAndEnqueueWhenReady #-}

261−forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()

262−forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->

263− void . forkIO $ do

264− wait

265− enqueueOutput outQ out

266− where

267− setup = addMyId mgr

268− teardown _ = deleteMyId mgr

269−

270−{-# INLINE enqueueOutput #-}

271−enqueueOutput :: PriorityTree Output -> Output -> IO ()

272−enqueueOutput outQ out = do

273− let Stream{..} = outputStream out

274− pre <- readIORef streamPrecedence

275− enqueue outQ streamNumber pre out

276−

277−{-# INLINE enqueueControl #-}

278−enqueueControl :: TQueue Control -> Control -> IO ()

279−enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl

280

24

281----------------------------------------------------------------

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

282

26

@@ -288,17 +32,21 @@ data HTTP2Data = HTTP2Data {

288 --

32 --

289 -- Since: 3.2.7

33 -- Since: 3.2.7

290 http2dataPushPromise :: [PushPromise]

34 http2dataPushPromise :: [PushPromise]

35+ -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.

36+ --

291− -- Since: 3.2.8

37+ -- Since: 3.2.8 but the type changed in 3.3.0

292− , http2dataTrailers :: H.ResponseHeaders

38+ , http2dataTrailers :: H2.TrailersMaker

293− } deriving (Eq,Show)

39+ }

294

40

295-- | Default HTTP/2 specific data.

41-- | Default HTTP/2 specific data.

296--

42--

297-- Since: 3.2.7

43-- Since: 3.2.7

298defaultHTTP2Data :: HTTP2Data

44defaultHTTP2Data :: HTTP2Data

299−defaultHTTP2Data = HTTP2Data [] []

45+defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

300

46

301-- | HTTP/2 push promise or sever push.

47-- | HTTP/2 push promise or sever push.

48+-- This allows files only for backward-compatibility

49+-- while the HTTP/2 library supports other types.

302--

50--

303-- Since: 3.2.7

51-- Since: 3.2.7

304data PushPromise = PushPromise {

52data PushPromise = PushPromise {

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hsdeleted−328

@@ -1,328 +0,0 @@

1−{-# LANGUAGE NamedFieldPuns #-}

2−{-# LANGUAGE PatternGuards #-}

3−{-# LANGUAGE CPP #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE BangPatterns #-}

7−

8−module Network.Wai.Handler.Warp.HTTP2.Worker (

9− Responder

10− , response

11− , worker

12− ) where

13−

14−import Control.Concurrent.STM

15−import Control.Exception (SomeException(..), AsyncException(..))

16−import qualified Control.Exception as E

17−import Data.ByteString.Builder (byteString)

18−import Data.IORef

19−import qualified Data.Vault.Lazy as Vault

20−import Network.HPACK

21−import Network.HPACK.Token

22−import qualified Network.HTTP.Types as H

23−import Network.HTTP2

24−import Network.HTTP2.Priority

25−import Network.Wai

26−import qualified Network.Wai.Handler.Warp.Timeout as Timeout

27−import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))

28−

29−import Network.Wai.Handler.Warp.FileInfoCache

30−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

31−import Network.Wai.Handler.Warp.HTTP2.File

32−import Network.Wai.Handler.Warp.HTTP2.Manager

33−import Network.Wai.Handler.Warp.HTTP2.Request

34−import Network.Wai.Handler.Warp.HTTP2.Types

35−import Network.Wai.Handler.Warp.Imports hiding (insert)

36−import Network.Wai.Handler.Warp.Request (pauseTimeoutKey)

37−import qualified Network.Wai.Handler.Warp.Response as R

38−import qualified Network.Wai.Handler.Warp.Settings as S

39−import qualified Network.Wai.Handler.Warp.Timeout as T

40−import Network.Wai.Handler.Warp.Types

41−

42−----------------------------------------------------------------

43−

44−-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.

45−-- This type implements the second argument (Response -> IO ResponseReceived)

46−-- with extra arguments.

47−type Responder = InternalInfo

48− -> ValueTable -- for Request

49− -> ThreadContinue

50− -> Stream

51− -> Request

52− -> Response

53− -> IO ResponseReceived

54−

55−pushStream :: Context -> S.Settings

56− -> StreamId -> ValueTable -> Request -> InternalInfo

57− -> Maybe HTTP2Data

58− -> IO (OutputType, IO ())

59−pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())

60−pushStream ctx@Context{http2settings,outputQ,streamTable}

61− settings pid reqvt req ii (Just h2d)

62− | len == 0 = return (ORspn, return ())

63− | otherwise = do

64− pushable <- enablePush <$> readIORef http2settings

65− if pushable then do

66− tvar <- newTVarIO 0

67− lim <- push tvar pps0 0

68− if lim == 0 then

69− return (ORspn, return ())

70− else

71− return (OWait, waiter lim tvar)

72− else

73− return (ORspn, return ())

74− where

75− !pps0 = http2dataPushPromise h2d

76− !len = length pps0

77− !pushLogger = S.settingsServerPushLogger settings

78− increment tvar = atomically $ modifyTVar' tvar (+1)

79− waiter lim tvar = atomically $ do

80− n <- readTVar tvar

81− check (n >= lim)

82− !h2data = getHTTP2Data req

83− push _ [] !n = return (n :: Int)

84− push tvar (pp:pps) !n = do

85− let !file = promisedFile pp

86− efinfo <- E.try $ getFileInfo ii file

87− case efinfo of

88− Left (_ex :: E.IOException) -> push tvar pps n

89− Right (FileInfo _ size _ date) -> do

90− ws <- initialWindowSize <$> readIORef http2settings

91− let !w = promisedWeight pp

92− !pri = defaultPriority { weight = w }

93− !pre = toPrecedence pri

94− strm <- newPushStream ctx ws pre

95− let !sid = streamNumber strm

96− insert streamTable sid strm

97− (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)

98− let !scheme = fromJust $ getHeaderValue tokenScheme reqvt

99− -- fixme: this value can be Nothing

100− !auth = fromJust (getHeaderValue tokenHost reqvt

101− <|> getHeaderValue tokenAuthority reqvt)

102− !path = promisedPath pp

103− !promisedRequest = [(tokenMethod, H.methodGet)

104− ,(tokenScheme, scheme)

105− ,(tokenAuthority, auth)

106− ,(tokenPath, path)]

107− !part = FilePart 0 size size

108− !rsp = RspnFile H.ok200 (ths,vt) file (Just part)

109− !ths = (tokenLastModified,date) :

110− addContentHeadersForFilePart ths0 part

111− pushLogger req path size

112− let !ot = OPush promisedRequest pid

113− !out = Output strm rsp ii (increment tvar) h2data ot

114− enqueueOutput outputQ out

115− push tvar pps (n + 1)

116−

117−

118−-- | This function is passed to workers.

119−-- They also pass 'Response's from 'Application's to this function.

120−-- This function enqueues commands for the HTTP/2 sender.

121−response :: S.Settings -> Context -> Manager -> Responder

122−response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of

123− ResponseStream s0 hs0 strmbdy

124− | noBody s0 -> responseNoBody s0 hs0

125− | isHead -> responseNoBody s0 hs0

126− | otherwise -> getHTTP2Data req

127− >>= pushStream ctx settings sid reqvt req ii

128− >>= responseStreaming s0 hs0 strmbdy

129− ResponseBuilder s0 hs0 b

130− | noBody s0 -> responseNoBody s0 hs0

131− | isHead -> responseNoBody s0 hs0

132− | otherwise -> getHTTP2Data req

133− >>= pushStream ctx settings sid reqvt req ii

134− >>= responseBuilderBody s0 hs0 b

135− ResponseFile s0 hs0 p mp

136− | noBody s0 -> responseNoBody s0 hs0

137− | otherwise -> getHTTP2Data req

138− >>= pushStream ctx settings sid reqvt req ii

139− >>= responseFileXXX s0 hs0 p mp

140− ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"

141− where

142− noBody = not . R.hasBody

143− !isHead = requestMethod req == H.methodHead

144− !logger = S.settingsLogger settings

145− !th = threadHandle ii

146− sid = streamNumber strm

147− !h2data = getHTTP2Data req

148−

149− -- Ideally, log messages should be written when responses are

150− -- actually sent. But there is no way to keep good memory usage

151− -- (resist to Request leak) and throughput. By compromise,

152− -- log message are written here even the window size of streams

153− -- is 0.

154−

155− responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s

156−

157− responseNoBody' s tbl = do

158− logger req s Nothing

159− setThreadContinue tconf True

160− let !rspn = RspnNobody s tbl

161− !out = Output strm rspn ii (return ()) h2data ORspn

162− enqueueOutput outputQ out

163− return ResponseReceived

164−

165− responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do

166− logger req s Nothing

167− setThreadContinue tconf True

168− tbl <- toHeaderTable hs0

169− let !rspn = RspnBuilder s tbl bdy

170− !out = Output strm rspn ii tell h2data rspnOrWait

171− enqueueOutput outputQ out

172− return ResponseReceived

173−

174− responseFileXXX _ hs0 path Nothing aux = do

175− efinfo <- E.try $ getFileInfo ii path

176− case efinfo of

177− Left (_ex :: E.IOException) -> response404 hs0

178− Right finfo -> do

179− (rspths0,vt) <- toHeaderTable hs0

180− case conditionalRequest finfo rspths0 reqvt of

181− WithoutBody s -> responseNoBody s hs0

182− WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux

183−

184− responseFileXXX s0 hs0 path mpart aux = do

185− tbl <- toHeaderTable hs0

186− responseFile2XX s0 tbl path mpart aux

187−

188− responseFile2XX s tbl path mpart (rspnOrWait,tell)

189− | isHead = do

190− logger req s Nothing

191− responseNoBody' s tbl

192− | otherwise = do

193− logger req s (filePartByteCount <$> mpart)

194− setThreadContinue tconf True

195− let !rspn = RspnFile s tbl path mpart

196− !out = Output strm rspn ii tell h2data rspnOrWait

197− enqueueOutput outputQ out

198− return ResponseReceived

199−

200− response404 hs0 = responseBuilderBody s hs body (ORspn, return ())

201− where

202− s = H.notFound404

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

204− body = byteString "File not found"

205−

206− responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do

207− logger req s0 Nothing

208− -- We must not exit this WAI application.

209− -- If the application exits, streaming would be also closed.

210− -- So, this work occupies this thread.

211− --

212− -- We need to increase the number of workers.

213− spawnAction mgr

214− -- After this work, this thread stops to decease

215− -- the number of workers.

216− setThreadContinue tconf False

217− -- Since 'StreamingBody' is loop, we cannot control it.

218− -- So, let's serialize 'Builder' with a designated queue.

219− tbq <- newTBQueueIO 10 -- fixme: hard coding: 10

220− tbl <- toHeaderTable hs0

221− let !rspn = RspnStreaming s0 tbl tbq

222− !out = Output strm rspn ii tell h2data rspnOrWait

223− enqueueOutput outputQ out

224− let push b = do

225− T.pause th

226− atomically $ writeTBQueue tbq (SBuilder b)

227− T.resume th

228− flush = atomically $ writeTBQueue tbq SFlush

229− _ <- strmbdy push flush

230− atomically $ writeTBQueue tbq SFinish

231− deleteMyId mgr

232− return ResponseReceived

233−

234−worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO ()

235−worker ctx@Context{inputQ,controlQ} set app responder tm = do

236− sinfo <- newStreamInfo

237− tcont <- newThreadContinue

238− let timeoutAction = return () -- cannot close the shared connection

239− E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont

240− where

241− go sinfo tcont th = do

242− setThreadContinue tcont True

243− ex <- E.try $ do

244− T.pause th

245− inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ

246− setStreamInfo sinfo inp

247− T.resume th

248− T.tickle th

249− let !ii' = ii { threadHandle = th }

250− !body = requestBody req

251− !body' = do

252− T.pause th

253− bs <- body

254− T.resume th

255− return bs

256− !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ vault req

257− !req' = req { vault = vaultValue, requestBody = body' }

258− app req' $ responder ii' reqvt tcont strm req'

259− cont1 <- case ex of

260− Right ResponseReceived -> return True

261− Left e@(SomeException _)

262− -- killed by the local worker manager

263− | Just ThreadKilled <- E.fromException e -> return False

264− -- killed by the local timeout manager

265− | Just T.TimeoutThread <- E.fromException e -> do

266− cleanup sinfo Nothing

267− return True

268− | otherwise -> do

269− cleanup sinfo $ Just e

270− return True

271− cont2 <- getThreadContinue tcont

272− clearStreamInfo sinfo

273− when (cont1 && cont2) $ go sinfo tcont th

274− cleanup sinfo me = do

275− minp <- getStreamInfo sinfo

276− case minp of

277− Nothing -> return ()

278− Just (Input strm req _reqvt _ii) -> do

279− closed ctx strm Killed

280− let !frame = resetFrame InternalError (streamNumber strm)

281− enqueueControl controlQ $ CFrame frame

282− case me of

283− Nothing -> return ()

284− Just e -> S.settingsOnException set (Just req) e

285−

286−----------------------------------------------------------------

287−

288−-- | It would nice if responders could return values to workers.

289−-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.

290−-- It is not wise to change this type.

291−-- So, a reference is shared by a responder and its worker.

292−-- The reference refers a value of this type as a return value.

293−-- If 'True', the worker continue to serve requests.

294−-- Otherwise, the worker get finished.

295−newtype ThreadContinue = ThreadContinue (IORef Bool)

296−

297−{-# INLINE newThreadContinue #-}

298−newThreadContinue :: IO ThreadContinue

299−newThreadContinue = ThreadContinue <$> newIORef True

300−

301−{-# INLINE setThreadContinue #-}

302−setThreadContinue :: ThreadContinue -> Bool -> IO ()

303−setThreadContinue (ThreadContinue ref) x = writeIORef ref x

304−

305−{-# INLINE getThreadContinue #-}

306−getThreadContinue :: ThreadContinue -> IO Bool

307−getThreadContinue (ThreadContinue ref) = readIORef ref

308−

309−----------------------------------------------------------------

310−

311−-- | The type to store enough information for 'settingsOnException'.

312−newtype StreamInfo = StreamInfo (IORef (Maybe Input))

313−

314−{-# INLINE newStreamInfo #-}

315−newStreamInfo :: IO StreamInfo

316−newStreamInfo = StreamInfo <$> newIORef Nothing

317−

318−{-# INLINE clearStreamInfo #-}

319−clearStreamInfo :: StreamInfo -> IO ()

320−clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing

321−

322−{-# INLINE setStreamInfo #-}

323−setStreamInfo :: StreamInfo -> Input -> IO ()

324−setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp

325−

326−{-# INLINE getStreamInfo #-}

327−getStreamInfo :: StreamInfo -> IO (Maybe Input)

328−getStreamInfo (StreamInfo ref) = readIORef ref

warp/Network/Wai/Handler/Warp/HashMap.hs+24−15

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

1+{-# LANGUAGE BangPatterns #-}

2+

1module Network.Wai.Handler.Warp.HashMap where

3module Network.Wai.Handler.Warp.HashMap where

2

4

3import Data.Hashable (hash)

5import Data.Hashable (hash)

@@ -7,27 +9,34 @@ import Data.Map.Strict (Map)

7import qualified Data.Map.Strict as M

9import qualified Data.Map.Strict as M

8import Prelude hiding (lookup)

10import Prelude hiding (lookup)

9

11

10−import Network.Wai.Handler.Warp.Imports hiding (insert, lookup)

12+----------------------------------------------------------------

11

13

12−type Hash = Int

14+-- | 'HashMap' is used for cache of file information.

15+-- Hash values of file pathes are used as outer keys.

16+-- Because negative entries are also contained,

17+-- a bad guy can intentionally cause the hash collison.

18+-- So, 'Map' is used internally to prevent

19+-- the hash collision attack.

13−newtype HashMap k v = HashMap (IntMap (Map k v))

20+newtype HashMap v = HashMap (IntMap (Map FilePath v))

14

21

15−hashByteString :: ByteString -> Hash

22+----------------------------------------------------------------

16−hashByteString = hash

17

23

18−empty :: HashMap k v

24+empty :: HashMap v

19empty = HashMap I.empty

25empty = HashMap I.empty

20

26

21−null :: HashMap k v -> Bool

27+isEmpty :: HashMap v -> Bool

22−null (HashMap hm) = I.null hm

28+isEmpty (HashMap hm) = I.null hm

29+

30+----------------------------------------------------------------

23

31

24−insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v

32+insert :: FilePath -> v -> HashMap v -> HashMap v

25−insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm

33+insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm

26 where

34 where

35+ !h = hash path

27− m = M.singleton k v

36+ !m = M.singleton path v

28 f = M.union -- fimxe

37 f = M.union -- fimxe

29−{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}

30

38

31−lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v

39+lookup :: FilePath -> HashMap v -> Maybe v

32−lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k

40+lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path

33−{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}

41+ where

42+ !h = hash path

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/Internal.hs+3−2

@@ -53,7 +53,7 @@ module Network.Wai.Handler.Warp.Internal (

53 -- resumed as soon as we return from user code.

54 --

55 -- * Every time data is successfully sent to the client, the timeout is tickled.

56− , module Network.Wai.Handler.Warp.Timeout

56+ , module System.TimeManager

57 -- * File descriptor cache

58 , module Network.Wai.Handler.Warp.FdCache

59 -- * File information cache

@@ -69,6 +69,8 @@ module Network.Wai.Handler.Warp.Internal (

69 , windowsThreadBlockHack

70 ) where

71

72+import System.TimeManager

73+

72import Network.Wai.Handler.Warp.Buffer

74import Network.Wai.Handler.Warp.Buffer

73import Network.Wai.Handler.Warp.Date

75import Network.Wai.Handler.Warp.Date

74import Network.Wai.Handler.Warp.FdCache

76import Network.Wai.Handler.Warp.FdCache

@@ -80,6 +82,5 @@ import Network.Wai.Handler.Warp.Response

80import Network.Wai.Handler.Warp.Run

82import Network.Wai.Handler.Warp.Run

81import Network.Wai.Handler.Warp.SendFile

83import Network.Wai.Handler.Warp.SendFile

82import Network.Wai.Handler.Warp.Settings

84import Network.Wai.Handler.Warp.Settings

83−import Network.Wai.Handler.Warp.Timeout

84import Network.Wai.Handler.Warp.Types

85import Network.Wai.Handler.Warp.Types

85import Network.Wai.Handler.Warp.Windows

86import Network.Wai.Handler.Warp.Windows

warp/Network/Wai/Handler/Warp/MultiMap.hs+55−44

@@ -1,100 +1,111 @@

1+{-# LANGUAGE BangPatterns #-}

2+

1module Network.Wai.Handler.Warp.MultiMap (

3module Network.Wai.Handler.Warp.MultiMap (

2− MMap

4+ MultiMap

3 , isEmpty

5 , isEmpty

4 , empty

6 , empty

5 , singleton

7 , singleton

6 , insert

8 , insert

7− , search

9+ , Network.Wai.Handler.Warp.MultiMap.lookup

8− , searchWith

9 , pruneWith

10 , pruneWith

10 , toList

11 , toList

11 , merge

12 , merge

12 ) where

13 ) where

13

14

15+import Data.Hashable (hash)

14import Data.IntMap.Strict (IntMap)

16import Data.IntMap.Strict (IntMap)

15import qualified Data.IntMap.Strict as I

17import qualified Data.IntMap.Strict as I

16−import qualified Data.List.NonEmpty as NE

17import Data.Semigroup

18import Data.Semigroup

18import Prelude -- Silence redundant import warnings

19import Prelude -- Silence redundant import warnings

19

20

20−import Network.Wai.Handler.Warp.Imports hiding ((<>), union, empty, insert)

21−

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

21----------------------------------------------------------------

23

22

24−type MMap v = IntMap (NonEmpty v)

23+-- | 'MultiMap' is used for cache of file descriptors.

24+-- Since multiple threads would open file descriptors for

25+-- the same file simultaneously, multiple entries must

26+-- be contained for the file.

27+-- Since hash values of file pathes are used as outer keys,

28+-- collison would happen for multiple file pathes.

29+-- Becase only positive entries are contained,

30+-- a bad guy cannot be cause the hash collision intentinally.

31+-- So, lists are good enough.

32+newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])

25

33

26----------------------------------------------------------------

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

27

35

28-- | O(1)

36-- | O(1)

29−isEmpty :: MMap v -> Bool

37+empty :: MultiMap v

30−isEmpty = I.null

38+empty = MultiMap $ I.empty

31

39

32-- | O(1)

40-- | O(1)

33−empty :: MMap v

41+isEmpty :: MultiMap v -> Bool

34−empty = I.empty

42+isEmpty (MultiMap mm) = I.null mm

35

43

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

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

37

45

38-- | O(1)

46-- | O(1)

39−singleton :: Int -> v -> MMap v

47+singleton :: FilePath -> v -> MultiMap v

48+singleton path v = MultiMap mm

49+ where

50+ !h = hash path

40−singleton k v = I.singleton k (v :| [])

51+ !mm = I.singleton h [(path,v)]

41

52

42----------------------------------------------------------------

53----------------------------------------------------------------

43

54

44−-- | O(log n)

55+-- | O(N)

45−search :: Int -> MMap v -> Maybe v

56+lookup :: FilePath -> MultiMap v -> Maybe v

46−search k m = case I.lookup k m of

57+lookup path (MultiMap mm) = case I.lookup h mm of

47 Nothing -> Nothing

58 Nothing -> Nothing

48− Just s -> Just $! NE.head s

59+ Just s -> Prelude.lookup path s

49−

60+ where

50−-- | O(log n)

61+ !h = hash path

51−searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v

52−searchWith k f m = case I.lookup k m of

53− Nothing -> Nothing

54− Just nxs -> find f $ NE.toList nxs

55

62

56----------------------------------------------------------------

63----------------------------------------------------------------

57

64

58-- | O(log n)

65-- | O(log n)

59−insert :: Int -> v -> MMap v -> MMap v

66+insert :: FilePath -> v -> MultiMap v -> MultiMap v

67+insert path v (MultiMap mm) = MultiMap mm'

68+ where

69+ !h = hash path

60−insert k v m = I.insertWith (<>) k (v :| []) m

70+ !mm' = I.insertWith (<>) h [(path,v)] mm

61

71

62----------------------------------------------------------------

72----------------------------------------------------------------

63

73

64-- | O(n)

74-- | O(n)

65−toList :: MMap v -> [v]

75+toList :: MultiMap v -> [(FilePath,v)]

66−toList m = concatMap f $ I.toAscList m

76+toList (MultiMap mm) = concatMap snd $ I.toAscList mm

67− where

68− f (_,s) = NE.toList s

69

77

70----------------------------------------------------------------

78----------------------------------------------------------------

71

79

72-- | O(n)

80-- | O(n)

73−pruneWith :: MMap v

81+pruneWith :: MultiMap v

74− -> (v -> IO Bool)

82+ -> ((FilePath,v) -> IO Bool)

75− -> IO (MMap v)

83+ -> IO (MultiMap v)

76−pruneWith m action = I.fromAscList <$> go (I.toDescList m) []

84+pruneWith (MultiMap mm) action = MultiMap <$> mm'

77 where

85 where

86+ !mm' = I.fromAscList <$> go (I.toDescList mm) []

78− go [] acc = return acc

87+ go [] !acc = return acc

79− go ((k,s):kss) acc = do

88+ go ((h,s):kss) !acc = do

80− mt <- prune action s

89+ rs <- prune action s

81− case mt of

90+ case rs of

82− Nothing -> go kss acc

91+ [] -> go kss acc

83− Just t -> go kss ((k,t) : acc)

92+ _ -> go kss ((h,rs) : acc)

84

93

85----------------------------------------------------------------

94----------------------------------------------------------------

86

95

87-- O(n + m) where N is the size of the second argument

96-- O(n + m) where N is the size of the second argument

88−merge :: MMap v -> MMap v -> MMap v

97+merge :: MultiMap v -> MultiMap v -> MultiMap v

98+merge (MultiMap m1) (MultiMap m2) = MultiMap mm

99+ where

89−merge m1 m2 = I.unionWith (<>) m1 m2

100+ !mm = I.unionWith (<>) m1 m2

90

101

91----------------------------------------------------------------

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

92

103

93−prune :: (a -> IO Bool) -> NonEmpty a -> IO (Maybe (NonEmpty a))

104+prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]

94−prune act nxs = NE.nonEmpty <$> go (NE.toList nxs)

105+prune action xs0 = go xs0

95 where

106 where

96 go [] = return []

107 go [] = return []

97 go (x:xs) = do

108 go (x:xs) = do

98− keep <- act x

109+ keep <- action x

99 rs <- go xs

110 rs <- go xs

100 return $ if keep then x:rs else rs

111 return $ if keep then x:rs else rs

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+26−28

@@ -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,29 +22,23 @@ 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

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

28import Network.Wai.Handler.Warp.Types

29import Network.Wai.Handler.Warp.Types

29import Network.Wai.Internal

30import Network.Wai.Internal

30import Prelude hiding (lines)

31import Prelude hiding (lines)

31import System.IO.Unsafe (unsafePerformIO)

32import System.IO.Unsafe (unsafePerformIO)

33+import qualified System.TimeManager as Timeout

32

34

33import Network.Wai.Handler.Warp.Conduit

35import Network.Wai.Handler.Warp.Conduit

34import Network.Wai.Handler.Warp.FileInfoCache

36import Network.Wai.Handler.Warp.FileInfoCache

35−import Network.Wai.Handler.Warp.HashMap (hashByteString)

36import Network.Wai.Handler.Warp.Header

37import Network.Wai.Handler.Warp.Header

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

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

38import Network.Wai.Handler.Warp.ReadInt

39import Network.Wai.Handler.Warp.ReadInt

39import Network.Wai.Handler.Warp.RequestHeader

40import Network.Wai.Handler.Warp.RequestHeader

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

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

41−

42−----------------------------------------------------------------

43−

44−-- FIXME come up with good values here

45−maxTotalHeaderLength :: Int

46−maxTotalHeaderLength = 50 * 1024

47

42

48----------------------------------------------------------------

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

49

44

@@ -52,21 +47,22 @@ maxTotalHeaderLength = 50 * 1024

52recvRequest :: Bool -- ^ first request on this connection?

47recvRequest :: Bool -- ^ first request on this connection?

53 -> Settings

48 -> Settings

54 -> Connection

49 -> Connection

55− -> InternalInfo1

50+ -> InternalInfo

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

61− ,IO ByteString

58+ ,IO ByteString) -- ^

62− ,InternalInfo) -- ^

63 -- 'Request' passed to 'Application',

59 -- 'Request' passed to 'Application',

64 -- how many bytes remain to be consumed, if known

60 -- how many bytes remain to be consumed, if known

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

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

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

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

67

63

68−recvRequest firstRequest settings conn ii1 addr src = do

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

69− hdrlines <- headerLines firstRequest src

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

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

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

71 let idxhdr = indexRequestHeader hdr

67 let idxhdr = indexRequestHeader hdr

72 expect = idxhdr ! fromEnum ReqExpect

68 expect = idxhdr ! fromEnum ReqExpect

@@ -74,11 +70,9 @@ recvRequest firstRequest settings conn ii1 addr src = do

74 te = idxhdr ! fromEnum ReqTransferEncoding

70 te = idxhdr ! fromEnum ReqTransferEncoding

75 handle100Continue = handleExpect conn httpversion expect

71 handle100Continue = handleExpect conn httpversion expect

76 rawPath = if settingsNoParsePath settings then unparsedPath else path

72 rawPath = if settingsNoParsePath settings then unparsedPath else path

77− h = hashByteString rawPath

78− ii = toInternalInfo ii1 h

79− th = threadHandle ii

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

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

81 $ Vault.insert getFileInfoKey (getFileInfo ii)

74 $ Vault.insert getFileInfoKey (getFileInfo ii)

75+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

82 Vault.empty

76 Vault.empty

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

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

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

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

@@ -93,7 +87,7 @@ recvRequest firstRequest settings conn ii1 addr src = do

93 , rawQueryString = query

87 , rawQueryString = query

94 , queryString = H.parseQuery query

88 , queryString = H.parseQuery query

95 , requestHeaders = hdr

89 , requestHeaders = hdr

96− , isSecure = False

90+ , isSecure = isTransportSecure transport

97 , remoteHost = addr

91 , remoteHost = addr

98 , requestBody = rbody'

92 , requestBody = rbody'

99 , vault = vaultValue

93 , vault = vaultValue

@@ -103,12 +97,12 @@ recvRequest firstRequest settings conn ii1 addr src = do

103 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

97 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

104 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

98 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

105 }

99 }

106− return (req, remainingRef, idxhdr, rbodyFlush, ii)

100+ return (req, remainingRef, idxhdr, rbodyFlush)

107

101

108----------------------------------------------------------------

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

109

103

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

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

111−headerLines firstRequest src = do

105+headerLines maxTotalHeaderLength firstRequest src = do

112 bs <- readSource src

106 bs <- readSource src

113 if S.null bs

107 if S.null bs

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

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

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

117 -- the Run module for more details.

111 -- the Run module for more details.

118 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

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

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

120

114

121data NoKeepAliveRequest = NoKeepAliveRequest

115data NoKeepAliveRequest = NoKeepAliveRequest

122 deriving (Show, Typeable)

116 deriving (Show, Typeable)

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

226close = throwIO IncompleteHeaders

220close = throwIO IncompleteHeaders

227-}

221-}

228

222

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

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

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

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

231 -- Too many bytes

225 -- Too many bytes

232 | len > maxTotalHeaderLength = throwIO OverLargeHeader

226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

233 | otherwise = push' mnl

227 | otherwise = push' mnl

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

255 push' Nothing = do

249 push' Nothing = do

256 bst <- readSource' src

250 bst <- readSource' src

257 when (S.null bst) $ throwIO IncompleteHeaders

251 when (S.null bst) $ throwIO IncompleteHeaders

258− push src status bst

252+ push maxTotalHeaderLength src status bst

259 where

253 where

260 len' = len + bsLen

254 len' = len + bsLen

261 prepend' = S.append bs

255 prepend' = S.append bs

262 status = THStatus len' lines prepend'

256 status = THStatus len' lines prepend'

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

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

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

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

265 where

259 where

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

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

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

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

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

280 in if start < bsLen then

274 in if start < bsLen then

281 -- more bytes in this chunk, push again

275 -- more bytes in this chunk, push again

282 let bs'' = SU.unsafeDrop start bs

276 let bs'' = SU.unsafeDrop start bs

283− in push src status bs''

277+ in push maxTotalHeaderLength src status bs''

284 else do

278 else do

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

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

286 bst <- readSource' src

280 bst <- readSource' src

287 when (S.null bs) $ throwIO IncompleteHeaders

281 when (S.null bs) $ throwIO IncompleteHeaders

288− push src status bst

282+ push maxTotalHeaderLength src status bst

289 where

283 where

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

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

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

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

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

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

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

304getFileInfoKey = unsafePerformIO Vault.newKey

298getFileInfoKey = unsafePerformIO Vault.newKey

305{-# 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+22−19

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

30import Network.Wai

31import Network.Wai.Internal

32import qualified Paths_warp

33+import qualified System.TimeManager as T

33

34

34import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

35import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

35import qualified Network.Wai.Handler.Warp.Date as D

36import qualified Network.Wai.Handler.Warp.Date as D

@@ -39,7 +40,6 @@ import Network.Wai.Handler.Warp.IO (toBufIOWith)

39import Network.Wai.Handler.Warp.Imports

40import Network.Wai.Handler.Warp.Imports

40import Network.Wai.Handler.Warp.ResponseHeader

41import Network.Wai.Handler.Warp.ResponseHeader

41import Network.Wai.Handler.Warp.Settings

42import Network.Wai.Handler.Warp.Settings

42−import qualified Network.Wai.Handler.Warp.Timeout as T

43import Network.Wai.Handler.Warp.Types

44

45-- $setup

@@ -101,12 +101,13 @@ import Network.Wai.Handler.Warp.Types

101sendResponse :: Settings

102 -> Connection

103 -> InternalInfo

104+ -> T.Handle

104 -> Request -- ^ HTTP request.

105 -> Request -- ^ HTTP request.

105 -> IndexedHeader -- ^ Indexed header of HTTP request.

106 -> IndexedHeader -- ^ Indexed header of HTTP request.

106 -> IO ByteString -- ^ source from client, for raw response

107 -> IO ByteString -- ^ source from client, for raw response

107 -> Response -- ^ HTTP response including status code and response header.

108 -> Response -- ^ HTTP response including status code and response header.

108 -> IO Bool -- ^ Returing True if the connection is persistent.

109 -> IO Bool -- ^ Returing True if the connection is persistent.

109−sendResponse settings conn ii req reqidxhdr src response = do

110+sendResponse settings conn ii th req reqidxhdr src response = do

110 hs <- addServerAndDate hs0

111 hs <- addServerAndDate hs0

111 if hasBody s then do

112 if hasBody s then do

112 -- The response to HEAD does not have body.

113 -- The response to HEAD does not have body.

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

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

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

116 --

117 --

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

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

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

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

119 case ms of

120 case ms of

120 Nothing -> return ()

121 Nothing -> return ()

121 Just realStatus -> logger req realStatus mlen

122 Just realStatus -> logger req realStatus mlen

122 T.tickle th

123 T.tickle th

123 return ret

124 return ret

124 else do

125 else do

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

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

126 logger req s Nothing

127 logger req s Nothing

127 T.tickle th

128 T.tickle th

128 return isPersist

129 return isPersist

@@ -133,7 +134,6 @@ sendResponse settings conn ii req reqidxhdr src response = do

133 s = responseStatus response

134 s = responseStatus response

134 hs0 = sanitizeHeaders $ responseHeaders response

135 hs0 = sanitizeHeaders $ responseHeaders response

135 rspidxhdr = indexResponseHeader hs0

136 rspidxhdr = indexResponseHeader hs0

136− th = threadHandle ii

137 getdate = getDate ii

138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

@@ -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+108−64

@@ -3,8 +3,10 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PackageImports #-}

5{-# LANGUAGE PatternGuards #-}

6+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TupleSections #-}

8{-# LANGUAGE TupleSections #-}

9+{-# LANGUAGE ViewPatterns #-}

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

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

9

11

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

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

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

15import Control.Exception as E

17import Control.Exception as E

16import qualified Data.ByteString as S

18import qualified Data.ByteString as S

17import Data.Char (chr)

19import Data.Char (chr)

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

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

19import Data.Streaming.Network (bindPortTCP)

21import Data.Streaming.Network (bindPortTCP)

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

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

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

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

24+import qualified Network.HTTP2 as H2

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

23import qualified Network.Socket.ByteString as Sock

29import qualified Network.Socket.ByteString as Sock

24import Network.Wai

30import Network.Wai

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

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

26import System.Environment (lookupEnv)

32import System.Environment (lookupEnv)

33+import qualified System.TimeManager as T

27import System.Timeout (timeout)

34import System.Timeout (timeout)

28

35

29import Network.Wai.Handler.Warp.Buffer

36import Network.Wai.Handler.Warp.Buffer

@@ -31,7 +38,8 @@ import Network.Wai.Handler.Warp.Counter

31import qualified Network.Wai.Handler.Warp.Date as D

38import qualified Network.Wai.Handler.Warp.Date as D

32import qualified Network.Wai.Handler.Warp.FdCache as F

39import qualified Network.Wai.Handler.Warp.FdCache as F

33import qualified Network.Wai.Handler.Warp.FileInfoCache as I

40import qualified Network.Wai.Handler.Warp.FileInfoCache as I

34−import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)

41+import Network.Wai.Handler.Warp.HTTP2 (http2)

42+import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)

35import Network.Wai.Handler.Warp.Header

43import Network.Wai.Handler.Warp.Header

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

44import Network.Wai.Handler.Warp.Imports hiding (readInt)

37import Network.Wai.Handler.Warp.ReadInt

45import Network.Wai.Handler.Warp.ReadInt

@@ -40,7 +48,6 @@ import Network.Wai.Handler.Warp.Request

40import Network.Wai.Handler.Warp.Response

48import Network.Wai.Handler.Warp.Response

41import Network.Wai.Handler.Warp.SendFile

49import Network.Wai.Handler.Warp.SendFile

42import Network.Wai.Handler.Warp.Settings

50import Network.Wai.Handler.Warp.Settings

43−import qualified Network.Wai.Handler.Warp.Timeout as T

44import Network.Wai.Handler.Warp.Types

51import Network.Wai.Handler.Warp.Types

45

52

46

53

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

51#endif

58#endif

52

59

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

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

54−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

55−socketConnection s = do

65+socketConnection _ s = do

66+#endif

56 bufferPool <- newBufferPool

67 bufferPool <- newBufferPool

57 writeBuf <- allocateBuffer bufferSize

68 writeBuf <- allocateBuffer bufferSize

58 let sendall = Sock.sendAll s

69 let sendall = Sock.sendAll s

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

59 return Connection {

71 return Connection {

60 connSendMany = Sock.sendMany s

72 connSendMany = Sock.sendMany s

61 , connSendAll = sendall

73 , connSendAll = sendall

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

63 , connClose = close s

85 , connClose = close s

86+#endif

64 , connFree = freeBuffer writeBuf

87 , connFree = freeBuffer writeBuf

65 , connRecv = receive s bufferPool

88 , connRecv = receive s bufferPool

66 , connRecvBuf = receiveBuf s

89 , connRecvBuf = receiveBuf s

67 , connWriteBuffer = writeBuf

90 , connWriteBuffer = writeBuf

68 , connBufferSize = bufferSize

91 , connBufferSize = bufferSize

92+ , connHTTP2 = isH2

69 }

93 }

70

94

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

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

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

127 setSocketCloseOnExec s

151 setSocketCloseOnExec s

128 -- NoDelay causes an error for AF_UNIX.

152 -- NoDelay causes an error for AF_UNIX.

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

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

130− conn <- socketConnection s

154+ conn <- socketConnection set s

131 return (conn, sa)

155 return (conn, sa)

132

156

133 closeListenSocket = close socket

157 closeListenSocket = close socket

@@ -168,15 +192,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),

168runSettingsConnectionMakerSecure set getConnMaker app = do

192runSettingsConnectionMakerSecure set getConnMaker app = do

169 settingsBeforeMainLoop set

193 settingsBeforeMainLoop set

170 counter <- newCounter

194 counter <- newCounter

171− withII0 $ acceptConnection set getConnMaker app counter

195+ withII $ acceptConnection set getConnMaker app counter

172 where

196 where

173− withII0 action =

197+ withII action =

174 withTimeoutManager $ \tm ->

198 withTimeoutManager $ \tm ->

175 D.withDateCache $ \dc ->

199 D.withDateCache $ \dc ->

176 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

177 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

178− let ii0 = InternalInfo0 tm dc fdc fic

202+ let ii = InternalInfo tm dc fdc fic

179− action ii0

203+ action ii

180

204

181 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

182 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

@@ -205,9 +229,9 @@ acceptConnection :: Settings

205 -> IO (IO (Connection, Transport), SockAddr)

229 -> IO (IO (Connection, Transport), SockAddr)

206 -> Application

230 -> Application

207 -> Counter

231 -> Counter

208− -> InternalInfo0

232+ -> InternalInfo

209 -> IO ()

233 -> IO ()

210−acceptConnection set getConnMaker app counter ii0 = do

234+acceptConnection set getConnMaker app counter ii = do

211 -- First mask all exceptions in acceptLoop. This is necessary to

235 -- First mask all exceptions in acceptLoop. This is necessary to

212 -- ensure that no async exception is throw between the call to

236 -- ensure that no async exception is throw between the call to

213 -- acceptNewConnection and the registering of connClose.

237 -- acceptNewConnection and the registering of connClose.

@@ -234,7 +258,7 @@ acceptConnection set getConnMaker app counter ii0 = do

234 case mx of

258 case mx of

235 Nothing -> return ()

259 Nothing -> return ()

236 Just (mkConn, addr) -> do

260 Just (mkConn, addr) -> do

237− fork set mkConn addr app counter ii0

261+ fork set mkConn addr app counter ii

238 acceptLoop

262 acceptLoop

239

263

240 acceptNewConnection = do

264 acceptNewConnection = do

@@ -257,15 +281,12 @@ fork :: Settings

257 -> SockAddr

281 -> SockAddr

258 -> Application

282 -> Application

259 -> Counter

283 -> Counter

260− -> InternalInfo0

284+ -> InternalInfo

261 -> IO ()

285 -> IO ()

262−fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

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

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

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

264 -- exceptions are thrown.

288 -- exceptions are thrown.

265− handle (settingsOnException set Nothing) .

289+ handle (settingsOnException set Nothing) $

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

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

268− withClosedRef $ \ref ->

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

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

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

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

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

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

@@ -276,24 +297,15 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

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

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

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

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

278 -- fact that async exceptions are still masked.

299 -- fact that async exceptions are still masked.

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

300+ bracket mkConn cleanUp (serve unmask)

280 where

301 where

281− withClosedRef inner = newIORef False >>= inner

282−

283− closeConn ref conn = do

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

285− unless isClosed $ connClose conn

286−

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

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

288

303

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

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

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

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

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

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

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

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

294− let ii1 = toInternalInfo1 ii0 th

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

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

296− -- the case of all exceptions, so it is safe to one again

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

297 -- allow async exceptions.

309 -- allow async exceptions.

298 unmask .

310 unmask .

299 -- Call the user-supplied code for connection open and

311 -- Call the user-supplied code for connection open and

@@ -301,23 +313,23 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

301 bracket (onOpen addr) (onClose addr) $ \goingon ->

313 bracket (onOpen addr) (onClose addr) $ \goingon ->

302 -- Actually serve this connection. bracket with closeConn

314 -- Actually serve this connection. bracket with closeConn

303 -- above ensures the connection is closed.

315 -- above ensures the connection is closed.

304− when goingon $ serveConnection conn ii1 addr transport set app

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

305 where

317 where

306− register = T.registerKillThread (timeoutManager0 ii0)

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

307− (closeConn ref conn)

308 cancel = T.cancel

319 cancel = T.cancel

309

320

310 onOpen adr = increase counter >> settingsOnOpen set adr

321 onOpen adr = increase counter >> settingsOnOpen set adr

311 onClose adr _ = decrease counter >> settingsOnClose set adr

322 onClose adr _ = decrease counter >> settingsOnClose set adr

312

323

313serveConnection :: Connection

324serveConnection :: Connection

314− -> InternalInfo1

325+ -> InternalInfo

326+ -> T.Handle

315 -> SockAddr

327 -> SockAddr

316 -> Transport

328 -> Transport

317 -> Settings

329 -> Settings

318 -> Application

330 -> Application

319 -> IO ()

331 -> IO ()

320−serveConnection conn ii1 origAddr transport settings app = do

332+serveConnection conn ii th origAddr transport settings app = do

321 -- fixme: Upgrading to HTTP/2 should be supported.

333 -- fixme: Upgrading to HTTP/2 should be supported.

322 (h2,bs) <- if isHTTP2 transport then

334 (h2,bs) <- if isHTTP2 transport then

323 return (True, "")

335 return (True, "")

@@ -330,22 +342,35 @@ serveConnection conn ii1 origAddr transport settings app = do

330 istatus <- newIORef False

342 istatus <- newIORef False

331 if settingsHTTP2Enabled settings && h2 then do

343 if settingsHTTP2Enabled settings && h2 then do

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

333 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

334 -- fixme: origAddr

354 -- fixme: origAddr

355+ checkTLS

356+ setConnHTTP2 conn True

335− http2 conn ii1 origAddr transport settings recvN app

357+ http2 conn transport ii origAddr settings recvN sendBS app

336 else do

358 else do

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

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

338 writeIORef istatus True

360 writeIORef istatus True

339 leftoverSource src bs

361 leftoverSource src bs

340 addr <- getProxyProtocolAddr src

362 addr <- getProxyProtocolAddr src

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

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

342− case fromException e of

364+ case () of

365+ ()

343− -- See comment below referencing

366+ -- See comment below referencing

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

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

345− Just NoKeepAliveRequest -> return ()

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

346− Nothing -> do

369+ -- No valid request

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

371+ | otherwise -> do

347− sendErrorResponse (dummyreq addr) istatus e

372+ _ <- sendErrorResponse (dummyreq addr) istatus e

348− throwIO e

373+ throwIO e

349

374

350 where

375 where

351 getProxyProtocolAddr src =

376 getProxyProtocolAddr src =

@@ -388,29 +413,25 @@ serveConnection conn ii1 origAddr transport settings app = do

388

413

389 decodeAscii = map (chr . fromEnum) . S.unpack

414 decodeAscii = map (chr . fromEnum) . S.unpack

390

415

391− th = threadHandle1 ii1

392−

393 shouldSendErrorResponse se

416 shouldSendErrorResponse se

394 | Just ConnectionClosedByPeer <- fromException se = False

417 | Just ConnectionClosedByPeer <- fromException se = False

395 | otherwise = True

418 | otherwise = True

396

419

397 sendErrorResponse req istatus e = do

420 sendErrorResponse req istatus e = do

398 status <- readIORef istatus

421 status <- readIORef istatus

399− when (shouldSendErrorResponse e && status) $ do

422+ if shouldSendErrorResponse e && status

400− let ii = toInternalInfo ii1 0 -- dummy

423+ then do

401− void $ sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)

424+ sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

425+ else return False

402

426

403 dummyreq addr = defaultRequest { remoteHost = addr }

427 dummyreq addr = defaultRequest { remoteHost = addr }

404

428

405 errorResponse e = settingsOnExceptionResponse settings e

429 errorResponse e = settingsOnExceptionResponse settings e

406

430

407 http1 firstRequest addr istatus src = do

431 http1 firstRequest addr istatus src = do

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

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

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

410− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii

433+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

411 `E.catch` \e -> do

434 `E.catch` \e -> do

412− -- Call the user-supplied exception handlers, passing the request.

413− sendErrorResponse req istatus e

414 settingsOnException settings (Just req) e

435 settingsOnException settings (Just req) e

415 -- Don't throw the error again to prevent calling settingsOnException twice.

436 -- Don't throw the error again to prevent calling settingsOnException twice.

416 return False

437 return False

@@ -425,7 +446,7 @@ serveConnection conn ii1 origAddr transport settings app = do

425 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

426 when keepAlive $ http1 False addr istatus src

447 when keepAlive $ http1 False addr istatus src

427

448

428− processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do

449+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

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

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

430 T.pause th

451 T.pause th

431

452

@@ -433,30 +454,38 @@ serveConnection conn ii1 origAddr transport settings app = do

433 -- creating the request, we need to make sure that we don't get

454 -- creating the request, we need to make sure that we don't get

434 -- an async exception before calling the ResponseSource.

455 -- an async exception before calling the ResponseSource.

435 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

436− _ <- app req $ \res -> do

457+ r <- E.try $ app req $ \res -> do

437 T.resume th

458 T.resume th

438 -- FIXME consider forcing evaluation of the res here to

459 -- FIXME consider forcing evaluation of the res here to

439 -- send more meaningful error messages to the user.

460 -- send more meaningful error messages to the user.

440 -- However, it may affect performance.

461 -- However, it may affect performance.

441 writeIORef istatus False

462 writeIORef istatus False

442− keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

463+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

443 writeIORef keepAliveRef keepAlive

464 writeIORef keepAliveRef keepAlive

444 return ResponseReceived

465 return ResponseReceived

466+ case r of

467+ Right ResponseReceived -> return ()

468+ Left e@(SomeException _)

469+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'

470+ | otherwise -> do

471+ keepAlive <- sendErrorResponse req istatus e

472+ settingsOnException settings (Just req) e

473+ writeIORef keepAliveRef keepAlive

474+

445 keepAlive <- readIORef keepAliveRef

475 keepAlive <- readIORef keepAliveRef

446

476

447 -- We just send a Response and it takes a time to

477 -- We just send a Response and it takes a time to

448 -- receive a Request again. If we immediately call recv,

478 -- receive a Request again. If we immediately call recv,

449− -- it is likely to fail and the IO manager works.

479+ -- it is likely to fail and cause the IO manager to do some work.

450− -- It is very costly. So, we yield to another Haskell

480+ -- It is very costly, so we yield to another Haskell

451 -- thread hoping that the next Request will arrive

481 -- thread hoping that the next Request will arrive

452 -- when this Haskell thread will be re-scheduled.

482 -- when this Haskell thread will be re-scheduled.

453 -- This improves performance at least when

483 -- This improves performance at least when

454 -- the number of cores is small.

484 -- the number of cores is small.

455 Conc.yield

485 Conc.yield

456

486

457− if not keepAlive then

487+ if keepAlive

458− return False

488+ then

459− else

460 -- If there is an unknown or large amount of data to still be read

489 -- If there is an unknown or large amount of data to still be read

461 -- from the request body, simple drop this connection instead of

490 -- from the request body, simple drop this connection instead of

462 -- reading it all in to satisfy a keep-alive request.

491 -- reading it all in to satisfy a keep-alive request.

@@ -482,6 +511,21 @@ serveConnection conn ii1 origAddr transport settings app = do

482 else

511 else

483 return False

512 return False

484 Nothing -> tryKeepAlive

513 Nothing -> tryKeepAlive

514+ else

515+ return False

516+

517+ checkTLS = case transport of

518+ TCP -> return () -- direct

519+ tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"

520+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

521+

522+-- connClose must not be called here since Run:fork calls it

523+goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()

524+goaway Connection{..} etype debugmsg = connSendAll bytestream

525+ where

526+ einfo = H2.encodeInfo id 0

527+ frame = H2.GoAwayFrame 0 etype debugmsg

528+ bytestream = H2.encodeFrame einfo frame

485

529

486flushEntireBody :: IO ByteString -> IO ()

530flushEntireBody :: IO ByteString -> IO ()

487flushEntireBody src =

531flushEntireBody src =

warp/Network/Wai/Handler/Warp/Settings.hs+54−10

@@ -8,20 +8,22 @@ import Control.Concurrent (forkIOWithUnmask)

8import Control.Exception

9import Data.ByteString.Builder (byteString)

10import qualified Data.ByteString.Char8 as C8

11+import Data.ByteString.Lazy (fromStrict)

11import Data.Streaming.Network (HostPreference)

12import Data.Streaming.Network (HostPreference)

12import qualified Data.Text as T

13import qualified Data.Text as T

13import qualified Data.Text.IO as TIO

14import qualified Data.Text.IO as TIO

14import Data.Version (showVersion)

15import Data.Version (showVersion)

15import GHC.IO.Exception (IOErrorType(..))

16import GHC.IO.Exception (IOErrorType(..))

16import qualified Network.HTTP.Types as H

17import qualified Network.HTTP.Types as H

18+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

17import Network.Socket (SockAddr)

19import Network.Socket (SockAddr)

18import Network.Wai

20import Network.Wai

19import qualified Paths_warp

21import qualified Paths_warp

20import System.IO (stderr)

22import System.IO (stderr)

21import System.IO.Error (ioeGetErrorType)

23import System.IO.Error (ioeGetErrorType)

24+import System.TimeManager

22

25

23import Network.Wai.Handler.Warp.Imports

26import Network.Wai.Handler.Warp.Imports

24−import Network.Wai.Handler.Warp.Timeout

25import Network.Wai.Handler.Warp.Types

27import Network.Wai.Handler.Warp.Types

26

28

27-- | Various Warp server settings. This is purposely kept as an abstract data

29-- | Various Warp server settings. This is purposely kept as an abstract data

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

74 --

76 --

75 -- Since 2.0.3

77 -- Since 2.0.3

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

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

77 , settingsServerName :: ByteString

86 , settingsServerName :: ByteString

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

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

79 --

88 --

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

85 , settingsProxyProtocol :: ProxyProtocol

94 , settingsProxyProtocol :: ProxyProtocol

86 -- ^ Specify usage of the PROXY protocol.

95 -- ^ Specify usage of the PROXY protocol.

87 --

96 --

88− -- Since 3.0.5.

97+ -- Since 3.0.5

89 , settingsSlowlorisSize :: Int

98 , settingsSlowlorisSize :: Int

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

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

91 --

100 --

92− -- Since 3.1.2.

101+ -- Since 3.1.2

93 , settingsHTTP2Enabled :: Bool

102 , settingsHTTP2Enabled :: Bool

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

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

95 --

104 --

96− -- Since 3.1.7.

105+ -- Since 3.1.7

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

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

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

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

99 --

108 --

100− -- Since 3.X.X.

109+ -- Since 3.1.10

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

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

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

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

103 --

112 --

104− -- Since 3.X.X.

113+ -- Since 3.2.7

105 , settingsGracefulShutdownTimeout :: Maybe Int

114 , settingsGracefulShutdownTimeout :: Maybe Int

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

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

107 -- a graceful shutdown of the web server.

116 -- a graceful shutdown of the web server.

108 --

117 --

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

110 }

135 }

111

136

112-- | Specify usage of the PROXY protocol.

137-- | Specify usage of the PROXY protocol.

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

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

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

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

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

145 , settingsGracefulShutdownTimeout = Nothing

170 , settingsGracefulShutdownTimeout = Nothing

171+ , settingsGracefulCloseTimeout1 = 0

172+ , settingsGracefulCloseTimeout2 = 2000

173+ , settingsMaxTotalHeaderLength = 50 * 1024

146 }

174 }

147

175

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

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

@@ -168,13 +196,29 @@ defaultOnException _ e =

168 when (defaultShouldDisplayException e)

196 when (defaultShouldDisplayException e)

169 $ TIO.hPutStrLn stderr $ T.pack $ show e

197 $ TIO.hPutStrLn stderr $ T.pack $ show e

170

198

199+-- | Sending 400 for bad requests.

171−-- | Sending 400 for bad requests. Sending 500 for internal server errors.

200+-- Sending 500 for internal server errors.

172−--

173-- Since: 3.1.0

201-- Since: 3.1.0

202+-- Sending 413 for too large payload.

203+-- Sending 431 for too large headers.

204+-- Since 3.2.27

174defaultOnExceptionResponse :: SomeException -> Response

205defaultOnExceptionResponse :: SomeException -> Response

175defaultOnExceptionResponse e

206defaultOnExceptionResponse e

207+ | Just (_ :: InvalidRequest) <-

176− | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request"

208+ fromException e = responseLBS H.badRequest400

209+ [(H.hContentType, "text/plain; charset=utf-8")]

210+ "Bad Request"

211+ | Just (ConnectionError (UnknownErrorCode 413) t) <-

212+ fromException e = responseLBS H.status413

213+ [(H.hContentType, "text/plain; charset=utf-8")]

214+ (fromStrict t)

215+ | Just (ConnectionError (UnknownErrorCode 431) t) <-

216+ fromException e = responseLBS H.status431

217+ [(H.hContentType, "text/plain; charset=utf-8")]

218+ (fromStrict t)

177− | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"

219+ | otherwise = responseLBS H.internalServerError500

220+ [(H.hContentType, "text/plain; charset=utf-8")]

221+ "Something went wrong"

178

222

179-- | Exception handler for the debugging purpose.

223-- | Exception handler for the debugging purpose.

180-- 500, text/plain, a showed exception.

224-- 500, text/plain, a showed exception.

warp/Network/Wai/Handler/Warp/Types.hs+25−30

@@ -8,14 +8,15 @@ 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)

14+import qualified System.TimeManager as T

13

15

14import qualified Network.Wai.Handler.Warp.Date as D

16import qualified Network.Wai.Handler.Warp.Date as D

15import qualified Network.Wai.Handler.Warp.FdCache as F

17import qualified Network.Wai.Handler.Warp.FdCache as F

16import qualified Network.Wai.Handler.Warp.FileInfoCache as I

18import qualified Network.Wai.Handler.Warp.FileInfoCache as I

17import Network.Wai.Handler.Warp.Imports

19import Network.Wai.Handler.Warp.Imports

18−import qualified Network.Wai.Handler.Warp.Timeout as T

19

20

20----------------------------------------------------------------

21----------------------------------------------------------------

21

22

@@ -52,6 +53,20 @@ instance Exception InvalidRequest

52

53

53----------------------------------------------------------------

54----------------------------------------------------------------

54

55

56+-- | Exception thrown if something goes wrong while in the midst of

57+-- sending a response, since the status code can't be altered at that

58+-- point.

59+--

60+-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe

61+-- or irrecoverable.

62+

63+newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException

64+ deriving (Show, Typeable)

65+

66+instance Exception ExceptionInsideResponseBody

67+

68+----------------------------------------------------------------

69+

55-- | Data type to abstract file identifiers.

70-- | Data type to abstract file identifiers.

56-- On Unix, a file descriptor would be specified to make use of

71-- On Unix, a file descriptor would be specified to make use of

57-- the file descriptor cache.

72-- the file descriptor cache.

@@ -108,46 +123,25 @@ data Connection = Connection {

108 , connWriteBuffer :: Buffer

123 , connWriteBuffer :: Buffer

109 -- | The size of the write buffer.

124 -- | The size of the write buffer.

110 , connBufferSize :: BufSize

125 , connBufferSize :: BufSize

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

127+ , connHTTP2 :: IORef Bool

111 }

128 }

112

129

113−----------------------------------------------------------------

130+getConnHTTP2 :: Connection -> IO Bool

114−

131+getConnHTTP2 conn = readIORef (connHTTP2 conn)

115−type Hash = Int

116−

117−

118−data InternalInfo0 =

119− InternalInfo0 T.Manager

120− (IO D.GMTDate)

121− (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

122− (Hash -> FilePath -> IO I.FileInfo)

123−

124−timeoutManager0 :: InternalInfo0 -> T.Manager

125−timeoutManager0 (InternalInfo0 tm _ _ _) = tm

126

132

127−data InternalInfo1 =

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

128− InternalInfo1 T.Handle

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

129− T.Manager

130− (IO D.GMTDate)

131− (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

132− (Hash -> FilePath -> IO I.FileInfo)

133

135

134−toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1

136+----------------------------------------------------------------

135−toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e

136−

137−threadHandle1 :: InternalInfo1 -> T.Handle

138−threadHandle1 (InternalInfo1 th _ _ _ _) = th

139

137

140data InternalInfo = InternalInfo {

138data InternalInfo = InternalInfo {

141− threadHandle :: T.Handle

142− , timeoutManager :: T.Manager

139+ timeoutManager :: T.Manager

143 , getDate :: IO D.GMTDate

140 , getDate :: IO D.GMTDate

144 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

141 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

145 , getFileInfo :: FilePath -> IO I.FileInfo

142 , getFileInfo :: FilePath -> IO I.FileInfo

146 }

143 }

147

144

148−toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo

149−toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h)

150−

151----------------------------------------------------------------

145----------------------------------------------------------------

152

146

153-- | Type for input streaming.

147-- | Type for input streaming.

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

186 , tlsMinorVersion :: Int

180 , tlsMinorVersion :: Int

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

188 , tlsChiperID :: Word16

182 , tlsChiperID :: Word16

183+ , tlsClientCertificate :: Maybe CertificateChain

189 } -- ^ Encrypted channel: TLS or SSL

184 } -- ^ Encrypted channel: TLS or SSL

190

185

191isTransportSecure :: Transport -> Bool

186isTransportSecure :: Transport -> Bool

warp/test/FdCacheSpec.hs+1−1

@@ -17,7 +17,7 @@ spec = describe "withFdCache" $ do

17 it "clean up Fd" $ do

18 ref <- newIORef (Fd (-1))

19 withFdCache 30000000 $ \getFd -> do

20− (Just fd,_) <- getFd 0 "warp.cabal"

20+ (Just fd,_) <- getFd "warp.cabal"

21 writeIORef ref fd

22 nfd <- readIORef ref

23 fdRead nfd 1 `shouldThrow` anyIOException

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/ResponseHeaderSpec.hs+2−35

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

7import Network.Wai.Handler.Warp.ResponseHeader

8import Network.Wai.Handler.Warp.Response

9import Network.Wai.Handler.Warp.Header

10−import Network.Wai.Handler.Warp.HTTP2.HPACK

11−import Network.HPACK

12−import Network.HPACK.Token

13import Test.Hspec

10import Test.Hspec

14

11

15main :: IO ()

12main :: IO ()

@@ -37,45 +34,15 @@ spec = do

37 let hdrs = [("Server","MyServer")]

34 let hdrs = [("Server","MyServer")]

38 rspidxhdr = indexResponseHeader hdrs

35 rspidxhdr = indexResponseHeader hdrs

39 addServer "" rspidxhdr hdrs `shouldBe` []

36 addServer "" rspidxhdr hdrs `shouldBe` []

40− describe "addHeader" $ do

41− it "adds Server if not exist" $ do

42− let v = "MyServer"

43− hdrs = []

44− hdrs1 = [("Server",v)]

45− (thl, vt) <- toHeaderTable hdrs

46− (thl1, _) <- toHeaderTable hdrs1

47− addHeader tokenServer v vt thl `shouldBe` thl1

48− it "does not add Server if exists" $ do

49− let v = "MyServer2"

50− hdrs = [("Server","MyServer")]

51− (thl, vt) <- toHeaderTable hdrs

52− addHeader tokenServer v vt thl `shouldBe` thl

53− it "does not add Server if empty" $ do

54− let v = ""

55− hdrs = []

56− (thl, vt) <- toHeaderTable hdrs

57− addHeader tokenServer v vt thl `shouldBe` thl

58− it "deletes Server" $ do

59− let v = ""

60− hdrs = [("Server","MyServer")]

61− hdrs1 = []

62− (thl, vt) <- toHeaderTable hdrs

63− (thl1, _) <- toHeaderTable hdrs1

64− addHeader tokenServer v vt thl `shouldBe` thl1

65− it "keeps Server" $ do

66− let v = ""

67− hdrs = [("Server","MyServer"),("Content-Type","Text/HTML")]

68− (thl, vt) <- toHeaderTable hdrs

69− addHeader tokenContentType v vt thl `shouldBe` thl

70

37

71headers :: H.ResponseHeaders

38headers :: H.ResponseHeaders

72headers = [

39headers = [

73 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

40 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

74− , ("Content-Lenght", "151")

41+ , ("Content-Length", "151")

75 , ("Server", "Mighttpd/2.5.8")

42 , ("Server", "Mighttpd/2.5.8")

76 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

43 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

77 , ("Content-Type", "text/html")

44 , ("Content-Type", "text/html")

78 ]

45 ]

79

46

80composedHeader :: ByteString

47composedHeader :: ByteString

81−composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

48+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

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+56−62

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4

3

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

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

6

5

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

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

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

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

@@ -22,6 +21,7 @@ import Network.HTTP.Types

22import Network.Socket

21import Network.Socket

23import Network.Socket.ByteString (sendAll)

22import Network.Socket.ByteString (sendAll)

24import Network.Wai hiding (responseHeaders)

23import Network.Wai hiding (responseHeaders)

24+import Network.Wai.Internal (getRequestBodyChunk)

25import Network.Wai.Handler.Warp

26import System.IO.Unsafe (unsafePerformIO)

27import System.Timeout (timeout)

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

@@ -85,7 +92,7 @@ err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

85

92

86readBody :: CounterApplication

93readBody :: CounterApplication

87readBody icount req f = do

94readBody icount req f = do

88− body <- consumeBody $ requestBody req

95+ body <- consumeBody $ getRequestBodyChunk req

89 case () of

96 case () of

90 ()

97 ()

91 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

98 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

@@ -106,8 +113,8 @@ ignoreBody icount req f = do

106

113

107doubleConnect :: CounterApplication

114doubleConnect :: CounterApplication

108doubleConnect icount req f = do

115doubleConnect icount req f = do

109− _ <- consumeBody $ requestBody req

116+ _ <- consumeBody $ getRequestBodyChunk req

110− _ <- consumeBody $ requestBody req

117+ _ <- consumeBody $ getRequestBodyChunk req

111 incr icount

118 incr icount

112 f $ responseLBS status200 [] "double connect"

119 f $ responseLBS status200 [] "double connect"

113

120

@@ -136,7 +143,13 @@ withApp settings app f = do

136 bracket

143 bracket

137 (forkIO $ runSettings settings' app `onException` putMVar baton ())

144 (forkIO $ runSettings settings' app `onException` putMVar baton ())

138 killThread

145 killThread

146+ (const $ do

139− (const $ takeMVar baton >> f port)

147+ takeMVar baton

148+ -- use timeout to make sure we don't take too long

149+ mres <- timeout (60 * 1000 * 1000) (f port)

150+ case mres of

151+ Nothing -> error "Timeout triggered, too slow!"

152+ Just a -> pure a)

140

153

141runTest :: Int -- ^ expected number of requests

154runTest :: Int -- ^ expected number of requests

142 -> CounterApplication

155 -> CounterApplication

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

144 -> IO ()

157 -> IO ()

145runTest expected app chunks = do

158runTest expected app chunks = do

146 ref <- I.newIORef (Right 0)

159 ref <- I.newIORef (Right 0)

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

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

148− ms <- connectTo port

149 forM_ chunks $ \chunk -> msWrite ms chunk

161 forM_ chunks $ \chunk -> msWrite ms chunk

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

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

151 res <- I.readIORef ref

163 res <- I.readIORef ref

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

162runTerminateTest expected input = do

174runTerminateTest expected input = do

163 ref <- I.newIORef Nothing

175 ref <- I.newIORef Nothing

164 let onExc _ = I.writeIORef ref . Just

176 let onExc _ = I.writeIORef ref . Just

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

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

166− handle <- connectTo port

167− msWrite handle input

178+ msWrite ms input

168− msClose handle

179+ msClose ms -- explicitly

169 threadDelay 1000

180 threadDelay 1000

170 res <- I.readIORef ref

181 res <- I.readIORef ref

171 show res `shouldBe` show (Just expected)

182 show res `shouldBe` show (Just expected)

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

236 let app req f = do

247 let app req f = do

237 liftIO $ I.writeIORef iheaders $ requestHeaders req

248 liftIO $ I.writeIORef iheaders $ requestHeaders req

238 f $ responseLBS status200 [] ""

249 f $ responseLBS status200 [] ""

239− withApp defaultSettings app $ \port -> do

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

240− handle <- connectTo port

241 let input = S.concat

251 let input = S.concat

242 [ "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"

243 ]

253 ]

244− msWrite handle input

254+ msWrite ms input

245− msClose handle

246 threadDelay 1000

255 threadDelay 1000

247 headers <- I.readIORef iheaders

256 headers <- I.readIORef iheaders

248 headers `shouldBe`

257 headers `shouldBe`

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

253 let app req f = do

262 let app req f = do

254 liftIO $ I.writeIORef iheaders $ requestHeaders req

263 liftIO $ I.writeIORef iheaders $ requestHeaders req

255 f $ responseLBS status200 [] ""

264 f $ responseLBS status200 [] ""

256− withApp defaultSettings app $ \port -> do

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

257− handle <- connectTo port

258 let input = S.concat

266 let input = S.concat

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

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

260 ]

268 ]

261− msWrite handle input

269+ msWrite ms input

262− msClose handle

263 threadDelay 1000

270 threadDelay 1000

264 headers <- I.readIORef iheaders

271 headers <- I.readIORef iheaders

265 headers `shouldBe`

272 headers `shouldBe`

@@ -271,20 +278,18 @@ spec = do

271 countVar <- newTVarIO (0 :: Int)

278 countVar <- newTVarIO (0 :: Int)

272 ifront <- I.newIORef id

279 ifront <- I.newIORef id

273 let app req f = do

280 let app req f = do

274− bss <- consumeBody $ requestBody req

281+ bss <- consumeBody $ getRequestBodyChunk req

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

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

276 atomically $ modifyTVar countVar (+ 1)

283 atomically $ modifyTVar countVar (+ 1)

277 f $ responseLBS status200 [] ""

284 f $ responseLBS status200 [] ""

278− withApp defaultSettings app $ \port -> do

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

279− handle <- connectTo port

280 let input = S.concat

286 let input = S.concat

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

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

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

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

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

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

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

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

285 ]

291 ]

286− msWrite handle input

292+ msWrite ms input

287− msClose handle

288 atomically $ do

293 atomically $ do

289 count <- readTVar countVar

294 count <- readTVar countVar

290 check $ count == 2

295 check $ count == 2

@@ -297,18 +302,16 @@ spec = do

297 ifront <- I.newIORef id

302 ifront <- I.newIORef id

298 countVar <- newTVarIO (0 :: Int)

303 countVar <- newTVarIO (0 :: Int)

299 let app req f = do

304 let app req f = do

300− bss <- consumeBody $ requestBody req

305+ bss <- consumeBody $ getRequestBodyChunk req

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

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

302 atomically $ modifyTVar countVar (+ 1)

307 atomically $ modifyTVar countVar (+ 1)

303 f $ responseLBS status200 [] ""

308 f $ responseLBS status200 [] ""

304− withApp defaultSettings app $ \port -> do

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

305− handle <- connectTo port

306 let input = concat $ replicate 2 $

310 let input = concat $ replicate 2 $

307 ["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"] ++

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

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

309 ["0\r\n\r\n"]

313 ["0\r\n\r\n"]

310− mapM_ (msWrite handle) input

314+ mapM_ (msWrite ms) input

311− msClose handle

312 atomically $ do

315 atomically $ do

313 count <- readTVar countVar

316 count <- readTVar countVar

314 check $ count == 2

317 check $ count == 2

@@ -316,25 +319,22 @@ spec = do

316 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

319 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

317-- For some reason, the following test on Windows causes the socket

320-- For some reason, the following test on Windows causes the socket

318-- to be killed prematurely. Worth investigating in the future if possible.

321-- to be killed prematurely. Worth investigating in the future if possible.

319−#if !WINDOWS

320 it "in chunks" $ do

322 it "in chunks" $ do

321 ifront <- I.newIORef id

323 ifront <- I.newIORef id

322 countVar <- newTVarIO (0 :: Int)

324 countVar <- newTVarIO (0 :: Int)

323 let app req f = do

325 let app req f = do

324− bss <- consumeBody $ requestBody req

326+ bss <- consumeBody $ getRequestBodyChunk req

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

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

326 atomically $ modifyTVar countVar (+ 1)

328 atomically $ modifyTVar countVar (+ 1)

327 f $ responseLBS status200 [] ""

329 f $ responseLBS status200 [] ""

328− withApp defaultSettings app $ \port -> do

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

329− handle <- connectTo port

330 let input = S.concat

331 let input = S.concat

331 [ "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"

332 , "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"

333 , "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"

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

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

335 ]

336 ]

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

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

337− msClose handle

338 atomically $ do

339 count <- readTVar countVar

340 check $ count == 2

@@ -343,11 +343,10 @@ spec = do

343 [ "Hello World\nBye"

344 , "Hello World"

345 ]

346−#endif

347 it "timeout in request body" $ do

346 it "timeout in request body" $ do

348 ifront <- I.newIORef id

347 ifront <- I.newIORef id

349 let app req f = do

348 let app req f = do

350− bss <- (consumeBody $ requestBody req) `onException`

349+ bss <- (consumeBody $ getRequestBodyChunk req) `onException`

351 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

350 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

352 liftIO $ threadDelay 4000000 `E.catch` \e -> do

351 liftIO $ threadDelay 4000000 `E.catch` \e -> do

353 I.atomicModifyIORef ifront (\front ->

352 I.atomicModifyIORef ifront (\front ->

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

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

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

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

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

358 f $ responseLBS status200 [] ""

357 f $ responseLBS status200 [] ""

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

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

360 let bs1 = S.replicate 2048 88

359 let bs1 = S.replicate 2048 88

361 bs2 = "This is short"

360 bs2 = "This is short"

362 bs = S.append bs1 bs2

361 bs = S.append bs1 bs2

363− handle <- connectTo port

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

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

365− msWrite handle "content-length: "

363+ msWrite ms "content-length: "

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

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

367− msWrite handle "\r\n\r\n"

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

368 threadDelay 100000

366 threadDelay 100000

369− msWrite handle bs1

367+ msWrite ms bs1

370 threadDelay 100000

368 threadDelay 100000

371− msWrite handle bs2

369+ msWrite ms bs2

372− msClose handle

373 threadDelay 5000000

370 threadDelay 5000000

374 front <- I.readIORef ifront

371 front <- I.readIORef ifront

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

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

@@ -385,13 +382,11 @@ spec = do

385 loop

382 loop

386 loop

383 loop

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

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

388− withApp defaultSettings app $ \port -> do

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

389− ms <- connectTo port

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

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

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

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

392 msWrite ms "67890"

388 msWrite ms "67890"

393 timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")

389 timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")

394−

395 it "only one date and server header" $ do

390 it "only one date and server header" $ do

396 let app _ f = f $ responseLBS status200

391 let app _ f = f $ responseLBS status200

397 [ ("server", "server")

392 [ ("server", "server")

@@ -408,22 +403,21 @@ spec = do

408 it "streaming echo #249" $ do

403 it "streaming echo #249" $ do

409 countVar <- newTVarIO (0 :: Int)

404 countVar <- newTVarIO (0 :: Int)

410 let app req f = f $ responseStream status200 [] $ \write _ -> do

405 let app req f = f $ responseStream status200 [] $ \write _ -> do

411− let loop = do

406+ let loop = do

412− bs <- requestBody req

407+ bs <- getRequestBodyChunk req

413 unless (S.null bs) $ do

408 unless (S.null bs) $ do

414 write $ byteString bs

409 write $ byteString bs

415 atomically $ modifyTVar countVar (+ 1)

410 atomically $ modifyTVar countVar (+ 1)

416 loop

411 loop

417− loop

412+ loop

418− withApp defaultSettings app $ \port -> do

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

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

420− 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"

421 threadDelay 10000

415 threadDelay 10000

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

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

423 atomically $ do

417 atomically $ do

424 count <- readTVar countVar

418 count <- readTVar countVar

425 check $ count >= 1

419 check $ count >= 1

426− bs <- safeRecv sock 4096

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

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

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

428

422

429 it "streaming response with length" $ do

423 it "streaming response with length" $ do

warp/warp.cabal+52−44

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

1Name: warp

2−Version: 3.2.26

2+Version: 3.3.9

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

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

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

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >=1.8

11+Cabal-Version: >= 1.10

12Stability: Stable

13description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.

14 For HTTP\/2, Warp supports direct and ALPN (in TLS)

@@ -42,19 +42,21 @@ Library

42 , case-insensitive >= 0.2

43 , containers

44 , ghc-prim

45+ , hashable

46+ , http-date

45− , http-types >= 0.9.1

47+ , http-types >= 0.12

48+ , http2 >= 2.0 && < 2.1

46 , iproute >= 1.3.1

49 , iproute >= 1.3.1

47− , http2 >= 1.6 && < 1.7

48 , simple-sendfile >= 0.2.7 && < 0.3

50 , simple-sendfile >= 0.2.7 && < 0.3

49− , unix-compat >= 0.2

51+ , stm >= 2.3

50− , wai >= 3.2 && < 3.3

51− , text

52 , streaming-commons >= 0.1.10

53+ , text

54+ , time-manager

55+ , unix-compat >= 0.2

53 , vault >= 0.3

56 , vault >= 0.3

54− , stm >= 2.3

57+ , wai >= 3.2 && < 3.3

55 , word8

58 , word8

56− , hashable

59+ , x509

57− , http-date

58 if impl(ghc < 8)

60 if impl(ghc < 8)

59 Build-Depends: semigroups

61 Build-Depends: semigroups

60 if flag(network-bytestring)

62 if flag(network-bytestring)

@@ -73,15 +75,11 @@ Library

73 Network.Wai.Handler.Warp.FileInfoCache

75 Network.Wai.Handler.Warp.FileInfoCache

74 Network.Wai.Handler.Warp.HashMap

76 Network.Wai.Handler.Warp.HashMap

75 Network.Wai.Handler.Warp.HTTP2

77 Network.Wai.Handler.Warp.HTTP2

76− Network.Wai.Handler.Warp.HTTP2.EncodeFrame

77 Network.Wai.Handler.Warp.HTTP2.File

78 Network.Wai.Handler.Warp.HTTP2.File

78− Network.Wai.Handler.Warp.HTTP2.HPACK

79+ Network.Wai.Handler.Warp.HTTP2.PushPromise

79− Network.Wai.Handler.Warp.HTTP2.Manager

80− Network.Wai.Handler.Warp.HTTP2.Receiver

81 Network.Wai.Handler.Warp.HTTP2.Request

80 Network.Wai.Handler.Warp.HTTP2.Request

82− Network.Wai.Handler.Warp.HTTP2.Sender

81+ Network.Wai.Handler.Warp.HTTP2.Response

83 Network.Wai.Handler.Warp.HTTP2.Types

82 Network.Wai.Handler.Warp.HTTP2.Types

84− Network.Wai.Handler.Warp.HTTP2.Worker

85 Network.Wai.Handler.Warp.Header

83 Network.Wai.Handler.Warp.Header

86 Network.Wai.Handler.Warp.IO

84 Network.Wai.Handler.Warp.IO

87 Network.Wai.Handler.Warp.Imports

85 Network.Wai.Handler.Warp.Imports

@@ -95,7 +93,6 @@ Library

95 Network.Wai.Handler.Warp.Run

93 Network.Wai.Handler.Warp.Run

96 Network.Wai.Handler.Warp.SendFile

94 Network.Wai.Handler.Warp.SendFile

97 Network.Wai.Handler.Warp.Settings

95 Network.Wai.Handler.Warp.Settings

98− Network.Wai.Handler.Warp.Timeout

99 Network.Wai.Handler.Warp.Types

96 Network.Wai.Handler.Warp.Types

100 Network.Wai.Handler.Warp.Windows

97 Network.Wai.Handler.Warp.Windows

101 Network.Wai.Handler.Warp.WithApplication

98 Network.Wai.Handler.Warp.WithApplication

@@ -112,8 +109,12 @@ Library

112 else

109 else

113 Build-Depends: unix

110 Build-Depends: unix

114 Other-modules: Network.Wai.Handler.Warp.MultiMap

111 Other-modules: Network.Wai.Handler.Warp.MultiMap

112+ if impl(ghc >= 8)

113+ Default-Extensions: Strict StrictData

114+ Default-Language: Haskell2010

115

116Test-Suite doctest

117+ buildable: False

117 Type: exitcode-stdio-1.0

118 Type: exitcode-stdio-1.0

118 HS-Source-Dirs: test

119 HS-Source-Dirs: test

119 Ghc-Options: -threaded -Wall

120 Ghc-Options: -threaded -Wall

@@ -122,6 +123,9 @@ Test-Suite doctest

122 , doctest >= 0.10.1

123 , doctest >= 0.10.1

123 if os(windows)

124 if os(windows)

124 Buildable: False

125 Buildable: False

126+ if impl(ghc >= 8)

127+ Default-Extensions: Strict StrictData

128+ Default-Language: Haskell2010

125

129

126Test-Suite spec

130Test-Suite spec

127 Main-Is: Spec.hs

131 Main-Is: Spec.hs

@@ -147,15 +151,11 @@ Test-Suite spec

147 Network.Wai.Handler.Warp.File

151 Network.Wai.Handler.Warp.File

148 Network.Wai.Handler.Warp.FileInfoCache

152 Network.Wai.Handler.Warp.FileInfoCache

149 Network.Wai.Handler.Warp.HTTP2

153 Network.Wai.Handler.Warp.HTTP2

150− Network.Wai.Handler.Warp.HTTP2.EncodeFrame

151 Network.Wai.Handler.Warp.HTTP2.File

154 Network.Wai.Handler.Warp.HTTP2.File

152− Network.Wai.Handler.Warp.HTTP2.HPACK

155+ Network.Wai.Handler.Warp.HTTP2.PushPromise

153− Network.Wai.Handler.Warp.HTTP2.Manager

154− Network.Wai.Handler.Warp.HTTP2.Receiver

155 Network.Wai.Handler.Warp.HTTP2.Request

156 Network.Wai.Handler.Warp.HTTP2.Request

156− Network.Wai.Handler.Warp.HTTP2.Sender

157+ Network.Wai.Handler.Warp.HTTP2.Response

157 Network.Wai.Handler.Warp.HTTP2.Types

158 Network.Wai.Handler.Warp.HTTP2.Types

158− Network.Wai.Handler.Warp.HTTP2.Worker

159 Network.Wai.Handler.Warp.HashMap

160 Network.Wai.Handler.Warp.Header

161 Network.Wai.Handler.Warp.IO

@@ -171,7 +171,6 @@ Test-Suite spec

171 Network.Wai.Handler.Warp.Run

172 Network.Wai.Handler.Warp.SendFile

173 Network.Wai.Handler.Warp.Settings

174− Network.Wai.Handler.Warp.Timeout

175 Network.Wai.Handler.Warp.Types

174 Network.Wai.Handler.Warp.Types

176 Network.Wai.Handler.Warp.Windows

175 Network.Wai.Handler.Warp.Windows

177 Network.Wai.Handler.Warp.WithApplication

176 Network.Wai.Handler.Warp.WithApplication

@@ -180,42 +179,44 @@ Test-Suite spec

180 Hs-Source-Dirs: test, .

179 Hs-Source-Dirs: test, .

181 Type: exitcode-stdio-1.0

180 Type: exitcode-stdio-1.0

182

181

183− Ghc-Options: -Wall

182+ Ghc-Options: -Wall -threaded

184 Build-Depends: base >= 4.8 && < 5

183 Build-Depends: base >= 4.8 && < 5

184+ , HUnit

185+ , QuickCheck

185 , array

186 , array

187+ , async

186 , auto-update

188 , auto-update

187 , bsb-http-chunked < 0.1

189 , bsb-http-chunked < 0.1

188 , bytestring >= 0.9.1.4

190 , bytestring >= 0.9.1.4

189 , case-insensitive >= 0.2

191 , case-insensitive >= 0.2

192+ , containers

193+ , directory

190 , ghc-prim

194 , ghc-prim

195+ , hashable

196+ , hspec >= 1.3

191 , http-client

197 , http-client

198+ , http-date

192− , http-types >= 0.8.5

199+ , http-types >= 0.12

200+ , http2 >= 2.0 && < 2.1

193 , iproute >= 1.3.1

201 , iproute >= 1.3.1

194 , lifted-base >= 0.1

202 , lifted-base >= 0.1

195− , simple-sendfile >= 0.2.4 && < 0.3

196− , transformers >= 0.2.2

197− , unix-compat >= 0.2

198− , wai >= 3.2 && < 3.3

199 , network

203 , network

200− , HUnit

204+ , process

201− , QuickCheck

205+ , simple-sendfile >= 0.2.4 && < 0.3

202− , hspec >= 1.3

206+ , stm >= 2.3

203− , time

204− , text

205 , streaming-commons >= 0.1.10

207 , streaming-commons >= 0.1.10

206− , async

208+ , text

209+ , time

210+ , time-manager

211+ , unix-compat >= 0.2

207 , vault

212 , vault

208− , stm >= 2.3

213+ , wai >= 3.2 && < 3.3

209− , directory

210− , process

211− , containers

212− , http2 >= 1.6 && < 1.7

213 , word8

214 , word8

214− , hashable

215+ , x509

215− , http-date

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

217 if impl(ghc < 8)

218 Build-Depends: semigroups

219+ , transformers

219

220

220 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

221 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

221 Cpp-Options: -DSENDFILEFD

222 Cpp-Options: -DSENDFILEFD

@@ -223,6 +224,9 @@ Test-Suite spec

223 if os(windows)

224 if os(windows)

224 Cpp-Options: -DWINDOWS

225 Cpp-Options: -DWINDOWS

225 Build-Depends: time

226 Build-Depends: time

227+ if impl(ghc >= 8)

228+ Default-Extensions: Strict StrictData

229+ Default-Language: Haskell2010

226

230

227Benchmark parser

231Benchmark parser

228 Type: exitcode-stdio-1.0

232 Type: exitcode-stdio-1.0

@@ -233,7 +237,6 @@ Benchmark parser

233 Network.Wai.Handler.Warp.HashMap

237 Network.Wai.Handler.Warp.HashMap

234 Network.Wai.Handler.Warp.Imports

238 Network.Wai.Handler.Warp.Imports

235 Network.Wai.Handler.Warp.MultiMap

239 Network.Wai.Handler.Warp.MultiMap

236− Network.Wai.Handler.Warp.Timeout

237 Network.Wai.Handler.Warp.Types

240 Network.Wai.Handler.Warp.Types

238 HS-Source-Dirs: bench .

241 HS-Source-Dirs: bench .

239 Build-Depends: base >= 4.8 && < 5

242 Build-Depends: base >= 4.8 && < 5

@@ -246,7 +249,9 @@ Benchmark parser

246 , http-types

249 , http-types

247 , network

250 , network

248 , network

251 , network

252+ , time-manager

249 , unix-compat

253 , unix-compat

254+ , x509

250 if impl(ghc < 8)

255 if impl(ghc < 8)

251 Build-Depends: semigroups

256 Build-Depends: semigroups

252

257

@@ -256,6 +261,9 @@ Benchmark parser

256 if os(windows)

261 if os(windows)

257 Cpp-Options: -DWINDOWS

262 Cpp-Options: -DWINDOWS

258 Build-Depends: time

263 Build-Depends: time

264+ if impl(ghc >= 8)

265+ Default-Extensions: Strict StrictData

266+ Default-Language: Haskell2010

259

267

260Source-Repository head

268Source-Repository head

261 Type: git

269 Type: git