master..455b48d · typeable/wai

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

since splitsnapshots

unifiedsplit

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

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8+ stack-def:

9+ BUILD: stack

10+ stack-lts-6:

11+ BUILD: stack

12+ STACK_YAML: stack-lts-6.yaml

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

14+ stack-lts-9:

15+ BUILD: stack

16+ STACK_YAML: stack-lts-9.yaml

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

8 stack-lts-11:

18 stack-lts-11:

9 BUILD: stack

19 BUILD: stack

10 STACK_YAML: stack-lts-11.yaml

20 STACK_YAML: stack-lts-11.yaml

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

13 BUILD: stack

23 BUILD: stack

14 STACK_YAML: stack-lts-12.yaml

24 STACK_YAML: stack-lts-12.yaml

15 ARGS: "--resolver lts-12"

25 ARGS: "--resolver lts-12"

16− stack-lts-14:

26+ stack-lts-13:

17 BUILD: stack

27 BUILD: stack

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

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

19− stack-nightly:

29+ cabal-7.10.3:

20− BUILD: stack

30+ BUILD: cabal

21− STACK_YAML: stack-nightly.yaml

31+ GHCVER: 7.10.3

22− ARGS: "--resolver nightly"

32+ CABALVER: 1.22

33+ cabal-8.0.2:

34+ BUILD: cabal

35+ GHCVER: 8.0.2

36+ CABALVER: 1.24

23 cabal-8.2.2:

37 cabal-8.2.2:

24 BUILD: cabal

38 BUILD: cabal

25 GHCVER: 8.4.4

39 GHCVER: 8.4.4

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

28 BUILD: cabal

42 BUILD: cabal

29 GHCVER: 8.4.4

43 GHCVER: 8.4.4

30 CABALVER: 2.2

44 CABALVER: 2.2

31− cabal-8.6.5:

45+ cabal-8.6.4:

32 BUILD: cabal

46 BUILD: cabal

33− GHCVER: 8.6.5

47+ GHCVER: 8.6.4

34 CABALVER: 2.4

48 CABALVER: 2.4

35 maxParallel: 6

49 maxParallel: 6

36 steps:

50 steps:

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

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

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8+ stack-def:

9+ BUILD: stack

10+ stack-lts-6:

11+ BUILD: stack

12+ STACK_YAML: stack-lts-6.yaml

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

14+ stack-lts-9:

15+ BUILD: stack

16+ STACK_YAML: stack-lts-9.yaml

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

8 stack-lts-11:

18 stack-lts-11:

9 BUILD: stack

19 BUILD: stack

10 STACK_YAML: stack-lts-11.yaml

20 STACK_YAML: stack-lts-11.yaml

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

13 BUILD: stack

23 BUILD: stack

14 STACK_YAML: stack-lts-12.yaml

24 STACK_YAML: stack-lts-12.yaml

15 ARGS: "--resolver lts-12"

25 ARGS: "--resolver lts-12"

16− stack-lts-14:

26+ stack-lts-13:

17 BUILD: stack

27 BUILD: stack

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

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

19 maxParallel: 3

29 maxParallel: 3

20 steps:

30 steps:

21 - script: |

31 - script: |

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

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

5 vmImage: ${{ parameters.vmImage }}

6 strategy:

7 matrix:

8− stack-lts-14:

8+ stack-lts-13:

9 BUILD: stack

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

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

11 maxParallel: 3

12 steps:

13 - bash: |

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

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

17 stack setup $ARGS > /dev/null

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

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

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

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

21 env:

20 env:

22 OS_NAME: ${{ parameters.os }}

21 OS_NAME: ${{ parameters.os }}

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

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

.gitignore−1

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

9cabal.sandbox.config

10.stack-work/

11*~

12−stack*.yaml.lock

auto-update/ChangeLog.md−5

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

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

3## 0.1.5

9

4

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

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

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

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

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

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

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

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

15-- }

14-- }

16-- @

15-- @

17--

16--

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

26-- @since 0.1.2

25-- @since 0.1.2

27module Control.Debounce

26module Control.Debounce

28 ( -- * Type

27 ( -- * Type

29− DI.DebounceSettings

28+ DebounceSettings

30 , defaultDebounceSettings

29 , defaultDebounceSettings

31 -- * Accessors

30 -- * Accessors

32− , DI.debounceFreq

31+ , debounceFreq

33− , DI.debounceAction

32+ , debounceAction

34− , DI.debounceEdge

35− , DI.leadingEdge

36− , DI.trailingEdge

37 -- * Creation

33 -- * Creation

38 , mkDebounce

34 , mkDebounce

39 ) where

35 ) where

40

36

41−import Control.Concurrent (newEmptyMVar, threadDelay)

37+import Control.Concurrent (forkIO, threadDelay)

42−import qualified Control.Debounce.Internal as DI

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

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

43

69

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

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

45--

71--

46-- @since 0.1.2

72-- @since 0.1.2

47−defaultDebounceSettings :: DI.DebounceSettings

73+defaultDebounceSettings :: DebounceSettings

48−defaultDebounceSettings = DI.DebounceSettings

74+defaultDebounceSettings = DebounceSettings

49− { DI.debounceFreq = 1000000

75+ { debounceFreq = 1000000

50− , DI.debounceAction = return ()

76+ , debounceAction = return ()

51− , DI.debounceEdge = DI.leadingEdge

52 }

77 }

53

78

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

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

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

81+-- current cooldown period has expired.

55--

82--

56-- @since 0.1.2

83-- @since 0.1.2

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

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

58−mkDebounce settings = do

85+mkDebounce (DebounceSettings freq action) = do

59− baton <- newEmptyMVar

86+ baton <- newEmptyMVar

60− DI.mkDebounceInternal baton threadDelay settings

87+ mask_ $ void $ forkIO $ forever $ do

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.hsdeleted−98

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

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

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

1name: auto-update

2−version: 0.1.6

2+version: 0.1.5

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,7 +17,6 @@ library

17 ghc-options: -Wall

18 exposed-modules: Control.AutoUpdate

19 Control.Debounce

20− Control.Debounce.Internal

21 Control.Reaper

20 Control.Reaper

22 other-modules: Control.AutoUpdate.Util

21 other-modules: Control.AutoUpdate.Util

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

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

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

27

26

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

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

29

28

30−test-suite spec

29+-- test-suite spec

31− main-is: Spec.hs

30+-- main-is: Spec.hs

32− other-modules: Control.AutoUpdateSpec

31+-- other-modules: Control.AutoUpdateSpec

33− Control.DebounceSpec

34− Control.ReaperSpec

32+-- Control.ReaperSpec

35− hs-source-dirs: test

33+-- hs-source-dirs: test

36− type: exitcode-stdio-1.0

34+-- type: exitcode-stdio-1.0

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

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

38− default-language: Haskell2010

36+-- default-language: Haskell2010

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

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

1module Control.AutoUpdateSpec (spec) where

2

3−import Control.AutoUpdate

4−import Control.Concurrent (threadDelay)

5−import Control.Monad (replicateM_, forM_)

6−import Data.IORef

7import Test.Hspec

3import Test.Hspec

8import Test.Hspec.QuickCheck

4import Test.Hspec.QuickCheck

5+import Data.IORef

6+import Control.Concurrent (threadDelay)

7+import Control.Monad (replicateM_, forM_)

8+import Control.AutoUpdate

9

10spec :: Spec

11−spec = return ()

11+spec = do

12− -- do

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

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

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

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

15− -- ref <- newIORef 0

14+ ref <- newIORef 0

16− -- next <- mkAutoUpdate defaultUpdateSettings

15+ next <- mkAutoUpdate defaultUpdateSettings

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

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

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

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

19− -- , updateSpawnThreshold = st

18+ , updateSpawnThreshold = st

20− -- , updateFreq = 10000

19+ , updateFreq = 10000

21− -- }

20+ }

22

21

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

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

24− -- j <- next

23+ j <- next

25− -- j `shouldBe` i

24+ j `shouldBe` i

26

25

27− -- replicateM_ 50 $ do

26+ replicateM_ 50 $ do

28− -- i <- next

27+ i <- next

29− -- i `shouldBe` st + 2

28+ i `shouldBe` st + 2

30

29

31− -- threadDelay 60000

30+ threadDelay 60000

32− -- last1 <- readIORef ref

31+ last1 <- readIORef ref

33− -- threadDelay 20000

32+ threadDelay 20000

34− -- last2 <- readIORef ref

33+ last2 <- readIORef ref

35− -- last2 `shouldBe` last1

34+ last2 `shouldBe` last1

auto-update/test/Control/DebounceSpec.hsdeleted−120

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

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

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

1module Control.ReaperSpec (spec) where

2

3−import Control.Concurrent

4import Control.Reaper

3import Control.Reaper

5−import Data.IORef

4+import Control.Concurrent

6import Test.Hspec

5import Test.Hspec

7import Test.Hspec.QuickCheck

6import Test.Hspec.QuickCheck

7+import Data.IORef

8

9+type Item = (Int, IORef Int)

9

10

10−spec :: Spec

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

11−spec = return ()

12+ modifyIORef ref succ

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

13+ return $ if i > 1

13−-- reaper <- mkReaper defaultReaperSettings

14+ then Just (pred i, ref)

14−-- { reaperAction = action

15+ else Nothing

15−-- , reaperDelay = 1000

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

16

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

17+spec :: Spec

26−-- actual <- readIORef ref

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

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

19+ reaper <- mkReaper defaultReaperSettings

28−-- threadDelay 100000

20+ { reaperAction = action

29−-- mapM_ test testCases

21+ , reaperDelay = 1000

30−-- [] <- reaperRead reaper

22+ }

31−-- return ()

32

23

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

24+ let mkTestCase i = do

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

34

30

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

31+ let test (expected, ref) = do

36−-- modifyIORef ref succ

32+ actual <- readIORef ref

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

34+ threadDelay 100000

35+ mapM_ test testCases

36+ [] <- reaperRead reaper

37−-- return $ if i > 1

37+ return ()

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

39−-- else Nothing

stack-lts-11.yaml+6−3

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

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

18- http2-2.0.0

19- network-byte-order-0.1.1.0

20−- tls-1.5.3

21−- tls-session-manager-0.0.4

22−- x509-1.7.5

23nix:

20nix:

24 enable: false

21 enable: false

25 packages:

22 packages:

26 - fcgi

23 - fcgi

27 - zlib

24 - zlib

25+image:

26+ containers:

27+ - base: "fpco/pid1"

28+ name: "yesodweb/warp"

29+ executables:

30+ - warp

stack-lts-12.yaml+6−3

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

18 packages:

19 - fcgi

20 - zlib

21+image:

22+ containers:

23+ - base: "fpco/pid1"

24+ name: "yesodweb/warp"

25+ executables:

26+ - warp

21extra-deps:

27extra-deps:

22- http2-2.0.0

28- http2-2.0.0

23- network-byte-order-0.1.1.0

29- network-byte-order-0.1.1.0

24−- tls-1.5.3

25−- tls-session-manager-0.0.4

26−- x509-1.7.5

stack-lts-6.yamlnew file+35

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

1+resolver: lts-6.35

2+packages:

3+- ./auto-update

4+- ./mime-types

5+- ./wai

6+- ./wai-extra

7+- ./warp

8+- ./warp-tls

9+- ./wai-app-static

10+- ./wai-websockets

11+- ./wai-conduit

12+- ./time-manager

13+extra-deps:

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

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

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

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

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

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

20+- basement-0.0.7@rev:0

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

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

23+- http2-2.0.0

24+- network-byte-order-0.1.1.0

25+nix:

26+ enable: false

27+ packages:

28+ - fcgi

29+ - zlib

30+image:

31+ containers:

32+ - base: "fpco/pid1"

33+ name: "yesodweb/warp"

34+ executables:

35+ - warp

stack-lts-9.yamlnew file+31

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

1+resolver: lts-9.21

2+packages:

3+- ./auto-update

4+- ./mime-types

5+- ./wai

6+- ./wai-extra

7+- ./warp

8+- ./warp-tls

9+- ./wai-app-static

10+- ./wai-websockets

11+- ./wai-conduit

12+- ./time-manager

13+extra-deps:

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

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

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

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

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

19+- http2-2.0.0

20+- network-byte-order-0.1.1.0

21+nix:

22+ enable: false

23+ packages:

24+ - fcgi

25+ - zlib

26+image:

27+ containers:

28+ - base: "fpco/pid1"

29+ name: "yesodweb/warp"

30+ executables:

31+ - warp

stack-nightly.yamldeleted−20

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

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

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

1−resolver: lts-14.22

1+resolver: lts-13.14

2packages:

3- ./auto-update

4- ./mime-types

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

18 packages:

19 - fcgi

20 - zlib

21+image:

22+ containers:

23+ - base: "fpco/pid1"

24+ name: "yesodweb/warp"

25+ executables:

26+ - warp

21extra-deps:

27extra-deps:

22- http2-2.0.0

28- http2-2.0.0

23- network-byte-order-0.1.1.0

29- network-byte-order-0.1.1.0

24−- tls-1.5.3

25−- tls-session-manager-0.0.4

wai-app-static/ChangeLog.md−10

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

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−

11## 3.1.6.3

1## 3.1.6.3

12

2

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

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

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

@@ -164,13 +164,11 @@ 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− -- RFC7232 (HTTP 1.1):

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

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

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

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

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

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

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

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

171+ -- new file being sent anyway.

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

173− -- > If-None-Match.

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

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

175

173

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

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

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

245 response :: StaticResponse -> IO W.ResponseReceived

243 response :: StaticResponse -> IO W.ResponseReceived

246 response (FileResponse file ch) = do

244 response (FileResponse file ch) = do

247 mimetype <- ssGetMimeType ss file

245 mimetype <- ssGetMimeType ss file

248− -- let filesize = fileGetSize file

246+ let filesize = fileGetSize file

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

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

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

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

251 -- range requests into account

249 -- range requests into account

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

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

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

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

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

271

269

272− sendResponse $ W.responseLBS H.status302

270+ sendResponse $ W.responseLBS H.status301

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

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

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

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

275 ] "Redirect"

273 ] "Redirect"

276

274

277 response (RawRedirect path) =

275 response (RawRedirect path) =

278− sendResponse $ W.responseLBS H.status302

276+ sendResponse $ W.responseLBS H.status301

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

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

280 , ("Location", path)

278 , ("Location", path)

281 ] "Redirect"

279 ] "Redirect"

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

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

39 }

40

41#if MIN_VERSION_optparse_applicative(0, 10, 0)

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

43option' = option auto

42option' = option auto

44#else

43#else

45option' = option

44option' = 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,6 +7,7 @@ module WaiAppStatic.Storage.Embedded.TH(

7

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

9import Codec.Compression.GZip (compress)

10+import Control.Applicative

10import Data.ByteString.Unsafe (unsafePackAddressLen)

11import Data.ByteString.Unsafe (unsafePackAddressLen)

11import Data.Either (lefts, rights)

12import Data.Either (lefts, rights)

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

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

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

@@ -59,8 +59,6 @@ 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.

64type Pieces = [Piece]

62type Pieces = [Piece]

65

63

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

64-- | 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-existent files" $ webApp $

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

61 assertStatus 404 =<<

62 request (setRawPathInfo defRequest "doesNotExist")

63

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

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

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

66− assertStatus 302 req

66+ assertStatus 301 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 "302 redirect when multiple slashes" $ absoluteApp $

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

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

74 req <- request (setRawPathInfo defRequest path)

75− assertStatus 302 req

75+ assertStatus 301 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 "302 redirect to add a trailing slash on directories if missing" $ do

134+ context "301 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 302 req

137+ assertStatus 301 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 302 req

147+ assertStatus 301 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 302 req

161+ assertStatus 301 req

162 assertHeader "Location" "/subPath/" req

163

164 context "with defaultWebAppSettings" $ do

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

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

1name: wai-app-static

2−version: 3.1.7.1

2+version: 3.1.6.3

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

52+ , warp >= 3.0.11 && < 3.3

53

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

55 WaiAppStatic.Storage.Filesystem

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

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

17import Control.Monad (unless)

18import Network.HTTP.Types

19import Data.ByteString.Builder (Builder)

20+import Data.IORef

20import qualified Data.Conduit.List as CL

21import qualified Data.Conduit.List as CL

21

22

22-- | Stream the request body.

23-- | Stream the request body.

23--

24--

24-- Since 3.0.0

25-- Since 3.0.0

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

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

26sourceRequestBody req =

27sourceRequestBody req =

27 loop

28 loop

28 where

29 where

29− go = liftIO (getRequestBodyChunk req)

30+ go = liftIO (requestBody req)

30

31

31 loop = do

32 loop = do

32 bs <- go

33 bs <- go

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

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

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

38--

39--

39-- Since 3.0.0

40-- Since 3.0.0

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

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

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

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

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

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

43 case mbuilder of

44 case mbuilder of

44 Chunk b -> send b

45 Chunk b -> send b

45 Flush -> flush)

46 Flush -> flush)

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

49--

50--

50-- Since 3.0.0

51-- Since 3.0.0

51responseRawSource :: (MonadIO m, MonadIO n)

52responseRawSource :: (MonadIO m, MonadIO n)

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

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

53 -> Response

54 -> Response

55 -> Response

55responseRawSource app =

56responseRawSource app =

wai-extra/ChangeLog.md−21

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

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

3## 3.0.26

25

4

26* Throw 413 for too large payload

5* Throw 413 for too large payload

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

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

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.

10-}

8-}

11module Network.Wai.EventSource (

9module Network.Wai.EventSource (

12 ServerEvent(..),

10 ServerEvent(..),

13 eventSourceAppChan,

11 eventSourceAppChan,

14− eventSourceAppIO,

12+ eventSourceAppIO

15− eventStreamAppRaw

16 ) where

13 ) where

17

14

18import Data.Function (fix)

15import Data.Function (fix)

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

42 case eventToBuilder se of

39 case eventToBuilder se of

43 Nothing -> return ()

40 Nothing -> return ()

44 Just b -> sendChunk b >> flush >> loop

41 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 originally from Chris Smith https://github.com/cdsmith/gloss-web -}

2+{- code adapted by Mathias Billman originaly 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,9 +89,6 @@ 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'.

95gzip :: GzipSettings -> Middleware

92gzip :: GzipSettings -> Middleware

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

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

97 case res of

94 case res of

wai-extra/Network/Wai/Middleware/RequestLogger.hs+10−60

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

14 , OutputFormat (..)

15 , OutputFormatter

16 , OutputFormatterWithDetails

17− , OutputFormatterWithDetailsAndHeaders

18 , Destination (..)

17 , Destination (..)

19 , Callback

18 , Callback

20 , IPAddrSource (..)

19 , IPAddrSource (..)

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

50import Network.Wai.Header (contentLength)

49import Network.Wai.Header (contentLength)

51import Data.Text.Encoding (decodeUtf8')

50import Data.Text.Encoding (decodeUtf8')

52

51

53−data OutputFormat

54− = Apache IPAddrSource

52+data OutputFormat = Apache IPAddrSource

55− | Detailed Bool -- ^ use colors?

53+ | Detailed Bool -- ^ use colors?

56− | CustomOutputFormat OutputFormatter

54+ | CustomOutputFormat OutputFormatter

57− | CustomOutputFormatWithDetails OutputFormatterWithDetails

55+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

58− | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

59

56

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

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

61−

62−type OutputFormatterWithDetails

58+type OutputFormatterWithDetails =

63− = ZonedDate

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

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

89

60

90data Destination = Handle Handle

61data Destination = Handle Handle

91 | Logger LoggerSet

62 | Logger LoggerSet

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

137 CustomOutputFormatWithDetails formatter -> do

108 CustomOutputFormatWithDetails formatter -> do

138 getdate <- getDateGetter flusher

109 getdate <- getDateGetter flusher

139 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

110 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

140− CustomOutputFormatWithDetailsAndHeaders formatter -> do

141− getdate <- getDateGetter flusher

142− return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

143

111

144apacheMiddleware :: ApacheLoggerActions -> Middleware

112apacheMiddleware :: ApacheLoggerActions -> Middleware

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

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

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

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

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

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

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

152 date <- liftIO getdate

120 date <- liftIO getdate

153− let msize = contentLength (responseHeaders res)

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

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

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

155 sendResponse res

123 sendResponse res

156

124

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

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

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

161 app req' $ \res -> do

129 app req' $ \res -> do

162 t1 <- getCurrentTime

130 t1 <- getCurrentTime

163 date <- liftIO getdate

131 date <- liftIO getdate

164− let msize = contentLength (responseHeaders res)

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

165 builderIO <- newIORef $ B.byteString ""

133 builderIO <- newIORef $ B.byteString ""

166 res' <- recordChunks builderIO res

134 res' <- recordChunks builderIO res

167 rspRcv <- sendResponse res'

135 rspRcv <- sendResponse res'

168 _ <- liftIO . cb .

136 _ <- liftIO . cb .

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

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

170 readIORef builderIO

138 readIORef builderIO

171 return rspRcv

139 return rspRcv

172

140

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

191-- | Production request logger middleware.

141-- | Production request logger middleware.

192--

142--

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

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

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

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

1{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE CPP #-}

3

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

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

5− ( formatAsJSON

6− , formatAsJSONWithHeaders

7− ) where

8

5

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

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

10import Data.ByteString.Lazy (toStrict)

7import Data.ByteString.Lazy (toStrict)

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

43 , "time" .= decodeUtf8With lenientDecode date

40 , "time" .= decodeUtf8With lenientDecode date

44 ]) <> "\n"

41 ]) <> "\n"

45

42

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−

70word32ToHostAddress :: Word32 -> Text

43word32ToHostAddress :: Word32 -> Text

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

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

72

45

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

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

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

118 hToJ hd = headerToJSON hd

91 hToJ hd = headerToJSON hd

119

92

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−

126headerToJSON :: Header -> Value

93headerToJSON :: Header -> Value

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

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

128

95

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 library could only handle path pieces, not queries.

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

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

174--

175-- @

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

@@ -99,10 +99,6 @@ 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'.

106 }

102 }

107data SResponse = SResponse

103data SResponse = SResponse

108 { simpleStatus :: H.Status

104 { simpleStatus :: H.Status

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

110 , simpleBody :: L.ByteString

106 , simpleBody :: L.ByteString

111 }

107 }

112 deriving (Show, Eq)

108 deriving (Show, Eq)

113−

114request :: Request -> Session SResponse

109request :: Request -> Session SResponse

115−request req = do

110+request = srequest . flip SRequest L.empty

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

123

111

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

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

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

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

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

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

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

179 return response

167 return response

180

168

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

182−-- 'L.ByteString'.

183srequest :: SRequest -> Session SResponse

169srequest :: SRequest -> Session SResponse

184srequest (SRequest req bod) = do

170srequest (SRequest req bod) = do

171+ app <- ask

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

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

186− request $

187− req

173+ let req' = req

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

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

189− case bss of

175+ case bss of

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

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

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

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

192− }

178+ }

179+ req'' <- addCookiesToRequest req'

180+ response <- liftIO $ do

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

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

183+ readIORef ref

184+ extractSetCookieFromSResponse response

193

185

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

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

195runResponse ref res = do

187runResponse ref res = do

wai-extra/example/Main.hs−11

@@ -37,17 +37,6 @@ 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−

51main :: IO ()

40main :: IO ()

52main = do

41main = do

53 chan <- newChan

42 chan <- newChan

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

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

3

4import Control.Monad (void)

5

6−import qualified Data.IORef as IORef

7−

8import qualified Data.Text.Encoding as TE

6import qualified Data.Text.Encoding as TE

9

7

10import Data.Time.Calendar (fromGregorian)

8import Data.Time.Calendar (fromGregorian)

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

55 it "sets rawQueryString to empty string" $ do

53 it "sets rawQueryString to empty string" $ do

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

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

57

55

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−

74 describe "request" $ do

56 describe "request" $ do

75

57

76− let echoApp req respond = do

58+ let simpleApp _req respond =

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

78− let reqHeaders = requestHeaders req

79 respond $

59 respond $

80 responseLBS

60 responseLBS

81 status200

61 status200

82− reqHeaders

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

83− reqBody

63+ "simple"

84

64

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

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

86− sresp <- runSession (request defaultRequest) echoApp

66+ sresp <- runSession (request defaultRequest) simpleApp

87 simpleStatus sresp `shouldBe` status200

67 simpleStatus sresp `shouldBe` status200

88

68

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

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

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

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

92− sresp <- flip runSession echoApp $

93− request $

94− defaultRequest

70+ sresp <- runSession (request defaultRequest) simpleApp

95− { requestBody = getBodyChunk

96− }

97− simpleBody sresp `shouldBe` "request body"

71+ simpleBody sresp `shouldBe` "simple"

98−

72+

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

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

100− sresp <- flip runSession echoApp $

101− request $

102− defaultRequest

74+ sresp <- runSession (request defaultRequest) simpleApp

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

104− }

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

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

106

76

107 let cookieApp req respond =

77 let cookieApp req respond =

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

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

1Name: wai-extra

2−Version: 3.0.29.1

2+Version: 3.0.26

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.8 && < 5

90+ Build-Depends: base >= 4.6 && < 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

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

103− , wai-logger >= 2.3.2

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

104 , ansi-terminal

105 , resourcet >= 0.4.6 && < 1.3

106 , void >= 0.5

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

@@ -120,12 +120,10 @@ 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

125− mpp <- makePushPromise refPath' path' file

123+ mpp <- makePushPromise refPath path file

126 case mpp of

124 case mpp of

127 Nothing -> return ()

125 Nothing -> return ()

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

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

129 ps -> do

127 ps -> do

130 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

128 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

131 setHTTP2Data req (Just h2d)

129 setHTTP2Data req (Just h2d)

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

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

1Name: wai-http2-extra

2−Version: 0.1.2

2+Version: 0.1.0

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

11+Cabal-Version: >=1.8

12Stability: Stable

13Description: WAI utilities for HTTP/2

14

@@ -24,9 +24,6 @@ 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

30

27

31Test-Suite doctest

28Test-Suite doctest

32 Type: exitcode-stdio-1.0

29 Type: exitcode-stdio-1.0

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

35 Main-Is: doctests.hs

32 Main-Is: doctests.hs

36 Build-Depends: base

33 Build-Depends: base

37 , doctest >= 0.10.1

34 , doctest >= 0.10.1

38− if impl(ghc >= 8)

39− default-extensions: Strict StrictData

40− default-language: Haskell2010

41−

42Source-Repository head

35Source-Repository head

43 Type: git

36 Type: git

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

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

wai-websockets/server.lhs+1−7

@@ -8,8 +8,6 @@ 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

13> import Data.Char (isPunctuation, isSpace)

11> import Data.Char (isPunctuation, isSpace)

14> import Data.Monoid (mappend)

12> import Data.Monoid (mappend)

15> import Data.Text (Text)

13> import Data.Text (Text)

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

101

99

102> application state pending = do

100> application state pending = do

103> conn <- WS.acceptRequest pending

101> conn <- WS.acceptRequest pending

104−#if __GLASGOW_HASKELL__ >= 806

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

106−#else

107> WS.forkPingThread conn 30

102> WS.forkPingThread conn 30

108−#endif

109

103

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

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

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

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

112

106

113> msg <- WS.receiveData conn

107> msg <- WS.receiveData conn

wai-websockets/wai-websockets.cabal−1

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

45 , text

46 , file-embed

47 , http-types

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

49 else

48 else

50 buildable: False

49 buildable: False

51

50

warp-tls/ChangeLog.md−22

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

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

1## 3.2.6

24

2

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

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

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

@@ -53,9 +53,6 @@ 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

59import Network.Socket.ByteString (sendAll)

56import Network.Socket.ByteString (sendAll)

60import qualified Network.TLS as TLS

57import qualified Network.TLS as TLS

61import qualified Crypto.PubKey.DH as DH

58import qualified Crypto.PubKey.DH as DH

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

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

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

282 runSettingsConnectionMakerSecure set get app

279 runSettingsConnectionMakerSecure set get app

283 where

280 where

284− get = getter tlsset set sock params

281+ get = getter tlsset sock params

285 params = def { -- TLS.ServerParams

282 params = def { -- TLS.ServerParams

286 TLS.serverWantClientCert = tlsWantClientCert

283 TLS.serverWantClientCert = tlsWantClientCert

287 , TLS.serverCACertificates = []

284 , TLS.serverCACertificates = []

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

322

319

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

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

324

321

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

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

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

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

327#if WINDOWS

324#if WINDOWS

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

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

329#else

326#else

330 (s, sa) <- accept sock

327 (s, sa) <- accept sock

331#endif

328#endif

332 setSocketCloseOnExec s

329 setSocketCloseOnExec s

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

330+ return (mkConn tlsset s params, sa)

334

331

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

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

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

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

337 where

334 where

338 switch = do

335 switch = do

339 firstBS <- safeRecv s 4096

336 firstBS <- safeRecv s 4096

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

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

341− httpOverTls tlsset set s firstBS params

338+ httpOverTls tlsset s firstBS params

342 else

339 else

343− plainHTTP tlsset set s firstBS

340+ plainHTTP tlsset s firstBS

344

341

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

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

346

343

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

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

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

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

349 recvN <- makePlainReceiveN s bs0

346 recvN <- makePlainReceiveN s bs0

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

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

351 TLS.contextHookSetLogging ctx tlsLogging

348 TLS.contextHookSetLogging ctx tlsLogging

352 TLS.handshake ctx

349 TLS.handshake ctx

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

354− isH2 <- I.newIORef h2

355 writeBuf <- allocateBuffer bufferSize

350 writeBuf <- allocateBuffer bufferSize

356 -- Creating a cache for leftover input data.

351 -- Creating a cache for leftover input data.

357 ref <- I.newIORef ""

352 ref <- I.newIORef ""

358 tls <- getTLSinfo ctx

353 tls <- getTLSinfo ctx

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

354+ return (conn ctx writeBuf ref, tls)

360 where

355 where

361 backend recvN = TLS.Backend {

356 backend recvN = TLS.Backend {

362 TLS.backendFlush = return ()

357 TLS.backendFlush = return ()

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

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

365−#else

366 , TLS.backendClose = close s

358 , TLS.backendClose = close s

367−#endif

368 , TLS.backendSend = sendAll' s

359 , TLS.backendSend = sendAll' s

369 , TLS.backendRecv = recvN

360 , TLS.backendRecv = recvN

370 }

361 }

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

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

372 throwIO ConnectionClosedByPeer

363 throwIO ConnectionClosedByPeer

373− conn ctx writeBuf ref isH2 = Connection {

364+ conn ctx writeBuf ref = Connection {

374 connSendMany = TLS.sendData ctx . L.fromChunks

365 connSendMany = TLS.sendData ctx . L.fromChunks

375 , connSendAll = sendall

366 , connSendAll = sendall

376 , connSendFile = sendfile

367 , connSendFile = sendfile

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

380 , connRecvBuf = recvBuf ref

371 , connRecvBuf = recvBuf ref

381 , connWriteBuffer = writeBuf

372 , connWriteBuffer = writeBuf

382 , connBufferSize = bufferSize

373 , connBufferSize = bufferSize

383− , connHTTP2 = isH2

384 }

374 }

385 where

375 where

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

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

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

468#if MIN_VERSION_tls(1,5,0)

458#if MIN_VERSION_tls(1,5,0)

469 TLS.TLS13 -> (3,4)

459 TLS.TLS13 -> (3,4)

470#endif

460#endif

471− clientCert <- TLS.getClientCertificateChain ctx

472 return TLS {

461 return TLS {

473 tlsMajorVersion = major

462 tlsMajorVersion = major

474 , tlsMinorVersion = minor

463 , tlsMinorVersion = minor

475 , tlsNegotiatedProtocol = proto

464 , tlsNegotiatedProtocol = proto

476 , tlsChiperID = TLS.cipherID infoCipher

465 , tlsChiperID = TLS.cipherID infoCipher

477− , tlsClientCertificate = clientCert

478 }

466 }

479

467

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

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

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

482

470

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

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

484

472

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

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

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

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

487 AllowInsecure -> do

475 AllowInsecure -> do

488− conn' <- socketConnection set s

476+ conn' <- socketConnection s

489 cachedRef <- I.newIORef bs0

477 cachedRef <- I.newIORef bs0

490 let conn'' = conn'

478 let conn'' = conn'

491 { connRecv = recvPlain cachedRef (connRecv conn')

479 { connRecv = recvPlain cachedRef (connRecv conn')

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

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

1Name: warp-tls

2−Version: 3.2.11

2+Version: 3.2.6

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

4License: MIT

5License-file: LICENSE

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

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

19

20Library

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

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

22 , bytestring >= 0.9

23 , wai >= 3.2 && < 3.3

24− , warp >= 3.3.6 && < 3.4

24+ , warp >= 3.2.17 && < 3.3

25 , data-default-class >= 0.0.1

26− , tls >= 1.5.3

26+ , tls >= 1.3.10

27 , cryptonite >= 0.12

28 , network >= 2.2.1

29 , streaming-commons

30− , tls-session-manager >= 0.0.4

30+ , tls-session-manager >= 0.0.0.1

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

32 ghc-options: -Wall

33 if os(windows)

warp/ChangeLog.md−56

@@ -1,59 +1,3 @@

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

1## 3.2.28

58

2

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

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

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

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

72 , setLogger

73 , setServerPushLogger

74 , setGracefulShutdownTimeout

75− , setGracefulCloseTimeout1

76− , setGracefulCloseTimeout2

77− , setMaxTotalHeaderLength

78 -- ** Getters

75 -- ** Getters

79 , getPort

76 , getPort

80 , getHost

77 , getHost

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

82 , getOnClose

79 , getOnClose

83 , getOnException

80 , getOnException

84 , getGracefulShutdownTimeout

81 , getGracefulShutdownTimeout

85− , getGracefulCloseTimeout1

86− , getGracefulCloseTimeout2

87 -- ** Exception handler

82 -- ** Exception handler

88 , defaultOnException

83 , defaultOnException

89 , defaultShouldDisplayException

84 , defaultShouldDisplayException

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

98 , pauseTimeout

93 , pauseTimeout

99 , FileInfo(..)

94 , FileInfo(..)

100 , getFileInfo

95 , getFileInfo

101− , clientCertificate

102 , withApplication

96 , withApplication

103 , withApplicationSettings

97 , withApplicationSettings

104 , testWithApplication

98 , testWithApplication

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

127import Control.Exception (SomeException, throwIO)

121import Control.Exception (SomeException, throwIO)

128import Data.Streaming.Network (HostPreference)

122import Data.Streaming.Network (HostPreference)

129import qualified Data.Vault.Lazy as Vault

123import qualified Data.Vault.Lazy as Vault

130−import Data.X509

131import qualified Network.HTTP.Types as H

124import qualified Network.HTTP.Types as H

132import Network.Socket (SockAddr)

125import Network.Socket (SockAddr)

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

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

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

385--

378--

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

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

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

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

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

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

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

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

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

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

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

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

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

437 -> Settings -> Settings

430 -> Settings -> Settings

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

431setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

439

432

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−

447-- | Explicitly pause the slowloris timeout.

433-- | Explicitly pause the slowloris timeout.

448--

434--

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

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

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

471-- Since 3.1.10

457-- Since 3.1.10

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

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

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

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

474−

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

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

477−-- Default: 0.

478−--

479−-- Since 3.3.5

480−setGracefulCloseTimeout1 :: Int -> Settings -> Settings

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

482−

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

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

485−--

486−-- Since 3.3.5

487−getGracefulCloseTimeout1 :: Settings -> Int

488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489−

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

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

492−-- Default: 2000.

493−--

494−-- Since 3.3.5

495−setGracefulCloseTimeout2 :: Int -> Settings -> Settings

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

497−

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

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

500−--

501−-- Since 3.3.5

502−getGracefulCloseTimeout2 :: Settings -> Int

503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504−

505−-- | Getting information of client certificate.

506−--

507−-- Since 3.3.5

508−clientCertificate :: Request -> Maybe CertificateChain

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

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

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

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

35

36conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders

37+ -> H.ResponseHeaders -> IndexedHeader

38− -> IndexedHeader -- ^ Response

39− -> IndexedHeader -- ^ Request

40 -> RspFileInfo

38 -> RspFileInfo

41−conditionalRequest finfo hs0 rspidx reqidx = case condition of

39+conditionalRequest finfo hs0 reqidx = case condition of

42 nobody@(WithoutBody _) -> nobody

40 nobody@(WithoutBody _) -> nobody

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

44− !hasLM = isJust $ rspidx ! fromEnum ResLastModified

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

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

42+ addContentHeaders hs0 off len size

46 in WithBody s hs off len

43 in WithBody s hs off len

47 where

44 where

48 !mtime = I.fileInfoTime finfo

45 !mtime = I.fileInfoTime finfo

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

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

6

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

8

9−import qualified Data.IORef as I

10import qualified Control.Exception as E

9import qualified Control.Exception as E

11import qualified Network.HTTP2.Server as H2

10import qualified Network.HTTP2.Server as H2

12import Network.Socket (SockAddr)

11import Network.Socket (SockAddr)

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

24

23

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

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

26

25

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

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

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

27+http2 conn ii addr settings readN app =

29 H2.run conf http2server

28 H2.run conf http2server

30 where

29 where

31 conf = H2.Config {

30 conf = H2.Config {

32 confWriteBuffer = connWriteBuffer conn

31 confWriteBuffer = connWriteBuffer conn

33 , confBufferSize = connBufferSize conn

32 , confBufferSize = connBufferSize conn

34− , confSendAll = send

33+ , confSendAll = connSendAll conn

35 , confReadN = readN

34 , confReadN = readN

36 , confPositionReadMaker = pReadMaker ii

35 , confPositionReadMaker = pReadMaker ii

37 }

36 }

38

37

39 http2server h2req aux response = do

38 http2server h2req aux response = do

40 req <- toWAIRequest h2req aux

39 req <- toWAIRequest h2req aux

41− ref <- I.newIORef Nothing

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

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

43 h2rsp <- fromResponse settings ii req rsp

41 h2rsp <- fromResponse settings ii req rsp

44 pps <- fromPushPromises ii req

42 pps <- fromPushPromises ii req

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

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

46− _ <- response h2rsp pps

44+ case ex of

45+ Right () -> do

46+ logResponse h2rsp req

47+ mapM_ (logPushPromise req) pps

48+ Left e@(E.SomeException _)

49+ -- killed by the local worker manager

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

51+ -- killed by the local timeout manager

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

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

47 return ResponseReceived

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

55 return ()

65

56

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

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

67 where

58 where

68 !hdr = H2.requestHeaders h2req

59 !hdr = H2.requestHeaders h2req

69 !bdy = H2.getRequestBodyChunk h2req

60 !bdy = H2.getRequestBodyChunk h2req

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

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

15

16pReadMaker :: InternalInfo -> PositionReadMaker

17pReadMaker ii path = do

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

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

19− case mfd of

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

19+ return (pread fd, Refresher refresh)

21− Nothing -> do

22− fd <- openFile path

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

24 where

20 where

25 pread :: Fd -> PositionRead

21 pread :: Fd -> PositionRead

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

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

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

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

22

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

24import Network.Wai.Handler.Warp.Imports

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

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

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

27import Network.Wai.Handler.Warp.Types

28

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

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

30

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

32

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

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

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

35 ref <- newIORef Nothing

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

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

37

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

39 -> IORef (Maybe HTTP2Data)

40 -> ToReq

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

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

42 where

43 !req = Request {

44 requestMethod = colonMethod

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

48 , rawQueryString = query

49 , queryString = H.parseQuery query

50 , requestHeaders = headers

51− , isSecure = isTransportSecure transport

51+ , isSecure = True

52 , remoteHost = addr

53 , requestBody = body

54 , vault = vaultValue

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

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

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

86− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

87 Vault.empty

86 Vault.empty

88

87

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

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

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

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

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

73 Right finfo -> do

74 let reqidx = indexRequestHeader reqhdr

75− rspidx = indexResponseHeader rsphdr

76− case conditionalRequest finfo rsphdr rspidx reqidx of

75+ case conditionalRequest finfo rsphdr reqidx of

77 WithoutBody s -> return $ responseNoBody s rsphdr

76 WithoutBody s -> return $ responseNoBody s rsphdr

78 WithBody s rsphdr' off bytes -> do

77 WithBody s rsphdr' off bytes -> do

79 let !off' = fromIntegral off

78 let !off' = fromIntegral off

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+1−5

@@ -32,9 +32,7 @@ data HTTP2Data = HTTP2Data {

32 --

33 -- Since: 3.2.7

34 http2dataPushPromise :: [PushPromise]

35− -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.

36− --

37− -- Since: 3.2.8 but the type changed in 3.3.0

35+ -- Since: 3.2.8

38 , http2dataTrailers :: H2.TrailersMaker

36 , http2dataTrailers :: H2.TrailersMaker

39 }

37 }

40

38

@@ -45,8 +43,6 @@ defaultHTTP2Data :: HTTP2Data

45defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

43defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

46

44

47-- | HTTP/2 push promise or sever push.

45-- | HTTP/2 push promise or sever push.

48−-- This allows files only for backward-compatibility

49−-- while the HTTP/2 library supports other types.

50--

46--

51-- Since: 3.2.7

47-- Since: 3.2.7

52data PushPromise = PushPromise {

48data PushPromise = PushPromise {

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

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

69data ResponseHeaderIndex = ResContentLength

70 | ResServer

71 | ResDate

72− | ResLastModified

73 deriving (Enum,Bounded)

72 deriving (Enum,Bounded)

74

73

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

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

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

80responseKeyIndex hn = case BS.length bs of

79responseKeyIndex hn = case BS.length bs of

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

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

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

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

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

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

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

85 _ -> -1

83 _ -> -1

86 where

84 where

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

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

21−import Network.Socket (Socket)

20+import Network.Socket (Socket, fdSocket)

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

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

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

29

22

30import Network.Wai.Handler.Warp.Buffer

23import Network.Wai.Handler.Warp.Buffer

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

96 siz' = siz - len

89 siz' = siz - len

97 loop bss' siz'

90 loop bss' siz'

98

91

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.

102receive :: Socket -> BufferPool -> Recv

92receive :: Socket -> BufferPool -> Recv

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

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

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

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

105− withFdSocket sock $ \fd -> do

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

107 fd <- fdSocket sock

95 fd <- fdSocket sock

108#else

96#else

109 let fd = fdSocket sock

97 let fd = fdSocket sock

110#endif

98#endif

111 let size' = fromIntegral size

99 let size' = fromIntegral size

112 fromIntegral <$> receiveloop fd ptr size'

100 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

118

101

119receiveBuf :: Socket -> RecvBuf

102receiveBuf :: Socket -> RecvBuf

120receiveBuf sock buf0 siz0 = do

103receiveBuf sock buf0 siz0 = do

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

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

122− withFdSocket sock $ \fd -> do

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

124 fd <- fdSocket sock

105 fd <- fdSocket sock

125#else

106#else

126 let fd = fdSocket sock

107 let fd = fdSocket sock

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

153 else

134 else

154 return bytes

135 return bytes

155

136

156−#ifndef mingw32_HOST_OS

157-- fixme: the type of the return value

137-- fixme: the type of the return value

158foreign import ccall unsafe "recv"

138foreign import ccall unsafe "recv"

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

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

160−#endif

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

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

9 , headerLines

10 , pauseTimeoutKey

11 , getFileInfoKey

12− , getClientCertificateKey

13 , NoKeepAliveRequest (..)

12 , NoKeepAliveRequest (..)

14 ) where

13 ) where

15

14

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

22import qualified Data.IORef as I

21import qualified Data.IORef as I

23import Data.Typeable (Typeable)

22import Data.Typeable (Typeable)

24import qualified Data.Vault.Lazy as Vault

23import qualified Data.Vault.Lazy as Vault

25−import Data.X509

26import qualified Network.HTTP.Types as H

24import qualified Network.HTTP.Types as H

27import Network.Socket (SockAddr)

25import Network.Socket (SockAddr)

28import Network.Wai

26import Network.Wai

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

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

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

39import Network.Wai.Handler.Warp.ReadInt

37import Network.Wai.Handler.Warp.ReadInt

40import Network.Wai.Handler.Warp.RequestHeader

38import Network.Wai.Handler.Warp.RequestHeader

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

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

40+

41+----------------------------------------------------------------

42+

43+-- FIXME come up with good values here

44+maxTotalHeaderLength :: Int

45+maxTotalHeaderLength = 50 * 1024

42

46

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

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

44

48

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

51 -> Timeout.Handle

55 -> Timeout.Handle

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

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

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

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

54− -> Transport

55 -> IO (Request

58 -> IO (Request

56 ,Maybe (I.IORef Int)

59 ,Maybe (I.IORef Int)

57 ,IndexedHeader

60 ,IndexedHeader

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

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

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

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

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

63

66

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

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

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

68+ hdrlines <- headerLines firstRequest src

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

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

67 let idxhdr = indexRequestHeader hdr

70 let idxhdr = indexRequestHeader hdr

68 expect = idxhdr ! fromEnum ReqExpect

71 expect = idxhdr ! fromEnum ReqExpect

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

72 rawPath = if settingsNoParsePath settings then unparsedPath else path

75 rawPath = if settingsNoParsePath settings then unparsedPath else path

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

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

74 $ Vault.insert getFileInfoKey (getFileInfo ii)

77 $ Vault.insert getFileInfoKey (getFileInfo ii)

75− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

76 Vault.empty

78 Vault.empty

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

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

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

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

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

87 , rawQueryString = query

89 , rawQueryString = query

88 , queryString = H.parseQuery query

90 , queryString = H.parseQuery query

89 , requestHeaders = hdr

91 , requestHeaders = hdr

90− , isSecure = isTransportSecure transport

92+ , isSecure = False

91 , remoteHost = addr

93 , remoteHost = addr

92 , requestBody = rbody'

94 , requestBody = rbody'

93 , vault = vaultValue

95 , vault = vaultValue

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

101

103

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

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

103

105

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

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

105−headerLines maxTotalHeaderLength firstRequest src = do

107+headerLines firstRequest src = do

106 bs <- readSource src

108 bs <- readSource src

107 if S.null bs

109 if S.null bs

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

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

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

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

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

111 -- the Run module for more details.

113 -- the Run module for more details.

112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

114 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

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

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

114

116

115data NoKeepAliveRequest = NoKeepAliveRequest

117data NoKeepAliveRequest = NoKeepAliveRequest

116 deriving (Show, Typeable)

118 deriving (Show, Typeable)

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

220close = throwIO IncompleteHeaders

222close = throwIO IncompleteHeaders

221-}

223-}

222

224

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

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

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

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

225 -- Too many bytes

227 -- Too many bytes

226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

228 | len > maxTotalHeaderLength = throwIO OverLargeHeader

227 | otherwise = push' mnl

229 | otherwise = push' mnl

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

249 push' Nothing = do

251 push' Nothing = do

250 bst <- readSource' src

252 bst <- readSource' src

251 when (S.null bst) $ throwIO IncompleteHeaders

253 when (S.null bst) $ throwIO IncompleteHeaders

252− push maxTotalHeaderLength src status bst

254+ push src status bst

253 where

255 where

254 len' = len + bsLen

256 len' = len + bsLen

255 prepend' = S.append bs

257 prepend' = S.append bs

256 status = THStatus len' lines prepend'

258 status = THStatus len' lines prepend'

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

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

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

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

259 where

261 where

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

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

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

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

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

274 in if start < bsLen then

276 in if start < bsLen then

275 -- more bytes in this chunk, push again

277 -- more bytes in this chunk, push again

276 let bs'' = SU.unsafeDrop start bs

278 let bs'' = SU.unsafeDrop start bs

277− in push maxTotalHeaderLength src status bs''

279+ in push src status bs''

278 else do

280 else do

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

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

280 bst <- readSource' src

282 bst <- readSource' src

281 when (S.null bs) $ throwIO IncompleteHeaders

283 when (S.null bs) $ throwIO IncompleteHeaders

282− push maxTotalHeaderLength src status bst

284+ push src status bst

283 where

285 where

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

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

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

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

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

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

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

298getFileInfoKey = unsafePerformIO Vault.newKey

300getFileInfoKey = unsafePerformIO Vault.newKey

299{-# NOINLINE getFileInfoKey #-}

301{-# NOINLINE getFileInfoKey #-}

300−

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

302−getClientCertificateKey = unsafePerformIO Vault.newKey

303−{-# NOINLINE getClientCertificateKey #-}

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

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

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

117 --

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

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

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

120 case ms of

121 Nothing -> return ()

122 Just realStatus -> logger req realStatus mlen

123 T.tickle th

124 return ret

125 else do

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

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

127 logger req s Nothing

128 T.tickle th

129 return isPersist

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

196 -> H.HttpVersion

197 -> H.Status

198 -> H.ResponseHeaders

199− -> IndexedHeader -- Response

200 -> Rsp

199 -> Rsp

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

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

202

201

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

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

204

203

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

204+sendRsp conn _ ver s hs RspNoBody = do

206 -- Not adding Content-Length.

205 -- Not adding Content-Length.

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

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

208 composeHeader ver s hs >>= connSendAll conn

207 composeHeader ver s hs >>= connSendAll conn

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

210

209

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

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

212

211

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

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

214 header <- composeHeaderBuilder ver s hs needsChunked

213 header <- composeHeaderBuilder ver s hs needsChunked

215 let hdrBdy

214 let hdrBdy

216 | needsChunked = header <> chunkedTransferEncoding body

215 | needsChunked = header <> chunkedTransferEncoding body

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

223

222

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

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

225

224

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

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

227 header <- composeHeaderBuilder ver s hs needsChunked

226 header <- composeHeaderBuilder ver s hs needsChunked

228 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

227 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

228 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

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

247

246

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

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

249

248

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

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

251 withApp recv send

250 withApp recv send

252 return (Nothing, Nothing)

251 return (Nothing, Nothing)

253 where

252 where

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

261

260

262-- Sophisticated WAI applications.

261-- Sophisticated WAI applications.

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

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

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

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

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

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

266 where

265 where

267 beg = filePartOffset part

266 beg = filePartOffset part

268 len = filePartByteCount part

267 len = filePartByteCount part

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

272

271

273-- Simple WAI applications.

272-- Simple WAI applications.

274-- Status is ignored

273-- Status is ignored

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

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

276 efinfo <- E.try $ getFileInfo ii path

275 efinfo <- E.try $ getFileInfo ii path

277 case efinfo of

276 case efinfo of

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

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

279#ifdef WARP_DEBUG

278#ifdef WARP_DEBUG

280 print _ex >>

279 print _ex >>

281#endif

280#endif

282− sendRspFile404 conn ii ver hs0 rspidxhdr

281+ sendRspFile404 conn ii ver hs0

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

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

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

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

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

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

286

285

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

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

288

287

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

291 -> H.HttpVersion

290 -> H.HttpVersion

292 -> H.Status

291 -> H.Status

293 -> H.ResponseHeaders

292 -> H.ResponseHeaders

294− -> IndexedHeader

295 -> FilePath

293 -> FilePath

296 -> Integer

294 -> Integer

297 -> Integer

295 -> Integer

298 -> Bool

296 -> Bool

299 -> IO ()

297 -> IO ()

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

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

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

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

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

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

303 | otherwise = do

301 | otherwise = do

304 lheader <- composeHeader ver s hs

302 lheader <- composeHeader ver s hs

305 (mfd, fresher) <- getFd ii path

303 (mfd, fresher) <- getFd ii path

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

312 -> InternalInfo

310 -> InternalInfo

313 -> H.HttpVersion

311 -> H.HttpVersion

314 -> H.ResponseHeaders

312 -> H.ResponseHeaders

315− -> IndexedHeader

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

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

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

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

318 where

315 where

319 s = H.notFound404

316 s = H.notFound404

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

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

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

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

6{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

9−{-# LANGUAGE ViewPatterns #-}

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

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

11

10

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

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

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

17import Control.Exception as E

16import Control.Exception as E

18import qualified Data.ByteString as S

17import qualified Data.ByteString as S

19import Data.Char (chr)

18import Data.Char (chr)

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

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

21import Data.Streaming.Network (bindPortTCP)

20import Data.Streaming.Network (bindPortTCP)

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

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

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

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

24import qualified Network.HTTP2 as H2

23import qualified Network.HTTP2 as H2

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

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

29import qualified Network.Socket.ByteString as Sock

25import qualified Network.Socket.ByteString as Sock

30import Network.Wai

26import Network.Wai

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

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

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

58#endif

54#endif

59

55

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

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

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

57+socketConnection :: Socket -> IO Connection

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

63−socketConnection set s = do

64−#else

65−socketConnection _ s = do

58+socketConnection s = do

66−#endif

67 bufferPool <- newBufferPool

59 bufferPool <- newBufferPool

68 writeBuf <- allocateBuffer bufferSize

60 writeBuf <- allocateBuffer bufferSize

69 let sendall = Sock.sendAll s

61 let sendall = Sock.sendAll s

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

71 return Connection {

62 return Connection {

72 connSendMany = Sock.sendMany s

63 connSendMany = Sock.sendMany s

73 , connSendAll = sendall

64 , connSendAll = sendall

74 , connSendFile = sendFile s writeBuf bufferSize sendall

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

85 , connClose = close s

66 , connClose = close s

86−#endif

87 , connFree = freeBuffer writeBuf

67 , connFree = freeBuffer writeBuf

88 , connRecv = receive s bufferPool

68 , connRecv = receive s bufferPool

89 , connRecvBuf = receiveBuf s

69 , connRecvBuf = receiveBuf s

90 , connWriteBuffer = writeBuf

70 , connWriteBuffer = writeBuf

91 , connBufferSize = bufferSize

71 , connBufferSize = bufferSize

92− , connHTTP2 = isH2

93 }

72 }

94

73

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

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

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

151 setSocketCloseOnExec s

130 setSocketCloseOnExec s

152 -- NoDelay causes an error for AF_UNIX.

131 -- NoDelay causes an error for AF_UNIX.

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

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

154− conn <- socketConnection set s

133+ conn <- socketConnection s

155 return (conn, sa)

134 return (conn, sa)

156

135

157 closeListenSocket = close socket

136 closeListenSocket = close socket

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

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

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

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

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

288 -- exceptions are thrown.

267 -- exceptions are thrown.

289− handle (settingsOnException set Nothing) $

268+ handle (settingsOnException set Nothing) .

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

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

271+ withClosedRef $ \ref ->

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

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

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

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

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

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

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

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

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

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

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

299 -- fact that async exceptions are still masked.

281 -- fact that async exceptions are still masked.

300− bracket mkConn cleanUp (serve unmask)

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

301 where

283 where

284+ withClosedRef inner = newIORef False >>= inner

285+

286+ closeConn ref conn = do

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

288+ unless isClosed $ connClose conn

289+

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

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

303

291

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

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

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

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

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

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

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

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

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

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

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

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

309 -- allow async exceptions.

299 -- allow async exceptions.

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

315 -- above ensures the connection is closed.

305 -- above ensures the connection is closed.

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

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

317 where

307 where

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

308+ register = T.registerKillThread (timeoutManager ii)

309+ (closeConn ref conn)

319 cancel = T.cancel

310 cancel = T.cancel

320

311

321 onOpen adr = increase counter >> settingsOnOpen set adr

312 onOpen adr = increase counter >> settingsOnOpen set adr

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

342 istatus <- newIORef False

333 istatus <- newIORef False

343 if settingsHTTP2Enabled settings && h2 then do

334 if settingsHTTP2Enabled settings && h2 then do

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

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

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

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

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

354 -- fixme: origAddr

337 -- fixme: origAddr

355 checkTLS

338 checkTLS

356− setConnHTTP2 conn True

357− http2 conn transport ii origAddr settings recvN sendBS app

339+ http2 conn ii origAddr settings recvN app

358 else do

340 else do

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

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

360 writeIORef istatus True

342 writeIORef istatus True

361 leftoverSource src bs

343 leftoverSource src bs

362 addr <- getProxyProtocolAddr src

344 addr <- getProxyProtocolAddr src

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

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

364− case () of

346+ case fromException e of

365− ()

366− -- See comment below referencing

347+ -- See comment below referencing

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

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

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

349+ Just NoKeepAliveRequest -> return ()

369− -- No valid request

350+ Nothing -> do

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

371− | otherwise -> do

372− _ <- sendErrorResponse (dummyreq addr) istatus e

351+ _ <- sendErrorResponse (dummyreq addr) istatus e

373− throwIO e

352+ throwIO e

374

353

375 where

354 where

376 getProxyProtocolAddr src =

355 getProxyProtocolAddr src =

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

429 errorResponse e = settingsOnExceptionResponse settings e

408 errorResponse e = settingsOnExceptionResponse settings e

430

409

431 http1 firstRequest addr istatus src = do

410 http1 firstRequest addr istatus src = do

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

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

412+ let req = req' { isSecure = isTransportSecure transport }

433 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

413 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

434 `E.catch` \e -> do

414 `E.catch` \e -> do

435 settingsOnException settings (Just req) e

415 settingsOnException settings (Just req) e

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

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

76 --

77 -- Since 2.0.3

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

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

80− -- to close a listen socket.

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

82− --

83− -- Default: no action

84− --

85− -- Since 3.0.1

86 , settingsServerName :: ByteString

79 , settingsServerName :: ByteString

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

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

88 --

81 --

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

94 , settingsProxyProtocol :: ProxyProtocol

87 , settingsProxyProtocol :: ProxyProtocol

95 -- ^ Specify usage of the PROXY protocol.

88 -- ^ Specify usage of the PROXY protocol.

96 --

89 --

97− -- Since 3.0.5

90+ -- Since 3.0.5.

98 , settingsSlowlorisSize :: Int

91 , settingsSlowlorisSize :: Int

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

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

100 --

93 --

101− -- Since 3.1.2

94+ -- Since 3.1.2.

102 , settingsHTTP2Enabled :: Bool

95 , settingsHTTP2Enabled :: Bool

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

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

104 --

97 --

105− -- Since 3.1.7

98+ -- Since 3.1.7.

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

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

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

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

108 --

101 --

109− -- Since 3.1.10

102+ -- Since 3.X.X.

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

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

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

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

112 --

105 --

113− -- Since 3.2.7

106+ -- Since 3.X.X.

114 , settingsGracefulShutdownTimeout :: Maybe Int

107 , settingsGracefulShutdownTimeout :: Maybe Int

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

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

116 -- a graceful shutdown of the web server.

109 -- a graceful shutdown of the web server.

117 --

110 --

118 -- Since 3.2.8

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

135 }

112 }

136

113

137-- | Specify usage of the PROXY protocol.

114-- | Specify usage of the PROXY protocol.

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

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

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

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

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

170 , settingsGracefulShutdownTimeout = Nothing

147 , settingsGracefulShutdownTimeout = Nothing

171− , settingsGracefulCloseTimeout1 = 0

172− , settingsGracefulCloseTimeout2 = 2000

173− , settingsMaxTotalHeaderLength = 50 * 1024

174 }

148 }

175

149

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

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

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

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

8import qualified Data.ByteString as S

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

10import Data.Typeable (Typeable)

11−import Data.X509

12import Foreign.Ptr (Ptr)

11import Foreign.Ptr (Ptr)

13import System.Posix.Types (Fd)

12import System.Posix.Types (Fd)

14import qualified System.TimeManager as T

13import qualified System.TimeManager as T

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

123 , connWriteBuffer :: Buffer

122 , connWriteBuffer :: Buffer

124 -- | The size of the write buffer.

123 -- | The size of the write buffer.

125 , connBufferSize :: BufSize

124 , connBufferSize :: BufSize

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

127− , connHTTP2 :: IORef Bool

128 }

125 }

129

126

130−getConnHTTP2 :: Connection -> IO Bool

131−getConnHTTP2 conn = readIORef (connHTTP2 conn)

132−

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

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

135−

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

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

137

128

138data InternalInfo = InternalInfo {

129data InternalInfo = InternalInfo {

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

180 , tlsMinorVersion :: Int

171 , tlsMinorVersion :: Int

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

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

182 , tlsChiperID :: Word16

173 , tlsChiperID :: Word16

183− , tlsClientCertificate :: Maybe CertificateChain

184 } -- ^ Encrypted channel: TLS or SSL

174 } -- ^ Encrypted channel: TLS or SSL

185

175

186isTransportSecure :: Transport -> Bool

176isTransportSecure :: Transport -> Bool

warp/test/FileSpec.hs+1−1

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

21 let WithBody s hs off len = ans

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

23 ans' = WithBody s hs' off len

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

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

25

26spec :: Spec

27spec = do

warp/test/RequestSpec.hs+7−11

@@ -7,7 +7,6 @@ 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)

11import Test.Hspec

10import Test.Hspec

12import Test.Hspec.QuickCheck

11import Test.Hspec.QuickCheck

13import qualified Data.ByteString as S

12import qualified Data.ByteString as S

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

18main :: IO ()

17main :: IO ()

19main = hspec spec

18main = hspec spec

20

19

21−defaultMaxTotalHeaderLength :: Int

22−defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23−

24spec :: Spec

20spec :: Spec

25spec = do

21spec = do

26 describe "headerLines" $ do

22 describe "headerLines" $ do

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

67 describe "headerLines" $ do

63 describe "headerLines" $ do

68 it "can handle a nomarl case" $ do

64 it "can handle a nomarl case" $ do

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

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

70− x <- headerLines defaultMaxTotalHeaderLength True src

66+ x <- headerLines True src

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

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

72

68

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

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

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

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

75− x <- headerLines defaultMaxTotalHeaderLength True src

71+ x <- headerLines True src

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

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

77

73

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

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

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

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

80− x <- headerLines defaultMaxTotalHeaderLength True src

76+ x <- headerLines True src

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

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

82

78

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

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

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

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

85− x <- headerLines defaultMaxTotalHeaderLength True src

81+ x <- headerLines True src

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

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

87

83

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

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

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

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

90− x <- headerLines defaultMaxTotalHeaderLength True src

86+ x <- headerLines True src

91 x `shouldBe` []

87 x `shouldBe` []

92− y <- headerLines defaultMaxTotalHeaderLength True src

88+ y <- headerLines True src

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

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

94

90

95 where

91 where

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

115 writeIORef ref z

111 writeIORef ref z

116 return y

112 return y

117 src' <- mkSource src

113 src' <- mkSource src

118− res <- headerLines defaultMaxTotalHeaderLength True src'

114+ res <- headerLines True src'

119 return (res, src')

115 return (res, src')

120

116

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

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

warp/test/ResponseSpec.hs+15−11

@@ -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, msWrite, msRead, withMySocket)

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

14import Test.Hspec

15

16main :: IO ()

@@ -20,13 +20,15 @@ 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 $ withMySocket $ \ms -> do

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

24+ handle <- connectTo port

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

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

25− msWrite ms "Range: bytes="

26+ msWrite handle "Range: bytes="

26− msWrite ms range

27+ msWrite handle range

27− msWrite ms "\r\n\r\n"

28+ msWrite handle "\r\n\r\n"

28 threadDelay 10000

29 threadDelay 10000

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

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

31+ msClose handle

30 last bss `shouldBe` out

32 last bss `shouldBe` out

31 let hs = mapMaybe toHeader bss

33 let hs = mapMaybe toHeader bss

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

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

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

44 -> Integer -- ^ byte count

46 -> Integer -- ^ byte count

45 -> String -- ^ expected output

47 -> String -- ^ expected output

46 -> Spec

48 -> Spec

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

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

50+ handle <- connectTo port

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

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

49 threadDelay 10000

52 threadDelay 10000

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

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

54+ msClose handle

51 out `shouldBe` last bss

55 out `shouldBe` last bss

52 let hs = mapMaybe toHeader bss

56 let hs = mapMaybe toHeader bss

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

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

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

83 it "discards empty lines" $ do

87 it "discards empty lines" $ do

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

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

85

89

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

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

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

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

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

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

89

93

warp/test/RunSpec.hs+47−38

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

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3

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

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

5

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

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

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

37

38data MySocket = MySocket

39 { msSocket :: !Socket

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

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

41 }

42

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

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

70msClose = Network.Socket.close . msSocket

71

72connectTo :: Int -> IO MySocket

73−connectTo port = do

73+connectTo port = MySocket

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

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

75− ref <- I.newIORef mempty

75+ <*> 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

83

76

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

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

85incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

78incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

@@ -157,7 +150,8 @@ runTest :: Int -- ^ expected number of requests

157 -> IO ()

150 -> IO ()

158runTest expected app chunks = do

151runTest expected app chunks = do

159 ref <- I.newIORef (Right 0)

152 ref <- I.newIORef (Right 0)

160− withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

153+ withApp defaultSettings (app ref) $ \port -> do

154+ ms <- connectTo port

161 forM_ chunks $ \chunk -> msWrite ms chunk

155 forM_ chunks $ \chunk -> msWrite ms chunk

162 _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

156 _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

163 res <- I.readIORef ref

157 res <- I.readIORef ref

@@ -174,9 +168,10 @@ runTerminateTest :: InvalidRequest

174runTerminateTest expected input = do

168runTerminateTest expected input = do

175 ref <- I.newIORef Nothing

169 ref <- I.newIORef Nothing

176 let onExc _ = I.writeIORef ref . Just

170 let onExc _ = I.writeIORef ref . Just

177− withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

171+ withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

172+ handle <- connectTo port

178− msWrite ms input

173+ msWrite handle input

179− msClose ms -- explicitly

174+ msClose handle

180 threadDelay 1000

175 threadDelay 1000

181 res <- I.readIORef ref

176 res <- I.readIORef ref

182 show res `shouldBe` show (Just expected)

177 show res `shouldBe` show (Just expected)

@@ -247,11 +242,13 @@ spec = do

247 let app req f = do

242 let app req f = do

248 liftIO $ I.writeIORef iheaders $ requestHeaders req

243 liftIO $ I.writeIORef iheaders $ requestHeaders req

249 f $ responseLBS status200 [] ""

244 f $ responseLBS status200 [] ""

250− withApp defaultSettings app $ withMySocket $ \ms -> do

245+ withApp defaultSettings app $ \port -> do

246+ handle <- connectTo port

251 let input = S.concat

247 let input = S.concat

252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

248 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

253 ]

249 ]

254− msWrite ms input

250+ msWrite handle input

251+ msClose handle

255 threadDelay 1000

252 threadDelay 1000

256 headers <- I.readIORef iheaders

253 headers <- I.readIORef iheaders

257 headers `shouldBe`

254 headers `shouldBe`

@@ -262,11 +259,13 @@ spec = do

262 let app req f = do

259 let app req f = do

263 liftIO $ I.writeIORef iheaders $ requestHeaders req

260 liftIO $ I.writeIORef iheaders $ requestHeaders req

264 f $ responseLBS status200 [] ""

261 f $ responseLBS status200 [] ""

265− withApp defaultSettings app $ withMySocket $ \ms -> do

262+ withApp defaultSettings app $ \port -> do

263+ handle <- connectTo port

266 let input = S.concat

264 let input = S.concat

267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

265 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

268 ]

266 ]

269− msWrite ms input

267+ msWrite handle input

268+ msClose handle

270 threadDelay 1000

269 threadDelay 1000

271 headers <- I.readIORef iheaders

270 headers <- I.readIORef iheaders

272 headers `shouldBe`

271 headers `shouldBe`

@@ -282,14 +281,16 @@ spec = do

282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

281 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

283 atomically $ modifyTVar countVar (+ 1)

282 atomically $ modifyTVar countVar (+ 1)

284 f $ responseLBS status200 [] ""

283 f $ responseLBS status200 [] ""

285− withApp defaultSettings app $ withMySocket $ \ms -> do

284+ withApp defaultSettings app $ \port -> do

285+ handle <- connectTo port

286 let input = S.concat

287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

288 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

289 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

290 , "b\r\nHello World\r\n0\r\n\r\n"

291 ]

292− msWrite ms input

292+ msWrite handle input

293+ msClose handle

293 atomically $ do

294 atomically $ do

294 count <- readTVar countVar

295 count <- readTVar countVar

295 check $ count == 2

296 check $ count == 2

@@ -306,12 +307,14 @@ spec = do

306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307 atomically $ modifyTVar countVar (+ 1)

308 atomically $ modifyTVar countVar (+ 1)

308 f $ responseLBS status200 [] ""

309 f $ responseLBS status200 [] ""

309− withApp defaultSettings app $ withMySocket $ \ms -> do

310+ withApp defaultSettings app $ \port -> do

311+ handle <- connectTo port

310 let input = concat $ replicate 2 $

312 let input = concat $ replicate 2 $

311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

313 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

312 (replicate 50 "5\r\n12345\r\n") ++

314 (replicate 50 "5\r\n12345\r\n") ++

313 ["0\r\n\r\n"]

315 ["0\r\n\r\n"]

314− mapM_ (msWrite ms) input

316+ mapM_ (msWrite handle) input

317+ msClose handle

315 atomically $ do

318 atomically $ do

316 count <- readTVar countVar

319 count <- readTVar countVar

317 check $ count == 2

320 check $ count == 2

@@ -327,14 +330,16 @@ spec = do

327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

330 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

328 atomically $ modifyTVar countVar (+ 1)

331 atomically $ modifyTVar countVar (+ 1)

329 f $ responseLBS status200 [] ""

332 f $ responseLBS status200 [] ""

330− withApp defaultSettings app $ withMySocket $ \ms -> do

333+ withApp defaultSettings app $ \port -> do

334+ handle <- connectTo port

331 let input = S.concat

335 let input = S.concat

332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

336 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

333 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

337 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

334 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

338 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

335 , "b\r\nHello World\r\n0\r\n\r\n"

339 , "b\r\nHello World\r\n0\r\n\r\n"

336 ]

340 ]

337− mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

341+ mapM_ (msWrite handle) $ map S.singleton $ S.unpack input

342+ msClose handle

338 atomically $ do

343 atomically $ do

339 count <- readTVar countVar

344 count <- readTVar countVar

340 check $ count == 2

345 check $ count == 2

@@ -355,18 +360,20 @@ spec = do

355 E.throwIO (e :: E.SomeException)

360 E.throwIO (e :: E.SomeException)

356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

361 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

357 f $ responseLBS status200 [] ""

362 f $ responseLBS status200 [] ""

358− withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

363+ withApp (setTimeout 1 defaultSettings) app $ \port -> do

359 let bs1 = S.replicate 2048 88

364 let bs1 = S.replicate 2048 88

360 bs2 = "This is short"

365 bs2 = "This is short"

361 bs = S.append bs1 bs2

366 bs = S.append bs1 bs2

367+ handle <- connectTo port

362− msWrite ms "POST / HTTP/1.1\r\n"

368+ msWrite handle "POST / HTTP/1.1\r\n"

363− msWrite ms "content-length: "

369+ msWrite handle "content-length: "

364− msWrite ms $ S8.pack $ show $ S.length bs

370+ msWrite handle $ S8.pack $ show $ S.length bs

365− msWrite ms "\r\n\r\n"

371+ msWrite handle "\r\n\r\n"

366 threadDelay 100000

372 threadDelay 100000

367− msWrite ms bs1

373+ msWrite handle bs1

368 threadDelay 100000

374 threadDelay 100000

369− msWrite ms bs2

375+ msWrite handle bs2

376+ msClose handle

370 threadDelay 5000000

377 threadDelay 5000000

371 front <- I.readIORef ifront

378 front <- I.readIORef ifront

372 S.concat (front []) `shouldBe` bs

379 S.concat (front []) `shouldBe` bs

@@ -382,7 +389,8 @@ spec = do

382 loop

389 loop

383 loop

390 loop

384 doubleBS = S.concatMap $ \w -> S.pack [w, w]

391 doubleBS = S.concatMap $ \w -> S.pack [w, w]

385− withApp defaultSettings app $ withMySocket $ \ms -> do

392+ withApp defaultSettings app $ \port -> do

393+ ms <- connectTo port

386 msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

394 msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

387 timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

395 timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

388 msWrite ms "67890"

396 msWrite ms "67890"

@@ -410,14 +418,15 @@ spec = do

410 atomically $ modifyTVar countVar (+ 1)

418 atomically $ modifyTVar countVar (+ 1)

411 loop

419 loop

412 loop

420 loop

413− withApp defaultSettings app $ withMySocket $ \ms -> do

421+ withApp defaultSettings app $ \port -> do

422+ (sock, _addr) <- getSocketTCP "127.0.0.1" port

414− msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

423+ sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

415 threadDelay 10000

424 threadDelay 10000

416− msWrite ms "5\r\nhello\r\n0\r\n\r\n"

425+ sendAll sock "5\r\nhello\r\n0\r\n\r\n"

417 atomically $ do

426 atomically $ do

418 count <- readTVar countVar

427 count <- readTVar countVar

419 check $ count >= 1

428 check $ count >= 1

420− bs <- safeRecv (msSocket ms) 4096 -- must not use msRead

429+ bs <- safeRecv sock 4096

421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

430 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

422

431

423 it "streaming response with length" $ do

432 it "streaming response with length" $ do

warp/warp.cabal+1−4

@@ -1,5 +1,5 @@

1Name: warp

2−Version: 3.3.9

2+Version: 3.2.28

3Synopsis: A fast, light-weight web server for WAI applications.

4License: MIT

5License-file: LICENSE

@@ -56,7 +56,6 @@ Library

56 , vault >= 0.3

57 , wai >= 3.2 && < 3.3

58 , word8

59− , x509

60 if impl(ghc < 8)

59 if impl(ghc < 8)

61 Build-Depends: semigroups

60 Build-Depends: semigroups

62 if flag(network-bytestring)

61 if flag(network-bytestring)

@@ -212,7 +211,6 @@ Test-Suite spec

212 , vault

211 , vault

213 , wai >= 3.2 && < 3.3

212 , wai >= 3.2 && < 3.3

214 , word8

213 , word8

215− , x509

216 -- Build-Tool-Depends: hspec-discover:hspec-discover

214 -- Build-Tool-Depends: hspec-discover:hspec-discover

217 if impl(ghc < 8)

215 if impl(ghc < 8)

218 Build-Depends: semigroups

216 Build-Depends: semigroups

@@ -251,7 +249,6 @@ Benchmark parser

251 , network

249 , network

252 , time-manager

250 , time-manager

253 , unix-compat

251 , unix-compat

254− , x509

255 if impl(ghc < 8)

252 if impl(ghc < 8)

256 Build-Depends: semigroups

253 Build-Depends: semigroups

257

254