master..89f81ce · typeable/wai

.azure/azure-linux-template.ymldeleted−93

since splitsnapshots

unifiedsplit

@@ -1,93 +0,0 @@

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

5− vmImage: ${{ parameters.vmImage }}

6− strategy:

7− matrix:

8− stack-lts-11:

9− BUILD: stack

10− STACK_YAML: stack-lts-11.yaml

11− ARGS: "--resolver lts-11"

12− stack-lts-12:

13− BUILD: stack

14− STACK_YAML: stack-lts-12.yaml

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

16− stack-lts-14:

17− BUILD: stack

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

19− stack-nightly:

20− BUILD: stack

21− STACK_YAML: stack-nightly.yaml

22− ARGS: "--resolver nightly"

23− cabal-8.2.2:

24− BUILD: cabal

25− GHCVER: 8.4.4

26− CABALVER: 2.0

27− cabal-8.4.4:

28− BUILD: cabal

29− GHCVER: 8.4.4

30− CABALVER: 2.2

31− cabal-8.6.5:

32− BUILD: cabal

33− GHCVER: 8.6.5

34− CABALVER: 2.4

35− maxParallel: 6

36− steps:

37− - script: |

38− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;

39− mkdir -p ~/.local/bin

40− curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

41− case "$BUILD" in

42− cabal)

43− sudo add-apt-repository -y ppa:hvr/ghc

44− sudo apt-get update

45− sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER

46− # See note here: https://github.com/haskell-CI/haskell-ci#alex--happy-with-ghc--78

47− if [ "$GHCVER" = "head" ] || [ "${GHCVER%.*}" = "7.8" ] || [ "${GHCVER%.*}" = "7.10" ]; then

48− sudo apt-get install happy-1.19.4 alex-3.1.3

49− export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH

50− else

51− sudo apt-get install happy alex

52− fi

53− export PATH=$HOME/.local/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

54− cabal --version

55− cabal update

56− PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')

57− cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES

58− ;;

59− *)

60− export PATH=$HOME/.local/bin:$PATH

61− stack --install-ghc $ARGS test --bench --only-dependencies

62− ;;

63− esac

64− set -ex

65− case "$BUILD" in

66− cabal)

67− cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES

68−

69− ORIGDIR=$(pwd)

70− for dir in $PACKAGES

71− do

72− cd $dir

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

74− cabal sdist

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

76− SRC_TGZ=$PKGVER.tar.gz

77− cd dist

78− tar zxfv "$SRC_TGZ"

79− cd "$PKGVER"

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

81− cabal build

82− cabal test --show-details=streaming

83− cd $ORIGDIR

84− done

85− ;;

86− *)

87− stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps

88− ;;

89− esac

90− set +ex

91− env:

92− OS_NAME: ${{ parameters.os }}

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

.azure/azure-osx-template.ymldeleted−30

@@ -1,30 +0,0 @@

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

5− vmImage: ${{ parameters.vmImage }}

6− strategy:

7− matrix:

8− stack-lts-11:

9− BUILD: stack

10− STACK_YAML: stack-lts-11.yaml

11− ARGS: "--resolver lts-11"

12− stack-lts-12:

13− BUILD: stack

14− STACK_YAML: stack-lts-12.yaml

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

16− stack-lts-14:

17− BUILD: stack

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

19− maxParallel: 3

20− steps:

21− - script: |

22− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;

23− mkdir -p ~/.local/bin

24− curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;

25− export PATH=$HOME/.local/bin:$PATH

26− stack --install-ghc $ARGS test --bench --only-dependencies

27− stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps

28− env:

29− OS_NAME: ${{ parameters.os }}

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

.azure/azure-pipelines.ymldeleted−30

@@ -1,30 +0,0 @@

1−# This is the complex Azure configuration, which is intended for use

2−# on open source libraries which need compatibility across multiple GHC

3−# versions, must work with cabal-install, and should be

4−# cross-platform. For more information and other options, see:

5−#

6−# https://docs.haskellstack.org/en/stable/azure_ci/

7−#

8−# Copy these contents into the root directory of your Github project in a file

9−# named azure-pipelines.yml

10−#

11−# For better organization, you split various jobs into seprate parts

12−# and each of them are controlled via individual file.

13−jobs:

14−- template: azure-linux-template.yml

15− parameters:

16− name: Linux

17− vmImage: ubuntu-16.04

18− os: linux

19−

20−- template: azure-osx-template.yml

21− parameters:

22− name: macOS

23− vmImage: macOS-10.13

24− os: osx

25−

26−- template: azure-windows-template.yml

27− parameters:

28− name: Windows

29− vmImage: vs2017-win2016

30− os: windows

.azure/azure-windows-template.ymldeleted−23

@@ -1,23 +0,0 @@

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

5− vmImage: ${{ parameters.vmImage }}

6− strategy:

7− matrix:

8− stack-lts-14:

9− BUILD: stack

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

11− maxParallel: 3

12− steps:

13− - bash: |

14− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;

15− curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip

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

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

21− env:

22− OS_NAME: ${{ parameters.os }}

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

.gitignore−2

@@ -8,5 +8,3 @@ tarballs/

8.cabal-sandbox/

9cabal.sandbox.config

10.stack-work/

11−*~

12−stack*.yaml.lock

.travis.ymlnew file+215

@@ -0,0 +1,215 @@

1+# This is the complex Travis configuration, which is intended for use

2+# on open source libraries which need compatibility across multiple GHC

3+# versions, must work with cabal-install, and should be

4+# cross-platform. For more information and other options, see:

5+#

6+# https://docs.haskellstack.org/en/stable/travis_ci/

7+#

8+# Copy these contents into the root directory of your Github project in a file

9+# named .travis.yml

10+

11+# Use new container infrastructure to enable caching

12+sudo: false

13+

14+# Choose a lightweight base image; we provide our own build tools.

15+language: c

16+

17+# Caching so the next build will be fast too.

18+cache:

19+ directories:

20+ - $HOME/.ghc

21+ - $HOME/.cabal

22+ - $HOME/.stack

23+

24+# The different configurations we want to test. We have BUILD=cabal which uses

25+# cabal-install, and BUILD=stack which uses Stack. More documentation on each

26+# of those below.

27+#

28+# We set the compiler values here to tell Travis to use a different

29+# cache file per set of arguments.

30+#

31+# If you need to have different apt packages for each combination in the

32+# matrix, you can use a line such as:

33+# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

34+matrix:

35+ include:

36+ - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7

37+ compiler: ": #GHC 7.10.3"

38+ addons: {apt: {packages: [libfcgi-dev,cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

39+ - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7

40+ compiler: ": #GHC 8.0.2"

41+ addons: {apt: {packages: [libfcgi-dev,cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

42+ - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7

43+ compiler: ": #GHC 8.2.2"

44+ addons: {apt: {packages: [libfcgi-dev,cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

45+

46+ # Build with the newest GHC and cabal-install. This is an accepted failure,

47+ # see below.

48+ - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7

49+ compiler: ": #GHC HEAD"

50+ addons: {apt: {packages: [libfcgi-dev,cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

51+

52+ # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS

53+ # variable, such as using --stack-yaml to point to a different file.

54+ #- env: BUILD=stack ARGS=""

55+ # compiler: ": #stack default"

56+ # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

57+

58+ #- env: BUILD=stack ARGS="--resolver lts-2"

59+ # compiler: ": #stack 7.8.4"

60+ # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

61+

62+ #- env: BUILD=stack ARGS="--resolver lts-3"

63+ # compiler: ": #stack 7.10.2"

64+ # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

65+

66+ - env: BUILD=stack ARGS="--resolver lts-6"

67+ compiler: ": #stack 7.10.3"

68+ addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

69+

70+ #- env: BUILD=stack ARGS="--resolver lts-7"

71+ # compiler: ": #stack 8.0.1"

72+ # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

73+

74+ - env: BUILD=stack ARGS="--resolver lts-9"

75+ compiler: ": #stack 8.0.2"

76+ addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

77+

78+ - env: BUILD=stack ARGS="--resolver lts-10"

79+ compiler: ": #stack 8.2.2"

80+ addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

81+

82+ # Nightly builds are allowed to fail

83+ - env: BUILD=stack ARGS="--resolver nightly"

84+ compiler: ": #stack nightly"

85+ addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}

86+

87+ # Build on OS X in addition to Linux

88+ #- env: BUILD=stack ARGS=""

89+ # compiler: ": #stack default osx"

90+ # os: osx

91+

92+ # Travis includes an OS X which is incompatible with GHC 7.8.4

93+ #- env: BUILD=stack ARGS="--resolver lts-2"

94+ # compiler: ": #stack 7.8.4 osx"

95+ # os: osx

96+

97+ #- env: BUILD=stack ARGS="--resolver lts-3"

98+ # compiler: ": #stack 7.10.2 osx"

99+ # os: osx

100+

101+ - env: BUILD=stack ARGS="--resolver lts-6"

102+ compiler: ": #stack 7.10.3 osx"

103+ os: osx

104+

105+ #- env: BUILD=stack ARGS="--resolver lts-7"

106+ # compiler: ": #stack 8.0.1 osx"

107+ # os: osx

108+

109+ - env: BUILD=stack ARGS="--resolver lts-9"

110+ compiler: ": #stack 8.0.2 osx"

111+ os: osx

112+

113+ - env: BUILD=stack ARGS="--resolver lts-10"

114+ compiler: ": #stack 8.2.2 osx"

115+ os: osx

116+

117+ - env: BUILD=stack ARGS="--resolver nightly"

118+ compiler: ": #stack nightly osx"

119+ os: osx

120+

121+ allow_failures:

122+ - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7

123+ - env: BUILD=stack ARGS="--resolver nightly"

124+

125+before_install:

126+# Using compiler above sets CC to an invalid value, so unset it

127+- unset CC

128+

129+# We want to always allow newer versions of packages when building on GHC HEAD

130+- CABALARGS=""

131+- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi

132+

133+# Download and unpack the stack executable

134+- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH

135+- mkdir -p ~/.local/bin

136+- |

137+ if [ `uname` = "Darwin" ]

138+ then

139+ travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin

140+

141+ # brew no longer has fcgi

142+ # brew install fcgi

143+ grep -v wai-handler-fastcgi < stack.yaml > tmp

144+ mv tmp stack.yaml

145+ else

146+ travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

147+ fi

148+

149+ # Use the more reliable S3 mirror of Hackage

150+ mkdir -p $HOME/.cabal

151+ echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config

152+ echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config

153+

154+ if [ "$CABALVER" != "1.16" ]

155+ then

156+ echo 'jobs: $ncpus' >> $HOME/.cabal/config

157+ fi

158+

159+install:

160+- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

161+- if [ -f configure.ac ]; then autoreconf -i; fi

162+- |

163+ set -ex

164+ case "$BUILD" in

165+ stack)

166+ # Avoid out of memory condition

167+ stack --no-terminal --install-ghc $ARGS build Cabal

168+

169+ stack --no-terminal --install-ghc $ARGS test --only-dependencies

170+ ;;

171+ cabal)

172+ cabal --version

173+ travis_retry cabal update

174+

175+ # Get the list of packages from the stack.yaml file

176+ PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')

177+

178+ # Due to dependency on wai-logger (which depends on some packages here),

179+ # we can't build just dependencies

180+ #

181+ # cabal install --only-dependencies --enable-tests --force-reinstalls --ghc-options=-O0 --max-backjumps=-1 $CABALARGS $PACKAGES

182+ cabal install hspec-discover

183+ ;;

184+ esac

185+ set +ex

186+

187+script:

188+- |

189+ set -ex

190+ case "$BUILD" in

191+ stack)

192+ stack --no-terminal $ARGS test --haddock --no-haddock-deps

193+ ;;

194+ cabal)

195+ cabal install --enable-tests --force-reinstalls --ghc-options=-O0 --max-backjumps=-1 $CABALARGS $PACKAGES

196+

197+ ORIGDIR=$(pwd)

198+ for dir in $PACKAGES

199+ do

200+ cd $dir

201+ cabal check || [ "$CABALVER" == "1.16" ]

202+ # Takes too long, see https://github.com/yesodweb/wai/issues/665

203+ #cabal sdist

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

205+ #SRC_TGZ=$PKGVER.tar.gz

206+ #cd dist

207+ #tar zxfv "$SRC_TGZ"

208+ #cd "$PKGVER"

209+ #cabal configure --enable-tests

210+ #cabal build

211+ cd $ORIGDIR

212+ done

213+ ;;

214+ esac

215+ set +ex

README.md+1−1

@@ -10,4 +10,4 @@ Code can be written that works with any web framework targeting WAI.

10

11[Haddock Documentation](http://hackage.haskell.org/package/wai)

12

13−[![Build Status](https://dev.azure.com/yesodweb/wai/_apis/build/status/yesodweb.wai?branchName=master)](https://dev.azure.com/yesodweb/wai/_build/latest?definitionId=1&branchName=master)

13+[![Build Status](https://travis-ci.org/yesodweb/wai.svg?branch=master)](https://travis-ci.org/yesodweb/wai)

auto-update/ChangeLog.md−14

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

1−# ChangeLog for auto-update

2−

3−## 0.1.6

4−

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

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

7−

8−## 0.1.5

9−

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

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

12−

13## 0.1.4.1

1## 0.1.4.1

14

2

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

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

16 Improve documentation for `reaperAction` function.

4 Improve documentation for `reaperAction` function.

17−* [#732](https://github.com/yesodweb/wai/pull/732):

18− Fixed memory leak in `reaperAdd` function.

19

5

20## 0.1.4

6## 0.1.4

21

7

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/Control/Reaper.hs+2−2

@@ -113,7 +113,7 @@ data Reaper workload item = Reaper {

113

114-- | State of reaper.

115data State workload = NoReaper -- ^ No reaper thread

116− | Workload !workload -- ^ The current jobs

116+ | Workload workload -- ^ The current jobs

117

118-- | Create a reaper addition function. This function can be used to add

119-- new items to the workload. Spawning of reaper threads will be handled

@@ -154,7 +154,7 @@ add settings@ReaperSettings{..} stateRef tidRef item =

154 next <- atomicModifyIORef' stateRef cons

155 next

156 where

157− cons NoReaper = let wl = reaperCons item reaperEmpty

157+ cons NoReaper = let !wl = reaperCons item reaperEmpty

158 in (Workload wl, spawn settings stateRef tidRef)

159 cons (Workload wl) = let wl' = reaperCons item wl

160 in (Workload wl', return ())

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

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

1name: auto-update

2−version: 0.1.6

2+version: 0.1.4.1

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

24 default-language: Haskell2010

23 default-language: Haskell2010

25− if impl(ghc >= 8)

26− default-extensions: Strict StrictData

27

24

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

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

29

26

30−test-suite spec

27+-- test-suite spec

31− main-is: Spec.hs

28+-- main-is: Spec.hs

32− other-modules: Control.AutoUpdateSpec

29+-- other-modules: Control.AutoUpdateSpec

33− Control.DebounceSpec

34− Control.ReaperSpec

30+-- Control.ReaperSpec

35− hs-source-dirs: test

31+-- hs-source-dirs: test

36− type: exitcode-stdio-1.0

32+-- type: exitcode-stdio-1.0

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

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

38− default-language: Haskell2010

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

hcar-wai.texnew file+54

@@ -0,0 +1,54 @@

1+% WAI-KW.tex

2+\begin{hcarentry}{WAI}

3+\label{wai}

4+\report{Kazu Yamamoto}%05/18

5+\participants{Michael Snoyman, Greg Weber}

6+\status{stable}

7+\makeheader

8+

9+WAI (Web Application Interface) is an application interface between web

10+applications and handlers in Haskell. The \texttt{Application} data type is

11+defined as follows:

12+

13+\begin{verbatim}

14+type Application

15+ = Request

16+ -> (Response -> IO ResponseReceived)

17+ -> IO ResponseReceived

18+\end{verbatim}

19+

20+That is, a WAI application takes two arguments: a \texttt{Request} and a

21+function to send a \texttt{Response}. So, the typical behavior of WAI

22+application is processing a request, generating a response and passing the

23+response to the function.

24+

25+Historically speaking, this interface made possible to develop handlers other

26+than HTTP. The WAI applications can run through FastCGI

27+(wai-handler-fastcgi), run as stand-alone (wai-handler-webkit), etc. But the

28+most popular handler is based on HTTP, of course. The major HTTP handler for

29+WAI is Warp which now provides both HTTP/1.1 and HTTP/2. TLS (warp-tls) is

30+also available. New transports such as WebSocket (wai-websocket) and Event

31+Source (wai-extra) can be implemented, too.

32+

33+It is possible to develop WAI applications directly. For instance, Hoogle and

34+Mighttpd2 take this way. However, you may want to use web application

35+frameworks such as Apiary, MFlow, rest, Servant, Scotty, Spock, Yesod, etc.

36+

37+WAI also provides \texttt{Middleware}:

38+

39+\begin{verbatim}

40+type Middleware = Application -> Application

41+\end{verbatim}

42+

43+WAI middleware can inspect and transform a request, for example by

44+automatically gzipping a response or logging a request (wai-extra).

45+

46+Since the last HCAR, WAI started using Builder of ByteString instead of

47+Builder of blaze-builder. Because they are identical, no backward

48+compatibility issue happens.

49+

50+\FurtherReading

51+\begin{compactitem}

52+\item\url{https://groups.google.com/d/forum/haskell-wai}

53+\end{compactitem}

54+\end{hcarentry}

hcar-warp.texnew file+28

@@ -0,0 +1,28 @@

1+% Warp-KW.tex

2+\begin{hcarentry}[updated]{Warp}

3+\label{warp}

4+\report{Kazu Yamamoto}%05/18

5+\participants{Michael Snoyman}

6+\status{stable}

7+\makeheader

8+

9+Warp is a high performance, easy to deploy HTTP handler for WAI~\cref{wai}.

10+Its supports both HTTP/1.1 and HTTP/2.

11+

12+Since the last HCAR, no major changes were made.

13+

14+\FurtherReading

15+\begin{compactitem}

16+\item``Warp: A Haskell Web Server''

17+ \begin{compactitem}

18+ \item the May/June 2011 issue of IEEE Internet Computing

19+ \item Issue page: \url{http://www.computer.org/portal/web/csdl/abs/mags/ic/2011/03/mic201103toc.htm}

20+ \item PDF: \url{http://steve.vinoski.net/pdf/IC-Warp\_a\_Haskell\_Web\_Server.pdf}

21+ \end{compactitem}

22+\item ``Warp''

23+ \begin{compactitem}

24+ \item The Performance of Open Source Applications

25+ \item HTML: \url{http://www.aosabook.org/en/posa/warp.html}

26+ \end{compactitem}

27+\end{compactitem}

28+\end{hcarentry}

mime-types/ChangeLog.md−4

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

1−## 0.1.0.9

2−

3−* Add mjs mime type

4−

5## 0.1.0.8

1## 0.1.0.8

6

2

7* Add wasm mime type

3* Add wasm mime type

mime-types/Network/Mime.hs−1

@@ -531,7 +531,6 @@ defaultMimeMap = Map.fromAscList [

531 , ("mime", "message/rfc822")

532 , ("mj2", "video/mj2")

533 , ("mjp2", "video/mj2")

534− , ("mjs", "application/javascript")

535 , ("mk3d", "video/x-matroska")

534 , ("mk3d", "video/x-matroska")

536 , ("mka", "audio/x-matroska")

535 , ("mka", "audio/x-matroska")

537 , ("mks", "video/x-matroska")

536 , ("mks", "video/x-matroska")

mime-types/mime-types.cabal+1−1

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

1name: mime-types

2−version: 0.1.0.9

2+version: 0.1.0.8

3synopsis: Basic mime-type handling types and functions

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

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

sources.txtnew file+11

@@ -0,0 +1,11 @@

1+./wai

2+./wai-extra

3+./warp

4+./warp-tls

5+./wai-app-static

6+./wai-handler-fastcgi

7+./wai-handler-launch

8+./wai-websockets

9+./wai-conduit

10+./mime-types

11+./auto-update

stack-lts-11.yamldeleted−27

@@ -1,27 +0,0 @@

1−resolver: lts-11.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−flags:

14− wai-extra:

15− build-example: true

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

23−nix:

24− enable: false

25− packages:

26− - fcgi

27− - zlib

stack-lts-12.yamldeleted−26

@@ -1,26 +0,0 @@

1−resolver: lts-12.6

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

21−extra-deps:

22−- http2-2.0.0

23−- network-byte-order-0.1.1.0

24−- tls-1.5.3

25−- tls-session-manager-0.0.4

26−- x509-1.7.5

stack-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+17−7

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

1−resolver: lts-14.22

1+resolver: lts-10.0

2packages:

3- ./auto-update

4- ./mime-types

@@ -7,19 +7,29 @@ packages:

7- ./warp

8- ./warp-tls

9- ./wai-app-static

10+- ./wai-handler-fastcgi

10- ./wai-websockets

11- ./wai-websockets

11- ./wai-conduit

12- ./wai-conduit

12−- ./time-manager

13flags:

14 wai-extra:

15 build-example: true

16+extra-deps:

17+- bsb-http-chunked-0

18+- tls-session-manager-0.0.0.2

19+- psqueues-0.2.4.0

20+- streaming-commons-0.2.0.0

21+- wai-logger-2.3.2

22+- http-client-0.5.10

23+- websockets-0.12.4.0

24+- binary-0.8.5.1

16nix:

25nix:

17 enable: false

26 enable: false

18 packages:

27 packages:

19 - fcgi

28 - fcgi

20 - zlib

29 - zlib

21−extra-deps:

30+image:

22−- http2-2.0.0

31+ containers:

23−- network-byte-order-0.1.1.0

32+ - base: "fpco/pid1"

24−- tls-1.5.3

33+ name: "yesodweb/warp"

25−- tls-session-manager-0.0.4

34+ executables:

35+ - warp

time-manager/time-manager.cabaldeleted−19

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

1−Name: time-manager

2−Version: 0.0.0

3−Synopsis: Scalable timer

4−License: MIT

5−License-file: LICENSE

6−Author: Michael Snoyman and Kazu Yamamoto

7−Maintainer: kazu@iij.ad.jp

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

9−Category: System

10−Build-Type: Simple

11−Cabal-Version: >=1.8

12−Stability: Stable

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

14−

15−Library

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

17− , auto-update

18− Exposed-modules: System.TimeManager

19− Ghc-Options: -Wall

wai-app-static/ChangeLog.md−16

@@ -1,19 +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

12−

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

14−now. Previously this used to invoke the help option. That can be

15−reached via `--help` as before.

16−

17## 3.1.6.2

1## 3.1.6.2

18

2

19* Drop dependency on blaze-builder

3* Drop dependency on blaze-builder

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

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

@@ -94,7 +93,7 @@ args = Args

94-- Since 2.0.1

93-- Since 2.0.1

95runCommandLine :: (Args -> Middleware) -> IO ()

94runCommandLine :: (Args -> Middleware) -> IO ()

96runCommandLine middleware = do

95runCommandLine middleware = do

97− args@Args {..} <- execParser $ info (helperOption <*> args) fullDesc

96+ args@Args {..} <- execParser $ info (helper <*> args) fullDesc

98 let mime' = map (pack *** S8.pack) mime

97 let mime' = map (pack *** S8.pack) mime

99 let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap

98 let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap

100 docroot' <- canonicalizePath docroot

99 docroot' <- canonicalizePath docroot

@@ -111,8 +110,3 @@ runCommandLine middleware = do

111 { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index

110 { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index

112 , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName

111 , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName

113 }

112 }

114− where

115− helperOption :: Parser (a -> a)

116− helperOption =

117− abortOption ShowHelpText $

118− mconcat [long "help", help "Show this help text", hidden]

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

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

1name: wai-app-static

2−version: 3.1.7.1

2+version: 3.1.6.2

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

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

102 , temporary

103 , mockery

104 -- , containers

105− ghc-options: -Wall

105+ ghc-options: -Wall

106

107source-repository head

108 type: git

wai-conduit/Network/Wai/Conduit.hs+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-conduit/example/Main.hsdeleted−19

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

1−#!/usr/bin/env stack

2−-- stack --resolver lts-11.10 script

3−import Network.Wai

4−import Network.Wai.Handler.Warp

5−import Network.Wai.Conduit

6−import Network.HTTP.Types

7−import Conduit

8−import Data.ByteString.Builder (byteString)

9−import Control.Monad.Trans.Resource

10−

11−main :: IO ()

12−main = run 3000 app

13−

14−app :: Application

15−app _req respond =

16− runResourceT $ withInternalState $ \is ->

17− respond $ responseSource status200 [] $

18− transPipe (`runInternalState` is) (sourceFile "Main.hs") .|

19− mapC (Chunk . byteString)

wai-extra/ChangeLog.md−51

@@ -1,54 +1,3 @@

1−# Changelog for wai-extra

2−

3−## 3.0.29.1

4−

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

6−

7−## 3.0.29

8−

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

10−

11−## 3.0.28

12−

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

14−

15−## 3.0.27

16−

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

18−

19−## 3.0.26.1

20−

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

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

23−

24−## 3.0.26

25−

26−* Throw 413 for too large payload

27−* Throw 431 for too large headers

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

29−

30−## 3.0.25

31−

32−* Supporting `network` version 3.0.

33−

34−## 3.0.24.3

35−

36−* Drop unnecessary `lifted-base` dependency

37−* Drop unnecessary `stringsearch` dependency [#714](https://github.com/yesodweb/wai/pull/714)

38−

39−## 3.0.24.2

40−

41−* Consider quoted multipart form boundary markers [#700](https://github.com/yesodweb/wai/pull/700).

42−* Don't raise exceptions in `formatAsJSON` [#709](https://github.com/yesodweb/wai/pull/709)

43−

44−## 3.0.24.1

45−

46−* Fix a "file not found" exception in wai-extra [#705](https://github.com/yesodweb/wai/pull/706)

47−

48−## 3.0.24.0

49−

50−* Add timeout middleware [#702](https://github.com/yesodweb/wai/pull/702).

51−

52## 3.0.23.0

1## 3.0.23.0

53

2

54* Add rewriteRoot middleware [#697](https://github.com/yesodweb/wai/pull/697).

3* Add rewriteRoot middleware [#697](https://github.com/yesodweb/wai/pull/697).

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

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

@@ -41,7 +40,7 @@ import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File

41import qualified Data.ByteString.Lazy as LBS

40import qualified Data.ByteString.Lazy as LBS

42import qualified Data.ByteString.Char8 as S8

41import qualified Data.ByteString.Char8 as S8

43import System.Console.ANSI

42import System.Console.ANSI

44−import Data.IORef

43+import Data.IORef.Lifted

45import System.IO.Unsafe

44import System.IO.Unsafe

46import Network.Wai.Internal (Response (..))

45import Network.Wai.Internal (Response (..))

47import Data.Default.Class (Default (def))

46import Data.Default.Class (Default (def))

@@ -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+9−46

@@ -1,10 +1,6 @@

1{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE CPP #-}

3

2

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

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

5− ( formatAsJSON

6− , formatAsJSONWithHeaders

7− ) where

8

4

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

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

10import Data.ByteString.Lazy (toStrict)

6import Data.ByteString.Lazy (toStrict)

@@ -15,8 +11,7 @@ import qualified Data.ByteString.Char8 as S8

15import Data.IP

11import Data.IP

16import qualified Data.Text as T

12import qualified Data.Text as T

17import Data.Text (Text)

13import Data.Text (Text)

18−import Data.Text.Encoding (decodeUtf8With)

14+import Data.Text.Encoding (decodeUtf8)

19−import Data.Text.Encoding.Error (lenientDecode)

20import Data.Time (NominalDiffTime)

15import Data.Time (NominalDiffTime)

21import Data.Word (Word32)

16import Data.Word (Word32)

22import Network.HTTP.Types as H

17import Network.HTTP.Types as H

@@ -37,34 +32,10 @@ formatAsJSON date req status responseSize duration reqBody response =

37 , "size" .= responseSize

32 , "size" .= responseSize

38 , "body" .=

33 , "body" .=

39 if statusCode status >= 400

34 if statusCode status >= 400

40− then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ response

35+ then Just . decodeUtf8 . toStrict . BB.toLazyByteString $ response

41 else Nothing

36 else Nothing

42 ]

37 ]

43− , "time" .= decodeUtf8With lenientDecode date

38+ , "time" .= decodeUtf8 date

44− ]) <> "\n"

45−

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

47−--

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

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

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

51−--

52−-- @since 3.0.27

53−formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders

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

55− toLogStr (encode $

56− object

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

58− , "response" .= object

59− [ "status" .= statusCode status

60− , "size" .= resSize

61− , "headers" .= responseHeadersToJSON resHeaders

62− , "body" .=

63− if statusCode status >= 400

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

65− else Nothing

66− ]

67− , "time" .= decodeUtf8With lenientDecode date

68 ]) <> "\n"

39 ]) <> "\n"

69

40

70word32ToHostAddress :: Word32 -> Text

41word32ToHostAddress :: Word32 -> Text

@@ -76,12 +47,12 @@ readAsDouble = read

76requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value

47requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value

77requestToJSON duration req reqBody =

48requestToJSON duration req reqBody =

78 object

49 object

79− [ "method" .= decodeUtf8With lenientDecode (requestMethod req)

50+ [ "method" .= decodeUtf8 (requestMethod req)

80− , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)

51+ , "path" .= decodeUtf8 (rawPathInfo req)

81 , "queryString" .= map queryItemToJSON (queryString req)

52 , "queryString" .= map queryItemToJSON (queryString req)

82 , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)

53 , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)

83 , "size" .= requestBodyLengthToJSON (requestBodyLength req)

54 , "size" .= requestBodyLengthToJSON (requestBodyLength req)

84− , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody)

55+ , "body" .= decodeUtf8 (S8.concat reqBody)

85 , "remoteHost" .= sockToJSON (remoteHost req)

56 , "remoteHost" .= sockToJSON (remoteHost req)

86 , "httpVersion" .= httpVersionToJSON (httpVersion req)

57 , "httpVersion" .= httpVersionToJSON (httpVersion req)

87 , "headers" .= requestHeadersToJSON (requestHeaders req)

58 , "headers" .= requestHeadersToJSON (requestHeaders req)

@@ -103,13 +74,11 @@ sockToJSON (SockAddrInet6 pn _ ha _) =

103 ]

74 ]

104sockToJSON (SockAddrUnix sock) =

75sockToJSON (SockAddrUnix sock) =

105 object [ "unix" .= sock ]

76 object [ "unix" .= sock ]

106−#if !MIN_VERSION_network(3,0,0)

107sockToJSON (SockAddrCan i) =

77sockToJSON (SockAddrCan i) =

108 object [ "can" .= i ]

78 object [ "can" .= i ]

109−#endif

110

79

111queryItemToJSON :: QueryItem -> Value

80queryItemToJSON :: QueryItem -> Value

112−queryItemToJSON (name, mValue) = toJSON (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue)

81+queryItemToJSON (name, mValue) = toJSON (decodeUtf8 name, fmap decodeUtf8 mValue)

113

82

114requestHeadersToJSON :: RequestHeaders -> Value

83requestHeadersToJSON :: RequestHeaders -> Value

115requestHeadersToJSON = toJSON . map hToJ where

84requestHeadersToJSON = toJSON . map hToJ where

@@ -117,14 +86,8 @@ requestHeadersToJSON = toJSON . map hToJ where

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

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

118 hToJ hd = headerToJSON hd

87 hToJ hd = headerToJSON hd

119

88

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

89headerToJSON :: Header -> Value

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

90+headerToJSON (headerName, header) = toJSON (decodeUtf8 . original $ headerName, decodeUtf8 header)

128

91

129portToJSON :: PortNumber -> Value

92portToJSON :: PortNumber -> Value

130portToJSON = toJSON . toInteger

93portToJSON = toJSON . toInteger

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/Middleware/Timeout.hsdeleted−33

@@ -1,33 +0,0 @@

1−-- | Timeout requests

2−module Network.Wai.Middleware.Timeout

3− ( timeout

4− , timeoutStatus

5− , timeoutAs

6− ) where

7−

8−import Network.HTTP.Types (Status, status503)

9−import Network.Wai

10−import qualified System.Timeout as Timeout

11−

12−-- | Time out the request after the given number of seconds

13−--

14−-- Timeouts respond with @'status503'@. See @'timeoutStatus'@ or @'timeoutAs'@

15−-- to customize the behavior of the timed-out case.

16−--

17−-- @since 3.0.24.0@

18−timeout :: Int -> Middleware

19−timeout = timeoutStatus status503

20−

21−-- | Time out with the given @'Status'@

22−--

23−-- @since 3.0.24.0@

24−timeoutStatus :: Status -> Int -> Middleware

25−timeoutStatus status = timeoutAs $ responseLBS status [] ""

26−

27−-- | Time out with the given @'Response'@

28−--

29−-- @since 3.0.24.0@

30−timeoutAs :: Response -> Int -> Middleware

31−timeoutAs timeoutReponse seconds app req respond =

32− maybe (respond timeoutReponse) pure

33− =<< Timeout.timeout (seconds * 1000000) (app req respond)

wai-extra/Network/Wai/Parse.hs+9−23

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

48#endif

49 ) where

50

51−import qualified Control.Exception as E

51+import qualified Data.ByteString.Search as Search

52import qualified Data.ByteString as S

53import qualified Data.ByteString.Lazy as L

54import qualified Data.ByteString.Char8 as S8

@@ -59,16 +59,13 @@ import Data.List (sortBy)

59import Data.Function (on, fix)

60import System.Directory (removeFile, getTemporaryDirectory)

61import System.IO (hClose, openBinaryTempFile)

62−import System.IO.Error (isDoesNotExistError)

63import Network.Wai

62import Network.Wai

64import qualified Network.HTTP.Types as H

63import qualified Network.HTTP.Types as H

65import Control.Applicative ((<$>))

64import Control.Applicative ((<$>))

66−import Control.Exception (catchJust)

67−import Control.Monad (when, unless, guard)

65+import Control.Monad (when, unless)

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

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

69import Data.IORef

67import Data.IORef

70import Network.HTTP.Types (hContentType)

68import Network.HTTP.Types (hContentType)

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

72import Data.CaseInsensitive (mk)

69import Data.CaseInsensitive (mk)

73

70

74import Prelude hiding (lines)

71import Prelude hiding (lines)

@@ -131,7 +128,7 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory

131 -> IO FilePath

128 -> IO FilePath

132tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

129tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

133 (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)

130 (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)

134− _ <- runInternalState (register $ removeFileQuiet fp) internalState

131+ _ <- runInternalState (register $ removeFile fp) internalState

135 fix $ \loop -> do

132 fix $ \loop -> do

136 bs <- popper

133 bs <- popper

137 unless (S.null bs) $ do

134 unless (S.null bs) $ do

@@ -143,9 +140,6 @@ tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

143 it = do

140 it = do

144 tempDir <- getTmpDir

141 tempDir <- getTmpDir

145 openBinaryTempFile tempDir pattrn

142 openBinaryTempFile tempDir pattrn

146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)

147− (removeFile fp)

148− (const $ return ())

149

143

150-- | A data structure that describes the behavior of

144-- | A data structure that describes the behavior of

151-- the parseRequestBodyEx function.

145-- the parseRequestBodyEx function.

@@ -337,9 +331,6 @@ parseContentType a = do

337 semicolon = 59

331 semicolon = 59

338 equals = 61

332 equals = 61

339 space = 32

333 space = 32

340− dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote

341− then S.tail $ S.init s

342− else s

343 goAttrs front bs

334 goAttrs front bs

344 | S.null bs = front []

335 | S.null bs = front []

345 | otherwise =

336 | otherwise =

@@ -348,7 +339,7 @@ parseContentType a = do

348 goAttr bs =

339 goAttr bs =

349 let (k, v') = S.break (== equals) bs

340 let (k, v') = S.break (== equals) bs

350 v = S.drop 1 v'

341 v = S.drop 1 v'

351− in (strip k, dq $ strip v)

342+ in (strip k, strip v)

352 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)

343 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)

353

344

354-- | Parse the body of an HTTP request.

345-- | Parse the body of an HTTP request.

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

428

419

429

420

430-- | Take one header or subheader line.

421-- | Take one header or subheader line.

431−-- Since: 3.0.26

432−-- Throw 431 if headers too large.

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

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

434takeLine maxlen src =

423takeLine maxlen src =

435 go ""

424 go ""

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

438 bs <- readSource src

427 bs <- readSource src

439 case maxlen of

428 case maxlen of

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

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

441− E.throwIO $ ConnectionError (UnknownErrorCode 431)

430+ error "Header line length exceeds allowed maximum."

442− "Request Header Fields Too Large"

443 Nothing -> return ()

431 Nothing -> return ()

444 if S.null bs

432 if S.null bs

445 then close front

433 then close front

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

455 let res = front `S.append` x

443 let res = front `S.append` x

456 case maxlen of

444 case maxlen of

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

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

458− E.throwIO $ ConnectionError (UnknownErrorCode 431)

446+ error "Header line length exceeds allowed maximum."

459− "Request Header Fields Too Large"

460 Nothing -> return ()

447 Nothing -> return ()

461 return $ Just $ killCR $ res

448 return $ Just $ killCR $ res

462

449

@@ -582,7 +569,7 @@ data Bound = FoundBound S.ByteString S.ByteString

582 deriving (Eq, Show)

569 deriving (Eq, Show)

583

570

584findBound :: S.ByteString -> S.ByteString -> Bound

571findBound :: S.ByteString -> S.ByteString -> Bound

585−findBound b bs = handleBreak $ S.breakSubstring b bs

572+findBound b bs = handleBreak $ Search.breakOn b bs

586 where

573 where

587 handleBreak (h, t)

574 handleBreak (h, t)

588 | S.null t = go [lowBound..S.length bs - 1]

575 | S.null t = go [lowBound..S.length bs - 1]

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

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

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

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

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

647 case max' of

634 case max' of

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

635+ Just max'' | cur > max'' -> error "Maximum size exceeded"

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

650− _ -> return ()

636+ _ -> return ()

651 if S.null bs

637 if S.null bs

652 then do

638 then do

653 writeIORef ref $ WTBDone False

639 writeIORef ref $ WTBDone False

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/Middleware/TimeoutSpec.hsdeleted−57

@@ -1,57 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module Network.Wai.Middleware.TimeoutSpec

4− ( spec

5− ) where

6−

7−import Test.Hspec

8−

9−import Control.Concurrent (threadDelay)

10−import Network.HTTP.Types (status200, status503, status504)

11−import Network.Wai

12−import Network.Wai.Middleware.Timeout

13−import Network.Wai.Test

14−

15−spec :: Spec

16−spec = do

17− describe "timeout" $ do

18− it "times out slow requests with 503" $ do

19− let app _req respond = do

20− threadDelay $ 2 * 1000000

21− respond $ responseLBS status200 [] ""

22−

23− resp <- runApp $ timeout 1 app

24−

25− simpleStatus resp `shouldBe` status503

26−

27− it "does not time out fast requests" $ do

28− let app _req respond = respond $ responseLBS status200 [] ""

29−

30− resp <- runApp $ timeout 3 app

31−

32− simpleStatus resp `shouldBe` status200

33−

34− describe "timeoutStatus" $ do

35− it "allows customizing the timeout response status" $ do

36− let app _req respond = do

37− threadDelay $ 2 * 1000000

38− respond $ responseLBS status200 [] ""

39−

40− resp <- runApp $ timeoutStatus status504 1 app

41−

42− simpleStatus resp `shouldBe` status504

43−

44− describe "timeoutAs" $ do

45− it "allows customizing the timeout response" $ do

46− let app _req respond = do

47− threadDelay $ 2 * 1000000

48− respond $ responseLBS status200 [] ""

49− timeoutResponse = responseLBS status503 [("X-Timeout", "1")] ""

50−

51− resp <- runApp $ timeoutAs timeoutResponse 1 app

52−

53− simpleStatus resp `shouldBe` status503

54− simpleHeaders resp `shouldBe` [("X-Timeout", "1")]

55−

56−runApp :: Application -> IO SResponse

57−runApp = runSession $ request defaultRequest

wai-extra/test/Network/Wai/ParseSpec.hs+5−15

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

13import qualified Data.Text as TS

14import qualified Data.Text.Encoding as TE

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

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

17

16

18import Network.Wai

17import Network.Wai

19import Network.Wai.Test

18import Network.Wai.Test

@@ -31,7 +30,6 @@ spec = do

31 [ ("text/plain", "text/plain", [])

30 [ ("text/plain", "text/plain", [])

32 , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])

31 , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])

33 , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")])

32 , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")])

34− , ("text/plain; charset=UTF-8 ; boundary = \"quoted\"", "text/plain", [("charset", "UTF-8"), ("boundary", "quoted")])

35 ]

33 ]

36 it "parseHttpAccept" caseParseHttpAccept

34 it "parseHttpAccept" caseParseHttpAccept

37 describe "parseRequestBody" $ do

35 describe "parseRequestBody" $ do

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

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

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

96 let expected3 = (expectedsmap3, expectedfile3)

94 let expected3 = (expectedsmap3, expectedfile3)

97

95

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

99− unknownErrorException _ _ = False

100−

101

96

102 let def = defaultParseRequestBodyOptions

97 let def = defaultParseRequestBodyOptions

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

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

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

123

118

124 it "exceeding file size" $ do

119 it "exceeding file size" $ do

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

120 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

121+ (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

127− `shouldThrow` unknownErrorException 413

128

122

129 it "exceeding total file size" $ do

123 it "exceeding total file size" $ do

130 SRequest req4 _bod4 <- toRequest'' ctype3 content3

124 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

125+ (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

132− `shouldThrow` unknownErrorException 413

133 SRequest req5 _bod5 <- toRequest'' ctype3 content5

126 SRequest req5 _bod5 <- toRequest'' ctype3 content5

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

127+ (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5) `shouldThrow` anyErrorCall

135− `shouldThrow` unknownErrorException 413

136

128

137 it "exceeding max parm value size" $ do

129 it "exceeding max parm value size" $ do

138 SRequest req4 _bod4 <- toRequest'' ctype2 content2

130 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

131+ (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

140− `shouldThrow` unknownErrorException 413

141

132

142 it "exceeding max header lines" $ do

133 it "exceeding max header lines" $ do

143 SRequest req4 _bod4 <- toRequest'' ctype2 content2

134 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

145

136

146 it "exceeding header line size" $ do

137 it "exceeding header line size" $ do

147 SRequest req4 _bod4 <- toRequest'' ctype3 content4

138 SRequest req4 _bod4 <- toRequest'' ctype3 content4

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

139+ (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

149− `shouldThrow` unknownErrorException 431

150

140

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

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

152 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

142 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

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

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

1Name: wai-extra

2−Version: 3.0.29.1

2+Version: 3.0.23.0

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

107+ , stringsearch >= 0.3 && < 0.4

107 , containers

108 , containers

108 , base64-bytestring

109 , base64-bytestring

109 , word8

110 , word8

111+ , lifted-base >= 0.1.2

110 , deepseq

112 , deepseq

111 , streaming-commons >= 0.2

113 , streaming-commons >= 0.2

112 , unix-compat

114 , unix-compat

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

115 , zlib

117 , zlib

116 , aeson

118 , aeson

117 , iproute

119 , iproute

118− , http2

119

120

120 if os(windows)

121 if os(windows)

121 cpp-options: -DWINDOWS

122 cpp-options: -DWINDOWS

@@ -147,7 +148,6 @@ Library

147 Network.Wai.Middleware.ForceDomain

148 Network.Wai.Middleware.ForceDomain

148 Network.Wai.Middleware.ForceSSL

149 Network.Wai.Middleware.ForceSSL

149 Network.Wai.Middleware.Routed

150 Network.Wai.Middleware.Routed

150− Network.Wai.Middleware.Timeout

151 Network.Wai.Parse

152 Network.Wai.Request

153 Network.Wai.UrlMap

@@ -186,7 +186,6 @@ test-suite spec

186 Network.Wai.Middleware.ForceSSLSpec

187 Network.Wai.Middleware.RoutedSpec

188 Network.Wai.Middleware.StripHeadersSpec

189− Network.Wai.Middleware.TimeoutSpec

190 WaiExtraSpec

189 WaiExtraSpec

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

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

192 , wai-extra

191 , wai-extra

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

203 , cookie

202 , cookie

204 , time

203 , time

205 , case-insensitive

204 , case-insensitive

206− , http2

207 ghc-options: -Wall

205 ghc-options: -Wall

208 default-language: Haskell2010

206 default-language: Haskell2010

209

207

wai-handler-fastcgi/.gitignorenew file+4

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

1+/dist/

2+*.swp

3+*.hi

4+*.o

wai-handler-fastcgi/ChangeLog.mdnew file+3

@@ -0,0 +1,3 @@

1+## 3.0.0.2

2+

3+* Support wai 3.2

time-manager/LICENSE → wai-handler-fastcgi/LICENSErenamed

The content is the same.

wai-handler-fastcgi/Network/Wai/Handler/FastCGI.hscnew file+192

@@ -0,0 +1,192 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+{-# LANGUAGE EmptyDataDecls #-}

3+{-# LANGUAGE CPP #-}

4+-----------------------------------------------------------------------------

5+-- |

6+-- Module : Network.Wai.Handler.FastCGI

7+-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006, (c) Michael Snoyman 2010

8+-- License : BSD-style (see the file libraries/network/LICENSE)

9+--

10+-- Maintainer : michael@snoyman.com

11+-- Stability : experimental

12+-- Portability : non-portable (uses FFI)

13+--

14+-- Interface for FastCGI <http://fastcgi.com/>, using the fcgiapp API.

15+-- Totally ripped off by Michael Snoyman to work with Hack, then WAI.

16+--

17+-----------------------------------------------------------------------------

18+module Network.Wai.Handler.FastCGI

19+ ( run

20+ , runSendfile

21+ , runFork

22+ ) where

23+

24+import Control.Monad ( liftM, forever )

25+import Data.Word (Word8)

26+import Foreign ( Ptr, castPtr, nullPtr, peekArray0

27+ , throwIfNeg_, mallocBytes, free )

28+#ifdef GHC_7_4

29+import Foreign.C (CInt(..), CString, CStringLen)

30+#else

31+import Foreign.C (CInt, CString, CStringLen)

32+#endif

33+import Control.Exception (finally)

34+import Foreign.Storable ( Storable (..) )

35+

36+import qualified Network.Wai as W

37+import qualified Network.Wai.Handler.CGI as CGI

38+

39+import qualified Data.ByteString as S

40+import qualified Data.ByteString.Char8 as S8

41+import qualified Data.ByteString as BS

42+import qualified Data.ByteString.Internal as BSB

43+import qualified Data.ByteString.Unsafe as BSB

44+

45+import Control.Arrow ((***))

46+

47+#include <fcgiapp.h>

48+

49+------------------------------------------------------------------------

50+

51+data FCGX_Stream

52+type StreamPtr = Ptr FCGX_Stream

53+type Environ = Ptr CString

54+

55+------------------------------------------------------------------------

56+

57+foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr

58+ :: CString -> CInt -> StreamPtr -> IO CInt

59+

60+foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr

61+ :: CString -> CInt -> StreamPtr -> IO CInt

62+

63+

64+------------------------------------------------------------------------

65+

66+foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init

67+ :: IO CInt

68+

69+runFork :: Maybe S.ByteString -> (IO () -> IO a) -> Int -> W.Application -> IO ()

70+runFork sf fork threads app = do

71+ testReturn "FCGX_Init" $ fcgx_init

72+ let oneThread = forever $ oneRequest app sf

73+ mapM_ fork $ replicate (threads - 1) oneThread

74+ oneThread

75+

76+-- | Handle FastCGI requests in an infinite loop.

77+run :: W.Application -> IO ()

78+run = runFork Nothing id 1

79+

80+-- | Handle FastCGI requests in an infinite loop. For a server which supports

81+-- the X-Sendfile header.

82+runSendfile :: S.ByteString -> W.Application -> IO ()

83+runSendfile sf = runFork (Just sf) id 1

84+

85+oneRequest :: W.Application

86+ -> Maybe S.ByteString -- X-Sendfile

87+ -> IO ()

88+oneRequest app xsendfile = withRequest $ \r -> do

89+ putStrLn "Received 1 request"

90+ env <- peekEnvp r

91+ ins <- peekIn r

92+ outs <- peekOut r

93+ handleRequest app ins outs env xsendfile

94+

95+peekIn, peekOut :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)

96+peekIn = (#peek FCGX_Request, in)

97+peekOut = (#peek FCGX_Request, out)

98+

99+peekEnvp :: Ptr FCGX_Request -> IO Environ

100+peekEnvp = (#peek FCGX_Request, envp)

101+

102+foreign import ccall unsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest

103+ :: Ptr FCGX_Request -> CInt -> CInt -> IO CInt

104+

105+foreign import ccall safe "fcgiapp.h FCGX_Accept_r" fcgx_accept_r

106+ :: Ptr FCGX_Request -> IO CInt

107+

108+acceptRequest :: IO (Ptr FCGX_Request)

109+acceptRequest = do

110+ reqp <- mallocBytes (#size FCGX_Request)

111+ initAndAccept reqp

112+ return reqp

113+ where initAndAccept reqp = do

114+ testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0

115+ testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp

116+

117+withRequest :: (Ptr FCGX_Request -> IO ()) -> IO ()

118+withRequest f = do

119+ req <- acceptRequest

120+ f req `finally` finishRequest req

121+

122+foreign import ccall unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r

123+ :: Ptr FCGX_Request -> IO ()

124+

125+finishRequest :: Ptr FCGX_Request -> IO ()

126+finishRequest reqp = do

127+ fcgx_finish_r reqp

128+ free reqp

129+

130+handleRequest :: W.Application

131+ -> StreamPtr

132+ -> StreamPtr

133+ -> Environ

134+ -> Maybe S.ByteString -- sendfile

135+ -> IO ()

136+handleRequest f ins outs env xsendfile = do

137+ vars <- environToTable env

138+ let vars' = map (S8.unpack *** S8.unpack) vars

139+ let input = const $ sRead ins

140+ let hPut = sPutStr' outs

141+ CGI.runGeneric vars' (CGI.requestBodyFunc input) hPut xsendfile f

142+

143+data FCGX_Request

144+

145+--

146+-- * Stream IO

147+--

148+

149+sPutStr' :: StreamPtr -> BS.ByteString -> IO ()

150+sPutStr' h str =

151+ BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h

152+

153+fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO ()

154+fcgxPutCStringLen h (cs,len) =

155+ testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h

156+

157+sRead :: StreamPtr -> IO (Maybe BS.ByteString)

158+sRead h = buildByteString (fcgxGetBuf h) 4096

159+

160+fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int

161+fcgxGetBuf h p c =

162+ liftM fromIntegral $ fcgx_getStr (castPtr p) (fromIntegral c) h

163+

164+--

165+-- * ByteString utilities

166+--

167+

168+-- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary

169+-- reading functions.

170+buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO (Maybe BS.ByteString)

171+buildByteString f k = do

172+ ps <- BSB.createAndTrim k $ \p -> f p k

173+ case BS.length ps of

174+ 0 -> return Nothing

175+ _ -> return $ Just ps

176+

177+--

178+-- * Utilities

179+--

180+

181+testReturn :: String -> IO CInt -> IO ()

182+testReturn e = throwIfNeg_ (\n -> e ++ " failed with error code: "++ show n)

183+

184+environToTable :: Environ -> IO [(S.ByteString, S.ByteString)]

185+environToTable arr = do

186+ css <- peekArray0 nullPtr arr

187+ ss <- mapM S.packCString css

188+ return $ map splitEq ss

189+ where

190+ splitEq s =

191+ let (a, b) = S.breakByte 61 s

192+ in (a, S.drop 1 b)

wai-handler-fastcgi/READMEnew file

No changes to the content.

wai-handler-fastcgi/README.mdnew file+3

@@ -0,0 +1,3 @@

1+## wai-handler-fastcgi

2+

3+Calls out to the libfcgi C library.

wai-handler-fastcgi/Setup.lhsnew file+7

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-fastcgi/configurenew file+9

@@ -0,0 +1,9 @@

1+#!/bin/sh

2+#

3+

4+# subst standard header path variables

5+if test -n "$CPPFLAGS" ; then

6+ echo "Found CPPFLAGS in environment: '$CPPFLAGS'"

7+ sed 's,@CPPFLAGS@,'"$CPPFLAGS"',g;s,@LDFLAGS@,'"$LDFLAGS"',g' \

8+ < fastcgi.buildinfo.in > fastcgi.buildinfo

9+fi

wai-handler-fastcgi/fastcgi.buildinfo.innew file+3

@@ -0,0 +1,3 @@

1+ghc-options: -optc@CPPFLAGS@

2+cc-options: @CPPFLAGS@

3+ld-options: @LDFLAGS@

wai-handler-fastcgi/lighttpd.confnew file+19

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

1+# Run with lighttpd -D -f lighttpd.conf

2+server.port = 3000

3+server.document-root = "."

4+server.modules = ("mod_fastcgi", "mod_rewrite")

5+

6+url.rewrite-once = (

7+ "(.*)" => "/app/$1"

8+)

9+

10+fastcgi.server = (

11+ "/app" => ((

12+ "socket" => "/tmp/test.fastcgi.socket",

13+ "check-local" => "disable",

14+ "bin-path" => "./test",

15+ "min-procs" => 1,

16+ "max-procs" => 12,

17+ "idle-timeout" => 30

18+ ))

19+)

wai-handler-fastcgi/test.hsnew file+19

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.FastCGI

4+import Control.Monad.IO.Class

5+import qualified Data.ByteString.Lazy as L

6+import qualified Data.ByteString.Lazy.Char8 as L8

7+import qualified Data.Enumerator as E

8+

9+main = run app

10+

11+app req

12+ | pathInfo req == "/" = return $ responseLBS status200 [("Content-Type", "text/html")] "<form method='post' action='/post'><input type='text' name='name'><input type='submit'></form>"

13+app req = do

14+ bss <- E.consume

15+ return $ responseLBS status200 [("Content-Type", "text/plain")] $ L.concat

16+ [ L8.pack $ show $ requestHeaders req

17+ , "\n"

18+ , L.fromChunks bss

19+ ]

wai-handler-fastcgi/wai-handler-fastcgi.cabalnew file+31

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

1+name: wai-handler-fastcgi

2+version: 3.0.0.2

3+license: MIT

4+license-file: LICENSE

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

6+maintainer: Michael Snoyman <michael@snoyman.com>

7+synopsis: Wai handler to fastcgi

8+description: API docs and the README are available at <http://www.stackage.org/package/wai-handler-fastcgi>.

9+category: Web

10+stability: stable

11+cabal-version: >= 1.6

12+build-type: Configure

13+extra-source-files: configure fastcgi.buildinfo.in README.md ChangeLog.md

14+homepage: http://www.yesodweb.com/book/web-application-interface

15+

16+library

17+ build-depends: base >= 4 && < 5

18+ , wai >= 3.0 && < 3.3

19+ , wai-extra >= 3.0 && < 3.1

20+ , bytestring >= 0.9.1.4

21+ exposed-modules: Network.Wai.Handler.FastCGI

22+ ghc-options: -Wall

23+ includes: fcgiapp.h

24+ extra-libraries: fcgi

25+

26+ if impl(ghc >= 7.4)

27+ cpp-options: -DGHC_7_4

28+

29+source-repository head

30+ type: git

31+ location: git://github.com/yesodweb/wai.git

wai-handler-launch/.gitignorenew file+2

@@ -0,0 +1,2 @@

1+dist/

2+*.swp

wai-handler-launch/ChangeLog.mdnew file+35

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

1+## 3.0.2.4

2+

3+* Drop dependency on blaze-builder, requiring streaming-commons >= 0.2

4+

5+## 3.0.2.3

6+

7+* `process` package bump

8+

9+## 3.0.2.2

10+

11+* Improvements to ping's javascript script. [#494](https://github.com/yesodweb/wai/pull/494)

12+

13+## 3.0.2.1

14+

15+* Relax upper bound on process

16+

17+## 3.0.2

18+

19+* Don't launch if server fails; kill server on exit [#537](https://github.com/yesodweb/wai/issues/537) [#541](https://github.com/yesodweb/wai/pull/541)

20+

21+## 3.0.1

22+

23+* make host configurable too (fixes #538) [#539](https://github.com/yesodweb/wai/pull/539)

24+

25+## 3.0.0.5

26+

27+* Support wai/warp 3.2

28+

29+## 3.0.0.3

30+

31+Allow blaze-builder 0.4

32+

33+## 3.0.0.2

34+

35+* Support for Win64

wai-handler-launch/LICENSEnew file+20

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

2+

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

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

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

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

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

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

9+the following conditions:

10+

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

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

13+

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

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

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

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

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

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

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

wai-handler-launch/Network/Wai/Handler/Launch.hsnew file+222

@@ -0,0 +1,222 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ForeignFunctionInterface #-}

3+{-# LANGUAGE CPP #-}

4+module Network.Wai.Handler.Launch

5+ ( run

6+ , runUrl

7+ , runUrlPort

8+ , runHostPortUrl

9+ ) where

10+

11+import Network.Wai

12+import Network.Wai.Internal

13+import Network.HTTP.Types

14+import qualified Network.Wai.Handler.Warp as Warp

15+import Data.IORef

16+import Data.Monoid (mappend)

17+import Data.String (fromString)

18+import Control.Concurrent (forkIO, threadDelay, newEmptyMVar, putMVar, takeMVar)

19+import Control.Concurrent.Async (race)

20+import Control.Monad.IO.Class (liftIO)

21+import Control.Monad (unless)

22+import Control.Exception (throwIO)

23+import Data.Function (fix)

24+import qualified Data.ByteString as S

25+import Data.ByteString.Builder (Builder, byteString)

26+import qualified Data.ByteString.Builder.Extra as Builder (flush)

27+#if WINDOWS

28+import Foreign

29+import Foreign.C.String

30+#else

31+import System.Process (rawSystem)

32+#endif

33+import Data.Streaming.ByteString.Builder as B (newBuilderRecv, defaultStrategy)

34+import qualified Data.Streaming.Zlib as Z

35+

36+ping :: IORef Bool -> Middleware

37+ping active app req sendResponse

38+ | pathInfo req == ["_ping"] = do

39+ liftIO $ writeIORef active True

40+ sendResponse $ responseLBS status200 [] ""

41+ | otherwise = app req $ \res -> do

42+ let isHtml hs =

43+ case lookup "content-type" hs of

44+ Just ct -> "text/html" `S.isPrefixOf` ct

45+ Nothing -> False

46+ if isHtml $ responseHeaders res

47+ then do

48+ let (s, hs, withBody) = responseToStream res

49+ (isEnc, headers') = fixHeaders id hs

50+ headers'' = filter (\(x, _) -> x /= "content-length") headers'

51+ withBody $ \body ->

52+ sendResponse $ responseStream s headers'' $ \sendChunk flush ->

53+ addInsideHead sendChunk flush $ \sendChunk' flush' ->

54+ if isEnc

55+ then decode sendChunk' flush' body

56+ else body sendChunk' flush'

57+ else sendResponse res

58+

59+decode :: (Builder -> IO ()) -> IO ()

60+ -> StreamingBody

61+ -> IO ()

62+decode sendInner flushInner streamingBody = do

63+ (blazeRecv, blazeFinish) <- newBuilderRecv defaultStrategy

64+ inflate <- Z.initInflate $ Z.WindowBits 31

65+ let send builder = blazeRecv builder >>= goBuilderPopper

66+ goBuilderPopper popper = fix $ \loop -> do

67+ bs <- popper

68+ unless (S.null bs) $ do

69+ Z.feedInflate inflate bs >>= goZlibPopper

70+ loop

71+ goZlibPopper popper = fix $ \loop -> do

72+ res <- popper

73+ case res of

74+ Z.PRDone -> return ()

75+ Z.PRNext bs -> do

76+ sendInner $ byteString bs

77+ loop

78+ Z.PRError e -> throwIO e

79+ streamingBody send (send Builder.flush)

80+ mbs <- blazeFinish

81+ case mbs of

82+ Nothing -> return ()

83+ Just bs -> Z.feedInflate inflate bs >>= goZlibPopper

84+ Z.finishInflate inflate >>= sendInner . byteString

85+

86+toInsert :: S.ByteString

87+toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping?\" + (new Date()).getTime(),true);x.send();},60000)</script>"

88+

89+addInsideHead :: (Builder -> IO ())

90+ -> IO ()

91+ -> StreamingBody

92+ -> IO ()

93+addInsideHead sendInner flushInner streamingBody = do

94+ (blazeRecv, blazeFinish) <- newBuilderRecv defaultStrategy

95+ ref <- newIORef $ Just (S.empty, whole)

96+ streamingBody (inner blazeRecv ref) (flush blazeRecv ref)

97+ state <- readIORef ref

98+ mbs <- blazeFinish

99+ held <- case mbs of

100+ Nothing -> return state

101+ Just bs -> push state bs

102+ case state of

103+ Nothing -> return ()

104+ Just (held, _) -> sendInner $ byteString held `mappend` byteString toInsert

105+ where

106+ whole = "<head>"

107+

108+ flush blazeRecv ref = inner blazeRecv ref Builder.flush

109+

110+ inner blazeRecv ref builder = do

111+ state0 <- readIORef ref

112+ popper <- blazeRecv builder

113+ let loop state = do

114+ bs <- popper

115+ if S.null bs

116+ then writeIORef ref state

117+ else push state bs >>= loop

118+ loop state0

119+

120+ push Nothing x = sendInner (byteString x) >> return Nothing

121+ push (Just (held, atFront)) x

122+ | atFront `S.isPrefixOf` x = do

123+ let y = S.drop (S.length atFront) x

124+ sendInner $ byteString held

125+ `mappend` byteString atFront

126+ `mappend` byteString toInsert

127+ `mappend` byteString y

128+ return Nothing

129+ | whole `S.isInfixOf` x = do

130+ let (before, rest) = S.breakSubstring whole x

131+ let after = S.drop (S.length whole) rest

132+ sendInner $ byteString held

133+ `mappend` byteString before

134+ `mappend` byteString whole

135+ `mappend` byteString toInsert

136+ `mappend` byteString after

137+ return Nothing

138+ | x `S.isPrefixOf` atFront = do

139+ let held' = held `S.append` x

140+ atFront' = S.drop (S.length x) atFront

141+ return $ Just (held', atFront')

142+ | otherwise = do

143+ let (held', atFront', x') = getOverlap whole x

144+ sendInner $ byteString held `mappend` byteString x'

145+ return $ Just (held', atFront')

146+

147+getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)

148+getOverlap whole x =

149+ go whole

150+ where

151+ go piece

152+ | S.null piece = ("", whole, x)

153+ | piece `S.isSuffixOf` x =

154+ let x' = S.take (S.length x - S.length piece) x

155+ atFront = S.drop (S.length piece) whole

156+ in (piece, atFront, x')

157+ | otherwise = go $ S.init piece

158+

159+fixHeaders :: ([Header] -> [Header])

160+ -> [Header]

161+ -> (Bool, [Header])

162+fixHeaders front [] = (False, front [])

163+fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)

164+fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs

165+

166+#if WINDOWS

167+foreign import ccall "launch"

168+ launch' :: Int -> CString -> IO ()

169+#endif

170+

171+launch :: Int -> String -> IO ()

172+

173+#if WINDOWS

174+launch port s = withCString s $ launch' port

175+#else

176+launch port s = forkIO (rawSystem

177+#if MAC

178+ "open"

179+#else

180+ "xdg-open"

181+#endif

182+ ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return ()

183+#endif

184+

185+run :: Application -> IO ()

186+run = runUrl ""

187+

188+runUrl :: String -> Application -> IO ()

189+runUrl = runUrlPort 4587

190+

191+runUrlPort :: Int -> String -> Application -> IO ()

192+runUrlPort = runHostPortUrl "*4"

193+

194+-- |

195+--

196+-- @since 3.0.1

197+runHostPortUrl :: String -> Int -> String -> Application -> IO ()

198+runHostPortUrl host port url app = do

199+ ready <- newEmptyMVar

200+ active <- newIORef True

201+ let settings =

202+ Warp.setPort port $

203+ Warp.setOnException (\_ _ -> return ()) $

204+ Warp.setHost (fromString host) $

205+ Warp.setBeforeMainLoop (putMVar ready ()) $

206+ Warp.defaultSettings

207+ -- Run these threads concurrently; when either one terminates or

208+ -- raises an exception, the same happens to the other.

209+ fmap (either id id) $ race

210+ -- serve app, keep updating the activity flag

211+ (Warp.runSettings settings (ping active app))

212+ -- wait for server startup, launch browser, poll until server idle

213+ (takeMVar ready >> launch port url >> loop active)

214+

215+loop :: IORef Bool -> IO ()

216+loop active = do

217+ let seconds = 120

218+ threadDelay $ 1000000 * seconds

219+ b <- readIORef active

220+ if b

221+ then writeIORef active False >> loop active

222+ else return ()

wai-handler-launch/READMEnew file

No changes to the content.

wai-handler-launch/README.mdnew file+4

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

1+## wai-handler-launch

2+

3+This handles cross-platform launching and inserts Javascript code to ping the

4+server. When the server no longer receives pings, it shuts down.

wai-handler-launch/Setup.lhsnew file+7

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-launch/runtests.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai.Handler.Launch (insideHead)

3+import Test.Hspec

4+import Test.Hspec.HUnit

5+import Data.Enumerator hiding (map)

6+import Test.HUnit

7+import qualified Data.ByteString as S

8+

9+main :: IO ()

10+main = hspec $ describe "insideHead"

11+ [ it "handles single chunks" $ helper "bar<head>foobaz" ["bar<head>baz"]

12+ , it "handles single chunks, no <head>" $ helper "barfoo" ["bar"]

13+ , it "handles whole chunks" $ helper "bar<head>foobaz" ["bar", "<head>", "baz"]

14+ , it "handles split chunks" $ helper "bar<head>foobaz" ["bar", "<he", "ad>", "baz"]

15+ , it "handles many chunks" $ helper "bar<head>foobaz1234567890" ["bar", "<he", "ad>", "baz", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"]

16+ , it "handles many pieces" $ helper "bar<head>foobaz" $ map S.singleton $ S.unpack "bar<head>baz"

17+ ]

18+

19+helper :: S.ByteString -> [S.ByteString] -> Assertion

20+helper res pieces = do

21+ x <- run_ $ enumList 1 pieces $$ joinI $ insideHead "foo" $$ consume

22+ S.concat x @?= res

wai-handler-launch/test.hsnew file+7

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.HTTP.Types

4+import Network.Wai.Handler.Launch

5+import Network.Wai.Middleware.Gzip

6+

7+main = runUrl "FIXME" $ gzip def $ \_ f -> f $ responseLBS status200 [("Content-Type", "text/html; charset=utf8")] "<html><head></head><body>HELLO THERE"

wai-handler-launch/wai-handler-launch.cabalnew file+36

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

1+Name: wai-handler-launch

2+Version: 3.0.2.4

3+Synopsis: Launch a web app in the default browser.

4+description: API docs and the README are available at <http://www.stackage.org/package/wai-handler-launch>.

5+License: MIT

6+License-file: LICENSE

7+Author: Michael Snoyman

8+Maintainer: michael@snoyman.com

9+Category: Web

10+Build-type: Simple

11+Cabal-version: >=1.6

12+extra-source-files: README.md ChangeLog.md

13+

14+Library

15+ Exposed-modules: Network.Wai.Handler.Launch

16+ build-depends: base >= 4 && < 5

17+ , wai >= 3.0 && < 3.3

18+ , warp >= 3.0 && < 3.3

19+ , http-types >= 0.7

20+ , transformers >= 0.2.2

21+ , bytestring >= 0.10.4

22+ , streaming-commons >= 0.2

23+ , async

24+

25+ if os(windows)

26+ c-sources: windows.c

27+ cpp-options: -DWINDOWS

28+ extra-libraries: Shell32 msvcrt

29+ else

30+ build-depends: process >= 1.0 && < 1.7

31+ if os(darwin)

32+ cpp-options: -DMAC

33+

34+source-repository head

35+ type: git

36+ location: git://github.com/yesodweb/wai.git

wai-handler-launch/windows.cnew file+12

@@ -0,0 +1,12 @@

1+#include <windows.h>

2+#include <shellapi.h>

3+#include <stdio.h>

4+

5+void launch(int port, char *s)

6+{

7+ int len = 8 + strlen("http://127.0.0.1:") + strlen(s);

8+ char *buff = malloc(len);

9+ _snprintf(buff, len, "http://127.0.0.1:%d/%s", port, s);

10+ ShellExecute(NULL, "open", buff, NULL, NULL, SW_SHOWNORMAL);

11+ free(buff);

12+}

wai-handler-webkit/.gitignorenew file+2

@@ -0,0 +1,2 @@

1+dist

2+*.swp

wai-handler-webkit/ChangeLog.mdnew file+3

@@ -0,0 +1,3 @@

1+## 3.0.0.3

2+

3+* Support for wai/warp 3.2

wai-handler-webkit/LICENSEnew file+20

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

2+

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

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

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

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

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

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

9+the following conditions:

10+

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

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

13+

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

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

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

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

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

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

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

wai-handler-webkit/Network/Wai/Handler/Webkit.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+module Network.Wai.Handler.Webkit (run) where

3+

4+import Network.Wai (Application)

5+import qualified Network.Wai.Handler.Warp as S

6+import Control.Concurrent (forkOS)

7+import Control.Concurrent.MVar

8+import Foreign.C.String (CString, withCString)

9+import Control.Exception (finally)

10+

11+run :: String -- ^ Title to show in titlebar

12+ -> Application -> IO ()

13+run title app = do

14+ mvar <- newEmptyMVar

15+ _ <- forkOS $ finally (S.run 3000 app) (putMVar mvar ())

16+ _ <- forkOS $ finally (withCString title startBrowser) (putMVar mvar ())

17+ _ <- takeMVar mvar

18+ return ()

19+

20+foreign import ccall "start_browser"

21+ startBrowser :: CString -> IO ()

wai-handler-webkit/README.mdnew file+53

@@ -0,0 +1,53 @@

1+wai-handler-webkit

2+==================

3+

4+Turn WAI applications into standalone GUIs using Qt WebKit.

5+

6+

7+Linux

8+-----

9+

10+You'll need the appropriate system libraries, on Ubuntu:

11+

12+ apt-get install libqtwebkit-dev

13+

14+On Lucid, this required adding a PPA:

15+

16+ sudo add-apt-repository ppa:kubuntu-ppa/backports

17+

18+

19+Windows

20+-------

21+

22+Install the Qt SDK from <http://qt.nokia.com/downloads/>

23+

24+Your application's Cabal file will require certain options for Windows,

25+shown below. In particular, we need to link with `g++`, so make sure

26+it's in your `PATH`. The option `-optl-mwindows` ensures that the

27+application does not open a terminal.

28+

29+ if os(windows)

30+ ghc-options: -Wall -threaded -pgml g++ -optl-static -optl-mwindows

31+ else

32+ ghc-options: -Wall

33+

34+Run `cabal-install` with the Qt `include` and `lib` directories.

35+

36+ export QT_PATH=c:/QtSDK/Desktop/Qt/4.7.3/mingw

37+

38+ cabal-dev install \

39+ --extra-include-dirs=$QT_PATH/include \

40+ --extra-include-dirs=$QT_PATH/include/QtCore \

41+ --extra-include-dirs=$QT_PATH/include/QtNetwork \

42+ --extra-include-dirs=$QT_PATH/include/QtGui \

43+ --extra-include-dirs=$QT_PATH/include/QtWebKit \

44+ --extra-lib-dirs=$QT_PATH/lib

45+

46+You'll need to include these DLLs with your application:

47+

48+ phonon4.dll

49+ libgcc_s_dw2-1.dll

50+ QtCore4.dll

51+ QtGui4.dll

52+ QtNetwork4.dll

53+ QtWebKit4.dll

wai-handler-webkit/Setup.lhsnew file+7

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-webkit/sample.hsnew file+10

@@ -0,0 +1,10 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.Webkit

4+import Network.HTTP.Types

5+

6+main :: IO ()

7+main = run "Sample App" app

8+

9+app :: Application

10+app _ response = response $ responseLBS status200 [("Content-Type", "text/html")] "<h1>Hello World!</h1>"

wai-handler-webkit/wai-handler-webkit.cabalnew file+30

@@ -0,0 +1,30 @@

1+name: wai-handler-webkit

2+version: 3.0.0.3

3+license: MIT

4+license-file: LICENSE

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

6+maintainer: Michael Snoyman <michael@snoyman.com>

7+synopsis: Turn WAI applications into standalone GUIs using QtWebkit.

8+description: API docs and the README are available at <http://www.stackage.org/package/wai-handler-webkit>.

9+category: Web

10+stability: unstable

11+cabal-version: >= 1.6

12+build-type: Simple

13+homepage: https://github.com/yesodweb/wai/tree/master/wai-handler-webkit

14+extra-source-files: README.md ChangeLog.md

15+

16+library

17+ build-depends: base >= 4 && < 5

18+ , wai >= 3.0 && < 3.3

19+ , warp >= 3.0 && < 3.3

20+ ghc-options: -Wall

21+ exposed-modules: Network.Wai.Handler.Webkit

22+ c-sources: webkit.cpp

23+ if os(windows)

24+ extra-libraries: QtCore4, QtGui4, QtNetwork4, QtWebKit4

25+ else

26+ pkgconfig-depends: QtWebKit

27+

28+source-repository head

29+ type: git

30+ location: git://github.com/yesodweb/wai.git

wai-handler-webkit/webkit.cppnew file+19

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

1+#include <QApplication>

2+#include <QPushButton>

3+#include <QtWebKit>

4+

5+extern "C" {

6+ int start_browser(char *title)

7+ {

8+ char *argv[1];

9+ argv[0] = title;

10+ int argc = 1;

11+

12+ QApplication app(argc, argv);

13+ QWebView *view = new QWebView();

14+ view->load(QUrl("http://localhost:3000/"));

15+ view->show();

16+

17+ return app.exec();

18+ }

19+}

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

wai/ChangeLog.md−10

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

1−# ChangeLog for wai

2−

3−## 3.2.2.1

4−

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

6−

7−## 3.2.2

8−

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

10−

11## 3.2.1.2

1## 3.2.1.2

12

2

13* Remove dependency on blaze-builder [#683](https://github.com/yesodweb/wai/pull/683)

3* Remove dependency on blaze-builder [#683](https://github.com/yesodweb/wai/pull/683)

wai/Network/Wai.hs+8−10

@@ -4,11 +4,10 @@ This module defines a generic web application interface. It is a common

4protocol between web servers and web applications.

5

6The overriding design principles here are performance and generality. To

7−address performance, this library uses a streaming interface for request and

7+address performance, this library is built on top of the conduit package and

8−response bodies, paired with bytestring's 'Builder' type. The advantages of a

8+bytestring's Builder type. The advantages of conduits over lazy IO have been

9−streaming API over lazy IO have been debated elsewhere and so will not be

10−addressed here. However, helper functions like 'responseLBS' allow you to

9+debated elsewhere and so will not be addressed here. However, helper functions

11−continue using lazy IO if you so desire.

10+like 'responseLBS' allow you to continue using lazy IO if you so desire.

12

11

13Generality is achieved by removing many variables commonly found in similar

12Generality is achieved by removing many variables commonly found in similar

14projects that are not universal to all servers. The goal is that the 'Request'

13projects that are not universal to all servers. The goal is that the 'Request'

@@ -30,9 +29,9 @@ include:

30

29

31[wai-extra] <http://hackage.haskell.org/package/wai-extra>

30[wai-extra] <http://hackage.haskell.org/package/wai-extra>

32

31

32+[wai-test] <http://hackage.haskell.org/package/wai-test>

33+

33-}

34-}

34−-- Ignore deprecations, because this module needs to use the deprecated requestBody to construct a response.

35−{-# OPTIONS_GHC -fno-warn-deprecations #-}

36module Network.Wai

35module Network.Wai

37 (

36 (

38 -- * Types

37 -- * Types

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

53 , remoteHost

52 , remoteHost

54 , pathInfo

53 , pathInfo

55 , queryString

54 , queryString

56− , getRequestBodyChunk

57 , requestBody

55 , requestBody

58 , vault

56 , vault

59 , requestBodyLength

57 , requestBodyLength

@@ -326,7 +324,7 @@ strictRequestBody req =

326 loop id

324 loop id

327 where

325 where

328 loop front = do

326 loop front = do

329− bs <- getRequestBodyChunk req

327+ bs <- requestBody req

330 if B.null bs

328 if B.null bs

331 then return $ front LI.Empty

329 then return $ front LI.Empty

332 else loop (front . LI.Chunk bs)

330 else loop (front . LI.Chunk bs)

@@ -340,7 +338,7 @@ lazyRequestBody req =

340 loop

338 loop

341 where

339 where

342 loop = unsafeInterleaveIO $ do

340 loop = unsafeInterleaveIO $ do

343− bs <- getRequestBodyChunk req

341+ bs <- requestBody req

344 if B.null bs

342 if B.null bs

345 then return LI.Empty

343 then return LI.Empty

346 else do

344 else do

wai/Network/Wai/Internal.hs+1−9

@@ -17,7 +17,6 @@ import Data.List (intercalate)

17

18-- | Information on the request sent by the client. This abstracts away the

19-- details of the underlying implementation.

20−{-# DEPRECATED requestBody "requestBody's name is misleading because it only gets a partial chunk of the body. Use getRequestBodyChunk instead." #-}

21data Request = Request {

20data Request = Request {

22 -- | Request method such as GET.

21 -- | Request method such as GET.

23 requestMethod :: H.Method

22 requestMethod :: H.Method

@@ -63,7 +62,7 @@ data Request = Request {

63 -- | Parsed query string information.

62 -- | Parsed query string information.

64 , queryString :: H.Query

63 , queryString :: H.Query

65 -- | Get the next chunk of the body. Returns 'B.empty' when the

64 -- | Get the next chunk of the body. Returns 'B.empty' when the

66− -- body is fully consumed. Since 3.2.2, this is deprecated in favor of 'getRequestBodyChunk'.

65+ -- body is fully consumed.

67 , requestBody :: IO B.ByteString

66 , requestBody :: IO B.ByteString

68 -- | A location for arbitrary data to be shared by applications and middleware.

67 -- | A location for arbitrary data to be shared by applications and middleware.

69 , vault :: Vault

68 , vault :: Vault

@@ -91,13 +90,6 @@ data Request = Request {

91 }

90 }

92 deriving (Typeable)

91 deriving (Typeable)

93

92

94−-- | Get the next chunk of the body. Returns 'B.empty' when the

95−-- body is fully consumed.

96−--

97−-- @since 3.2.2

98−getRequestBodyChunk :: Request -> IO B.ByteString

99−getRequestBodyChunk = requestBody

100−

101instance Show Request where

93instance Show Request where

102 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"

94 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"

103 where

95 where

wai/wai.cabal+2−1

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

1Name: wai

2−Version: 3.2.2.1

2+Version: 3.2.1.2

3Synopsis: Web Application Interface.

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

5 .

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

25 , network >= 2.2.1.5

26 , http-types >= 0.7

27 , text >= 0.7

28+ , transformers >= 0.0

28 , vault >= 0.3 && < 0.4

29 , vault >= 0.3 && < 0.4

29 Exposed-modules: Network.Wai

30 Exposed-modules: Network.Wai

30 Network.Wai.Internal

31 Network.Wai.Internal

warp-tls/ChangeLog.md+1−44

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

1−## 3.2.11

1+## 3.2.4.1

2−

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

4−

5−## 3.2.10

6−

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

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

9−

10−## 3.2.9

11−

12−* Cooperating setGracefulCloseTimeout1 and setGracefulCloseTimeout2 of Warp.

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

14−

15−## 3.2.8

16−

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

18−

19−## 3.2.7

20−

21−* Relaxing version constraint.

22−

23−## 3.2.6

24−

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

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

27−

28−## 3.2.5

29−

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

31−

32−## 3.2.4.3

33−

34−* Using warp >= 3.2.17.

35−

36−## 3.2.4.2

37

2

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

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

39

4

40−## 3.2.4

41−

42−* Using tls-session-manager.

43−

44−## 3.2.3

45−

46−* Stop using obsoleted APIs of network.

47−

48## 3.2.2

5## 3.2.2

49

6

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

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

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

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

@@ -93,37 +90,19 @@ data TLSSettings = TLSSettings {

93 --

90 --

94 -- Since 1.4.0

91 -- Since 1.4.0

95 , tlsAllowedVersions :: [TLS.Version]

92 , tlsAllowedVersions :: [TLS.Version]

96−#if MIN_VERSION_tls(1,5,0)

97− -- ^ The TLS versions this server accepts.

98− --

99− -- >>> tlsAllowedVersions defaultTlsSettings

100− -- [TLS13,TLS12,TLS11,TLS10]

101− --

102− -- Since 1.4.2

103−#else

104 -- ^ The TLS versions this server accepts.

93 -- ^ The TLS versions this server accepts.

105 --

94 --

106 -- >>> tlsAllowedVersions defaultTlsSettings

95 -- >>> tlsAllowedVersions defaultTlsSettings

107 -- [TLS12,TLS11,TLS10]

96 -- [TLS12,TLS11,TLS10]

108 --

97 --

109 -- Since 1.4.2

98 -- Since 1.4.2

110−#endif

111 , tlsCiphers :: [TLS.Cipher]

99 , tlsCiphers :: [TLS.Cipher]

112−#if MIN_VERSION_tls(1,5,0)

113− -- ^ The TLS ciphers this server accepts.

114− --

115− -- >>> tlsCiphers defaultTlsSettings

116− -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1,AES128GCM-SHA256,AES256GCM-SHA384]

117− --

118− -- Since 1.4.2

119−#else

120 -- ^ The TLS ciphers this server accepts.

100 -- ^ The TLS ciphers this server accepts.

121 --

101 --

122 -- >>> tlsCiphers defaultTlsSettings

102 -- >>> tlsCiphers defaultTlsSettings

123 -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1]

103 -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1]

124 --

104 --

125 -- Since 1.4.2

105 -- Since 1.4.2

126−#endif

127 , tlsWantClientCert :: Bool

106 , tlsWantClientCert :: Bool

128 -- ^ Whether or not to demand a certificate from the client. If this

107 -- ^ Whether or not to demand a certificate from the client. If this

129 -- is set to True, you must handle received certificates in a server hook

108 -- is set to True, you must handle received certificates in a server hook

@@ -170,11 +149,7 @@ defaultTlsSettings = TLSSettings {

170 , keyMemory = Nothing

149 , keyMemory = Nothing

171 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

150 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

172 , tlsLogging = def

151 , tlsLogging = def

173−#if MIN_VERSION_tls(1,5,0)

174− , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]

175−#else

176 , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]

152 , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]

177−#endif

178 , tlsCiphers = ciphers

153 , tlsCiphers = ciphers

179 , tlsWantClientCert = False

154 , tlsWantClientCert = False

180 , tlsServerHooks = def

155 , tlsServerHooks = def

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

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

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

282 runSettingsConnectionMakerSecure set get app

257 runSettingsConnectionMakerSecure set get app

283 where

258 where

284− get = getter tlsset set sock params

259+ get = getter tlsset sock params

285 params = def { -- TLS.ServerParams

260 params = def { -- TLS.ServerParams

286 TLS.serverWantClientCert = tlsWantClientCert

261 TLS.serverWantClientCert = tlsWantClientCert

287 , TLS.serverCACertificates = []

262 , TLS.serverCACertificates = []

@@ -289,9 +264,6 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

289 , TLS.serverHooks = hooks

264 , TLS.serverHooks = hooks

290 , TLS.serverShared = shared

265 , TLS.serverShared = shared

291 , TLS.serverSupported = supported

266 , TLS.serverSupported = supported

292−#if MIN_VERSION_tls(1,5,0)

293− , TLS.serverEarlyDataSize = 2018

294−#endif

295 }

267 }

296 -- Adding alpn to user's tlsServerHooks.

268 -- Adding alpn to user's tlsServerHooks.

297 hooks = tlsServerHooks {

269 hooks = tlsServerHooks {

@@ -310,9 +282,6 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

310 , TLS.supportedClientInitiatedRenegotiation = False

282 , TLS.supportedClientInitiatedRenegotiation = False

311 , TLS.supportedSession = True

283 , TLS.supportedSession = True

312 , TLS.supportedFallbackScsv = True

284 , TLS.supportedFallbackScsv = True

313−#if MIN_VERSION_tls(1,5,0)

314− , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]

315−#endif

316 }

285 }

317

286

318alpn :: [S.ByteString] -> IO S.ByteString

287alpn :: [S.ByteString] -> IO S.ByteString

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

322

291

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

292----------------------------------------------------------------

324

293

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

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

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

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

327#if WINDOWS

296#if WINDOWS

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

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

329#else

298#else

330 (s, sa) <- accept sock

299 (s, sa) <- accept sock

331#endif

300#endif

332 setSocketCloseOnExec s

301 setSocketCloseOnExec s

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

302+ return (mkConn tlsset s params, sa)

334

303

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

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

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

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

337 where

306 where

338 switch = do

307 switch = do

339 firstBS <- safeRecv s 4096

308 firstBS <- safeRecv s 4096

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

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

341− httpOverTls tlsset set s firstBS params

310+ httpOverTls tlsset s firstBS params

342 else

311 else

343− plainHTTP tlsset set s firstBS

312+ plainHTTP tlsset s firstBS

344

313

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

314----------------------------------------------------------------

346

315

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

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

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

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

349 recvN <- makePlainReceiveN s bs0

318 recvN <- makePlainReceiveN s bs0

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

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

351 TLS.contextHookSetLogging ctx tlsLogging

320 TLS.contextHookSetLogging ctx tlsLogging

352 TLS.handshake ctx

321 TLS.handshake ctx

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

354− isH2 <- I.newIORef h2

355 writeBuf <- allocateBuffer bufferSize

322 writeBuf <- allocateBuffer bufferSize

356 -- Creating a cache for leftover input data.

323 -- Creating a cache for leftover input data.

357 ref <- I.newIORef ""

324 ref <- I.newIORef ""

358 tls <- getTLSinfo ctx

325 tls <- getTLSinfo ctx

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

326+ return (conn ctx writeBuf ref, tls)

360 where

327 where

361 backend recvN = TLS.Backend {

328 backend recvN = TLS.Backend {

362 TLS.backendFlush = return ()

329 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

330 , TLS.backendClose = close s

367−#endif

368 , TLS.backendSend = sendAll' s

331 , TLS.backendSend = sendAll' s

369 , TLS.backendRecv = recvN

332 , TLS.backendRecv = recvN

370 }

333 }

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

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

372 throwIO ConnectionClosedByPeer

335 throwIO ConnectionClosedByPeer

373− conn ctx writeBuf ref isH2 = Connection {

336+ conn ctx writeBuf ref = Connection {

374 connSendMany = TLS.sendData ctx . L.fromChunks

337 connSendMany = TLS.sendData ctx . L.fromChunks

375 , connSendAll = sendall

338 , connSendAll = sendall

376 , connSendFile = sendfile

339 , connSendFile = sendfile

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

380 , connRecvBuf = recvBuf ref

343 , connRecvBuf = recvBuf ref

381 , connWriteBuffer = writeBuf

344 , connWriteBuffer = writeBuf

382 , connBufferSize = bufferSize

345 , connBufferSize = bufferSize

383− , connHTTP2 = isH2

384 }

346 }

385 where

347 where

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

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

@@ -465,16 +427,11 @@ getTLSinfo ctx = do

465 TLS.TLS10 -> (3,1)

427 TLS.TLS10 -> (3,1)

466 TLS.TLS11 -> (3,2)

428 TLS.TLS11 -> (3,2)

467 TLS.TLS12 -> (3,3)

429 TLS.TLS12 -> (3,3)

468−#if MIN_VERSION_tls(1,5,0)

469− TLS.TLS13 -> (3,4)

470−#endif

471− clientCert <- TLS.getClientCertificateChain ctx

472 return TLS {

430 return TLS {

473 tlsMajorVersion = major

431 tlsMajorVersion = major

474 , tlsMinorVersion = minor

432 , tlsMinorVersion = minor

475 , tlsNegotiatedProtocol = proto

433 , tlsNegotiatedProtocol = proto

476 , tlsChiperID = TLS.cipherID infoCipher

434 , tlsChiperID = TLS.cipherID infoCipher

477− , tlsClientCertificate = clientCert

478 }

435 }

479

436

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

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

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

482

439

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

440----------------------------------------------------------------

484

441

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

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

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

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

487 AllowInsecure -> do

444 AllowInsecure -> do

488− conn' <- socketConnection set s

445+ conn' <- socketConnection s

489 cachedRef <- I.newIORef bs0

446 cachedRef <- I.newIORef bs0

490 let conn'' = conn'

447 let conn'' = conn'

491 { connRecv = recvPlain cachedRef (connRecv conn')

448 { connRecv = recvPlain cachedRef (connRecv conn')

warp-tls/warp-tls.cabal+6−9

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

1Name: warp-tls

2−Version: 3.2.11

2+Version: 3.2.4.3

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

4License: MIT

5License-file: LICENSE

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

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

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >= 1.10

11+Cabal-Version: >=1.6

12Stability: Stable

13description: SSLv1 and SSLv2 are obsoleted by IETF.

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

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

34 Cpp-Options: -DWINDOWS

35− if impl(ghc >= 8)

36− Default-Extensions: Strict StrictData

37− Default-Language: Haskell2010

38

35

39

36

40source-repository head

37source-repository head

warp/ChangeLog.md−93

@@ -1,96 +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

58−

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

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

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

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

63−* Fixing a bug of ALPN.

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

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

66−

67−## 3.2.27

68−

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

70− value of the `PORT` environment variable

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

72−* Throw 413 for too large payload

73−* Throw 431 for too large headers

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

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

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

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

78−

79−## 3.2.26

80−

81−* Support network package version 3

82−

83−## 3.2.25

84−

85−* Removing Connection: and Transfer-Encoding: from HTTP/2

86− response header

87− [#707](https://github.com/yesodweb/wai/pull/707)

88−

89−## 3.2.24

90−

91−* Fix HTTP2 unwanted GoAways on late WindowUpdate frames.

92− [#711](https://github.com/yesodweb/wai/pull/711)

93−

94## 3.2.23

1## 3.2.23

95

2

96* Log real requsts when an app throws an error.

3* Log real requsts when an app throws an error.

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

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

134−import System.TimeManager

135

127

136import Network.Wai.Handler.Warp.FileInfoCache

128import Network.Wai.Handler.Warp.FileInfoCache

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

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

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

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

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

142import Network.Wai.Handler.Warp.Run

134import Network.Wai.Handler.Warp.Run

143import Network.Wai.Handler.Warp.Settings

135import Network.Wai.Handler.Warp.Settings

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

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

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

145import Network.Wai.Handler.Warp.WithApplication

138import Network.Wai.Handler.Warp.WithApplication

146

139

@@ -303,18 +296,6 @@ getGracefulShutdownTimeout = settingsGracefulShutdownTimeout

303-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

296-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

304-- @

297-- @

305--

298--

306−-- Note that by default, the graceful shutdown mode lasts indefinitely

307−-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,

308−-- upon receiving that signal, the custon shutdown action will run /and/ all

309−-- outstanding requests will be handled.

310−--

311−-- You may instead prefer to do one or both of the following:

312−--

313−-- * Only wait a finite amount of time for outstanding requests to complete,

314−-- using 'setGracefulShutdownTimeout'.

315−-- * Only catch one signal, so the second hard-kills the Warp server, using

316−-- 'System.Posix.Signals.CatchOnce'.

317−--

318-- Default: does not install any code.

299-- Default: does not install any code.

319--

300--

320-- Since 3.0.1

301-- Since 3.0.1

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

385--

366--

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

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

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

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

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

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

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

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

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

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

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

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

@@ -428,22 +409,11 @@ setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }

428-- wait indefinitely, and a number, if provided, will be treated as seconds

409-- wait indefinitely, and a number, if provided, will be treated as seconds

429-- to wait for requests to finish, before shutting down the server entirely.

410-- to wait for requests to finish, before shutting down the server entirely.

430--

411--

431−-- Graceful shutdown mode is entered when the server socket is closed; see

432−-- 'setInstallShutdownHandler' for an example of how this could be done in

433−-- response to a UNIX signal.

434−--

435-- Since 3.2.8

412-- Since 3.2.8

436setGracefulShutdownTimeout :: Maybe Int

413setGracefulShutdownTimeout :: Maybe Int

437 -> Settings -> Settings

414 -> Settings -> Settings

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

415setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

439

416

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.

417-- | Explicitly pause the slowloris timeout.

448--

418--

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

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

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

471-- Since 3.1.10

441-- Since 3.1.10

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

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

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

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

474−

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

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

477−-- Default: 0.

478−--

479−-- Since 3.3.5

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

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

482−

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

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

485−--

486−-- Since 3.3.5

487−getGracefulCloseTimeout1 :: Settings -> Int

488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489−

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

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

492−-- Default: 2000.

493−--

494−-- Since 3.3.5

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

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

497−

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

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

500−--

501−-- Since 3.3.5

502−getGracefulCloseTimeout2 :: Settings -> Int

503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504−

505−-- | Getting information of client certificate.

506−--

507−-- Since 3.3.5

508−clientCertificate :: Request -> Maybe CertificateChain

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

warp/Network/Wai/Handler/Warp/FdCache.hs+22−18

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

17import Control.Exception (bracket)

18import Control.Reaper

19import Data.IORef

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

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

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

22#endif

23import System.Posix.Types (Fd)

24

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

26

27+type Hash = Int

28+

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

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

28type Refresh = IO ()

30type Refresh = IO ()

29

31

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

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

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

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

32

34

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

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

34

36

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

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

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

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

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

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

38#ifdef WINDOWS

40#ifdef WINDOWS

39withFdCache _ action = action getFdNothing

41withFdCache _ action = action getFdNothing

40#else

42#else

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

63

65

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

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

65

67

66−data FdEntry = FdEntry !Fd !MutableStatus

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

67

69

68openFile :: FilePath -> IO Fd

70openFile :: FilePath -> IO Fd

69openFile path = do

71openFile path = do

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

75closeFile = closeFd

77closeFile = closeFd

76

78

77newFdEntry :: FilePath -> IO FdEntry

79newFdEntry :: FilePath -> IO FdEntry

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

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

79

81

80setFileCloseOnExec :: Fd -> IO ()

82setFileCloseOnExec :: Fd -> IO ()

81setFileCloseOnExec fd = setFdOption fd CloseOnExec True

83setFileCloseOnExec fd = setFdOption fd CloseOnExec True

82

84

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

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

84

86

85−type FdCache = MultiMap FdEntry

87+type FdCache = MMap FdEntry

86

88

87-- | Mutable Fd cacher.

89-- | Mutable Fd cacher.

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

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

89

91

90fdCache :: MutableFdCache -> IO FdCache

92fdCache :: MutableFdCache -> IO FdCache

91fdCache (MutableFdCache reaper) = reaperRead reaper

93fdCache (MutableFdCache reaper) = reaperRead reaper

92

94

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

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

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

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

97+ where

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

95

99

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

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

97

101

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

112 new <- pruneWith old prune

116 new <- pruneWith old prune

113 return $ merge new

117 return $ merge new

114 where

118 where

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

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

116 where

120 where

117 act Active = inactive mst >> return True

121 act Active = inactive mst >> return True

118 act Inactive = closeFd fd >> return False

122 act Inactive = closeFd fd >> return False

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

122terminate :: MutableFdCache -> IO ()

126terminate :: MutableFdCache -> IO ()

123terminate (MutableFdCache reaper) = do

127terminate (MutableFdCache reaper) = do

124 !t <- reaperStop reaper

128 !t <- reaperStop reaper

125− mapM_ (closeIt . snd) $ toList t

129+ mapM_ closeIt $ toList t

126 where

130 where

127− closeIt (FdEntry fd _) = closeFd fd

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

128

132

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

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

130

134

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

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

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

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

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

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

134 where

138 where

135 get Nothing = do

139 get Nothing = do

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

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

137− reaperAdd reaper (path,ent)

141+ reaperAdd reaper (h, ent)

138 return (Just fd, refresh mst)

142 return (Just fd, refresh mst)

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

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

140 refresh mst

144 refresh mst

141 return (Just fd, refresh mst)

145 return (Just fd, refresh mst)

142#endif

146#endif

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

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

2

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

4 FileInfo(..)

5+ , Hash

5 , withFileInfoCache

6 , withFileInfoCache

6 , getInfo -- test purpose only

7 , getInfo -- test purpose only

7 ) where

8 ) where

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

17

18

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

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

19

20

21+type Hash = Int

22+

20-- | File information.

23-- | File information.

21data FileInfo = FileInfo {

24data FileInfo = FileInfo {

22 fileInfoName :: !FilePath

25 fileInfoName :: !FilePath

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

26 } deriving (Eq, Show)

29 } deriving (Eq, Show)

27

30

28data Entry = Negative | Positive FileInfo

31data Entry = Negative | Positive FileInfo

29−type Cache = HashMap Entry

32+type Cache = HashMap FilePath Entry

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

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

31

34

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

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

33

36

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

51 else

54 else

52 throwIO (userError "FileInfoCache:getInfo")

55 throwIO (userError "FileInfoCache:getInfo")

53

56

54−getInfoNaive :: FilePath -> IO FileInfo

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

55−getInfoNaive = getInfo

58+getInfoNaive _ = getInfo

56

59

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

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

58

61

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

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

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

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

61 cache <- reaperRead

64 cache <- reaperRead

62− case M.lookup path cache of

65+ case M.lookup h path cache of

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

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

64 Just (Positive x) -> return x

67 Just (Positive x) -> return x

65− Nothing -> positive reaper path

68+ Nothing -> positive reaper h path

66− `E.onException` negative reaper path

69+ `E.onException` negative reaper h path

67

70

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

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

69−positive Reaper{..} path = do

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

70 info <- getInfo path

73 info <- getInfo path

71− reaperAdd (path, Positive info)

74+ reaperAdd (h, path, Positive info)

72 return info

75 return info

73

76

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

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

75−negative Reaper{..} path = do

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

76− reaperAdd (path, Negative)

79+ reaperAdd (h, path,Negative)

77 throwIO (userError "FileInfoCache:negative")

80 throwIO (userError "FileInfoCache:negative")

78

81

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

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

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

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

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

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

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

84withFileInfoCache :: Int

87withFileInfoCache :: Int

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

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

86 -> IO a

89 -> IO a

87withFileInfoCache 0 action = action getInfoNaive

90withFileInfoCache 0 action = action getInfoNaive

88withFileInfoCache duration action =

91withFileInfoCache duration action =

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

90 terminate

93 terminate

91 (action . getAndRegisterInfo)

94 (action . getAndRegisterInfo)

92

95

93−initialize :: Int -> IO FileInfoCache

96+initialize :: Hash -> IO FileInfoCache

94initialize duration = mkReaper settings

97initialize duration = mkReaper settings

95 where

98 where

96 settings = defaultReaperSettings {

99 settings = defaultReaperSettings {

97 reaperAction = override

100 reaperAction = override

98 , reaperDelay = duration

101 , reaperDelay = duration

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

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

100− , reaperNull = M.isEmpty

103+ , reaperNull = M.null

101 , reaperEmpty = M.empty

104 , reaperEmpty = M.empty

102 }

105 }

103

106

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

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

1−{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE PatternGuards #-}

2+{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6

3

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

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

8

5

9−import qualified Data.IORef as I

6+import Control.Concurrent (forkIO, killThread)

10import qualified Control.Exception as E

7import qualified Control.Exception as E

11−import qualified Network.HTTP2.Server as H2

8+import Network.HTTP2

12import Network.Socket (SockAddr)

9import Network.Socket (SockAddr)

13import Network.Wai

10import Network.Wai

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

15−import qualified System.TimeManager as T

16

11

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

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

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

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

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

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

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

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

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

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

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

21import Network.Wai.Handler.Warp.Imports

19import Network.Wai.Handler.Warp.Imports

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

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

23import Network.Wai.Handler.Warp.Types

21import Network.Wai.Handler.Warp.Types

24

22

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

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

26

24

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

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

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

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

29− H2.run conf http2server

27+ checkTLS

28+ ok <- checkPreface

29+ when ok $ do

30+ ctx <- newContext

31+ -- Workers, worker manager and timer manager

32+ mgr <- start settings

33+ let responder = response settings ctx mgr

34+ action = worker ctx settings app responder

35+ setAction mgr action

36+ -- The number of workers is 3.

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

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

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

40+ -- context switches happen.

41+ replicateM_ 3 $ spawnAction mgr

42+ -- Receiver

43+ let mkreq = mkRequest ii1 settings addr

44+ tid <- forkIO $ frameReceiver ctx mkreq readN

45+ -- Sender

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

47+ -- a goway frame.

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

49+ clearContext ctx

50+ stop mgr

51+ killThread tid

30 where

52 where

31− conf = H2.Config {

53+ checkTLS = case transport of

32− confWriteBuffer = connWriteBuffer conn

54+ TCP -> return () -- direct

33− , confBufferSize = connBufferSize conn

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

34− , confSendAll = send

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

35− , confReadN = readN

57+ checkPreface = do

36− , confPositionReadMaker = pReadMaker ii

58+ preface <- readN connectionPrefaceLength

37− }

59+ if connectionPreface /= preface then do

38−

60+ goaway conn ProtocolError "Preface mismatch"

39− http2server h2req aux response = do

61+ return False

40− req <- toWAIRequest h2req aux

62+ else

41− ref <- I.newIORef Nothing

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

43− h2rsp <- fromResponse settings ii req rsp

44− pps <- fromPushPromises ii req

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

46− _ <- response h2rsp pps

47− return ResponseReceived

48− case eResponseReceived of

49− Right ResponseReceived -> do

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

51− logResponse h2rsp req

52− mapM_ (logPushPromise req) pps

53− Left e@(E.SomeException _)

54− -- killed by the local worker manager

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

56− -- killed by the local timeout manager

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

58− | otherwise -> do

59− S.settingsOnException settings (Just req) e

60− let ersp = S.settingsOnExceptionResponse settings e

61− h2rsp' <- fromResponse settings ii req ersp

62− _ <- response h2rsp' []

63− logResponse h2rsp' req

64− return ()

63+ return True

65

64

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

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

67− where

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

68− !hdr = H2.requestHeaders h2req

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

69− !bdy = H2.getRequestBodyChunk h2req

68+ where

70− !bdylen = H2.requestBodySize h2req

69+ bytestream = goawayFrame 0 etype debugmsg

71− !th = H2.auxTimeHandle aux

72−

73− logResponse h2rsp req = logger req st msiz

74− where

75− !logger = S.settingsLogger settings

76− !st = H2.responseStatus h2rsp

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

78−

79− logPushPromise req pp = logger req path siz

80− where

81− !logger = S.settingsServerPushLogger settings

82− !path = H2.promiseRequestPath pp

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

84− Nothing -> 0

85− Just s -> fromIntegral s

warp/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hsnew file+34

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

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

2+

3+import Network.HTTP2

4+

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

6+

7+----------------------------------------------------------------

8+

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

10+goawayFrame sid etype debugmsg = encodeFrame einfo frame

11+ where

12+ einfo = encodeInfo id 0

13+ frame = GoAwayFrame sid etype debugmsg

14+

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

16+resetFrame etype sid = encodeFrame einfo frame

17+ where

18+ einfo = encodeInfo id sid

19+ frame = RSTStreamFrame etype

20+

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

22+settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist

23+ where

24+ einfo = encodeInfo func 0

25+

26+pingFrame :: ByteString -> ByteString

27+pingFrame bs = encodeFrame einfo $ PingFrame bs

28+ where

29+ einfo = encodeInfo setAck 0

30+

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

32+windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz

33+ where

34+ einfo = encodeInfo id sid

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

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE BangPatterns #-}

2

4

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

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

6+ RspFileInfo(..)

7+ , conditionalRequest

8+ , addContentHeadersForFilePart

9+ , H.parseByteRanges

10+ ) where

4

11

5−import Network.HTTP2.Server

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

13+import Network.HPACK

14+import Network.HPACK.Token

15+import Network.HTTP.Date

16+import qualified Network.HTTP.Types as H

17+import Network.Wai

6

18

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

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

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

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

8

22

9−#ifdef WINDOWS

23+-- $setup

10−pReadMaker :: InternalInfo -> PositionReadMaker

24+-- >>> import Test.QuickCheck

11−pReadMaker _ = defaultPositionReadMaker

12−#else

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

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

15

25

16−pReadMaker :: InternalInfo -> PositionReadMaker

26+----------------------------------------------------------------

17−pReadMaker ii path = do

27+

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

28+data RspFileInfo = WithoutBody !H.Status

19− case mfd of

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

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

30+ deriving (Eq,Show)

21− Nothing -> do

31+

22− fd <- openFile path

32+----------------------------------------------------------------

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

33+

34+conditionalRequest :: I.FileInfo

35+ -> TokenHeaderList -- Response

36+ -> ValueTable -- Request

37+ -> RspFileInfo

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

39+ nobody@(WithoutBody _) -> nobody

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

41+ addContentHeaders ths0 off len size

42+ in WithBody s hs off len

43+ where

44+ !mcondition = ifmodified reqtbl size mtime

45+ <|> ifunmodified reqtbl size mtime

46+ <|> ifrange reqtbl size mtime

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

48+

49+----------------------------------------------------------------

50+

51+{-# INLINE ifModifiedSince #-}

52+ifModifiedSince :: ValueTable -> Maybe HTTPDate

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

54+

55+{-# INLINE ifUnmodifiedSince #-}

56+ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate

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

58+

59+{-# INLINE ifRange #-}

60+ifRange :: ValueTable -> Maybe HTTPDate

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

62+

63+----------------------------------------------------------------

64+

65+{-# INLINE ifmodified #-}

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

67+ifmodified reqtbl size mtime = do

68+ date <- ifModifiedSince reqtbl

69+ return $ if date /= mtime

70+ then unconditional reqtbl size

71+ else WithoutBody H.notModified304

72+

73+{-# INLINE ifunmodified #-}

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

75+ifunmodified reqtbl size mtime = do

76+ date <- ifUnmodifiedSince reqtbl

77+ return $ if date == mtime

78+ then unconditional reqtbl size

79+ else WithoutBody H.preconditionFailed412

80+

81+{-# INLINE ifrange #-}

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

83+ifrange reqtbl size mtime = do

84+ date <- ifRange reqtbl

85+ rng <- getHeaderValue tokenRange reqtbl

86+ return $ if date == mtime

87+ then parseRange rng size

88+ else WithBody H.ok200 [] 0 size

89+

90+{-# INLINE unconditional #-}

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

92+unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of

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

94+ Just rng -> parseRange rng size

95+

96+----------------------------------------------------------------

97+

98+{-# INLINE parseRange #-}

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

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

101+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416

102+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416

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

104+ !len = end - beg + 1

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

106+ H.ok200

107+ else

108+ H.partialContent206

109+ in WithBody s [] beg len

110+

111+{-# INLINE checkRange #-}

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

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

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

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

116+

117+----------------------------------------------------------------

118+

119+{-# INLINE contentRangeHeader #-}

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

121+-- for the range specified.

122+contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader

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

124+ where

125+ range = C8.pack

126+ -- building with ShowS

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

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

129+ showInt beg

130+ . ('-' :)

131+ . showInt end)

132+ ( '/'

133+ : showInt total "")

134+

135+{-# INLINE addContentHeaders #-}

136+addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList

137+addContentHeaders ths off len size

138+ | len == size = ths'

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

140+ in ctrng:ths'

141+ where

142+ !lengthBS = packIntegral len

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

144+

145+{-# INLINE addContentHeadersForFilePart #-}

146+-- |

147+--

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

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

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

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

152+addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList

153+addContentHeadersForFilePart hs part = addContentHeaders hs off len size

24 where

154 where

25− pread :: Fd -> PositionRead

155+ off = filePartOffset part

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

156+ len = filePartByteCount part

27− where

157+ size = filePartFileSize part

28− bytes' = fromIntegral bytes

29− off' = fromIntegral off

30−#endif

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hsnew file+112

@@ -0,0 +1,112 @@

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

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

3+

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

5+ hpackEncodeHeader

6+ , hpackEncodeHeaderLoop

7+ , hpackDecodeHeader

8+ , just

9+ , addNecessaryHeaders

10+ , addHeader -- testing

11+ ) where

12+

13+import qualified Control.Exception as E

14+import Network.HPACK hiding (Buffer)

15+import Network.HPACK.Token

16+import Network.HTTP2

17+

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

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

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

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

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

23+

24+-- $setup

25+-- >>> :set -XOverloadedStrings

26+

27+----------------------------------------------------------------

28+

29+{-# INLINE addHeader #-}

30+addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList

31+addHeader t "" tbl ths = case getHeaderValue t tbl of

32+ Nothing -> ths

33+ _ -> filter ((/= tokenServer) . fst) ths

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

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

36+ _ -> ths

37+

38+addNecessaryHeaders :: Context

39+ -> Rspn

40+ -> InternalInfo

41+ -> S.Settings

42+ -> IO TokenHeaderList

43+addNecessaryHeaders Context{..} rspn ii settings = do

44+ date <- getDate ii

45+ let !s = rspnStatus rspn

46+ !status = packStatus s

47+ !defServer = S.settingsServerName settings

48+ (!ths0,tbl) = rspnHeaders rspn

49+ !ths1 = addHeader tokenServer defServer tbl ths0

50+ !ths2 = addHeader tokenDate date tbl ths1

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

52+ return ths3

53+

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

55+

56+strategy :: EncodeStrategy

57+strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }

58+

59+-- Set-Cookie: contains only one cookie value.

60+-- So, we don't need to split it.

61+hpackEncodeHeader :: Context -> Buffer -> BufSize

62+ -> TokenHeaderList

63+ -> IO (TokenHeaderList, Int)

64+hpackEncodeHeader Context{..} buf siz ths =

65+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths

66+

67+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize

68+ -> TokenHeaderList

69+ -> IO (TokenHeaderList, Int)

70+hpackEncodeHeaderLoop Context{..} buf siz hs =

71+ encodeTokenHeader buf siz strategy False encodeDynamicTable hs

72+

73+----------------------------------------------------------------

74+

75+hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)

76+hpackDecodeHeader hdrblk Context{..} = do

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

78+ unless (checkRequestHeader vt) $

79+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

80+ return tbl

81+ where

82+ handl IllegalHeaderName =

83+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

84+ handl _ =

85+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"

86+

87+{-# INLINE checkRequestHeader #-}

88+checkRequestHeader :: ValueTable -> Bool

89+checkRequestHeader reqvt

90+ | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme

91+ | isJust mStatus = False

92+ | isNothing mMethod = False

93+ | isNothing mScheme = False

94+ | isNothing mPath = False

95+ | mPath == Just "" = False

96+ | isJust mConnection = False

97+ | just mTE (/= "trailers") = False

98+ | otherwise = True

99+ where

100+ mStatus = getHeaderValue tokenStatus reqvt

101+ mScheme = getHeaderValue tokenScheme reqvt

102+ mPath = getHeaderValue tokenPath reqvt

103+ mMethod = getHeaderValue tokenMethod reqvt

104+ mConnection = getHeaderValue tokenConnection reqvt

105+ mTE = getHeaderValue tokenTE reqvt

106+

107+{-# INLINE just #-}

108+just :: Maybe a -> (a -> Bool) -> Bool

109+just Nothing _ = False

110+just (Just x) p

111+ | p x = True

112+ | otherwise = False

warp/Network/Wai/Handler/Warp/HTTP2/Manager.hsnew file+95

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

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

2+

3+-- | A thread pool manager.

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

5+-- worker threads.

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

7+ Manager

8+ , start

9+ , setAction

10+ , stop

11+ , spawnAction

12+ , addMyId

13+ , deleteMyId

14+ ) where

15+

16+import Control.Concurrent

17+import Control.Concurrent.STM

18+import Data.Foldable

19+import Data.IORef

20+import Data.Set (Set)

21+import qualified Data.Set as Set

22+

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

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

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

26+

27+----------------------------------------------------------------

28+

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

30+

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

32+

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

34+

35+-- | Starting a thread pool manager.

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

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

38+-- the manager itself.

39+start :: Settings -> IO Manager

40+start set = do

41+ q <- newTQueueIO

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

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

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

45+ return $ Manager q ref

46+ where

47+ go q !tset0 ref timmgr = do

48+ x <- atomically $ readTQueue q

49+ case x of

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

51+ Spawn -> next tset0

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

53+ in go q tset ref timmgr

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

55+ in go q tset ref timmgr

56+ where

57+ next tset = do

58+ action <- readIORef ref

59+ newtid <- forkIO (action timmgr)

60+ let !tset' = add newtid tset

61+ go q tset' ref timmgr

62+

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

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

65+

66+stop :: Manager -> IO ()

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

68+

69+spawnAction :: Manager -> IO ()

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

71+

72+addMyId :: Manager -> IO ()

73+addMyId (Manager q _) = do

74+ tid <- myThreadId

75+ atomically $ writeTQueue q $ Add tid

76+

77+deleteMyId :: Manager -> IO ()

78+deleteMyId (Manager q _) = do

79+ tid <- myThreadId

80+ atomically $ writeTQueue q $ Delete tid

81+

82+----------------------------------------------------------------

83+

84+add :: ThreadId -> Set ThreadId -> Set ThreadId

85+add tid set = set'

86+ where

87+ !set' = Set.insert tid set

88+

89+del :: ThreadId -> Set ThreadId -> Set ThreadId

90+del tid set = set'

91+ where

92+ !set' = Set.delete tid set

93+

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

95+kill set = traverse_ killThread set

warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hsdeleted−36

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

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

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

6−

7−import qualified Control.Exception as E

8−import qualified Network.HTTP.Types as H

9−import qualified Network.HTTP2.Server as H2

10−

11−import Network.Wai

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

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

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

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

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

17−

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

19−fromPushPromises ii req = do

20− mh2data <- getHTTP2Data req

21− let pp = case mh2data of

22− Nothing -> []

23− Just h2data -> http2dataPushPromise h2data

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

25−

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

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

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

29− case efinfo of

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

31− Right finfo -> do

32− let !siz = fromIntegral $ fileInfoSize finfo

33− !fileSpec = H2.FileSpec file 0 siz

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

35− !pp = H2.pushPromise path rsp w

36− return $ Just pp

warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hsnew file+397

@@ -0,0 +1,397 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE NamedFieldPuns #-}

3+{-# LANGUAGE BangPatterns #-}

4+{-# LANGUAGE CPP #-}

5+{-# LANGUAGE PatternGuards #-}

6+

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

8+

9+import Control.Concurrent

10+import Control.Concurrent.STM

11+import qualified Control.Exception as E

12+import qualified Data.ByteString as BS

13+import Data.IORef

14+import Network.HPACK

15+import Network.HPACK.Token

16+import Network.HTTP2

17+import Network.HTTP2.Priority (toPrecedence, delete, prepare)

18+

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

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

21+import Network.Wai.Handler.Warp.HTTP2.Request

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

23+import Network.Wai.Handler.Warp.Imports hiding (delete, insert, readInt)

24+import Network.Wai.Handler.Warp.ReadInt

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

26+

27+----------------------------------------------------------------

28+

29+frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()

30+frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway

31+ where

32+ Context{ http2settings

33+ , streamTable

34+ , concurrency

35+ , continued

36+ , clientStreamId

37+ , inputQ

38+ , controlQ

39+ } = ctx

40+ sendGoaway e

41+ | Just (ConnectionError err msg) <- E.fromException e = do

42+ csid <- readIORef clientStreamId

43+ let !frame = goawayFrame csid err msg

44+ enqueueControl controlQ $ CGoaway frame

45+ | otherwise = return ()

46+

47+ sendReset err sid = do

48+ let !frame = resetFrame err sid

49+ enqueueControl controlQ $ CFrame frame

50+

51+ loop :: Int -> IO ()

52+ loop !n

53+ | n == 6 = do

54+ yield

55+ loop 0

56+ | otherwise = do

57+ hd <- recvN frameHeaderLength

58+ if BS.null hd then

59+ enqueueControl controlQ CFinish

60+ else do

61+ cont <- processStreamGuardingError $ decodeFrameHeader hd

62+ when cont $ loop (n + 1)

63+

64+ processStreamGuardingError (fid, FrameHeader{streamId})

65+ | isResponse streamId &&

66+ (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =

67+ E.throwIO $ ConnectionError ProtocolError "stream id should be odd"

68+ processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do

69+ mx <- readIORef continued

70+ case mx of

71+ Nothing -> do

72+ -- ignoring unknown frame

73+ consume payloadLength

74+ return True

75+ Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"

76+ processStreamGuardingError (FramePushPromise, _) =

77+ E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"

78+ processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do

79+ settings <- readIORef http2settings

80+ case checkFrameHeader settings typhdr of

81+ Left h2err -> case h2err of

82+ StreamError err sid -> do

83+ sendReset err sid

84+ consume payloadLength

85+ return True

86+ connErr -> E.throwIO connErr

87+ Right _ -> do

88+ ex <- E.try $ controlOrStream ftyp header

89+ case ex of

90+ Left (StreamError err sid) -> do

91+ sendReset err sid

92+ return True

93+ Left connErr -> E.throw connErr

94+ Right cont -> return cont

95+

96+ controlOrStream ftyp header@FrameHeader{streamId, payloadLength}

97+ | isControl streamId = do

98+ pl <- recvN payloadLength

99+ control ftyp header pl ctx

100+ | otherwise = do

101+ checkContinued

102+ !mstrm <- getStream

103+ pl <- recvN payloadLength

104+ case mstrm of

105+ Nothing -> do

106+ -- for h2spec only

107+ when (ftyp == FramePriority) $ do

108+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl

109+ checkPriority newpri streamId

110+ return True -- just ignore this frame

111+ Just strm@Stream{streamState,streamPrecedence} -> do

112+ state <- readIORef streamState

113+ state' <- stream ftyp header pl ctx state strm

114+ case state' of

115+ Open (NoBody tbl@(_,reqvt) pri) -> do

116+ resetContinued

117+ let mcl = readInt <$> getHeaderValue tokenContentLength reqvt

118+ when (just mcl (/= (0 :: Int))) $

119+ E.throwIO $ StreamError ProtocolError streamId

120+ writeIORef streamPrecedence $ toPrecedence pri

121+ writeIORef streamState HalfClosed

122+ (!req, !ii) <- mkreq tbl (Just 0, return "")

123+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii

124+ Open (HasBody tbl@(_,reqvt) pri) -> do

125+ resetContinued

126+ q <- newTQueueIO

127+ let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt

128+ writeIORef streamPrecedence $ toPrecedence pri

129+ bodyLength <- newIORef 0

130+ writeIORef streamState $ Open (Body q mcl bodyLength)

131+ readQ <- newReadBody q

132+ bodySource <- mkSource readQ

133+ (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)

134+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii

135+ s@(Open Continued{}) -> do

136+ setContinued

137+ writeIORef streamState s

138+ s -> do -- Idle, Open Body, HalfClosed, Closed

139+ resetContinued

140+ writeIORef streamState s

141+ return True

142+ where

143+ setContinued = writeIORef continued (Just streamId)

144+ resetContinued = writeIORef continued Nothing

145+ checkContinued = do

146+ mx <- readIORef continued

147+ case mx of

148+ Nothing -> return ()

149+ Just sid

150+ | sid == streamId && ftyp == FrameContinuation -> return ()

151+ | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"

152+ getStream = do

153+ mstrm0 <- search streamTable streamId

154+ case mstrm0 of

155+ js@(Just strm0) -> do

156+ when (ftyp == FrameHeaders) $ do

157+ st <- readIORef $ streamState strm0

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

159+ -- Priority made an idele stream

160+ when (isIdle st) $ opened ctx strm0

161+ return js

162+ Nothing

163+ | isResponse streamId -> return Nothing

164+ | otherwise -> do

165+ when (ftyp `notElem` [FrameHeaders,FramePriority]) $

166+ E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream"

167+ csid <- readIORef clientStreamId

168+ if streamId <= csid then

169+ if ftyp == FramePriority then

170+ return Nothing -- will be ignored

171+ else

172+ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"

173+ else do

174+ when (ftyp == FrameHeaders) $ do

175+ writeIORef clientStreamId streamId

176+ cnt <- readIORef concurrency

177+ -- Checking the limitation of concurrency

178+ when (cnt >= maxConcurrency) $

179+ E.throwIO $ StreamError RefusedStream streamId

180+ ws <- initialWindowSize <$> readIORef http2settings

181+ newstrm <- newStream streamId (fromIntegral ws)

182+ when (ftyp == FrameHeaders) $ opened ctx newstrm

183+ insert streamTable streamId newstrm

184+ return $ Just newstrm

185+

186+ consume = void . recvN

187+

188+maxConcurrency :: Int

189+maxConcurrency = recommendedConcurrency

190+

191+initialFrame :: ByteString

192+initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]

193+

194+----------------------------------------------------------------

195+

196+control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool

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

198+ SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs

199+ case checkSettingsList alist of

200+ Just x -> E.throwIO x

201+ Nothing -> return ()

202+ -- HTTP/2 Setting from a browser

203+ unless (testAck flags) $ do

204+ oldws <- initialWindowSize <$> readIORef http2settings

205+ modifyIORef' http2settings $ \old -> updateSettings old alist

206+ newws <- initialWindowSize <$> readIORef http2settings

207+ let diff = newws - oldws

208+ when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable

209+ let !frame = settingsFrame setAck []

210+ sent <- readIORef firstSettings

211+ let !setframe

212+ | sent = CSettings frame alist

213+ | otherwise = CSettings0 initialFrame frame alist

214+ unless sent $ writeIORef firstSettings True

215+ enqueueControl controlQ setframe

216+ return True

217+

218+control FramePing FrameHeader{flags} bs Context{controlQ} =

219+ if testAck flags then

220+ return True -- just ignore

221+ else do

222+ let !frame = pingFrame bs

223+ enqueueControl controlQ $ CFrame frame

224+ return True

225+

226+control FrameGoAway _ _ Context{controlQ} = do

227+ enqueueControl controlQ CFinish

228+ return False

229+

230+control FrameWindowUpdate header bs Context{connectionWindow} = do

231+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

232+ !w <- atomically $ do

233+ w0 <- readTVar connectionWindow

234+ let !w1 = w0 + n

235+ writeTVar connectionWindow w1

236+ return w1

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

238+ return True

239+

240+control _ _ _ _ =

241+ -- must not reach here

242+ return False

243+

244+----------------------------------------------------------------

245+

246+{-# INLINE guardIt #-}

247+guardIt :: Either HTTP2Error a -> IO a

248+guardIt x = case x of

249+ Left err -> E.throwIO err

250+ Right frame -> return frame

251+

252+

253+{-# INLINE checkPriority #-}

254+checkPriority :: Priority -> StreamId -> IO ()

255+checkPriority p me

256+ | dep == me = E.throwIO $ StreamError ProtocolError me

257+ | otherwise = return ()

258+ where

259+ dep = streamDependency p

260+

261+stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState

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

263+ HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs

264+ pri <- case mp of

265+ Nothing -> return defaultPriority

266+ Just p -> do

267+ checkPriority p streamNumber

268+ return p

269+ let !endOfStream = testEndStream flags

270+ !endOfHeader = testEndHeader flags

271+ if endOfHeader then do

272+ tbl <- hpackDecodeHeader frag ctx -- fixme

273+ return $ if endOfStream then

274+ Open (NoBody tbl pri)

275+ else

276+ Open (HasBody tbl pri)

277+ else do

278+ let !siz = BS.length frag

279+ return $ Open $ Continued [frag] siz 1 endOfStream pri

280+

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

282+ -- trailer is not supported.

283+ -- let's read and ignore it.

284+ HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs

285+ let !endOfStream = testEndStream flags

286+ if endOfStream then do

287+ atomically $ writeTQueue q ""

288+ return HalfClosed

289+ else

290+ -- we don't support continuation here.

291+ E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"

292+

293+stream FrameData

294+ header@FrameHeader{flags,payloadLength,streamId}

295+ bs

296+ Context{controlQ} s@(Open (Body q mcl bodyLength))

297+ Stream{streamNumber} = do

298+ DataFrame body <- guardIt $ decodeDataFrame header bs

299+ let !endOfStream = testEndStream flags

300+ len0 <- readIORef bodyLength

301+ let !len = len0 + payloadLength

302+ writeIORef bodyLength len

303+ when (payloadLength /= 0) $ do

304+ let !frame1 = windowUpdateFrame 0 payloadLength

305+ !frame2 = windowUpdateFrame streamNumber payloadLength

306+ !frame = frame1 `BS.append` frame2

307+ enqueueControl controlQ $ CFrame frame

308+ atomically $ writeTQueue q body

309+ if endOfStream then do

310+ case mcl of

311+ Nothing -> return ()

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

313+ atomically $ writeTQueue q ""

314+ return HalfClosed

315+ else

316+ return s

317+

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

319+ let !endOfHeader = testEndHeader flags

320+ !rfrags' = frag : rfrags

321+ !siz' = siz + BS.length frag

322+ !n' = n + 1

323+ when (siz' > 51200) $ -- fixme: hard coding: 50K

324+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"

325+ when (n' > 10) $ -- fixme: hard coding

326+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"

327+ if endOfHeader then do

328+ let !hdrblk = BS.concat $ reverse rfrags'

329+ tbl <- hpackDecodeHeader hdrblk ctx

330+ return $ if endOfStream then

331+ Open (NoBody tbl pri)

332+ else

333+ Open (HasBody tbl pri)

334+ else

335+ return $ Open $ Continued rfrags' siz' n' endOfStream pri

336+

337+stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do

338+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

339+ !w <- atomically $ do

340+ w0 <- readTVar streamWindow

341+ let !w1 = w0 + n

342+ writeTVar streamWindow w1

343+ return w1

344+ when (isWindowOverflow w) $

345+ E.throwIO $ StreamError FlowControlError streamId

346+ return s

347+

348+stream FrameRSTStream header bs ctx _ strm = do

349+ RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs

350+ let !cc = Reset e

351+ closed ctx strm cc

352+ return $ Closed cc -- will be written to streamState again

353+

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

355+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs

356+ checkPriority newpri streamNumber

357+ oldpre <- readIORef streamPrecedence

358+ let !newpre = toPrecedence newpri

359+ writeIORef streamPrecedence newpre

360+ if isIdle s then do

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

362+ -- fixme hard coding

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

364+ prepare outputQ streamNumber newpri

365+ else do

366+ mx <- delete outputQ streamNumber oldpre

367+ case mx of

368+ Nothing -> return ()

369+ Just out -> enqueueOutput outputQ out

370+ return s

371+

372+-- this ordering is important

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

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

375+-- Ignore frames to streams we have just reset, per section 5.1.

376+stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st

377+stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId

378+stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId

379+

380+----------------------------------------------------------------

381+

382+{-# INLINE newReadBody #-}

383+newReadBody :: TQueue ByteString -> IO (IO ByteString)

384+newReadBody q = do

385+ ref <- newIORef False

386+ return $ readBody q ref

387+

388+{-# INLINE readBody #-}

389+readBody :: TQueue ByteString -> IORef Bool -> IO ByteString

390+readBody q ref = do

391+ eof <- readIORef ref

392+ if eof then

393+ return ""

394+ else do

395+ bs <- atomically $ readTQueue q

396+ when (bs == "") $ writeIORef ref True

397+ return bs

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2

3

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

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

4− toRequest

5+ mkRequest

6+ , MkReq

5 , getHTTP2Data

7 , getHTTP2Data

6 , setHTTP2Data

8 , setHTTP2Data

7 , modifyHTTP2Data

9 , modifyHTTP2Data

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

18import Network.Wai

20import Network.Wai

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

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

20import System.IO.Unsafe (unsafePerformIO)

22import System.IO.Unsafe (unsafePerformIO)

21−import qualified System.TimeManager as T

22

23

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

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

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

24import Network.Wai.Handler.Warp.Imports

26import Network.Wai.Handler.Warp.Imports

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

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

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

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

27import Network.Wai.Handler.Warp.Types

29import Network.Wai.Handler.Warp.Types

28

30

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

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

30

32

31−----------------------------------------------------------------

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

32−

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

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

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

35 ref <- newIORef Nothing

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

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

37

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

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

39 -> IORef (Maybe HTTP2Data)

40− -> ToReq

40+ -> MkReq

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

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

42 where

43 !req = Request {

44 requestMethod = colonMethod

45− , httpVersion = H.http20

45+ , httpVersion = http2ver

46 , rawPathInfo = rawPath

47 , pathInfo = H.decodePathSegments path

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

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

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

78 !path = H.extractPath unparsedPath

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

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

80+ !h = hashByteString rawPath

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

82+ !ii = toInternalInfo ii1 h

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

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

82 $ Vault.insert getHTTP2DataKey (readIORef ref)

84 $ Vault.insert getHTTP2DataKey (readIORef ref)

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

85 $ Vault.insert setHTTP2DataKey (writeIORef ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

86 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

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

86− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

87 Vault.empty

88

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

warp/Network/Wai/Handler/Warp/HTTP2/Response.hsdeleted−127

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

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE BangPatterns #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−

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

7− fromResponse

8− ) where

9−

10−import qualified Control.Exception as E

11−import qualified Data.ByteString.Builder as BB

12−import qualified Network.HTTP.Types as H

13−import qualified Network.HTTP2.Server as H2

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

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

16−

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

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

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

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

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

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

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

24−

25−----------------------------------------------------------------

26−

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

28−fromResponse settings ii req rsp = do

29− date <- getDate ii

30− h2rsp <- case rsp of

31− ResponseFile st rsphdr path mpart -> do

32− let rsphdr' = add date svr rsphdr

33− responseFile st rsphdr' isHead path mpart ii reqhdr

34− ResponseBuilder st rsphdr builder -> do

35− let rsphdr' = add date svr rsphdr

36− return $ responseBuilder st rsphdr' isHead builder

37− ResponseStream st rsphdr strmbdy -> do

38− let rsphdr' = add date svr rsphdr

39− return $ responseStream st rsphdr' isHead strmbdy

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

41− mh2data <- getHTTP2Data req

42− case mh2data of

43− Nothing -> return h2rsp

44− Just h2data -> do

45− let !trailers = http2dataTrailers h2data

46− return $ H2.setResponseTrailersMaker h2rsp trailers

47− where

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

49− !reqhdr = requestHeaders req

50− !svr = S.settingsServerName settings

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

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

53−

54−----------------------------------------------------------------

55−

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

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

58− -> IO H2.Response

59−responseFile st rsphdr _ _ _ _ _

60− | noBody st = return $ responseNoBody st rsphdr

61−

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

63− return $ responseFile2XX st rsphdr isHead fileSpec

64− where

65− !off' = fromIntegral $ filePartOffset fp

66− !bytes' = fromIntegral $ filePartByteCount fp

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

68−

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

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

71− case efinfo of

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

73− Right finfo -> do

74− let reqidx = indexRequestHeader reqhdr

75− rspidx = indexResponseHeader rsphdr

76− case conditionalRequest finfo rsphdr rspidx reqidx of

77− WithoutBody s -> return $ responseNoBody s rsphdr

78− WithBody s rsphdr' off bytes -> do

79− let !off' = fromIntegral off

80− !bytes' = fromIntegral bytes

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

82− return $ responseFile2XX s rsphdr' isHead fileSpec

83−

84−----------------------------------------------------------------

85−

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

87−responseFile2XX st rsphdr isHead fileSpec

88− | isHead = responseNoBody st rsphdr

89− | otherwise = H2.responseFile st rsphdr fileSpec

90−

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

92−

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

94− -> BB.Builder

95− -> H2.Response

96−responseBuilder st rsphdr isHead builder

97− | noBody st = responseNoBody st rsphdr

98− | isHead = responseNoBody st rsphdr

99− | otherwise = H2.responseBuilder st rsphdr builder

100−

101−----------------------------------------------------------------

102−

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

104− -> StreamingBody

105− -> H2.Response

106−responseStream st rsphdr isHead strmbdy

107− | noBody st = responseNoBody st rsphdr

108− | isHead = responseNoBody st rsphdr

109− | otherwise = H2.responseStreaming st rsphdr strmbdy

110−

111−----------------------------------------------------------------

112−

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

114−responseNoBody st rsphdr = H2.responseNoBody st rsphdr

115−

116−----------------------------------------------------------------

117−

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

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

120− where

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

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

123−

124−----------------------------------------------------------------

125−

126−noBody :: H.Status -> Bool

127−noBody = not . R.hasBody

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hsnew file+536

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

1+{-# LANGUAGE OverloadedStrings #-}

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

3+{-# LANGUAGE NamedFieldPuns #-}

4+

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

6+

7+import Control.Concurrent.STM

8+import qualified Control.Exception as E

9+import qualified Data.ByteString as BS

10+import Data.ByteString.Builder (Builder)

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

12+import Data.IORef

13+import Foreign.Ptr (Ptr, plusPtr)

14+import Foreign.Storable (poke)

15+import Network.HPACK (setLimitForEncoding, toHeaderTable)

16+import Network.HTTP2

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

18+import Network.Wai

19+

20+#ifdef WINDOWS

21+import qualified System.IO as IO

22+#else

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

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

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

26+#endif

27+

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

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

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

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

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

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

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

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

36+

37+----------------------------------------------------------------

38+

39+data Leftover = LZero

40+ | LOne B.BufferWriter

41+ | LTwo ByteString B.BufferWriter

42+

43+----------------------------------------------------------------

44+

45+{-# INLINE getStreamWindowSize #-}

46+getStreamWindowSize :: Stream -> IO WindowSize

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

48+

49+{-# INLINE waitStreamWindowSize #-}

50+waitStreamWindowSize :: Stream -> IO ()

51+waitStreamWindowSize Stream{streamWindow} = atomically $ do

52+ w <- readTVar streamWindow

53+ check (w > 0)

54+

55+{-# INLINE waitStreaming #-}

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

57+waitStreaming tbq = atomically $ do

58+ isEmpty <- isEmptyTBQueue tbq

59+ check (not isEmpty)

60+

61+data Switch = C Control

62+ | O (StreamId,Precedence,Output)

63+ | Flush

64+

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

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

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

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

69+ where

70+ dequeue off = do

71+ isEmpty <- isEmptyTQueue controlQ

72+ if isEmpty then do

73+ w <- readTVar connectionWindow

74+ check (w > 0)

75+ emp <- isEmptySTM outputQ

76+ if emp then

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

78+ else

79+ O <$> dequeueSTM outputQ

80+ else

81+ C <$> readTQueue controlQ

82+

83+ loop off = do

84+ x <- atomically $ dequeue off

85+ case x of

86+ C ctl -> do

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

88+ off' <- control ctl off

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

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

91+ let strm = outputStream out

92+ writeIORef (streamPrecedence strm) pre

93+ off' <- outputOrEnqueueAgain out off

94+ case off' of

95+ 0 -> loop 0

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

97+ | otherwise -> loop off'

98+ Flush -> flushN off >> loop 0

99+

100+ control CFinish _ = return (-1)

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

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

103+ control (CSettings frame alist) _ = do

104+ connSendAll frame

105+ setLimit alist

106+ return 0

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

108+ let !buf = connWriteBuffer `plusPtr` off

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

110+ buf' <- copy buf frame1

111+ void $ copy buf' frame2

112+ setLimit alist

113+ return off'

114+

115+ {-# INLINE setLimit #-}

116+ setLimit alist = case lookup SettingsHeaderTableSize alist of

117+ Nothing -> return ()

118+ Just siz -> setLimitForEncoding siz encodeDynamicTable

119+

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

121+ -- Data frame payload

122+ let !buf = connWriteBuffer `plusPtr` off0

123+ !siz = connBufferSize - off0

124+ Next datPayloadLen mnext <- curr buf siz lim

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

126+ maybeEnqueueNext out mnext

127+ return off

128+

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

130+ -- Header frame and Continuation frame

131+ let !sid = streamNumber strm

132+ !endOfStream = case rspn of

133+ RspnNobody _ _ -> True

134+ _ -> False

135+ ths <- addNecessaryHeaders ctx rspn ii settings

136+ kvlen <- headerContinue sid ths endOfStream off0

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

138+ case rspn of

139+ RspnNobody _ _ -> do

140+ closed ctx strm Finished

141+ return off

142+ RspnFile _ _ path mpart -> do

143+ -- Data frame payload

144+ let payloadOff = off + frameHeaderLength

145+ Next datPayloadLen mnext <-

146+ fillFileBodyGetNext conn ii payloadOff lim path mpart

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

148+ maybeEnqueueNext out mnext

149+ return off'

150+ RspnBuilder _ _ builder -> do

151+ -- Data frame payload

152+ let payloadOff = off + frameHeaderLength

153+ Next datPayloadLen mnext <-

154+ fillBuilderBodyGetNext conn ii payloadOff lim builder

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

156+ maybeEnqueueNext out mnext

157+ return off'

158+ RspnStreaming _ _ tbq -> do

159+ let payloadOff = off + frameHeaderLength

160+ Next datPayloadLen mnext <-

161+ fillStreamBodyGetNext conn payloadOff lim tbq strm

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

163+ maybeEnqueueNext out mnext

164+ return off'

165+

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

167+ -- Creating a push promise header

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

169+ let !sid = streamNumber strm

170+ len <- pushPromise pid sid ths off0

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

172+ output out{ outputType = ORspn } off lim

173+

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

175+

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

177+ state <- readIORef $ streamState strm

178+ if isClosed state then

179+ return off

180+ else case out of

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

182+ -- Checking if all push are done.

183+ let out' = out {

184+ outputHook = return ()

185+ , outputType = ORspn

186+ }

187+ forkAndEnqueueWhenReady wait outputQ out' mgr

188+ return off

189+ _ -> case mtbq of

190+ Just tbq -> checkStreaming tbq

191+ _ -> checkStreamWindowSize

192+ where

193+ strm = outputStream out

194+ mtbq = outputMaybeTBQueue out

195+ checkStreaming tbq = do

196+ isEmpty <- atomically $ isEmptyTBQueue tbq

197+ if isEmpty then do

198+ forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr

199+ return off

200+ else

201+ checkStreamWindowSize

202+ checkStreamWindowSize = do

203+ sws <- getStreamWindowSize strm

204+ if sws == 0 then do

205+ forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr

206+ return off

207+ else do

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

209+ let !lim = min cws sws

210+ output out off lim

211+ resetStream e = do

212+ closed ctx strm (ResetByMe e)

213+ let !rst = resetFrame InternalError $ streamNumber strm

214+ enqueueControl controlQ $ CFrame rst

215+ return off

216+

217+ {-# INLINE flushN #-}

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

219+ -- the buffer are filled.

220+ flushN :: Int -> IO ()

221+ flushN n = bufferIO connWriteBuffer n connSendAll

222+

223+ headerContinue sid ths endOfStream off = do

224+ let !offkv = off + frameHeaderLength

225+ let !bufkv = connWriteBuffer `plusPtr` offkv

226+ !limkv = connBufferSize - offkv

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

228+ let flag0 = case hs of

229+ [] -> setEndHeader defaultFlags

230+ _ -> defaultFlags

231+ flag = if endOfStream then setEndStream flag0 else flag0

232+ let buf = connWriteBuffer `plusPtr` off

233+ fillFrameHeader FrameHeaders kvlen sid flag buf

234+ continue sid kvlen hs

235+

236+ !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength

237+ !headerPayloadLim = connBufferSize - frameHeaderLength

238+

239+ continue _ kvlen [] = return kvlen

240+ continue sid kvlen ths = do

241+ flushN $ kvlen + frameHeaderLength

242+ -- Now off is 0

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

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

245+ let flag = case ths' of

246+ [] -> setEndHeader defaultFlags

247+ _ -> defaultFlags

248+ fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer

249+ continue sid kvlen' ths'

250+

251+ {-# INLINE maybeEnqueueNext #-}

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

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

254+ maybeEnqueueNext _ Nothing = return ()

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

256+ where

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

258+

259+ {-# INLINE sendHeadersIfNecessary #-}

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

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

262+ sendHeadersIfNecessary off

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

264+ | off + frameHeaderLength < connBufferSize = return off

265+ | otherwise = do

266+ flushN off

267+ return 0

268+

269+ fillDataHeader strm@Stream{streamWindow,streamNumber}

270+ off datPayloadLen mnext tell getH2D = do

271+ -- Data frame header

272+ mh2d <- getH2D

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

274+ Nothing -> ([], True)

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

276+ !buf = connWriteBuffer `plusPtr` off

277+ !off' = off + frameHeaderLength + datPayloadLen

278+ !noMoreBody = isNothing mnext

279+ flag | noMoreBody && noTrailers = setEndStream defaultFlags

280+ | otherwise = defaultFlags

281+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf

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

283+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

284+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)

285+ return off''

286+ where

287+ handleTrailers True off0 _ = return off0

288+ handleTrailers _ off0 trailers = do

289+ (ths,_) <- toHeaderTable trailers

290+ kvlen <- headerContinue streamNumber ths True off0

291+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

292+ handleEndOfBody True off0 noTrailers trailers = do

293+ off1 <- handleTrailers noTrailers off0 trailers

294+ void tell

295+ closed ctx strm Finished

296+ return off1

297+ handleEndOfBody False off0 _ _ = return off0

298+

299+

300+ pushPromise pid sid ths off = do

301+ let !offsid = off + frameHeaderLength

302+ !bufsid = connWriteBuffer `plusPtr` offsid

303+ poke32 bufsid $ fromIntegral sid

304+ let !offkv = offsid + 4

305+ !bufkv = connWriteBuffer `plusPtr` offkv

306+ !limkv = connBufferSize - offkv

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

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

309+ !buf = connWriteBuffer `plusPtr` off

310+ !len = kvlen + 4

311+ fillFrameHeader FramePushPromise len pid flag buf

312+ return len

313+

314+ {-# INLINE fillFrameHeader #-}

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

316+ where

317+ hinfo = FrameHeader len flag sid

318+

319+ {-# INLINE ignore #-}

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

321+ ignore _ = return ()

322+

323+----------------------------------------------------------------

324+

325+{-

326+ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)

327+ResponseBuilder Status ResponseHeaders Builder

328+ResponseStream Status ResponseHeaders StreamingBody

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

330+-}

331+

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

333+fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}

334+ _ off lim bb = do

335+ let datBuf = connWriteBuffer `plusPtr` off

336+ room = min (connBufferSize - off) lim

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

338+ return $ nextForBuilder len signal

339+

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

341+#ifdef WINDOWS

342+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

343+ _ off lim path mpart = do

344+ let datBuf = connWriteBuffer `plusPtr` off

345+ room = min (connBufferSize - off) lim

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

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

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

349+ IO.hSeek hdl IO.AbsoluteSeek start

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

351+ let bytes' = bytes - fromIntegral len

352+ -- fixme: connWriteBuffer connBufferSize

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

354+#else

355+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

356+ ii off lim path mpart = do

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

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

359+ Nothing -> do

360+ fd' <- openFile path

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

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

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

364+ let datBuf = connWriteBuffer `plusPtr` off

365+ room = min (connBufferSize - off) lim

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

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

368+ refresh

369+ let len' = fromIntegral len

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

371+#endif

372+

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

374+fileStartEnd _ (Just part) =

375+ return (filePartOffset part, filePartByteCount part)

376+fileStartEnd _ _ = error "fileStartEnd"

377+

378+----------------------------------------------------------------

379+

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

381+fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

382+ off lim sq strm = do

383+ let datBuf = connWriteBuffer `plusPtr` off

384+ room = min (connBufferSize - off) lim

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

386+ return $ nextForStream sq strm leftover cont len

387+

388+----------------------------------------------------------------

389+

390+fillBufBuilder :: Leftover -> DynaNext

391+fillBufBuilder leftover buf0 siz0 lim = do

392+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

393+ room = min (siz0 - frameHeaderLength) lim

394+ case leftover of

395+ LZero -> error "fillBufBuilder: LZero"

396+ LOne writer -> do

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

398+ getNext len signal

399+ LTwo bs writer

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

401+ buf1 <- copy payloadBuf bs

402+ let len1 = BS.length bs

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

404+ getNext (len1 + len2) signal

405+ | otherwise -> do

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

407+ void $ copy payloadBuf bs1

408+ getNext room (B.Chunk bs2 writer)

409+ where

410+ getNext l s = return $ nextForBuilder l s

411+

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

413+nextForBuilder len B.Done

414+ = Next len Nothing

415+nextForBuilder len (B.More _ writer)

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

417+nextForBuilder len (B.Chunk bs writer)

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

419+

420+----------------------------------------------------------------

421+

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

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

424+runStreamBuilder buf0 room0 sq = loop buf0 room0 0

425+ where

426+ loop !buf !room !total = do

427+ mbuilder <- atomically $ tryReadTBQueue sq

428+ case mbuilder of

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

430+ Just (SBuilder builder) -> do

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

432+ let !total' = total + len

433+ case signal of

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

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

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

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

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

439+

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

441+fillBufStream leftover0 sq strm buf0 siz0 lim0 = do

442+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

443+ room0 = min (siz0 - frameHeaderLength) lim0

444+ case leftover0 of

445+ LZero -> do

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

447+ getNext leftover cont len

448+ LOne writer -> write writer payloadBuf room0 0

449+ LTwo bs writer

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

451+ buf1 <- copy payloadBuf bs

452+ let len = BS.length bs

453+ write writer buf1 (room0 - len) len

454+ | otherwise -> do

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

456+ void $ copy payloadBuf bs1

457+ getNext (LTwo bs2 writer) True room0

458+ where

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

460+ write writer1 buf room sofar = do

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

462+ case signal of

463+ B.Done -> do

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

465+ let !total = sofar + len + extra

466+ getNext leftover cont total

467+ B.More _ writer -> do

468+ let !total = sofar + len

469+ getNext (LOne writer) True total

470+ B.Chunk bs writer -> do

471+ let !total = sofar + len

472+ getNext (LTwo bs writer) True total

473+

474+nextForStream :: TBQueue Sequence -> Stream

475+ -> Leftover -> Bool -> BytesFilled

476+ -> Next

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

478+nextForStream sq strm leftOrZero True len =

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

480+

481+----------------------------------------------------------------

482+

483+#ifdef WINDOWS

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

485+fillBufFile h bytes refresh buf siz lim = do

486+ let payloadBuf = buf `plusPtr` frameHeaderLength

487+ room = min (siz - frameHeaderLength) lim

488+ len <- IO.hGetBufSome h payloadBuf room

489+ refresh

490+ let bytes' = bytes - fromIntegral len

491+ return $ nextForFile len h bytes' refresh

492+

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

494+nextForFile 0 _ _ _ = Next 0 Nothing

495+nextForFile len _ 0 _ = Next len Nothing

496+nextForFile len h bytes refresh =

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

498+#else

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

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

501+ let payloadBuf = buf `plusPtr` frameHeaderLength

502+ room = min (siz - frameHeaderLength) lim

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

504+ let len' = fromIntegral len

505+ refresh

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

507+

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

509+nextForFile 0 _ _ _ _ = Next 0 Nothing

510+nextForFile len _ _ 0 _ = Next len Nothing

511+nextForFile len fd start bytes refresh =

512+ Next len $ Just (fillBufFile fd start bytes refresh)

513+#endif

514+

515+{-# INLINE mini #-}

516+mini :: Int -> Integer -> Int

517+mini i n

518+ | fromIntegral i < n = i

519+ | otherwise = fromIntegral n

520+

521+

522+----------------------------------------------------------------

523+

524+poke32 :: Ptr Word8 -> Word32 -> IO ()

525+poke32 ptr i = do

526+ poke ptr w0

527+ poke8 ptr 1 w1

528+ poke8 ptr 2 w2

529+ poke8 ptr 3 w3

530+ where

531+ w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)

532+ w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)

533+ w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)

534+ w3 = fromIntegral (i .&. 0xff)

535+ poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()

536+ poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+265−13

@@ -1,26 +1,282 @@

1−{-# LANGUAGE NamedFieldPuns #-}

1+{-# LANGUAGE OverloadedStrings, CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

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

3+{-# LANGUAGE BangPatterns #-}

4

5module Network.Wai.Handler.Warp.HTTP2.Types where

6

7+import Control.Concurrent (forkIO)

8+import Control.Concurrent.STM

9+import Control.Exception (SomeException, bracket)

7import qualified Data.ByteString as BS

10import qualified Data.ByteString as BS

11+import Data.ByteString.Builder (Builder)

12+import Data.IORef

13+import Data.IntMap.Strict (IntMap, IntMap)

14+import qualified Data.IntMap.Strict as M

15+import Network.HPACK hiding (Buffer)

8import qualified Network.HTTP.Types as H

16import qualified Network.HTTP.Types as H

9import Network.HTTP2

17import Network.HTTP2

10−import qualified Network.HTTP2.Server as H2

18+import Network.HTTP2.Priority

19+import Network.Wai (Request, FilePart)

11

20

21+import Network.Wai.Handler.Warp.HTTP2.Manager

12import Network.Wai.Handler.Warp.Imports

22import Network.Wai.Handler.Warp.Imports

13import Network.Wai.Handler.Warp.Types

23import Network.Wai.Handler.Warp.Types

14

24

15----------------------------------------------------------------

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

16

26

27+http2ver :: H.HttpVersion

28+http2ver = H.HttpVersion 2 0

29+

17isHTTP2 :: Transport -> Bool

30isHTTP2 :: Transport -> Bool

18isHTTP2 TCP = False

31isHTTP2 TCP = False

19isHTTP2 tls = useHTTP2

32isHTTP2 tls = useHTTP2

20 where

33 where

21 useHTTP2 = case tlsNegotiatedProtocol tls of

34 useHTTP2 = case tlsNegotiatedProtocol tls of

22 Nothing -> False

35 Nothing -> False

23− Just proto -> "h2" `BS.isPrefixOf` proto

36+ Just proto -> "h2-" `BS.isPrefixOf` proto

37+

38+----------------------------------------------------------------

39+

40+data Input = Input Stream Request ValueTable InternalInfo

41+

42+----------------------------------------------------------------

43+

44+type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next

45+

46+type BytesFilled = Int

47+

48+data Next = Next !BytesFilled (Maybe DynaNext)

49+

50+data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)

51+ | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)

52+ | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder

53+ | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)

54+

55+rspnStatus :: Rspn -> H.Status

56+rspnStatus (RspnNobody s _) = s

57+rspnStatus (RspnStreaming s _ _) = s

58+rspnStatus (RspnBuilder s _ _) = s

59+rspnStatus (RspnFile s _ _ _ ) = s

60+

61+rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)

62+rspnHeaders (RspnNobody _ t) = t

63+rspnHeaders (RspnStreaming _ t _) = t

64+rspnHeaders (RspnBuilder _ t _) = t

65+rspnHeaders (RspnFile _ t _ _ ) = t

66+

67+data Output = Output {

68+ outputStream :: !Stream

69+ , outputRspn :: !Rspn

70+ , outputII :: !InternalInfo

71+ , outputHook :: IO () -- OPush: wait for done, O*: telling done

72+ , outputH2Data :: IO (Maybe HTTP2Data)

73+ , outputType :: !OutputType

74+ }

75+

76+data OutputType = ORspn

77+ | OWait

78+ | OPush !TokenHeaderList !StreamId -- associated stream id from client

79+ | ONext !DynaNext

80+

81+outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)

82+outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq

83+outputMaybeTBQueue _ = Nothing

84+

85+data Control = CFinish

86+ | CGoaway !ByteString

87+ | CFrame !ByteString

88+ | CSettings !ByteString !SettingsList

89+ | CSettings0 !ByteString !ByteString !SettingsList

90+

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

92+

93+data Sequence = SFinish

94+ | SFlush

95+ | SBuilder Builder

96+

97+----------------------------------------------------------------

98+

99+-- | The context for HTTP/2 connection.

100+data Context = Context {

101+ -- HTTP/2 settings received from a browser

102+ http2settings :: !(IORef Settings)

103+ , firstSettings :: !(IORef Bool)

104+ , streamTable :: !StreamTable

105+ , concurrency :: !(IORef Int)

106+ , priorityTreeSize :: !(IORef Int)

107+ -- | RFC 7540 says "Other frames (from any stream) MUST NOT

108+ -- occur between the HEADERS frame and any CONTINUATION

109+ -- frames that might follow". This field is used to implement

110+ -- this requirement.

111+ , continued :: !(IORef (Maybe StreamId))

112+ , clientStreamId :: !(IORef StreamId)

113+ , serverStreamId :: !(IORef StreamId)

114+ , inputQ :: !(TQueue Input)

115+ , outputQ :: !(PriorityTree Output)

116+ , controlQ :: !(TQueue Control)

117+ , encodeDynamicTable :: !DynamicTable

118+ , decodeDynamicTable :: !DynamicTable

119+ -- the connection window for data from a server to a browser.

120+ , connectionWindow :: !(TVar WindowSize)

121+ }

122+

123+----------------------------------------------------------------

124+

125+newContext :: IO Context

126+newContext = Context <$> newIORef defaultSettings

127+ <*> newIORef False

128+ <*> newStreamTable

129+ <*> newIORef 0

130+ <*> newIORef 0

131+ <*> newIORef Nothing

132+ <*> newIORef 0

133+ <*> newIORef 0

134+ <*> newTQueueIO

135+ <*> newPriorityTree

136+ <*> newTQueueIO

137+ <*> newDynamicTableForEncoding defaultDynamicTableSize

138+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096

139+ <*> newTVarIO defaultInitialWindowSize

140+

141+clearContext :: Context -> IO ()

142+clearContext _ctx = return ()

143+

144+----------------------------------------------------------------

145+

146+data OpenState =

147+ JustOpened

148+ | Continued [HeaderBlockFragment]

149+ !Int -- Total size

150+ !Int -- The number of continuation frames

151+ !Bool -- End of stream

152+ !Priority

153+ | NoBody (TokenHeaderList,ValueTable) !Priority

154+ | HasBody (TokenHeaderList,ValueTable) !Priority

155+ | Body !(TQueue ByteString)

156+ !(Maybe Int) -- received Content-Length

157+ -- compared the body length for error checking

158+ !(IORef Int) -- actual body length

159+

160+data ClosedCode = Finished

161+ | Killed

162+ | Reset !ErrorCodeId

163+ | ResetByMe SomeException

164+ deriving Show

165+

166+data StreamState =

167+ Idle

168+ | Open !OpenState

169+ | HalfClosed

170+ | Closed !ClosedCode

171+ | Reserved

172+

173+isIdle :: StreamState -> Bool

174+isIdle Idle = True

175+isIdle _ = False

176+

177+isOpen :: StreamState -> Bool

178+isOpen Open{} = True

179+isOpen _ = False

180+

181+isHalfClosed :: StreamState -> Bool

182+isHalfClosed HalfClosed = True

183+isHalfClosed _ = False

184+

185+isClosed :: StreamState -> Bool

186+isClosed Closed{} = True

187+isClosed _ = False

188+

189+instance Show StreamState where

190+ show Idle = "Idle"

191+ show Open{} = "Open"

192+ show HalfClosed = "HalfClosed"

193+ show (Closed e) = "Closed: " ++ show e

194+ show Reserved = "Reserved"

195+

196+----------------------------------------------------------------

197+

198+data Stream = Stream {

199+ streamNumber :: !StreamId

200+ , streamState :: !(IORef StreamState)

201+ , streamWindow :: !(TVar WindowSize)

202+ , streamPrecedence :: !(IORef Precedence)

203+ }

204+

205+instance Show Stream where

206+ show s = show (streamNumber s)

207+

208+newStream :: StreamId -> WindowSize -> IO Stream

209+newStream sid win = Stream sid <$> newIORef Idle

210+ <*> newTVarIO win

211+ <*> newIORef defaultPrecedence

212+

213+newPushStream :: Context -> WindowSize -> Precedence -> IO Stream

214+newPushStream Context{serverStreamId} win pre = do

215+ sid <- atomicModifyIORef' serverStreamId inc2

216+ Stream sid <$> newIORef Reserved

217+ <*> newTVarIO win

218+ <*> newIORef pre

219+ where

220+ inc2 x = let !x' = x + 2 in (x', x')

221+

222+----------------------------------------------------------------

223+

224+opened :: Context -> Stream -> IO ()

225+opened Context{concurrency} Stream{streamState} = do

226+ atomicModifyIORef' concurrency (\x -> (x+1,()))

227+ writeIORef streamState (Open JustOpened)

228+

229+closed :: Context -> Stream -> ClosedCode -> IO ()

230+closed Context{concurrency,streamTable} Stream{streamState,streamNumber} cc = do

231+ remove streamTable streamNumber

232+ atomicModifyIORef' concurrency (\x -> (x-1,()))

233+ writeIORef streamState (Closed cc) -- anyway

234+

235+----------------------------------------------------------------

236+

237+newtype StreamTable = StreamTable (IORef (IntMap Stream))

238+

239+newStreamTable :: IO StreamTable

240+newStreamTable = StreamTable <$> newIORef M.empty

241+

242+insert :: StreamTable -> M.Key -> Stream -> IO ()

243+insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->

244+ let !m' = M.insert k v m

245+ in (m', ())

246+

247+remove :: StreamTable -> M.Key -> IO ()

248+remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->

249+ let !m' = M.delete k m

250+ in (m', ())

251+

252+search :: StreamTable -> M.Key -> IO (Maybe Stream)

253+search (StreamTable ref) k = M.lookup k <$> readIORef ref

254+

255+updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()

256+updateAllStreamWindow adst (StreamTable ref) = do

257+ strms <- M.elems <$> readIORef ref

258+ forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst

259+

260+{-# INLINE forkAndEnqueueWhenReady #-}

261+forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()

262+forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->

263+ void . forkIO $ do

264+ wait

265+ enqueueOutput outQ out

266+ where

267+ setup = addMyId mgr

268+ teardown _ = deleteMyId mgr

269+

270+{-# INLINE enqueueOutput #-}

271+enqueueOutput :: PriorityTree Output -> Output -> IO ()

272+enqueueOutput outQ out = do

273+ let Stream{..} = outputStream out

274+ pre <- readIORef streamPrecedence

275+ enqueue outQ streamNumber pre out

276+

277+{-# INLINE enqueueControl #-}

278+enqueueControl :: TQueue Control -> Control -> IO ()

279+enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl

24

280

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

281----------------------------------------------------------------

26

282

@@ -32,21 +288,17 @@ data HTTP2Data = HTTP2Data {

32 --

288 --

33 -- Since: 3.2.7

289 -- Since: 3.2.7

34 http2dataPushPromise :: [PushPromise]

290 http2dataPushPromise :: [PushPromise]

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

36− --

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

291+ -- Since: 3.2.8

38− , http2dataTrailers :: H2.TrailersMaker

292+ , http2dataTrailers :: H.ResponseHeaders

39− }

293+ } deriving (Eq,Show)

40

294

41-- | Default HTTP/2 specific data.

295-- | Default HTTP/2 specific data.

42--

296--

43-- Since: 3.2.7

297-- Since: 3.2.7

44defaultHTTP2Data :: HTTP2Data

298defaultHTTP2Data :: HTTP2Data

45−defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

299+defaultHTTP2Data = HTTP2Data [] []

46

300

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

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

302--

51-- Since: 3.2.7

303-- Since: 3.2.7

52data PushPromise = PushPromise {

304data PushPromise = PushPromise {

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hsnew file+328

@@ -0,0 +1,328 @@

1+{-# LANGUAGE NamedFieldPuns #-}

2+{-# LANGUAGE PatternGuards #-}

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE BangPatterns #-}

7+

8+module Network.Wai.Handler.Warp.HTTP2.Worker (

9+ Responder

10+ , response

11+ , worker

12+ ) where

13+

14+import Control.Concurrent.STM

15+import Control.Exception (SomeException(..), AsyncException(..))

16+import qualified Control.Exception as E

17+import Data.ByteString.Builder (byteString)

18+import Data.IORef

19+import qualified Data.Vault.Lazy as Vault

20+import Network.HPACK

21+import Network.HPACK.Token

22+import qualified Network.HTTP.Types as H

23+import Network.HTTP2

24+import Network.HTTP2.Priority

25+import Network.Wai

26+import qualified Network.Wai.Handler.Warp.Timeout as Timeout

27+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))

28+

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

30+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

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

32+import Network.Wai.Handler.Warp.HTTP2.Manager

33+import Network.Wai.Handler.Warp.HTTP2.Request

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

35+import Network.Wai.Handler.Warp.Imports hiding (insert)

36+import Network.Wai.Handler.Warp.Request (pauseTimeoutKey)

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

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

39+import qualified Network.Wai.Handler.Warp.Timeout as T

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

41+

42+----------------------------------------------------------------

43+

44+-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.

45+-- This type implements the second argument (Response -> IO ResponseReceived)

46+-- with extra arguments.

47+type Responder = InternalInfo

48+ -> ValueTable -- for Request

49+ -> ThreadContinue

50+ -> Stream

51+ -> Request

52+ -> Response

53+ -> IO ResponseReceived

54+

55+pushStream :: Context -> S.Settings

56+ -> StreamId -> ValueTable -> Request -> InternalInfo

57+ -> Maybe HTTP2Data

58+ -> IO (OutputType, IO ())

59+pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())

60+pushStream ctx@Context{http2settings,outputQ,streamTable}

61+ settings pid reqvt req ii (Just h2d)

62+ | len == 0 = return (ORspn, return ())

63+ | otherwise = do

64+ pushable <- enablePush <$> readIORef http2settings

65+ if pushable then do

66+ tvar <- newTVarIO 0

67+ lim <- push tvar pps0 0

68+ if lim == 0 then

69+ return (ORspn, return ())

70+ else

71+ return (OWait, waiter lim tvar)

72+ else

73+ return (ORspn, return ())

74+ where

75+ !pps0 = http2dataPushPromise h2d

76+ !len = length pps0

77+ !pushLogger = S.settingsServerPushLogger settings

78+ increment tvar = atomically $ modifyTVar' tvar (+1)

79+ waiter lim tvar = atomically $ do

80+ n <- readTVar tvar

81+ check (n >= lim)

82+ !h2data = getHTTP2Data req

83+ push _ [] !n = return (n :: Int)

84+ push tvar (pp:pps) !n = do

85+ let !file = promisedFile pp

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

87+ case efinfo of

88+ Left (_ex :: E.IOException) -> push tvar pps n

89+ Right (FileInfo _ size _ date) -> do

90+ ws <- initialWindowSize <$> readIORef http2settings

91+ let !w = promisedWeight pp

92+ !pri = defaultPriority { weight = w }

93+ !pre = toPrecedence pri

94+ strm <- newPushStream ctx ws pre

95+ let !sid = streamNumber strm

96+ insert streamTable sid strm

97+ (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)

98+ let !scheme = fromJust $ getHeaderValue tokenScheme reqvt

99+ -- fixme: this value can be Nothing

100+ !auth = fromJust (getHeaderValue tokenHost reqvt

101+ <|> getHeaderValue tokenAuthority reqvt)

102+ !path = promisedPath pp

103+ !promisedRequest = [(tokenMethod, H.methodGet)

104+ ,(tokenScheme, scheme)

105+ ,(tokenAuthority, auth)

106+ ,(tokenPath, path)]

107+ !part = FilePart 0 size size

108+ !rsp = RspnFile H.ok200 (ths,vt) file (Just part)

109+ !ths = (tokenLastModified,date) :

110+ addContentHeadersForFilePart ths0 part

111+ pushLogger req path size

112+ let !ot = OPush promisedRequest pid

113+ !out = Output strm rsp ii (increment tvar) h2data ot

114+ enqueueOutput outputQ out

115+ push tvar pps (n + 1)

116+

117+

118+-- | This function is passed to workers.

119+-- They also pass 'Response's from 'Application's to this function.

120+-- This function enqueues commands for the HTTP/2 sender.

121+response :: S.Settings -> Context -> Manager -> Responder

122+response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of

123+ ResponseStream s0 hs0 strmbdy

124+ | noBody s0 -> responseNoBody s0 hs0

125+ | isHead -> responseNoBody s0 hs0

126+ | otherwise -> getHTTP2Data req

127+ >>= pushStream ctx settings sid reqvt req ii

128+ >>= responseStreaming s0 hs0 strmbdy

129+ ResponseBuilder s0 hs0 b

130+ | noBody s0 -> responseNoBody s0 hs0

131+ | isHead -> responseNoBody s0 hs0

132+ | otherwise -> getHTTP2Data req

133+ >>= pushStream ctx settings sid reqvt req ii

134+ >>= responseBuilderBody s0 hs0 b

135+ ResponseFile s0 hs0 p mp

136+ | noBody s0 -> responseNoBody s0 hs0

137+ | otherwise -> getHTTP2Data req

138+ >>= pushStream ctx settings sid reqvt req ii

139+ >>= responseFileXXX s0 hs0 p mp

140+ ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"

141+ where

142+ noBody = not . R.hasBody

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

144+ !logger = S.settingsLogger settings

145+ !th = threadHandle ii

146+ sid = streamNumber strm

147+ !h2data = getHTTP2Data req

148+

149+ -- Ideally, log messages should be written when responses are

150+ -- actually sent. But there is no way to keep good memory usage

151+ -- (resist to Request leak) and throughput. By compromise,

152+ -- log message are written here even the window size of streams

153+ -- is 0.

154+

155+ responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s

156+

157+ responseNoBody' s tbl = do

158+ logger req s Nothing

159+ setThreadContinue tconf True

160+ let !rspn = RspnNobody s tbl

161+ !out = Output strm rspn ii (return ()) h2data ORspn

162+ enqueueOutput outputQ out

163+ return ResponseReceived

164+

165+ responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do

166+ logger req s Nothing

167+ setThreadContinue tconf True

168+ tbl <- toHeaderTable hs0

169+ let !rspn = RspnBuilder s tbl bdy

170+ !out = Output strm rspn ii tell h2data rspnOrWait

171+ enqueueOutput outputQ out

172+ return ResponseReceived

173+

174+ responseFileXXX _ hs0 path Nothing aux = do

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

176+ case efinfo of

177+ Left (_ex :: E.IOException) -> response404 hs0

178+ Right finfo -> do

179+ (rspths0,vt) <- toHeaderTable hs0

180+ case conditionalRequest finfo rspths0 reqvt of

181+ WithoutBody s -> responseNoBody s hs0

182+ WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux

183+

184+ responseFileXXX s0 hs0 path mpart aux = do

185+ tbl <- toHeaderTable hs0

186+ responseFile2XX s0 tbl path mpart aux

187+

188+ responseFile2XX s tbl path mpart (rspnOrWait,tell)

189+ | isHead = do

190+ logger req s Nothing

191+ responseNoBody' s tbl

192+ | otherwise = do

193+ logger req s (filePartByteCount <$> mpart)

194+ setThreadContinue tconf True

195+ let !rspn = RspnFile s tbl path mpart

196+ !out = Output strm rspn ii tell h2data rspnOrWait

197+ enqueueOutput outputQ out

198+ return ResponseReceived

199+

200+ response404 hs0 = responseBuilderBody s hs body (ORspn, return ())

201+ where

202+ s = H.notFound404

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

204+ body = byteString "File not found"

205+

206+ responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do

207+ logger req s0 Nothing

208+ -- We must not exit this WAI application.

209+ -- If the application exits, streaming would be also closed.

210+ -- So, this work occupies this thread.

211+ --

212+ -- We need to increase the number of workers.

213+ spawnAction mgr

214+ -- After this work, this thread stops to decease

215+ -- the number of workers.

216+ setThreadContinue tconf False

217+ -- Since 'StreamingBody' is loop, we cannot control it.

218+ -- So, let's serialize 'Builder' with a designated queue.

219+ tbq <- newTBQueueIO 10 -- fixme: hard coding: 10

220+ tbl <- toHeaderTable hs0

221+ let !rspn = RspnStreaming s0 tbl tbq

222+ !out = Output strm rspn ii tell h2data rspnOrWait

223+ enqueueOutput outputQ out

224+ let push b = do

225+ T.pause th

226+ atomically $ writeTBQueue tbq (SBuilder b)

227+ T.resume th

228+ flush = atomically $ writeTBQueue tbq SFlush

229+ _ <- strmbdy push flush

230+ atomically $ writeTBQueue tbq SFinish

231+ deleteMyId mgr

232+ return ResponseReceived

233+

234+worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO ()

235+worker ctx@Context{inputQ,controlQ} set app responder tm = do

236+ sinfo <- newStreamInfo

237+ tcont <- newThreadContinue

238+ let timeoutAction = return () -- cannot close the shared connection

239+ E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont

240+ where

241+ go sinfo tcont th = do

242+ setThreadContinue tcont True

243+ ex <- E.try $ do

244+ T.pause th

245+ inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ

246+ setStreamInfo sinfo inp

247+ T.resume th

248+ T.tickle th

249+ let !ii' = ii { threadHandle = th }

250+ !body = requestBody req

251+ !body' = do

252+ T.pause th

253+ bs <- body

254+ T.resume th

255+ return bs

256+ !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ vault req

257+ !req' = req { vault = vaultValue, requestBody = body' }

258+ app req' $ responder ii' reqvt tcont strm req'

259+ cont1 <- case ex of

260+ Right ResponseReceived -> return True

261+ Left e@(SomeException _)

262+ -- killed by the local worker manager

263+ | Just ThreadKilled <- E.fromException e -> return False

264+ -- killed by the local timeout manager

265+ | Just T.TimeoutThread <- E.fromException e -> do

266+ cleanup sinfo Nothing

267+ return True

268+ | otherwise -> do

269+ cleanup sinfo $ Just e

270+ return True

271+ cont2 <- getThreadContinue tcont

272+ clearStreamInfo sinfo

273+ when (cont1 && cont2) $ go sinfo tcont th

274+ cleanup sinfo me = do

275+ minp <- getStreamInfo sinfo

276+ case minp of

277+ Nothing -> return ()

278+ Just (Input strm req _reqvt _ii) -> do

279+ closed ctx strm Killed

280+ let !frame = resetFrame InternalError (streamNumber strm)

281+ enqueueControl controlQ $ CFrame frame

282+ case me of

283+ Nothing -> return ()

284+ Just e -> S.settingsOnException set (Just req) e

285+

286+----------------------------------------------------------------

287+

288+-- | It would nice if responders could return values to workers.

289+-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.

290+-- It is not wise to change this type.

291+-- So, a reference is shared by a responder and its worker.

292+-- The reference refers a value of this type as a return value.

293+-- If 'True', the worker continue to serve requests.

294+-- Otherwise, the worker get finished.

295+newtype ThreadContinue = ThreadContinue (IORef Bool)

296+

297+{-# INLINE newThreadContinue #-}

298+newThreadContinue :: IO ThreadContinue

299+newThreadContinue = ThreadContinue <$> newIORef True

300+

301+{-# INLINE setThreadContinue #-}

302+setThreadContinue :: ThreadContinue -> Bool -> IO ()

303+setThreadContinue (ThreadContinue ref) x = writeIORef ref x

304+

305+{-# INLINE getThreadContinue #-}

306+getThreadContinue :: ThreadContinue -> IO Bool

307+getThreadContinue (ThreadContinue ref) = readIORef ref

308+

309+----------------------------------------------------------------

310+

311+-- | The type to store enough information for 'settingsOnException'.

312+newtype StreamInfo = StreamInfo (IORef (Maybe Input))

313+

314+{-# INLINE newStreamInfo #-}

315+newStreamInfo :: IO StreamInfo

316+newStreamInfo = StreamInfo <$> newIORef Nothing

317+

318+{-# INLINE clearStreamInfo #-}

319+clearStreamInfo :: StreamInfo -> IO ()

320+clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing

321+

322+{-# INLINE setStreamInfo #-}

323+setStreamInfo :: StreamInfo -> Input -> IO ()

324+setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp

325+

326+{-# INLINE getStreamInfo #-}

327+getStreamInfo :: StreamInfo -> IO (Maybe Input)

328+getStreamInfo (StreamInfo ref) = readIORef ref

warp/Network/Wai/Handler/Warp/HashMap.hs+15−24

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

1−{-# LANGUAGE BangPatterns #-}

2−

3module Network.Wai.Handler.Warp.HashMap where

1module Network.Wai.Handler.Warp.HashMap where

4

2

5import Data.Hashable (hash)

3import Data.Hashable (hash)

@@ -9,34 +7,27 @@ import Data.Map.Strict (Map)

9import qualified Data.Map.Strict as M

7import qualified Data.Map.Strict as M

10import Prelude hiding (lookup)

8import Prelude hiding (lookup)

11

9

12−----------------------------------------------------------------

10+import Network.Wai.Handler.Warp.Imports hiding (insert, lookup)

13

11

14−-- | 'HashMap' is used for cache of file information.

12+type Hash = Int

15−-- Hash values of file pathes are used as outer keys.

16−-- Because negative entries are also contained,

17−-- a bad guy can intentionally cause the hash collison.

18−-- So, 'Map' is used internally to prevent

19−-- the hash collision attack.

20−newtype HashMap v = HashMap (IntMap (Map FilePath v))

13+newtype HashMap k v = HashMap (IntMap (Map k v))

21

14

22−----------------------------------------------------------------

15+hashByteString :: ByteString -> Hash

16+hashByteString = hash

23

17

24−empty :: HashMap v

18+empty :: HashMap k v

25empty = HashMap I.empty

19empty = HashMap I.empty

26

20

27−isEmpty :: HashMap v -> Bool

21+null :: HashMap k v -> Bool

28−isEmpty (HashMap hm) = I.null hm

22+null (HashMap hm) = I.null hm

29−

30−----------------------------------------------------------------

31

23

32−insert :: FilePath -> v -> HashMap v -> HashMap v

24+insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v

33−insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm

25+insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm

34 where

26 where

35− !h = hash path

36− !m = M.singleton path v

27+ m = M.singleton k v

37 f = M.union -- fimxe

28 f = M.union -- fimxe

29+{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}

38

30

39−lookup :: FilePath -> HashMap v -> Maybe v

31+lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v

40−lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path

32+lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k

41− where

33+{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}

42− !h = hash path

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/Internal.hs+2−3

@@ -53,7 +53,7 @@ module Network.Wai.Handler.Warp.Internal (

53 -- resumed as soon as we return from user code.

54 --

55 -- * Every time data is successfully sent to the client, the timeout is tickled.

56− , module System.TimeManager

56+ , module Network.Wai.Handler.Warp.Timeout

57 -- * File descriptor cache

58 , module Network.Wai.Handler.Warp.FdCache

59 -- * File information cache

@@ -69,8 +69,6 @@ module Network.Wai.Handler.Warp.Internal (

69 , windowsThreadBlockHack

70 ) where

71

72−import System.TimeManager

73−

74import Network.Wai.Handler.Warp.Buffer

72import Network.Wai.Handler.Warp.Buffer

75import Network.Wai.Handler.Warp.Date

73import Network.Wai.Handler.Warp.Date

76import Network.Wai.Handler.Warp.FdCache

74import Network.Wai.Handler.Warp.FdCache

@@ -82,5 +80,6 @@ import Network.Wai.Handler.Warp.Response

82import Network.Wai.Handler.Warp.Run

80import Network.Wai.Handler.Warp.Run

83import Network.Wai.Handler.Warp.SendFile

81import Network.Wai.Handler.Warp.SendFile

84import Network.Wai.Handler.Warp.Settings

82import Network.Wai.Handler.Warp.Settings

83+import Network.Wai.Handler.Warp.Timeout

85import Network.Wai.Handler.Warp.Types

84import Network.Wai.Handler.Warp.Types

86import Network.Wai.Handler.Warp.Windows

85import Network.Wai.Handler.Warp.Windows

warp/Network/Wai/Handler/Warp/MultiMap.hs+44−55

@@ -1,111 +1,100 @@

1−{-# LANGUAGE BangPatterns #-}

2−

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

1module Network.Wai.Handler.Warp.MultiMap (

4− MultiMap

2+ MMap

5 , isEmpty

3 , isEmpty

6 , empty

4 , empty

7 , singleton

5 , singleton

8 , insert

6 , insert

9− , Network.Wai.Handler.Warp.MultiMap.lookup

7+ , search

8+ , searchWith

10 , pruneWith

9 , pruneWith

11 , toList

10 , toList

12 , merge

11 , merge

13 ) where

12 ) where

14

13

15−import Data.Hashable (hash)

16import Data.IntMap.Strict (IntMap)

14import Data.IntMap.Strict (IntMap)

17import qualified Data.IntMap.Strict as I

15import qualified Data.IntMap.Strict as I

16+import qualified Data.List.NonEmpty as NE

18import Data.Semigroup

17import Data.Semigroup

19import Prelude -- Silence redundant import warnings

18import Prelude -- Silence redundant import warnings

20

19

20+import Network.Wai.Handler.Warp.Imports hiding ((<>), union, empty, insert)

21+

21----------------------------------------------------------------

22----------------------------------------------------------------

22

23

23−-- | 'MultiMap' is used for cache of file descriptors.

24+type MMap v = IntMap (NonEmpty v)

24−-- Since multiple threads would open file descriptors for

25−-- the same file simultaneously, multiple entries must

26−-- be contained for the file.

27−-- Since hash values of file pathes are used as outer keys,

28−-- collison would happen for multiple file pathes.

29−-- Becase only positive entries are contained,

30−-- a bad guy cannot be cause the hash collision intentinally.

31−-- So, lists are good enough.

32−newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])

33

25

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

26----------------------------------------------------------------

35

27

36-- | O(1)

28-- | O(1)

37−empty :: MultiMap v

29+isEmpty :: MMap v -> Bool

38−empty = MultiMap $ I.empty

30+isEmpty = I.null

39

31

40-- | O(1)

32-- | O(1)

41−isEmpty :: MultiMap v -> Bool

33+empty :: MMap v

42−isEmpty (MultiMap mm) = I.null mm

34+empty = I.empty

43

35

44----------------------------------------------------------------

36----------------------------------------------------------------

45

37

46-- | O(1)

38-- | O(1)

47−singleton :: FilePath -> v -> MultiMap v

39+singleton :: Int -> v -> MMap v

48−singleton path v = MultiMap mm

49− where

50− !h = hash path

51− !mm = I.singleton h [(path,v)]

40+singleton k v = I.singleton k (v :| [])

52

41

53----------------------------------------------------------------

42----------------------------------------------------------------

54

43

55−-- | O(N)

44+-- | O(log n)

56−lookup :: FilePath -> MultiMap v -> Maybe v

45+search :: Int -> MMap v -> Maybe v

57−lookup path (MultiMap mm) = case I.lookup h mm of

46+search k m = case I.lookup k m of

58 Nothing -> Nothing

47 Nothing -> Nothing

59− Just s -> Prelude.lookup path s

48+ Just s -> Just $! NE.head s

60− where

49+

61− !h = hash path

50+-- | O(log n)

51+searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v

52+searchWith k f m = case I.lookup k m of

53+ Nothing -> Nothing

54+ Just nxs -> find f $ NE.toList nxs

62

55

63----------------------------------------------------------------

56----------------------------------------------------------------

64

57

65-- | O(log n)

58-- | O(log n)

66−insert :: FilePath -> v -> MultiMap v -> MultiMap v

59+insert :: Int -> v -> MMap v -> MMap v

67−insert path v (MultiMap mm) = MultiMap mm'

68− where

69− !h = hash path

70− !mm' = I.insertWith (<>) h [(path,v)] mm

60+insert k v m = I.insertWith (<>) k (v :| []) m

71

61

72----------------------------------------------------------------

62----------------------------------------------------------------

73

63

74-- | O(n)

64-- | O(n)

75−toList :: MultiMap v -> [(FilePath,v)]

65+toList :: MMap v -> [v]

76−toList (MultiMap mm) = concatMap snd $ I.toAscList mm

66+toList m = concatMap f $ I.toAscList m

67+ where

68+ f (_,s) = NE.toList s

77

69

78----------------------------------------------------------------

70----------------------------------------------------------------

79

71

80-- | O(n)

72-- | O(n)

81−pruneWith :: MultiMap v

73+pruneWith :: MMap v

82− -> ((FilePath,v) -> IO Bool)

74+ -> (v -> IO Bool)

83− -> IO (MultiMap v)

75+ -> IO (MMap v)

84−pruneWith (MultiMap mm) action = MultiMap <$> mm'

76+pruneWith m action = I.fromAscList <$> go (I.toDescList m) []

85 where

77 where

86− !mm' = I.fromAscList <$> go (I.toDescList mm) []

87− go [] !acc = return acc

78+ go [] acc = return acc

88− go ((h,s):kss) !acc = do

79+ go ((k,s):kss) acc = do

89− rs <- prune action s

80+ mt <- prune action s

90− case rs of

81+ case mt of

91− [] -> go kss acc

82+ Nothing -> go kss acc

92− _ -> go kss ((h,rs) : acc)

83+ Just t -> go kss ((k,t) : acc)

93

84

94----------------------------------------------------------------

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

95

86

96-- O(n + m) where N is the size of the second argument

87-- O(n + m) where N is the size of the second argument

97−merge :: MultiMap v -> MultiMap v -> MultiMap v

88+merge :: MMap v -> MMap v -> MMap v

98−merge (MultiMap m1) (MultiMap m2) = MultiMap mm

99− where

100− !mm = I.unionWith (<>) m1 m2

89+merge m1 m2 = I.unionWith (<>) m1 m2

101

90

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

91----------------------------------------------------------------

103

92

104−prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]

93+prune :: (a -> IO Bool) -> NonEmpty a -> IO (Maybe (NonEmpty a))

105−prune action xs0 = go xs0

94+prune act nxs = NE.nonEmpty <$> go (NE.toList nxs)

106 where

95 where

107 go [] = return []

96 go [] = return []

108 go (x:xs) = do

97 go (x:xs) = do

109− keep <- action x

98+ keep <- act x

110 rs <- go xs

99 rs <- go xs

111 return $ if keep then x:rs else rs

100 return $ if keep then x:rs else rs

warp/Network/Wai/Handler/Warp/Recv.hs+10−40

@@ -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,45 +89,24 @@ 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)

105− withFdSocket sock $ \fd -> do

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

107− fd <- fdSocket sock

108−#else

109− let fd = fdSocket sock

94+ let sock' = fdSocket sock

110−#endif

111− let size' = fromIntegral size

95+ size' = fromIntegral size

112− fromIntegral <$> receiveloop fd ptr size'

96+ fromIntegral <$> receiveloop sock' 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

97

119receiveBuf :: Socket -> RecvBuf

98receiveBuf :: Socket -> RecvBuf

120−receiveBuf sock buf0 siz0 = do

99+receiveBuf sock buf0 siz0 = loop buf0 siz0

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

122− withFdSocket sock $ \fd -> do

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

124− fd <- fdSocket sock

125−#else

126− let fd = fdSocket sock

127−#endif

128− loop fd buf0 siz0

129 where

100 where

130− loop _ _ 0 = return True

101+ loop _ 0 = return True

131− loop fd buf siz = do

102+ loop buf siz = do

132 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

103 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

133 -- fixme: what should we do in the case of n == 0

104 -- fixme: what should we do in the case of n == 0

134 if n == 0 then

105 if n == 0 then

135 return False

106 return False

136 else

107 else

137− loop fd (buf `plusPtr` n) (siz - n)

108+ loop (buf `plusPtr` n) (siz - n)

109+ fd = fdSocket sock

138

110

139receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

111receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

140receiveloop sock ptr size = do

112receiveloop sock ptr size = do

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

153 else

125 else

154 return bytes

126 return bytes

155

127

156−#ifndef mingw32_HOST_OS

157-- fixme: the type of the return value

128-- fixme: the type of the return value

158foreign import ccall unsafe "recv"

129foreign import ccall unsafe "recv"

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

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

160−#endif

warp/Network/Wai/Handler/Warp/Request.hs+28−26

@@ -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,23 +21,29 @@ 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

27+import qualified Network.Wai.Handler.Warp.Timeout as Timeout

29import Network.Wai.Handler.Warp.Types

28import Network.Wai.Handler.Warp.Types

30import Network.Wai.Internal

29import Network.Wai.Internal

31import Prelude hiding (lines)

30import Prelude hiding (lines)

32import System.IO.Unsafe (unsafePerformIO)

31import System.IO.Unsafe (unsafePerformIO)

33−import qualified System.TimeManager as Timeout

34

32

35import Network.Wai.Handler.Warp.Conduit

33import Network.Wai.Handler.Warp.Conduit

36import Network.Wai.Handler.Warp.FileInfoCache

34import Network.Wai.Handler.Warp.FileInfoCache

35+import Network.Wai.Handler.Warp.HashMap (hashByteString)

37import Network.Wai.Handler.Warp.Header

36import Network.Wai.Handler.Warp.Header

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

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

39import Network.Wai.Handler.Warp.ReadInt

38import Network.Wai.Handler.Warp.ReadInt

40import Network.Wai.Handler.Warp.RequestHeader

39import Network.Wai.Handler.Warp.RequestHeader

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

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

41+

42+----------------------------------------------------------------

43+

44+-- FIXME come up with good values here

45+maxTotalHeaderLength :: Int

46+maxTotalHeaderLength = 50 * 1024

42

47

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

48----------------------------------------------------------------

44

49

@@ -47,22 +52,21 @@ import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, setting

47recvRequest :: Bool -- ^ first request on this connection?

52recvRequest :: Bool -- ^ first request on this connection?

48 -> Settings

53 -> Settings

49 -> Connection

54 -> Connection

50− -> InternalInfo

55+ -> InternalInfo1

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

58− ,IO ByteString) -- ^

61+ ,IO ByteString

62+ ,InternalInfo) -- ^

59 -- 'Request' passed to 'Application',

63 -- 'Request' passed to 'Application',

60 -- how many bytes remain to be consumed, if known

64 -- how many bytes remain to be consumed, if known

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

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

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

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

63

67

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

68+recvRequest firstRequest settings conn ii1 addr src = do

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

69+ hdrlines <- headerLines firstRequest src

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

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

67 let idxhdr = indexRequestHeader hdr

71 let idxhdr = indexRequestHeader hdr

68 expect = idxhdr ! fromEnum ReqExpect

72 expect = idxhdr ! fromEnum ReqExpect

@@ -70,9 +74,11 @@ recvRequest firstRequest settings conn ii th addr src transport = do

70 te = idxhdr ! fromEnum ReqTransferEncoding

74 te = idxhdr ! fromEnum ReqTransferEncoding

71 handle100Continue = handleExpect conn httpversion expect

75 handle100Continue = handleExpect conn httpversion expect

72 rawPath = if settingsNoParsePath settings then unparsedPath else path

76 rawPath = if settingsNoParsePath settings then unparsedPath else path

77+ h = hashByteString rawPath

78+ ii = toInternalInfo ii1 h

79+ th = threadHandle ii

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

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

74 $ Vault.insert getFileInfoKey (getFileInfo ii)

81 $ Vault.insert getFileInfoKey (getFileInfo ii)

75− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

76 Vault.empty

82 Vault.empty

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

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

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

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

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

87 , rawQueryString = query

93 , rawQueryString = query

88 , queryString = H.parseQuery query

94 , queryString = H.parseQuery query

89 , requestHeaders = hdr

95 , requestHeaders = hdr

90− , isSecure = isTransportSecure transport

96+ , isSecure = False

91 , remoteHost = addr

97 , remoteHost = addr

92 , requestBody = rbody'

98 , requestBody = rbody'

93 , vault = vaultValue

99 , vault = vaultValue

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

97 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

103 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

98 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

104 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

99 }

105 }

100− return (req, remainingRef, idxhdr, rbodyFlush)

106+ return (req, remainingRef, idxhdr, rbodyFlush, ii)

101

107

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

108----------------------------------------------------------------

103

109

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

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

105−headerLines maxTotalHeaderLength firstRequest src = do

111+headerLines firstRequest src = do

106 bs <- readSource src

112 bs <- readSource src

107 if S.null bs

113 if S.null bs

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

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

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

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

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

111 -- the Run module for more details.

117 -- the Run module for more details.

112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

118 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

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

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

114

120

115data NoKeepAliveRequest = NoKeepAliveRequest

121data NoKeepAliveRequest = NoKeepAliveRequest

116 deriving (Show, Typeable)

122 deriving (Show, Typeable)

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

220close = throwIO IncompleteHeaders

226close = throwIO IncompleteHeaders

221-}

227-}

222

228

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

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

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

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

225 -- Too many bytes

231 -- Too many bytes

226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

232 | len > maxTotalHeaderLength = throwIO OverLargeHeader

227 | otherwise = push' mnl

233 | otherwise = push' mnl

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

249 push' Nothing = do

255 push' Nothing = do

250 bst <- readSource' src

256 bst <- readSource' src

251 when (S.null bst) $ throwIO IncompleteHeaders

257 when (S.null bst) $ throwIO IncompleteHeaders

252− push maxTotalHeaderLength src status bst

258+ push src status bst

253 where

259 where

254 len' = len + bsLen

260 len' = len + bsLen

255 prepend' = S.append bs

261 prepend' = S.append bs

256 status = THStatus len' lines prepend'

262 status = THStatus len' lines prepend'

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

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

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

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

259 where

265 where

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

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

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

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

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

274 in if start < bsLen then

280 in if start < bsLen then

275 -- more bytes in this chunk, push again

281 -- more bytes in this chunk, push again

276 let bs'' = SU.unsafeDrop start bs

282 let bs'' = SU.unsafeDrop start bs

277− in push maxTotalHeaderLength src status bs''

283+ in push src status bs''

278 else do

284 else do

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

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

280 bst <- readSource' src

286 bst <- readSource' src

281 when (S.null bs) $ throwIO IncompleteHeaders

287 when (S.null bs) $ throwIO IncompleteHeaders

282− push maxTotalHeaderLength src status bst

288+ push src status bst

283 where

289 where

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

290 start = end + 1 -- start of next chunk

285 line = SU.unsafeTake (checkCR bs end) bs

291 line = SU.unsafeTake (checkCR bs end) bs

@@ -297,7 +303,3 @@ pauseTimeoutKey = unsafePerformIO Vault.newKey

297getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

303getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

298getFileInfoKey = unsafePerformIO Vault.newKey

304getFileInfoKey = unsafePerformIO Vault.newKey

299{-# NOINLINE getFileInfoKey #-}

305{-# NOINLINE getFileInfoKey #-}

300−

301−getClientCertificateKey :: Vault.Key (Maybe CertificateChain)

302−getClientCertificateKey = unsafePerformIO Vault.newKey

303−{-# NOINLINE getClientCertificateKey #-}

warp/Network/Wai/Handler/Warp/Response.hs+19−22

@@ -30,7 +30,6 @@ import qualified Network.HTTP.Types.Header as H

30import Network.Wai

31import Network.Wai.Internal

32import qualified Paths_warp

33−import qualified System.TimeManager as T

34

33

35import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

34import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

36import qualified Network.Wai.Handler.Warp.Date as D

35import qualified Network.Wai.Handler.Warp.Date as D

@@ -40,6 +39,7 @@ import Network.Wai.Handler.Warp.IO (toBufIOWith)

40import Network.Wai.Handler.Warp.Imports

39import Network.Wai.Handler.Warp.Imports

41import Network.Wai.Handler.Warp.ResponseHeader

40import Network.Wai.Handler.Warp.ResponseHeader

42import Network.Wai.Handler.Warp.Settings

41import Network.Wai.Handler.Warp.Settings

42+import qualified Network.Wai.Handler.Warp.Timeout as T

43import Network.Wai.Handler.Warp.Types

44

45-- $setup

@@ -101,13 +101,12 @@ import Network.Wai.Handler.Warp.Types

101sendResponse :: Settings

102 -> Connection

103 -> InternalInfo

104− -> T.Handle

105 -> Request -- ^ HTTP request.

104 -> Request -- ^ HTTP request.

106 -> IndexedHeader -- ^ Indexed header of HTTP request.

105 -> IndexedHeader -- ^ Indexed header of HTTP request.

107 -> IO ByteString -- ^ source from client, for raw response

106 -> IO ByteString -- ^ source from client, for raw response

108 -> Response -- ^ HTTP response including status code and response header.

107 -> Response -- ^ HTTP response including status code and response header.

109 -> IO Bool -- ^ Returing True if the connection is persistent.

108 -> IO Bool -- ^ Returing True if the connection is persistent.

110−sendResponse settings conn ii th req reqidxhdr src response = do

109+sendResponse settings conn ii req reqidxhdr src response = do

111 hs <- addServerAndDate hs0

110 hs <- addServerAndDate hs0

112 if hasBody s then do

111 if hasBody s then do

113 -- The response to HEAD does not have body.

112 -- The response to HEAD does not have body.

@@ -116,14 +115,14 @@ sendResponse settings conn ii th req reqidxhdr src response = do

116 -- and status, the response to HEAD is processed here.

115 -- and status, the response to HEAD is processed here.

117 --

116 --

118 -- See definition of rsp below for proper body stripping.

117 -- See definition of rsp below for proper body stripping.

119− (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp

118+ (ms, mlen) <- sendRsp conn ii ver s hs rsp

120 case ms of

119 case ms of

121 Nothing -> return ()

120 Nothing -> return ()

122 Just realStatus -> logger req realStatus mlen

121 Just realStatus -> logger req realStatus mlen

123 T.tickle th

122 T.tickle th

124 return ret

123 return ret

125 else do

124 else do

126− _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody

125+ _ <- sendRsp conn ii ver s hs RspNoBody

127 logger req s Nothing

126 logger req s Nothing

128 T.tickle th

127 T.tickle th

129 return isPersist

128 return isPersist

@@ -134,6 +133,7 @@ sendResponse settings conn ii th req reqidxhdr src response = do

134 s = responseStatus response

133 s = responseStatus response

135 hs0 = sanitizeHeaders $ responseHeaders response

134 hs0 = sanitizeHeaders $ responseHeaders response

136 rspidxhdr = indexResponseHeader hs0

135 rspidxhdr = indexResponseHeader hs0

136+ th = threadHandle ii

137 getdate = getDate ii

138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

@@ -196,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+67−122

@@ -3,10 +3,8 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PackageImports #-}

5{-# LANGUAGE PatternGuards #-}

6−{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE TupleSections #-}

9−{-# LANGUAGE ViewPatterns #-}

10{-# OPTIONS_GHC -fno-warn-deprecations #-}

8{-# OPTIONS_GHC -fno-warn-deprecations #-}

11

9

12module Network.Wai.Handler.Warp.Run where

10module Network.Wai.Handler.Warp.Run where

@@ -17,20 +15,15 @@ import qualified Control.Concurrent as Conc (yield)

17import Control.Exception as E

15import Control.Exception as E

18import qualified Data.ByteString as S

16import qualified Data.ByteString as S

19import Data.Char (chr)

17import Data.Char (chr)

20−import Data.IORef (IORef, newIORef, readIORef, writeIORef)

18+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')

21import Data.Streaming.Network (bindPortTCP)

19import Data.Streaming.Network (bindPortTCP)

22import Foreign.C.Error (Errno(..), eCONNABORTED)

20import Foreign.C.Error (Errno(..), eCONNABORTED)

23import GHC.IO.Exception (IOException(..))

21import GHC.IO.Exception (IOException(..))

24−import qualified Network.HTTP2 as H2

25import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

22import 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

23import qualified Network.Socket.ByteString as Sock

30import Network.Wai

24import Network.Wai

31import Network.Wai.Internal (ResponseReceived (ResponseReceived))

25import Network.Wai.Internal (ResponseReceived (ResponseReceived))

32−import System.Environment (lookupEnv)

26+import System.Environment (getEnvironment)

33−import qualified System.TimeManager as T

34import System.Timeout (timeout)

27import System.Timeout (timeout)

35

28

36import Network.Wai.Handler.Warp.Buffer

29import Network.Wai.Handler.Warp.Buffer

@@ -38,8 +31,7 @@ import Network.Wai.Handler.Warp.Counter

38import qualified Network.Wai.Handler.Warp.Date as D

31import qualified Network.Wai.Handler.Warp.Date as D

39import qualified Network.Wai.Handler.Warp.FdCache as F

32import qualified Network.Wai.Handler.Warp.FdCache as F

40import qualified Network.Wai.Handler.Warp.FileInfoCache as I

33import qualified Network.Wai.Handler.Warp.FileInfoCache as I

41−import Network.Wai.Handler.Warp.HTTP2 (http2)

34+import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)

42−import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)

43import Network.Wai.Handler.Warp.Header

35import Network.Wai.Handler.Warp.Header

44import Network.Wai.Handler.Warp.Imports hiding (readInt)

36import Network.Wai.Handler.Warp.Imports hiding (readInt)

45import Network.Wai.Handler.Warp.ReadInt

37import Network.Wai.Handler.Warp.ReadInt

@@ -48,6 +40,7 @@ import Network.Wai.Handler.Warp.Request

48import Network.Wai.Handler.Warp.Response

40import Network.Wai.Handler.Warp.Response

49import Network.Wai.Handler.Warp.SendFile

41import Network.Wai.Handler.Warp.SendFile

50import Network.Wai.Handler.Warp.Settings

42import Network.Wai.Handler.Warp.Settings

43+import qualified Network.Wai.Handler.Warp.Timeout as T

51import Network.Wai.Handler.Warp.Types

44import Network.Wai.Handler.Warp.Types

52

45

53

46

@@ -58,38 +51,21 @@ import Network.Socket (fdSocket)

58#endif

51#endif

59

52

60-- | Creating 'Connection' for plain HTTP based on a given socket.

53-- | Creating 'Connection' for plain HTTP based on a given socket.

61−socketConnection :: Settings -> Socket -> IO Connection

54+socketConnection :: Socket -> IO Connection

62−#if MIN_VERSION_network(3,1,1)

63−socketConnection set s = do

64−#else

65−socketConnection _ s = do

55+socketConnection s = do

66−#endif

67 bufferPool <- newBufferPool

56 bufferPool <- newBufferPool

68 writeBuf <- allocateBuffer bufferSize

57 writeBuf <- allocateBuffer bufferSize

69 let sendall = Sock.sendAll s

58 let sendall = Sock.sendAll s

70− isH2 <- newIORef False -- HTTP/1.x

71 return Connection {

59 return Connection {

72 connSendMany = Sock.sendMany s

60 connSendMany = Sock.sendMany s

73 , connSendAll = sendall

61 , connSendAll = sendall

74 , connSendFile = sendFile s writeBuf bufferSize sendall

62 , 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

63 , connClose = close s

86−#endif

87 , connFree = freeBuffer writeBuf

64 , connFree = freeBuffer writeBuf

88 , connRecv = receive s bufferPool

65 , connRecv = receive s bufferPool

89 , connRecvBuf = receiveBuf s

66 , connRecvBuf = receiveBuf s

90 , connWriteBuffer = writeBuf

67 , connWriteBuffer = writeBuf

91 , connBufferSize = bufferSize

68 , connBufferSize = bufferSize

92− , connHTTP2 = isH2

93 }

69 }

94

70

95-- | Run an 'Application' on the given port.

71-- | Run an 'Application' on the given port.

@@ -104,7 +80,7 @@ run p = runSettings defaultSettings { settingsPort = p }

104-- Since 3.0.9

80-- Since 3.0.9

105runEnv :: Port -> Application -> IO ()

81runEnv :: Port -> Application -> IO ()

106runEnv p app = do

82runEnv p app = do

107− mp <- lookupEnv "PORT"

83+ mp <- lookup "PORT" <$> getEnvironment

108

84

109 maybe (run p app) runReadPort mp

85 maybe (run p app) runReadPort mp

110

86

@@ -151,7 +127,7 @@ runSettingsSocket set socket app = do

151 setSocketCloseOnExec s

127 setSocketCloseOnExec s

152 -- NoDelay causes an error for AF_UNIX.

128 -- NoDelay causes an error for AF_UNIX.

153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

129 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

154− conn <- socketConnection set s

130+ conn <- socketConnection s

155 return (conn, sa)

131 return (conn, sa)

156

132

157 closeListenSocket = close socket

133 closeListenSocket = close socket

@@ -192,15 +168,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),

192runSettingsConnectionMakerSecure set getConnMaker app = do

168runSettingsConnectionMakerSecure set getConnMaker app = do

193 settingsBeforeMainLoop set

169 settingsBeforeMainLoop set

194 counter <- newCounter

170 counter <- newCounter

195− withII $ acceptConnection set getConnMaker app counter

171+ withII0 $ acceptConnection set getConnMaker app counter

196 where

172 where

197− withII action =

173+ withII0 action =

198 withTimeoutManager $ \tm ->

174 withTimeoutManager $ \tm ->

199 D.withDateCache $ \dc ->

175 D.withDateCache $ \dc ->

200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

176 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

177 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

202− let ii = InternalInfo tm dc fdc fic

178+ let ii0 = InternalInfo0 tm dc fdc fic

203− action ii

179+ action ii0

204

180

205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

181 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

182 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

@@ -229,18 +205,13 @@ acceptConnection :: Settings

229 -> IO (IO (Connection, Transport), SockAddr)

205 -> IO (IO (Connection, Transport), SockAddr)

230 -> Application

206 -> Application

231 -> Counter

207 -> Counter

232− -> InternalInfo

208+ -> InternalInfo0

233 -> IO ()

209 -> IO ()

234−acceptConnection set getConnMaker app counter ii = do

210+acceptConnection set getConnMaker app counter ii0 = do

235 -- First mask all exceptions in acceptLoop. This is necessary to

211 -- First mask all exceptions in acceptLoop. This is necessary to

236 -- ensure that no async exception is throw between the call to

212 -- ensure that no async exception is throw between the call to

237 -- acceptNewConnection and the registering of connClose.

213 -- acceptNewConnection and the registering of connClose.

238− --

239− -- acceptLoop can be broken by closing the listing socket.

240 void $ mask_ acceptLoop

214 void $ mask_ acceptLoop

241− -- In some cases, we want to stop Warp here without graceful shutdown.

242− -- So, async exceptions are allowed here.

243− -- That's why `finally` is not used.

244 gracefulShutdown set counter

215 gracefulShutdown set counter

245 where

216 where

246 acceptLoop = do

217 acceptLoop = do

@@ -258,7 +229,7 @@ acceptConnection set getConnMaker app counter ii = do

258 case mx of

229 case mx of

259 Nothing -> return ()

230 Nothing -> return ()

260 Just (mkConn, addr) -> do

231 Just (mkConn, addr) -> do

261− fork set mkConn addr app counter ii

232+ fork set mkConn addr app counter ii0

262 acceptLoop

233 acceptLoop

263

234

264 acceptNewConnection = do

235 acceptNewConnection = do

@@ -281,12 +252,15 @@ fork :: Settings

281 -> SockAddr

252 -> SockAddr

282 -> Application

253 -> Application

283 -> Counter

254 -> Counter

284− -> InternalInfo

255+ -> InternalInfo0

285 -> IO ()

256 -> IO ()

286−fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

257+fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

287 -- Call the user-supplied on exception code if any

258 -- Call the user-supplied on exception code if any

288 -- exceptions are thrown.

259 -- exceptions are thrown.

289− handle (settingsOnException set Nothing) $

260+ handle (settingsOnException set Nothing) .

261+ -- Allocate a new IORef indicating whether the connection has been

262+ -- closed, to avoid double-freeing a connection

263+ withClosedRef $ \ref ->

290 -- Run the connection maker to get a new connection, and ensure

264 -- Run the connection maker to get a new connection, and ensure

291 -- that the connection is closed. If the mkConn call throws an

265 -- that the connection is closed. If the mkConn call throws an

292 -- exception, we will leak the connection. If the mkConn call is

266 -- exception, we will leak the connection. If the mkConn call is

@@ -297,15 +271,24 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

297 -- We grab the connection before registering timeouts since the

271 -- We grab the connection before registering timeouts since the

298 -- timeouts will be useless during connection creation, due to the

272 -- timeouts will be useless during connection creation, due to the

299 -- fact that async exceptions are still masked.

273 -- fact that async exceptions are still masked.

300− bracket mkConn cleanUp (serve unmask)

274+ bracket mkConn (cleanUp ref) (serve unmask ref)

301 where

275 where

276+ withClosedRef inner = newIORef False >>= inner

277+

278+ closeConn ref conn = do

279+ isClosed <- atomicModifyIORef' ref $ \x -> (True, x)

280+ unless isClosed $ connClose conn

281+

302− cleanUp (conn, _) = connClose conn `finally` connFree conn

282+ cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn

303

283

304 -- We need to register a timeout handler for this thread, and

284 -- We need to register a timeout handler for this thread, and

305− -- cancel that handler as soon as we exit.

285+ -- cancel that handler as soon as we exit. We additionally close

286+ -- the connection immediately in case the child thread catches the

287+ -- async exception or performs some long-running cleanup action.

306− serve unmask (conn, transport) = bracket register cancel $ \th -> do

288+ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do

289+ let ii1 = toInternalInfo1 ii0 th

307 -- We now have fully registered a connection close handler in

290 -- We now have fully registered a connection close handler in

308− -- the case of all exceptions, so it is safe to once again

291+ -- the case of all exceptions, so it is safe to one again

309 -- allow async exceptions.

292 -- allow async exceptions.

310 unmask .

293 unmask .

311 -- Call the user-supplied code for connection open and

294 -- Call the user-supplied code for connection open and

@@ -313,23 +296,23 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

313 bracket (onOpen addr) (onClose addr) $ \goingon ->

296 bracket (onOpen addr) (onClose addr) $ \goingon ->

314 -- Actually serve this connection. bracket with closeConn

297 -- Actually serve this connection. bracket with closeConn

315 -- above ensures the connection is closed.

298 -- above ensures the connection is closed.

316− when goingon $ serveConnection conn ii th addr transport set app

299+ when goingon $ serveConnection conn ii1 addr transport set app

317 where

300 where

318− register = T.registerKillThread (timeoutManager ii) (connClose conn)

301+ register = T.registerKillThread (timeoutManager0 ii0)

302+ (closeConn ref conn)

319 cancel = T.cancel

303 cancel = T.cancel

320

304

321 onOpen adr = increase counter >> settingsOnOpen set adr

305 onOpen adr = increase counter >> settingsOnOpen set adr

322 onClose adr _ = decrease counter >> settingsOnClose set adr

306 onClose adr _ = decrease counter >> settingsOnClose set adr

323

307

324serveConnection :: Connection

308serveConnection :: Connection

325− -> InternalInfo

309+ -> InternalInfo1

326− -> T.Handle

327 -> SockAddr

310 -> SockAddr

328 -> Transport

311 -> Transport

329 -> Settings

312 -> Settings

330 -> Application

313 -> Application

331 -> IO ()

314 -> IO ()

332−serveConnection conn ii th origAddr transport settings app = do

315+serveConnection conn ii1 origAddr transport settings app = do

333 -- fixme: Upgrading to HTTP/2 should be supported.

316 -- fixme: Upgrading to HTTP/2 should be supported.

334 (h2,bs) <- if isHTTP2 transport then

317 (h2,bs) <- if isHTTP2 transport then

335 return (True, "")

318 return (True, "")

@@ -342,35 +325,22 @@ serveConnection conn ii th origAddr transport settings app = do

342 istatus <- newIORef False

325 istatus <- newIORef False

343 if settingsHTTP2Enabled settings && h2 then do

326 if settingsHTTP2Enabled settings && h2 then do

344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

327 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

328 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

353− sendBS x = connSendAll conn x >> T.tickle th

354 -- fixme: origAddr

329 -- fixme: origAddr

355− checkTLS

356− setConnHTTP2 conn True

357− http2 conn transport ii origAddr settings recvN sendBS app

330+ http2 conn ii1 origAddr transport settings recvN app

358 else do

331 else do

359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

332 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

360 writeIORef istatus True

333 writeIORef istatus True

361 leftoverSource src bs

334 leftoverSource src bs

362 addr <- getProxyProtocolAddr src

335 addr <- getProxyProtocolAddr src

363 http1 True addr istatus src `E.catch` \e ->

336 http1 True addr istatus src `E.catch` \e ->

364− case () of

337+ case fromException e of

365− ()

366− -- See comment below referencing

338+ -- See comment below referencing

367− -- https://github.com/yesodweb/wai/issues/618

339+ -- https://github.com/yesodweb/wai/issues/618

368− | Just NoKeepAliveRequest <- fromException e -> return ()

340+ Just NoKeepAliveRequest -> return ()

369− -- No valid request

341+ Nothing -> do

370− | Just (BadFirstLine _) <- fromException e -> return ()

371− | otherwise -> do

372− _ <- sendErrorResponse (dummyreq addr) istatus e

342+ sendErrorResponse (dummyreq addr) istatus e

373− throwIO e

343+ throwIO e

374

344

375 where

345 where

376 getProxyProtocolAddr src =

346 getProxyProtocolAddr src =

@@ -413,25 +383,29 @@ serveConnection conn ii th origAddr transport settings app = do

413

383

414 decodeAscii = map (chr . fromEnum) . S.unpack

384 decodeAscii = map (chr . fromEnum) . S.unpack

415

385

386+ th = threadHandle1 ii1

387+

416 shouldSendErrorResponse se

388 shouldSendErrorResponse se

417 | Just ConnectionClosedByPeer <- fromException se = False

389 | Just ConnectionClosedByPeer <- fromException se = False

418 | otherwise = True

390 | otherwise = True

419

391

420 sendErrorResponse req istatus e = do

392 sendErrorResponse req istatus e = do

421 status <- readIORef istatus

393 status <- readIORef istatus

422− if shouldSendErrorResponse e && status

394+ when (shouldSendErrorResponse e && status) $ do

423− then do

395+ let ii = toInternalInfo ii1 0 -- dummy

424− sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

396+ void $ sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)

425− else return False

426

397

427 dummyreq addr = defaultRequest { remoteHost = addr }

398 dummyreq addr = defaultRequest { remoteHost = addr }

428

399

429 errorResponse e = settingsOnExceptionResponse settings e

400 errorResponse e = settingsOnExceptionResponse settings e

430

401

431 http1 firstRequest addr istatus src = do

402 http1 firstRequest addr istatus src = do

432− (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport

403+ (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src

404+ let req = req' { isSecure = isTransportSecure transport }

433− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

405+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii

434 `E.catch` \e -> do

406 `E.catch` \e -> do

407+ -- Call the user-supplied exception handlers, passing the request.

408+ sendErrorResponse req istatus e

435 settingsOnException settings (Just req) e

409 settingsOnException settings (Just req) e

436 -- Don't throw the error again to prevent calling settingsOnException twice.

410 -- Don't throw the error again to prevent calling settingsOnException twice.

437 return False

411 return False

@@ -446,7 +420,7 @@ serveConnection conn ii th origAddr transport settings app = do

446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

420 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

447 when keepAlive $ http1 False addr istatus src

421 when keepAlive $ http1 False addr istatus src

448

422

449− processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

423+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do

450 -- Let the application run for as long as it wants

424 -- Let the application run for as long as it wants

451 T.pause th

425 T.pause th

452

426

@@ -454,38 +428,30 @@ serveConnection conn ii th origAddr transport settings app = do

454 -- creating the request, we need to make sure that we don't get

428 -- creating the request, we need to make sure that we don't get

455 -- an async exception before calling the ResponseSource.

429 -- an async exception before calling the ResponseSource.

456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

430 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

457− r <- E.try $ app req $ \res -> do

431+ _ <- app req $ \res -> do

458 T.resume th

432 T.resume th

459 -- FIXME consider forcing evaluation of the res here to

433 -- FIXME consider forcing evaluation of the res here to

460 -- send more meaningful error messages to the user.

434 -- send more meaningful error messages to the user.

461 -- However, it may affect performance.

435 -- However, it may affect performance.

462 writeIORef istatus False

436 writeIORef istatus False

463− keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

437+ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

464 writeIORef keepAliveRef keepAlive

438 writeIORef keepAliveRef keepAlive

465 return ResponseReceived

439 return ResponseReceived

466− case r of

467− Right ResponseReceived -> return ()

468− Left e@(SomeException _)

469− | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'

470− | otherwise -> do

471− keepAlive <- sendErrorResponse req istatus e

472− settingsOnException settings (Just req) e

473− writeIORef keepAliveRef keepAlive

474−

475 keepAlive <- readIORef keepAliveRef

440 keepAlive <- readIORef keepAliveRef

476

441

477 -- We just send a Response and it takes a time to

442 -- We just send a Response and it takes a time to

478 -- receive a Request again. If we immediately call recv,

443 -- receive a Request again. If we immediately call recv,

479− -- it is likely to fail and cause the IO manager to do some work.

444+ -- it is likely to fail and the IO manager works.

480− -- It is very costly, so we yield to another Haskell

445+ -- It is very costly. So, we yield to another Haskell

481 -- thread hoping that the next Request will arrive

446 -- thread hoping that the next Request will arrive

482 -- when this Haskell thread will be re-scheduled.

447 -- when this Haskell thread will be re-scheduled.

483 -- This improves performance at least when

448 -- This improves performance at least when

484 -- the number of cores is small.

449 -- the number of cores is small.

485 Conc.yield

450 Conc.yield

486

451

487− if keepAlive

452+ if not keepAlive then

488− then

453+ return False

454+ else

489 -- If there is an unknown or large amount of data to still be read

455 -- If there is an unknown or large amount of data to still be read

490 -- from the request body, simple drop this connection instead of

456 -- from the request body, simple drop this connection instead of

491 -- reading it all in to satisfy a keep-alive request.

457 -- reading it all in to satisfy a keep-alive request.

@@ -511,21 +477,6 @@ serveConnection conn ii th origAddr transport settings app = do

511 else

477 else

512 return False

478 return False

513 Nothing -> tryKeepAlive

479 Nothing -> tryKeepAlive

514− else

515− return False

516−

517− checkTLS = case transport of

518− TCP -> return () -- direct

519− tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"

520− tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

521−

522−-- connClose must not be called here since Run:fork calls it

523−goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()

524−goaway Connection{..} etype debugmsg = connSendAll bytestream

525− where

526− einfo = H2.encodeInfo id 0

527− frame = H2.GoAwayFrame 0 etype debugmsg

528− bytestream = H2.encodeFrame einfo frame

529

480

530flushEntireBody :: IO ByteString -> IO ()

481flushEntireBody :: IO ByteString -> IO ()

531flushEntireBody src =

482flushEntireBody src =

@@ -580,13 +531,7 @@ setSocketCloseOnExec :: Socket -> IO ()

580#if WINDOWS

531#if WINDOWS

581setSocketCloseOnExec _ = return ()

532setSocketCloseOnExec _ = return ()

582#else

533#else

583−setSocketCloseOnExec socket = do

584−#if MIN_VERSION_network(3,0,0)

585− fd <- fdSocket socket

586−#else

587− let fd = fdSocket socket

588−#endif

589− F.setFileCloseOnExec $ fromIntegral fd

534+setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket

590#endif

535#endif

591

536

592gracefulShutdown :: Settings -> Counter -> IO ()

537gracefulShutdown :: Settings -> Counter -> IO ()

warp/Network/Wai/Handler/Warp/Settings.hs+10−54

@@ -8,22 +8,20 @@ import Control.Concurrent (forkIOWithUnmask)

8import Control.Exception

9import Data.ByteString.Builder (byteString)

10import qualified Data.ByteString.Char8 as C8

11−import Data.ByteString.Lazy (fromStrict)

12import Data.Streaming.Network (HostPreference)

11import Data.Streaming.Network (HostPreference)

13import qualified Data.Text as T

12import qualified Data.Text as T

14import qualified Data.Text.IO as TIO

13import qualified Data.Text.IO as TIO

15import Data.Version (showVersion)

14import Data.Version (showVersion)

16import GHC.IO.Exception (IOErrorType(..))

15import GHC.IO.Exception (IOErrorType(..))

17import qualified Network.HTTP.Types as H

16import qualified Network.HTTP.Types as H

18−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

19import Network.Socket (SockAddr)

17import Network.Socket (SockAddr)

20import Network.Wai

18import Network.Wai

21import qualified Paths_warp

19import qualified Paths_warp

22import System.IO (stderr)

20import System.IO (stderr)

23import System.IO.Error (ioeGetErrorType)

21import System.IO.Error (ioeGetErrorType)

24−import System.TimeManager

25

22

26import Network.Wai.Handler.Warp.Imports

23import Network.Wai.Handler.Warp.Imports

24+import Network.Wai.Handler.Warp.Timeout

27import Network.Wai.Handler.Warp.Types

25import Network.Wai.Handler.Warp.Types

28

26

29-- | Various Warp server settings. This is purposely kept as an abstract data

27-- | Various Warp server settings. This is purposely kept as an abstract data

@@ -76,13 +74,6 @@ data Settings = Settings

76 --

74 --

77 -- Since 2.0.3

75 -- Since 2.0.3

78 , settingsInstallShutdownHandler :: IO () -> IO ()

76 , 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

77 , settingsServerName :: ByteString

87 -- ^ Default server name if application does not set one.

78 -- ^ Default server name if application does not set one.

88 --

79 --

@@ -94,44 +85,28 @@ data Settings = Settings

94 , settingsProxyProtocol :: ProxyProtocol

85 , settingsProxyProtocol :: ProxyProtocol

95 -- ^ Specify usage of the PROXY protocol.

86 -- ^ Specify usage of the PROXY protocol.

96 --

87 --

97− -- Since 3.0.5

88+ -- Since 3.0.5.

98 , settingsSlowlorisSize :: Int

89 , settingsSlowlorisSize :: Int

99 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

90 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

100 --

91 --

101− -- Since 3.1.2

92+ -- Since 3.1.2.

102 , settingsHTTP2Enabled :: Bool

93 , settingsHTTP2Enabled :: Bool

103 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

94 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

104 --

95 --

105− -- Since 3.1.7

96+ -- Since 3.1.7.

106 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

97 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

107 -- ^ A log function. Default: no action.

98 -- ^ A log function. Default: no action.

108 --

99 --

109− -- Since 3.1.10

100+ -- Since 3.X.X.

110 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

101 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

111 -- ^ A HTTP/2 server push log function. Default: no action.

102 -- ^ A HTTP/2 server push log function. Default: no action.

112 --

103 --

113− -- Since 3.2.7

104+ -- Since 3.X.X.

114 , settingsGracefulShutdownTimeout :: Maybe Int

105 , settingsGracefulShutdownTimeout :: Maybe Int

115 -- ^ An optional timeout to limit the time (in seconds) waiting for

106 -- ^ An optional timeout to limit the time (in seconds) waiting for

116 -- a graceful shutdown of the web server.

107 -- a graceful shutdown of the web server.

117 --

108 --

118 -- Since 3.2.8

109 -- 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 }

110 }

136

111

137-- | Specify usage of the PROXY protocol.

112-- | Specify usage of the PROXY protocol.

@@ -168,9 +143,6 @@ defaultSettings = Settings

168 , settingsLogger = \_ _ _ -> return ()

143 , settingsLogger = \_ _ _ -> return ()

169 , settingsServerPushLogger = \_ _ _ -> return ()

144 , settingsServerPushLogger = \_ _ _ -> return ()

170 , settingsGracefulShutdownTimeout = Nothing

145 , settingsGracefulShutdownTimeout = Nothing

171− , settingsGracefulCloseTimeout1 = 0

172− , settingsGracefulCloseTimeout2 = 2000

173− , settingsMaxTotalHeaderLength = 50 * 1024

174 }

146 }

175

147

176-- | Apply the logic provided by 'defaultOnException' to determine if an

148-- | Apply the logic provided by 'defaultOnException' to determine if an

@@ -196,29 +168,13 @@ defaultOnException _ e =

196 when (defaultShouldDisplayException e)

168 when (defaultShouldDisplayException e)

197 $ TIO.hPutStrLn stderr $ T.pack $ show e

169 $ TIO.hPutStrLn stderr $ T.pack $ show e

198

170

199−-- | Sending 400 for bad requests.

200−-- Sending 500 for internal server errors.

171+-- | Sending 400 for bad requests. Sending 500 for internal server errors.

172+--

201-- Since: 3.1.0

173-- Since: 3.1.0

202−-- Sending 413 for too large payload.

203−-- Sending 431 for too large headers.

204−-- Since 3.2.27

205defaultOnExceptionResponse :: SomeException -> Response

174defaultOnExceptionResponse :: SomeException -> Response

206defaultOnExceptionResponse e

175defaultOnExceptionResponse e

207− | Just (_ :: InvalidRequest) <-

208− fromException e = responseLBS H.badRequest400

176+ | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request"

209− [(H.hContentType, "text/plain; charset=utf-8")]

210− "Bad Request"

211− | Just (ConnectionError (UnknownErrorCode 413) t) <-

212− fromException e = responseLBS H.status413

213− [(H.hContentType, "text/plain; charset=utf-8")]

214− (fromStrict t)

215− | Just (ConnectionError (UnknownErrorCode 431) t) <-

216− fromException e = responseLBS H.status431

217− [(H.hContentType, "text/plain; charset=utf-8")]

218− (fromStrict t)

219− | otherwise = responseLBS H.internalServerError500

177+ | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"

220− [(H.hContentType, "text/plain; charset=utf-8")]

221− "Something went wrong"

222

178

223-- | Exception handler for the debugging purpose.

179-- | Exception handler for the debugging purpose.

224-- 500, text/plain, a showed exception.

180-- 500, text/plain, a showed exception.

time-manager/System/TimeManager.hs → warp/Network/Wai/Handler/Warp/Timeout.hsrenamed+3−2

@@ -1,6 +1,7 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

2

3

3−module System.TimeManager (

4+module Network.Wai.Handler.Warp.Timeout (

4 -- ** Types

5 -- ** Types

5 Manager

6 Manager

6 , TimeoutAction

7 , TimeoutAction

@@ -114,7 +115,7 @@ instance E.Exception TimeoutThread where

114 toException = E.asyncExceptionToException

115 toException = E.asyncExceptionToException

115 fromException = E.asyncExceptionFromException

116 fromException = E.asyncExceptionFromException

116instance Show TimeoutThread where

117instance Show TimeoutThread where

117− show TimeoutThread = "Thread killed by timeout manager"

118+ show TimeoutThread = "Thread killed by Warp's timeout reaper"

118

119

119----------------------------------------------------------------

120----------------------------------------------------------------

120

121

warp/Network/Wai/Handler/Warp/Types.hs+30−25

@@ -8,15 +8,14 @@ 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)

14−import qualified System.TimeManager as T

15

13

16import qualified Network.Wai.Handler.Warp.Date as D

14import qualified Network.Wai.Handler.Warp.Date as D

17import qualified Network.Wai.Handler.Warp.FdCache as F

15import qualified Network.Wai.Handler.Warp.FdCache as F

18import qualified Network.Wai.Handler.Warp.FileInfoCache as I

16import qualified Network.Wai.Handler.Warp.FileInfoCache as I

19import Network.Wai.Handler.Warp.Imports

17import Network.Wai.Handler.Warp.Imports

18+import qualified Network.Wai.Handler.Warp.Timeout as T

20

19

21----------------------------------------------------------------

20----------------------------------------------------------------

22

21

@@ -53,20 +52,6 @@ instance Exception InvalidRequest

53

52

54----------------------------------------------------------------

53----------------------------------------------------------------

55

54

56−-- | Exception thrown if something goes wrong while in the midst of

57−-- sending a response, since the status code can't be altered at that

58−-- point.

59−--

60−-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe

61−-- or irrecoverable.

62−

63−newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException

64− deriving (Show, Typeable)

65−

66−instance Exception ExceptionInsideResponseBody

67−

68−----------------------------------------------------------------

69−

70-- | Data type to abstract file identifiers.

55-- | Data type to abstract file identifiers.

71-- On Unix, a file descriptor would be specified to make use of

56-- On Unix, a file descriptor would be specified to make use of

72-- the file descriptor cache.

57-- the file descriptor cache.

@@ -123,25 +108,46 @@ data Connection = Connection {

123 , connWriteBuffer :: Buffer

108 , connWriteBuffer :: Buffer

124 -- | The size of the write buffer.

109 -- | The size of the write buffer.

125 , connBufferSize :: BufSize

110 , connBufferSize :: BufSize

126− -- | Is this connection HTTP/2?

127− , connHTTP2 :: IORef Bool

128 }

111 }

129

112

130−getConnHTTP2 :: Connection -> IO Bool

113+----------------------------------------------------------------

131−getConnHTTP2 conn = readIORef (connHTTP2 conn)

114+

115+type Hash = Int

132

116

133−setConnHTTP2 :: Connection -> Bool -> IO ()

134−setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b

135

117

136−----------------------------------------------------------------

118+data InternalInfo0 =

119+ InternalInfo0 T.Manager

120+ (IO D.GMTDate)

121+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

122+ (Hash -> FilePath -> IO I.FileInfo)

123+

124+timeoutManager0 :: InternalInfo0 -> T.Manager

125+timeoutManager0 (InternalInfo0 tm _ _ _) = tm

126+

127+data InternalInfo1 =

128+ InternalInfo1 T.Handle

129+ T.Manager

130+ (IO D.GMTDate)

131+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

132+ (Hash -> FilePath -> IO I.FileInfo)

133+

134+toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1

135+toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e

136+

137+threadHandle1 :: InternalInfo1 -> T.Handle

138+threadHandle1 (InternalInfo1 th _ _ _ _) = th

137

139

138data InternalInfo = InternalInfo {

140data InternalInfo = InternalInfo {

141+ threadHandle :: T.Handle

139− timeoutManager :: T.Manager

142+ , timeoutManager :: T.Manager

140 , getDate :: IO D.GMTDate

143 , getDate :: IO D.GMTDate

141 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

144 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

142 , getFileInfo :: FilePath -> IO I.FileInfo

145 , getFileInfo :: FilePath -> IO I.FileInfo

143 }

146 }

144

147

148+toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo

149+toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h)

150+

145----------------------------------------------------------------

151----------------------------------------------------------------

146

152

147-- | Type for input streaming.

153-- | Type for input streaming.

@@ -180,7 +186,6 @@ data Transport = TCP -- ^ Plain channel: TCP

180 , tlsMinorVersion :: Int

186 , tlsMinorVersion :: Int

181 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

187 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

182 , tlsChiperID :: Word16

188 , tlsChiperID :: Word16

183− , tlsClientCertificate :: Maybe CertificateChain

184 } -- ^ Encrypted channel: TLS or SSL

189 } -- ^ Encrypted channel: TLS or SSL

185

190

186isTransportSecure :: Transport -> Bool

191isTransportSecure :: Transport -> Bool

warp/test/FdCacheSpec.hs+1−1

@@ -17,7 +17,7 @@ spec = describe "withFdCache" $ do

17 it "clean up Fd" $ do

18 ref <- newIORef (Fd (-1))

19 withFdCache 30000000 $ \getFd -> do

20− (Just fd,_) <- getFd "warp.cabal"

20+ (Just fd,_) <- getFd 0 "warp.cabal"

21 writeIORef ref fd

22 nfd <- readIORef ref

23 fdRead nfd 1 `shouldThrow` anyIOException

warp/test/FileSpec.hs+1−1

@@ -21,7 +21,7 @@ testFileRange desc reqhs file ans = it desc $ do

21 let WithBody s hs off len = ans

22 hs' = ("Last-Modified",fileInfoDate finfo) : hs

23 ans' = WithBody s hs' off len

24− conditionalRequest finfo [] (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/ResponseHeaderSpec.hs+30−2

@@ -7,6 +7,9 @@ import qualified Network.HTTP.Types as H

7import Network.Wai.Handler.Warp.ResponseHeader

8import Network.Wai.Handler.Warp.Response

9import Network.Wai.Handler.Warp.Header

10+import Network.Wai.Handler.Warp.HTTP2.HPACK

11+import Network.HPACK

12+import Network.HPACK.Token

10import Test.Hspec

13import Test.Hspec

11

14

12main :: IO ()

15main :: IO ()

@@ -34,15 +37,40 @@ spec = do

34 let hdrs = [("Server","MyServer")]

37 let hdrs = [("Server","MyServer")]

35 rspidxhdr = indexResponseHeader hdrs

38 rspidxhdr = indexResponseHeader hdrs

36 addServer "" rspidxhdr hdrs `shouldBe` []

39 addServer "" rspidxhdr hdrs `shouldBe` []

40+ describe "addHeader" $ do

41+ it "adds Server if not exist" $ do

42+ let v = "MyServer"

43+ hdrs = []

44+ hdrs1 = [("Server",v)]

45+ (thl, vt) <- toHeaderTable hdrs

46+ (thl1, _) <- toHeaderTable hdrs1

47+ addHeader tokenServer v vt thl `shouldBe` thl1

48+ it "does not add Server if exists" $ do

49+ let v = "MyServer2"

50+ hdrs = [("Server","MyServer")]

51+ (thl, vt) <- toHeaderTable hdrs

52+ addHeader tokenServer v vt thl `shouldBe` thl

53+ it "does not add Server if empty" $ do

54+ let v = ""

55+ hdrs = []

56+ (thl, vt) <- toHeaderTable hdrs

57+ addHeader tokenServer v vt thl `shouldBe` thl

58+ it "deletes Server " $ do

59+ let v = ""

60+ hdrs = [("Server","MyServer")]

61+ hdrs1 = []

62+ (thl, vt) <- toHeaderTable hdrs

63+ (thl1, _) <- toHeaderTable hdrs1

64+ addHeader tokenServer v vt thl `shouldBe` thl1

37

65

38headers :: H.ResponseHeaders

66headers :: H.ResponseHeaders

39headers = [

67headers = [

40 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

68 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

41− , ("Content-Length", "151")

69+ , ("Content-Lenght", "151")

42 , ("Server", "Mighttpd/2.5.8")

70 , ("Server", "Mighttpd/2.5.8")

43 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

71 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

44 , ("Content-Type", "text/html")

72 , ("Content-Type", "text/html")

45 ]

73 ]

46

74

47composedHeader :: ByteString

75composedHeader :: ByteString

48−composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

76+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

warp/test/ResponseSpec.hs+21−11

@@ -10,9 +10,13 @@ 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)

14+import System.IO (hClose, hFlush)

14import Test.Hspec

15import Test.Hspec

15

16

17+-- import HTTP

18+import RunSpec (connectTo)

19+

16main :: IO ()

20main :: IO ()

17main = hspec spec

21main = hspec spec

18

22

@@ -20,13 +24,16 @@ testRange :: S.ByteString -- ^ range value

20 -> String -- ^ expected output

24 -> String -- ^ expected output

21 -> Maybe String -- ^ expected content-range value

25 -> Maybe String -- ^ expected content-range value

22 -> Spec

26 -> Spec

23−testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

27+testRange range out crange = it title $ withApp defaultSettings app $ \port -> do

28+ handle <- connectTo "127.0.0.1" port

24− msWrite ms "GET / HTTP/1.0\r\n"

29+ S.hPutStr handle "GET / HTTP/1.0\r\n"

25− msWrite ms "Range: bytes="

30+ S.hPutStr handle "Range: bytes="

26− msWrite ms range

31+ S.hPutStr handle range

27− msWrite ms "\r\n\r\n"

32+ S.hPutStr handle "\r\n\r\n"

33+ hFlush handle

28 threadDelay 10000

34 threadDelay 10000

29− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

35+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

36+ hClose handle

30 last bss `shouldBe` out

37 last bss `shouldBe` out

31 let hs = mapMaybe toHeader bss

38 let hs = mapMaybe toHeader bss

32 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

39 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

@@ -44,10 +51,13 @@ testPartial :: Integer -- ^ file size

44 -> Integer -- ^ byte count

51 -> Integer -- ^ byte count

45 -> String -- ^ expected output

52 -> String -- ^ expected output

46 -> Spec

53 -> Spec

47−testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

54+testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do

55+ handle <- connectTo "127.0.0.1" port

48− msWrite ms "GET / HTTP/1.0\r\n\r\n"

56+ S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"

57+ hFlush handle

49 threadDelay 10000

58 threadDelay 10000

50− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

59+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

60+ hClose handle

51 out `shouldBe` last bss

61 out `shouldBe` last bss

52 let hs = mapMaybe toHeader bss

62 let hs = mapMaybe toHeader bss

53 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

63 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

@@ -83,7 +93,7 @@ spec = do

83 it "discards empty lines" $ do

93 it "discards empty lines" $ do

84 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

94 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

85

95

86− context "when sanitizing single occurrences of \n" $ do

96+ context "when sanitizing single occurences of \n" $ do

87 it "replaces \n with \r\n" $ do

97 it "replaces \n with \r\n" $ do

88 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

98 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

89

99

warp/test/RunSpec.hs+82−125

@@ -1,16 +1,16 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3

4

4−module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where

5+module RunSpec (main, spec, withApp, connectTo) where

5

6

6import Control.Concurrent (forkIO, killThread, threadDelay)

7import Control.Concurrent (forkIO, killThread, threadDelay)

7import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

8import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

8−import Control.Concurrent.STM

9import qualified Control.Exception as E

10import Control.Exception.Lifted (bracket, try, IOException, onException)

11import Control.Monad (forM_, replicateM_, unless)

12import Control.Monad.IO.Class (MonadIO, liftIO)

13−import Data.ByteString (ByteString)

13+import Data.ByteString (ByteString, hPutStr, hGetSome)

14import qualified Data.ByteString as S

15import Data.ByteString.Builder (byteString)

16import qualified Data.ByteString.Char8 as S8

@@ -21,8 +21,8 @@ import Network.HTTP.Types

21import Network.Socket

22import Network.Socket.ByteString (sendAll)

23import Network.Wai hiding (responseHeaders)

24−import Network.Wai.Internal (getRequestBodyChunk)

25import Network.Wai.Handler.Warp

24import Network.Wai.Handler.Warp

25+import System.IO (hFlush, hClose, Handle, IOMode(..))

26import System.IO.Unsafe (unsafePerformIO)

27import System.Timeout (timeout)

28import Test.Hspec

@@ -35,51 +35,13 @@ main = hspec spec

35type Counter = I.IORef (Either String Int)

36type CounterApplication = Counter -> Application

37

38−data MySocket = MySocket

38+connectTo :: HostName -> Int -> IO Handle

39− { msSocket :: !Socket

39+connectTo host port = do

40− , msBuffer :: !(I.IORef ByteString)

40+ let hints = defaultHints { addrSocketType = Stream }

41− }

41+ addr:_ <- getAddrInfo (Just hints) (Just host) (Just $ show port)

42−

42+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

43−msWrite :: MySocket -> ByteString -> IO ()

43+ connect sock $ addrAddress addr

44−msWrite ms bs = sendAll (msSocket ms) bs

44+ socketToHandle sock ReadWriteMode

45−

46−msRead :: MySocket -> Int -> IO ByteString

47−msRead (MySocket s ref) expected = do

48− bs <- I.readIORef ref

49− inner (bs:) (S.length bs)

50− where

51− inner front total =

52− case compare total expected of

53− EQ -> do

54− I.writeIORef ref mempty

55− pure $ S.concat $ front []

56− GT -> do

57− let bs = S.concat $ front []

58− (x, y) = S.splitAt expected bs

59− I.writeIORef ref y

60− pure x

61− LT -> do

62− bs <- safeRecv s 4096

63− if S.null bs

64− then do

65− I.writeIORef ref mempty

66− pure $ S.concat $ front []

67− else inner (front . (bs:)) (total + S.length bs)

68−

69−msClose :: MySocket -> IO ()

70−msClose = Network.Socket.close . msSocket

71−

72−connectTo :: Int -> IO MySocket

73−connectTo port = do

74− s <- fst <$> getSocketTCP "127.0.0.1" port

75− ref <- I.newIORef mempty

76− return MySocket {

77− msSocket = s

78− , msBuffer = ref

79− }

80−

81−withMySocket :: (MySocket -> IO a) -> Int -> IO a

82−withMySocket body port = bracket (connectTo port) msClose body

83

45

84incr :: MonadIO m => Counter -> m ()

46incr :: MonadIO m => Counter -> m ()

85incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

47incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

@@ -92,7 +54,7 @@ err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

92

54

93readBody :: CounterApplication

55readBody :: CounterApplication

94readBody icount req f = do

56readBody icount req f = do

95− body <- consumeBody $ getRequestBodyChunk req

57+ body <- consumeBody $ requestBody req

96 case () of

58 case () of

97 ()

59 ()

98 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

60 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

@@ -113,8 +75,8 @@ ignoreBody icount req f = do

113

75

114doubleConnect :: CounterApplication

76doubleConnect :: CounterApplication

115doubleConnect icount req f = do

77doubleConnect icount req f = do

116− _ <- consumeBody $ getRequestBodyChunk req

78+ _ <- consumeBody $ requestBody req

117− _ <- consumeBody $ getRequestBodyChunk req

79+ _ <- consumeBody $ requestBody req

118 incr icount

80 incr icount

119 f $ responseLBS status200 [] "double connect"

81 f $ responseLBS status200 [] "double connect"

120

82

@@ -143,13 +105,7 @@ withApp settings app f = do

143 bracket

105 bracket

144 (forkIO $ runSettings settings' app `onException` putMVar baton ())

106 (forkIO $ runSettings settings' app `onException` putMVar baton ())

145 killThread

107 killThread

146− (const $ do

147− takeMVar baton

108+ (const $ takeMVar baton >> f port)

148− -- use timeout to make sure we don't take too long

149− mres <- timeout (60 * 1000 * 1000) (f port)

150− case mres of

151− Nothing -> error "Timeout triggered, too slow!"

152− Just a -> pure a)

153

109

154runTest :: Int -- ^ expected number of requests

110runTest :: Int -- ^ expected number of requests

155 -> CounterApplication

111 -> CounterApplication

@@ -157,9 +113,10 @@ runTest :: Int -- ^ expected number of requests

157 -> IO ()

113 -> IO ()

158runTest expected app chunks = do

114runTest expected app chunks = do

159 ref <- I.newIORef (Right 0)

115 ref <- I.newIORef (Right 0)

160− withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

116+ withApp defaultSettings (app ref) $ \port -> do

117+ handle <- connectTo "127.0.0.1" port

161− forM_ chunks $ \chunk -> msWrite ms chunk

118+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle

162− _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

119+ _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096

163 res <- I.readIORef ref

120 res <- I.readIORef ref

164 case res of

121 case res of

165 Left s -> error s

122 Left s -> error s

@@ -174,9 +131,11 @@ runTerminateTest :: InvalidRequest

174runTerminateTest expected input = do

131runTerminateTest expected input = do

175 ref <- I.newIORef Nothing

132 ref <- I.newIORef Nothing

176 let onExc _ = I.writeIORef ref . Just

133 let onExc _ = I.writeIORef ref . Just

177− withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

134+ withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

178− msWrite ms input

135+ handle <- connectTo "127.0.0.1" port

179− msClose ms -- explicitly

136+ hPutStr handle input

137+ hFlush handle

138+ hClose handle

180 threadDelay 1000

139 threadDelay 1000

181 res <- I.readIORef ref

140 res <- I.readIORef ref

182 show res `shouldBe` show (Just expected)

141 show res `shouldBe` show (Just expected)

@@ -247,11 +206,14 @@ spec = do

247 let app req f = do

206 let app req f = do

248 liftIO $ I.writeIORef iheaders $ requestHeaders req

207 liftIO $ I.writeIORef iheaders $ requestHeaders req

249 f $ responseLBS status200 [] ""

208 f $ responseLBS status200 [] ""

250− withApp defaultSettings app $ withMySocket $ \ms -> do

209+ withApp defaultSettings app $ \port -> do

210+ handle <- connectTo "127.0.0.1" port

251 let input = S.concat

211 let input = S.concat

252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

212 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

253 ]

213 ]

254− msWrite ms input

214+ hPutStr handle input

215+ hFlush handle

216+ hClose handle

255 threadDelay 1000

217 threadDelay 1000

256 headers <- I.readIORef iheaders

218 headers <- I.readIORef iheaders

257 headers `shouldBe`

219 headers `shouldBe`

@@ -262,11 +224,14 @@ spec = do

262 let app req f = do

224 let app req f = do

263 liftIO $ I.writeIORef iheaders $ requestHeaders req

225 liftIO $ I.writeIORef iheaders $ requestHeaders req

264 f $ responseLBS status200 [] ""

226 f $ responseLBS status200 [] ""

265− withApp defaultSettings app $ withMySocket $ \ms -> do

227+ withApp defaultSettings app $ \port -> do

228+ handle <- connectTo "127.0.0.1" port

266 let input = S.concat

229 let input = S.concat

267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

230 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

268 ]

231 ]

269− msWrite ms input

232+ hPutStr handle input

233+ hFlush handle

234+ hClose handle

270 threadDelay 1000

235 threadDelay 1000

271 headers <- I.readIORef iheaders

236 headers <- I.readIORef iheaders

272 headers `shouldBe`

237 headers `shouldBe`

@@ -275,24 +240,23 @@ spec = do

275

240

276 describe "chunked bodies" $ do

241 describe "chunked bodies" $ do

277 it "works" $ do

242 it "works" $ do

278− countVar <- newTVarIO (0 :: Int)

279 ifront <- I.newIORef id

243 ifront <- I.newIORef id

280 let app req f = do

244 let app req f = do

281− bss <- consumeBody $ getRequestBodyChunk req

245+ bss <- consumeBody $ requestBody req

282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

246 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

283− atomically $ modifyTVar countVar (+ 1)

284 f $ responseLBS status200 [] ""

247 f $ responseLBS status200 [] ""

285− withApp defaultSettings app $ withMySocket $ \ms -> do

248+ withApp defaultSettings app $ \port -> do

249+ handle <- connectTo "127.0.0.1" port

286 let input = S.concat

250 let input = S.concat

287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

251 [ "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"

252 , "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"

253 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

290 , "b\r\nHello World\r\n0\r\n\r\n"

254 , "b\r\nHello World\r\n0\r\n\r\n"

291 ]

255 ]

292− msWrite ms input

256+ hPutStr handle input

293− atomically $ do

257+ hFlush handle

294− count <- readTVar countVar

258+ hClose handle

295− check $ count == 2

259+ threadDelay 1000

296 front <- I.readIORef ifront

260 front <- I.readIORef ifront

297 front [] `shouldBe`

261 front [] `shouldBe`

298 [ "Hello World\nBye"

262 [ "Hello World\nBye"

@@ -300,44 +264,38 @@ spec = do

300 ]

264 ]

301 it "lots of chunks" $ do

265 it "lots of chunks" $ do

302 ifront <- I.newIORef id

266 ifront <- I.newIORef id

303− countVar <- newTVarIO (0 :: Int)

304 let app req f = do

267 let app req f = do

305− bss <- consumeBody $ getRequestBodyChunk req

268+ bss <- consumeBody $ requestBody req

306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

269 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307− atomically $ modifyTVar countVar (+ 1)

308 f $ responseLBS status200 [] ""

270 f $ responseLBS status200 [] ""

309− withApp defaultSettings app $ withMySocket $ \ms -> do

271+ withApp defaultSettings app $ \port -> do

272+ handle <- connectTo "127.0.0.1" port

310 let input = concat $ replicate 2 $

273 let input = concat $ replicate 2 $

311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

274 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

312 (replicate 50 "5\r\n12345\r\n") ++

275 (replicate 50 "5\r\n12345\r\n") ++

313 ["0\r\n\r\n"]

276 ["0\r\n\r\n"]

314− mapM_ (msWrite ms) input

277+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input

315− atomically $ do

278+ hClose handle

316− count <- readTVar countVar

279+ threadDelay 100000 -- FIXME why does this delay need to be so high?

317− check $ count == 2

318 front <- I.readIORef ifront

280 front <- I.readIORef ifront

319 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

281 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

320−-- For some reason, the following test on Windows causes the socket

321−-- to be killed prematurely. Worth investigating in the future if possible.

322 it "in chunks" $ do

282 it "in chunks" $ do

323 ifront <- I.newIORef id

283 ifront <- I.newIORef id

324− countVar <- newTVarIO (0 :: Int)

325 let app req f = do

284 let app req f = do

326− bss <- consumeBody $ getRequestBodyChunk req

285+ bss <- consumeBody $ requestBody req

327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

286 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

328− atomically $ modifyTVar countVar (+ 1)

329 f $ responseLBS status200 [] ""

287 f $ responseLBS status200 [] ""

330− withApp defaultSettings app $ withMySocket $ \ms -> do

288+ withApp defaultSettings app $ \port -> do

289+ handle <- connectTo "127.0.0.1" port

331 let input = S.concat

290 let input = S.concat

332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

291 [ "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"

292 , "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"

293 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

335 , "b\r\nHello World\r\n0\r\n\r\n"

294 , "b\r\nHello World\r\n0\r\n\r\n"

336 ]

295 ]

337− mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

296+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input

338− atomically $ do

297+ hClose handle

339− count <- readTVar countVar

298+ threadDelay 1000

340− check $ count == 2

341 front <- I.readIORef ifront

299 front <- I.readIORef ifront

342 front [] `shouldBe`

300 front [] `shouldBe`

343 [ "Hello World\nBye"

301 [ "Hello World\nBye"

@@ -346,7 +304,7 @@ spec = do

346 it "timeout in request body" $ do

304 it "timeout in request body" $ do

347 ifront <- I.newIORef id

305 ifront <- I.newIORef id

348 let app req f = do

306 let app req f = do

349− bss <- (consumeBody $ getRequestBodyChunk req) `onException`

307+ bss <- (consumeBody $ requestBody req) `onException`

350 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

308 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

351 liftIO $ threadDelay 4000000 `E.catch` \e -> do

309 liftIO $ threadDelay 4000000 `E.catch` \e -> do

352 I.atomicModifyIORef ifront (\front ->

310 I.atomicModifyIORef ifront (\front ->

@@ -355,18 +313,20 @@ spec = do

355 E.throwIO (e :: E.SomeException)

313 E.throwIO (e :: E.SomeException)

356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

314 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

357 f $ responseLBS status200 [] ""

315 f $ responseLBS status200 [] ""

358− withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

316+ withApp (setTimeout 1 defaultSettings) app $ \port -> do

359 let bs1 = S.replicate 2048 88

317 let bs1 = S.replicate 2048 88

360 bs2 = "This is short"

318 bs2 = "This is short"

361 bs = S.append bs1 bs2

319 bs = S.append bs1 bs2

320+ handle <- connectTo "127.0.0.1" port

362− msWrite ms "POST / HTTP/1.1\r\n"

321+ hPutStr handle "POST / HTTP/1.1\r\n"

363− msWrite ms "content-length: "

322+ hPutStr handle "content-length: "

364− msWrite ms $ S8.pack $ show $ S.length bs

323+ hPutStr handle $ S8.pack $ show $ S.length bs

365− msWrite ms "\r\n\r\n"

324+ hPutStr handle "\r\n\r\n"

366 threadDelay 100000

325 threadDelay 100000

367− msWrite ms bs1

326+ hPutStr handle bs1

368 threadDelay 100000

327 threadDelay 100000

369− msWrite ms bs2

328+ hPutStr handle bs2

329+ hClose handle

370 threadDelay 5000000

330 threadDelay 5000000

371 front <- I.readIORef ifront

331 front <- I.readIORef ifront

372 S.concat (front []) `shouldBe` bs

332 S.concat (front []) `shouldBe` bs

@@ -382,42 +342,39 @@ spec = do

382 loop

342 loop

383 loop

343 loop

384 doubleBS = S.concatMap $ \w -> S.pack [w, w]

344 doubleBS = S.concatMap $ \w -> S.pack [w, w]

385− withApp defaultSettings app $ withMySocket $ \ms -> do

345+ withApp defaultSettings app $ \port -> do

346+ handle <- connectTo "127.0.0.1" port

386− msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

347+ hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"

348+ hFlush handle

387− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

349+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")

388− msWrite ms "67890"

350+ hPutStr handle "67890"

351+ hFlush handle

389− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")

352+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")

353+

390 it "only one date and server header" $ do

354 it "only one date and server header" $ do

391 let app _ f = f $ responseLBS status200

355 let app _ f = f $ responseLBS status200

392 [ ("server", "server")

356 [ ("server", "server")

393 , ("date", "date")

357 , ("date", "date")

394 ] ""

358 ] ""

395− getValues key = map snd

396− . filter (\(key', _) -> key == key')

397− . responseHeaders

398 withApp defaultSettings app $ \port -> do

359 withApp defaultSettings app $ \port -> do

399 res <- sendGET $ "http://127.0.0.1:" ++ show port

360 res <- sendGET $ "http://127.0.0.1:" ++ show port

400− getValues hServer res `shouldBe` ["server"]

361+ getHeaderValue hServer (responseHeaders res) `shouldBe` Just "server"

401− getValues hDate res `shouldBe` ["date"]

362+ getHeaderValue hDate (responseHeaders res) `shouldBe` Just "date"

402

363

403 it "streaming echo #249" $ do

364 it "streaming echo #249" $ do

404− countVar <- newTVarIO (0 :: Int)

405 let app req f = f $ responseStream status200 [] $ \write _ -> do

365 let app req f = f $ responseStream status200 [] $ \write _ -> do

406− let loop = do

366+ let loop = do

407− bs <- getRequestBodyChunk req

367+ bs <- requestBody req

408 unless (S.null bs) $ do

368 unless (S.null bs) $ do

409 write $ byteString bs

369 write $ byteString bs

410− atomically $ modifyTVar countVar (+ 1)

411 loop

370 loop

412− loop

371+ loop

413− withApp defaultSettings app $ withMySocket $ \ms -> do

372+ withApp defaultSettings app $ \port -> do

373+ (sock, _addr) <- getSocketTCP "127.0.0.1" port

414− msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

374+ sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

415 threadDelay 10000

375 threadDelay 10000

416− msWrite ms "5\r\nhello\r\n0\r\n\r\n"

376+ sendAll sock "5\r\nhello\r\n0\r\n\r\n"

417− atomically $ do

418− count <- readTVar countVar

419− check $ count >= 1

420− bs <- safeRecv (msSocket ms) 4096 -- must not use msRead

377+ bs <- safeRecv sock 4096

421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

378 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

422

379

423 it "streaming response with length" $ do

380 it "streaming response with length" $ do

warp/test/WithApplicationSpec.hs+14−10

@@ -6,6 +6,8 @@ import Control.Exception

6import Network.HTTP.Types

7import Network.Wai

8import System.Environment

9+import System.IO

10+import System.IO.Silently

9import System.Process

11import System.Process

10import Test.Hspec

12import Test.Hspec

11

13

@@ -23,18 +25,20 @@ spec = do

23 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

25 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

24 output `shouldBe` "foo"

26 output `shouldBe` "foo"

25

27

26− it "does not propagate exceptions from the server to the executing thread" $ do

28+ it "does not propagate exceptions from the server to the executing thread" $

29+ hSilence [stderr] $ do

27− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

30+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

28− withApplication mkApp $ \ port -> do

31+ withApplication mkApp $ \ port -> do

29− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

32+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

30− output `shouldContain` "Something went wron"

33+ output `shouldContain` "Something went wron"

31

34

32 describe "testWithApplication" $ do

35 describe "testWithApplication" $ do

33− it "propagates exceptions from the server to the executing thread" $ do

36+ it "propagates exceptions from the server to the executing thread" $

37+ hSilence [stderr] $ do

34− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

38+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

35− (testWithApplication mkApp $ \ port -> do

39+ (testWithApplication mkApp $ \ port -> do

36− readProcess "curl" ["-s", "localhost:" ++ show port] "")

40+ readProcess "curl" ["-s", "localhost:" ++ show port] "")

37− `shouldThrow` (errorCall "foo")

41+ `shouldThrow` (errorCall "foo")

38

42

39{- The future netwrok library will not export MkSocket.

43{- The future netwrok library will not export MkSocket.

40 describe "withFreePort" $ do

44 describe "withFreePort" $ do

warp/warp.cabal+47−59

@@ -1,5 +1,5 @@

1Name: warp

2−Version: 3.3.9

2+Version: 3.2.23

3Synopsis: A fast, light-weight web server for WAI applications.

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

8Homepage: http://github.com/yesodweb/wai

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >= 1.10

11+Cabal-Version: >=1.8

12Stability: Stable

13description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.

14 For HTTP\/2, Warp supports direct and ALPN (in TLS)

@@ -42,21 +42,19 @@ Library

42 , case-insensitive >= 0.2

43 , containers

44 , ghc-prim

45− , hashable

46− , http-date

47− , http-types >= 0.12

45+ , http-types >= 0.9.1

48− , http2 >= 2.0 && < 2.1

49 , iproute >= 1.3.1

46 , iproute >= 1.3.1

47+ , http2 >= 1.6 && < 1.7

50 , simple-sendfile >= 0.2.7 && < 0.3

48 , simple-sendfile >= 0.2.7 && < 0.3

51− , stm >= 2.3

52− , streaming-commons >= 0.1.10

53− , text

54− , time-manager

55 , unix-compat >= 0.2

49 , unix-compat >= 0.2

56− , vault >= 0.3

57 , wai >= 3.2 && < 3.3

50 , wai >= 3.2 && < 3.3

51+ , text

52+ , streaming-commons >= 0.1.10

53+ , vault >= 0.3

54+ , stm >= 2.3

58 , word8

55 , word8

59− , x509

56+ , hashable

57+ , http-date

60 if impl(ghc < 8)

58 if impl(ghc < 8)

61 Build-Depends: semigroups

59 Build-Depends: semigroups

62 if flag(network-bytestring)

60 if flag(network-bytestring)

@@ -75,11 +73,15 @@ Library

75 Network.Wai.Handler.Warp.FileInfoCache

73 Network.Wai.Handler.Warp.FileInfoCache

76 Network.Wai.Handler.Warp.HashMap

74 Network.Wai.Handler.Warp.HashMap

77 Network.Wai.Handler.Warp.HTTP2

75 Network.Wai.Handler.Warp.HTTP2

76+ Network.Wai.Handler.Warp.HTTP2.EncodeFrame

78 Network.Wai.Handler.Warp.HTTP2.File

77 Network.Wai.Handler.Warp.HTTP2.File

79− Network.Wai.Handler.Warp.HTTP2.PushPromise

78+ Network.Wai.Handler.Warp.HTTP2.HPACK

79+ Network.Wai.Handler.Warp.HTTP2.Manager

80+ Network.Wai.Handler.Warp.HTTP2.Receiver

80 Network.Wai.Handler.Warp.HTTP2.Request

81 Network.Wai.Handler.Warp.HTTP2.Request

81− Network.Wai.Handler.Warp.HTTP2.Response

82+ Network.Wai.Handler.Warp.HTTP2.Sender

82 Network.Wai.Handler.Warp.HTTP2.Types

83 Network.Wai.Handler.Warp.HTTP2.Types

84+ Network.Wai.Handler.Warp.HTTP2.Worker

83 Network.Wai.Handler.Warp.Header

85 Network.Wai.Handler.Warp.Header

84 Network.Wai.Handler.Warp.IO

86 Network.Wai.Handler.Warp.IO

85 Network.Wai.Handler.Warp.Imports

87 Network.Wai.Handler.Warp.Imports

@@ -93,6 +95,7 @@ Library

93 Network.Wai.Handler.Warp.Run

95 Network.Wai.Handler.Warp.Run

94 Network.Wai.Handler.Warp.SendFile

96 Network.Wai.Handler.Warp.SendFile

95 Network.Wai.Handler.Warp.Settings

97 Network.Wai.Handler.Warp.Settings

98+ Network.Wai.Handler.Warp.Timeout

96 Network.Wai.Handler.Warp.Types

99 Network.Wai.Handler.Warp.Types

97 Network.Wai.Handler.Warp.Windows

100 Network.Wai.Handler.Warp.Windows

98 Network.Wai.Handler.Warp.WithApplication

101 Network.Wai.Handler.Warp.WithApplication

@@ -109,23 +112,14 @@ Library

109 else

112 else

110 Build-Depends: unix

113 Build-Depends: unix

111 Other-modules: Network.Wai.Handler.Warp.MultiMap

114 Other-modules: Network.Wai.Handler.Warp.MultiMap

112− if impl(ghc >= 8)

113− Default-Extensions: Strict StrictData

114− Default-Language: Haskell2010

115

116Test-Suite doctest

117− buildable: False

118 Type: exitcode-stdio-1.0

117 Type: exitcode-stdio-1.0

119 HS-Source-Dirs: test

118 HS-Source-Dirs: test

120 Ghc-Options: -threaded -Wall

119 Ghc-Options: -threaded -Wall

121 Main-Is: doctests.hs

120 Main-Is: doctests.hs

122 Build-Depends: base >= 4.8 && < 5

121 Build-Depends: base >= 4.8 && < 5

123 , doctest >= 0.10.1

122 , doctest >= 0.10.1

124− if os(windows)

125− Buildable: False

126− if impl(ghc >= 8)

127− Default-Extensions: Strict StrictData

128− Default-Language: Haskell2010

129

123

130Test-Suite spec

124Test-Suite spec

131 Main-Is: Spec.hs

125 Main-Is: Spec.hs

@@ -151,11 +145,15 @@ Test-Suite spec

151 Network.Wai.Handler.Warp.File

145 Network.Wai.Handler.Warp.File

152 Network.Wai.Handler.Warp.FileInfoCache

146 Network.Wai.Handler.Warp.FileInfoCache

153 Network.Wai.Handler.Warp.HTTP2

147 Network.Wai.Handler.Warp.HTTP2

148+ Network.Wai.Handler.Warp.HTTP2.EncodeFrame

154 Network.Wai.Handler.Warp.HTTP2.File

149 Network.Wai.Handler.Warp.HTTP2.File

155− Network.Wai.Handler.Warp.HTTP2.PushPromise

150+ Network.Wai.Handler.Warp.HTTP2.HPACK

151+ Network.Wai.Handler.Warp.HTTP2.Manager

152+ Network.Wai.Handler.Warp.HTTP2.Receiver

156 Network.Wai.Handler.Warp.HTTP2.Request

153 Network.Wai.Handler.Warp.HTTP2.Request

157− Network.Wai.Handler.Warp.HTTP2.Response

154+ Network.Wai.Handler.Warp.HTTP2.Sender

158 Network.Wai.Handler.Warp.HTTP2.Types

155 Network.Wai.Handler.Warp.HTTP2.Types

156+ Network.Wai.Handler.Warp.HTTP2.Worker

159 Network.Wai.Handler.Warp.HashMap

157 Network.Wai.Handler.Warp.HashMap

160 Network.Wai.Handler.Warp.Header

158 Network.Wai.Handler.Warp.Header

161 Network.Wai.Handler.Warp.IO

159 Network.Wai.Handler.Warp.IO

@@ -171,62 +169,57 @@ Test-Suite spec

171 Network.Wai.Handler.Warp.Run

169 Network.Wai.Handler.Warp.Run

172 Network.Wai.Handler.Warp.SendFile

170 Network.Wai.Handler.Warp.SendFile

173 Network.Wai.Handler.Warp.Settings

171 Network.Wai.Handler.Warp.Settings

172+ Network.Wai.Handler.Warp.Timeout

174 Network.Wai.Handler.Warp.Types

173 Network.Wai.Handler.Warp.Types

175− Network.Wai.Handler.Warp.Windows

176 Network.Wai.Handler.Warp.WithApplication

174 Network.Wai.Handler.Warp.WithApplication

177 Paths_warp

175 Paths_warp

178

176

179 Hs-Source-Dirs: test, .

177 Hs-Source-Dirs: test, .

180 Type: exitcode-stdio-1.0

178 Type: exitcode-stdio-1.0

181

179

182− Ghc-Options: -Wall -threaded

180+ Ghc-Options: -Wall

183 Build-Depends: base >= 4.8 && < 5

181 Build-Depends: base >= 4.8 && < 5

184− , HUnit

185− , QuickCheck

186 , array

182 , array

187− , async

188 , auto-update

183 , auto-update

189 , bsb-http-chunked < 0.1

184 , bsb-http-chunked < 0.1

190 , bytestring >= 0.9.1.4

185 , bytestring >= 0.9.1.4

191 , case-insensitive >= 0.2

186 , case-insensitive >= 0.2

192− , containers

193− , directory

194 , ghc-prim

187 , ghc-prim

195− , hashable

196− , hspec >= 1.3

197 , http-client

188 , http-client

198− , http-date

199− , http-types >= 0.12

189+ , http-types >= 0.8.5

200− , http2 >= 2.0 && < 2.1

201 , iproute >= 1.3.1

190 , iproute >= 1.3.1

202 , lifted-base >= 0.1

191 , lifted-base >= 0.1

203− , network

204− , process

205 , simple-sendfile >= 0.2.4 && < 0.3

192 , simple-sendfile >= 0.2.4 && < 0.3

206− , stm >= 2.3

193+ , transformers >= 0.2.2

207− , streaming-commons >= 0.1.10

208− , text

209− , time

210− , time-manager

211 , unix-compat >= 0.2

194 , unix-compat >= 0.2

212− , vault

213 , wai >= 3.2 && < 3.3

195 , wai >= 3.2 && < 3.3

196+ , network

197+ , HUnit

198+ , QuickCheck

199+ , hspec >= 1.3

200+ , time

201+ , text

202+ , streaming-commons >= 0.1.10

203+ , silently

204+ , async

205+ , vault

206+ , stm >= 2.3

207+ , directory

208+ , process

209+ , containers

210+ , http2 >= 1.6 && < 1.7

214 , word8

211 , word8

215− , x509

212+ , hashable

213+ , http-date

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

219− , transformers

220

217

221 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

218 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

222 Cpp-Options: -DSENDFILEFD

219 Cpp-Options: -DSENDFILEFD

223 Build-Depends: unix

220 Build-Depends: unix

224 if os(windows)

221 if os(windows)

225− Cpp-Options: -DWINDOWS

222+ Cpp-Options: -DWINDOWS

226− Build-Depends: time

227− if impl(ghc >= 8)

228− Default-Extensions: Strict StrictData

229− Default-Language: Haskell2010

230

223

231Benchmark parser

224Benchmark parser

232 Type: exitcode-stdio-1.0

225 Type: exitcode-stdio-1.0

@@ -237,6 +230,7 @@ Benchmark parser

237 Network.Wai.Handler.Warp.HashMap

230 Network.Wai.Handler.Warp.HashMap

238 Network.Wai.Handler.Warp.Imports

231 Network.Wai.Handler.Warp.Imports

239 Network.Wai.Handler.Warp.MultiMap

232 Network.Wai.Handler.Warp.MultiMap

233+ Network.Wai.Handler.Warp.Timeout

240 Network.Wai.Handler.Warp.Types

234 Network.Wai.Handler.Warp.Types

241 HS-Source-Dirs: bench .

235 HS-Source-Dirs: bench .

242 Build-Depends: base >= 4.8 && < 5

236 Build-Depends: base >= 4.8 && < 5

@@ -249,9 +243,7 @@ Benchmark parser

249 , http-types

243 , http-types

250 , network

244 , network

251 , network

245 , network

252− , time-manager

253 , unix-compat

246 , unix-compat

254− , x509

255 if impl(ghc < 8)

247 if impl(ghc < 8)

256 Build-Depends: semigroups

248 Build-Depends: semigroups

257

249

@@ -259,11 +251,7 @@ Benchmark parser

259 Cpp-Options: -DSENDFILEFD

251 Cpp-Options: -DSENDFILEFD

260 Build-Depends: unix

252 Build-Depends: unix

261 if os(windows)

253 if os(windows)

262− Cpp-Options: -DWINDOWS

254+ Cpp-Options: -DWINDOWS

263− Build-Depends: time

264− if impl(ghc >= 8)

265− Default-Extensions: Strict StrictData

266− Default-Language: Haskell2010

267

255

268Source-Repository head

256Source-Repository head

269 Type: git

257 Type: git