master..59ea282 · 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−1

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

9cabal.sandbox.config

10.stack-work/

11*~

12−stack*.yaml.lock

.travis.ymlnew file+251

@@ -0,0 +1,251 @@

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+# Do not choose a language; we provide our own build tools.

15+language: generic

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+ - $TRAVIS_BUILD_DIR/.stack-work

24+

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

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

27+# of those below.

28+#

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

30+# cache file per set of arguments.

31+#

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

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

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

35+matrix:

36+ include:

37+ # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:

38+ # https://github.com/hvr/multi-ghc-travis

39+ #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7

40+ # compiler: ": #GHC 7.0.4"

41+ # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

42+ #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7

43+ # compiler: ": #GHC 7.2.2"

44+ # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

45+ #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7

46+ # compiler: ": #GHC 7.4.2"

47+ # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

48+ #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7

49+ # compiler: ": #GHC 7.6.3"

50+ # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

51+ #- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7

52+ # compiler: ": #GHC 7.8.4"

53+ # addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

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

55+ compiler: ": #GHC 7.10.3"

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

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

58+ compiler: ": #GHC 8.0.2"

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

60+ - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7

61+ compiler: ": #GHC 8.2.2"

62+ addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

63+ - env: BUILD=cabal GHCVER=8.4.3 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7

64+ compiler: ": #GHC 8.4.3"

65+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}

66+

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

68+ # see below.

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

70+ compiler: ": #GHC HEAD"

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

72+

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

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

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

76+ # compiler: ": #stack default"

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

78+

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

80+ # compiler: ": #stack 7.8.4"

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

82+

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

84+ # compiler: ": #stack 7.10.2"

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

86+

87+ - env: BUILD=stack ARGS="--resolver lts-6" STACK_YAML="stack-lts-6.yaml"

88+ compiler: ": #stack 7.10.3"

89+ addons: {apt: {packages: [libgmp-dev]}}

90+

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

92+ # compiler: ": #stack 8.0.1"

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

94+

95+ - env: BUILD=stack ARGS="--resolver lts-9" STACK_YAML="stack-lts-9.yaml"

96+ compiler: ": #stack 8.0.2"

97+ addons: {apt: {packages: [libgmp-dev]}}

98+

99+ - env: BUILD=stack ARGS="--resolver lts-11" STACK_YAML="stack-lts-11.yaml"

100+ compiler: ": #stack 8.2.2"

101+ addons: {apt: {packages: [libgmp-dev]}}

102+

103+ - env: BUILD=stack ARGS="--resolver lts-12" STACK_YAML="stack-lts-12.yaml"

104+ compiler: ": #stack 8.4.3"

105+ addons: {apt: {packages: [libgmp-dev]}}

106+

107+ # Nightly builds are allowed to fail

108+ - env: BUILD=stack ARGS="--resolver nightly" STACK_YAML="stack-nightly.yaml"

109+ compiler: ": #stack nightly"

110+ addons: {apt: {packages: [libgmp-dev]}}

111+

112+ # Build on macOS in addition to Linux

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

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

115+ # os: osx

116+

117+ # Travis includes an macOS which is incompatible with GHC 7.8.4

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

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

120+ # os: osx

121+

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

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

124+ # os: osx

125+

126+ - env: BUILD=stack ARGS="--resolver lts-6" STACK_YAML="stack-lts-6.yaml"

127+ compiler: ": #stack 7.10.3 osx"

128+ os: osx

129+

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

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

132+ # os: osx

133+

134+ - env: BUILD=stack ARGS="--resolver lts-9" STACK_YAML="stack-lts-9.yaml"

135+ compiler: ": #stack 8.0.2 osx"

136+ os: osx

137+

138+ - env: BUILD=stack ARGS="--resolver lts-11" STACK_YAML="stack-lts-11.yaml"

139+ compiler: ": #stack 8.2.2 osx"

140+ os: osx

141+

142+ - env: BUILD=stack ARGS="--resolver lts-12" STACK_YAML="stack-lts-12.yaml"

143+ compiler: ": #stack 8.4.3 osx"

144+ os: osx

145+

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

147+ compiler: ": #stack nightly osx"

148+ os: osx

149+

150+ allow_failures:

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

152+ #- env: BUILD=stack ARGS="--resolver nightly"

153+

154+before_install:

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

156+- unset CC

157+

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

159+- CABALARGS=""

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

161+

162+# Download and unpack the stack executable

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

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

165+- |

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

167+ then

168+ travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin

169+ else

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

171+ fi

172+

173+ # Use the more reliable S3 mirror of Hackage

174+ mkdir -p $HOME/.cabal

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

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

177+

178+

179+install:

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

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

182+- |

183+ set -ex

184+ case "$BUILD" in

185+ stack)

186+ # Avoid out of memory condition

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

188+

189+ # Add in extra-deps for older snapshots, as necessary

190+ #

191+ # This is disabled by default, as relying on the solver like this can

192+ # make builds unreliable. Instead, if you have this situation, it's

193+ # recommended that you maintain multiple stack-lts-X.yaml files.

194+

195+ #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \

196+ # stack --no-terminal $ARGS build cabal-install && \

197+ # stack --no-terminal $ARGS solver --update-config)

198+

199+ # Build the dependencies

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

201+ ;;

202+ cabal)

203+ cabal --version

204+ travis_retry cabal update

205+

206+ # Get the list of packages from the stack.yaml file. Note that

207+ # this will also implicitly run hpack as necessary to generate

208+ # the .cabal files needed by cabal-install.

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

210+

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

212+ # we can't build just dependencies

213+ #

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

215+ ;;

216+ esac

217+ set +ex

218+

219+script:

220+- |

221+ set -ex

222+ case "$BUILD" in

223+ stack)

224+ stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps

225+ ;;

226+ cabal)

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

228+

229+ ORIGDIR=$(pwd)

230+ for dir in $PACKAGES

231+ do

232+ cd $dir

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

234+ cabal sdist

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

236+ SRC_TGZ=$PKGVER.tar.gz

237+ cd dist

238+ tar zxfv "$SRC_TGZ"

239+ cd "$PKGVER"

240+ cabal configure --enable-tests --ghc-options -O0

241+ cabal build

242+ if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then

243+ cabal test

244+ else

245+ cabal test --show-details=streaming --log=/dev/stdout

246+ fi

247+ cd $ORIGDIR

248+ done

249+ ;;

250+ esac

251+ 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)

appveyor.ymlnew file+37

@@ -0,0 +1,37 @@

1+build: off

2+

3+before_test:

4+# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found

5+- set PATH=C:\Program Files\Git\mingw64\bin;%PATH%

6+

7+- curl -sS -ostack.zip -L --insecure https://get.haskellstack.org/stable/windows-x86_64.zip

8+- 7z x stack.zip stack.exe

9+

10+clone_folder: "c:\\stack"

11+environment:

12+ global:

13+ STACK_ROOT: "c:\\sr"

14+

15+ # Override the temp directory to avoid sed escaping issues

16+ # See https://github.com/haskell/cabal/issues/5386

17+ TMP: "c:\\tmp"

18+

19+ matrix:

20+ #- ARGS: ""

21+ #- ARGS: "--resolver lts-2"

22+ #- ARGS: "--resolver lts-3"

23+ - ARGS: "--stack-yaml stack-lts-6.yaml"

24+ #- ARGS: "--resolver lts-7"

25+ - ARGS: "--stack-yaml stack-lts-9.yaml"

26+ - ARGS: "--stack-yaml stack-lts-11.yaml"

27+ - ARGS: "--stack-yaml stack-lts-12.yaml"

28+ #- ARGS: "--resolver nightly"

29+

30+test_script:

31+

32+# Install toolchain, but do it silently due to lots of output

33+- stack %ARGS% setup > nul

34+

35+# The ugly echo "" hack is to avoid complaints about 0 being an invalid file

36+# descriptor

37+- echo "" | stack %ARGS% --no-terminal test

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

stack-lts-11.yaml+6−6

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

9- ./wai-app-static

10- ./wai-websockets

11- ./wai-conduit

12−- ./time-manager

13flags:

12flags:

14 wai-extra:

13 wai-extra:

15 build-example: true

14 build-example: true

16extra-deps:

15extra-deps:

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

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

18−- http2-2.0.0

19−- network-byte-order-0.1.1.0

20−- tls-1.5.3

21−- tls-session-manager-0.0.4

22−- x509-1.7.5

23nix:

17nix:

24 enable: false

18 enable: false

25 packages:

19 packages:

26 - fcgi

20 - fcgi

27 - zlib

21 - zlib

22+image:

23+ containers:

24+ - base: "fpco/pid1"

25+ name: "yesodweb/warp"

26+ executables:

27+ - warp

stack-lts-12.yaml+6−7

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

9- ./wai-app-static

10- ./wai-websockets

11- ./wai-conduit

12−- ./time-manager

13flags:

12flags:

14 wai-extra:

13 wai-extra:

15 build-example: true

14 build-example: true

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

18 packages:

17 packages:

19 - fcgi

18 - fcgi

20 - zlib

19 - zlib

21−extra-deps:

20+image:

22−- http2-2.0.0

21+ containers:

23−- network-byte-order-0.1.1.0

22+ - base: "fpco/pid1"

24−- tls-1.5.3

23+ name: "yesodweb/warp"

25−- tls-session-manager-0.0.4

24+ executables:

26−- x509-1.7.5

25+ - warp

stack-lts-6.yamlnew file+31

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

1+resolver: lts-6.35

2+packages:

3+- ./auto-update

4+- ./mime-types

5+- ./wai

6+- ./wai-extra

7+- ./warp

8+- ./warp-tls

9+- ./wai-app-static

10+- ./wai-websockets

11+- ./wai-conduit

12+extra-deps:

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

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

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

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

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

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

19+- basement-0.0.7@rev:0

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

21+nix:

22+ enable: false

23+ packages:

24+ - fcgi

25+ - zlib

26+image:

27+ containers:

28+ - base: "fpco/pid1"

29+ name: "yesodweb/warp"

30+ executables:

31+ - warp

stack-lts-9.yamlnew file+27

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

1+resolver: lts-9.21

2+packages:

3+- ./auto-update

4+- ./mime-types

5+- ./wai

6+- ./wai-extra

7+- ./warp

8+- ./warp-tls

9+- ./wai-app-static

10+- ./wai-websockets

11+- ./wai-conduit

12+extra-deps:

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

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

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

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

17+nix:

18+ enable: false

19+ packages:

20+ - fcgi

21+ - zlib

22+image:

23+ containers:

24+ - base: "fpco/pid1"

25+ name: "yesodweb/warp"

26+ executables:

27+ - warp

stack-nightly.yaml+7−2

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

1−resolver: nightly-2020-01-08

1+resolver: nightly-2018-08-17

2packages:

3- ./auto-update

4- ./mime-types

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

9- ./wai-app-static

10- ./wai-websockets

11- ./wai-conduit

12−- ./time-manager

13flags:

12flags:

14 wai-extra:

13 wai-extra:

15 build-example: true

14 build-example: true

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

18 packages:

17 packages:

19 - fcgi

18 - fcgi

20 - zlib

19 - zlib

20+image:

21+ containers:

22+ - base: "fpco/pid1"

23+ name: "yesodweb/warp"

24+ executables:

25+ - warp

stack.yamlmode 100644 → 120000+1−25

@@ -1,25 +0,0 @@

1−resolver: lts-14.22

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

@@ -0,0 +1 @@

1+stack-lts-12.yaml

time-manager/LICENSEdeleted−20

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

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.

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-extra/ChangeLog.md−31

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

1# Changelog for wai-extra

2

3−## 3.0.29.1

4−

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

6−

7−## 3.0.29

8−

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

10−

11−## 3.0.28

12−

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

14−

15−## 3.0.27

16−

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

18−

19−## 3.0.26.1

20−

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

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

23−

24−## 3.0.26

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

3## 3.0.24.3

35

4

36* Drop unnecessary `lifted-base` dependency

5* Drop unnecessary `lifted-base` dependency

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

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

5 headers:

6

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

8−

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

10-}

8-}

11module Network.Wai.EventSource (

9module Network.Wai.EventSource (

12 ServerEvent(..),

10 ServerEvent(..),

13 eventSourceAppChan,

11 eventSourceAppChan,

14− eventSourceAppIO,

12+ eventSourceAppIO

15− eventStreamAppRaw

16 ) where

13 ) where

17

14

18import Data.Function (fix)

15import Data.Function (fix)

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

42 case eventToBuilder se of

39 case eventToBuilder se of

43 Nothing -> return ()

40 Nothing -> return ()

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

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

45−

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

47−--

48−-- @since 3.0.28

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

50−eventStreamAppRaw handler _ sendResponse =

51− sendResponse $ responseStream

52− status200

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

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

55− where

56− sendEvent sendChunk event =

57− case eventToBuilder event of

58− Nothing -> return ()

59− Just b -> sendChunk b

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

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

1{-# LANGUAGE CPP #-}

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

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

3

4{-|

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

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

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

89-- if gzip is supported.

90--

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

92−--

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

94−-- behavior, see 'defaultCheckMime'.

95gzip :: GzipSettings -> Middleware

92gzip :: GzipSettings -> Middleware

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

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

97 case res of

94 case res of

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

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

14 , OutputFormat (..)

15 , OutputFormatter

16 , OutputFormatterWithDetails

17− , OutputFormatterWithDetailsAndHeaders

18 , Destination (..)

17 , Destination (..)

19 , Callback

18 , Callback

20 , IPAddrSource (..)

19 , IPAddrSource (..)

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

50import Network.Wai.Header (contentLength)

49import Network.Wai.Header (contentLength)

51import Data.Text.Encoding (decodeUtf8')

50import Data.Text.Encoding (decodeUtf8')

52

51

53−data OutputFormat

54− = Apache IPAddrSource

52+data OutputFormat = Apache IPAddrSource

55− | Detailed Bool -- ^ use colors?

53+ | Detailed Bool -- ^ use colors?

56− | CustomOutputFormat OutputFormatter

54+ | CustomOutputFormat OutputFormatter

57− | CustomOutputFormatWithDetails OutputFormatterWithDetails

55+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

58− | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

59

56

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

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

61−

62−type OutputFormatterWithDetails

58+type OutputFormatterWithDetails =

63− = ZonedDate

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

64− -> Request

65− -> Status

66− -> Maybe Integer

67− -> NominalDiffTime

68− -> [S8.ByteString]

69− -> B.Builder

70− -> LogStr

71−

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

73−--

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

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

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

77−--

78−-- @since 3.0.27

79−type OutputFormatterWithDetailsAndHeaders

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

81− -> Request -- ^ The WAI request

82− -> Status -- ^ HTTP status code

83− -> Maybe Integer -- ^ Response size

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

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

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

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

88− -> LogStr

89

60

90data Destination = Handle Handle

61data Destination = Handle Handle

91 | Logger LoggerSet

62 | Logger LoggerSet

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

137 CustomOutputFormatWithDetails formatter -> do

108 CustomOutputFormatWithDetails formatter -> do

138 getdate <- getDateGetter flusher

109 getdate <- getDateGetter flusher

139 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

110 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

140− CustomOutputFormatWithDetailsAndHeaders formatter -> do

141− getdate <- getDateGetter flusher

142− return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

143

111

144apacheMiddleware :: ApacheLoggerActions -> Middleware

112apacheMiddleware :: ApacheLoggerActions -> Middleware

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

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

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

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

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

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

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

152 date <- liftIO getdate

120 date <- liftIO getdate

153− let msize = contentLength (responseHeaders res)

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

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

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

155 sendResponse res

123 sendResponse res

156

124

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

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

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

161 app req' $ \res -> do

129 app req' $ \res -> do

162 t1 <- getCurrentTime

130 t1 <- getCurrentTime

163 date <- liftIO getdate

131 date <- liftIO getdate

164− let msize = contentLength (responseHeaders res)

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

165 builderIO <- newIORef $ B.byteString ""

133 builderIO <- newIORef $ B.byteString ""

166 res' <- recordChunks builderIO res

134 res' <- recordChunks builderIO res

167 rspRcv <- sendResponse res'

135 rspRcv <- sendResponse res'

168 _ <- liftIO . cb .

136 _ <- liftIO . cb .

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

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

170 readIORef builderIO

138 readIORef builderIO

171 return rspRcv

139 return rspRcv

172

140

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

174−customMiddlewareWithDetailsAndHeaders cb getdate formatter app req sendResponse = do

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

176− t0 <- getCurrentTime

177− app req' $ \res -> do

178− t1 <- getCurrentTime

179− date <- liftIO getdate

180− let msize = contentLength (responseHeaders res)

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

182− res' <- recordChunks builderIO res

183− rspRcv <- sendResponse res'

184− _ <- do

185− rawResponse <- readIORef builderIO

186− let status = responseStatus res'

187− duration = t1 `diffUTCTime` t0

188− resHeaders = responseHeaders res'

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

190− return rspRcv

191-- | Production request logger middleware.

141-- | Production request logger middleware.

192--

142--

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

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

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

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

1{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE CPP #-}

3

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

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

5− ( formatAsJSON

6− , formatAsJSONWithHeaders

7− ) where

8

5

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

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

10import Data.ByteString.Lazy (toStrict)

7import Data.ByteString.Lazy (toStrict)

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

43 , "time" .= decodeUtf8With lenientDecode date

40 , "time" .= decodeUtf8With lenientDecode date

44 ]) <> "\n"

41 ]) <> "\n"

45

42

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

47−--

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

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

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

51−--

52−-- @since 3.0.27

53−formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders

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

55− toLogStr (encode $

56− object

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

58− , "response" .= object

59− [ "status" .= statusCode status

60− , "size" .= resSize

61− , "headers" .= responseHeadersToJSON resHeaders

62− , "body" .=

63− if statusCode status >= 400

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

65− else Nothing

66− ]

67− , "time" .= decodeUtf8With lenientDecode date

68− ]) <> "\n"

69−

70word32ToHostAddress :: Word32 -> Text

43word32ToHostAddress :: Word32 -> Text

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

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

72

45

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

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

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

118 hToJ hd = headerToJSON hd

91 hToJ hd = headerToJSON hd

119

92

120−responseHeadersToJSON :: [Header] -> Value

121−responseHeadersToJSON = toJSON . map hToJ where

122− -- Redact cookies

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

124− hToJ hd = headerToJSON hd

125−

126headerToJSON :: Header -> Value

93headerToJSON :: Header -> Value

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

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

128

95

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

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

169--

170-- as the following example demonstrates.

171--

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

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

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

174--

175-- @

wai-extra/Network/Wai/Parse.hs+4−11

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

48#endif

49 ) where

50

51−import qualified Control.Exception as E

52import qualified Data.ByteString as S

51import qualified Data.ByteString as S

53import qualified Data.ByteString.Lazy as L

52import qualified Data.ByteString.Lazy as L

54import qualified Data.ByteString.Char8 as S8

53import qualified Data.ByteString.Char8 as S8

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

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

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

69import Data.IORef

68import Data.IORef

70import Network.HTTP.Types (hContentType)

69import Network.HTTP.Types (hContentType)

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

72import Data.CaseInsensitive (mk)

70import Data.CaseInsensitive (mk)

73

71

74import Prelude hiding (lines)

72import Prelude hiding (lines)

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

428

426

429

427

430-- | Take one header or subheader line.

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

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

434takeLine maxlen src =

430takeLine maxlen src =

435 go ""

431 go ""

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

438 bs <- readSource src

434 bs <- readSource src

439 case maxlen of

435 case maxlen of

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

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

441− E.throwIO $ ConnectionError (UnknownErrorCode 431)

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

442− "Request Header Fields Too Large"

443 Nothing -> return ()

438 Nothing -> return ()

444 if S.null bs

439 if S.null bs

445 then close front

440 then close front

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

455 let res = front `S.append` x

450 let res = front `S.append` x

456 case maxlen of

451 case maxlen of

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

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

458− E.throwIO $ ConnectionError (UnknownErrorCode 431)

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

459− "Request Header Fields Too Large"

460 Nothing -> return ()

454 Nothing -> return ()

461 return $ Just $ killCR $ res

455 return $ Just $ killCR $ res

462

456

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

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

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

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

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

647 case max' of

641 case max' of

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

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

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

650− _ -> return ()

643+ _ -> return ()

651 if S.null bs

644 if S.null bs

652 then do

645 then do

653 writeIORef ref $ WTBDone False

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

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

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

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

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

96 let expected3 = (expectedsmap3, expectedfile3)

95 let expected3 = (expectedsmap3, expectedfile3)

97

96

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

99− unknownErrorException _ _ = False

100−

101

97

102 let def = defaultParseRequestBodyOptions

98 let def = defaultParseRequestBodyOptions

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

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

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

123

119

124 it "exceeding file size" $ do

120 it "exceeding file size" $ do

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

121 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

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

127− `shouldThrow` unknownErrorException 413

128

123

129 it "exceeding total file size" $ do

124 it "exceeding total file size" $ do

130 SRequest req4 _bod4 <- toRequest'' ctype3 content3

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

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

132− `shouldThrow` unknownErrorException 413

133 SRequest req5 _bod5 <- toRequest'' ctype3 content5

127 SRequest req5 _bod5 <- toRequest'' ctype3 content5

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

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

135− `shouldThrow` unknownErrorException 413

136

129

137 it "exceeding max parm value size" $ do

130 it "exceeding max parm value size" $ do

138 SRequest req4 _bod4 <- toRequest'' ctype2 content2

131 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

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

140− `shouldThrow` unknownErrorException 413

141

133

142 it "exceeding max header lines" $ do

134 it "exceeding max header lines" $ do

143 SRequest req4 _bod4 <- toRequest'' ctype2 content2

135 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

145

137

146 it "exceeding header line size" $ do

138 it "exceeding header line size" $ do

147 SRequest req4 _bod4 <- toRequest'' ctype3 content4

139 SRequest req4 _bod4 <- toRequest'' ctype3 content4

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

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

149− `shouldThrow` unknownErrorException 431

150

141

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

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

152 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

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

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

1Name: wai-extra

2−Version: 3.0.29.1

2+Version: 3.0.24.3

3Synopsis: Provides some basic WAI handlers and middleware.

4description:

5 Provides basic WAI handler and middleware functionality:

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

87 default: False

88

89Library

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

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

91 , bytestring >= 0.10.4

92 , wai >= 3.0.3.0 && < 3.3

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

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

99 , text >= 0.7

100 , case-insensitive >= 0.2

101 , data-default-class

102− , fast-logger >= 2.4.5

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

103− , wai-logger >= 2.3.2

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

104 , ansi-terminal

105 , resourcet >= 0.4.6 && < 1.3

106 , void >= 0.5

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

115 , zlib

116 , aeson

117 , iproute

118− , http2

119

118

120 if os(windows)

119 if os(windows)

121 cpp-options: -DWINDOWS

120 cpp-options: -DWINDOWS

@@ -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-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+4−5

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

30

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

32

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

34+

33-}

35-}

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

37 (

38 -- * Types

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

53 , remoteHost

54 , pathInfo

55 , queryString

56− , getRequestBodyChunk

57 , requestBody

56 , requestBody

58 , vault

57 , vault

59 , requestBodyLength

58 , requestBodyLength

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

326 loop id

325 loop id

327 where

326 where

328 loop front = do

327 loop front = do

329− bs <- getRequestBodyChunk req

328+ bs <- requestBody req

330 if B.null bs

329 if B.null bs

331 then return $ front LI.Empty

330 then return $ front LI.Empty

332 else loop (front . LI.Chunk bs)

331 else loop (front . LI.Chunk bs)

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

340 loop

339 loop

341 where

340 where

342 loop = unsafeInterleaveIO $ do

341 loop = unsafeInterleaveIO $ do

343− bs <- getRequestBodyChunk req

342+ bs <- requestBody req

344 if B.null bs

343 if B.null bs

345 then return LI.Empty

344 then return LI.Empty

346 else do

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

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

1## 3.2.25

84

2

85* Removing Connection: and Transfer-Encoding: from HTTP/2

3* Removing Connection: and Transfer-Encoding: from HTTP/2

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

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

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

385--

378--

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

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

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

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

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

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

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

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

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

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

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

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

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

437 -> Settings -> Settings

430 -> Settings -> Settings

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

431setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

439

432

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

441−--

442−-- Since 3.3.8

443−setMaxTotalHeaderLength :: Int -> Settings -> Settings

444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446−

447-- | Explicitly pause the slowloris timeout.

433-- | Explicitly pause the slowloris timeout.

448--

434--

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

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

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

471-- Since 3.1.10

457-- Since 3.1.10

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

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

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

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

474−

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

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

477−-- Default: 0.

478−--

479−-- Since 3.3.5

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

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

482−

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

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

485−--

486−-- Since 3.3.5

487−getGracefulCloseTimeout1 :: Settings -> Int

488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489−

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

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

492−-- Default: 2000.

493−--

494−-- Since 3.3.5

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

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

497−

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

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

500−--

501−-- Since 3.3.5

502−getGracefulCloseTimeout2 :: Settings -> Int

503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504−

505−-- | Getting information of client certificate.

506−--

507−-- Since 3.3.5

508−clientCertificate :: Request -> Maybe CertificateChain

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

warp/Network/Wai/Handler/Warp/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+130

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

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

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

3+

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

5+ hpackEncodeHeader

6+ , hpackEncodeHeaderLoop

7+ , hpackDecodeHeader

8+ , just

9+ , fixHeaders

10+ , addHeader -- testing

11+ , deleteUnnecessaryHeaders

12+ ) where

13+

14+import qualified Control.Exception as E

15+import Network.HPACK hiding (Buffer)

16+import Network.HPACK.Token

17+import Network.HTTP2

18+

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

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

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

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

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

24+

25+-- $setup

26+-- >>> :set -XOverloadedStrings

27+

28+----------------------------------------------------------------

29+

30+{-# INLINE addHeader #-}

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

32+addHeader t "" _ ths

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

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

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

36+ _ -> ths

37+

38+fixHeaders :: Context

39+ -> Rspn

40+ -> InternalInfo

41+ -> S.Settings

42+ -> IO TokenHeaderList

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

44+ date <- getDate ii

45+ let !s = rspnStatus rspn

46+ !status = packStatus s

47+ !defServer = S.settingsServerName settings

48+ (!ths0,tbl) = rspnHeaders rspn

49+ !ths1 = addHeader tokenServer defServer tbl ths0

50+ !ths2 = addHeader tokenDate date tbl ths1

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

52+ !ths4 = deleteUnnecessaryHeaders ths3 tbl

53+ return ths4

54+

55+deleteUnnecessaryHeaders :: TokenHeaderList -> ValueTable -> TokenHeaderList

56+deleteUnnecessaryHeaders htl0 tbl0 = loop headersToBeRemoved htl0

57+ where

58+ loop [] thl = thl

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

60+ Nothing -> thl

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

62+ in loop ts thl'

63+

64+headersToBeRemoved :: [Token]

65+headersToBeRemoved = [ tokenConnection

66+ , tokenTransferEncoding

67+ -- Keep-Alive:

68+ -- Proxy-Connection:

69+ -- Upgrade:

70+ ]

71+

72+----------------------------------------------------------------

73+

74+strategy :: EncodeStrategy

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

76+

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

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

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

80+ -> TokenHeaderList

81+ -> IO (TokenHeaderList, Int)

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

83+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths

84+

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

86+ -> TokenHeaderList

87+ -> IO (TokenHeaderList, Int)

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

89+ encodeTokenHeader buf siz strategy False encodeDynamicTable hs

90+

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

92+

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

94+hpackDecodeHeader hdrblk Context{..} = do

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

96+ unless (checkRequestHeader vt) $

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

98+ return tbl

99+ where

100+ handl IllegalHeaderName =

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

102+ handl _ =

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

104+

105+{-# INLINE checkRequestHeader #-}

106+checkRequestHeader :: ValueTable -> Bool

107+checkRequestHeader reqvt

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

109+ | isJust mStatus = False

110+ | isNothing mMethod = False

111+ | isNothing mScheme = False

112+ | isNothing mPath = False

113+ | mPath == Just "" = False

114+ | isJust mConnection = False

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

116+ | otherwise = True

117+ where

118+ mStatus = getHeaderValue tokenStatus reqvt

119+ mScheme = getHeaderValue tokenScheme reqvt

120+ mPath = getHeaderValue tokenPath reqvt

121+ mMethod = getHeaderValue tokenMethod reqvt

122+ mConnection = getHeaderValue tokenConnection reqvt

123+ mTE = getHeaderValue tokenTE reqvt

124+

125+{-# INLINE just #-}

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

127+just Nothing _ = False

128+just (Just x) p

129+ | p x = True

130+ | otherwise = False

warp/Network/Wai/Handler/Warp/HTTP2/Manager.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+398

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

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE NamedFieldPuns #-}

3+{-# LANGUAGE BangPatterns #-}

4+{-# LANGUAGE CPP #-}

5+{-# LANGUAGE PatternGuards #-}

6+

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

8+

9+import Control.Concurrent

10+import Control.Concurrent.STM

11+import qualified Control.Exception as E

12+import qualified Data.ByteString as BS

13+import qualified Data.ByteString.Char8 as C8

14+import Data.IORef

15+import Network.HPACK

16+import Network.HPACK.Token

17+import Network.HTTP2

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

19+

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

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

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

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

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

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

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

27+

28+----------------------------------------------------------------

29+

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

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

32+ where

33+ Context{ http2settings

34+ , streamTable

35+ , concurrency

36+ , continued

37+ , clientStreamId

38+ , inputQ

39+ , controlQ

40+ } = ctx

41+ sendGoaway e

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

43+ csid <- readIORef clientStreamId

44+ let !frame = goawayFrame csid err msg

45+ enqueueControl controlQ $ CGoaway frame

46+ | otherwise = return ()

47+

48+ sendReset err sid = do

49+ let !frame = resetFrame err sid

50+ enqueueControl controlQ $ CFrame frame

51+

52+ loop :: Int -> IO ()

53+ loop !n

54+ | n == 6 = do

55+ yield

56+ loop 0

57+ | otherwise = do

58+ hd <- recvN frameHeaderLength

59+ if BS.null hd then

60+ enqueueControl controlQ CFinish

61+ else do

62+ cont <- processStreamGuardingError $ decodeFrameHeader hd

63+ when cont $ loop (n + 1)

64+

65+ processStreamGuardingError (fid, FrameHeader{streamId})

66+ | isResponse streamId &&

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

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

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

70+ mx <- readIORef continued

71+ case mx of

72+ Nothing -> do

73+ -- ignoring unknown frame

74+ consume payloadLength

75+ return True

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

77+ processStreamGuardingError (FramePushPromise, _) =

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

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

80+ settings <- readIORef http2settings

81+ case checkFrameHeader settings typhdr of

82+ Left h2err -> case h2err of

83+ StreamError err sid -> do

84+ sendReset err sid

85+ consume payloadLength

86+ return True

87+ connErr -> E.throwIO connErr

88+ Right _ -> do

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

90+ case ex of

91+ Left (StreamError err sid) -> do

92+ sendReset err sid

93+ return True

94+ Left connErr -> E.throw connErr

95+ Right cont -> return cont

96+

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

98+ | isControl streamId = do

99+ pl <- recvN payloadLength

100+ control ftyp header pl ctx

101+ | otherwise = do

102+ checkContinued

103+ !mstrm <- getStream

104+ pl <- recvN payloadLength

105+ case mstrm of

106+ Nothing -> do

107+ -- for h2spec only

108+ when (ftyp == FramePriority) $ do

109+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl

110+ checkPriority newpri streamId

111+ return True -- just ignore this frame

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

113+ state <- readIORef streamState

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

115+ case state' of

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

117+ resetContinued

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

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

120+ E.throwIO $ StreamError ProtocolError streamId

121+ writeIORef streamPrecedence $ toPrecedence pri

122+ writeIORef streamState HalfClosed

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

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

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

126+ resetContinued

127+ q <- newTQueueIO

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

129+ writeIORef streamPrecedence $ toPrecedence pri

130+ bodyLength <- newIORef 0

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

132+ readQ <- newReadBody q

133+ bodySource <- mkSource readQ

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

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

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

137+ setContinued

138+ writeIORef streamState s

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

140+ resetContinued

141+ writeIORef streamState s

142+ return True

143+ where

144+ setContinued = writeIORef continued (Just streamId)

145+ resetContinued = writeIORef continued Nothing

146+ checkContinued = do

147+ mx <- readIORef continued

148+ case mx of

149+ Nothing -> return ()

150+ Just sid

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

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

153+ getStream = do

154+ mstrm0 <- search streamTable streamId

155+ case mstrm0 of

156+ js@(Just strm0) -> do

157+ when (ftyp == FrameHeaders) $ do

158+ st <- readIORef $ streamState strm0

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

160+ -- Priority made an idele stream

161+ when (isIdle st) $ opened ctx strm0

162+ return js

163+ Nothing

164+ | isResponse streamId -> return Nothing

165+ | otherwise -> do

166+ csid <- readIORef clientStreamId

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

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

169+ return Nothing -- will be ignored

170+ else

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

172+ else do -- consider the stream idle

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

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

175+ when (ftyp == FrameHeaders) $ do

176+ writeIORef clientStreamId streamId

177+ cnt <- readIORef concurrency

178+ -- Checking the limitation of concurrency

179+ when (cnt >= maxConcurrency) $

180+ E.throwIO $ StreamError RefusedStream streamId

181+ ws <- initialWindowSize <$> readIORef http2settings

182+ newstrm <- newStream streamId (fromIntegral ws)

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

184+ insert streamTable streamId newstrm

185+ return $ Just newstrm

186+

187+ consume = void . recvN

188+

189+maxConcurrency :: Int

190+maxConcurrency = recommendedConcurrency

191+

192+initialFrame :: ByteString

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

194+

195+----------------------------------------------------------------

196+

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

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

199+ SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs

200+ case checkSettingsList alist of

201+ Just x -> E.throwIO x

202+ Nothing -> return ()

203+ -- HTTP/2 Setting from a browser

204+ unless (testAck flags) $ do

205+ oldws <- initialWindowSize <$> readIORef http2settings

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

207+ newws <- initialWindowSize <$> readIORef http2settings

208+ let diff = newws - oldws

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

210+ let !frame = settingsFrame setAck []

211+ sent <- readIORef firstSettings

212+ let !setframe

213+ | sent = CSettings frame alist

214+ | otherwise = CSettings0 initialFrame frame alist

215+ unless sent $ writeIORef firstSettings True

216+ enqueueControl controlQ setframe

217+ return True

218+

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

220+ if testAck flags then

221+ return True -- just ignore

222+ else do

223+ let !frame = pingFrame bs

224+ enqueueControl controlQ $ CFrame frame

225+ return True

226+

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

228+ enqueueControl controlQ CFinish

229+ return False

230+

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

232+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

233+ !w <- atomically $ do

234+ w0 <- readTVar connectionWindow

235+ let !w1 = w0 + n

236+ writeTVar connectionWindow w1

237+ return w1

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

239+ return True

240+

241+control _ _ _ _ =

242+ -- must not reach here

243+ return False

244+

245+----------------------------------------------------------------

246+

247+{-# INLINE guardIt #-}

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

249+guardIt x = case x of

250+ Left err -> E.throwIO err

251+ Right frame -> return frame

252+

253+

254+{-# INLINE checkPriority #-}

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

256+checkPriority p me

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

258+ | otherwise = return ()

259+ where

260+ dep = streamDependency p

261+

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

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

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

265+ pri <- case mp of

266+ Nothing -> return defaultPriority

267+ Just p -> do

268+ checkPriority p streamNumber

269+ return p

270+ let !endOfStream = testEndStream flags

271+ !endOfHeader = testEndHeader flags

272+ if endOfHeader then do

273+ tbl <- hpackDecodeHeader frag ctx -- fixme

274+ return $ if endOfStream then

275+ Open (NoBody tbl pri)

276+ else

277+ Open (HasBody tbl pri)

278+ else do

279+ let !siz = BS.length frag

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

281+

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

283+ -- trailer is not supported.

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

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

286+ let !endOfStream = testEndStream flags

287+ if endOfStream then do

288+ atomically $ writeTQueue q ""

289+ return HalfClosed

290+ else

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

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

293+

294+stream FrameData

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

296+ bs

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

298+ Stream{streamNumber} = do

299+ DataFrame body <- guardIt $ decodeDataFrame header bs

300+ let !endOfStream = testEndStream flags

301+ len0 <- readIORef bodyLength

302+ let !len = len0 + payloadLength

303+ writeIORef bodyLength len

304+ when (payloadLength /= 0) $ do

305+ let !frame1 = windowUpdateFrame 0 payloadLength

306+ !frame2 = windowUpdateFrame streamNumber payloadLength

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

308+ enqueueControl controlQ $ CFrame frame

309+ atomically $ writeTQueue q body

310+ if endOfStream then do

311+ case mcl of

312+ Nothing -> return ()

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

314+ atomically $ writeTQueue q ""

315+ return HalfClosed

316+ else

317+ return s

318+

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

320+ let !endOfHeader = testEndHeader flags

321+ !rfrags' = frag : rfrags

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

323+ !n' = n + 1

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

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

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

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

328+ if endOfHeader then do

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

330+ tbl <- hpackDecodeHeader hdrblk ctx

331+ return $ if endOfStream then

332+ Open (NoBody tbl pri)

333+ else

334+ Open (HasBody tbl pri)

335+ else

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

337+

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

339+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

340+ !w <- atomically $ do

341+ w0 <- readTVar streamWindow

342+ let !w1 = w0 + n

343+ writeTVar streamWindow w1

344+ return w1

345+ when (isWindowOverflow w) $

346+ E.throwIO $ StreamError FlowControlError streamId

347+ return s

348+

349+stream FrameRSTStream header bs ctx _ strm = do

350+ RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs

351+ let !cc = Reset e

352+ closed ctx strm cc

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

354+

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

356+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs

357+ checkPriority newpri streamNumber

358+ oldpre <- readIORef streamPrecedence

359+ let !newpre = toPrecedence newpri

360+ writeIORef streamPrecedence newpre

361+ if isIdle s then do

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

363+ -- fixme hard coding

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

365+ prepare outputQ streamNumber newpri

366+ else do

367+ mx <- delete outputQ streamNumber oldpre

368+ case mx of

369+ Nothing -> return ()

370+ Just out -> enqueueOutput outputQ out

371+ return s

372+

373+-- this ordering is important

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

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

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

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

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

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

380+

381+----------------------------------------------------------------

382+

383+{-# INLINE newReadBody #-}

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

385+newReadBody q = do

386+ ref <- newIORef False

387+ return $ readBody q ref

388+

389+{-# INLINE readBody #-}

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

391+readBody q ref = do

392+ eof <- readIORef ref

393+ if eof then

394+ return ""

395+ else do

396+ bs <- atomically $ readTQueue q

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

398+ return bs

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

@@ -1,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 <- fixHeaders ctx rspn ii settings

136+ kvlen <- headerContinue sid ths endOfStream off0

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

138+ case rspn of

139+ RspnNobody _ _ -> do

140+ closed ctx strm Finished

141+ return off

142+ RspnFile _ _ path mpart -> do

143+ -- Data frame payload

144+ let payloadOff = off + frameHeaderLength

145+ Next datPayloadLen mnext <-

146+ fillFileBodyGetNext conn ii payloadOff lim path mpart

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

148+ maybeEnqueueNext out mnext

149+ return off'

150+ RspnBuilder _ _ builder -> do

151+ -- Data frame payload

152+ let payloadOff = off + frameHeaderLength

153+ Next datPayloadLen mnext <-

154+ fillBuilderBodyGetNext conn ii payloadOff lim builder

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

156+ maybeEnqueueNext out mnext

157+ return off'

158+ RspnStreaming _ _ tbq -> do

159+ let payloadOff = off + frameHeaderLength

160+ Next datPayloadLen mnext <-

161+ fillStreamBodyGetNext conn payloadOff lim tbq strm

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

163+ maybeEnqueueNext out mnext

164+ return off'

165+

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

167+ -- Creating a push promise header

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

169+ let !sid = streamNumber strm

170+ len <- pushPromise pid sid ths off0

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

172+ output out{ outputType = ORspn } off lim

173+

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

175+

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

177+ state <- readIORef $ streamState strm

178+ if isClosed state then

179+ return off

180+ else case out of

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

182+ -- Checking if all push are done.

183+ let out' = out {

184+ outputHook = return ()

185+ , outputType = ORspn

186+ }

187+ forkAndEnqueueWhenReady wait outputQ out' mgr

188+ return off

189+ _ -> case mtbq of

190+ Just tbq -> checkStreaming tbq

191+ _ -> checkStreamWindowSize

192+ where

193+ strm = outputStream out

194+ mtbq = outputMaybeTBQueue out

195+ checkStreaming tbq = do

196+ isEmpty <- atomically $ isEmptyTBQueue tbq

197+ if isEmpty then do

198+ forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr

199+ return off

200+ else

201+ checkStreamWindowSize

202+ checkStreamWindowSize = do

203+ sws <- getStreamWindowSize strm

204+ if sws == 0 then do

205+ forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr

206+ return off

207+ else do

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

209+ let !lim = min cws sws

210+ output out off lim

211+ resetStream e = do

212+ closed ctx strm (ResetByMe e)

213+ let !rst = resetFrame InternalError $ streamNumber strm

214+ enqueueControl controlQ $ CFrame rst

215+ return off

216+

217+ {-# INLINE flushN #-}

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

219+ -- the buffer are filled.

220+ flushN :: Int -> IO ()

221+ flushN n = bufferIO connWriteBuffer n connSendAll

222+

223+ headerContinue sid ths endOfStream off = do

224+ let !offkv = off + frameHeaderLength

225+ let !bufkv = connWriteBuffer `plusPtr` offkv

226+ !limkv = connBufferSize - offkv

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

228+ let flag0 = case hs of

229+ [] -> setEndHeader defaultFlags

230+ _ -> defaultFlags

231+ flag = if endOfStream then setEndStream flag0 else flag0

232+ let buf = connWriteBuffer `plusPtr` off

233+ fillFrameHeader FrameHeaders kvlen sid flag buf

234+ continue sid kvlen hs

235+

236+ !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength

237+ !headerPayloadLim = connBufferSize - frameHeaderLength

238+

239+ continue _ kvlen [] = return kvlen

240+ continue sid kvlen ths = do

241+ flushN $ kvlen + frameHeaderLength

242+ -- Now off is 0

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

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

245+ let flag = case ths' of

246+ [] -> setEndHeader defaultFlags

247+ _ -> defaultFlags

248+ fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer

249+ continue sid kvlen' ths'

250+

251+ {-# INLINE maybeEnqueueNext #-}

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

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

254+ maybeEnqueueNext _ Nothing = return ()

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

256+ where

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

258+

259+ {-# INLINE sendHeadersIfNecessary #-}

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

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

262+ sendHeadersIfNecessary off

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

264+ | off + frameHeaderLength < connBufferSize = return off

265+ | otherwise = do

266+ flushN off

267+ return 0

268+

269+ fillDataHeader strm@Stream{streamWindow,streamNumber}

270+ off datPayloadLen mnext tell getH2D = do

271+ -- Data frame header

272+ mh2d <- getH2D

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

274+ Nothing -> ([], True)

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

276+ !buf = connWriteBuffer `plusPtr` off

277+ !off' = off + frameHeaderLength + datPayloadLen

278+ !noMoreBody = isNothing mnext

279+ flag | noMoreBody && noTrailers = setEndStream defaultFlags

280+ | otherwise = defaultFlags

281+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf

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

283+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

284+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)

285+ return off''

286+ where

287+ handleTrailers True off0 _ = return off0

288+ handleTrailers _ off0 trailers = do

289+ (ths,_) <- toHeaderTable trailers

290+ kvlen <- headerContinue streamNumber ths True off0

291+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

292+ handleEndOfBody True off0 noTrailers trailers = do

293+ off1 <- handleTrailers noTrailers off0 trailers

294+ void tell

295+ closed ctx strm Finished

296+ return off1

297+ handleEndOfBody False off0 _ _ = return off0

298+

299+

300+ pushPromise pid sid ths off = do

301+ let !offsid = off + frameHeaderLength

302+ !bufsid = connWriteBuffer `plusPtr` offsid

303+ poke32 bufsid $ fromIntegral sid

304+ let !offkv = offsid + 4

305+ !bufkv = connWriteBuffer `plusPtr` offkv

306+ !limkv = connBufferSize - offkv

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

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

309+ !buf = connWriteBuffer `plusPtr` off

310+ !len = kvlen + 4

311+ fillFrameHeader FramePushPromise len pid flag buf

312+ return len

313+

314+ {-# INLINE fillFrameHeader #-}

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

316+ where

317+ hinfo = FrameHeader len flag sid

318+

319+ {-# INLINE ignore #-}

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

321+ ignore _ = return ()

322+

323+----------------------------------------------------------------

324+

325+{-

326+ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)

327+ResponseBuilder Status ResponseHeaders Builder

328+ResponseStream Status ResponseHeaders StreamingBody

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

330+-}

331+

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

333+fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}

334+ _ off lim bb = do

335+ let datBuf = connWriteBuffer `plusPtr` off

336+ room = min (connBufferSize - off) lim

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

338+ return $ nextForBuilder len signal

339+

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

341+#ifdef WINDOWS

342+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

343+ _ off lim path mpart = do

344+ let datBuf = connWriteBuffer `plusPtr` off

345+ room = min (connBufferSize - off) lim

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

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

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

349+ IO.hSeek hdl IO.AbsoluteSeek start

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

351+ let bytes' = bytes - fromIntegral len

352+ -- fixme: connWriteBuffer connBufferSize

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

354+#else

355+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

356+ ii off lim path mpart = do

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

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

359+ Nothing -> do

360+ fd' <- openFile path

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

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

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

364+ let datBuf = connWriteBuffer `plusPtr` off

365+ room = min (connBufferSize - off) lim

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

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

368+ refresh

369+ let len' = fromIntegral len

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

371+#endif

372+

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

374+fileStartEnd _ (Just part) =

375+ return (filePartOffset part, filePartByteCount part)

376+fileStartEnd _ _ = error "fileStartEnd"

377+

378+----------------------------------------------------------------

379+

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

381+fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

382+ off lim sq strm = do

383+ let datBuf = connWriteBuffer `plusPtr` off

384+ room = min (connBufferSize - off) lim

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

386+ return $ nextForStream sq strm leftover cont len

387+

388+----------------------------------------------------------------

389+

390+fillBufBuilder :: Leftover -> DynaNext

391+fillBufBuilder leftover buf0 siz0 lim = do

392+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

393+ room = min (siz0 - frameHeaderLength) lim

394+ case leftover of

395+ LZero -> error "fillBufBuilder: LZero"

396+ LOne writer -> do

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

398+ getNext len signal

399+ LTwo bs writer

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

401+ buf1 <- copy payloadBuf bs

402+ let len1 = BS.length bs

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

404+ getNext (len1 + len2) signal

405+ | otherwise -> do

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

407+ void $ copy payloadBuf bs1

408+ getNext room (B.Chunk bs2 writer)

409+ where

410+ getNext l s = return $ nextForBuilder l s

411+

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

413+nextForBuilder len B.Done

414+ = Next len Nothing

415+nextForBuilder len (B.More _ writer)

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

417+nextForBuilder len (B.Chunk bs writer)

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

419+

420+----------------------------------------------------------------

421+

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

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

424+runStreamBuilder buf0 room0 sq = loop buf0 room0 0

425+ where

426+ loop !buf !room !total = do

427+ mbuilder <- atomically $ tryReadTBQueue sq

428+ case mbuilder of

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

430+ Just (SBuilder builder) -> do

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

432+ let !total' = total + len

433+ case signal of

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

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

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

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

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

439+

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

441+fillBufStream leftover0 sq strm buf0 siz0 lim0 = do

442+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

443+ room0 = min (siz0 - frameHeaderLength) lim0

444+ case leftover0 of

445+ LZero -> do

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

447+ getNext leftover cont len

448+ LOne writer -> write writer payloadBuf room0 0

449+ LTwo bs writer

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

451+ buf1 <- copy payloadBuf bs

452+ let len = BS.length bs

453+ write writer buf1 (room0 - len) len

454+ | otherwise -> do

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

456+ void $ copy payloadBuf bs1

457+ getNext (LTwo bs2 writer) True room0

458+ where

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

460+ write writer1 buf room sofar = do

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

462+ case signal of

463+ B.Done -> do

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

465+ let !total = sofar + len + extra

466+ getNext leftover cont total

467+ B.More _ writer -> do

468+ let !total = sofar + len

469+ getNext (LOne writer) True total

470+ B.Chunk bs writer -> do

471+ let !total = sofar + len

472+ getNext (LTwo bs writer) True total

473+

474+nextForStream :: TBQueue Sequence -> Stream

475+ -> Leftover -> Bool -> BytesFilled

476+ -> Next

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

478+nextForStream sq strm leftOrZero True len =

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

480+

481+----------------------------------------------------------------

482+

483+#ifdef WINDOWS

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

485+fillBufFile h bytes refresh buf siz lim = do

486+ let payloadBuf = buf `plusPtr` frameHeaderLength

487+ room = min (siz - frameHeaderLength) lim

488+ len <- IO.hGetBufSome h payloadBuf room

489+ refresh

490+ let bytes' = bytes - fromIntegral len

491+ return $ nextForFile len h bytes' refresh

492+

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

494+nextForFile 0 _ _ _ = Next 0 Nothing

495+nextForFile len _ 0 _ = Next len Nothing

496+nextForFile len h bytes refresh =

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

498+#else

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

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

501+ let payloadBuf = buf `plusPtr` frameHeaderLength

502+ room = min (siz - frameHeaderLength) lim

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

504+ let len' = fromIntegral len

505+ refresh

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

507+

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

509+nextForFile 0 _ _ _ _ = Next 0 Nothing

510+nextForFile len _ _ 0 _ = Next len Nothing

511+nextForFile len fd start bytes refresh =

512+ Next len $ Just (fillBufFile fd start bytes refresh)

513+#endif

514+

515+{-# INLINE mini #-}

516+mini :: Int -> Integer -> Int

517+mini i n

518+ | fromIntegral i < n = i

519+ | otherwise = fromIntegral n

520+

521+

522+----------------------------------------------------------------

523+

524+poke32 :: Ptr Word8 -> Word32 -> IO ()

525+poke32 ptr i = do

526+ poke ptr w0

527+ poke8 ptr 1 w1

528+ poke8 ptr 2 w2

529+ poke8 ptr 3 w3

530+ where

531+ w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)

532+ w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)

533+ w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)

534+ w3 = fromIntegral (i .&. 0xff)

535+ poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()

536+ poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+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−117

@@ -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,9 +205,9 @@ 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.

@@ -258,7 +234,7 @@ acceptConnection set getConnMaker app counter ii = do

258 case mx of

234 case mx of

259 Nothing -> return ()

235 Nothing -> return ()

260 Just (mkConn, addr) -> do

236 Just (mkConn, addr) -> do

261− fork set mkConn addr app counter ii

237+ fork set mkConn addr app counter ii0

262 acceptLoop

238 acceptLoop

263

239

264 acceptNewConnection = do

240 acceptNewConnection = do

@@ -281,12 +257,15 @@ fork :: Settings

281 -> SockAddr

257 -> SockAddr

282 -> Application

258 -> Application

283 -> Counter

259 -> Counter

284− -> InternalInfo

260+ -> InternalInfo0

285 -> IO ()

261 -> IO ()

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

262+fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

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

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

288 -- exceptions are thrown.

264 -- exceptions are thrown.

289− handle (settingsOnException set Nothing) $

265+ handle (settingsOnException set Nothing) .

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

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

268+ withClosedRef $ \ref ->

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

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

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

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

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

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

@@ -297,15 +276,24 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

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

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

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

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

299 -- fact that async exceptions are still masked.

278 -- fact that async exceptions are still masked.

300− bracket mkConn cleanUp (serve unmask)

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

301 where

280 where

281+ withClosedRef inner = newIORef False >>= inner

282+

283+ closeConn ref conn = do

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

285+ unless isClosed $ connClose conn

286+

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

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

303

288

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

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

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

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

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

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

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

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

294+ let ii1 = toInternalInfo1 ii0 th

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

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

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

296+ -- the case of all exceptions, so it is safe to one again

309 -- allow async exceptions.

297 -- allow async exceptions.

310 unmask .

298 unmask .

311 -- Call the user-supplied code for connection open and

299 -- Call the user-supplied code for connection open and

@@ -313,23 +301,23 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

313 bracket (onOpen addr) (onClose addr) $ \goingon ->

301 bracket (onOpen addr) (onClose addr) $ \goingon ->

314 -- Actually serve this connection. bracket with closeConn

302 -- Actually serve this connection. bracket with closeConn

315 -- above ensures the connection is closed.

303 -- above ensures the connection is closed.

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

304+ when goingon $ serveConnection conn ii1 addr transport set app

317 where

305 where

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

306+ register = T.registerKillThread (timeoutManager0 ii0)

307+ (closeConn ref conn)

319 cancel = T.cancel

308 cancel = T.cancel

320

309

321 onOpen adr = increase counter >> settingsOnOpen set adr

310 onOpen adr = increase counter >> settingsOnOpen set adr

322 onClose adr _ = decrease counter >> settingsOnClose set adr

311 onClose adr _ = decrease counter >> settingsOnClose set adr

323

312

324serveConnection :: Connection

313serveConnection :: Connection

325− -> InternalInfo

314+ -> InternalInfo1

326− -> T.Handle

327 -> SockAddr

315 -> SockAddr

328 -> Transport

316 -> Transport

329 -> Settings

317 -> Settings

330 -> Application

318 -> Application

331 -> IO ()

319 -> IO ()

332−serveConnection conn ii th origAddr transport settings app = do

320+serveConnection conn ii1 origAddr transport settings app = do

333 -- fixme: Upgrading to HTTP/2 should be supported.

321 -- fixme: Upgrading to HTTP/2 should be supported.

334 (h2,bs) <- if isHTTP2 transport then

322 (h2,bs) <- if isHTTP2 transport then

335 return (True, "")

323 return (True, "")

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

342 istatus <- newIORef False

330 istatus <- newIORef False

343 if settingsHTTP2Enabled settings && h2 then do

331 if settingsHTTP2Enabled settings && h2 then do

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

332 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

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

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

354 -- fixme: origAddr

334 -- fixme: origAddr

355− checkTLS

356− setConnHTTP2 conn True

357− http2 conn transport ii origAddr settings recvN sendBS app

335+ http2 conn ii1 origAddr transport settings recvN app

358 else do

336 else do

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

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

360 writeIORef istatus True

338 writeIORef istatus True

361 leftoverSource src bs

339 leftoverSource src bs

362 addr <- getProxyProtocolAddr src

340 addr <- getProxyProtocolAddr src

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

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

364− case () of

342+ case fromException e of

365− ()

366− -- See comment below referencing

343+ -- See comment below referencing

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

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

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

345+ Just NoKeepAliveRequest -> return ()

369− -- No valid request

346+ Nothing -> do

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

371− | otherwise -> do

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

347+ sendErrorResponse (dummyreq addr) istatus e

373− throwIO e

348+ throwIO e

374

349

375 where

350 where

376 getProxyProtocolAddr src =

351 getProxyProtocolAddr src =

@@ -413,25 +388,29 @@ serveConnection conn ii th origAddr transport settings app = do

413

388

414 decodeAscii = map (chr . fromEnum) . S.unpack

389 decodeAscii = map (chr . fromEnum) . S.unpack

415

390

391+ th = threadHandle1 ii1

392+

416 shouldSendErrorResponse se

393 shouldSendErrorResponse se

417 | Just ConnectionClosedByPeer <- fromException se = False

394 | Just ConnectionClosedByPeer <- fromException se = False

418 | otherwise = True

395 | otherwise = True

419

396

420 sendErrorResponse req istatus e = do

397 sendErrorResponse req istatus e = do

421 status <- readIORef istatus

398 status <- readIORef istatus

422− if shouldSendErrorResponse e && status

399+ when (shouldSendErrorResponse e && status) $ do

423− then do

400+ let ii = toInternalInfo ii1 0 -- dummy

424− sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

401+ void $ sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)

425− else return False

426

402

427 dummyreq addr = defaultRequest { remoteHost = addr }

403 dummyreq addr = defaultRequest { remoteHost = addr }

428

404

429 errorResponse e = settingsOnExceptionResponse settings e

405 errorResponse e = settingsOnExceptionResponse settings e

430

406

431 http1 firstRequest addr istatus src = do

407 http1 firstRequest addr istatus src = do

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

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

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

433− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

410+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii

434 `E.catch` \e -> do

411 `E.catch` \e -> do

412+ -- Call the user-supplied exception handlers, passing the request.

413+ sendErrorResponse req istatus e

435 settingsOnException settings (Just req) e

414 settingsOnException settings (Just req) e

436 -- Don't throw the error again to prevent calling settingsOnException twice.

415 -- Don't throw the error again to prevent calling settingsOnException twice.

437 return False

416 return False

@@ -446,7 +425,7 @@ serveConnection conn ii th origAddr transport settings app = do

446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

425 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

447 when keepAlive $ http1 False addr istatus src

426 when keepAlive $ http1 False addr istatus src

448

427

449− processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

428+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do

450 -- Let the application run for as long as it wants

429 -- Let the application run for as long as it wants

451 T.pause th

430 T.pause th

452

431

@@ -454,38 +433,30 @@ serveConnection conn ii th origAddr transport settings app = do

454 -- creating the request, we need to make sure that we don't get

433 -- creating the request, we need to make sure that we don't get

455 -- an async exception before calling the ResponseSource.

434 -- an async exception before calling the ResponseSource.

456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

435 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

457− r <- E.try $ app req $ \res -> do

436+ _ <- app req $ \res -> do

458 T.resume th

437 T.resume th

459 -- FIXME consider forcing evaluation of the res here to

438 -- FIXME consider forcing evaluation of the res here to

460 -- send more meaningful error messages to the user.

439 -- send more meaningful error messages to the user.

461 -- However, it may affect performance.

440 -- However, it may affect performance.

462 writeIORef istatus False

441 writeIORef istatus False

463− keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

442+ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

464 writeIORef keepAliveRef keepAlive

443 writeIORef keepAliveRef keepAlive

465 return ResponseReceived

444 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

445 keepAlive <- readIORef keepAliveRef

476

446

477 -- We just send a Response and it takes a time to

447 -- We just send a Response and it takes a time to

478 -- receive a Request again. If we immediately call recv,

448 -- receive a Request again. If we immediately call recv,

479− -- it is likely to fail and cause the IO manager to do some work.

449+ -- it is likely to fail and the IO manager works.

480− -- It is very costly, so we yield to another Haskell

450+ -- It is very costly. So, we yield to another Haskell

481 -- thread hoping that the next Request will arrive

451 -- thread hoping that the next Request will arrive

482 -- when this Haskell thread will be re-scheduled.

452 -- when this Haskell thread will be re-scheduled.

483 -- This improves performance at least when

453 -- This improves performance at least when

484 -- the number of cores is small.

454 -- the number of cores is small.

485 Conc.yield

455 Conc.yield

486

456

487− if keepAlive

457+ if not keepAlive then

488− then

458+ return False

459+ else

489 -- If there is an unknown or large amount of data to still be read

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

461 -- from the request body, simple drop this connection instead of

491 -- reading it all in to satisfy a keep-alive request.

462 -- reading it all in to satisfy a keep-alive request.

@@ -511,21 +482,6 @@ serveConnection conn ii th origAddr transport settings app = do

511 else

482 else

512 return False

483 return False

513 Nothing -> tryKeepAlive

484 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

485

530flushEntireBody :: IO ByteString -> IO ()

486flushEntireBody :: IO ByteString -> IO ()

531flushEntireBody src =

487flushEntireBody src =

@@ -580,13 +536,7 @@ setSocketCloseOnExec :: Socket -> IO ()

580#if WINDOWS

536#if WINDOWS

581setSocketCloseOnExec _ = return ()

537setSocketCloseOnExec _ = return ()

582#else

538#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

539+setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket

590#endif

540#endif

591

541

592gracefulShutdown :: Settings -> Counter -> IO ()

542gracefulShutdown :: 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+35−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,45 @@ 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

65+ it "keeps Server" $ do

66+ let v = ""

67+ hdrs = [("Server","MyServer"),("Content-Type","Text/HTML")]

68+ (thl, vt) <- toHeaderTable hdrs

69+ addHeader tokenContentType v vt thl `shouldBe` thl

37

70

38headers :: H.ResponseHeaders

71headers :: H.ResponseHeaders

39headers = [

72headers = [

40 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

73 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

41− , ("Content-Length", "151")

74+ , ("Content-Lenght", "151")

42 , ("Server", "Mighttpd/2.5.8")

75 , ("Server", "Mighttpd/2.5.8")

43 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

76 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

44 , ("Content-Type", "text/html")

77 , ("Content-Type", "text/html")

45 ]

78 ]

46

79

47composedHeader :: ByteString

80composedHeader :: 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"

81+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

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

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