master..3eb03a4 · 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'

.github/ISSUE_TEMPLATE.mddeleted−28

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

1−<!---

2−

3−### Bug Reports

4−

5−Reporting a bug? If relevant, we recommend including:

6−

7−* Your OS name and version

8−* The versions of tools you're using (e.g. `stack`, `ghc`).

9−* The versions of dependencies you're using

10−

11−For your convenience, we recommend pasting this script into bash and uploading the output [as a gist](https://gist.github.com/).

12−

13−```

14−command -v sw_vers && sw_vers # OS X only

15−command -v uname && uname -a # Kernel version

16−command -v stack && stack --version

17−command -v stack && stack ghc -- --version

18−command -v stack && stack list-dependencies

19−```

20−

21−* Also, is there anything custom or unusual about your setup? i.e. new or prerelease versions of GHC, Stack, etc.

22−

23−* Finally, if possible, please reproduce the error in a small script, or if necessary create a new Github repo with the smallest possible reproducing case. [Stack's scripting support](https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter) might be useful for creating your reproduction example.

24−

25−### Support

26−

27−Please direct support questions to [Stack Overflow](https://stackoverflow.com/questions/tagged/yesod+haskell) or the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb). If you don't get a response there, or you suspect there may be a bug in Wai causing your problem, you're welcome to ask here.

28−-->

.github/PULL_REQUEST_TEMPLATE.mddeleted−14

@@ -1,14 +0,0 @@

1−Before submitting your PR, check that you've:

2−

3−- [ ] Bumped the version number

4−- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html)

5−- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock

6−

7−After submitting your PR:

8−

9−- [ ] Update the Changelog.md file with a link to your PR

10−- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts)

11−

12−<!---Thanks so much for contributing! :)

13−

14−_If these checkboxes don't apply to your PR, you can delete them_-->

.gitignore−2

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

8.cabal-sandbox/

9cabal.sandbox.config

10.stack-work/

11−*~

12−stack*.yaml.lock

.travis.ymlnew file+219

@@ -0,0 +1,219 @@

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

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

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

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

5+#

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

7+#

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

9+# named .travis.yml

10+

11+# Use new container infrastructure to enable caching

12+sudo: false

13+

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

15+language: c

16+

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

18+cache:

19+ directories:

20+ - $HOME/.ghc

21+ - $HOME/.cabal

22+ - $HOME/.stack

23+

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

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

26+# of those below.

27+#

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

29+# cache file per set of arguments.

30+#

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

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

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

34+matrix:

35+ include:

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

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

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

39+ # compiler: ": #GHC 7.0.4"

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

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

42+ # compiler: ": #GHC 7.2.2"

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

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

45+ # compiler: ": #GHC 7.4.2"

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

47+ #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7

48+ # compiler: ": #GHC 7.6.3"

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

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

51+ # compiler: ": #GHC 7.8.4"

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

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

54+ compiler: ": #GHC 7.10.3"

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

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

57+ compiler: ": #GHC 8.0.2"

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

59+

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

61+ # see below.

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

63+ compiler: ": #GHC HEAD"

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

65+

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

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

68+ - env: BUILD=stack ARGS=""

69+ compiler: ": #stack default"

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

71+

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

73+ # compiler: ": #stack 7.8.4"

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

75+

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

77+ compiler: ": #stack 7.10.2"

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

79+

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

81+ compiler: ": #stack 7.10.3"

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

83+

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

85+ compiler: ": #stack 8.0.1"

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

87+

88+ - env: BUILD=stack ARGS="--resolver lts-8"

89+ compiler: ": #stack 8.0.2"

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

91+

92+ # Nightly builds are allowed to fail

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

94+ compiler: ": #stack nightly"

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

96+

97+ # Build on OS X in addition to Linux

98+ - env: BUILD=stack ARGS=""

99+ compiler: ": #stack default osx"

100+ os: osx

101+

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

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

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

105+ # os: osx

106+

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

108+ compiler: ": #stack 7.10.2 osx"

109+ os: osx

110+

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

112+ compiler: ": #stack 7.10.3 osx"

113+ os: osx

114+

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

116+ compiler: ": #stack 8.0.1 osx"

117+ os: osx

118+

119+ - env: BUILD=stack ARGS="--resolver lts-8"

120+ compiler: ": #stack 8.0.2 osx"

121+ os: osx

122+

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

124+ compiler: ": #stack nightly osx"

125+ os: osx

126+

127+ allow_failures:

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

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

130+

131+before_install:

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

133+- unset CC

134+

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

136+- CABALARGS=""

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

138+# Due to https://github.com/haskell/cabal/issues/3453, we don't build benchmarks on GHC 7.6.3

139+- if [ "x$GHCVER" != "x7.6.3" ]; then CABALARGS="$CABALARGS --enable-benchmarks"; fi

140+

141+# Download and unpack the stack executable

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

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

144+- |

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

146+ then

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

148+

149+ # brew no longer has fcgi

150+ # brew install fcgi

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

152+ mv tmp stack.yaml

153+ else

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

155+ fi

156+

157+ # Use the more reliable S3 mirror of Hackage

158+ mkdir -p $HOME/.cabal

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

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

161+

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

163+ then

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

165+ fi

166+

167+install:

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

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

170+- |

171+ set -ex

172+ case "$BUILD" in

173+ stack)

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

175+ ;;

176+ cabal)

177+ cabal --version

178+ travis_retry cabal update

179+

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

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

182+

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

184+ # we can't build just dependencies

185+ #

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

187+ cabal install hspec-discover

188+ ;;

189+ esac

190+ set +ex

191+

192+script:

193+- |

194+ set -ex

195+ case "$BUILD" in

196+ stack)

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

198+ ;;

199+ cabal)

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

201+

202+ ORIGDIR=$(pwd)

203+ for dir in $PACKAGES

204+ do

205+ cd $dir

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

207+ cabal sdist

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

209+ SRC_TGZ=$PKGVER.tar.gz

210+ cd dist

211+ tar zxfv "$SRC_TGZ"

212+ cd "$PKGVER"

213+ cabal configure --enable-tests

214+ cabal build

215+ cd $ORIGDIR

216+ done

217+ ;;

218+ esac

219+ set +ex

CONTRIBUTING.mddeleted−94

@@ -1,94 +0,0 @@

1−# Contributing

2−

3−Thanks for your interest in contributing to Wai! This file has some tips for developing Wai and getting a pull request accepted.

4−

5−## Development

6−

7−Wai is a mega-repo that contains many Haskell packages, each in a different directory. All the subprojects can be developed with Stack, using `stack <command> <subproject>`, e.g.

8−

9−* `stack build mime-types`

10−* `stack test auto-update`

11−* `stack haddock warp`

12−

13−If you'd like to test your changes in a full-fledged Wai app, you can use Stack to build against it, e.g.:

14−

15−```

16−packages:

17−- '/path/to/this/repo/wai'

18−```

19−

20−## Coding Guidelines

21−

22−### Safety

23−

24−Avoid partial functions. Even if you know the partial function is safe in your instance, partial functions require more reasoning from the programmer and are not resilient to refactoring. For the rare cases where a partial function is appropriate, a custom `error` should be used.

25−

26−### Style

27−

28−Keep coding style consistent with the rest of the file, but don't worry about style too much otherwise. PRs changing code style are viewed skeptically.

29−

30−### Dependencies

31−

32−Avoid adding unnecessary dependencies. If a dependency provides only a minor convenience for your implementation, it's probably better to skip it.

33−

34−If you do add a new dependency, try to support a wide range of versions of it.

35−

36−### Backwards Compatibility

37−

38−Backwards incompatible changes are viewed skeptically—best to ask in an issue to see if a particular backwards incompatible change would be approved. If possible keep backwards compatibility by adding new APIs and deprecating old ones.

39−

40−Keep backwards compatibility with old versions of dependencies when possible.

41−

42−## PR Guidelines

43−

44−### PR Scope

45−

46−As much as possible, keep separate changes in separate PRs.

47−

48−### Testing

49−

50−Tests are recommended, but not required.

51−

52−### Documentation

53−

54−All public APIs must be documented. Documenting private functions is optional, but may be nice depending on their complexity. Example documentation:

55−

56−```

57−-- | Generate an action which will either read from an automatically

58−-- updated value, or run the update action in the current thread.

59−--

60−-- ==== __Examples__

61−--

62−-- > getTime <- mkAutoUpdate defaultUpdateSettings

63−--

64−-- @since 0.1.0

65−mkAutoUpdate :: UpdateSettings a -> IO (IO a)

66−```

67−

68−Examples are recommended, but not required, in documentation. Marking new APIs with `@since <version number>` is required.

69−

70−### Versioning

71−

72−Wai packages roughly follow the Haskell Package Versioning Policy style of A.B.C.[D] (MAJOR.MAJOR.MINOR.[PATCH])

73−

74−* A - Used for massive changes in the library. (Example: 1.2.3.4 becomes 2.0.0)

75−* B - Used for smaller breaking changes, like removing, renaming, or changing behavior of existing public API. (Example: 1.2.3.4 becomes 1.3.0)

76−* C - Used for new public APIs (Example: 1.2.3.4 becomes 1.2.4)

77−* D - Used for bug fixes (Example: 1.2.3.4 becomes 1.2.3.5).

78− * D is optional in the version number, so 2.0.0 is a valid version.

79−

80−Documentation changes don't require a new version.

81−

82−If you feel there is ambiguity to a change (e.g. fixing a bug in a function, when people may be relying on the old broken behavior), you can ask in an issue or pull request.

83−

84−Unlike in the Package Versioning Policy, deprecations are not counted as MAJOR changes.

85−

86−In some cases, dropping compatibility with a major version of a dependency (e.g. changing from transformers >= 0.3 to transformers >= 0.4), is considered a breaking change.

87−

88−### Changelog

89−

90−After you submit a PR, update the subproject's Changelog.md file with the new version number and a link to your PR. If your PR does not need to bump the version number, include the change in an "Unreleased" section at the top.

91−

92−### Releases

93−

94−Releases should be done as soon as possible after a pull request is merged—don't be shy about reminding us to make a release if we forget.

README.md+1−1

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

10

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

12

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

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

auto-update/ChangeLog.md−19

@@ -1,22 +1,3 @@

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

14−

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

16− Improve documentation for `reaperAction` function.

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

18− Fixed memory leak in `reaperAdd` function.

19−

20## 0.1.4

1## 0.1.4

21

2

22* Provide updateActionModify API in AutoUpdate [#547](https://github.com/yesodweb/wai/pull/547)

3* Provide updateActionModify API in AutoUpdate [#547](https://github.com/yesodweb/wai/pull/547)

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

@@ -49,9 +49,8 @@ data ReaperSettings workload item = ReaperSettings

49 -- ^ The action to perform on a workload. The result of this is a

50 -- \"workload modifying\" function. In the common case of using lists,

51 -- the result should be a difference list that prepends the remaining

52− -- workload to the temporary workload. The temporary workload here

52+ -- workload to the temporary workload. For help with setting up such

53− -- refers to items added to the workload while the reaper action is

54− -- running. For help with setting up such an action, see 'mkListAction'.

53+ -- an action, see 'mkListAction'.

55 --

54 --

56 -- Default: do nothing with the workload, and then prepend it to the

55 -- Default: do nothing with the workload, and then prepend it to the

57 -- temporary workload. This is incredibly useless; you should

56 -- temporary workload. This is incredibly useless; you should

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

113

112

114-- | State of reaper.

113-- | State of reaper.

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

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

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

115+ | Workload workload -- ^ The current jobs

117

116

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

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

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

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

154 next <- atomicModifyIORef' stateRef cons

153 next <- atomicModifyIORef' stateRef cons

155 next

154 next

156 where

155 where

157− cons NoReaper = let wl = reaperCons item reaperEmpty

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

158 in (Workload wl, spawn settings stateRef tidRef)

157 in (Workload wl, spawn settings stateRef tidRef)

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

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

160 in (Workload wl', return ())

159 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

3synopsis: Efficiently run periodic, on-demand actions

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

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

@@ -17,22 +17,18 @@ library

17 ghc-options: -Wall

18 exposed-modules: Control.AutoUpdate

19 Control.Debounce

20− Control.Debounce.Internal

21 Control.Reaper

20 Control.Reaper

22 other-modules: Control.AutoUpdate.Util

21 other-modules: Control.AutoUpdate.Util

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

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

24 default-language: Haskell2010

23 default-language: Haskell2010

25− if impl(ghc >= 8)

26− default-extensions: Strict StrictData

27

24

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

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

29

26

30−test-suite spec

27+-- test-suite spec

31− main-is: Spec.hs

28+-- main-is: Spec.hs

32− other-modules: Control.AutoUpdateSpec

29+-- other-modules: Control.AutoUpdateSpec

33− Control.DebounceSpec

34− Control.ReaperSpec

30+-- Control.ReaperSpec

35− hs-source-dirs: test

31+-- hs-source-dirs: test

36− type: exitcode-stdio-1.0

32+-- type: exitcode-stdio-1.0

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

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

38− default-language: Haskell2010

34+-- default-language: Haskell2010

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

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

1module Control.AutoUpdateSpec (spec) where

2

3−import Control.AutoUpdate

4−import Control.Concurrent (threadDelay)

5−import Control.Monad (replicateM_, forM_)

6−import Data.IORef

7import Test.Hspec

3import Test.Hspec

8import Test.Hspec.QuickCheck

4import Test.Hspec.QuickCheck

5+import Data.IORef

6+import Control.Concurrent (threadDelay)

7+import Control.Monad (replicateM_, forM_)

8+import Control.AutoUpdate

9

10spec :: Spec

11−spec = return ()

11+spec = do

12− -- do

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

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

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

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

15− -- ref <- newIORef 0

14+ ref <- newIORef 0

16− -- next <- mkAutoUpdate defaultUpdateSettings

15+ next <- mkAutoUpdate defaultUpdateSettings

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

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

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

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

19− -- , updateSpawnThreshold = st

18+ , updateSpawnThreshold = st

20− -- , updateFreq = 10000

19+ , updateFreq = 10000

21− -- }

20+ }

22

21

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

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

24− -- j <- next

23+ j <- next

25− -- j `shouldBe` i

24+ j `shouldBe` i

26

25

27− -- replicateM_ 50 $ do

26+ replicateM_ 50 $ do

28− -- i <- next

27+ i <- next

29− -- i `shouldBe` st + 2

28+ i `shouldBe` st + 2

30

29

31− -- threadDelay 60000

30+ threadDelay 60000

32− -- last1 <- readIORef ref

31+ last1 <- readIORef ref

33− -- threadDelay 20000

32+ threadDelay 20000

34− -- last2 <- readIORef ref

33+ last2 <- readIORef ref

35− -- last2 `shouldBe` last1

34+ last2 `shouldBe` last1

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

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

1−{-# LANGUAGE ScopedTypeVariables #-}

2−module Control.DebounceSpec (spec) where

3−

4−import Control.Concurrent

5−import Control.Debounce

6−import qualified Control.Debounce.Internal as DI

7−import Control.Monad

8−import Control.Monad.Catch

9−import Control.Retry

10−import Data.IORef

11−import Test.HUnit.Lang

12−import Test.Hspec

13−

14−spec :: Spec

15−spec = describe "mkDebounce" $ do

16− describe "Leading edge" $ do

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

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

19−

20− debounced

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

22−

23− returnFromWait

24− pause

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

26−

27− -- Try another round

28− debounced

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

30−

31− returnFromWait

32− pause

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

34−

35− it "works for multiple events" $ do

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

37−

38− debounced

39− waitForBatonToBeTaken baton

40− debounced

41− pause

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

43−

44− returnFromWait

45− pause

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

47−

48− describe "Trailing edge" $ do

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

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

51−

52− debounced

53− pause

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

55−

56− returnFromWait

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

58−

59− -- Try another round

60− debounced

61− pause

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

63−

64− returnFromWait

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

66−

67− it "works for multiple events" $ do

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

69−

70− debounced

71− waitForBatonToBeTaken baton

72− debounced

73− pause

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

75−

76− returnFromWait

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

78−

79−

80−-- | Make a controllable delay function

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

82−getWaitAction = do

83− waitVar <- newEmptyMVar

84− let waitAction _ = takeMVar waitVar

85− let returnFromWait = putMVar waitVar ()

86− return (waitAction, returnFromWait)

87−

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

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

90−getDebounce edge = do

91− ref :: IORef Int <- newIORef 0

92− let action = modifyIORef ref (+ 1)

93−

94− (waitAction, returnFromWait) <- getWaitAction

95−

96− baton <- newEmptyMVar

97−

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

99− debounceFreq = 5000000 -- unused

100− , debounceAction = action

101− , debounceEdge = edge

102− }

103−

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

105−

106−-- | Pause briefly (100ms)

107−pause :: IO ()

108−pause = threadDelay 100000

109−

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

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

112−

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

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

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

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

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

118−

119−main :: IO ()

120−main = hspec spec

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

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

1module Control.ReaperSpec (spec) where

2

3−import Control.Concurrent

4import Control.Reaper

3import Control.Reaper

5−import Data.IORef

4+import Control.Concurrent

6import Test.Hspec

5import Test.Hspec

7import Test.Hspec.QuickCheck

6import Test.Hspec.QuickCheck

7+import Data.IORef

8

9+type Item = (Int, IORef Int)

9

10

10−spec :: Spec

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

11−spec = return ()

12+ modifyIORef ref succ

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

13+ return $ if i > 1

13−-- reaper <- mkReaper defaultReaperSettings

14+ then Just (pred i, ref)

14−-- { reaperAction = action

15+ else Nothing

15−-- , reaperDelay = 1000

16−-- }

17−

18−-- let mkTestCase i = do

19−-- ref <- newIORef 0

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

21−-- reaperAdd reaper (expected, ref)

22−-- return (expected, ref)

23−-- testCases <- mapM mkTestCase is

24

16

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

17+spec :: Spec

26−-- actual <- readIORef ref

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

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

19+ reaper <- mkReaper defaultReaperSettings

28−-- threadDelay 100000

20+ { reaperAction = action

29−-- mapM_ test testCases

21+ , reaperDelay = 1000

30−-- [] <- reaperRead reaper

22+ }

31−-- return ()

32

23

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

24+ let mkTestCase i = do

25+ ref <- newIORef 0

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

27+ reaperAdd reaper (expected, ref)

28+ return (expected, ref)

29+ testCases <- mapM mkTestCase is

34

30

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

31+ let test (expected, ref) = do

36−-- modifyIORef ref succ

32+ actual <- readIORef ref

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

34+ threadDelay 100000

35+ mapM_ test testCases

36+ [] <- reaperRead reaper

37−-- return $ if i > 1

37+ return ()

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

39−-- else Nothing

hcar-wai.texnew file+52

@@ -0,0 +1,52 @@

1+% WAI-KW.tex

2+\begin{hcarentry}{WAI}

3+\label{wai}

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

5+\participants{Michael Snoyman, Greg Weber}

6+\status{stable}

7+\makeheader

8+

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

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

11+defined as follows:

12+

13+\begin{verbatim}

14+type Application

15+ = Request

16+ -> (Response -> IO ResponseReceived)

17+ -> IO ResponseReceived

18+\end{verbatim}

19+

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

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

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

23+response to the function.

24+

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

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

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

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

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

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

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

32+

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

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

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

36+

37+WAI also provides \texttt{Middleware}:

38+

39+\begin{verbatim}

40+type Middleware = Application -> Application

41+\end{verbatim}

42+

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

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

45+

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

47+

48+\FurtherReading

49+\begin{compactitem}

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

51+\end{compactitem}

52+\end{hcarentry}

hcar-warp.texnew file+28

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

1+% Warp-KW.tex

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

3+\label{warp}

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

5+\participants{Michael Snoyman}

6+\status{stable}

7+\makeheader

8+

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

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

11+

12+Since the last HCAR, Warp improved some exception handling.

13+

14+\FurtherReading

15+\begin{compactitem}

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

17+ \begin{compactitem}

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

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

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

21+ \end{compactitem}

22+\item ``Warp''

23+ \begin{compactitem}

24+ \item The Performance of Open Source Applications

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

26+ \end{compactitem}

27+\end{compactitem}

28+\end{hcarentry}

mime-types/ChangeLog.md−8

@@ -1,11 +1,3 @@

1−## 0.1.0.9

2−

3−* Add mjs mime type

4−

5−## 0.1.0.8

6−

7−* Add wasm mime type

8−

9## 0.1.0.7

1## 0.1.0.7

10

2

11* Add support for .less files [#534](https://github.com/yesodweb/wai/pull/534)

3* Add support for .less files [#534](https://github.com/yesodweb/wai/pull/534)

mime-types/Network/Mime.hs−2

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

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

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

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

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

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

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

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

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

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

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

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

980 , ("w3d", "application/x-director")

979 , ("w3d", "application/x-director")

981 , ("wad", "application/x-doom")

980 , ("wad", "application/x-doom")

982 , ("war", "application/java-archive")

981 , ("war", "application/java-archive")

983− , ("wasm", "application/wasm")

984 , ("wav", "audio/x-wav")

982 , ("wav", "audio/x-wav")

985 , ("wax", "audio/x-ms-wax")

983 , ("wax", "audio/x-ms-wax")

986 , ("wbmp", "image/vnd.wap.wbmp")

984 , ("wbmp", "image/vnd.wap.wbmp")

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

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

1name: mime-types

2−version: 0.1.0.9

2+version: 0.1.0.7

3synopsis: Basic mime-type handling types and functions

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

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

sources.txtnew file+11

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

1+./wai

2+./wai-extra

3+./warp

4+./warp-tls

5+./wai-app-static

6+./wai-handler-fastcgi

7+./wai-handler-launch

8+./wai-websockets

9+./wai-conduit

10+./mime-types

11+./auto-update

stack-lts-11.yamldeleted−27

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

1−resolver: lts-11.21

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−extra-deps:

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

18−- http2-2.0.0

19−- network-byte-order-0.1.1.0

20−- tls-1.5.3

21−- tls-session-manager-0.0.4

22−- x509-1.7.5

23−nix:

24− enable: false

25− packages:

26− - fcgi

27− - zlib

stack-lts-12.yamldeleted−26

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

1−resolver: lts-12.6

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−nix:

17− enable: false

18− packages:

19− - fcgi

20− - zlib

21−extra-deps:

22−- http2-2.0.0

23−- network-byte-order-0.1.1.0

24−- tls-1.5.3

25−- tls-session-manager-0.0.4

26−- x509-1.7.5

stack-nightly.yamldeleted−20

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

1−resolver: nightly-2020-01-08

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−nix:

17− enable: false

18− packages:

19− - fcgi

20− - zlib

stack.yaml+24−12

@@ -1,25 +1,37 @@

1−resolver: lts-14.22

1+resolver: lts-4.1

2packages:

3−- ./auto-update

4−- ./mime-types

5- ./wai

3- ./wai

6- ./wai-extra

4- ./wai-extra

7- ./warp

5- ./warp

8- ./warp-tls

6- ./warp-tls

9- ./wai-app-static

7- ./wai-app-static

8+- ./wai-handler-fastcgi

9+- ./wai-handler-launch

10- ./wai-websockets

11- ./wai-conduit

12+- ./mime-types

13+- ./auto-update

14+extra-deps:

15+- http2-1.6.0

16+- cryptonite-0.23

17+- memory-0.14.6

18+- tls-1.3.11

19+- fast-logger-2.4.5

20+- wai-logger-2.2.7

21+- http-types-0.9.1

22+- x509-1.6.5

23+- x509-validation-1.6.5

24+- foundation-0.0.12

12−- ./time-manager

25+- tls-session-manager-0.0.0.1

13−flags:

26+- psqueues-0.2.3.0

14− wai-extra:

15− build-example: true

16nix:

27nix:

17 enable: false

28 enable: false

18 packages:

29 packages:

19 - fcgi

30 - fcgi

20 - zlib

31 - zlib

21−extra-deps:

32+image:

22−- http2-2.0.0

33+ containers:

23−- network-byte-order-0.1.1.0

34+ - base: "fpco/pid1"

24−- tls-1.5.3

35+ name: "yesodweb/warp"

25−- tls-session-manager-0.0.4

36+ executables:

37+ - warp

time-manager/time-manager.cabaldeleted−19

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

1−Name: time-manager

2−Version: 0.0.0

3−Synopsis: Scalable timer

4−License: MIT

5−License-file: LICENSE

6−Author: Michael Snoyman and Kazu Yamamoto

7−Maintainer: kazu@iij.ad.jp

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

9−Category: System

10−Build-Type: Simple

11−Cabal-Version: >=1.8

12−Stability: Stable

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

14−

15−Library

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

17− , auto-update

18− Exposed-modules: System.TimeManager

19− Ghc-Options: -Wall

tls-session-manager/ChangeLog.mdnew file+2

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

1+# 0.0.0.0

2+- A first release.

tls-session-manager/LICENSEnew file+29

@@ -0,0 +1,29 @@

3+

4+Redistribution and use in source and binary forms, with or without

5+modification, are permitted provided that the following conditions

6+are met:

7+

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+ * Redistributions in binary form must reproduce the above copyright

11+ notice, this list of conditions and the following disclaimer in

12+ the documentation and/or other materials provided with the

13+ distribution.

14+ * Neither the name of the copyright holders nor the names of its

15+ contributors may be used to endorse or promote products derived

16+ from this software without specific prior written permission.

17+

18+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

19+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

20+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS

21+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

22+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,

23+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,

24+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;

25+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

26+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

27+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN

28+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

29+POSSIBILITY OF SUCH DAMAGE.

tls-session-manager/Network/TLS/SessionManager.hsnew file+132

@@ -0,0 +1,132 @@

1+{-# LANGUAGE BangPatterns #-}

2+

3+-- | In-memory TLS session manager.

4+--

5+-- * Limitation: you can set the maximum size of the session data database.

6+-- * Automatic pruning: old session data over their lifetime are pruned automatically.

7+-- * Energy saving: no dedicate pruning thread is running when the size of session data database is zero.

8+-- * (Replay resistance: each session data is used at most once to prevent replay attacks against 0RTT early data of TLS 1.3.)

9+

10+module Network.TLS.SessionManager (

11+ Config(..)

12+ , defaultConfig

13+ , newSessionManager

14+ ) where

15+

16+import Control.Exception (assert)

17+import Control.Reaper

18+import Data.IORef

19+import Data.Int (Int64)

20+import Data.List (foldl')

21+import Data.OrdPSQ (OrdPSQ)

22+import qualified Data.OrdPSQ as Q

23+import Network.TLS (SessionID, SessionData, SessionManager(..))

24+import qualified System.Clock as C

25+

26+----------------------------------------------------------------

27+

28+-- | Configuration for session managers.

29+data Config = Config {

30+ -- | Ticket lifetime in seconds.

31+ ticketLifetime :: !Int

32+ -- | Pruning delay in seconds. This is set to 'reaperDelay'.

33+ , pruningDelay :: !Int

34+ -- | The limit size of session data entries.

35+ , dbMaxSize :: !Int

36+ }

37+

38+-- | Lifetime: 1 day , delay: 10 minutes, limit: 10,000 entries.

39+defaultConfig :: Config

40+defaultConfig = Config {

41+ ticketLifetime = 86400

42+ , pruningDelay = 6000

43+ , dbMaxSize = 10000

44+ }

45+

46+----------------------------------------------------------------

47+

48+type Sec = Int64

49+type Value = (SessionData, IORef Availability)

50+type DB = OrdPSQ SessionID Sec Value

51+type Item = (SessionID, Sec, Value, Operation)

52+

53+data Operation = Add | Del

54+data Use = SingleUse | MultipleUse

55+data Availability = Fresh | Used

56+

57+----------------------------------------------------------------

58+

59+-- | Creating an in-memory session manager.

60+newSessionManager :: Config -> IO SessionManager

61+newSessionManager conf = do

62+ let lifetime = fromIntegral $ ticketLifetime conf

63+ maxsiz = dbMaxSize conf

64+ reaper <- mkReaper defaultReaperSettings {

65+ reaperEmpty = Q.empty

66+ , reaperCons = cons maxsiz

67+ , reaperAction = clean

68+ , reaperNull = Q.null

69+ , reaperDelay = pruningDelay conf * 1000000

70+ }

71+ return SessionManager {

72+ sessionResume = resume reaper MultipleUse

73+ , sessionEstablish = establish reaper lifetime

74+ , sessionInvalidate = invalidate reaper

75+ }

76+

77+cons :: Int -> Item -> DB -> DB

78+cons lim (k,t,v,Add) db

79+ | lim <= 0 = Q.empty

80+ | Q.size db == lim = case Q.minView db of

81+ Nothing -> assert False $ Q.insert k t v Q.empty

82+ Just (_,_,_,db') -> Q.insert k t v db'

83+ | otherwise = Q.insert k t v db

84+cons _ (k,_,_,Del) db = Q.delete k db

85+

86+clean :: DB -> IO (DB -> DB)

87+clean olddb = do

88+ currentTime <- C.sec <$> C.getTime C.Monotonic

89+ let !pruned = snd $ Q.atMostView currentTime olddb

90+ return $ merge pruned

91+ where

92+ ins db (k,p,v) = Q.insert k p v db

93+ -- There is not 'merge' API.

94+ -- We hope that newdb is smaller than pruned.

95+ merge pruned newdb = foldl' ins pruned entries

96+ where

97+ entries = Q.toList newdb

98+

99+----------------------------------------------------------------

100+

101+establish :: Reaper DB Item -> Sec

102+ -> SessionID -> SessionData -> IO ()

103+establish reaper lifetime k sd = do

104+ ref <- newIORef Fresh

105+ !p <- ((+ lifetime) . C.sec) <$> C.getTime C.Monotonic

106+ let !v = (sd,ref)

107+ reaperAdd reaper (k,p,v,Add)

108+

109+resume :: Reaper DB Item -> Use

110+ -> SessionID -> IO (Maybe SessionData)

111+resume reaper use k = do

112+ db <- reaperRead reaper

113+ case Q.lookup k db of

114+ Nothing -> return Nothing

115+ Just (p,v@(sd,ref)) -> do

116+ case use of

117+ SingleUse -> do

118+ available <- atomicModifyIORef' ref check

119+ reaperAdd reaper (k,p,v,Del)

120+ return $ if available then Just sd else Nothing

121+ MultipleUse -> return $ Just sd

122+ where

123+ check Fresh = (Used,True)

124+ check Used = (Used,False)

125+

126+invalidate :: Reaper DB Item

127+ -> SessionID -> IO ()

128+invalidate reaper k = do

129+ db <- reaperRead reaper

130+ case Q.lookup k db of

131+ Nothing -> return ()

132+ Just (p,v) -> reaperAdd reaper (k,p,v,Del)

tls-session-manager/Setup.hsnew file+2

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

1+import Distribution.Simple

2+main = defaultMain

tls-session-manager/tls-session-manager.cabalnew file+26

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

1+name: tls-session-manager

2+version: 0.0.0.1

3+synopsis: In-memory TLS session manager

4+description: TLS session manager with limitation, automatic pruning, energy saving and replay resistance

5+license: BSD3

6+license-file: LICENSE

7+author: Kazu Yamamoto

8+maintainer: kazu@iij.ad.jp

9+-- copyright:

10+category: Web

11+build-type: Simple

12+extra-source-files: ChangeLog.md

13+cabal-version: >= 1.10

14+

15+library

16+ exposed-modules: Network.TLS.SessionManager

17+ -- other-modules:

18+ -- other-extensions:

19+ build-depends: base >= 4.7 && < 5

20+ , auto-update

21+ , clock

22+ , psqueues >= 0.2.3

23+ , tls

24+ -- hs-source-dirs:

25+ default-language: Haskell2010

26+ ghc-options: -Wall

wai-app-static/ChangeLog.md−20

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

18−

19−* Drop dependency on blaze-builder

20−

21## 3.1.6.1

1## 3.1.6.1

22

2

23* Add `<>` import

3* Add `<>` import

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

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

34import Data.ByteString.Lazy.Char8 ()

35import Control.Monad.IO.Class (liftIO)

36

37−import Data.ByteString.Builder (toLazyByteString)

37+import Blaze.ByteString.Builder (toByteString)

38

39import Data.FileEmbed (embedFile)

40

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

@@ -264,18 +262,18 @@ staticAppPieces ss rawPieces req sendResponse = liftIO $ do

264 ] lbs

262 ] lbs

265

263

266 response (Redirect pieces' mHash) = do

264 response (Redirect pieces' mHash) = do

267− let loc = ssMkRedirect ss pieces' $ L.toStrict $ toLazyByteString (H.encodePathSegments $ map fromPiece pieces')

265+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map fromPiece pieces')

268 let qString = case mHash of

266 let qString = case mHash of

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/Runtime.hs+3−3

@@ -8,7 +8,7 @@ import WaiAppStatic.Types

8import Data.ByteString (ByteString)

9import Control.Arrow ((&&&), second)

10import Data.List

11−import Data.ByteString.Builder (byteString)

11+import Blaze.ByteString.Builder (fromByteString)

12import qualified Network.Wai as W

13import qualified Data.Map as Map

14import Data.Function (on)

@@ -50,7 +50,7 @@ toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File

50toEntry (name, EEFolder{}) = Left name

51toEntry (name, EEFile bs) = Right File

52 { fileGetSize = fromIntegral $ S.length bs

53− , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs

53+ , fileToResponse = \s h -> W.responseBuilder s h $ fromByteString bs

54 , fileName = name

55 , fileGetHash = return $ Just $ runHash bs

56 , fileGetModified = Nothing

@@ -87,7 +87,7 @@ toEmbedded fps =

87bsToFile :: Piece -> ByteString -> File

88bsToFile name bs = File

89 { fileGetSize = fromIntegral $ S.length bs

90− , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs

90+ , fileToResponse = \s h -> W.responseBuilder s h $ fromByteString bs

91 , fileName = name

92 , fileGetHash = return $ Just $ runHash bs

93 , fileGetModified = Nothing

wai-app-static/WaiAppStatic/Storage/Embedded/TH.hs+3−2

@@ -5,8 +5,9 @@ module WaiAppStatic.Storage.Embedded.TH(

5 , mkSettings

6) where

7

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

8+import Blaze.ByteString.Builder.ByteString (insertByteString)

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

@@ -129,7 +130,7 @@ embeddedToFile entry = File

129 let h' = if embCompressed entry

130 let h' = if embCompressed entry

130 then h ++ [("Content-Encoding", "gzip")]

131 then h ++ [("Content-Encoding", "gzip")]

131 else h

132 else h

132− in W.responseBuilder s h' $ byteStringInsert $ embContent entry

133+ in W.responseBuilder s h' $ insertByteString $ embContent entry

133

134

134 -- Usually the fileName should just be the filename not the entire path,

135 -- Usually the fileName should just be the filename not the entire path,

135 -- but we need the whole path to make the lookup within lookupMime

136 -- but we need the whole path to make the lookup within lookupMime

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

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

1+{-# LANGUAGE OverloadedStrings #-}

1module WaiAppStatic.Types

2module WaiAppStatic.Types

2 ( -- * Pieces

3 ( -- * Pieces

3 Piece

4 Piece

@@ -24,7 +25,7 @@ import qualified Network.Wai as W

24import Data.ByteString (ByteString)

25import Data.ByteString (ByteString)

25import System.Posix.Types (EpochTime)

26import System.Posix.Types (EpochTime)

26import qualified Data.Text as T

27import qualified Data.Text as T

27−import Data.ByteString.Builder (Builder)

28+import Blaze.ByteString.Builder (Builder)

28import Network.Mime (MimeType)

29import Network.Mime (MimeType)

29

30

30-- | An individual component of a path, or of a filepath.

31-- | An individual component of a path, or of a filepath.

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

59toPieces = mapM toPiece

60toPieces = mapM toPiece

60

61

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

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

62−--

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

64type Pieces = [Piece]

63type Pieces = [Piece]

65

64

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

65-- | 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+6−5

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

1name: wai-app-static

2−version: 3.1.7.1

2+version: 3.1.6.1

3license: MIT

4license-file: LICENSE

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

@@ -27,7 +27,7 @@ Flag print

27library

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

29 , wai >= 3.0 && < 3.3

30− , bytestring >= 0.10.4

30+ , bytestring >= 0.9.1.4

31 , http-types >= 0.7

32 , transformers >= 0.2.2

33 , unix-compat >= 0.2

@@ -37,6 +37,7 @@ library

37 , old-locale >= 1.0.0.2

38 , file-embed >= 0.0.3.1

39 , text >= 0.7

40+ , blaze-builder >= 0.2.1.4

40 , cryptonite >= 0.6

41 , cryptonite >= 0.6

41 , memory >= 0.7

42 , memory >= 0.7

42 , http-date

43 , http-date

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

49 , filepath

50 , filepath

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

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

51 , optparse-applicative >= 0.7

52 , optparse-applicative >= 0.7

52− , warp >= 3.0.11 && < 3.4

53+ , warp >= 3.0.11 && < 3.3

53

54

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

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

55 WaiAppStatic.Storage.Filesystem

56 WaiAppStatic.Storage.Filesystem

@@ -73,7 +74,7 @@ Executable warp

73 , wai-app-static

74 , wai-app-static

74 , directory >= 1.0

75 , directory >= 1.0

75 , containers >= 0.2

76 , containers >= 0.2

76− , bytestring >= 0.10.4

77+ , bytestring >= 0.9.1.4

77 , text >= 0.7

78 , text >= 0.7

78 , mime-types >= 0.1 && < 0.2

79 , mime-types >= 0.1 && < 0.2

79

80

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

102 , temporary

103 , temporary

103 , mockery

104 , mockery

104 -- , containers

105 -- , containers

105− ghc-options: -Wall

106+ ghc-options: -Wall

106

107

107source-repository head

108source-repository head

108 type: git

109 type: git

wai-conduit/ChangeLog.md−4

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

1−## 3.0.0.4

2−

3−* Drop dependency on blaze-builder

4−

5## 3.0.0.3

1## 3.0.0.3

6

2

7* Support wai 3.2

3* Support wai 3.2

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

@@ -16,17 +16,18 @@ import Data.ByteString (ByteString)

16import qualified Data.ByteString as S

17import Control.Monad (unless)

18import Network.HTTP.Types

19−import Data.ByteString.Builder (Builder)

19+import Blaze.ByteString.Builder (Builder)

20+import Data.IORef

20import qualified Data.Conduit.List as CL

21import qualified Data.Conduit.List as CL

21

22

22-- | Stream the request body.

23-- | Stream the request body.

23--

24--

24-- Since 3.0.0

25-- Since 3.0.0

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

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

26sourceRequestBody req =

27sourceRequestBody req =

27 loop

28 loop

28 where

29 where

29− go = liftIO (getRequestBodyChunk req)

30+ go = liftIO (requestBody req)

30

31

31 loop = do

32 loop = do

32 bs <- go

33 bs <- go

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

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

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

38--

39--

39-- Since 3.0.0

40-- Since 3.0.0

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

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

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

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

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

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

43 case mbuilder of

44 case mbuilder of

44 Chunk b -> send b

45 Chunk b -> send b

45 Flush -> flush)

46 Flush -> flush)

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

49--

50--

50-- Since 3.0.0

51-- Since 3.0.0

51responseRawSource :: (MonadIO m, MonadIO n)

52responseRawSource :: (MonadIO m, MonadIO n)

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

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

53 -> Response

54 -> Response

55 -> Response

55responseRawSource app =

56responseRawSource app =

wai-conduit/example/Main.hsdeleted−19

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

1−#!/usr/bin/env stack

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

3−import Network.Wai

4−import Network.Wai.Handler.Warp

5−import Network.Wai.Conduit

6−import Network.HTTP.Types

7−import Conduit

8−import Data.ByteString.Builder (byteString)

9−import Control.Monad.Trans.Resource

10−

11−main :: IO ()

12−main = run 3000 app

13−

14−app :: Application

15−app _req respond =

16− runResourceT $ withInternalState $ \is ->

17− respond $ responseSource status200 [] $

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

19− mapC (Chunk . byteString)

wai-conduit/wai-conduit.cabal+3−2

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

1name: wai-conduit

2−version: 3.0.0.4

2+version: 3.0.0.3

3synopsis: conduit wrappers for WAI

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

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

@@ -18,6 +18,7 @@ library

18 , wai >= 3.0 && < 3.3

19 , conduit

20 , transformers

21− , bytestring >= 0.10.4

21+ , bytestring

22 , http-types

23+ , blaze-builder

23 default-language: Haskell2010

24 default-language: Haskell2010

wai-extra/ChangeLog.md−76

@@ -1,79 +1,3 @@

1−# Changelog for wai-extra

2−

3−## 3.0.29.1

4−

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

6−

7−## 3.0.29

8−

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

10−

11−## 3.0.28

12−

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

14−

15−## 3.0.27

16−

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

18−

19−## 3.0.26.1

20−

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

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

23−

24−## 3.0.26

25−

26−* Throw 413 for too large payload

27−* Throw 431 for too large headers

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

29−

30−## 3.0.25

31−

32−* Supporting `network` version 3.0.

33−

34−## 3.0.24.3

35−

36−* Drop unnecessary `lifted-base` dependency

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

38−

39−## 3.0.24.2

40−

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

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

43−

44−## 3.0.24.1

45−

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

47−

48−## 3.0.24.0

49−

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

51−

52−## 3.0.23.0

53−

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

55−

56−## 3.0.22.1

57−

58−* Drop dependency on blaze-builder, requiring streaming-commons >= 0.2

59−

60−## 3.0.22.0

61−

62−* Support for streaming-commons 0.2

63−* Support for resourcet 1.2

64−

65−## 3.0.21.0

66−

67−* Export `Network.Wai.Parse.noLimitParseRequestBodyOptions` [#662](https://github.com/yesodweb/wai/pull/662).

68−

69−## 3.0.20.2

70−

71−* Revert previous change to `srequest`, which caused breakage

72−

73−## 3.0.20.1

74−

75−* Set `requestBodyLength` for `srequest` [#654](https://github.com/yesodweb/wai/pull/654)

76−

77## 3.0.20.0

1## 3.0.20.0

78

2

79* runSessionWith (runSession variant that gives access to ClientState) [#629](https://github.com/yesodweb/wai/pull/629)

3* runSessionWith (runSession variant that gives access to ClientState) [#629](https://github.com/yesodweb/wai/pull/629)

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

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

@@ -9,7 +9,8 @@ module Network.Wai.EventSource.EventStream (

9 eventToBuilder

10 ) where

11

12+import Blaze.ByteString.Builder

12−import Data.ByteString.Builder

13+import Blaze.ByteString.Builder.Char8

13#if __GLASGOW_HASKELL__ < 710

14#if __GLASGOW_HASKELL__ < 710

14import Data.Monoid

15import Data.Monoid

15#endif

16#endif

@@ -38,18 +39,18 @@ data ServerEvent

38 Newline as a Builder.

39 Newline as a Builder.

39-}

40-}

40nl :: Builder

41nl :: Builder

41−nl = char7 '\n'

42+nl = fromChar '\n'

42

43

44

44{-|

45{-|

45 Field names as Builder

46 Field names as Builder

46-}

47-}

47nameField, idField, dataField, retryField, commentField :: Builder

48nameField, idField, dataField, retryField, commentField :: Builder

48−nameField = string7 "event:"

49+nameField = fromString "event:"

49−idField = string7 "id:"

50+idField = fromString "id:"

50−dataField = string7 "data:"

51+dataField = fromString "data:"

51−retryField = string7 "retry:"

52+retryField = fromString "retry:"

52−commentField = char7 ':'

53+commentField = fromChar ':'

53

54

55

55{-|

56{-|

@@ -65,7 +66,7 @@ field l b = l `mappend` b `mappend` nl

65-}

66-}

66eventToBuilder :: ServerEvent -> Maybe Builder

67eventToBuilder :: ServerEvent -> Maybe Builder

67eventToBuilder (CommentEvent txt) = Just $ field commentField txt

68eventToBuilder (CommentEvent txt) = Just $ field commentField txt

68−eventToBuilder (RetryEvent n) = Just $ field retryField (string8 . show $ n)

69+eventToBuilder (RetryEvent n) = Just $ field retryField (fromShow n)

69eventToBuilder (CloseEvent) = Nothing

70eventToBuilder (CloseEvent) = Nothing

70eventToBuilder (ServerEvent n i d)= Just $

71eventToBuilder (ServerEvent n i d)= Just $

71 (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl

72 (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl

wai-extra/Network/Wai/Handler/CGI.hs+16−17

@@ -19,8 +19,8 @@ import Control.Arrow ((***))

19import Data.Char (toLower)

20import qualified System.IO

21import qualified Data.String as String

22−import Data.ByteString.Builder (byteString, toLazyByteString, char7, string8)

22+import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush)

23−import Data.ByteString.Builder.Extra (flush)

23+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)

24import Data.ByteString.Lazy.Internal (defaultChunkSize)

25import System.IO (Handle)

26import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)

@@ -29,8 +29,7 @@ import qualified Data.CaseInsensitive as CI

29#if __GLASGOW_HASKELL__ < 710

30import Data.Monoid (mconcat, mempty, mappend)

31#endif

32−

33−import qualified Data.Streaming.ByteString.Builder as Builder

32+import qualified Data.Streaming.Blaze as Blaze

34import Data.Function (fix)

33import Data.Function (fix)

35import Control.Monad (unless, void)

34import Control.Monad (unless, void)

36

35

@@ -131,7 +130,7 @@ runGeneric vars inputH outputH xsendfile app = do

131 return ResponseReceived

130 return ResponseReceived

132 _ -> do

131 _ -> do

133 let (s, hs, wb) = responseToStream res

132 let (s, hs, wb) = responseToStream res

134− (blazeRecv, blazeFinish) <- Builder.newBuilderRecv Builder.defaultStrategy

133+ (blazeRecv, blazeFinish) <- Blaze.newBlazeRecv Blaze.defaultStrategy

135 wb $ \b -> do

134 wb $ \b -> do

136 let sendBuilder builder = do

135 let sendBuilder builder = do

137 popper <- blazeRecv builder

136 popper <- blazeRecv builder

@@ -140,30 +139,30 @@ runGeneric vars inputH outputH xsendfile app = do

140 unless (B.null bs) $ do

139 unless (B.null bs) $ do

141 outputH bs

140 outputH bs

142 loop

141 loop

143− sendBuilder $ headers s hs `mappend` char7 '\n'

142+ sendBuilder $ headers s hs `mappend` fromChar '\n'

144 b sendBuilder (sendBuilder flush)

143 b sendBuilder (sendBuilder flush)

145 blazeFinish >>= maybe (return ()) outputH

144 blazeFinish >>= maybe (return ()) outputH

146 return ResponseReceived

145 return ResponseReceived

147 where

146 where

148 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))

147 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))

149− status (Status i m) = (byteString "Status", mconcat

148+ status (Status i m) = (fromByteString "Status", mconcat

150− [ string8 $ show i

149+ [ fromString $ show i

151− , char7 ' '

150+ , fromChar ' '

152− , byteString m

151+ , fromByteString m

153 ])

152 ])

154− header' (x, y) = (byteString $ CI.original x, byteString y)

153+ header' (x, y) = (fromByteString $ CI.original x, fromByteString y)

155 header (x, y) = mconcat

154 header (x, y) = mconcat

156 [ x

155 [ x

157− , byteString ": "

156+ , fromByteString ": "

158 , y

157 , y

159− , char7 '\n'

158+ , fromChar '\n'

160 ]

159 ]

161 sfBuilder s hs sf fp = mconcat

160 sfBuilder s hs sf fp = mconcat

162 [ headers s hs

161 [ headers s hs

163− , header $ (byteString sf, string8 fp)

162+ , header $ (fromByteString sf, fromString fp)

164− , char7 '\n'

163+ , fromChar '\n'

165− , byteString sf

164+ , fromByteString sf

166− , byteString " not supported"

165+ , fromByteString " not supported"

167 ]

166 ]

168 fixHeaders h =

167 fixHeaders h =

169 case lookup hContentType h of

168 case lookup hContentType h of

wai-extra/Network/Wai/Header.hs+1−1

@@ -14,5 +14,5 @@ contentLength hdrs = lookup H.hContentLength hdrs >>= readInt

14readInt :: S8.ByteString -> Maybe Integer

15readInt bs =

16 case S8.readInteger bs of

17− Just (i, rest) | S8.null rest -> Just i

17+ Just (i, "") -> Just i

18 _ -> Nothing

wai-extra/Network/Wai/Middleware/Gzip.hs+8−11

@@ -30,14 +30,14 @@ import Data.Default.Class

30import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent

31 , hContentType, hContentLength)

32import System.Directory (doesFileExist, createDirectoryIfMissing)

33−import Data.ByteString.Builder (byteString)

33+import Blaze.ByteString.Builder (fromByteString)

34−import qualified Data.ByteString.Builder.Extra as Blaze (flush)

35import Control.Exception (try, SomeException)

34import Control.Exception (try, SomeException)

36import qualified Data.Set as Set

35import qualified Data.Set as Set

37import Network.Wai.Header

36import Network.Wai.Header

38import Network.Wai.Internal

37import Network.Wai.Internal

39−import qualified Data.Streaming.ByteString.Builder as B

38+import qualified Data.Streaming.Blaze as B

40import qualified Data.Streaming.Zlib as Z

39import qualified Data.Streaming.Zlib as Z

40+import qualified Blaze.ByteString.Builder as Blaze

41import Control.Monad (unless)

42import Data.Function (fix)

43import Control.Exception (throwIO)

@@ -69,7 +69,7 @@ instance Default GzipSettings where

69 def = GzipSettings GzipIgnore defaultCheckMime

70

71-- | MIME types that will be compressed by default:

72−-- @text/@ @*@, @application/json@, @application/javascript@,

72+-- @text/*@, @application/json@, @application/javascript@,

73-- @application/ecmascript@, @image/x-icon@.

74defaultCheckMime :: S.ByteString -> Bool

75defaultCheckMime bs =

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

@@ -104,8 +101,8 @@ gzip set app env sendResponse = app env $ \res ->

104 let

101 let

105 compressedVersion = file ++ ".gz"

102 compressedVersion = file ++ ".gz"

106 in

103 in

107− doesFileExist compressedVersion >>= \y ->

104+ doesFileExist compressedVersion >>= \x ->

108− if y

105+ if x

109 then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing)

106 then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing)

110 else (runAction (ResponseFile s hs file Nothing, nextAction))

107 else (runAction (ResponseFile s hs file Nothing, nextAction))

111 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->

108 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->

@@ -185,7 +182,7 @@ compressE set res sendResponse =

185 Just m | gzipCheckMime set m ->

182 Just m | gzipCheckMime set m ->

186 let hs' = fixHeaders hs

183 let hs' = fixHeaders hs

187 in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do

184 in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do

188− (blazeRecv, _) <- B.newBuilderRecv B.defaultStrategy

185+ (blazeRecv, _) <- B.newBlazeRecv B.defaultStrategy

189 deflate <- Z.initDeflate 1 (Z.WindowBits 31)

186 deflate <- Z.initDeflate 1 (Z.WindowBits 31)

190 let sendBuilder builder = do

187 let sendBuilder builder = do

191 popper <- blazeRecv builder

188 popper <- blazeRecv builder

@@ -204,7 +201,7 @@ compressE set res sendResponse =

204 case result of

201 case result of

205 Z.PRDone -> return ()

202 Z.PRDone -> return ()

206 Z.PRNext bs' -> do

203 Z.PRNext bs' -> do

207− sendChunk $ byteString bs'

204+ sendChunk $ fromByteString bs'

208 loop

205 loop

209 Z.PRError e -> throwIO e

206 Z.PRError e -> throwIO e

210

207

wai-extra/Network/Wai/Middleware/Jsonp.hs+7−7

@@ -18,8 +18,8 @@ import Network.Wai

18import Network.Wai.Internal

19import Data.ByteString (ByteString)

20import qualified Data.ByteString.Char8 as B8

21−import Data.ByteString.Builder.Extra (byteStringCopy)

21+import Blaze.ByteString.Builder (copyByteString)

22−import Data.ByteString.Builder (char7)

22+import Blaze.ByteString.Builder.Char8 (fromChar)

23#if __GLASGOW_HASKELL__ < 710

24import Data.Monoid (mappend)

25#endif

@@ -60,10 +60,10 @@ jsonp app env sendResponse = do

60 sendResponse $ case checkJSON hs of

61 Nothing -> r

62 Just hs' -> responseBuilder s hs' $

63− byteStringCopy c

63+ copyByteString c

64− `mappend` char7 '('

64+ `mappend` fromChar '('

65 `mappend` b

66− `mappend` char7 ')'

66+ `mappend` fromChar ')'

67 go c r =

68 case checkJSON hs of

69 Just hs' -> addCallback c s hs' wb

@@ -81,9 +81,9 @@ jsonp app env sendResponse = do

81

82 addCallback cb s hs wb =

83 wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do

84− sendChunk $ byteStringCopy cb `mappend` char7 '('

84+ sendChunk $ copyByteString cb `mappend` fromChar '('

85 _ <- body sendChunk flush

86− sendChunk $ char7 ')'

86+ sendChunk $ fromChar ')'

87

88changeVal :: Eq a

89 => a

wai-extra/Network/Wai/Middleware/RequestLogger.hs+14−64

@@ -14,16 +14,15 @@ 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 (..)

21 ) where

20 ) where

22

21

23import System.IO (Handle, hFlush, stdout)

22import System.IO (Handle, hFlush, stdout)

24−import qualified Data.ByteString.Builder as B (Builder, byteString)

23+import qualified Blaze.ByteString.Builder as B

25import qualified Data.ByteString as BS

24import qualified Data.ByteString as BS

26−import Data.ByteString.Char8 (pack)

25+import Data.ByteString.Char8 (pack, unpack)

27import Control.Monad (when)

26import Control.Monad (when)

28import Control.Monad.IO.Class (liftIO)

27import Control.Monad.IO.Class (liftIO)

29import Network.Wai

28import Network.Wai

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

41import qualified Data.ByteString.Lazy as LBS

40import qualified Data.ByteString.Lazy as LBS

42import qualified Data.ByteString.Char8 as S8

41import qualified Data.ByteString.Char8 as S8

43import System.Console.ANSI

42import System.Console.ANSI

44−import Data.IORef

43+import Data.IORef.Lifted

45import System.IO.Unsafe

44import System.IO.Unsafe

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

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

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

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

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

50import Network.Wai.Header (contentLength)

49import Network.Wai.Header (contentLength)

51import Data.Text.Encoding (decodeUtf8')

50import Data.Text.Encoding (decodeUtf8')

52

51

53−data OutputFormat

54− = Apache IPAddrSource

52+data OutputFormat = Apache IPAddrSource

55− | Detailed Bool -- ^ use colors?

53+ | Detailed Bool -- ^ use colors?

56− | CustomOutputFormat OutputFormatter

54+ | CustomOutputFormat OutputFormatter

57− | CustomOutputFormatWithDetails OutputFormatterWithDetails

55+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

58− | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

59

56

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

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

61−

62−type OutputFormatterWithDetails

58+type OutputFormatterWithDetails =

63− = ZonedDate

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

64− -> Request

65− -> Status

66− -> Maybe Integer

67− -> NominalDiffTime

68− -> [S8.ByteString]

69− -> B.Builder

70− -> LogStr

71−

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

73−--

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

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

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

77−--

78−-- @since 3.0.27

79−type OutputFormatterWithDetailsAndHeaders

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

81− -> Request -- ^ The WAI request

82− -> Status -- ^ HTTP status code

83− -> Maybe Integer -- ^ Response size

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

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

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

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

88− -> LogStr

89

60

90data Destination = Handle Handle

61data Destination = Handle Handle

91 | Logger LoggerSet

62 | Logger LoggerSet

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

137 CustomOutputFormatWithDetails formatter -> do

108 CustomOutputFormatWithDetails formatter -> do

138 getdate <- getDateGetter flusher

109 getdate <- getDateGetter flusher

139 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

110 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

140− CustomOutputFormatWithDetailsAndHeaders formatter -> do

141− getdate <- getDateGetter flusher

142− return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

143

111

144apacheMiddleware :: ApacheLoggerActions -> Middleware

112apacheMiddleware :: ApacheLoggerActions -> Middleware

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

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

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

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

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

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

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

152 date <- liftIO getdate

120 date <- liftIO getdate

153− let msize = contentLength (responseHeaders res)

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

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

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

155 sendResponse res

123 sendResponse res

156

124

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

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

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

161 app req' $ \res -> do

129 app req' $ \res -> do

162 t1 <- getCurrentTime

130 t1 <- getCurrentTime

163 date <- liftIO getdate

131 date <- liftIO getdate

164− let msize = contentLength (responseHeaders res)

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

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

133+ builderIO <- newIORef $ B.fromByteString ""

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

@@ -1,13 +1,8 @@

1{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE CPP #-}

3

2

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

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

5− ( formatAsJSON

6− , formatAsJSONWithHeaders

7− ) where

8

4

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

5+import qualified Blaze.ByteString.Builder as BB

10−import Data.ByteString.Lazy (toStrict)

11import Data.Aeson

6import Data.Aeson

12import Data.CaseInsensitive (original)

7import Data.CaseInsensitive (original)

13import Data.Monoid ((<>))

8import Data.Monoid ((<>))

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

15import Data.IP

10import Data.IP

16import qualified Data.Text as T

11import qualified Data.Text as T

17import Data.Text (Text)

12import Data.Text (Text)

18−import Data.Text.Encoding (decodeUtf8With)

13+import Data.Text.Encoding (decodeUtf8)

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

20import Data.Time (NominalDiffTime)

14import Data.Time (NominalDiffTime)

21import Data.Word (Word32)

15import Data.Word (Word32)

22import Network.HTTP.Types as H

16import Network.HTTP.Types as H

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

37 , "size" .= responseSize

31 , "size" .= responseSize

38 , "body" .=

32 , "body" .=

39 if statusCode status >= 400

33 if statusCode status >= 400

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

34+ then Just . decodeUtf8 . BB.toByteString $ response

41 else Nothing

35 else Nothing

42 ]

36 ]

43− , "time" .= decodeUtf8With lenientDecode date

37+ , "time" .= decodeUtf8 date

44− ]) <> "\n"

45−

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

47−--

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

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

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

51−--

52−-- @since 3.0.27

53−formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders

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

55− toLogStr (encode $

56− object

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

58− , "response" .= object

59− [ "status" .= statusCode status

60− , "size" .= resSize

61− , "headers" .= responseHeadersToJSON resHeaders

62− , "body" .=

63− if statusCode status >= 400

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

65− else Nothing

66− ]

67− , "time" .= decodeUtf8With lenientDecode date

68 ]) <> "\n"

38 ]) <> "\n"

69

39

70word32ToHostAddress :: Word32 -> Text

40word32ToHostAddress :: Word32 -> Text

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

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

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

77requestToJSON duration req reqBody =

47requestToJSON duration req reqBody =

78 object

48 object

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

103 ]

73 ]

104sockToJSON (SockAddrUnix sock) =

74sockToJSON (SockAddrUnix sock) =

105 object [ "unix" .= sock ]

75 object [ "unix" .= sock ]

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

107sockToJSON (SockAddrCan i) =

76sockToJSON (SockAddrCan i) =

108 object [ "can" .= i ]

77 object [ "can" .= i ]

109−#endif

110

78

111queryItemToJSON :: QueryItem -> Value

79queryItemToJSON :: QueryItem -> Value

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

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

113

81

114requestHeadersToJSON :: RequestHeaders -> Value

82requestHeadersToJSON :: RequestHeaders -> Value

115requestHeadersToJSON = toJSON . map hToJ where

83requestHeadersToJSON = toJSON . map hToJ where

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

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

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

118 hToJ hd = headerToJSON hd

86 hToJ hd = headerToJSON hd

119

87

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

88headerToJSON :: Header -> Value

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

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

128

90

129portToJSON :: PortNumber -> Value

91portToJSON :: PortNumber -> Value

130portToJSON = toJSON . toInteger

92portToJSON = toJSON . toInteger

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

@@ -27,7 +27,6 @@ module Network.Wai.Middleware.Rewrite

27 -- ** Recommended functions

28 , rewriteWithQueries

29 , rewritePureWithQueries

30− , rewriteRoot

31

30

32 -- ** Deprecated

31 -- ** Deprecated

33 , rewrite

32 , rewrite

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

169--

168--

170-- as the following example demonstrates.

169-- as the following example demonstrates.

171--

170--

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

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

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

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

174--

173--

175-- @

174-- @

@@ -264,21 +263,6 @@ rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQuerie

264 -> Middleware

263 -> Middleware

265rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req

264rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req

266

265

267−-- | Rewrite root requests (/) to a specified path

268−--

269−-- Note that /index.html/ in example below should already be a valid route.

270−--

271−-- @

272−-- rewriteRoot "index.html" :: Middleware

273−-- @

274−--

275−-- @since 3.0.23.0

276−rewriteRoot :: Text -> Middleware

277−rewriteRoot root = rewritePureWithQueries onlyRoot

278− where

279− onlyRoot ([], q) _ = ([root], q)

280− onlyRoot paths _ = paths

281−

282--------------------------------------------------

266--------------------------------------------------

283-- * Modifying 'Request's directly

267-- * Modifying 'Request's directly

284--------------------------------------------------

268--------------------------------------------------

wai-extra/Network/Wai/Middleware/Timeout.hsdeleted−33

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

1−-- | Timeout requests

2−module Network.Wai.Middleware.Timeout

3− ( timeout

4− , timeoutStatus

5− , timeoutAs

6− ) where

7−

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

9−import Network.Wai

10−import qualified System.Timeout as Timeout

11−

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

13−--

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

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

16−--

17−-- @since 3.0.24.0@

18−timeout :: Int -> Middleware

19−timeout = timeoutStatus status503

20−

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

22−--

23−-- @since 3.0.24.0@

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

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

26−

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

28−--

29−-- @since 3.0.24.0@

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

31−timeoutAs timeoutReponse seconds app req respond =

32− maybe (respond timeoutReponse) pure

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

wai-extra/Network/Wai/Parse.hs+10−25

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

22 , parseContentType

23 , ParseRequestBodyOptions

24 , defaultParseRequestBodyOptions

25− , noLimitParseRequestBodyOptions

26 , parseRequestBodyEx

25 , parseRequestBodyEx

27 , setMaxRequestKeyLength

26 , setMaxRequestKeyLength

28 , clearMaxRequestKeyLength

27 , clearMaxRequestKeyLength

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

48#endif

47#endif

49 ) where

48 ) where

50

49

51−import qualified Control.Exception as E

50+import qualified Data.ByteString.Search as Search

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

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

59import Data.Function (on, fix)

58import Data.Function (on, fix)

60import System.Directory (removeFile, getTemporaryDirectory)

59import System.Directory (removeFile, getTemporaryDirectory)

61import System.IO (hClose, openBinaryTempFile)

60import System.IO (hClose, openBinaryTempFile)

62−import System.IO.Error (isDoesNotExistError)

63import Network.Wai

61import Network.Wai

64import qualified Network.HTTP.Types as H

62import qualified Network.HTTP.Types as H

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

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

66−import Control.Exception (catchJust)

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

64+import Control.Monad (when, unless)

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

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

69import Data.IORef

66import Data.IORef

70import Network.HTTP.Types (hContentType)

67import Network.HTTP.Types (hContentType)

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

72import Data.CaseInsensitive (mk)

68import Data.CaseInsensitive (mk)

73

69

74import Prelude hiding (lines)

70import Prelude hiding (lines)

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

131 -> IO FilePath

127 -> IO FilePath

132tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

128tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

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

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

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

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

135 fix $ \loop -> do

131 fix $ \loop -> do

136 bs <- popper

132 bs <- popper

137 unless (S.null bs) $ do

133 unless (S.null bs) $ do

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

143 it = do

139 it = do

144 tempDir <- getTmpDir

140 tempDir <- getTmpDir

145 openBinaryTempFile tempDir pattrn

141 openBinaryTempFile tempDir pattrn

146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)

147− (removeFile fp)

148− (const $ return ())

149

142

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

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

151-- the parseRequestBodyEx function.

144-- the parseRequestBodyEx function.

@@ -273,7 +266,7 @@ defaultParseRequestBodyOptions = ParseRequestBodyOptions

273

266

274-- | Do not impose any memory limits.

267-- | Do not impose any memory limits.

275--

268--

276−-- @since 3.0.21.0

269+-- @since 3.0.16.0

277noLimitParseRequestBodyOptions :: ParseRequestBodyOptions

270noLimitParseRequestBodyOptions :: ParseRequestBodyOptions

278noLimitParseRequestBodyOptions = ParseRequestBodyOptions

271noLimitParseRequestBodyOptions = ParseRequestBodyOptions

279 { prboKeyLength=Nothing

272 { prboKeyLength=Nothing

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

337 semicolon = 59

330 semicolon = 59

338 equals = 61

331 equals = 61

339 space = 32

332 space = 32

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

341− then S.tail $ S.init s

342− else s

343 goAttrs front bs

333 goAttrs front bs

344 | S.null bs = front []

334 | S.null bs = front []

345 | otherwise =

335 | otherwise =

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

348 goAttr bs =

338 goAttr bs =

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

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

350 v = S.drop 1 v'

340 v = S.drop 1 v'

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

341+ in (strip k, strip v)

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

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

353

343

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

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

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

428

418

429

419

430-- | Take one header or subheader line.

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

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

434takeLine maxlen src =

422takeLine maxlen src =

435 go ""

423 go ""

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

438 bs <- readSource src

426 bs <- readSource src

439 case maxlen of

427 case maxlen of

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

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

441− E.throwIO $ ConnectionError (UnknownErrorCode 431)

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

442− "Request Header Fields Too Large"

443 Nothing -> return ()

430 Nothing -> return ()

444 if S.null bs

431 if S.null bs

445 then close front

432 then close front

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

455 let res = front `S.append` x

442 let res = front `S.append` x

456 case maxlen of

443 case maxlen of

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

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

458− E.throwIO $ ConnectionError (UnknownErrorCode 431)

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

459− "Request Header Fields Too Large"

460 Nothing -> return ()

446 Nothing -> return ()

461 return $ Just $ killCR $ res

447 return $ Just $ killCR $ res

462

448

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

582 deriving (Eq, Show)

568 deriving (Eq, Show)

583

569

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

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

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

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

586 where

572 where

587 handleBreak (h, t)

573 handleBreak (h, t)

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

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

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

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

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

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

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

647 case max' of

633 case max' of

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

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

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

650− _ -> return ()

635+ _ -> return ()

651 if S.null bs

636 if S.null bs

652 then do

637 then do

653 writeIORef ref $ WTBDone False

638 writeIORef ref $ WTBDone False

wai-extra/Network/Wai/Test.hs+18−25

@@ -52,7 +52,8 @@ import qualified Data.Map as Map

52import qualified Web.Cookie as Cookie

53import Data.ByteString (ByteString)

54import qualified Data.ByteString.Char8 as S8

55−import Data.ByteString.Builder (toLazyByteString)

55+import Blaze.ByteString.Builder (toLazyByteString, toByteString)

56+import qualified Blaze.ByteString.Builder as B

56import qualified Data.ByteString.Lazy as L

57import qualified Data.ByteString.Lazy as L

57import qualified Data.ByteString.Lazy.Char8 as L8

58import qualified Data.ByteString.Lazy.Char8 as L8

58import qualified Network.HTTP.Types as H

59import qualified Network.HTTP.Types as H

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

99data SRequest = SRequest

100data SRequest = SRequest

100 { simpleRequest :: Request

101 { simpleRequest :: Request

101 , simpleRequestBody :: L.ByteString

102 , 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 }

103 }

107data SResponse = SResponse

104data SResponse = SResponse

108 { simpleStatus :: H.Status

105 { simpleStatus :: H.Status

@@ -110,22 +107,14 @@ data SResponse = SResponse

110 , simpleBody :: L.ByteString

107 , simpleBody :: L.ByteString

111 }

108 }

112 deriving (Show, Eq)

109 deriving (Show, Eq)

113−

114request :: Request -> Session SResponse

110request :: Request -> Session SResponse

115−request req = do

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

112

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

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

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

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

126setPath req path = req {

115setPath req path = req {

127 pathInfo = segments

116 pathInfo = segments

128− , rawPathInfo = (L8.toStrict . toLazyByteString) (H.encodePathSegments segments)

117+ , rawPathInfo = B.toByteString (H.encodePathSegments segments)

129 , queryString = query

118 , queryString = query

130 , rawQueryString = (H.renderQuery True query)

119 , rawQueryString = (H.renderQuery True query)

131 }

120 }

@@ -154,7 +143,7 @@ addCookiesToRequest req = do

154 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)

143 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)

155 | c <- map snd $ Map.toList cookiesForRequest

144 | c <- map snd $ Map.toList cookiesForRequest

156 ]

145 ]

157− let cookieValue = L8.toStrict . toLazyByteString $ Cookie.renderCookies cookiePairs

146+ let cookieValue = toByteString $ Cookie.renderCookies cookiePairs

158 addCookieHeader rest

147 addCookieHeader rest

159 | null cookiePairs = rest

148 | null cookiePairs = rest

160 | otherwise = ("Cookie", cookieValue) : rest

149 | otherwise = ("Cookie", cookieValue) : rest

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

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

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

179 return response

168 return response

180

169

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

182−-- 'L.ByteString'.

183srequest :: SRequest -> Session SResponse

170srequest :: SRequest -> Session SResponse

184srequest (SRequest req bod) = do

171srequest (SRequest req bod) = do

172+ app <- ask

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

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

186− request $

187− req

174+ let req' = req

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

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

189− case bss of

176+ case bss of

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

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

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

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

192− }

179+ }

180+ req'' <- addCookiesToRequest req'

181+ response <- liftIO $ do

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

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

184+ readIORef ref

185+ extractSetCookieFromSResponse response

193

186

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

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

195runResponse ref res = do

188runResponse ref res = do

wai-extra/README.md+1−14

@@ -1,16 +1,3 @@

1−# wai-extra

1+## wai-extra

2

3The goal here is to provide common features without many dependencies.

4−

5−

6−## Example using Server-Sent Events ##

7−

8−There is a small example using Server-Sent Events (SSE) in the

9−`./example` directory.

10−

11−Run the commands below to start the server on http://localhost:8080

12−

13−```

14−$ stack build .

15−$ stack exec example

16−```

wai-extra/app/Main.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Main where

3+

4+import Control.Monad

5+import Control.Concurrent (forkIO, threadDelay)

6+import Control.Monad.Trans (liftIO)

7+import Control.Concurrent.Chan

8+import Network.Wai.Handler.Warp (run)

9+import Network.Wai.Middleware.Gzip (gzip, def)

10+import Network.Wai

11+import Network.HTTP.Types (status200)

12+import Data.Time.Clock.POSIX

13+import Blaze.ByteString.Builder.Char.Utf8 (fromString)

14+import qualified Data.Conduit as C

15+

16+import Network.Wai.EventSource

17+

18+app :: Chan ServerEvent -> Application

19+app chan req =

20+ case pathInfo req of

21+ [] -> return $ ResponseFile status200 [("Content-Type", "text/html")] "static/index.html" Nothing

22+ ["esold"] -> eventSourceAppChan chan req

23+ ["eschan"] -> eventSourceAppChan chan req

24+ ["esio"] -> eventSourceAppIO eventIO req

25+ ["essrc"] -> eventSourceAppSource eventSource req

26+ _ -> error "unexpected pathInfo"

27+

28+eventChan :: Chan ServerEvent -> IO ()

29+eventChan chan = forever $ do

30+ threadDelay 1000000

31+ time <- getPOSIXTime

32+ writeChan chan (ServerEvent Nothing Nothing [fromString . show $ time])

33+

34+eventIO :: IO ServerEvent

35+eventIO = do

36+ threadDelay 1000000

37+ time <- getPOSIXTime

38+ return $ ServerEvent (Just $ fromString "io")

39+ Nothing

40+ [fromString . show $ time]

41+

42+eventSource :: C.Source (C.ResourceT IO) ServerEvent

43+eventSource = forever $ do

44+ time <- liftIO $ do

45+ threadDelay 1000000

46+ getPOSIXTime

47+ C.yield $ ServerEvent (Just $ fromString "source")

48+ Nothing

49+ [fromString . show $ time]

50+

51+main = do

52+ chan <- newChan

53+ _ <- forkIO . eventChan $ chan

54+ run 8080 (gzip def $ app chan)

55+

wai-extra/example/index.html → wai-extra/app/index.htmlrenamed+2−3

@@ -1,9 +1,8 @@

1<!doctype html>

2<head>

3− <title>Example</title>

3+ <title>Hello</title>

4− <link rel="icon" href="data:;base64,=">

5</head>

4</head>

6−<h1>Testing Server-Sent Events</h1>

5+<h1>Testing</h1>

7

6

8<div id="output"></div>

7<div id="output"></div>

9

8

wai-extra/example/Main.hsdeleted−62

@@ -1,62 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Main where

3−

4−import Data.ByteString.Builder (string8)

5−import Control.Concurrent (forkIO, threadDelay)

6−import Control.Concurrent.Chan

7−import Control.Monad

8−import Data.Time.Clock.POSIX (getPOSIXTime)

9−import Network.HTTP.Types (status200)

10−import Network.Wai (Application, Middleware, pathInfo, responseFile)

11−import Network.Wai.EventSource (ServerEvent(..), eventSourceAppChan, eventSourceAppIO)

12−import Network.Wai.Handler.Warp (run)

13−import Network.Wai.Middleware.AddHeaders (addHeaders)

14−import Network.Wai.Middleware.Gzip (gzip, def)

15−

16−

17−app :: Chan ServerEvent -> Application

18−app chan req respond =

19− case pathInfo req of

20− [] -> respond $ responseFile status200 [("Content-Type", "text/html")] "example/index.html" Nothing

21− ["esold"] -> eventSourceAppChan chan req respond

22− ["eschan"] -> eventSourceAppChan chan req respond

23− ["esio"] -> eventSourceAppIO eventIO req respond

24− _ -> error "unexpected pathInfo"

25−

26−eventChan :: Chan ServerEvent -> IO ()

27−eventChan chan = forever $ do

28− threadDelay 1000000

29− time <- getPOSIXTime

30− writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time])

31−

32−eventIO :: IO ServerEvent

33−eventIO = do

34− threadDelay 1000000

35− time <- getPOSIXTime

36− return $ ServerEvent (Just $ string8 "io")

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−

51−main :: IO ()

52−main = do

53− chan <- newChan

54− _ <- forkIO . eventChan $ chan

55− run 8080 (gzip def $ headers $ app chan)

56− where

57− -- headers required for SSE to work through nginx

58− -- not required if using warp directly

59− headers :: Middleware

60− headers = addHeaders [ ("X-Accel-Buffering", "no")

61− , ("Cache-Control", "no-cache")

62− ]

wai-extra/test/Network/Wai/Middleware/TimeoutSpec.hsdeleted−57

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module Network.Wai.Middleware.TimeoutSpec

4− ( spec

5− ) where

6−

7−import Test.Hspec

8−

9−import Control.Concurrent (threadDelay)

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

11−import Network.Wai

12−import Network.Wai.Middleware.Timeout

13−import Network.Wai.Test

14−

15−spec :: Spec

16−spec = do

17− describe "timeout" $ do

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

19− let app _req respond = do

20− threadDelay $ 2 * 1000000

21− respond $ responseLBS status200 [] ""

22−

23− resp <- runApp $ timeout 1 app

24−

25− simpleStatus resp `shouldBe` status503

26−

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

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

29−

30− resp <- runApp $ timeout 3 app

31−

32− simpleStatus resp `shouldBe` status200

33−

34− describe "timeoutStatus" $ do

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

36− let app _req respond = do

37− threadDelay $ 2 * 1000000

38− respond $ responseLBS status200 [] ""

39−

40− resp <- runApp $ timeoutStatus status504 1 app

41−

42− simpleStatus resp `shouldBe` status504

43−

44− describe "timeoutAs" $ do

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

46− let app _req respond = do

47− threadDelay $ 2 * 1000000

48− respond $ responseLBS status200 [] ""

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

50−

51− resp <- runApp $ timeoutAs timeoutResponse 1 app

52−

53− simpleStatus resp `shouldBe` status503

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

55−

56−runApp :: Application -> IO SResponse

57−runApp = runSession $ request defaultRequest

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

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

13import qualified Data.Text as TS

14import qualified Data.Text.Encoding as TE

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

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

17

16

18import Network.Wai

17import Network.Wai

19import Network.Wai.Test

18import Network.Wai.Test

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

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

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

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

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

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

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

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

35 ]

33 ]

36 it "parseHttpAccept" caseParseHttpAccept

34 it "parseHttpAccept" caseParseHttpAccept

37 describe "parseRequestBody" $ do

35 describe "parseRequestBody" $ do

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

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

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

96 let expected3 = (expectedsmap3, expectedfile3)

94 let expected3 = (expectedsmap3, expectedfile3)

97

95

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

99− unknownErrorException _ _ = False

100−

101

96

102 let def = defaultParseRequestBodyOptions

97 let def = defaultParseRequestBodyOptions

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

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

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

123

118

124 it "exceeding file size" $ do

119 it "exceeding file size" $ do

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

120 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

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

127− `shouldThrow` unknownErrorException 413

128

122

129 it "exceeding total file size" $ do

123 it "exceeding total file size" $ do

130 SRequest req4 _bod4 <- toRequest'' ctype3 content3

124 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

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

132− `shouldThrow` unknownErrorException 413

133 SRequest req5 _bod5 <- toRequest'' ctype3 content5

126 SRequest req5 _bod5 <- toRequest'' ctype3 content5

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

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

135− `shouldThrow` unknownErrorException 413

136

128

137 it "exceeding max parm value size" $ do

129 it "exceeding max parm value size" $ do

138 SRequest req4 _bod4 <- toRequest'' ctype2 content2

130 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

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

140− `shouldThrow` unknownErrorException 413

141

132

142 it "exceeding max header lines" $ do

133 it "exceeding max header lines" $ do

143 SRequest req4 _bod4 <- toRequest'' ctype2 content2

134 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

145

136

146 it "exceeding header line size" $ do

137 it "exceeding header line size" $ do

147 SRequest req4 _bod4 <- toRequest'' ctype3 content4

138 SRequest req4 _bod4 <- toRequest'' ctype3 content4

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

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

149− `shouldThrow` unknownErrorException 431

150

140

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

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

152 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

142 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

wai-extra/test/Network/Wai/TestSpec.hs+12−46

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

@@ -18,17 +16,13 @@ import Network.Wai.Test

18import Network.HTTP.Types (status200)

16import Network.HTTP.Types (status200)

19

17

20import qualified Data.ByteString.Lazy.Char8 as L8

18import qualified Data.ByteString.Lazy.Char8 as L8

21−import Data.ByteString.Builder (Builder, toLazyByteString)

19+import Blaze.ByteString.Builder (toByteString)

22−import Data.ByteString (ByteString)

23

20

24import qualified Web.Cookie as Cookie

21import qualified Web.Cookie as Cookie

25

22

26main :: IO ()

23main :: IO ()

27main = hspec spec

24main = hspec spec

28

25

29−toByteString :: Builder -> ByteString

30−toByteString = L8.toStrict . toLazyByteString

31−

32spec :: Spec

26spec :: Spec

33spec = do

27spec = do

34 describe "setPath" $ do

28 describe "setPath" $ do

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

55 it "sets rawQueryString to empty string" $ do

49 it "sets rawQueryString to empty string" $ do

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

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

57

51

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

52 describe "request" $ do

75

53

76− let echoApp req respond = do

54+ let simpleApp _req respond =

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

78− let reqHeaders = requestHeaders req

79 respond $

55 respond $

80 responseLBS

56 responseLBS

81 status200

57 status200

82− reqHeaders

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

83− reqBody

59+ "simple"

84

60

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

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

86− sresp <- runSession (request defaultRequest) echoApp

62+ sresp <- runSession (request defaultRequest) simpleApp

87 simpleStatus sresp `shouldBe` status200

63 simpleStatus sresp `shouldBe` status200

88

64

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

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

66+ sresp <- runSession (request defaultRequest) simpleApp

95− { requestBody = getBodyChunk

96− }

97− simpleBody sresp `shouldBe` "request body"

67+ simpleBody sresp `shouldBe` "simple"

98−

68+

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

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

100− sresp <- flip runSession echoApp $

101− request $

102− defaultRequest

70+ sresp <- runSession (request defaultRequest) simpleApp

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

104− }

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

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

106

72

107 let cookieApp req respond =

73 let cookieApp req respond =

wai-extra/wai-extra.cabal+11−32

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

1Name: wai-extra

2−Version: 3.0.29.1

2+Version: 3.0.20.0

3Synopsis: Provides some basic WAI handlers and middleware.

4description:

5 Provides basic WAI handler and middleware functionality:

@@ -81,41 +81,38 @@ extra-source-files:

81 ChangeLog.md

82 README.md

83

84−flag build-example

85− description: Build example executable.

86− manual: True

87− default: False

88−

89Library

84Library

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

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

91− , bytestring >= 0.10.4

86+ , bytestring >= 0.9.1.4

92 , wai >= 3.0.3.0 && < 3.3

87 , wai >= 3.0.3.0 && < 3.3

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

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

94 , time >= 1.1.4

89 , time >= 1.1.4

95 , network >= 2.6.1.0

90 , network >= 2.6.1.0

96 , directory >= 1.0.1

91 , directory >= 1.0.1

97 , transformers >= 0.2.2

92 , transformers >= 0.2.2

93+ , blaze-builder >= 0.2.1.4 && < 0.5

98 , http-types >= 0.7

94 , http-types >= 0.7

99 , text >= 0.7

95 , text >= 0.7

100 , case-insensitive >= 0.2

96 , case-insensitive >= 0.2

101 , data-default-class

97 , data-default-class

102− , fast-logger >= 2.4.5

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

103− , wai-logger >= 2.3.2

99+ , wai-logger >= 2.2.6 && < 2.4

104 , ansi-terminal

100 , ansi-terminal

105− , resourcet >= 0.4.6 && < 1.3

101+ , resourcet >= 0.4.6 && < 1.2

106 , void >= 0.5

102 , void >= 0.5

103+ , stringsearch >= 0.3 && < 0.4

107 , containers

104 , containers

108 , base64-bytestring

105 , base64-bytestring

109 , word8

106 , word8

107+ , lifted-base >= 0.1.2

110 , deepseq

108 , deepseq

111− , streaming-commons >= 0.2

109+ , streaming-commons

112 , unix-compat

110 , unix-compat

113 , cookie

111 , cookie

114 , vault

112 , vault

115 , zlib

113 , zlib

116 , aeson

114 , aeson

117 , iproute

115 , iproute

118− , http2

119

116

120 if os(windows)

117 if os(windows)

121 cpp-options: -DWINDOWS

118 cpp-options: -DWINDOWS

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

147 Network.Wai.Middleware.ForceDomain

144 Network.Wai.Middleware.ForceDomain

148 Network.Wai.Middleware.ForceSSL

145 Network.Wai.Middleware.ForceSSL

149 Network.Wai.Middleware.Routed

146 Network.Wai.Middleware.Routed

150− Network.Wai.Middleware.Timeout

151 Network.Wai.Parse

147 Network.Wai.Parse

152 Network.Wai.Request

148 Network.Wai.Request

153 Network.Wai.UrlMap

149 Network.Wai.UrlMap

@@ -159,22 +155,6 @@ Library

159 default-language: Haskell2010

155 default-language: Haskell2010

160 ghc-options: -Wall

156 ghc-options: -Wall

161

157

162−executable example

163− hs-source-dirs: example

164− main-is: Main.hs

165− ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall

166− if flag(build-example)

167− build-depends: base

168− , wai-extra

169− , warp

170− , wai

171− , time

172− , http-types

173− , bytestring

174− else

175− buildable: False

176− default-language: Haskell2010

177−

178test-suite spec

158test-suite spec

179 type: exitcode-stdio-1.0

159 type: exitcode-stdio-1.0

180 hs-source-dirs: test

160 hs-source-dirs: test

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

186 Network.Wai.Middleware.ForceSSLSpec

166 Network.Wai.Middleware.ForceSSLSpec

187 Network.Wai.Middleware.RoutedSpec

167 Network.Wai.Middleware.RoutedSpec

188 Network.Wai.Middleware.StripHeadersSpec

168 Network.Wai.Middleware.StripHeadersSpec

189− Network.Wai.Middleware.TimeoutSpec

190 WaiExtraSpec

169 WaiExtraSpec

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

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

192 , wai-extra

171 , wai-extra

@@ -200,10 +179,10 @@ test-suite spec

200 , resourcet

179 , resourcet

201 , bytestring

180 , bytestring

202 , HUnit

181 , HUnit

182+ , blaze-builder

203 , cookie

183 , cookie

204 , time

184 , time

205 , case-insensitive

185 , case-insensitive

206− , http2

207 ghc-options: -Wall

186 ghc-options: -Wall

208 default-language: Haskell2010

187 default-language: Haskell2010

209

188

wai-handler-fastcgi/.gitignorenew file+4

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

1+/dist/

2+*.swp

3+*.hi

4+*.o

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

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

1+## 3.0.0.2

2+

3+* Support wai 3.2

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

The content is the same.

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

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

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+{-# LANGUAGE EmptyDataDecls #-}

3+{-# LANGUAGE CPP #-}

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

5+-- |

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

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

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

9+--

10+-- Maintainer : michael@snoyman.com

11+-- Stability : experimental

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

13+--

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

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

16+--

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

18+module Network.Wai.Handler.FastCGI

19+ ( run

20+ , runSendfile

21+ , runFork

22+ ) where

23+

24+import Control.Monad ( liftM, forever )

25+import Data.Word (Word8)

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

27+ , throwIfNeg_, mallocBytes, free )

28+#ifdef GHC_7_4

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

30+#else

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

32+#endif

33+import Control.Exception (finally)

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

35+

36+import qualified Network.Wai as W

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

38+

39+import qualified Data.ByteString as S

40+import qualified Data.ByteString.Char8 as S8

41+import qualified Data.ByteString as BS

42+import qualified Data.ByteString.Internal as BSB

43+import qualified Data.ByteString.Unsafe as BSB

44+

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

46+

47+#include <fcgiapp.h>

48+

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

50+

51+data FCGX_Stream

52+type StreamPtr = Ptr FCGX_Stream

53+type Environ = Ptr CString

54+

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

56+

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

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

59+

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

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

62+

63+

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

65+

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

67+ :: IO CInt

68+

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

70+runFork sf fork threads app = do

71+ testReturn "FCGX_Init" $ fcgx_init

72+ let oneThread = forever $ oneRequest app sf

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

74+ oneThread

75+

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

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

78+run = runFork Nothing id 1

79+

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

81+-- the X-Sendfile header.

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

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

84+

85+oneRequest :: W.Application

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

87+ -> IO ()

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

89+ putStrLn "Received 1 request"

90+ env <- peekEnvp r

91+ ins <- peekIn r

92+ outs <- peekOut r

93+ handleRequest app ins outs env xsendfile

94+

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

96+peekIn = (#peek FCGX_Request, in)

97+peekOut = (#peek FCGX_Request, out)

98+

99+peekEnvp :: Ptr FCGX_Request -> IO Environ

100+peekEnvp = (#peek FCGX_Request, envp)

101+

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

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

104+

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

106+ :: Ptr FCGX_Request -> IO CInt

107+

108+acceptRequest :: IO (Ptr FCGX_Request)

109+acceptRequest = do

110+ reqp <- mallocBytes (#size FCGX_Request)

111+ initAndAccept reqp

112+ return reqp

113+ where initAndAccept reqp = do

114+ testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0

115+ testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp

116+

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

118+withRequest f = do

119+ req <- acceptRequest

120+ f req `finally` finishRequest req

121+

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

123+ :: Ptr FCGX_Request -> IO ()

124+

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

126+finishRequest reqp = do

127+ fcgx_finish_r reqp

128+ free reqp

129+

130+handleRequest :: W.Application

131+ -> StreamPtr

132+ -> StreamPtr

133+ -> Environ

134+ -> Maybe S.ByteString -- sendfile

135+ -> IO ()

136+handleRequest f ins outs env xsendfile = do

137+ vars <- environToTable env

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

139+ let input = const $ sRead ins

140+ let hPut = sPutStr' outs

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

142+

143+data FCGX_Request

144+

145+--

146+-- * Stream IO

147+--

148+

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

150+sPutStr' h str =

151+ BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h

152+

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

154+fcgxPutCStringLen h (cs,len) =

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

156+

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

158+sRead h = buildByteString (fcgxGetBuf h) 4096

159+

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

161+fcgxGetBuf h p c =

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

163+

164+--

165+-- * ByteString utilities

166+--

167+

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

169+-- reading functions.

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

171+buildByteString f k = do

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

173+ case BS.length ps of

174+ 0 -> return Nothing

175+ _ -> return $ Just ps

176+

177+--

178+-- * Utilities

179+--

180+

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

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

183+

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

185+environToTable arr = do

186+ css <- peekArray0 nullPtr arr

187+ ss <- mapM S.packCString css

188+ return $ map splitEq ss

189+ where

190+ splitEq s =

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

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

wai-handler-fastcgi/READMEnew file

No changes to the content.

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

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

1+## wai-handler-fastcgi

2+

3+Calls out to the libfcgi C library.

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

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-fastcgi/configurenew file+9

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

1+#!/bin/sh

2+#

3+

4+# subst standard header path variables

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

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

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

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

9+fi

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

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

1+ghc-options: -optc@CPPFLAGS@

2+cc-options: @CPPFLAGS@

3+ld-options: @LDFLAGS@

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

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

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

2+server.port = 3000

3+server.document-root = "."

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

5+

6+url.rewrite-once = (

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

8+)

9+

10+fastcgi.server = (

11+ "/app" => ((

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

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

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

15+ "min-procs" => 1,

16+ "max-procs" => 12,

17+ "idle-timeout" => 30

18+ ))

19+)

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

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.FastCGI

4+import Control.Monad.IO.Class

5+import qualified Data.ByteString.Lazy as L

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

7+import qualified Data.Enumerator as E

8+

9+main = run app

10+

11+app req

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

13+app req = do

14+ bss <- E.consume

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

16+ [ L8.pack $ show $ requestHeaders req

17+ , "\n"

18+ , L.fromChunks bss

19+ ]

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

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

1+name: wai-handler-fastcgi

2+version: 3.0.0.2

3+license: MIT

4+license-file: LICENSE

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

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

7+synopsis: Wai handler to fastcgi

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

9+category: Web

10+stability: stable

11+cabal-version: >= 1.6

12+build-type: Configure

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

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

15+

16+library

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

18+ , wai >= 3.0 && < 3.3

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

20+ , bytestring >= 0.9.1.4

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

22+ ghc-options: -Wall

23+ includes: fcgiapp.h

24+ extra-libraries: fcgi

25+

26+ if impl(ghc >= 7.4)

27+ cpp-options: -DGHC_7_4

28+

29+source-repository head

30+ type: git

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

wai-handler-launch/.gitignorenew file+2

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

1+dist/

2+*.swp

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

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

1+## 3.0.2.2

2+

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

4+

5+## 3.0.2.1

6+

7+* Relax upper bound on process

8+

9+## 3.0.2

10+

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

12+

13+## 3.0.1

14+

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

16+

17+## 3.0.0.5

18+

19+* Support wai/warp 3.2

20+

21+## 3.0.0.3

22+

23+Allow blaze-builder 0.4

24+

25+## 3.0.0.2

26+

27+* Support for Win64

wai-handler-launch/LICENSEnew file+20

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

2+

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

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

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

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

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

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

9+the following conditions:

10+

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

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

13+

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

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

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

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

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

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

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

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

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

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ForeignFunctionInterface #-}

3+{-# LANGUAGE CPP #-}

4+module Network.Wai.Handler.Launch

5+ ( run

6+ , runUrl

7+ , runUrlPort

8+ , runHostPortUrl

9+ ) where

10+

11+import Network.Wai

12+import Network.Wai.Internal

13+import Network.HTTP.Types

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

15+import Data.IORef

16+import Data.Monoid (mappend)

17+import Data.String (fromString)

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

19+import Control.Concurrent.Async (race)

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

21+import Control.Monad (unless)

22+import Control.Exception (throwIO)

23+import Data.Function (fix)

24+import qualified Data.ByteString as S

25+import Blaze.ByteString.Builder (fromByteString, Builder, flush)

26+import qualified Blaze.ByteString.Builder as Blaze

27+#if WINDOWS

28+import Foreign

29+import Foreign.C.String

30+#else

31+import System.Process (rawSystem)

32+#endif

33+import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)

34+import qualified Data.Streaming.Zlib as Z

35+

36+ping :: IORef Bool -> Middleware

37+ping active app req sendResponse

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

39+ liftIO $ writeIORef active True

40+ sendResponse $ responseLBS status200 [] ""

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

42+ let isHtml hs =

43+ case lookup "content-type" hs of

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

45+ Nothing -> False

46+ if isHtml $ responseHeaders res

47+ then do

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

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

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

51+ withBody $ \body ->

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

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

54+ if isEnc

55+ then decode sendChunk' flush' body

56+ else body sendChunk' flush'

57+ else sendResponse res

58+

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

60+ -> StreamingBody

61+ -> IO ()

62+decode sendInner flushInner streamingBody = do

63+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

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

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

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

67+ bs <- popper

68+ unless (S.null bs) $ do

69+ Z.feedInflate inflate bs >>= goZlibPopper

70+ loop

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

72+ res <- popper

73+ case res of

74+ Z.PRDone -> return ()

75+ Z.PRNext bs -> do

76+ sendInner $ fromByteString bs

77+ loop

78+ Z.PRError e -> throwIO e

79+ streamingBody send (send flush)

80+ mbs <- blazeFinish

81+ case mbs of

82+ Nothing -> return ()

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

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

85+

86+toInsert :: S.ByteString

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

88+

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

90+ -> IO ()

91+ -> StreamingBody

92+ -> IO ()

93+addInsideHead sendInner flushInner streamingBody = do

94+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

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

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

97+ state <- readIORef ref

98+ mbs <- blazeFinish

99+ held <- case mbs of

100+ Nothing -> return state

101+ Just bs -> push state bs

102+ case state of

103+ Nothing -> return ()

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

105+ where

106+ whole = "<head>"

107+

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

109+

110+ inner blazeRecv ref builder = do

111+ state0 <- readIORef ref

112+ popper <- blazeRecv builder

113+ let loop state = do

114+ bs <- popper

115+ if S.null bs

116+ then writeIORef ref state

117+ else push state bs >>= loop

118+ loop state0

119+

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

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

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

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

124+ sendInner $ fromByteString held

125+ `mappend` fromByteString atFront

126+ `mappend` fromByteString toInsert

127+ `mappend` fromByteString y

128+ return Nothing

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

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

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

132+ sendInner $ fromByteString held

133+ `mappend` fromByteString before

134+ `mappend` fromByteString whole

135+ `mappend` fromByteString toInsert

136+ `mappend` fromByteString after

137+ return Nothing

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

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

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

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

142+ | otherwise = do

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

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

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

146+

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

148+getOverlap whole x =

149+ go whole

150+ where

151+ go piece

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

153+ | piece `S.isSuffixOf` x =

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

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

156+ in (piece, atFront, x')

157+ | otherwise = go $ S.init piece

158+

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

160+ -> [Header]

161+ -> (Bool, [Header])

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

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

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

165+

166+#if WINDOWS

167+foreign import ccall "launch"

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

169+#endif

170+

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

172+

173+#if WINDOWS

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

175+#else

176+launch port s = forkIO (rawSystem

177+#if MAC

178+ "open"

179+#else

180+ "xdg-open"

181+#endif

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

183+#endif

184+

185+run :: Application -> IO ()

186+run = runUrl ""

187+

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

189+runUrl = runUrlPort 4587

190+

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

192+runUrlPort = runHostPortUrl "*4"

193+

194+-- |

195+--

196+-- @since 3.0.1

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

198+runHostPortUrl host port url app = do

199+ ready <- newEmptyMVar

200+ active <- newIORef True

201+ let settings =

202+ Warp.setPort port $

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

204+ Warp.setHost (fromString host) $

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

206+ Warp.defaultSettings

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

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

209+ fmap (either id id) $ race

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

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

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

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

214+

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

216+loop active = do

217+ let seconds = 120

218+ threadDelay $ 1000000 * seconds

219+ b <- readIORef active

220+ if b

221+ then writeIORef active False >> loop active

222+ else return ()

wai-handler-launch/READMEnew file

No changes to the content.

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

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

1+## wai-handler-launch

2+

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

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

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

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

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

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

1+{-# LANGUAGE OverloadedStrings #-}

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

3+import Test.Hspec

4+import Test.Hspec.HUnit

5+import Data.Enumerator hiding (map)

6+import Test.HUnit

7+import qualified Data.ByteString as S

8+

9+main :: IO ()

10+main = hspec $ describe "insideHead"

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

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

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

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

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

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

17+ ]

18+

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

20+helper res pieces = do

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

22+ S.concat x @?= res

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

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.HTTP.Types

4+import Network.Wai.Handler.Launch

5+import Network.Wai.Middleware.Gzip

6+

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

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

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

1+Name: wai-handler-launch

2+Version: 3.0.2.2

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

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

5+License: MIT

6+License-file: LICENSE

7+Author: Michael Snoyman

8+Maintainer: michael@snoyman.com

9+Category: Web

10+Build-type: Simple

11+Cabal-version: >=1.6

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

13+

14+Library

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

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

17+ , wai >= 3.0 && < 3.3

18+ , warp >= 3.0 && < 3.3

19+ , http-types >= 0.7

20+ , transformers >= 0.2.2

21+ , bytestring >= 0.9.1.4

22+ , blaze-builder >= 0.2.1.4 && < 0.5

23+ , streaming-commons

24+ , async

25+

26+ if os(windows)

27+ c-sources: windows.c

28+ cpp-options: -DWINDOWS

29+ extra-libraries: Shell32 msvcrt

30+ else

31+ build-depends: process >= 1.0 && < 1.5

32+ if os(darwin)

33+ cpp-options: -DMAC

34+

35+source-repository head

36+ type: git

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

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

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

1+#include <windows.h>

2+#include <shellapi.h>

3+#include <stdio.h>

4+

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

6+{

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

8+ char *buff = malloc(len);

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

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

11+ free(buff);

12+}

wai-handler-webkit/.gitignorenew file+2

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

1+dist

2+*.swp

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

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

1+## 3.0.0.3

2+

3+* Support for wai/warp 3.2

wai-handler-webkit/LICENSEnew file+20

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

2+

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

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

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

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

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

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

9+the following conditions:

10+

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

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

13+

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

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

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

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

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

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

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

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

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

1+{-# LANGUAGE ForeignFunctionInterface #-}

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

3+

4+import Network.Wai (Application)

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

6+import Control.Concurrent (forkOS)

7+import Control.Concurrent.MVar

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

9+import Control.Exception (finally)

10+

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

12+ -> Application -> IO ()

13+run title app = do

14+ mvar <- newEmptyMVar

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

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

17+ _ <- takeMVar mvar

18+ return ()

19+

20+foreign import ccall "start_browser"

21+ startBrowser :: CString -> IO ()

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

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

1+wai-handler-webkit

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

3+

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

5+

6+

7+Linux

8+-----

9+

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

11+

12+ apt-get install libqtwebkit-dev

13+

14+On Lucid, this required adding a PPA:

15+

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

17+

18+

19+Windows

20+-------

21+

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

23+

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

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

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

27+application does not open a terminal.

28+

29+ if os(windows)

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

31+ else

32+ ghc-options: -Wall

33+

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

35+

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

37+

38+ cabal-dev install \

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

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

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

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

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

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

45+

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

47+

48+ phonon4.dll

49+ libgcc_s_dw2-1.dll

50+ QtCore4.dll

51+ QtGui4.dll

52+ QtNetwork4.dll

53+ QtWebKit4.dll

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

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

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

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.Webkit

4+import Network.HTTP.Types

5+

6+main :: IO ()

7+main = run "Sample App" app

8+

9+app :: Application

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

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

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

1+name: wai-handler-webkit

2+version: 3.0.0.3

3+license: MIT

4+license-file: LICENSE

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

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

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

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

9+category: Web

10+stability: unstable

11+cabal-version: >= 1.6

12+build-type: Simple

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

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

15+

16+library

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

18+ , wai >= 3.0 && < 3.3

19+ , warp >= 3.0 && < 3.3

20+ ghc-options: -Wall

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

22+ c-sources: webkit.cpp

23+ if os(windows)

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

25+ else

26+ pkgconfig-depends: QtWebKit

27+

28+source-repository head

29+ type: git

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

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

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

1+#include <QApplication>

2+#include <QPushButton>

3+#include <QtWebKit>

4+

5+extern "C" {

6+ int start_browser(char *title)

7+ {

8+ char *argv[1];

9+ argv[0] = title;

10+ int argc = 1;

11+

12+ QApplication app(argc, argv);

13+ QWebView *view = new QWebView();

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

15+ view->show();

16+

17+ return app.exec();

18+ }

19+}

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

@@ -120,12 +120,10 @@ pushOnReferer settings@Settings{..} app req sendResponse = do

120 when (isNothing mauth

121 || requestHeaderHost req == mauth) $ do

122 when (path /= refPath) $ do -- just in case

123− let !path' = BS.copy path

124− !refPath' = BS.copy refPath

125− mpp <- makePushPromise refPath' path' file

123+ mpp <- makePushPromise refPath path file

126 case mpp of

124 case mpp of

127 Nothing -> return ()

125 Nothing -> return ()

128− Just pp -> reaperAdd reaper (refPath',pp)

126+ Just pp -> reaperAdd reaper (refPath,pp)

129 ps -> do

127 ps -> do

130 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

128 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

131 setHTTP2Data req (Just h2d)

129 setHTTP2Data req (Just h2d)

wai-http2-extra/wai-http2-extra.cabal+2−9

@@ -1,5 +1,5 @@

1Name: wai-http2-extra

2−Version: 0.1.2

2+Version: 0.1.0

3Synopsis: WAI utilities for HTTP/2

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: kazu@iij.ad.jp

8Homepage: http://github.com/yesodweb/wai

9Category: Web

10Build-Type: Simple

11−Cabal-Version: >=1.10

11+Cabal-Version: >=1.8

12Stability: Stable

13Description: WAI utilities for HTTP/2

14

@@ -24,9 +24,6 @@ Library

24 Exposed-modules: Network.Wai.Middleware.Push.Referer

25 Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap

26 Ghc-Options: -Wall

27− if impl(ghc >= 8)

28− default-extensions: Strict StrictData

29− default-language: Haskell2010

30

27

31Test-Suite doctest

28Test-Suite doctest

32 Type: exitcode-stdio-1.0

29 Type: exitcode-stdio-1.0

@@ -35,10 +32,6 @@ Test-Suite doctest

35 Main-Is: doctests.hs

32 Main-Is: doctests.hs

36 Build-Depends: base

33 Build-Depends: base

37 , doctest >= 0.10.1

34 , doctest >= 0.10.1

38− if impl(ghc >= 8)

39− default-extensions: Strict StrictData

40− default-language: Haskell2010

41−

42Source-Repository head

35Source-Repository head

43 Type: git

36 Type: git

44 Location: git://github.com/yesodweb/wai.git

37 Location: git://github.com/yesodweb/wai.git

wai-websockets/ChangeLog.md−4

@@ -1,7 +1,3 @@

1−## 3.0.1.2

2−

3−* Drop unused dependency on blaze-builder

4−

5## 3.0.1.1

1## 3.0.1.1

6

2

7* Doc improvement

3* Doc improvement

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+3−2

@@ -1,5 +1,5 @@

1Name: wai-websockets

2−Version: 3.0.1.2

2+Version: 3.0.1.1

3Synopsis: Provide a bridge between WAI and the websockets package.

4License: MIT

5License-file: LICENSE

@@ -21,6 +21,7 @@ Library

21 Build-Depends: base >= 3 && < 5

22 , bytestring >= 0.9.1.4

23 , wai >= 3.0 && < 3.3

24+ , blaze-builder >= 0.2.1.4 && < 0.5

24 , case-insensitive >= 0.2

25 , case-insensitive >= 0.2

25 , network >= 2.2.1.5

26 , network >= 2.2.1.5

26 , transformers >= 0.2

27 , transformers >= 0.2

@@ -40,12 +41,12 @@ Executable wai-websockets-example

40 , wai-app-static

41 , wai-app-static

41 , bytestring

42 , bytestring

42 , case-insensitive

43 , case-insensitive

44+ , blaze-builder

43 , transformers

45 , transformers

44 , network

46 , network

45 , text

47 , text

46 , file-embed

48 , file-embed

47 , http-types

49 , http-types

48− other-modules: Network.Wai.Handler.WebSockets

49 else

50 else

50 buildable: False

51 buildable: False

51

52

wai/ChangeLog.md−14

@@ -1,17 +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

12−

13−* Remove dependency on blaze-builder [#683](https://github.com/yesodweb/wai/pull/683)

14−

15## 3.2.1.1

1## 3.2.1.1

16

2

17* Relax upper bound on bytestring-builder

3* Relax upper bound on bytestring-builder

wai/Network/Wai.hs+21−20

@@ -1,14 +1,15 @@

1+{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE CPP #-}

1{-|

3{-|

2

4

3This module defines a generic web application interface. It is a common

5This module defines a generic web application interface. It is a common

4protocol between web servers and web applications.

6protocol between web servers and web applications.

5

7

6The overriding design principles here are performance and generality. To

8The overriding design principles here are performance and generality. To

7−address performance, this library uses a streaming interface for request and

9+address performance, this library is built on top of the conduit and

8−response bodies, paired with bytestring's 'Builder' type. The advantages of a

10+blaze-builder packages. The advantages of conduits over lazy IO have been

9−streaming API over lazy IO have been debated elsewhere and so will not be

10−addressed here. However, helper functions like 'responseLBS' allow you to

11+debated elsewhere and so will not be addressed here. However, helper functions

11−continue using lazy IO if you so desire.

12+like 'responseLBS' allow you to continue using lazy IO if you so desire.

12

13

13Generality is achieved by removing many variables commonly found in similar

14Generality is achieved by removing many variables commonly found in similar

14projects that are not universal to all servers. The goal is that the 'Request'

15projects that are not universal to all servers. The goal is that the 'Request'

@@ -30,9 +31,9 @@ include:

30

31

31[wai-extra] <http://hackage.haskell.org/package/wai-extra>

32[wai-extra] <http://hackage.haskell.org/package/wai-extra>

32

33

34+[wai-test] <http://hackage.haskell.org/package/wai-test>

35+

33-}

36-}

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

37module Network.Wai

37 (

38 (

38 -- * Types

39 -- * Types

@@ -53,7 +54,6 @@ module Network.Wai

53 , remoteHost

54 , remoteHost

54 , pathInfo

55 , pathInfo

55 , queryString

56 , queryString

56− , getRequestBodyChunk

57 , requestBody

58 , vault

59 , requestBodyLength

@@ -85,8 +85,8 @@ module Network.Wai

85 , modifyResponse

86 ) where

87

88−import Data.ByteString.Builder (Builder, lazyByteString)

88+import Blaze.ByteString.Builder (Builder, fromLazyByteString)

89−import Data.ByteString.Builder (byteString)

89+import Blaze.ByteString.Builder (fromByteString)

90import Control.Monad (unless)

91import qualified Data.ByteString as B

92import qualified Data.ByteString.Lazy as L

@@ -94,6 +94,7 @@ import qualified Data.ByteString.Lazy.Internal as LI

94import Data.ByteString.Lazy.Internal (defaultChunkSize)

95import Data.ByteString.Lazy.Char8 ()

96import Data.Function (fix)

97+import Data.Monoid (mempty)

97import qualified Network.HTTP.Types as H

98import qualified Network.HTTP.Types as H

98import Network.Socket (SockAddr (SockAddrInet))

99import Network.Socket (SockAddr (SockAddrInet))

99import Network.Wai.Internal

100import Network.Wai.Internal

@@ -121,13 +122,13 @@ responseFile = ResponseFile

121--

122--

122-- A2. No. If the ByteStrings are small, then they will be copied into a larger

123-- A2. No. If the ByteStrings are small, then they will be copied into a larger

123-- buffer, which should be a performance gain overall (less system calls). If

124-- buffer, which should be a performance gain overall (less system calls). If

124−-- they are already large, then an insert operation is used

125+-- they are already large, then blaze-builder uses an InsertByteString

125−-- to avoid copying.

126+-- instruction to avoid copying.

126--

127--

127-- Q3. Doesn't this prevent us from creating comet-style servers, since data

128-- Q3. Doesn't this prevent us from creating comet-style servers, since data

128-- will be cached?

129-- will be cached?

129--

130--

130−-- A3. You can force a Builder to output a ByteString before it is an

131+-- A3. You can force blaze-builder to output a ByteString before it is an

131-- optimal size by sending a flush command.

132-- optimal size by sending a flush command.

132responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

133responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

133responseBuilder = ResponseBuilder

134responseBuilder = ResponseBuilder

@@ -135,7 +136,7 @@ responseBuilder = ResponseBuilder

135-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for

136-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for

136-- 'responseBuilder'.

137-- 'responseBuilder'.

137responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

138responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

138−responseLBS s h = ResponseBuilder s h . lazyByteString

139+responseLBS s h = ResponseBuilder s h . fromLazyByteString

139

140

140-- | Creating 'Response' from a stream of values.

141-- | Creating 'Response' from a stream of values.

141--

142--

@@ -149,9 +150,9 @@ responseLBS s h = ResponseBuilder s h . lazyByteString

149-- (putStrLn \"Allocating scarce resource\")

150-- (putStrLn \"Allocating scarce resource\")

150-- (putStrLn \"Cleaning up\")

151-- (putStrLn \"Cleaning up\")

151-- $ respond $ responseStream status200 [] $ \\write flush -> do

152-- $ respond $ responseStream status200 [] $ \\write flush -> do

152−-- write $ byteString \"Hello\\n\"

153+-- write $ fromByteString \"Hello\\n\"

153-- flush

154-- flush

154−-- write $ byteString \"World\\n\"

155+-- write $ fromByteString \"World\\n\"

155-- @

156-- @

156--

157--

157-- Note that in some cases you can use @bracket@ from inside @responseStream@

158-- Note that in some cases you can use @bracket@ from inside @responseStream@

@@ -214,7 +215,7 @@ responseToStream (ResponseFile s h fp (Just part)) =

214 bs <- B.hGetSome handle defaultChunkSize

215 bs <- B.hGetSome handle defaultChunkSize

215 unless (B.null bs) $ do

216 unless (B.null bs) $ do

216 let x = B.take remaining bs

217 let x = B.take remaining bs

217− sendChunk $ byteString x

218+ sendChunk $ fromByteString x

218 loop $ remaining - B.length x

219 loop $ remaining - B.length x

219 loop $ fromIntegral $ filePartByteCount part

220 loop $ fromIntegral $ filePartByteCount part

220 )

221 )

@@ -225,7 +226,7 @@ responseToStream (ResponseFile s h fp Nothing) =

225 withBody $ \sendChunk _flush -> fix $ \loop -> do

226 withBody $ \sendChunk _flush -> fix $ \loop -> do

226 bs <- B.hGetSome handle defaultChunkSize

227 bs <- B.hGetSome handle defaultChunkSize

227 unless (B.null bs) $ do

228 unless (B.null bs) $ do

228− sendChunk $ byteString bs

229+ sendChunk $ fromByteString bs

229 loop

230 loop

230 )

231 )

231responseToStream (ResponseBuilder s h b) =

232responseToStream (ResponseBuilder s h b) =

@@ -326,7 +327,7 @@ strictRequestBody req =

326 loop id

327 loop id

327 where

328 where

328 loop front = do

329 loop front = do

329− bs <- getRequestBodyChunk req

330+ bs <- requestBody req

330 if B.null bs

331 if B.null bs

331 then return $ front LI.Empty

332 then return $ front LI.Empty

332 else loop (front . LI.Chunk bs)

333 else loop (front . LI.Chunk bs)

@@ -340,7 +341,7 @@ lazyRequestBody req =

340 loop

341 loop

341 where

342 where

342 loop = unsafeInterleaveIO $ do

343 loop = unsafeInterleaveIO $ do

343− bs <- getRequestBodyChunk req

344+ bs <- requestBody req

344 if B.null bs

345 if B.null bs

345 then return LI.Empty

346 then return LI.Empty

346 else do

347 else do

wai/Network/Wai/Internal.hs+7−10

@@ -1,12 +1,17 @@

1{-# OPTIONS_HADDOCK not-home #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE CPP #-}

4+{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE RecordWildCards #-}

4-- | Internal constructors and helper functions. Note that no guarantees are

6-- | Internal constructors and helper functions. Note that no guarantees are

5-- given for stability of these interfaces.

7-- given for stability of these interfaces.

6module Network.Wai.Internal where

8module Network.Wai.Internal where

7

9

8−import Data.ByteString.Builder (Builder)

10+import Blaze.ByteString.Builder (Builder)

9import qualified Data.ByteString as B hiding (pack)

11import qualified Data.ByteString as B hiding (pack)

12+#if __GLASGOW_HASKELL__ < 709

13+import Data.Functor ((<$>))

14+#endif

10import Data.Text (Text)

15import Data.Text (Text)

11import Data.Typeable (Typeable)

16import Data.Typeable (Typeable)

12import Data.Vault.Lazy (Vault)

17import Data.Vault.Lazy (Vault)

@@ -17,7 +22,6 @@ import Data.List (intercalate)

17

22

18-- | Information on the request sent by the client. This abstracts away the

23-- | Information on the request sent by the client. This abstracts away the

19-- details of the underlying implementation.

24-- 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 {

25data Request = Request {

22 -- | Request method such as GET.

26 -- | Request method such as GET.

23 requestMethod :: H.Method

27 requestMethod :: H.Method

@@ -63,7 +67,7 @@ data Request = Request {

63 -- | Parsed query string information.

67 -- | Parsed query string information.

64 , queryString :: H.Query

68 , queryString :: H.Query

65 -- | Get the next chunk of the body. Returns 'B.empty' when the

69 -- | 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'.

70+ -- body is fully consumed.

67 , requestBody :: IO B.ByteString

71 , requestBody :: IO B.ByteString

68 -- | A location for arbitrary data to be shared by applications and middleware.

72 -- | A location for arbitrary data to be shared by applications and middleware.

69 , vault :: Vault

73 , vault :: Vault

@@ -91,13 +95,6 @@ data Request = Request {

91 }

95 }

92 deriving (Typeable)

96 deriving (Typeable)

93

97

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

98instance Show Request where

102 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"

99 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"

103 where

100 where

wai/test/Network/WaiSpec.hs+9−7

@@ -3,10 +3,12 @@ module Network.WaiSpec (spec) where

3import Test.Hspec

4import Test.Hspec.QuickCheck (prop)

5import Network.Wai

6+import Network.Wai.Internal (Request (Request))

6import Data.IORef

7import Data.IORef

8+import Data.Monoid

7import qualified Data.ByteString as S

9import qualified Data.ByteString as S

8import qualified Data.ByteString.Lazy as L

10import qualified Data.ByteString.Lazy as L

9−import Data.ByteString.Builder (Builder, toLazyByteString, word8)

11+import Blaze.ByteString.Builder (toByteString, Builder, fromWord8)

10import Control.Monad (forM_)

12import Control.Monad (forM_)

11

13

12spec :: Spec

14spec :: Spec

@@ -22,17 +24,17 @@ spec = do

22 flush :: IO ()

24 flush :: IO ()

23 flush = return ()

25 flush = return ()

24 streamingBody add flush

26 streamingBody add flush

25− fmap (L.toStrict . toLazyByteString) $ readIORef builderRef

27+ fmap toByteString $ readIORef builderRef

26 prop "responseLBS" $ \bytes -> do

28 prop "responseLBS" $ \bytes -> do

27 body <- getBody $ responseLBS undefined undefined $ L.pack bytes

29 body <- getBody $ responseLBS undefined undefined $ L.pack bytes

28 body `shouldBe` S.pack bytes

30 body `shouldBe` S.pack bytes

29 prop "responseBuilder" $ \bytes -> do

31 prop "responseBuilder" $ \bytes -> do

30 body <- getBody $ responseBuilder undefined undefined

32 body <- getBody $ responseBuilder undefined undefined

31− $ mconcat $ map word8 bytes

33+ $ mconcat $ map fromWord8 bytes

32 body `shouldBe` S.pack bytes

34 body `shouldBe` S.pack bytes

33 prop "responseStream" $ \chunks -> do

35 prop "responseStream" $ \chunks -> do

34 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

36 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

35− forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk

37+ forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk

36 body `shouldBe` S.concat (map S.pack chunks)

38 body `shouldBe` S.concat (map S.pack chunks)

37 it "responseFile total" $ do

39 it "responseFile total" $ do

38 let fp = "wai.cabal"

40 let fp = "wai.cabal"

@@ -55,7 +57,7 @@ spec = do

55 describe "lazyRequestBody" $ do

57 describe "lazyRequestBody" $ do

56 prop "works" $ \chunks -> do

58 prop "works" $ \chunks -> do

57 ref <- newIORef $ map S.pack $ filter (not . null) chunks

59 ref <- newIORef $ map S.pack $ filter (not . null) chunks

58− let req = defaultRequest

60+ let req = Request

59 { requestBody = atomicModifyIORef ref $ \bss ->

61 { requestBody = atomicModifyIORef ref $ \bss ->

60 case bss of

62 case bss of

61 [] -> ([], S.empty)

63 [] -> ([], S.empty)

@@ -64,7 +66,7 @@ spec = do

64 body <- lazyRequestBody req

66 body <- lazyRequestBody req

65 body `shouldBe` L.fromChunks (map S.pack chunks)

67 body `shouldBe` L.fromChunks (map S.pack chunks)

66 it "is lazy" $ do

68 it "is lazy" $ do

67− let req = defaultRequest

69+ let req = Request

68 { requestBody = error "requestBody"

70 { requestBody = error "requestBody"

69 }

71 }

70 _ <- lazyRequestBody req

72 _ <- lazyRequestBody req

@@ -72,7 +74,7 @@ spec = do

72 describe "strictRequestBody" $ do

74 describe "strictRequestBody" $ do

73 prop "works" $ \chunks -> do

75 prop "works" $ \chunks -> do

74 ref <- newIORef $ map S.pack $ filter (not . null) chunks

76 ref <- newIORef $ map S.pack $ filter (not . null) chunks

75− let req = defaultRequest

77+ let req = Request

76 { requestBody = atomicModifyIORef ref $ \bss ->

78 { requestBody = atomicModifyIORef ref $ \bss ->

77 case bss of

79 case bss of

78 [] -> ([], S.empty)

80 [] -> ([], S.empty)

wai/wai.cabal+10−8

@@ -1,9 +1,8 @@

1Name: wai

2−Version: 3.2.2.1

2+Version: 3.2.1.1

3Synopsis: Web Application Interface.

4Description: Provides a common protocol for communication between web applications and web servers.

5− .

6− API docs and the README are available at <http://www.stackage.org/package/wai>.

5+description: API docs and the README are available at <http://www.stackage.org/package/wai>.

7License: MIT

6License: MIT

8License-file: LICENSE

7License-file: LICENSE

9Author: Michael Snoyman

8Author: Michael Snoyman

@@ -20,11 +19,14 @@ Source-repository head

20 location: git://github.com/yesodweb/wai.git

19 location: git://github.com/yesodweb/wai.git

21

20

22Library

21Library

23− Build-Depends: base >= 4.8 && < 5

22+ Build-Depends: base >= 4 && < 5

24− , bytestring >= 0.10.4

23+ , bytestring >= 0.10

24+ , bytestring-builder >= 0.10.4.0 && < 0.11

25+ , blaze-builder >= 0.2.1.4 && < 0.5

25 , network >= 2.2.1.5

26 , network >= 2.2.1.5

26 , http-types >= 0.7

27 , http-types >= 0.7

27 , text >= 0.7

28 , text >= 0.7

29+ , transformers >= 0.0

28 , vault >= 0.3 && < 0.4

30 , vault >= 0.3 && < 0.4

29 Exposed-modules: Network.Wai

31 Exposed-modules: Network.Wai

30 Network.Wai.Internal

32 Network.Wai.Internal

@@ -34,14 +36,14 @@ test-suite test

34 hs-source-dirs: test

36 hs-source-dirs: test

35 main-is: Spec.hs

37 main-is: Spec.hs

36 type: exitcode-stdio-1.0

38 type: exitcode-stdio-1.0

37− ghc-options: -threaded -Wall

39+ ghc-options: -threaded

38 cpp-options: -DTEST

40 cpp-options: -DTEST

39− build-depends: base >= 4.8 && < 5

41+ build-depends: base

40 , wai

42 , wai

41 , hspec

43 , hspec

44+ , blaze-builder

42 , bytestring

45 , bytestring

43 other-modules: Network.WaiSpec

46 other-modules: Network.WaiSpec

44− build-tool-depends: hspec-discover:hspec-discover

45

47

46source-repository head

48source-repository head

47 type: git

49 type: git

wai/webkit-sample/webkit-sample.hs+2−2

@@ -5,7 +5,7 @@ import Network.Wai.Handler.Webkit

5import Data.ByteString (ByteString)

6import qualified Data.ByteString.Lazy as L

7import Data.Enumerator (consume, Iteratee)

8−import Data.ByteString.Builder (lazyByteString)

8+import Blaze.ByteString.Builder (fromLazyByteString)

9

10main :: IO ()

11main = putStrLn "http://localhost:3000/" >> run "Webkit Sample" app

@@ -27,4 +27,4 @@ postResponse :: L.ByteString -> Iteratee ByteString IO Response

27postResponse lbs = return $ ResponseBuilder

28 status200

29 [("Content-Type", "text/plain")]

30− (lazyByteString lbs)

30+ (fromLazyByteString lbs)

warp-tls/ChangeLog.md−47

@@ -1,50 +1,3 @@

1−## 3.2.11

2−

3−* Ignoring an exception from shutdown (gracefulClose).

4−

5−## 3.2.10

6−

7−* Passing client certificate, if any, to Warp

8− [#783](https://github.com/yesodweb/wai/pull/783)

9−

10−## 3.2.9

11−

12−* Cooperating setGracefulCloseTimeout1 and setGracefulCloseTimeout2 of Warp.

13− [#782](https://github.com/yesodweb/wai/pull/782)

14−

15−## 3.2.8

16−

17−* Using gracefullClose of network 3.1.1 or later if available.

18−

19−## 3.2.7

20−

21−* Relaxing version constraint.

22−

23−## 3.2.6

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−

38−* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640)

39−

40−## 3.2.4

41−

42−* Using tls-session-manager.

43−

44−## 3.2.3

45−

46−* Stop using obsoleted APIs of network.

47−

48## 3.2.2

1## 3.2.2

49

2

50* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)

3* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)

warp-tls/Network/Wai/Handler/WarpTLS.hs+22−74

@@ -4,6 +4,7 @@

4{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE DeriveDataTypeable #-}

6{-# LANGUAGE PatternGuards #-}

7+{-# LANGUAGE CPP #-}

7

8

8-- | HTTP over TLS support for Warp via the TLS package.

9-- | HTTP over TLS support for Warp via the TLS package.

9--

10--

@@ -42,10 +43,13 @@ module Network.Wai.Handler.WarpTLS (

42 , DH.generateParams

43 , DH.generateParams

43 ) where

44 ) where

44

45

46+#if __GLASGOW_HASKELL__ < 709

47+import Control.Applicative ((<$>))

48+#endif

45import Control.Applicative ((<|>))

49import Control.Applicative ((<|>))

46−import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)

50+import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..))

47import qualified Control.Exception as E

51import qualified Control.Exception as E

48−import Control.Monad (void, guard)

52+import Control.Monad (void)

49import qualified Data.ByteString as S

53import qualified Data.ByteString as S

50import qualified Data.ByteString.Lazy as L

54import qualified Data.ByteString.Lazy as L

51import Data.Default.Class (def)

55import Data.Default.Class (def)

@@ -53,9 +57,6 @@ import qualified Data.IORef as I

53import Data.Streaming.Network (bindPortTCP, safeRecv)

57import Data.Streaming.Network (bindPortTCP, safeRecv)

54import Data.Typeable (Typeable)

58import Data.Typeable (Typeable)

55import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)

59import 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)

60import Network.Socket.ByteString (sendAll)

60import qualified Network.TLS as TLS

61import qualified Network.TLS as TLS

61import qualified Crypto.PubKey.DH as DH

62import qualified Crypto.PubKey.DH as DH

@@ -93,37 +94,19 @@ data TLSSettings = TLSSettings {

93 --

94 --

94 -- Since 1.4.0

95 -- Since 1.4.0

95 , tlsAllowedVersions :: [TLS.Version]

96 , 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.

97 -- ^ The TLS versions this server accepts.

105 --

98 --

106 -- >>> tlsAllowedVersions defaultTlsSettings

99 -- >>> tlsAllowedVersions defaultTlsSettings

107 -- [TLS12,TLS11,TLS10]

100 -- [TLS12,TLS11,TLS10]

108 --

101 --

109 -- Since 1.4.2

102 -- Since 1.4.2

110−#endif

111 , tlsCiphers :: [TLS.Cipher]

103 , 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.

104 -- ^ The TLS ciphers this server accepts.

121 --

105 --

122 -- >>> tlsCiphers defaultTlsSettings

106 -- >>> 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]

107 -- [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 --

108 --

125 -- Since 1.4.2

109 -- Since 1.4.2

126−#endif

127 , tlsWantClientCert :: Bool

110 , tlsWantClientCert :: Bool

128 -- ^ Whether or not to demand a certificate from the client. If this

111 -- ^ 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

112 -- is set to True, you must handle received certificates in a server hook

@@ -170,11 +153,7 @@ defaultTlsSettings = TLSSettings {

170 , keyMemory = Nothing

153 , keyMemory = Nothing

171 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

154 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

172 , tlsLogging = def

155 , 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]

156 , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]

177−#endif

178 , tlsCiphers = ciphers

157 , tlsCiphers = ciphers

179 , tlsWantClientCert = False

158 , tlsWantClientCert = False

180 , tlsServerHooks = def

159 , tlsServerHooks = def

@@ -281,7 +260,7 @@ runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager

281runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

260runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

282 runSettingsConnectionMakerSecure set get app

261 runSettingsConnectionMakerSecure set get app

283 where

262 where

284− get = getter tlsset set sock params

263+ get = getter tlsset sock params

285 params = def { -- TLS.ServerParams

264 params = def { -- TLS.ServerParams

286 TLS.serverWantClientCert = tlsWantClientCert

265 TLS.serverWantClientCert = tlsWantClientCert

287 , TLS.serverCACertificates = []

266 , TLS.serverCACertificates = []

@@ -289,9 +268,6 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

289 , TLS.serverHooks = hooks

268 , TLS.serverHooks = hooks

290 , TLS.serverShared = shared

269 , TLS.serverShared = shared

291 , TLS.serverSupported = supported

270 , TLS.serverSupported = supported

292−#if MIN_VERSION_tls(1,5,0)

293− , TLS.serverEarlyDataSize = 2018

294−#endif

295 }

271 }

296 -- Adding alpn to user's tlsServerHooks.

272 -- Adding alpn to user's tlsServerHooks.

297 hooks = tlsServerHooks {

273 hooks = tlsServerHooks {

@@ -310,9 +286,6 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

310 , TLS.supportedClientInitiatedRenegotiation = False

286 , TLS.supportedClientInitiatedRenegotiation = False

311 , TLS.supportedSession = True

287 , TLS.supportedSession = True

312 , TLS.supportedFallbackScsv = True

288 , TLS.supportedFallbackScsv = True

313−#if MIN_VERSION_tls(1,5,0)

314− , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]

315−#endif

316 }

289 }

317

290

318alpn :: [S.ByteString] -> IO S.ByteString

291alpn :: [S.ByteString] -> IO S.ByteString

@@ -322,55 +295,44 @@ alpn xs

322

295

323----------------------------------------------------------------

296----------------------------------------------------------------

324

297

325−getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

298+getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

326−getter tlsset@TLSSettings{..} set sock params = do

299+getter tlsset@TLSSettings{..} sock params = do

327−#if WINDOWS

328− (s, sa) <- windowsThreadBlockHack $ accept sock

329−#else

330 (s, sa) <- accept sock

300 (s, sa) <- accept sock

331−#endif

332− setSocketCloseOnExec s

333− return (mkConn tlsset set s params, sa)

301+ return (mkConn tlsset s params, sa)

334

302

335−mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)

303+mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)

336−mkConn tlsset set s params = switch `onException` close s

304+mkConn tlsset s params = switch `onException` close s

337 where

305 where

338 switch = do

306 switch = do

339 firstBS <- safeRecv s 4096

307 firstBS <- safeRecv s 4096

340 if not (S.null firstBS) && S.head firstBS == 0x16 then

308 if not (S.null firstBS) && S.head firstBS == 0x16 then

341− httpOverTls tlsset set s firstBS params

309+ httpOverTls tlsset s firstBS params

342 else

310 else

343− plainHTTP tlsset set s firstBS

311+ plainHTTP tlsset s firstBS

344

312

345----------------------------------------------------------------

313----------------------------------------------------------------

346

314

347−httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)

315+httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)

348−httpOverTls TLSSettings{..} _set s bs0 params = do

316+httpOverTls TLSSettings{..} s bs0 params = do

349 recvN <- makePlainReceiveN s bs0

317 recvN <- makePlainReceiveN s bs0

350 ctx <- TLS.contextNew (backend recvN) params

318 ctx <- TLS.contextNew (backend recvN) params

351 TLS.contextHookSetLogging ctx tlsLogging

319 TLS.contextHookSetLogging ctx tlsLogging

352 TLS.handshake ctx

320 TLS.handshake ctx

353− h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx

354− isH2 <- I.newIORef h2

355 writeBuf <- allocateBuffer bufferSize

321 writeBuf <- allocateBuffer bufferSize

356 -- Creating a cache for leftover input data.

322 -- Creating a cache for leftover input data.

357 ref <- I.newIORef ""

323 ref <- I.newIORef ""

358 tls <- getTLSinfo ctx

324 tls <- getTLSinfo ctx

359− return (conn ctx writeBuf ref isH2, tls)

325+ return (conn ctx writeBuf ref, tls)

360 where

326 where

361 backend recvN = TLS.Backend {

327 backend recvN = TLS.Backend {

362 TLS.backendFlush = return ()

328 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

329 , TLS.backendClose = close s

367−#endif

368 , TLS.backendSend = sendAll' s

330 , TLS.backendSend = sendAll' s

369 , TLS.backendRecv = recvN

331 , TLS.backendRecv = recvN

370 }

332 }

371 sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->

333 sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->

372 throwIO ConnectionClosedByPeer

334 throwIO ConnectionClosedByPeer

373− conn ctx writeBuf ref isH2 = Connection {

335+ conn ctx writeBuf ref = Connection {

374 connSendMany = TLS.sendData ctx . L.fromChunks

336 connSendMany = TLS.sendData ctx . L.fromChunks

375 , connSendAll = sendall

337 , connSendAll = sendall

376 , connSendFile = sendfile

338 , connSendFile = sendfile

@@ -380,24 +342,15 @@ httpOverTls TLSSettings{..} _set s bs0 params = do

380 , connRecvBuf = recvBuf ref

342 , connRecvBuf = recvBuf ref

381 , connWriteBuffer = writeBuf

343 , connWriteBuffer = writeBuf

382 , connBufferSize = bufferSize

344 , connBufferSize = bufferSize

383− , connHTTP2 = isH2

384 }

345 }

385 where

346 where

386 sendall = TLS.sendData ctx . L.fromChunks . return

347 sendall = TLS.sendData ctx . L.fromChunks . return

387 sendfile fid offset len hook headers =

348 sendfile fid offset len hook headers =

388 readSendFile writeBuf bufferSize sendall fid offset len hook headers

349 readSendFile writeBuf bufferSize sendall fid offset len hook headers

389

350

390− close' = void (tryIO sendBye) `finally`

351+ close' = void (tryIO $ TLS.bye ctx) `finally`

391 TLS.contextClose ctx

352 TLS.contextClose ctx

392

353

393− sendBye =

394− -- It's fine if the connection was closed by the other side before

395− -- receiving close_notify, see RFC 5246 section 7.2.1.

396− handleJust

397− (\e -> guard (e == ConnectionClosedByPeer) >> return e)

398− (const (return ()))

399− (TLS.bye ctx)

400−

401 -- TLS version of recv with a cache for leftover input data.

354 -- TLS version of recv with a cache for leftover input data.

402 -- The cache is shared with recvBuf.

355 -- The cache is shared with recvBuf.

403 recv cref = do

356 recv cref = do

@@ -465,16 +418,11 @@ getTLSinfo ctx = do

465 TLS.TLS10 -> (3,1)

418 TLS.TLS10 -> (3,1)

466 TLS.TLS11 -> (3,2)

419 TLS.TLS11 -> (3,2)

467 TLS.TLS12 -> (3,3)

420 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 {

421 return TLS {

473 tlsMajorVersion = major

422 tlsMajorVersion = major

474 , tlsMinorVersion = minor

423 , tlsMinorVersion = minor

475 , tlsNegotiatedProtocol = proto

424 , tlsNegotiatedProtocol = proto

476 , tlsChiperID = TLS.cipherID infoCipher

425 , tlsChiperID = TLS.cipherID infoCipher

477− , tlsClientCertificate = clientCert

478 }

426 }

479

427

480tryIO :: IO a -> IO (Either IOException a)

428tryIO :: IO a -> IO (Either IOException a)

@@ -482,10 +430,10 @@ tryIO = try

482

430

483----------------------------------------------------------------

431----------------------------------------------------------------

484

432

485−plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)

433+plainHTTP :: TLSSettings -> Socket -> S.ByteString -> IO (Connection, Transport)

486−plainHTTP TLSSettings{..} set s bs0 = case onInsecure of

434+plainHTTP TLSSettings{..} s bs0 = case onInsecure of

487 AllowInsecure -> do

435 AllowInsecure -> do

488− conn' <- socketConnection set s

436+ conn' <- socketConnection s

489 cachedRef <- I.newIORef bs0

437 cachedRef <- I.newIORef bs0

490 let conn'' = conn'

438 let conn'' = conn'

491 { connRecv = recvPlain cachedRef (connRecv conn')

439 { connRecv = recvPlain cachedRef (connRecv conn')

warp-tls/warp-tls.cabal+6−12

@@ -1,5 +1,5 @@

1Name: warp-tls

2−Version: 3.2.11

2+Version: 3.2.4

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,24 +18,18 @@ 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 && < 5

22 , bytestring >= 0.9

23 , wai >= 3.2 && < 3.3

24− , warp >= 3.3.6 && < 3.4

24+ , warp >= 3.2.10 && < 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−

39

33

40source-repository head

34source-repository head

41 type: git

35 type: git

warp/ChangeLog.md−150

@@ -1,153 +1,3 @@

1−## 3.3.9

2−

3−* Don't insert Last-Modified: if exists.

4− [#791](https://github.com/yesodweb/wai/pull/791)

5−

6−## 3.3.8

7−

8−* Maximum header size is configurable.

9− [#781](https://github.com/yesodweb/wai/pull/781)

10−* Ignoring an exception from shutdown (gracefulClose).

11−

12−## 3.3.7

13−

14−* InvalidArgument (Bad file descriptor) is ignored in `receive`.

15− [#787](https://github.com/yesodweb/wai/pull/787)

16−

17−## 3.3.6

18−

19−* Fixing a bug of thread killed in the case of event source with

20− HTTP/2 (fixing #692 and #785)

21−* New APIs: clientCertificate to get client's certificate

22− [#783](https://github.com/yesodweb/wai/pull/783)

23−

24−## 3.3.5

25−

26−* New APIs: setGracefulCloseTimeout1 and setGracefulCloseTimeout2.

27− For HTTP/1.x, connections are closed immediately by default.

28− gracefullClose is used for HTTP/2 by default.

29− [#782](https://github.com/yesodweb/wai/pull/782)

30−

31−## 3.3.4

32−

33−* Setting isSecure of HTTP/2 correctly.

34−

35−## 3.3.3

36−

37−* Calling setOnException in HTTP/2.

38− [#771](https://github.com/yesodweb/wai/pull/771)

39−

40−## 3.3.2

41−

42−* Fixing a bug of HTTP/2 without fd cache.

43−

44−## 3.3.1

45−

46−* Using gracefullClose of network 3.1.1 or later if available.

47−* If the first line of an HTTP request is really invalid,

48− don't send an error response

49−

50−## 3.3.0

51−

52−* Switching from the original implementation to HTTP/2 server library.

53− [#754](https://github.com/yesodweb/wai/pull/754)

54−* Breaking change: The type of `http2dataTrailers` is now

55− `HTTP2Data -> TrailersMaker`.

56−

57−## 3.2.28

58−

59−* Using the Strict and StrictData language extensions for GHC >8.

60− [#752](https://github.com/yesodweb/wai/pull/752)

61−* System.TimeManager is now in a separate package: time-manager.

62− [#750](https://github.com/yesodweb/wai/pull/750)

63−* Fixing a bug of ALPN.

64−* Introducing the half closed state for HTTP/2.

65− [#717](https://github.com/yesodweb/wai/pull/717)

66−

67−## 3.2.27

68−

69−* Internally, use `lookupEnv` instead of `getEnvironment` to get the

70− value of the `PORT` environment variable

71− [#736](https://github.com/yesodweb/wai/pull/736)

72−* Throw 413 for too large payload

73−* Throw 431 for too large headers

74− [#741](https://github.com/yesodweb/wai/pull/741)

75−* Use exception response handler in HTTP/2 & improve connection preservation

76− in HTTP/1.x if uncaught exceptions are thrown in an `Application`.

77− [#738](https://github.com/yesodweb/wai/pull/738)

78−

79−## 3.2.26

80−

81−* Support network package version 3

82−

83−## 3.2.25

84−

85−* Removing Connection: and Transfer-Encoding: from HTTP/2

86− response header

87− [#707](https://github.com/yesodweb/wai/pull/707)

88−

89−## 3.2.24

90−

91−* Fix HTTP2 unwanted GoAways on late WindowUpdate frames.

92− [#711](https://github.com/yesodweb/wai/pull/711)

93−

94−## 3.2.23

95−

96−* Log real requsts when an app throws an error.

97− [#698](https://github.com/yesodweb/wai/pull/698)

98−

99−## 3.2.22

100−

101−* Fixing large request body in HTTP/2.

102−

103−## 3.2.21

104−

105−* Fixing HTTP/2's timeout handler in request's vault.

106−

107−## 3.2.20

108−

109−* Fixing large request body in HTTP/2

110− [#593](https://github.com/yesodweb/wai/issues/593)

111−

112−## 3.2.19

113−

114−* Fixing 0-byte request body in HTTP/2

115− [#597](https://github.com/yesodweb/wai/issues/597)

116− [#679](https://github.com/yesodweb/wai/issues/679)

117−

118−## 3.2.18.2

119−

120−* Replace dependency on `blaze-builder` with `bsb-http-chunked`

121−

122−## 3.2.18.1

123−

124−* Fix benchmark compilation [#681](https://github.com/yesodweb/wai/issues/681)

125−

126−## 3.2.18

127−

128−* Make `testWithApplicationSettings` actually use the settings passed.

129− [#677](https://github.com/yesodweb/wai/pull/677).

130−

131−## 3.2.17

132−* Add support for windows thread block hack and closeOnExec to TLS.

133− [#674](https://github.com/yesodweb/wai/pull/674).

134−

135−## 3.2.16

136−

137−* In `testWithApplication`, don't `throwTo` ignorable exceptions

138− [#671](https://github.com/yesodweb/wai/issues/671), and

139− reuse `bindRandomPortTCP`

140−

141−## 3.2.15

142−

143−* Address space leak from exception handlers

144− [#649](https://github.com/yesodweb/wai/issues/649)

145−

146−## 3.2.14

147−

148−* Support streaming-commons 0.2

149−* Warnings cleanup

150−

151## 3.2.13

1## 3.2.13

152

2

153* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)

3* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)

warp/Network/Wai/Handler/Warp.hs+6−72

@@ -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

@@ -125,22 +119,21 @@ module Network.Wai.Handler.Warp (

125 ) where

119 ) where

126

120

127import Control.Exception (SomeException, throwIO)

121import Control.Exception (SomeException, throwIO)

122+import Data.ByteString (ByteString)

123+import Data.Maybe (fromMaybe)

128import Data.Streaming.Network (HostPreference)

124import Data.Streaming.Network (HostPreference)

129import qualified Data.Vault.Lazy as Vault

125import qualified Data.Vault.Lazy as Vault

130−import Data.X509

131import qualified Network.HTTP.Types as H

126import qualified Network.HTTP.Types as H

132import Network.Socket (SockAddr)

127import Network.Socket (SockAddr)

133import Network.Wai (Request, Response, vault)

128import Network.Wai (Request, Response, vault)

134−import System.TimeManager

135−

136import Network.Wai.Handler.Warp.FileInfoCache

129import Network.Wai.Handler.Warp.FileInfoCache

137−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

138−import Network.Wai.Handler.Warp.HTTP2.Types

139−import Network.Wai.Handler.Warp.Imports

140import Network.Wai.Handler.Warp.Request

130import Network.Wai.Handler.Warp.Request

141import Network.Wai.Handler.Warp.Response (warpVersion)

131import Network.Wai.Handler.Warp.Response (warpVersion)

142import Network.Wai.Handler.Warp.Run

132import Network.Wai.Handler.Warp.Run

143import Network.Wai.Handler.Warp.Settings

133import Network.Wai.Handler.Warp.Settings

134+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

135+import Network.Wai.Handler.Warp.HTTP2.Types

136+import Network.Wai.Handler.Warp.Timeout

144import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

137import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

145import Network.Wai.Handler.Warp.WithApplication

138import Network.Wai.Handler.Warp.WithApplication

146

139

@@ -303,18 +296,6 @@ getGracefulShutdownTimeout = settingsGracefulShutdownTimeout

303-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

296-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

304-- @

297-- @

305--

298--

306−-- Note that by default, the graceful shutdown mode lasts indefinitely

307−-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,

308−-- upon receiving that signal, the custon shutdown action will run /and/ all

309−-- outstanding requests will be handled.

310−--

311−-- You may instead prefer to do one or both of the following:

312−--

313−-- * Only wait a finite amount of time for outstanding requests to complete,

314−-- using 'setGracefulShutdownTimeout'.

315−-- * Only catch one signal, so the second hard-kills the Warp server, using

316−-- 'System.Posix.Signals.CatchOnce'.

317−--

318-- Default: does not install any code.

299-- Default: does not install any code.

319--

300--

320-- Since 3.0.1

301-- Since 3.0.1

@@ -385,7 +366,7 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }

385--

366--

386-- WARNING: This is contrary to the PROXY protocol specification and

367-- WARNING: This is contrary to the PROXY protocol specification and

387-- using it can indicate a security problem with your

368-- using it can indicate a security problem with your

388−-- architecture if the web server is directly accessible

369+-- architecture if the web server is directly accessable

389-- to the public, since it would allow easy IP address

370-- to the public, since it would allow easy IP address

390-- spoofing. However, it can be useful in some cases,

371-- spoofing. However, it can be useful in some cases,

391-- such as if a load balancer health check uses regular

372-- such as if a load balancer health check uses regular

@@ -428,22 +409,11 @@ setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }

428-- wait indefinitely, and a number, if provided, will be treated as seconds

409-- wait indefinitely, and a number, if provided, will be treated as seconds

429-- to wait for requests to finish, before shutting down the server entirely.

410-- to wait for requests to finish, before shutting down the server entirely.

430--

411--

431−-- Graceful shutdown mode is entered when the server socket is closed; see

432−-- 'setInstallShutdownHandler' for an example of how this could be done in

433−-- response to a UNIX signal.

434−--

435-- Since 3.2.8

412-- Since 3.2.8

436setGracefulShutdownTimeout :: Maybe Int

413setGracefulShutdownTimeout :: Maybe Int

437 -> Settings -> Settings

414 -> Settings -> Settings

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

415setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

439

416

440−-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.

441−--

442−-- Since 3.3.8

443−setMaxTotalHeaderLength :: Int -> Settings -> Settings

444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446−

447-- | Explicitly pause the slowloris timeout.

417-- | Explicitly pause the slowloris timeout.

448--

418--

449-- This is useful for cases where you partially consume a request body. For

419-- This is useful for cases where you partially consume a request body. For

@@ -471,39 +441,3 @@ pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

471-- Since 3.1.10

441-- Since 3.1.10

472getFileInfo :: Request -> FilePath -> IO FileInfo

442getFileInfo :: Request -> FilePath -> IO FileInfo

473getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

443getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

474−

475−-- | A timeout to limit the time (in milliseconds) waiting for

476−-- FIN for HTTP/1.x. 0 means uses immediate close.

477−-- Default: 0.

478−--

479−-- Since 3.3.5

480−setGracefulCloseTimeout1 :: Int -> Settings -> Settings

481−setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }

482−

483−-- | A timeout to limit the time (in milliseconds) waiting for

484−-- FIN for HTTP/1.x. 0 means uses immediate close.

485−--

486−-- Since 3.3.5

487−getGracefulCloseTimeout1 :: Settings -> Int

488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489−

490−-- | A timeout to limit the time (in milliseconds) waiting for

491−-- FIN for HTTP/2. 0 means uses immediate close.

492−-- Default: 2000.

493−--

494−-- Since 3.3.5

495−setGracefulCloseTimeout2 :: Int -> Settings -> Settings

496−setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }

497−

498−-- | A timeout to limit the time (in milliseconds) waiting for

499−-- FIN for HTTP/2. 0 means uses immediate close.

500−--

501−-- Since 3.3.5

502−getGracefulCloseTimeout2 :: Settings -> Int

503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504−

505−-- | Getting information of client certificate.

506−--

507−-- Since 3.3.5

508−clientCertificate :: Request -> Maybe CertificateChain

509−clientCertificate = join . Vault.lookup getClientCertificateKey . vault

warp/Network/Wai/Handler/Warp/Buffer.hs+2−4

@@ -1,4 +1,4 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2

3module Network.Wai.Handler.Warp.Buffer (

4 bufferSize

@@ -13,15 +13,13 @@ module Network.Wai.Handler.Warp.Buffer (

13 ) where

14

15import qualified Data.ByteString as BS

16−import Data.ByteString.Internal (memcpy)

16+import Data.ByteString.Internal (ByteString(..), memcpy)

17import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)

18import Data.IORef (newIORef, readIORef, writeIORef)

19import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))

20import Foreign.ForeignPtr

21import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)

22import Foreign.Ptr (castPtr, plusPtr)

23−

24−import Network.Wai.Handler.Warp.Imports

25import Network.Wai.Handler.Warp.Types

23import Network.Wai.Handler.Warp.Types

26

24

27----------------------------------------------------------------

25----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Conduit.hs+6−2

@@ -3,10 +3,14 @@

3module Network.Wai.Handler.Warp.Conduit where

4

5import Control.Exception

6+import Control.Monad (when, unless)

7+import Data.ByteString (ByteString)

6import qualified Data.ByteString as S

8import qualified Data.ByteString as S

7import qualified Data.IORef as I

9import qualified Data.IORef as I

8−

10+#if __GLASGOW_HASKELL__ < 709

9−import Network.Wai.Handler.Warp.Imports

11+import Data.Word (Word)

12+#endif

13+import Data.Word (Word8)

10import Network.Wai.Handler.Warp.Types

14import Network.Wai.Handler.Warp.Types

11

15

12----------------------------------------------------------------

16----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Counter.hs+4−3

@@ -8,10 +8,11 @@ module Network.Wai.Handler.Warp.Counter (

8 , decrease

9 ) where

10

11+#if __GLASGOW_HASKELL__ < 709

12+import Control.Applicative ((<$>))

13+#endif

11import Control.Concurrent.STM

14import Control.Concurrent.STM

12−

15+import Control.Monad (unless)

13−import Network.Wai.Handler.Warp.Imports

14−

15

16

16newtype Counter = Counter (TVar Int)

17newtype Counter = Counter (TVar Int)

17

18

warp/Network/Wai/Handler/Warp/Date.hs+4−1

@@ -5,8 +5,11 @@ module Network.Wai.Handler.Warp.Date (

5 , GMTDate

6 ) where

7

8+#if __GLASGOW_HASKELL__ < 709

9+import Control.Applicative

10+#endif

8import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

11import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

9−import Data.ByteString

12+import Data.ByteString.Char8

10import Network.HTTP.Date

13import Network.HTTP.Date

11

14

12#if WINDOWS

15#if WINDOWS

warp/Network/Wai/Handler/Warp/FdCache.hs+27−20

@@ -14,34 +14,39 @@ module Network.Wai.Handler.Warp.FdCache (

14 ) where

15

16#ifndef WINDOWS

17+#if __GLASGOW_HASKELL__ < 709

18+import Control.Applicative ((<$>), (<*>))

19+#endif

17import Control.Exception (bracket)

20import Control.Exception (bracket)

21+import Network.Wai.Handler.Warp.IORef

22+import Network.Wai.Handler.Warp.MultiMap

18import Control.Reaper

23import Control.Reaper

19−import Data.IORef

20−import Network.Wai.Handler.Warp.MultiMap as MM

21import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)

24import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)

22#endif

25#endif

23import System.Posix.Types (Fd)

26import System.Posix.Types (Fd)

24

27

25----------------------------------------------------------------

28----------------------------------------------------------------

26

29

30+type Hash = Int

31+

27-- | An action to activate a Fd cache entry.

32-- | An action to activate a Fd cache entry.

28type Refresh = IO ()

33type Refresh = IO ()

29

34

30−getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)

35+getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)

31−getFdNothing _ = return (Nothing, return ())

36+getFdNothing _ _ = return (Nothing, return ())

32

37

33----------------------------------------------------------------

38----------------------------------------------------------------

34

39

35-- | Creating 'MutableFdCache' and executing the action in the second

40-- | Creating 'MutableFdCache' and executing the action in the second

36-- argument. The first argument is a cache duration in second.

41-- argument. The first argument is a cache duration in second.

37−withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

42+withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

38#ifdef WINDOWS

43#ifdef WINDOWS

39withFdCache _ action = action getFdNothing

44withFdCache _ action = action getFdNothing

40#else

45#else

41withFdCache 0 action = action getFdNothing

46withFdCache 0 action = action getFdNothing

42withFdCache duration action = bracket (initialize duration)

47withFdCache duration action = bracket (initialize duration)

43 terminate

48 terminate

44− (action . getFd)

49+ (\mfc -> action (getFd mfc))

45

50

46----------------------------------------------------------------

51----------------------------------------------------------------

47

52

@@ -63,7 +68,7 @@ inactive (MutableStatus ref) = writeIORef ref Inactive

63

68

64----------------------------------------------------------------

69----------------------------------------------------------------

65

70

66−data FdEntry = FdEntry !Fd !MutableStatus

71+data FdEntry = FdEntry !FilePath !Fd !MutableStatus

67

72

68openFile :: FilePath -> IO Fd

73openFile :: FilePath -> IO Fd

69openFile path = do

74openFile path = do

@@ -75,23 +80,25 @@ closeFile :: Fd -> IO ()

75closeFile = closeFd

80closeFile = closeFd

76

81

77newFdEntry :: FilePath -> IO FdEntry

82newFdEntry :: FilePath -> IO FdEntry

78−newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus

83+newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus

79

84

80setFileCloseOnExec :: Fd -> IO ()

85setFileCloseOnExec :: Fd -> IO ()

81setFileCloseOnExec fd = setFdOption fd CloseOnExec True

86setFileCloseOnExec fd = setFdOption fd CloseOnExec True

82

87

83----------------------------------------------------------------

88----------------------------------------------------------------

84

89

85−type FdCache = MultiMap FdEntry

90+type FdCache = MMap FdEntry

86

91

87-- | Mutable Fd cacher.

92-- | Mutable Fd cacher.

88−newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))

93+newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))

89

94

90fdCache :: MutableFdCache -> IO FdCache

95fdCache :: MutableFdCache -> IO FdCache

91fdCache (MutableFdCache reaper) = reaperRead reaper

96fdCache (MutableFdCache reaper) = reaperRead reaper

92

97

93−look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)

98+look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)

94−look mfc path = MM.lookup path <$> fdCache mfc

99+look mfc path key = searchWith key check <$> fdCache mfc

100+ where

101+ check (FdEntry path' _ _) = path == path'

95

102

96----------------------------------------------------------------

103----------------------------------------------------------------

97

104

@@ -112,7 +119,7 @@ clean old = do

112 new <- pruneWith old prune

119 new <- pruneWith old prune

113 return $ merge new

120 return $ merge new

114 where

121 where

115− prune (_,FdEntry fd mst) = status mst >>= act

122+ prune (FdEntry _ fd mst) = status mst >>= act

116 where

123 where

117 act Active = inactive mst >> return True

124 act Active = inactive mst >> return True

118 act Inactive = closeFd fd >> return False

125 act Inactive = closeFd fd >> return False

@@ -122,21 +129,21 @@ clean old = do

122terminate :: MutableFdCache -> IO ()

129terminate :: MutableFdCache -> IO ()

123terminate (MutableFdCache reaper) = do

130terminate (MutableFdCache reaper) = do

124 !t <- reaperStop reaper

131 !t <- reaperStop reaper

125− mapM_ (closeIt . snd) $ toList t

132+ mapM_ closeIt $ toList t

126 where

133 where

127− closeIt (FdEntry fd _) = closeFd fd

134+ closeIt (FdEntry _ fd _) = closeFd fd

128

135

129----------------------------------------------------------------

136----------------------------------------------------------------

130

137

131-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

138-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

132−getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)

139+getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)

133−getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get

140+getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get

134 where

141 where

135 get Nothing = do

142 get Nothing = do

136− ent@(FdEntry fd mst) <- newFdEntry path

143+ ent@(FdEntry _ fd mst) <- newFdEntry path

137− reaperAdd reaper (path,ent)

144+ reaperAdd reaper (h, ent)

138 return (Just fd, refresh mst)

145 return (Just fd, refresh mst)

139− get (Just (FdEntry fd mst)) = do

146+ get (Just (FdEntry _ fd mst)) = do

140 refresh mst

147 refresh mst

141 return (Just fd, refresh mst)

148 return (Just fd, refresh mst)

142#endif

149#endif

warp/Network/Wai/Handler/Warp/File.hs+10−12

@@ -9,18 +9,19 @@ module Network.Wai.Handler.Warp.File (

9 , H.parseByteRanges

10 ) where

11

12+import Control.Applicative ((<|>))

12import Data.Array ((!))

13import Data.Array ((!))

13−import qualified Data.ByteString.Char8 as C8 (pack)

14+import qualified Data.ByteString.Char8 as B (pack)

15+import Data.ByteString (ByteString)

16+import Data.Maybe (fromMaybe)

14import Network.HTTP.Date

17import Network.HTTP.Date

15import qualified Network.HTTP.Types as H

18import qualified Network.HTTP.Types as H

16import qualified Network.HTTP.Types.Header as H

19import qualified Network.HTTP.Types.Header as H

17import Network.Wai

20import Network.Wai

18−

19import qualified Network.Wai.Handler.Warp.FileInfoCache as I

21import qualified Network.Wai.Handler.Warp.FileInfoCache as I

20import Network.Wai.Handler.Warp.Header

22import Network.Wai.Handler.Warp.Header

21−import Network.Wai.Handler.Warp.Imports

22import Network.Wai.Handler.Warp.PackInt

23import Network.Wai.Handler.Warp.PackInt

23−

24+import Numeric (showInt)

24

25

25-- $setup

26-- $setup

26-- >>> import Test.QuickCheck

27-- >>> import Test.QuickCheck

@@ -34,15 +35,12 @@ data RspFileInfo = WithoutBody H.Status

34----------------------------------------------------------------

35----------------------------------------------------------------

35

36

36conditionalRequest :: I.FileInfo

37conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders

38+ -> H.ResponseHeaders -> IndexedHeader

38− -> IndexedHeader -- ^ Response

39− -> IndexedHeader -- ^ Request

40 -> RspFileInfo

39 -> RspFileInfo

41−conditionalRequest finfo hs0 rspidx reqidx = case condition of

40+conditionalRequest finfo hs0 reqidx = case condition of

42 nobody@(WithoutBody _) -> nobody

41 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

42+ WithBody s _ off len -> let !hs = (H.hLastModified,date) :

43+ addContentHeaders hs0 off len size

46 in WithBody s hs off len

44 in WithBody s hs off len

47 where

45 where

48 !mtime = I.fileInfoTime finfo

46 !mtime = I.fileInfoTime finfo

@@ -119,7 +117,7 @@ checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)

119contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

117contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

120contentRangeHeader beg end total = (H.hContentRange, range)

118contentRangeHeader beg end total = (H.hContentRange, range)

121 where

119 where

122− range = C8.pack

120+ range = B.pack

123 -- building with ShowS

121 -- building with ShowS

124 $ 'b' : 'y': 't' : 'e' : 's' : ' '

122 $ 'b' : 'y': 't' : 'e' : 's' : ' '

125 : (if beg > end then ('*':) else

123 : (if beg > end then ('*':) else

warp/Network/Wai/Handler/Warp/FileInfoCache.hs+26−23

@@ -2,21 +2,24 @@

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

8

9

9import Control.Exception as E

10import Control.Exception as E

11+import Control.Monad (void)

10import Control.Reaper

12import Control.Reaper

13+import Data.ByteString (ByteString)

11import Network.HTTP.Date

14import Network.HTTP.Date

12−import System.PosixCompat.Files

13−

14import Network.Wai.Handler.Warp.HashMap (HashMap)

15import Network.Wai.Handler.Warp.HashMap (HashMap)

15import qualified Network.Wai.Handler.Warp.HashMap as M

16import qualified Network.Wai.Handler.Warp.HashMap as M

16−import Network.Wai.Handler.Warp.Imports

17+import System.PosixCompat.Files

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,22 +85,22 @@ 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 =

89 E.bracket (initialize duration)

92 E.bracket (initialize duration)

90 terminate

93 terminate

91− (action . getAndRegisterInfo)

94+ (\r -> action (getAndRegisterInfo r))

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+56−72

@@ -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

8+import Control.Monad (when, unless, replicateM_)

9+import Data.ByteString (ByteString)

11−import qualified Network.HTTP2.Server as H2

10+import Network.HTTP2

12import Network.Socket (SockAddr)

11import Network.Socket (SockAddr)

13import Network.Wai

12import Network.Wai

14−import Network.Wai.Internal (ResponseReceived(..))

13+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

15−import qualified System.TimeManager as T

16−

17−import Network.Wai.Handler.Warp.HTTP2.File

14+import Network.Wai.Handler.Warp.HTTP2.Manager

18−import Network.Wai.Handler.Warp.HTTP2.PushPromise

15+import Network.Wai.Handler.Warp.HTTP2.Receiver

19import Network.Wai.Handler.Warp.HTTP2.Request

16import Network.Wai.Handler.Warp.HTTP2.Request

20−import Network.Wai.Handler.Warp.HTTP2.Response

17+import Network.Wai.Handler.Warp.HTTP2.Sender

18+import Network.Wai.Handler.Warp.HTTP2.Types

21−import Network.Wai.Handler.Warp.Imports

19+import Network.Wai.Handler.Warp.HTTP2.Worker

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+35

@@ -0,0 +1,35 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+

3+module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where

4+

5+import Data.ByteString (ByteString)

6+import Network.HTTP2

7+

8+----------------------------------------------------------------

9+

10+goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString

11+goawayFrame sid etype debugmsg = encodeFrame einfo frame

12+ where

13+ einfo = encodeInfo id 0

14+ frame = GoAwayFrame sid etype debugmsg

15+

16+resetFrame :: ErrorCodeId -> StreamId -> ByteString

17+resetFrame etype sid = encodeFrame einfo frame

18+ where

19+ einfo = encodeInfo id sid

20+ frame = RSTStreamFrame etype

21+

22+settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString

23+settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist

24+ where

25+ einfo = encodeInfo func 0

26+

27+pingFrame :: ByteString -> ByteString

28+pingFrame bs = encodeFrame einfo $ PingFrame bs

29+ where

30+ einfo = encodeInfo setAck 0

31+

32+windowUpdateFrame :: StreamId -> WindowSize -> ByteString

33+windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz

34+ where

35+ einfo = encodeInfo id sid

warp/Network/Wai/Handler/Warp/HTTP2/File.hs+152−23

@@ -1,30 +1,159 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE BangPatterns, RecordWildCards #-}

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 Control.Applicative ((<|>))

13+import qualified Data.ByteString.Char8 as B (pack)

14+import Data.ByteString (ByteString)

15+import Data.Maybe (fromMaybe)

16+import Network.HTTP.Date

17+import qualified Network.HTTP.Types as H

18+import Network.Wai

19+import qualified Network.Wai.Handler.Warp.FileInfoCache as I

20+import Network.Wai.Handler.Warp.PackInt

21+import Numeric (showInt)

22+import Network.HPACK

23+import Network.HPACK.Token

6

24

7−import Network.Wai.Handler.Warp.Types

25+-- $setup

26+-- >>> import Test.QuickCheck

8

27

9−#ifdef WINDOWS

28+----------------------------------------------------------------

10−pReadMaker :: InternalInfo -> PositionReadMaker

11−pReadMaker _ = defaultPositionReadMaker

12−#else

13−import Network.Wai.Handler.Warp.FdCache

14−import Network.Wai.Handler.Warp.SendFile (positionRead)

15

29

16−pReadMaker :: InternalInfo -> PositionReadMaker

30+data RspFileInfo = WithoutBody !H.Status

17−pReadMaker ii path = do

31+ | WithBody !H.Status !TokenHeaderList !Integer !Integer

18− (mfd, refresh) <- getFd ii path

32+ deriving (Eq,Show)

19− case mfd of

33+

20− Just fd -> return (pread fd, Refresher refresh)

34+----------------------------------------------------------------

21− Nothing -> do

35+

22− fd <- openFile path

36+conditionalRequest :: I.FileInfo

23− return (pread fd, Closer $ closeFile fd)

37+ -> TokenHeaderList -- Response

38+ -> ValueTable -- Request

39+ -> RspFileInfo

40+conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of

41+ nobody@(WithoutBody _) -> nobody

42+ WithBody s _ off len -> let !hs = (tokenLastModified,date) :

43+ addContentHeaders ths0 off len size

44+ in WithBody s hs off len

45+ where

46+ !mcondition = ifmodified reqtbl size mtime

47+ <|> ifunmodified reqtbl size mtime

48+ <|> ifrange reqtbl size mtime

49+ !condition = fromMaybe (unconditional reqtbl size) mcondition

50+

51+----------------------------------------------------------------

52+

53+{-# INLINE ifModifiedSince #-}

54+ifModifiedSince :: ValueTable -> Maybe HTTPDate

55+ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate

56+

57+{-# INLINE ifUnmodifiedSince #-}

58+ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate

59+ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate

60+

61+{-# INLINE ifRange #-}

62+ifRange :: ValueTable -> Maybe HTTPDate

63+ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate

64+

65+----------------------------------------------------------------

66+

67+{-# INLINE ifmodified #-}

68+ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

69+ifmodified reqtbl size mtime = do

70+ date <- ifModifiedSince reqtbl

71+ return $ if date /= mtime

72+ then unconditional reqtbl size

73+ else WithoutBody H.notModified304

74+

75+{-# INLINE ifunmodified #-}

76+ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

77+ifunmodified reqtbl size mtime = do

78+ date <- ifUnmodifiedSince reqtbl

79+ return $ if date == mtime

80+ then unconditional reqtbl size

81+ else WithoutBody H.preconditionFailed412

82+

83+{-# INLINE ifrange #-}

84+ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

85+ifrange reqtbl size mtime = do

86+ date <- ifRange reqtbl

87+ rng <- getHeaderValue tokenRange reqtbl

88+ return $ if date == mtime

89+ then parseRange rng size

90+ else WithBody H.ok200 [] 0 size

91+

92+{-# INLINE unconditional #-}

93+unconditional :: ValueTable -> Integer -> RspFileInfo

94+unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of

95+ Nothing -> WithBody H.ok200 [] 0 size

96+ Just rng -> parseRange rng size

97+

98+----------------------------------------------------------------

99+

100+{-# INLINE parseRange #-}

101+parseRange :: ByteString -> Integer -> RspFileInfo

102+parseRange rng size = case H.parseByteRanges rng of

103+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416

104+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416

105+ Just (r:_) -> let (!beg, !end) = checkRange r size

106+ !len = end - beg + 1

107+ s = if beg == 0 && end == size - 1 then

108+ H.ok200

109+ else

110+ H.partialContent206

111+ in WithBody s [] beg len

112+

113+{-# INLINE checkRange #-}

114+checkRange :: H.ByteRange -> Integer -> (Integer, Integer)

115+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)

116+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)

117+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)

118+

119+----------------------------------------------------------------

120+

121+{-# INLINE contentRangeHeader #-}

122+-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'

123+-- for the range specified.

124+contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader

125+contentRangeHeader beg end total = (tokenContentRange, range)

126+ where

127+ range = B.pack

128+ -- building with ShowS

129+ $ 'b' : 'y': 't' : 'e' : 's' : ' '

130+ : (if beg > end then ('*':) else

131+ showInt beg

132+ . ('-' :)

133+ . showInt end)

134+ ( '/'

135+ : showInt total "")

136+

137+{-# INLINE addContentHeaders #-}

138+addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList

139+addContentHeaders ths off len size

140+ | len == size = ths'

141+ | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size

142+ in ctrng:ths'

143+ where

144+ !lengthBS = packIntegral len

145+ !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths

146+

147+{-# INLINE addContentHeadersForFilePart #-}

148+-- |

149+--

150+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)

151+-- [(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")]

152+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)

153+-- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]

154+addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList

155+addContentHeadersForFilePart hs part = addContentHeaders hs off len size

24 where

156 where

25− pread :: Fd -> PositionRead

157+ off = filePartOffset part

26− pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'

158+ len = filePartByteCount part

27− where

159+ size = filePartFileSize part

28− bytes' = fromIntegral bytes

29− off' = fromIntegral off

30−#endif

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hsnew file+112

@@ -0,0 +1,112 @@

1+{-# LANGUAGE OverloadedStrings, BangPatterns #-}

2+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

3+

4+module Network.Wai.Handler.Warp.HTTP2.HPACK (

5+ hpackEncodeHeader

6+ , hpackEncodeHeaderLoop

7+ , hpackDecodeHeader

8+ , just

9+ , addNecessaryHeaders

10+ , addHeader -- testing

11+ ) where

12+

13+import qualified Control.Exception as E

14+import Control.Monad (unless)

15+import Data.ByteString (ByteString)

16+import Network.HPACK hiding (Buffer)

17+import Network.HPACK.Token

18+import Network.HTTP2

19+import Network.Wai.Handler.Warp.HTTP2.Types

20+import Network.Wai.Handler.Warp.PackInt

21+import qualified Network.Wai.Handler.Warp.Settings as S

22+import Network.Wai.Handler.Warp.Types

23+

24+-- $setup

25+-- >>> :set -XOverloadedStrings

26+

27+----------------------------------------------------------------

28+

29+{-# INLINE addHeader #-}

30+addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList

31+addHeader t "" tbl ths = case getHeaderValue t tbl of

32+ Nothing -> ths

33+ _ -> filter ((/= tokenServer) . fst) ths

34+addHeader t v tbl ths = case getHeaderValue t tbl of

35+ Nothing -> (t,v) : ths

36+ _ -> ths

37+

38+addNecessaryHeaders :: Context

39+ -> Rspn

40+ -> InternalInfo

41+ -> S.Settings

42+ -> IO TokenHeaderList

43+addNecessaryHeaders Context{..} rspn ii settings = do

44+ date <- getDate ii

45+ let !s = rspnStatus rspn

46+ !status = packStatus s

47+ !defServer = S.settingsServerName settings

48+ (!ths0,tbl) = rspnHeaders rspn

49+ !ths1 = addHeader tokenServer defServer tbl ths0

50+ !ths2 = addHeader tokenDate date tbl ths1

51+ !ths3 = (tokenStatus, status) : ths2

52+ return ths3

53+

54+----------------------------------------------------------------

55+

56+strategy :: EncodeStrategy

57+strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }

58+

59+-- Set-Cookie: contains only one cookie value.

60+-- So, we don't need to split it.

61+hpackEncodeHeader :: Context -> Buffer -> BufSize

62+ -> TokenHeaderList

63+ -> IO (TokenHeaderList, Int)

64+hpackEncodeHeader Context{..} buf siz ths =

65+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths

66+

67+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize

68+ -> TokenHeaderList

69+ -> IO (TokenHeaderList, Int)

70+hpackEncodeHeaderLoop Context{..} buf siz hs =

71+ encodeTokenHeader buf siz strategy False encodeDynamicTable hs

72+

73+----------------------------------------------------------------

74+

75+hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)

76+hpackDecodeHeader hdrblk Context{..} = do

77+ tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl

78+ unless (checkRequestHeader vt) $

79+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

80+ return tbl

81+ where

82+ handl IllegalHeaderName =

83+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

84+ handl _ =

85+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"

86+

87+{-# INLINE checkRequestHeader #-}

88+checkRequestHeader :: ValueTable -> Bool

89+checkRequestHeader reqvt

90+ | just mMethod (== "CONNECT") = mPath == Nothing && mScheme == Nothing

91+ | mStatus /= Nothing = False

92+ | mMethod == Nothing = False

93+ | mScheme == Nothing = False

94+ | mPath == Nothing = False

95+ | mPath == Just "" = False

96+ | mConnection /= Nothing = False

97+ | just mTE (/= "trailers") = False

98+ | otherwise = True

99+ where

100+ mStatus = getHeaderValue tokenStatus reqvt

101+ mScheme = getHeaderValue tokenScheme reqvt

102+ mPath = getHeaderValue tokenPath reqvt

103+ mMethod = getHeaderValue tokenMethod reqvt

104+ mConnection = getHeaderValue tokenConnection reqvt

105+ mTE = getHeaderValue tokenTE reqvt

106+

107+{-# INLINE just #-}

108+just :: Maybe a -> (a -> Bool) -> Bool

109+just Nothing _ = False

110+just (Just x) p

111+ | p x = True

112+ | otherwise = False

warp/Network/Wai/Handler/Warp/HTTP2/Manager.hsnew file+97

@@ -0,0 +1,97 @@

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+#if __GLASGOW_HASKELL__ < 709

17+import Control.Applicative

18+#endif

19+import Control.Concurrent

20+import Control.Concurrent.STM

21+import Control.Monad (void)

22+import Data.Set (Set)

23+import qualified Data.Set as Set

24+import Data.Foldable

25+import Network.Wai.Handler.Warp.IORef

26+import Network.Wai.Handler.Warp.Settings

27+import qualified Network.Wai.Handler.Warp.Timeout as T

28+

29+----------------------------------------------------------------

30+

31+type Action = T.Manager -> IO ()

32+

33+data Command = Stop | Spawn | Add ThreadId | Delete ThreadId

34+

35+data Manager = Manager (TQueue Command) (IORef Action)

36+

37+-- | Starting a thread pool manager.

38+-- Its action is initially set to 'return ()' and should be set

39+-- by 'setAction'. This allows that the action can include

40+-- the manager itself.

41+start :: Settings -> IO Manager

42+start set = do

43+ q <- newTQueueIO

44+ ref <- newIORef (\_ -> return ())

45+ timmgr <- T.initialize $ settingsTimeout set * 1000000

46+ void $ forkIO $ go q Set.empty ref timmgr

47+ return $ Manager q ref

48+ where

49+ go q !tset0 ref timmgr = do

50+ x <- atomically $ readTQueue q

51+ case x of

52+ Stop -> kill tset0 >> T.killManager timmgr

53+ Spawn -> next tset0

54+ Add newtid -> let !tset = add newtid tset0

55+ in go q tset ref timmgr

56+ Delete oldtid -> let !tset = del oldtid tset0

57+ in go q tset ref timmgr

58+ where

59+ next tset = do

60+ action <- readIORef ref

61+ newtid <- forkIO (action timmgr)

62+ let !tset' = add newtid tset

63+ go q tset' ref timmgr

64+

65+setAction :: Manager -> Action -> IO ()

66+setAction (Manager _ ref) action = writeIORef ref action

67+

68+stop :: Manager -> IO ()

69+stop (Manager q _) = atomically $ writeTQueue q Stop

70+

71+spawnAction :: Manager -> IO ()

72+spawnAction (Manager q _) = atomically $ writeTQueue q Spawn

73+

74+addMyId :: Manager -> IO ()

75+addMyId (Manager q _) = do

76+ tid <- myThreadId

77+ atomically $ writeTQueue q $ Add tid

78+

79+deleteMyId :: Manager -> IO ()

80+deleteMyId (Manager q _) = do

81+ tid <- myThreadId

82+ atomically $ writeTQueue q $ Delete tid

83+

84+----------------------------------------------------------------

85+

86+add :: ThreadId -> Set ThreadId -> Set ThreadId

87+add tid set = set'

88+ where

89+ !set' = Set.insert tid set

90+

91+del :: ThreadId -> Set ThreadId -> Set ThreadId

92+del tid set = set'

93+ where

94+ !set' = Set.delete tid set

95+

96+kill :: Set ThreadId -> IO ()

97+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+400

@@ -0,0 +1,400 @@

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+#if __GLASGOW_HASKELL__ < 709

10+import Control.Applicative

11+#endif

12+import Control.Concurrent

13+import Control.Concurrent.STM

14+import qualified Control.Exception as E

15+import Control.Monad (when, unless, void)

16+import Data.ByteString (ByteString)

17+import qualified Data.ByteString as BS

18+import Network.HPACK

19+import Network.HPACK.Token

20+import Network.HTTP2

21+import Network.HTTP2.Priority (toPrecedence, delete, prepare)

22+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

23+import Network.Wai.Handler.Warp.HTTP2.HPACK

24+import Network.Wai.Handler.Warp.HTTP2.Request

25+import Network.Wai.Handler.Warp.HTTP2.Types

26+import Network.Wai.Handler.Warp.IORef

27+import Network.Wai.Handler.Warp.ReadInt

28+import Network.Wai.Handler.Warp.Types

29+

30+----------------------------------------------------------------

31+

32+frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()

33+frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway

34+ where

35+ Context{ http2settings

36+ , streamTable

37+ , concurrency

38+ , continued

39+ , clientStreamId

40+ , inputQ

41+ , controlQ

42+ } = ctx

43+ sendGoaway e

44+ | Just (ConnectionError err msg) <- E.fromException e = do

45+ csid <- readIORef clientStreamId

46+ let !frame = goawayFrame csid err msg

47+ enqueueControl controlQ $ CGoaway frame

48+ | otherwise = return ()

49+

50+ sendReset err sid = do

51+ let !frame = resetFrame err sid

52+ enqueueControl controlQ $ CFrame frame

53+

54+ loop :: Int -> IO ()

55+ loop !n

56+ | n == 6 = do

57+ yield

58+ loop 0

59+ | otherwise = do

60+ hd <- recvN frameHeaderLength

61+ if BS.null hd then

62+ enqueueControl controlQ CFinish

63+ else do

64+ cont <- processStreamGuardingError $ decodeFrameHeader hd

65+ when cont $ loop (n + 1)

66+

67+ processStreamGuardingError (fid, FrameHeader{streamId})

68+ | isResponse streamId &&

69+ (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =

70+ E.throwIO $ ConnectionError ProtocolError "stream id should be odd"

71+ processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do

72+ mx <- readIORef continued

73+ case mx of

74+ Nothing -> do

75+ -- ignoring unknown frame

76+ consume payloadLength

77+ return True

78+ Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"

79+ processStreamGuardingError (FramePushPromise, _) =

80+ E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"

81+ processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do

82+ settings <- readIORef http2settings

83+ case checkFrameHeader settings typhdr of

84+ Left h2err -> case h2err of

85+ StreamError err sid -> do

86+ sendReset err sid

87+ consume payloadLength

88+ return True

89+ connErr -> E.throwIO connErr

90+ Right _ -> do

91+ ex <- E.try $ controlOrStream ftyp header

92+ case ex of

93+ Left (StreamError err sid) -> do

94+ sendReset err sid

95+ return True

96+ Left connErr -> E.throw connErr

97+ Right cont -> return cont

98+

99+ controlOrStream ftyp header@FrameHeader{streamId, payloadLength}

100+ | isControl streamId = do

101+ pl <- recvN payloadLength

102+ control ftyp header pl ctx

103+ | otherwise = do

104+ checkContinued

105+ !mstrm <- getStream

106+ pl <- recvN payloadLength

107+ case mstrm of

108+ Nothing -> do

109+ -- for h2spec only

110+ when (ftyp == FramePriority) $ do

111+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl

112+ checkPriority newpri streamId

113+ return True -- just ignore this frame

114+ Just strm@Stream{streamState,streamPrecedence} -> do

115+ state <- readIORef streamState

116+ state' <- stream ftyp header pl ctx state strm

117+ case state' of

118+ Open (NoBody tbl@(_,reqvt) pri) -> do

119+ resetContinued

120+ let mcl = readInt <$> getHeaderValue tokenContentLength reqvt

121+ when (just mcl (== (0 :: Int))) $

122+ E.throwIO $ StreamError ProtocolError streamId

123+ writeIORef streamPrecedence $ toPrecedence pri

124+ writeIORef streamState HalfClosed

125+ (!req, !ii) <- mkreq tbl (Just 0, return "")

126+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii

127+ Open (HasBody tbl@(_,reqvt) pri) -> do

128+ resetContinued

129+ q <- newTQueueIO

130+ let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt

131+ writeIORef streamPrecedence $ toPrecedence pri

132+ bodyLength <- newIORef 0

133+ writeIORef streamState $ Open (Body q mcl bodyLength)

134+ readQ <- newReadBody q

135+ bodySource <- mkSource readQ

136+ (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)

137+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii

138+ s@(Open Continued{}) -> do

139+ setContinued

140+ writeIORef streamState s

141+ s -> do -- Idle, Open Body, HalfClosed, Closed

142+ resetContinued

143+ writeIORef streamState s

144+ return True

145+ where

146+ setContinued = writeIORef continued (Just streamId)

147+ resetContinued = writeIORef continued Nothing

148+ checkContinued = do

149+ mx <- readIORef continued

150+ case mx of

151+ Nothing -> return ()

152+ Just sid

153+ | sid == streamId && ftyp == FrameContinuation -> return ()

154+ | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"

155+ getStream = do

156+ mstrm0 <- search streamTable streamId

157+ case mstrm0 of

158+ js@(Just strm0) -> do

159+ when (ftyp == FrameHeaders) $ do

160+ st <- readIORef $ streamState strm0

161+ when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed"

162+ -- Priority made an idele stream

163+ when (isIdle st) $ opened ctx strm0

164+ return js

165+ Nothing

166+ | isResponse streamId -> return Nothing

167+ | otherwise -> do

168+ when (ftyp `notElem` [FrameHeaders,FramePriority]) $

169+ E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream"

170+ csid <- readIORef clientStreamId

171+ if streamId <= csid then do

172+ if ftyp == FramePriority then

173+ return Nothing -- will be ignored

174+ else

175+ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"

176+ else do

177+ when (ftyp == FrameHeaders) $ do

178+ writeIORef clientStreamId streamId

179+ cnt <- readIORef concurrency

180+ -- Checking the limitation of concurrency

181+ when (cnt >= maxConcurrency) $

182+ E.throwIO $ StreamError RefusedStream streamId

183+ ws <- initialWindowSize <$> readIORef http2settings

184+ newstrm <- newStream streamId (fromIntegral ws)

185+ when (ftyp == FrameHeaders) $ opened ctx newstrm

186+ insert streamTable streamId newstrm

187+ return $ Just newstrm

188+

189+ consume = void . recvN

190+

191+maxConcurrency :: Int

192+maxConcurrency = recommendedConcurrency

193+

194+initialFrame :: ByteString

195+initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]

196+

197+----------------------------------------------------------------

198+

199+control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool

200+control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do

201+ SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs

202+ case checkSettingsList alist of

203+ Just x -> E.throwIO x

204+ Nothing -> return ()

205+ -- HTTP/2 Setting from a browser

206+ unless (testAck flags) $ do

207+ oldws <- initialWindowSize <$> readIORef http2settings

208+ modifyIORef' http2settings $ \old -> updateSettings old alist

209+ newws <- initialWindowSize <$> readIORef http2settings

210+ let diff = newws - oldws

211+ when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable

212+ let !frame = settingsFrame setAck []

213+ sent <- readIORef firstSettings

214+ let !setframe

215+ | sent = CSettings frame alist

216+ | otherwise = CSettings0 initialFrame frame alist

217+ unless sent $ writeIORef firstSettings True

218+ enqueueControl controlQ setframe

219+ return True

220+

221+control FramePing FrameHeader{flags} bs Context{controlQ} =

222+ if testAck flags then

223+ return True -- just ignore

224+ else do

225+ let !frame = pingFrame bs

226+ enqueueControl controlQ $ CFrame frame

227+ return True

228+

229+control FrameGoAway _ _ Context{controlQ} = do

230+ enqueueControl controlQ CFinish

231+ return False

232+

233+control FrameWindowUpdate header bs Context{connectionWindow} = do

234+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

235+ !w <- atomically $ do

236+ w0 <- readTVar connectionWindow

237+ let !w1 = w0 + n

238+ writeTVar connectionWindow w1

239+ return w1

240+ when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"

241+ return True

242+

243+control _ _ _ _ =

244+ -- must not reach here

245+ return False

246+

247+----------------------------------------------------------------

248+

249+{-# INLINE guardIt #-}

250+guardIt :: Either HTTP2Error a -> IO a

251+guardIt x = case x of

252+ Left err -> E.throwIO err

253+ Right frame -> return frame

254+

255+

256+{-# INLINE checkPriority #-}

257+checkPriority :: Priority -> StreamId -> IO ()

258+checkPriority p me

259+ | dep == me = E.throwIO $ StreamError ProtocolError me

260+ | otherwise = return ()

261+ where

262+ dep = streamDependency p

263+

264+stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState

265+stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do

266+ HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs

267+ pri <- case mp of

268+ Nothing -> return defaultPriority

269+ Just p -> do

270+ checkPriority p streamNumber

271+ return p

272+ let !endOfStream = testEndStream flags

273+ !endOfHeader = testEndHeader flags

274+ if endOfHeader then do

275+ tbl <- hpackDecodeHeader frag ctx -- fixme

276+ return $ if endOfStream then

277+ Open (NoBody tbl pri)

278+ else

279+ Open (HasBody tbl pri)

280+ else do

281+ let !siz = BS.length frag

282+ return $ Open $ Continued [frag] siz 1 endOfStream pri

283+

284+stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do

285+ -- trailer is not supported.

286+ -- let's read and ignore it.

287+ HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs

288+ let !endOfStream = testEndStream flags

289+ if endOfStream then do

290+ atomically $ writeTQueue q ""

291+ return HalfClosed

292+ else

293+ -- we don't support continuation here.

294+ E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"

295+

296+stream FrameData

297+ header@FrameHeader{flags,payloadLength,streamId}

298+ bs

299+ Context{controlQ} s@(Open (Body q mcl bodyLength))

300+ Stream{streamNumber} = do

301+ DataFrame body <- guardIt $ decodeDataFrame header bs

302+ let !endOfStream = testEndStream flags

303+ len0 <- readIORef bodyLength

304+ let !len = len0 + payloadLength

305+ writeIORef bodyLength len

306+ when (payloadLength /= 0) $ do

307+ let !frame1 = windowUpdateFrame 0 payloadLength

308+ !frame2 = windowUpdateFrame streamNumber payloadLength

309+ !frame = frame1 `BS.append` frame2

310+ enqueueControl controlQ $ CFrame frame

311+ atomically $ writeTQueue q body

312+ if endOfStream then do

313+ case mcl of

314+ Nothing -> return ()

315+ Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId

316+ atomically $ writeTQueue q ""

317+ return HalfClosed

318+ else

319+ return s

320+

321+stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do

322+ let !endOfHeader = testEndHeader flags

323+ !rfrags' = frag : rfrags

324+ !siz' = siz + BS.length frag

325+ !n' = n + 1

326+ when (siz' > 51200) $ -- fixme: hard coding: 50K

327+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"

328+ when (n' > 10) $ -- fixme: hard coding

329+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"

330+ if endOfHeader then do

331+ let !hdrblk = BS.concat $ reverse rfrags'

332+ tbl <- hpackDecodeHeader hdrblk ctx

333+ return $ if endOfStream then

334+ Open (NoBody tbl pri)

335+ else

336+ Open (HasBody tbl pri)

337+ else

338+ return $ Open $ Continued rfrags' siz' n' endOfStream pri

339+

340+stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do

341+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

342+ !w <- atomically $ do

343+ w0 <- readTVar streamWindow

344+ let !w1 = w0 + n

345+ writeTVar streamWindow w1

346+ return w1

347+ when (isWindowOverflow w) $

348+ E.throwIO $ StreamError FlowControlError streamId

349+ return s

350+

351+stream FrameRSTStream header bs ctx _ strm = do

352+ RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs

353+ let !cc = Reset e

354+ closed ctx strm cc

355+ return $ Closed cc -- will be written to streamState again

356+

357+stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do

358+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs

359+ checkPriority newpri streamNumber

360+ oldpre <- readIORef streamPrecedence

361+ let !newpre = toPrecedence newpri

362+ writeIORef streamPrecedence newpre

363+ if isIdle s then do

364+ n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))

365+ -- fixme hard coding

366+ when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"

367+ prepare outputQ streamNumber newpri

368+ else do

369+ mx <- delete outputQ streamNumber oldpre

370+ case mx of

371+ Nothing -> return ()

372+ Just out -> enqueueOutput outputQ out

373+ return s

374+

375+-- this ordering is important

376+stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"

377+stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"

378+-- Ignore frames to streams we have just reset, per section 5.1.

379+stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st

380+stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId

381+stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId

382+

383+----------------------------------------------------------------

384+

385+{-# INLINE newReadBody #-}

386+newReadBody :: TQueue ByteString -> IO (IO ByteString)

387+newReadBody q = do

388+ ref <- newIORef False

389+ return $ readBody q ref

390+

391+{-# INLINE readBody #-}

392+readBody :: TQueue ByteString -> IORef Bool -> IO ByteString

393+readBody q ref = do

394+ eof <- readIORef ref

395+ if eof then

396+ return ""

397+ else do

398+ bs <- atomically $ readTQueue q

399+ when (bs == "") $ writeIORef ref True

400+ return bs

warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+31−28

@@ -1,54 +1,56 @@

1+{-# LANGUAGE OverloadedStrings, 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

8 ) where

10 ) where

9

11

12+import Control.Applicative ((<|>))

10import Control.Arrow (first)

13import Control.Arrow (first)

14+import Data.ByteString (ByteString)

11−import qualified Data.ByteString.Char8 as C8

15+import qualified Data.ByteString.Char8 as B8

12−import Data.IORef

16+import Data.Maybe (fromJust)

13import qualified Data.Vault.Lazy as Vault

17import qualified Data.Vault.Lazy as Vault

14import Network.HPACK

18import Network.HPACK

15import Network.HPACK.Token

19import Network.HPACK.Token

16import qualified Network.HTTP.Types as H

20import qualified Network.HTTP.Types as H

17import Network.Socket (SockAddr)

21import Network.Socket (SockAddr)

18import Network.Wai

22import Network.Wai

19−import Network.Wai.Internal (Request(..))

20−import System.IO.Unsafe (unsafePerformIO)

21−import qualified System.TimeManager as T

22−

23import Network.Wai.Handler.Warp.HTTP2.Types

24−import Network.Wai.Handler.Warp.Imports

24+import Network.Wai.Handler.Warp.HashMap (hashByteString)

25+import Network.Wai.Handler.Warp.IORef

25−import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey, getClientCertificateKey)

26+import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)

26import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

27import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

28+import qualified Network.Wai.Handler.Warp.Timeout as Timeout

27import Network.Wai.Handler.Warp.Types

29import Network.Wai.Handler.Warp.Types

30+import Network.Wai.Internal (Request(..))

31+import System.IO.Unsafe (unsafePerformIO)

28

32

29−type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request

33+type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)

30−

31−----------------------------------------------------------------

32

34

33−toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq

35+mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq

34−toRequest ii settings addr ht bodylen body th transport = do

36+mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do

35 ref <- newIORef Nothing

37 ref <- newIORef Nothing

36− toRequest' ii settings addr ref ht bodylen body th transport

38+ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)

37

39

38−toRequest' :: InternalInfo -> S.Settings -> SockAddr

40+mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr

39 -> IORef (Maybe HTTP2Data)

41 -> IORef (Maybe HTTP2Data)

40− -> ToReq

42+ -> MkReq

41−toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req

43+mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)

42 where

44 where

43 !req = Request {

45 !req = Request {

44 requestMethod = colonMethod

46 requestMethod = colonMethod

45− , httpVersion = H.http20

47+ , httpVersion = http2ver

46 , rawPathInfo = rawPath

48 , rawPathInfo = rawPath

47 , pathInfo = H.decodePathSegments path

49 , pathInfo = H.decodePathSegments path

48 , rawQueryString = query

50 , rawQueryString = query

49 , queryString = H.parseQuery query

51 , queryString = H.parseQuery query

50 , requestHeaders = headers

52 , requestHeaders = headers

51− , isSecure = isTransportSecure transport

53+ , isSecure = True

52 , remoteHost = addr

54 , remoteHost = addr

53 , requestBody = body

55 , requestBody = body

54 , vault = vaultValue

56 , vault = vaultValue

@@ -74,21 +76,22 @@ toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = retur

74 !mUserAgent = getHeaderValue tokenUserAgent reqvt

76 !mUserAgent = getHeaderValue tokenUserAgent reqvt

75 -- CONNECT request will have ":path" omitted, use ":authority" as unparsed

77 -- CONNECT request will have ":path" omitted, use ":authority" as unparsed

76 -- path instead so that it will have consistent behavior compare to HTTP 1.0

78 -- path instead so that it will have consistent behavior compare to HTTP 1.0

77− (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)

79+ (unparsedPath,query) = B8.break (=='?') $ fromJust (mPath <|> mAuth)

78 !path = H.extractPath unparsedPath

80 !path = H.extractPath unparsedPath

79 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

81 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

80− -- fixme: pauseTimeout. th is not available here.

82+ !h = hashByteString rawPath

83+ !ii = toInternalInfo ii1 h

84+ !th = threadHandle ii

85+ !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

81− !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)

86+ $ Vault.insert getFileInfoKey (getFileInfo ii)

82 $ Vault.insert getHTTP2DataKey (readIORef ref)

87 $ Vault.insert getHTTP2DataKey (readIORef ref)

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

88 $ Vault.insert setHTTP2DataKey (writeIORef ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

89 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

85− $ Vault.insert pauseTimeoutKey (T.pause th)

86− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

87 Vault.empty

90 Vault.empty

88

91

89getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

92getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

90getHTTP2DataKey = unsafePerformIO Vault.newKey

93getHTTP2DataKey = unsafePerformIO Vault.newKey

91−{-# NOINLINE getHTTP2DataKey #-}

94+{-# NOINLINE getHTTP2Data #-}

92

95

93-- | Getting 'HTTP2Data' through vault of the request.

96-- | Getting 'HTTP2Data' through vault of the request.

94-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.

97-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.

@@ -101,7 +104,7 @@ getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of

101

104

102setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())

105setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())

103setHTTP2DataKey = unsafePerformIO Vault.newKey

106setHTTP2DataKey = unsafePerformIO Vault.newKey

104−{-# NOINLINE setHTTP2DataKey #-}

107+{-# NOINLINE setHTTP2Data #-}

105

108

106-- | Setting 'HTTP2Data' through vault of the request.

109-- | Setting 'HTTP2Data' through vault of the request.

107-- 'Application' or 'Middleware' should use this.

110-- 'Application' or 'Middleware' should use this.

@@ -114,7 +117,7 @@ setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of

114

117

115modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

118modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

116modifyHTTP2DataKey = unsafePerformIO Vault.newKey

119modifyHTTP2DataKey = unsafePerformIO Vault.newKey

117−{-# NOINLINE modifyHTTP2DataKey #-}

120+{-# NOINLINE modifyHTTP2Data #-}

118

121

119-- | Modifying 'HTTP2Data' through vault of the request.

122-- | Modifying 'HTTP2Data' through vault of the request.

120-- 'Application' or 'Middleware' should use this.

123-- 'Application' or 'Middleware' should use this.

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+541

@@ -0,0 +1,541 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE BangPatterns, CPP #-}

3+{-# LANGUAGE NamedFieldPuns #-}

4+

5+module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where

6+

7+#if __GLASGOW_HASKELL__ < 709

8+import Control.Applicative

9+#endif

10+import Control.Concurrent.STM

11+import qualified Control.Exception as E

12+import Control.Monad (void, when)

13+import Data.Bits

14+import qualified Data.ByteString as BS

15+import Data.ByteString.Builder (Builder)

16+import qualified Data.ByteString.Builder.Extra as B

17+import Data.Maybe (isNothing)

18+import Data.Word (Word8, Word32)

19+import Foreign.Ptr (Ptr, plusPtr)

20+import Foreign.Storable (poke)

21+import Network.HPACK (setLimitForEncoding, toHeaderTable)

22+import Network.HTTP2

23+import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)

24+import Network.Wai

25+import Network.Wai.Handler.Warp.Buffer

26+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

27+import Network.Wai.Handler.Warp.HTTP2.HPACK

28+import Network.Wai.Handler.Warp.HTTP2.Manager (Manager)

29+import Network.Wai.Handler.Warp.HTTP2.Types

30+import Network.Wai.Handler.Warp.IORef

31+import qualified Network.Wai.Handler.Warp.Settings as S

32+import Network.Wai.Handler.Warp.Types

33+

34+#ifdef WINDOWS

35+import qualified System.IO as IO

36+#else

37+import Network.Wai.Handler.Warp.FdCache

38+import Network.Wai.Handler.Warp.SendFile (positionRead)

39+import qualified Network.Wai.Handler.Warp.Timeout as T

40+#endif

41+

42+----------------------------------------------------------------

43+

44+data Leftover = LZero

45+ | LOne B.BufferWriter

46+ | LTwo BS.ByteString B.BufferWriter

47+

48+----------------------------------------------------------------

49+

50+{-# INLINE getStreamWindowSize #-}

51+getStreamWindowSize :: Stream -> IO WindowSize

52+getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow

53+

54+{-# INLINE waitStreamWindowSize #-}

55+waitStreamWindowSize :: Stream -> IO ()

56+waitStreamWindowSize Stream{streamWindow} = atomically $ do

57+ w <- readTVar streamWindow

58+ check (w > 0)

59+

60+{-# INLINE waitStreaming #-}

61+waitStreaming :: TBQueue a -> IO ()

62+waitStreaming tbq = atomically $ do

63+ isEmpty <- isEmptyTBQueue tbq

64+ check (isEmpty == False)

65+

66+data Switch = C Control

67+ | O (StreamId,Precedence,Output)

68+ | Flush

69+

70+frameSender :: Context -> Connection -> S.Settings -> Manager -> IO ()

71+frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

72+ conn@Connection{connWriteBuffer,connBufferSize,connSendAll}

73+ settings mgr = loop 0 `E.catch` ignore

74+ where

75+ dequeue off = do

76+ isEmpty <- isEmptyTQueue controlQ

77+ if isEmpty then do

78+ w <- readTVar connectionWindow

79+ check (w > 0)

80+ emp <- isEmptySTM outputQ

81+ if emp then

82+ if off /= 0 then return Flush else retry

83+ else

84+ O <$> dequeueSTM outputQ

85+ else

86+ C <$> readTQueue controlQ

87+

88+ loop off = do

89+ x <- atomically $ dequeue off

90+ case x of

91+ C ctl -> do

92+ when (off /= 0) $ flushN off

93+ off' <- control ctl off

94+ when (off' >= 0) $ loop off'

95+ O (_,pre,out) -> do

96+ let strm = outputStream out

97+ writeIORef (streamPrecedence strm) pre

98+ off' <- outputOrEnqueueAgain out off

99+ case off' of

100+ 0 -> loop 0

101+ _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding

102+ | otherwise -> loop off'

103+ Flush -> flushN off >> loop 0

104+

105+ control CFinish _ = return (-1)

106+ control (CGoaway frame) _ = connSendAll frame >> return (-1)

107+ control (CFrame frame) _ = connSendAll frame >> return 0

108+ control (CSettings frame alist) _ = do

109+ connSendAll frame

110+ setLimit alist

111+ return 0

112+ control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case

113+ let !buf = connWriteBuffer `plusPtr` off

114+ !off' = off + BS.length frame1 + BS.length frame2

115+ buf' <- copy buf frame1

116+ void $ copy buf' frame2

117+ setLimit alist

118+ return off'

119+

120+ {-# INLINE setLimit #-}

121+ setLimit alist = case lookup SettingsHeaderTableSize alist of

122+ Nothing -> return ()

123+ Just siz -> setLimitForEncoding siz encodeDynamicTable

124+

125+ output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do

126+ -- Data frame payload

127+ let !buf = connWriteBuffer `plusPtr` off0

128+ !siz = connBufferSize - off0

129+ Next datPayloadLen mnext <- curr buf siz lim

130+ off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D

131+ maybeEnqueueNext out mnext

132+ return off

133+

134+ output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do

135+ -- Header frame and Continuation frame

136+ let !sid = streamNumber strm

137+ !endOfStream = case rspn of

138+ RspnNobody _ _ -> True

139+ _ -> False

140+ ths <- addNecessaryHeaders ctx rspn ii settings

141+ kvlen <- headerContinue sid ths endOfStream off0

142+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

143+ case rspn of

144+ RspnNobody _ _ -> do

145+ closed ctx strm Finished

146+ return off

147+ RspnFile _ _ path mpart -> do

148+ -- Data frame payload

149+ let payloadOff = off + frameHeaderLength

150+ Next datPayloadLen mnext <-

151+ fillFileBodyGetNext conn ii payloadOff lim path mpart

152+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

153+ maybeEnqueueNext out mnext

154+ return off'

155+ RspnBuilder _ _ builder -> do

156+ -- Data frame payload

157+ let payloadOff = off + frameHeaderLength

158+ Next datPayloadLen mnext <-

159+ fillBuilderBodyGetNext conn ii payloadOff lim builder

160+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

161+ maybeEnqueueNext out mnext

162+ return off'

163+ RspnStreaming _ _ tbq -> do

164+ let payloadOff = off + frameHeaderLength

165+ Next datPayloadLen mnext <-

166+ fillStreamBodyGetNext conn payloadOff lim tbq strm

167+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

168+ maybeEnqueueNext out mnext

169+ return off'

170+

171+ output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do

172+ -- Creating a push promise header

173+ -- Frame id should be associated stream id from the client.

174+ let !sid = streamNumber strm

175+ len <- pushPromise pid sid ths off0

176+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len

177+ output out{ outputType = ORspn } off lim

178+

179+ output _ _ _ = undefined -- never reach

180+

181+ outputOrEnqueueAgain out off = E.handle resetStream $ do

182+ state <- readIORef $ streamState strm

183+ if isClosed state then

184+ return off

185+ else case out of

186+ Output _ _ _ wait _ OWait -> do

187+ -- Checking if all push are done.

188+ let out' = out {

189+ outputHook = return ()

190+ , outputType = ORspn

191+ }

192+ forkAndEnqueueWhenReady wait outputQ out' mgr

193+ return off

194+ _ -> case mtbq of

195+ Just tbq -> checkStreaming tbq

196+ _ -> checkStreamWindowSize

197+ where

198+ strm = outputStream out

199+ mtbq = outputMaybeTBQueue out

200+ checkStreaming tbq = do

201+ isEmpty <- atomically $ isEmptyTBQueue tbq

202+ if isEmpty then do

203+ forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr

204+ return off

205+ else

206+ checkStreamWindowSize

207+ checkStreamWindowSize = do

208+ sws <- getStreamWindowSize strm

209+ if sws == 0 then do

210+ forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr

211+ return off

212+ else do

213+ cws <- atomically $ readTVar connectionWindow -- not 0

214+ let !lim = min cws sws

215+ output out off lim

216+ resetStream e = do

217+ closed ctx strm (ResetByMe e)

218+ let !rst = resetFrame InternalError $ streamNumber strm

219+ enqueueControl controlQ $ CFrame rst

220+ return off

221+

222+ {-# INLINE flushN #-}

223+ -- Flush the connection buffer to the socket, where the first 'n' bytes of

224+ -- the buffer are filled.

225+ flushN :: Int -> IO ()

226+ flushN n = bufferIO connWriteBuffer n connSendAll

227+

228+ headerContinue sid ths endOfStream off = do

229+ let !offkv = off + frameHeaderLength

230+ let !bufkv = connWriteBuffer `plusPtr` offkv

231+ !limkv = connBufferSize - offkv

232+ (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths

233+ let flag0 = case hs of

234+ [] -> setEndHeader defaultFlags

235+ _ -> defaultFlags

236+ flag = if endOfStream then setEndStream flag0 else flag0

237+ let buf = connWriteBuffer `plusPtr` off

238+ fillFrameHeader FrameHeaders kvlen sid flag buf

239+ continue sid kvlen hs

240+

241+ !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength

242+ !headerPayloadLim = connBufferSize - frameHeaderLength

243+

244+ continue _ kvlen [] = return kvlen

245+ continue sid kvlen ths = do

246+ flushN $ kvlen + frameHeaderLength

247+ -- Now off is 0

248+ (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths

249+ when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"

250+ let flag = case ths' of

251+ [] -> setEndHeader defaultFlags

252+ _ -> defaultFlags

253+ fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer

254+ continue sid kvlen' ths'

255+

256+ {-# INLINE maybeEnqueueNext #-}

257+ -- Re-enqueue the stream in the output queue.

258+ maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()

259+ maybeEnqueueNext _ Nothing = return ()

260+ maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'

261+ where

262+ !out' = out { outputType = ONext next }

263+

264+ {-# INLINE sendHeadersIfNecessary #-}

265+ -- Send headers if there is not room for a 1-byte data frame, and return

266+ -- the offset of the next frame's first header byte.

267+ sendHeadersIfNecessary off

268+ -- True if the connection buffer has room for a 1-byte data frame.

269+ | off + frameHeaderLength < connBufferSize = return off

270+ | otherwise = do

271+ flushN off

272+ return 0

273+

274+ fillDataHeader strm@Stream{streamWindow,streamNumber}

275+ off datPayloadLen mnext tell getH2D = do

276+ -- Data frame header

277+ mh2d <- getH2D

278+ let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of

279+ Nothing -> ([], True)

280+ Just ts -> (ts, null ts)

281+ !buf = connWriteBuffer `plusPtr` off

282+ !off' = off + frameHeaderLength + datPayloadLen

283+ !noMoreBody = isNothing mnext

284+ flag | noMoreBody && noTrailers = setEndStream defaultFlags

285+ | otherwise = defaultFlags

286+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf

287+ off'' <- handleEndOfBody noMoreBody off' noTrailers trailers

288+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

289+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)

290+ return off''

291+ where

292+ handleTrailers True off0 _ = return off0

293+ handleTrailers _ off0 trailers = do

294+ (ths,_) <- toHeaderTable trailers

295+ kvlen <- headerContinue streamNumber ths True off0

296+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

297+ handleEndOfBody True off0 noTrailers trailers = do

298+ off1 <- handleTrailers noTrailers off0 trailers

299+ void $ tell

300+ closed ctx strm Finished

301+ return off1

302+ handleEndOfBody False off0 _ _ = return off0

303+

304+

305+ pushPromise pid sid ths off = do

306+ let !offsid = off + frameHeaderLength

307+ !bufsid = connWriteBuffer `plusPtr` offsid

308+ poke32 bufsid $ fromIntegral sid

309+ let !offkv = offsid + 4

310+ !bufkv = connWriteBuffer `plusPtr` offkv

311+ !limkv = connBufferSize - offkv

312+ (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths

313+ let !flag = setEndHeader defaultFlags -- No EndStream flag

314+ !buf = connWriteBuffer `plusPtr` off

315+ !len = kvlen + 4

316+ fillFrameHeader FramePushPromise len pid flag buf

317+ return len

318+

319+ {-# INLINE fillFrameHeader #-}

320+ fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf

321+ where

322+ hinfo = FrameHeader len flag sid

323+

324+ {-# INLINE ignore #-}

325+ ignore :: E.SomeException -> IO ()

326+ ignore _ = return ()

327+

328+----------------------------------------------------------------

329+

330+{-

331+ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)

332+ResponseBuilder Status ResponseHeaders Builder

333+ResponseStream Status ResponseHeaders StreamingBody

334+ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response

335+-}

336+

337+fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next

338+fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}

339+ _ off lim bb = do

340+ let datBuf = connWriteBuffer `plusPtr` off

341+ room = min (connBufferSize - off) lim

342+ (len, signal) <- B.runBuilder bb datBuf room

343+ return $ nextForBuilder len signal

344+

345+fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next

346+#ifdef WINDOWS

347+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

348+ _ off lim path mpart = do

349+ let datBuf = connWriteBuffer `plusPtr` off

350+ room = min (connBufferSize - off) lim

351+ (start, bytes) <- fileStartEnd path mpart

352+ -- fixme: how to close Handle? GC does it at this moment.

353+ hdl <- IO.openBinaryFile path IO.ReadMode

354+ IO.hSeek hdl IO.AbsoluteSeek start

355+ len <- IO.hGetBufSome hdl datBuf (mini room bytes)

356+ let bytes' = bytes - fromIntegral len

357+ -- fixme: connWriteBuffer connBufferSize

358+ return $ nextForFile len hdl bytes' (return ())

359+#else

360+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

361+ ii off lim path mpart = do

362+ (mfd, refresh') <- getFd ii path

363+ (fd, refresh) <- case mfd of

364+ Nothing -> do

365+ fd' <- openFile path

366+ th <- T.register (timeoutManager ii) (closeFile fd')

367+ return (fd', T.tickle th)

368+ Just fd -> return (fd, refresh')

369+ let datBuf = connWriteBuffer `plusPtr` off

370+ room = min (connBufferSize - off) lim

371+ (start, bytes) <- fileStartEnd path mpart

372+ len <- positionRead fd datBuf (mini room bytes) start

373+ refresh

374+ let len' = fromIntegral len

375+ return $ nextForFile len fd (start + len') (bytes - len') refresh

376+#endif

377+

378+fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)

379+fileStartEnd _ (Just part) =

380+ return (filePartOffset part, filePartByteCount part)

381+fileStartEnd _ _ = error "fileStartEnd"

382+

383+----------------------------------------------------------------

384+

385+fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next

386+fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

387+ off lim sq strm = do

388+ let datBuf = connWriteBuffer `plusPtr` off

389+ room = min (connBufferSize - off) lim

390+ (leftover, cont, len) <- runStreamBuilder datBuf room sq

391+ return $ nextForStream sq strm leftover cont len

392+

393+----------------------------------------------------------------

394+

395+fillBufBuilder :: Leftover -> DynaNext

396+fillBufBuilder leftover buf0 siz0 lim = do

397+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

398+ room = min (siz0 - frameHeaderLength) lim

399+ case leftover of

400+ LZero -> error "fillBufBuilder: LZero"

401+ LOne writer -> do

402+ (len, signal) <- writer payloadBuf room

403+ getNext len signal

404+ LTwo bs writer

405+ | BS.length bs <= room -> do

406+ buf1 <- copy payloadBuf bs

407+ let len1 = BS.length bs

408+ (len2, signal) <- writer buf1 (room - len1)

409+ getNext (len1 + len2) signal

410+ | otherwise -> do

411+ let (bs1,bs2) = BS.splitAt room bs

412+ void $ copy payloadBuf bs1

413+ getNext room (B.Chunk bs2 writer)

414+ where

415+ getNext l s = return $ nextForBuilder l s

416+

417+nextForBuilder :: BytesFilled -> B.Next -> Next

418+nextForBuilder len B.Done

419+ = Next len Nothing

420+nextForBuilder len (B.More _ writer)

421+ = Next len $ Just (fillBufBuilder (LOne writer))

422+nextForBuilder len (B.Chunk bs writer)

423+ = Next len $ Just (fillBufBuilder (LTwo bs writer))

424+

425+----------------------------------------------------------------

426+

427+runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence

428+ -> IO (Leftover, Bool, BytesFilled)

429+runStreamBuilder buf0 room0 sq = loop buf0 room0 0

430+ where

431+ loop !buf !room !total = do

432+ mbuilder <- atomically $ tryReadTBQueue sq

433+ case mbuilder of

434+ Nothing -> return (LZero, True, total)

435+ Just (SBuilder builder) -> do

436+ (len, signal) <- B.runBuilder builder buf room

437+ let !total' = total + len

438+ case signal of

439+ B.Done -> loop (buf `plusPtr` len) (room - len) total'

440+ B.More _ writer -> return (LOne writer, True, total')

441+ B.Chunk bs writer -> return (LTwo bs writer, True, total')

442+ Just SFlush -> return (LZero, True, total)

443+ Just SFinish -> return (LZero, False, total)

444+

445+fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext

446+fillBufStream leftover0 sq strm buf0 siz0 lim0 = do

447+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

448+ room0 = min (siz0 - frameHeaderLength) lim0

449+ case leftover0 of

450+ LZero -> do

451+ (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq

452+ getNext leftover cont len

453+ LOne writer -> write writer payloadBuf room0 0

454+ LTwo bs writer

455+ | BS.length bs <= room0 -> do

456+ buf1 <- copy payloadBuf bs

457+ let len = BS.length bs

458+ write writer buf1 (room0 - len) len

459+ | otherwise -> do

460+ let (bs1,bs2) = BS.splitAt room0 bs

461+ void $ copy payloadBuf bs1

462+ getNext (LTwo bs2 writer) True room0

463+ where

464+ getNext l b r = return $ nextForStream sq strm l b r

465+ write writer1 buf room sofar = do

466+ (len, signal) <- writer1 buf room

467+ case signal of

468+ B.Done -> do

469+ (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq

470+ let !total = sofar + len + extra

471+ getNext leftover cont total

472+ B.More _ writer -> do

473+ let !total = sofar + len

474+ getNext (LOne writer) True total

475+ B.Chunk bs writer -> do

476+ let !total = sofar + len

477+ getNext (LTwo bs writer) True total

478+

479+nextForStream :: TBQueue Sequence -> Stream

480+ -> Leftover -> Bool -> BytesFilled

481+ -> Next

482+nextForStream _ _ _ False len = Next len Nothing

483+nextForStream sq strm leftOrZero True len =

484+ Next len $ Just (fillBufStream leftOrZero sq strm)

485+

486+----------------------------------------------------------------

487+

488+#ifdef WINDOWS

489+fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext

490+fillBufFile h bytes refresh buf siz lim = do

491+ let payloadBuf = buf `plusPtr` frameHeaderLength

492+ room = min (siz - frameHeaderLength) lim

493+ len <- IO.hGetBufSome h payloadBuf room

494+ refresh

495+ let bytes' = bytes - fromIntegral len

496+ return $ nextForFile len h bytes' refresh

497+

498+nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next

499+nextForFile 0 _ _ _ = Next 0 Nothing

500+nextForFile len _ 0 _ = Next len Nothing

501+nextForFile len h bytes refresh =

502+ Next len $ Just (fillBufFile h bytes refresh)

503+#else

504+fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext

505+fillBufFile fd start bytes refresh buf siz lim = do

506+ let payloadBuf = buf `plusPtr` frameHeaderLength

507+ room = min (siz - frameHeaderLength) lim

508+ len <- positionRead fd payloadBuf (mini room bytes) start

509+ let len' = fromIntegral len

510+ refresh

511+ return $ nextForFile len fd (start + len') (bytes - len') refresh

512+

513+nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next

514+nextForFile 0 _ _ _ _ = Next 0 Nothing

515+nextForFile len _ _ 0 _ = Next len Nothing

516+nextForFile len fd start bytes refresh =

517+ Next len $ Just (fillBufFile fd start bytes refresh)

518+#endif

519+

520+{-# INLINE mini #-}

521+mini :: Int -> Integer -> Int

522+mini i n

523+ | fromIntegral i < n = i

524+ | otherwise = fromIntegral n

525+

526+

527+----------------------------------------------------------------

528+

529+poke32 :: Ptr Word8 -> Word32 -> IO ()

530+poke32 ptr i = do

531+ poke ptr w0

532+ poke8 ptr 1 w1

533+ poke8 ptr 2 w2

534+ poke8 ptr 3 w3

535+ where

536+ w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)

537+ w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)

538+ w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)

539+ w3 = fromIntegral (i .&. 0xff)

540+ poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()

541+ poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+272−16

@@ -1,26 +1,286 @@

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 Data.ByteString.Builder (Builder)

8+#if __GLASGOW_HASKELL__ < 709

9+import Control.Applicative ((<$>),(<*>))

10+#endif

11+import Control.Concurrent (forkIO)

12+import Control.Concurrent.STM

13+import Control.Exception (SomeException, bracket)

14+import Control.Monad (void, forM_)

15+import Data.ByteString (ByteString)

7import qualified Data.ByteString as BS

16import qualified Data.ByteString as BS

17+import Data.IntMap.Strict (IntMap, IntMap)

18+import qualified Data.IntMap.Strict as M

8import qualified Network.HTTP.Types as H

19import qualified Network.HTTP.Types as H

9−import Network.HTTP2

20+import Network.Wai (Request, FilePart)

10−import qualified Network.HTTP2.Server as H2

21+import Network.Wai.Handler.Warp.HTTP2.Manager

11−

12−import Network.Wai.Handler.Warp.Imports

22+import Network.Wai.Handler.Warp.IORef

13import Network.Wai.Handler.Warp.Types

23import Network.Wai.Handler.Warp.Types

14

24

25+import Network.HTTP2

26+import Network.HTTP2.Priority

27+import Network.HPACK hiding (Buffer)

28+

15----------------------------------------------------------------

29----------------------------------------------------------------

16

30

31+http2ver :: H.HttpVersion

32+http2ver = H.HttpVersion 2 0

33+

17isHTTP2 :: Transport -> Bool

34isHTTP2 :: Transport -> Bool

18isHTTP2 TCP = False

35isHTTP2 TCP = False

19isHTTP2 tls = useHTTP2

36isHTTP2 tls = useHTTP2

20 where

37 where

21 useHTTP2 = case tlsNegotiatedProtocol tls of

38 useHTTP2 = case tlsNegotiatedProtocol tls of

22 Nothing -> False

39 Nothing -> False

23− Just proto -> "h2" `BS.isPrefixOf` proto

40+ Just proto -> "h2-" `BS.isPrefixOf` proto

41+

42+----------------------------------------------------------------

43+

44+data Input = Input Stream Request ValueTable InternalInfo

45+

46+----------------------------------------------------------------

47+

48+type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next

49+

50+type BytesFilled = Int

51+

52+data Next = Next !BytesFilled (Maybe DynaNext)

53+

54+data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)

55+ | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)

56+ | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder

57+ | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)

58+

59+rspnStatus :: Rspn -> H.Status

60+rspnStatus (RspnNobody s _) = s

61+rspnStatus (RspnStreaming s _ _) = s

62+rspnStatus (RspnBuilder s _ _) = s

63+rspnStatus (RspnFile s _ _ _ ) = s

64+

65+rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)

66+rspnHeaders (RspnNobody _ t) = t

67+rspnHeaders (RspnStreaming _ t _) = t

68+rspnHeaders (RspnBuilder _ t _) = t

69+rspnHeaders (RspnFile _ t _ _ ) = t

70+

71+data Output = Output {

72+ outputStream :: !Stream

73+ , outputRspn :: !Rspn

74+ , outputII :: !InternalInfo

75+ , outputHook :: IO () -- OPush: wait for done, O*: telling done

76+ , outputH2Data :: IO (Maybe HTTP2Data)

77+ , outputType :: !OutputType

78+ }

79+

80+data OutputType = ORspn

81+ | OWait

82+ | OPush !TokenHeaderList !StreamId -- associated stream id from client

83+ | ONext !DynaNext

84+

85+outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)

86+outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq

87+outputMaybeTBQueue _ = Nothing

88+

89+data Control = CFinish

90+ | CGoaway !ByteString

91+ | CFrame !ByteString

92+ | CSettings !ByteString !SettingsList

93+ | CSettings0 !ByteString !ByteString !SettingsList

94+

95+----------------------------------------------------------------

96+

97+data Sequence = SFinish

98+ | SFlush

99+ | SBuilder Builder

100+

101+----------------------------------------------------------------

102+

103+-- | The context for HTTP/2 connection.

104+data Context = Context {

105+ -- HTTP/2 settings received from a browser

106+ http2settings :: !(IORef Settings)

107+ , firstSettings :: !(IORef Bool)

108+ , streamTable :: !StreamTable

109+ , concurrency :: !(IORef Int)

110+ , priorityTreeSize :: !(IORef Int)

111+ -- | RFC 7540 says "Other frames (from any stream) MUST NOT

112+ -- occur between the HEADERS frame and any CONTINUATION

113+ -- frames that might follow". This field is used to implement

114+ -- this requirement.

115+ , continued :: !(IORef (Maybe StreamId))

116+ , clientStreamId :: !(IORef StreamId)

117+ , serverStreamId :: !(IORef StreamId)

118+ , inputQ :: !(TQueue Input)

119+ , outputQ :: !(PriorityTree Output)

120+ , controlQ :: !(TQueue Control)

121+ , encodeDynamicTable :: !DynamicTable

122+ , decodeDynamicTable :: !DynamicTable

123+ -- the connection window for data from a server to a browser.

124+ , connectionWindow :: !(TVar WindowSize)

125+ }

126+

127+----------------------------------------------------------------

128+

129+newContext :: IO Context

130+newContext = Context <$> newIORef defaultSettings

131+ <*> newIORef False

132+ <*> newStreamTable

133+ <*> newIORef 0

134+ <*> newIORef 0

135+ <*> newIORef Nothing

136+ <*> newIORef 0

137+ <*> newIORef 0

138+ <*> newTQueueIO

139+ <*> newPriorityTree

140+ <*> newTQueueIO

141+ <*> newDynamicTableForEncoding defaultDynamicTableSize

142+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096

143+ <*> newTVarIO defaultInitialWindowSize

144+

145+clearContext :: Context -> IO ()

146+clearContext _ctx = return ()

147+

148+----------------------------------------------------------------

149+

150+data OpenState =

151+ JustOpened

152+ | Continued [HeaderBlockFragment]

153+ !Int -- Total size

154+ !Int -- The number of continuation frames

155+ !Bool -- End of stream

156+ !Priority

157+ | NoBody (TokenHeaderList,ValueTable) !Priority

158+ | HasBody (TokenHeaderList,ValueTable) !Priority

159+ | Body !(TQueue ByteString)

160+ !(Maybe Int) -- received Content-Length

161+ -- compared the body length for error checking

162+ !(IORef Int) -- actual body length

163+

164+data ClosedCode = Finished

165+ | Killed

166+ | Reset !ErrorCodeId

167+ | ResetByMe SomeException

168+ deriving Show

169+

170+data StreamState =

171+ Idle

172+ | Open !OpenState

173+ | HalfClosed

174+ | Closed !ClosedCode

175+ | Reserved

176+

177+isIdle :: StreamState -> Bool

178+isIdle Idle = True

179+isIdle _ = False

180+

181+isOpen :: StreamState -> Bool

182+isOpen Open{} = True

183+isOpen _ = False

184+

185+isHalfClosed :: StreamState -> Bool

186+isHalfClosed HalfClosed = True

187+isHalfClosed _ = False

188+

189+isClosed :: StreamState -> Bool

190+isClosed Closed{} = True

191+isClosed _ = False

192+

193+instance Show StreamState where

194+ show Idle = "Idle"

195+ show Open{} = "Open"

196+ show HalfClosed = "HalfClosed"

197+ show (Closed e) = "Closed: " ++ show e

198+ show Reserved = "Reserved"

199+

200+----------------------------------------------------------------

201+

202+data Stream = Stream {

203+ streamNumber :: !StreamId

204+ , streamState :: !(IORef StreamState)

205+ , streamWindow :: !(TVar WindowSize)

206+ , streamPrecedence :: !(IORef Precedence)

207+ }

208+

209+instance Show Stream where

210+ show s = show (streamNumber s)

211+

212+newStream :: StreamId -> WindowSize -> IO Stream

213+newStream sid win = Stream sid <$> newIORef Idle

214+ <*> newTVarIO win

215+ <*> newIORef defaultPrecedence

216+

217+newPushStream :: Context -> WindowSize -> Precedence -> IO Stream

218+newPushStream Context{serverStreamId} win pre = do

219+ sid <- atomicModifyIORef' serverStreamId inc2

220+ Stream sid <$> newIORef Reserved

221+ <*> newTVarIO win

222+ <*> newIORef pre

223+ where

224+ inc2 x = let !x' = x + 2 in (x', x')

225+

226+----------------------------------------------------------------

227+

228+opened :: Context -> Stream -> IO ()

229+opened Context{concurrency} Stream{streamState} = do

230+ atomicModifyIORef' concurrency (\x -> (x+1,()))

231+ writeIORef streamState (Open JustOpened)

232+

233+closed :: Context -> Stream -> ClosedCode -> IO ()

234+closed Context{concurrency,streamTable} Stream{streamState,streamNumber} cc = do

235+ remove streamTable streamNumber

236+ atomicModifyIORef' concurrency (\x -> (x-1,()))

237+ writeIORef streamState (Closed cc) -- anyway

238+

239+----------------------------------------------------------------

240+

241+newtype StreamTable = StreamTable (IORef (IntMap Stream))

242+

243+newStreamTable :: IO StreamTable

244+newStreamTable = StreamTable <$> newIORef M.empty

245+

246+insert :: StreamTable -> M.Key -> Stream -> IO ()

247+insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->

248+ let !m' = M.insert k v m

249+ in (m', ())

250+

251+remove :: StreamTable -> M.Key -> IO ()

252+remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->

253+ let !m' = M.delete k m

254+ in (m', ())

255+

256+search :: StreamTable -> M.Key -> IO (Maybe Stream)

257+search (StreamTable ref) k = M.lookup k <$> readIORef ref

258+

259+updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()

260+updateAllStreamWindow adst (StreamTable ref) = do

261+ strms <- M.elems <$> readIORef ref

262+ forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst

263+

264+{-# INLINE forkAndEnqueueWhenReady #-}

265+forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()

266+forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->

267+ void . forkIO $ do

268+ wait

269+ enqueueOutput outQ out

270+ where

271+ setup = addMyId mgr

272+ teardown _ = deleteMyId mgr

273+

274+{-# INLINE enqueueOutput #-}

275+enqueueOutput :: PriorityTree Output -> Output -> IO ()

276+enqueueOutput outQ out = do

277+ let Stream{..} = outputStream out

278+ pre <- readIORef streamPrecedence

279+ enqueue outQ streamNumber pre out

280+

281+{-# INLINE enqueueControl #-}

282+enqueueControl :: TQueue Control -> Control -> IO ()

283+enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl

24

284

25----------------------------------------------------------------

285----------------------------------------------------------------

26

286

@@ -32,21 +292,17 @@ data HTTP2Data = HTTP2Data {

32 --

292 --

33 -- Since: 3.2.7

293 -- Since: 3.2.7

34 http2dataPushPromise :: [PushPromise]

294 http2dataPushPromise :: [PushPromise]

35− -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.

36− --

37− -- Since: 3.2.8 but the type changed in 3.3.0

295+ -- Since: 3.2.8

38− , http2dataTrailers :: H2.TrailersMaker

296+ , http2dataTrailers :: H.ResponseHeaders

39− }

297+ } deriving (Eq,Show)

40

298

41-- | Default HTTP/2 specific data.

299-- | Default HTTP/2 specific data.

42--

300--

43-- Since: 3.2.7

301-- Since: 3.2.7

44defaultHTTP2Data :: HTTP2Data

302defaultHTTP2Data :: HTTP2Data

45−defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

303+defaultHTTP2Data = HTTP2Data [] []

46

304

47-- | HTTP/2 push promise or sever push.

305-- | 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--

306--

51-- Since: 3.2.7

307-- Since: 3.2.7

52data PushPromise = PushPromise {

308data PushPromise = PushPromise {

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hsnew file+320

@@ -0,0 +1,320 @@

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+#if __GLASGOW_HASKELL__ < 709

15+import Control.Applicative

16+import Data.Monoid (mempty)

17+#endif

18+import Control.Applicative ((<|>))

19+import Data.Maybe (fromJust)

20+import Control.Concurrent.STM

21+import Control.Exception (SomeException(..), AsyncException(..))

22+import qualified Control.Exception as E

23+import Control.Monad (when)

24+import Data.ByteString.Builder (byteString)

25+import qualified Network.HTTP.Types as H

26+import Network.HTTP2

27+import Network.HTTP2.Priority

28+import Network.HPACK

29+import Network.HPACK.Token

30+import Network.Wai

31+import Network.Wai.Handler.Warp.FileInfoCache

32+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

33+import Network.Wai.Handler.Warp.HTTP2.File

34+import Network.Wai.Handler.Warp.HTTP2.Manager

35+import Network.Wai.Handler.Warp.HTTP2.Types

36+import Network.Wai.Handler.Warp.HTTP2.Request

37+import Network.Wai.Handler.Warp.IORef

38+import qualified Network.Wai.Handler.Warp.Response as R

39+import qualified Network.Wai.Handler.Warp.Settings as S

40+import qualified Network.Wai.Handler.Warp.Timeout as T

41+import Network.Wai.Handler.Warp.Types

42+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))

43+

44+----------------------------------------------------------------

45+

46+-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.

47+-- This type implements the second argument (Response -> IO ResponseReceived)

48+-- with extra arguments.

49+type Responder = InternalInfo

50+ -> ValueTable -- for Request

51+ -> ThreadContinue

52+ -> Stream

53+ -> Request

54+ -> Response

55+ -> IO ResponseReceived

56+

57+pushStream :: Context -> S.Settings

58+ -> StreamId -> ValueTable -> Request -> InternalInfo

59+ -> Maybe HTTP2Data

60+ -> IO (OutputType, IO ())

61+pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())

62+pushStream ctx@Context{http2settings,outputQ,streamTable}

63+ settings pid reqvt req ii (Just h2d)

64+ | len == 0 = return (ORspn, return ())

65+ | otherwise = do

66+ pushable <- enablePush <$> readIORef http2settings

67+ if pushable then do

68+ tvar <- newTVarIO 0

69+ lim <- push tvar pps0 0

70+ if lim == 0 then

71+ return (ORspn, return ())

72+ else

73+ return (OWait, waiter lim tvar)

74+ else

75+ return (ORspn, return ())

76+ where

77+ !pps0 = http2dataPushPromise h2d

78+ !len = length pps0

79+ !pushLogger = S.settingsServerPushLogger settings

80+ increment tvar = atomically $ modifyTVar' tvar (+1)

81+ waiter lim tvar = atomically $ do

82+ n <- readTVar tvar

83+ check (n >= lim)

84+ !h2data = getHTTP2Data req

85+ push _ [] !n = return (n :: Int)

86+ push tvar (pp:pps) !n = do

87+ let !file = promisedFile pp

88+ efinfo <- E.try $ getFileInfo ii file

89+ case efinfo of

90+ Left (_ex :: E.IOException) -> push tvar pps n

91+ Right (FileInfo _ size _ date) -> do

92+ ws <- initialWindowSize <$> readIORef http2settings

93+ let !w = promisedWeight pp

94+ !pri = defaultPriority { weight = w }

95+ !pre = toPrecedence pri

96+ strm <- newPushStream ctx ws pre

97+ let !sid = streamNumber strm

98+ insert streamTable sid strm

99+ (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)

100+ let !scheme = fromJust $ getHeaderValue tokenScheme reqvt

101+ -- fixme: this value can be Nothing

102+ !auth = fromJust (getHeaderValue tokenHost reqvt

103+ <|> getHeaderValue tokenAuthority reqvt)

104+ !path = promisedPath pp

105+ !promisedRequest = [(tokenMethod, H.methodGet)

106+ ,(tokenScheme, scheme)

107+ ,(tokenAuthority, auth)

108+ ,(tokenPath, path)]

109+ !part = FilePart 0 size size

110+ !rsp = RspnFile H.ok200 (ths,vt) file (Just part)

111+ !ths = (tokenLastModified,date) :

112+ addContentHeadersForFilePart ths0 part

113+ pushLogger req path size

114+ let !ot = OPush promisedRequest pid

115+ !out = Output strm rsp ii (increment tvar) h2data ot

116+ enqueueOutput outputQ out

117+ push tvar pps (n + 1)

118+

119+

120+-- | This function is passed to workers.

121+-- They also pass 'Response's from 'Application's to this function.

122+-- This function enqueues commands for the HTTP/2 sender.

123+response :: S.Settings -> Context -> Manager -> Responder

124+response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of

125+ ResponseStream s0 hs0 strmbdy

126+ | noBody s0 -> responseNoBody s0 hs0

127+ | isHead -> responseNoBody s0 hs0

128+ | otherwise -> getHTTP2Data req

129+ >>= pushStream ctx settings sid reqvt req ii

130+ >>= responseStreaming s0 hs0 strmbdy

131+ ResponseBuilder s0 hs0 b

132+ | noBody s0 -> responseNoBody s0 hs0

133+ | isHead -> responseNoBody s0 hs0

134+ | otherwise -> getHTTP2Data req

135+ >>= pushStream ctx settings sid reqvt req ii

136+ >>= responseBuilderBody s0 hs0 b

137+ ResponseFile s0 hs0 p mp

138+ | noBody s0 -> responseNoBody s0 hs0

139+ | otherwise -> getHTTP2Data req

140+ >>= pushStream ctx settings sid reqvt req ii

141+ >>= responseFileXXX s0 hs0 p mp

142+ ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"

143+ where

144+ noBody = not . R.hasBody

145+ !isHead = requestMethod req == H.methodHead

146+ !logger = S.settingsLogger settings

147+ !th = threadHandle ii

148+ sid = streamNumber strm

149+ !h2data = getHTTP2Data req

150+

151+ -- Ideally, log messages should be written when responses are

152+ -- actually sent. But there is no way to keep good memory usage

153+ -- (resist to Request leak) and throughput. By compromise,

154+ -- log message are written here even the window size of streams

155+ -- is 0.

156+

157+ responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s

158+

159+ responseNoBody' s tbl = do

160+ logger req s Nothing

161+ setThreadContinue tconf True

162+ let !rspn = RspnNobody s tbl

163+ !out = Output strm rspn ii (return ()) h2data ORspn

164+ enqueueOutput outputQ out

165+ return ResponseReceived

166+

167+ responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do

168+ logger req s Nothing

169+ setThreadContinue tconf True

170+ tbl <- toHeaderTable hs0

171+ let !rspn = RspnBuilder s tbl bdy

172+ !out = Output strm rspn ii tell h2data rspnOrWait

173+ enqueueOutput outputQ out

174+ return ResponseReceived

175+

176+ responseFileXXX _ hs0 path Nothing aux = do

177+ efinfo <- E.try $ getFileInfo ii path

178+ case efinfo of

179+ Left (_ex :: E.IOException) -> response404 hs0

180+ Right finfo -> do

181+ (rspths0,vt) <- toHeaderTable hs0

182+ case conditionalRequest finfo rspths0 reqvt of

183+ WithoutBody s -> responseNoBody s hs0

184+ WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux

185+

186+ responseFileXXX s0 hs0 path mpart aux = do

187+ tbl <- toHeaderTable hs0

188+ responseFile2XX s0 tbl path mpart aux

189+

190+ responseFile2XX s tbl path mpart (rspnOrWait,tell)

191+ | isHead = do

192+ logger req s Nothing

193+ responseNoBody' s tbl

194+ | otherwise = do

195+ logger req s (filePartByteCount <$> mpart)

196+ setThreadContinue tconf True

197+ let !rspn = RspnFile s tbl path mpart

198+ !out = Output strm rspn ii tell h2data rspnOrWait

199+ enqueueOutput outputQ out

200+ return ResponseReceived

201+

202+ response404 hs0 = responseBuilderBody s hs body (ORspn, return ())

203+ where

204+ s = H.notFound404

205+ hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

206+ body = byteString "File not found"

207+

208+ responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do

209+ logger req s0 Nothing

210+ -- We must not exit this WAI application.

211+ -- If the application exits, streaming would be also closed.

212+ -- So, this work occupies this thread.

213+ --

214+ -- We need to increase the number of workers.

215+ spawnAction mgr

216+ -- After this work, this thread stops to decease

217+ -- the number of workers.

218+ setThreadContinue tconf False

219+ -- Since 'StreamingBody' is loop, we cannot control it.

220+ -- So, let's serialize 'Builder' with a designated queue.

221+ tbq <- newTBQueueIO 10 -- fixme: hard coding: 10

222+ tbl <- toHeaderTable hs0

223+ let !rspn = RspnStreaming s0 tbl tbq

224+ !out = Output strm rspn ii tell h2data rspnOrWait

225+ enqueueOutput outputQ out

226+ let push b = do

227+ atomically $ writeTBQueue tbq (SBuilder b)

228+ T.tickle th

229+ flush = atomically $ writeTBQueue tbq SFlush

230+ _ <- strmbdy push flush

231+ atomically $ writeTBQueue tbq SFinish

232+ deleteMyId mgr

233+ return ResponseReceived

234+

235+worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO ()

236+worker ctx@Context{inputQ,controlQ} set app responder tm = do

237+ sinfo <- newStreamInfo

238+ tcont <- newThreadContinue

239+ let timeoutAction = return () -- cannot close the shared connection

240+ E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont

241+ where

242+ go sinfo tcont th = do

243+ setThreadContinue tcont True

244+ ex <- E.try $ do

245+ T.pause th

246+ inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ

247+ setStreamInfo sinfo inp

248+ T.resume th

249+ T.tickle th

250+ app req $ responder ii reqvt tcont strm req

251+ cont1 <- case ex of

252+ Right ResponseReceived -> return True

253+ Left e@(SomeException _)

254+ -- killed by the local worker manager

255+ | Just ThreadKilled <- E.fromException e -> return False

256+ -- killed by the local timeout manager

257+ | Just T.TimeoutThread <- E.fromException e -> do

258+ cleanup sinfo Nothing

259+ return True

260+ | otherwise -> do

261+ cleanup sinfo $ Just e

262+ return True

263+ cont2 <- getThreadContinue tcont

264+ clearStreamInfo sinfo

265+ when (cont1 && cont2) $ go sinfo tcont th

266+ cleanup sinfo me = do

267+ minp <- getStreamInfo sinfo

268+ case minp of

269+ Nothing -> return ()

270+ Just (Input strm req _reqvt _ii) -> do

271+ closed ctx strm Killed

272+ let !frame = resetFrame InternalError (streamNumber strm)

273+ enqueueControl controlQ $ CFrame frame

274+ case me of

275+ Nothing -> return ()

276+ Just e -> S.settingsOnException set (Just req) e

277+

278+----------------------------------------------------------------

279+

280+-- | It would nice if responders could return values to workers.

281+-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.

282+-- It is not wise to change this type.

283+-- So, a reference is shared by a responder and its worker.

284+-- The reference refers a value of this type as a return value.

285+-- If 'True', the worker continue to serve requests.

286+-- Otherwise, the worker get finished.

287+newtype ThreadContinue = ThreadContinue (IORef Bool)

288+

289+{-# INLINE newThreadContinue #-}

290+newThreadContinue :: IO ThreadContinue

291+newThreadContinue = ThreadContinue <$> newIORef True

292+

293+{-# INLINE setThreadContinue #-}

294+setThreadContinue :: ThreadContinue -> Bool -> IO ()

295+setThreadContinue (ThreadContinue ref) x = writeIORef ref x

296+

297+{-# INLINE getThreadContinue #-}

298+getThreadContinue :: ThreadContinue -> IO Bool

299+getThreadContinue (ThreadContinue ref) = readIORef ref

300+

301+----------------------------------------------------------------

302+

303+-- | The type to store enough information for 'settingsOnException'.

304+newtype StreamInfo = StreamInfo (IORef (Maybe Input))

305+

306+{-# INLINE newStreamInfo #-}

307+newStreamInfo :: IO StreamInfo

308+newStreamInfo = StreamInfo <$> newIORef Nothing

309+

310+{-# INLINE clearStreamInfo #-}

311+clearStreamInfo :: StreamInfo -> IO ()

312+clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing

313+

314+{-# INLINE setStreamInfo #-}

315+setStreamInfo :: StreamInfo -> Input -> IO ()

316+setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp

317+

318+{-# INLINE getStreamInfo #-}

319+getStreamInfo :: StreamInfo -> IO (Maybe Input)

320+getStreamInfo (StreamInfo ref) = readIORef ref

warp/Network/Wai/Handler/Warp/HashMap.hs+16−26

@@ -1,7 +1,6 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3module Network.Wai.Handler.Warp.HashMap where

1module Network.Wai.Handler.Warp.HashMap where

4

2

3+import Data.ByteString (ByteString)

5import Data.Hashable (hash)

4import Data.Hashable (hash)

6import Data.IntMap.Strict (IntMap)

5import Data.IntMap.Strict (IntMap)

7import qualified Data.IntMap.Strict as I

6import qualified Data.IntMap.Strict as I

@@ -9,34 +8,25 @@ import Data.Map.Strict (Map)

9import qualified Data.Map.Strict as M

8import qualified Data.Map.Strict as M

10import Prelude hiding (lookup)

9import Prelude hiding (lookup)

11

10

12−----------------------------------------------------------------

11+type Hash = Int

13−

14−-- | 'HashMap' is used for cache of file information.

15−-- Hash values of file pathes are used as outer keys.

16−-- Because negative entries are also contained,

17−-- a bad guy can intentionally cause the hash collison.

18−-- So, 'Map' is used internally to prevent

19−-- the hash collision attack.

20−newtype HashMap v = HashMap (IntMap (Map FilePath v))

12+newtype HashMap k v = HashMap (IntMap (Map k v))

21

13

22−----------------------------------------------------------------

14+hashByteString :: ByteString -> Hash

15+hashByteString = hash

23

16

24−empty :: HashMap v

17+empty :: HashMap k v

25−empty = HashMap I.empty

18+empty = HashMap $ I.empty

26

19

27−isEmpty :: HashMap v -> Bool

20+null :: HashMap k v -> Bool

28−isEmpty (HashMap hm) = I.null hm

21+null (HashMap hm) = I.null hm

29

22

30−----------------------------------------------------------------

31−

32−insert :: FilePath -> v -> HashMap v -> HashMap v

23+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

24+insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm

34 where

25 where

35− !h = hash path

36− !m = M.singleton path v

26+ m = M.singleton k v

37 f = M.union -- fimxe

27 f = M.union -- fimxe

28+{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}

38

29

39−lookup :: FilePath -> HashMap v -> Maybe v

30+lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v

40−lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path

31+lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k

41− where

32+{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}

42− !h = hash path

warp/Network/Wai/Handler/Warp/Header.hs−3

@@ -7,7 +7,6 @@ import Data.Array.ST

7import qualified Data.ByteString as BS

8import Data.CaseInsensitive (foldedCase)

9import Network.HTTP.Types

10−

11import Network.Wai.Handler.Warp.Types

10import Network.Wai.Handler.Warp.Types

12

11

13----------------------------------------------------------------

12----------------------------------------------------------------

@@ -69,7 +68,6 @@ indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex

69data ResponseHeaderIndex = ResContentLength

68data ResponseHeaderIndex = ResContentLength

70 | ResServer

69 | ResServer

71 | ResDate

70 | ResDate

72− | ResLastModified

73 deriving (Enum,Bounded)

71 deriving (Enum,Bounded)

74

72

75-- | The size for 'IndexedHeader' for HTTP Response.

73-- | The size for 'IndexedHeader' for HTTP Response.

@@ -80,7 +78,6 @@ responseKeyIndex :: HeaderName -> Int

80responseKeyIndex hn = case BS.length bs of

78responseKeyIndex hn = case BS.length bs of

81 4 -> if bs == "date" then fromEnum ResDate else -1

79 4 -> if bs == "date" then fromEnum ResDate else -1

82 6 -> if bs == "server" then fromEnum ResServer else -1

80 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

81 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

85 _ -> -1

82 _ -> -1

86 where

83 where

warp/Network/Wai/Handler/Warp/IO.hs+1−2

@@ -3,11 +3,10 @@

3

4module Network.Wai.Handler.Warp.IO where

5

6+import Data.ByteString (ByteString)

6import Data.ByteString.Builder (Builder)

7import Data.ByteString.Builder (Builder)

7import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

8import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

8−

9import Network.Wai.Handler.Warp.Buffer

10−import Network.Wai.Handler.Warp.Imports

11import Network.Wai.Handler.Warp.Types

10import Network.Wai.Handler.Warp.Types

12

11

13toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

12toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

warp/Network/Wai/Handler/Warp/IORef.hsnew file+26

@@ -0,0 +1,26 @@

1+{-# LANGUAGE CPP #-}

2+

3+#ifndef MIN_VERSION_base

4+#define MIN_VERSION_base(x,y,z) 1

5+#endif

6+

7+module Network.Wai.Handler.Warp.IORef (

8+ module Data.IORef

9+#if !MIN_VERSION_base(4,6,0)

10+ , atomicModifyIORef'

11+#endif

12+ ) where

13+

14+import Data.IORef

15+

16+#if !MIN_VERSION_base(4,6,0)

17+-- | Strict version of 'atomicModifyIORef'. This forces both the value stored

18+-- in the 'IORef' as well as the value returned.

19+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b

20+atomicModifyIORef' ref f = do

21+ c <- atomicModifyIORef ref

22+ (\x -> let (a, b) = f x -- Lazy application of "f"

23+ in (a, a `seq` b)) -- Lazy application of "seq"

24+ -- The following forces "a `seq` b", so it also forces "f x".

25+ c `seq` return c

26+#endif

warp/Network/Wai/Handler/Warp/Imports.hsdeleted−27

@@ -1,27 +0,0 @@

1−module Network.Wai.Handler.Warp.Imports (

2− ByteString(..)

3− , NonEmpty(..)

4− , module Control.Applicative

5− , module Control.Monad

6− , module Data.Bits

7− , module Data.List

8− , module Data.Int

9− , module Data.Monoid

10− , module Data.Ord

11− , module Data.Word

12− , module Data.Maybe

13− , module Numeric

14− ) where

15−

16−import Control.Applicative

17−import Control.Monad

18−import Data.Bits

19−import Data.ByteString.Internal (ByteString(..))

20−import Data.Int

21−import Data.List

22−import Data.List.NonEmpty (NonEmpty(..))

23−import Data.Maybe

24−import Data.Monoid

25−import Data.Ord

26−import Data.Word

27−import Numeric

warp/Network/Wai/Handler/Warp/Internal.hs+2−7

@@ -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

@@ -64,13 +64,8 @@ module Network.Wai.Handler.Warp.Internal (

64 , Source

65 , recvRequest

66 , sendResponse

67− -- * Platform dependent helper functions

68− , setSocketCloseOnExec

69− , windowsThreadBlockHack

70 ) where

67 ) where

71

68

72−import System.TimeManager

73−

74import Network.Wai.Handler.Warp.Buffer

69import Network.Wai.Handler.Warp.Buffer

75import Network.Wai.Handler.Warp.Date

70import Network.Wai.Handler.Warp.Date

76import Network.Wai.Handler.Warp.FdCache

71import Network.Wai.Handler.Warp.FdCache

@@ -82,5 +77,5 @@ import Network.Wai.Handler.Warp.Response

82import Network.Wai.Handler.Warp.Run

77import Network.Wai.Handler.Warp.Run

83import Network.Wai.Handler.Warp.SendFile

78import Network.Wai.Handler.Warp.SendFile

84import Network.Wai.Handler.Warp.Settings

79import Network.Wai.Handler.Warp.Settings

80+import Network.Wai.Handler.Warp.Timeout

85import Network.Wai.Handler.Warp.Types

81import Network.Wai.Handler.Warp.Types

86−import Network.Wai.Handler.Warp.Windows

warp/Network/Wai/Handler/Warp/MultiMap.hs+43−64

@@ -1,111 +1,90 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE CPP, BangPatterns #-}

2

3module Network.Wai.Handler.Warp.MultiMap (

4− MultiMap

4+ MMap

5 , isEmpty

6 , empty

7 , singleton

8 , insert

9− , Network.Wai.Handler.Warp.MultiMap.lookup

9+ , search

10+ , searchWith

10 , pruneWith

11 , pruneWith

11 , toList

12 , toList

12 , merge

13 , merge

13 ) where

14 ) where

14

15

15−import Data.Hashable (hash)

16+#if __GLASGOW_HASKELL__ < 709

17+import Control.Applicative ((<$>))

18+#endif

16import Data.IntMap.Strict (IntMap)

19import Data.IntMap.Strict (IntMap)

17import qualified Data.IntMap.Strict as I

20import qualified Data.IntMap.Strict as I

18−import Data.Semigroup

21+import qualified Network.Wai.Handler.Warp.Some as S

19−import Prelude -- Silence redundant import warnings

20

22

21----------------------------------------------------------------

23----------------------------------------------------------------

22

24

23−-- | 'MultiMap' is used for cache of file descriptors.

25+type MMap v = IntMap (S.Some 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

26

34----------------------------------------------------------------

27----------------------------------------------------------------

35

28

36-- | O(1)

29-- | O(1)

37−empty :: MultiMap v

30+isEmpty :: MMap v -> Bool

38−empty = MultiMap $ I.empty

31+isEmpty = I.null

39

32

40-- | O(1)

33-- | O(1)

41−isEmpty :: MultiMap v -> Bool

34+empty :: MMap v

42−isEmpty (MultiMap mm) = I.null mm

35+empty = I.empty

43

36

44----------------------------------------------------------------

37----------------------------------------------------------------

45

38

46-- | O(1)

39-- | O(1)

47−singleton :: FilePath -> v -> MultiMap v

40+singleton :: Int -> v -> MMap v

48−singleton path v = MultiMap mm

49− where

50− !h = hash path

51− !mm = I.singleton h [(path,v)]

41+singleton k v = I.singleton k (S.singleton v)

52

42

53----------------------------------------------------------------

43----------------------------------------------------------------

54

44

55−-- | O(N)

45+-- | O(log n)

56−lookup :: FilePath -> MultiMap v -> Maybe v

46+search :: Int -> MMap v -> Maybe v

57−lookup path (MultiMap mm) = case I.lookup h mm of

47+search k m = case I.lookup k m of

58 Nothing -> Nothing

48 Nothing -> Nothing

59− Just s -> Prelude.lookup path s

49+ Just s -> Just $! S.top s

60− where

61− !h = hash path

62−

63−----------------------------------------------------------------

64

50

65-- | O(log n)

51-- | O(log n)

66−insert :: FilePath -> v -> MultiMap v -> MultiMap v

52+searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v

67−insert path v (MultiMap mm) = MultiMap mm'

53+searchWith k f m = case I.lookup k m of

68− where

54+ Nothing -> Nothing

69− !h = hash path

55+ Just s -> S.lookupWith f s

70− !mm' = I.insertWith (<>) h [(path,v)] mm

71

56

72----------------------------------------------------------------

57----------------------------------------------------------------

73

58

74−-- | O(n)

59+-- | O(log n)

75−toList :: MultiMap v -> [(FilePath,v)]

60+insert :: Int -> v -> MMap v -> MMap v

76−toList (MultiMap mm) = concatMap snd $ I.toAscList mm

61+insert k v m = I.insertWith S.union k (S.singleton v) m

77

62

78----------------------------------------------------------------

63----------------------------------------------------------------

79

64

80-- | O(n)

65-- | O(n)

81−pruneWith :: MultiMap v

66+toList :: MMap v -> [v]

82− -> ((FilePath,v) -> IO Bool)

67+toList m = concatMap f $ I.toAscList m

83− -> IO (MultiMap v)

84−pruneWith (MultiMap mm) action = MultiMap <$> mm'

85 where

68 where

86− !mm' = I.fromAscList <$> go (I.toDescList mm) []

69+ f (_,s) = S.toList s

87− go [] !acc = return acc

88− go ((h,s):kss) !acc = do

89− rs <- prune action s

90− case rs of

91− [] -> go kss acc

92− _ -> go kss ((h,rs) : acc)

93

70

94----------------------------------------------------------------

71----------------------------------------------------------------

95

72

96−-- O(n + m) where N is the size of the second argument

73+-- | O(n)

97−merge :: MultiMap v -> MultiMap v -> MultiMap v

74+pruneWith :: MMap v

98−merge (MultiMap m1) (MultiMap m2) = MultiMap mm

75+ -> (v -> IO Bool)

76+ -> IO (MMap v)

77+pruneWith m action = I.fromAscList <$> go (I.toDescList m) []

99 where

78 where

100− !mm = I.unionWith (<>) m1 m2

79+ go [] acc = return acc

80+ go ((k,s):kss) acc = do

81+ mt <- S.prune action s

82+ case mt of

83+ Nothing -> go kss acc

84+ Just t -> go kss ((k,t) : acc)

101

85

102----------------------------------------------------------------

86----------------------------------------------------------------

103

87

104−prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]

88+-- O(n + m) where N is the size of the second argument

105−prune action xs0 = go xs0

89+merge :: MMap v -> MMap v -> MMap v

106− where

90+merge m1 m2 = I.unionWith S.union m1 m2

107− go [] = return []

108− go (x:xs) = do

109− keep <- action x

110− rs <- go xs

111− return $ if keep then x:rs else rs

warp/Network/Wai/Handler/Warp/PackInt.hs+6−6

@@ -2,21 +2,21 @@

2

3module Network.Wai.Handler.Warp.PackInt where

4

5+import Control.Monad (when)

5−import Data.ByteString.Internal (unsafeCreate)

6+import Data.ByteString.Internal (ByteString(..), unsafeCreate)

7+import Data.Word8 (Word8)

6import Foreign.Ptr (Ptr, plusPtr)

8import Foreign.Ptr (Ptr, plusPtr)

7import Foreign.Storable (poke)

9import Foreign.Storable (poke)

8import qualified Network.HTTP.Types as H

10import qualified Network.HTTP.Types as H

9

11

10−import Network.Wai.Handler.Warp.Imports

11−

12-- $setup

13−-- >>> import Data.ByteString.Char8 as C8

13+-- >>> import Data.ByteString.Char8 as B

14-- >>> import Test.QuickCheck (Large(..))

15

16-- |

17--

18−-- prop> packIntegral (abs n) == C8.pack (show (abs n))

18+-- prop> packIntegral (abs n) == B.pack (show (abs n))

19−-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.pack (show n')

19+-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == B.pack (show n')

20

21packIntegral :: Integral a => a -> ByteString

22packIntegral 0 = "0"

warp/Network/Wai/Handler/Warp/ReadInt.hs+2−2

@@ -13,13 +13,13 @@ module Network.Wai.Handler.Warp.ReadInt (

13-- This function lives in its own file because the MagicHash pragma interacts

14-- poorly with the CPP pragma.

15

16+import Data.ByteString (ByteString)

16import qualified Data.ByteString as S

17import qualified Data.ByteString as S

18+import Data.Int (Int64)

17import GHC.Prim

19import GHC.Prim

18import GHC.Types

20import GHC.Types

19import GHC.Word

21import GHC.Word

20

22

21−import Network.Wai.Handler.Warp.Imports hiding (readInt)

22−

23{-# INLINE readInt #-}

24readInt :: Integral a => ByteString -> a

25readInt bs = fromIntegral $ readInt64 bs

warp/Network/Wai/Handler/Warp/Recv.hs+17−44

@@ -9,27 +9,23 @@ module Network.Wai.Handler.Warp.Recv (

9 , spell

10 ) where

11

12+#if __GLASGOW_HASKELL__ < 709

13+import Control.Applicative ((<$>))

14+#endif

12import qualified Control.Exception as E

15import qualified Control.Exception as E

13import qualified Data.ByteString as BS

16import qualified Data.ByteString as BS

14−import Data.IORef

17+import Data.ByteString.Internal (ByteString(..))

18+import Data.Word (Word8)

15import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

19import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

16import Foreign.C.Types

20import Foreign.C.Types

17import Foreign.ForeignPtr (withForeignPtr)

21import Foreign.ForeignPtr (withForeignPtr)

18import Foreign.Ptr (Ptr, castPtr, plusPtr)

22import Foreign.Ptr (Ptr, castPtr, plusPtr)

19import GHC.Conc (threadWaitRead)

23import GHC.Conc (threadWaitRead)

20−import qualified GHC.IO.Exception as E

21−import Network.Socket (Socket)

24+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

28−import System.Posix.Types (Fd(..))

29−

30import Network.Wai.Handler.Warp.Buffer

25import Network.Wai.Handler.Warp.Buffer

31−import Network.Wai.Handler.Warp.Imports

26+import Network.Wai.Handler.Warp.IORef

32import Network.Wai.Handler.Warp.Types

27import Network.Wai.Handler.Warp.Types

28+import System.Posix.Types (Fd(..))

33

29

34#ifdef mingw32_HOST_OS

30#ifdef mingw32_HOST_OS

35import GHC.IO.FD (FD(..), readRawBufferPtr)

31import GHC.IO.FD (FD(..), readRawBufferPtr)

@@ -96,45 +92,24 @@ spell init0 siz0 recv recvBuf

96 siz' = siz - len

92 siz' = siz - len

97 loop bss' siz'

93 loop bss' siz'

98

94

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

95receive :: Socket -> BufferPool -> Recv

103−receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do

96+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

97+ let sock' = fdSocket sock

110−#endif

111− let size' = fromIntegral size

98+ size' = fromIntegral size

112− fromIntegral <$> receiveloop fd ptr size'

99+ 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

100

119receiveBuf :: Socket -> RecvBuf

101receiveBuf :: Socket -> RecvBuf

120−receiveBuf sock buf0 siz0 = do

102+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

103 where

130− loop _ _ 0 = return True

104+ loop _ 0 = return True

131− loop fd buf siz = do

105+ loop buf siz = do

132 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

106 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

133 -- fixme: what should we do in the case of n == 0

107 -- fixme: what should we do in the case of n == 0

134 if n == 0 then

108 if n == 0 then

135 return False

109 return False

136 else

110 else

137− loop fd (buf `plusPtr` n) (siz - n)

111+ loop (buf `plusPtr` n) (siz - n)

112+ fd = fdSocket sock

138

113

139receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

114receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

140receiveloop sock ptr size = do

115receiveloop sock ptr size = do

@@ -153,8 +128,6 @@ receiveloop sock ptr size = do

153 else

128 else

154 return bytes

129 return bytes

155

130

156−#ifndef mingw32_HOST_OS

157-- fixme: the type of the return value

131-- fixme: the type of the return value

158foreign import ccall unsafe "recv"

132foreign import ccall unsafe "recv"

159 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

133 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

160−#endif

warp/Network/Wai/Handler/Warp/Request.hs+36−34

@@ -9,36 +9,41 @@ module Network.Wai.Handler.Warp.Request (

9 , headerLines

10 , pauseTimeoutKey

11 , getFileInfoKey

12− , getClientCertificateKey

13 , NoKeepAliveRequest (..)

12 , NoKeepAliveRequest (..)

14 ) where

13 ) where

15

14

16import qualified Control.Concurrent as Conc (yield)

15import qualified Control.Concurrent as Conc (yield)

17import Control.Exception (throwIO, Exception)

16import Control.Exception (throwIO, Exception)

18import Data.Array ((!))

17import Data.Array ((!))

18+import Data.ByteString (ByteString)

19+import Data.Typeable (Typeable)

19import qualified Data.ByteString as S

20import qualified Data.ByteString as S

20import qualified Data.ByteString.Unsafe as SU

21import qualified Data.ByteString.Unsafe as SU

21import qualified Data.CaseInsensitive as CI

22import qualified Data.CaseInsensitive as CI

22import qualified Data.IORef as I

23import qualified Data.IORef as I

23−import Data.Typeable (Typeable)

24−import 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

29−import Network.Wai.Handler.Warp.Types

30−import Network.Wai.Internal

31−import Prelude hiding (lines)

32−import System.IO.Unsafe (unsafePerformIO)

33−import qualified System.TimeManager as Timeout

34−

35import Network.Wai.Handler.Warp.Conduit

27import Network.Wai.Handler.Warp.Conduit

36import Network.Wai.Handler.Warp.FileInfoCache

28import Network.Wai.Handler.Warp.FileInfoCache

29+import Network.Wai.Handler.Warp.HashMap (hashByteString)

37import Network.Wai.Handler.Warp.Header

30import Network.Wai.Handler.Warp.Header

38−import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

39import Network.Wai.Handler.Warp.ReadInt

31import Network.Wai.Handler.Warp.ReadInt

40import Network.Wai.Handler.Warp.RequestHeader

32import Network.Wai.Handler.Warp.RequestHeader

41−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)

33+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)

34+import qualified Network.Wai.Handler.Warp.Timeout as Timeout

35+import Network.Wai.Handler.Warp.Types

36+import Network.Wai.Internal

37+import Prelude hiding (lines)

38+import Control.Monad (when)

39+import qualified Data.Vault.Lazy as Vault

40+import System.IO.Unsafe (unsafePerformIO)

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/RequestHeader.hs+6−5

@@ -1,3 +1,4 @@

1+{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2

3

3module Network.Wai.Handler.Warp.RequestHeader (

4module Network.Wai.Handler.Warp.RequestHeader (

@@ -5,16 +6,16 @@ module Network.Wai.Handler.Warp.RequestHeader (

5 ) where

6 ) where

6

7

7import Control.Exception (throwIO)

8import Control.Exception (throwIO)

9+import Control.Monad (when)

8import qualified Data.ByteString as S

10import qualified Data.ByteString as S

9−import qualified Data.ByteString.Char8 as C8 (unpack)

11+import qualified Data.ByteString.Char8 as B (unpack)

10−import Data.ByteString.Internal (memchr)

12+import Data.ByteString.Internal (ByteString(..), memchr)

11import qualified Data.CaseInsensitive as CI

13import qualified Data.CaseInsensitive as CI

14+import Data.Word (Word8)

12import Foreign.ForeignPtr (withForeignPtr)

15import Foreign.ForeignPtr (withForeignPtr)

13import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

16import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

14import Foreign.Storable (peek)

17import Foreign.Storable (peek)

15import qualified Network.HTTP.Types as H

18import qualified Network.HTTP.Types as H

16−

17−import Network.Wai.Handler.Warp.Imports

18import Network.Wai.Handler.Warp.Types

19import Network.Wai.Handler.Warp.Types

19

20

20-- $setup

21-- $setup

@@ -88,7 +89,7 @@ parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> d

88

89

89 return (method,path,query,hv)

90 return (method,path,query,hv)

90 where

91 where

91− baderr = BadFirstLine $ C8.unpack requestLine

92+ baderr = BadFirstLine $ B.unpack requestLine

92 check :: Ptr Word8 -> Int -> Word8 -> IO ()

93 check :: Ptr Word8 -> Int -> Word8 -> IO ()

93 check p n w = do

94 check p n w = do

94 w0 <- peek $ p `plusPtr` n

95 w0 <- peek $ p `plusPtr` n

warp/Network/Wai/Handler/Warp/Response.hs+53−33

@@ -1,5 +1,6 @@

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE TupleSections #-}

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

5{-# LANGUAGE BangPatterns #-}

6{-# LANGUAGE BangPatterns #-}

@@ -13,34 +14,56 @@ module Network.Wai.Handler.Warp.Response (

13 , addServer -- testing

14 , addServer -- testing

14 ) where

15 ) where

15

16

17+#ifndef MIN_VERSION_base

18+#define MIN_VERSION_base(x,y,z) 1

19+#endif

20+

16−import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)

21+import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)

22+#if __GLASGOW_HASKELL__ < 709

23+import Control.Applicative

24+#endif

17import qualified Control.Exception as E

25import qualified Control.Exception as E

26+import Control.Monad (unless, when)

18import Data.Array ((!))

27import Data.Array ((!))

28+import Data.ByteString (ByteString)

19import qualified Data.ByteString as S

29import qualified Data.ByteString as S

30+import qualified Data.ByteString.Char8 as S8

20import Data.ByteString.Builder (byteString, Builder)

31import Data.ByteString.Builder (byteString, Builder)

21import Data.ByteString.Builder.Extra (flush)

32import Data.ByteString.Builder.Extra (flush)

22−import qualified Data.ByteString.Char8 as C8

23import qualified Data.CaseInsensitive as CI

33import qualified Data.CaseInsensitive as CI

24import Data.Function (on)

34import Data.Function (on)

35+import Data.List (deleteBy)

36+import Data.Maybe

37+#if MIN_VERSION_base(4,5,0)

38+# if __GLASGOW_HASKELL__ < 709

39+import Data.Monoid (mempty)

40+# endif

41+import Data.Monoid ((<>))

42+#else

43+import Data.Monoid (mappend, mempty)

44+#endif

25−import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)

45+import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)

26import Data.Version (showVersion)

46import Data.Version (showVersion)

27import Data.Word8 (_cr, _lf)

47import Data.Word8 (_cr, _lf)

28import qualified Network.HTTP.Types as H

48import qualified Network.HTTP.Types as H

29import qualified Network.HTTP.Types.Header as H

49import qualified Network.HTTP.Types.Header as H

30import Network.Wai

50import Network.Wai

31−import Network.Wai.Internal

32−import qualified Paths_warp

33−import qualified System.TimeManager as T

34−

35import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

51import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

36import qualified Network.Wai.Handler.Warp.Date as D

52import qualified Network.Wai.Handler.Warp.Date as D

37import Network.Wai.Handler.Warp.File

53import Network.Wai.Handler.Warp.File

38import Network.Wai.Handler.Warp.Header

54import Network.Wai.Handler.Warp.Header

39import Network.Wai.Handler.Warp.IO (toBufIOWith)

55import Network.Wai.Handler.Warp.IO (toBufIOWith)

40−import Network.Wai.Handler.Warp.Imports

41import Network.Wai.Handler.Warp.ResponseHeader

56import Network.Wai.Handler.Warp.ResponseHeader

42import Network.Wai.Handler.Warp.Settings

57import Network.Wai.Handler.Warp.Settings

58+import qualified Network.Wai.Handler.Warp.Timeout as T

43import Network.Wai.Handler.Warp.Types

59import Network.Wai.Handler.Warp.Types

60+import Network.Wai.Internal

61+import qualified Paths_warp

62+

63+#if !MIN_VERSION_base(4,5,0)

64+(<>) :: Monoid m => m -> m -> m

65+(<>) = mappend

66+#endif

44

67

45-- $setup

68-- $setup

46-- >>> :set -XOverloadedStrings

69-- >>> :set -XOverloadedStrings

@@ -101,13 +124,12 @@ import Network.Wai.Handler.Warp.Types

101sendResponse :: Settings

124sendResponse :: Settings

102 -> Connection

125 -> Connection

103 -> InternalInfo

126 -> InternalInfo

104− -> T.Handle

105 -> Request -- ^ HTTP request.

127 -> Request -- ^ HTTP request.

106 -> IndexedHeader -- ^ Indexed header of HTTP request.

128 -> IndexedHeader -- ^ Indexed header of HTTP request.

107 -> IO ByteString -- ^ source from client, for raw response

129 -> IO ByteString -- ^ source from client, for raw response

108 -> Response -- ^ HTTP response including status code and response header.

130 -> Response -- ^ HTTP response including status code and response header.

109 -> IO Bool -- ^ Returing True if the connection is persistent.

131 -> IO Bool -- ^ Returing True if the connection is persistent.

110−sendResponse settings conn ii th req reqidxhdr src response = do

132+sendResponse settings conn ii req reqidxhdr src response = do

111 hs <- addServerAndDate hs0

133 hs <- addServerAndDate hs0

112 if hasBody s then do

134 if hasBody s then do

113 -- The response to HEAD does not have body.

135 -- The response to HEAD does not have body.

@@ -116,14 +138,14 @@ sendResponse settings conn ii th req reqidxhdr src response = do

116 -- and status, the response to HEAD is processed here.

138 -- and status, the response to HEAD is processed here.

117 --

139 --

118 -- See definition of rsp below for proper body stripping.

140 -- See definition of rsp below for proper body stripping.

119− (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp

141+ (ms, mlen) <- sendRsp conn ii ver s hs rsp

120 case ms of

142 case ms of

121 Nothing -> return ()

143 Nothing -> return ()

122 Just realStatus -> logger req realStatus mlen

144 Just realStatus -> logger req realStatus mlen

123 T.tickle th

145 T.tickle th

124 return ret

146 return ret

125 else do

147 else do

126− _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody

148+ _ <- sendRsp conn ii ver s hs RspNoBody

127 logger req s Nothing

149 logger req s Nothing

128 T.tickle th

150 T.tickle th

129 return isPersist

151 return isPersist

@@ -134,6 +156,7 @@ sendResponse settings conn ii th req reqidxhdr src response = do

134 s = responseStatus response

156 s = responseStatus response

135 hs0 = sanitizeHeaders $ responseHeaders response

157 hs0 = sanitizeHeaders $ responseHeaders response

136 rspidxhdr = indexResponseHeader hs0

158 rspidxhdr = indexResponseHeader hs0

159+ th = threadHandle ii

137 getdate = getDate ii

160 getdate = getDate ii

138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

161 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

162 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

@@ -171,11 +194,11 @@ containsNewlines = S.any (\w -> w == _cr || w == _lf)

171

194

172{-# INLINE sanitizeHeaderValue #-}

195{-# INLINE sanitizeHeaderValue #-}

173sanitizeHeaderValue :: ByteString -> ByteString

196sanitizeHeaderValue :: ByteString -> ByteString

174−sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of

197+sanitizeHeaderValue v = case S8.lines $ S.filter (/= _cr) v of

175 [] -> ""

198 [] -> ""

176− x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)

199+ x : xs -> S8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)

177 where

200 where

178− addSpaceIfMissing line = case C8.uncons line of

201+ addSpaceIfMissing line = case S8.uncons line of

179 Nothing -> Nothing

202 Nothing -> Nothing

180 Just (first, _)

203 Just (first, _)

181 | first == ' ' || first == '\t' -> Just line

204 | first == ' ' || first == '\t' -> Just line

@@ -196,13 +219,12 @@ sendRsp :: Connection

196 -> H.HttpVersion

219 -> H.HttpVersion

197 -> H.Status

220 -> H.Status

198 -> H.ResponseHeaders

221 -> H.ResponseHeaders

199− -> IndexedHeader -- Response

200 -> Rsp

222 -> Rsp

201 -> IO (Maybe H.Status, Maybe Integer)

223 -> IO (Maybe H.Status, Maybe Integer)

202

224

203----------------------------------------------------------------

225----------------------------------------------------------------

204

226

205−sendRsp conn _ ver s hs _ RspNoBody = do

227+sendRsp conn _ ver s hs RspNoBody = do

206 -- Not adding Content-Length.

228 -- Not adding Content-Length.

207 -- User agents treats it as Content-Length: 0.

229 -- User agents treats it as Content-Length: 0.

208 composeHeader ver s hs >>= connSendAll conn

230 composeHeader ver s hs >>= connSendAll conn

@@ -210,7 +232,7 @@ sendRsp conn _ ver s hs _ RspNoBody = do

210

232

211----------------------------------------------------------------

233----------------------------------------------------------------

212

234

213−sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

235+sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

214 header <- composeHeaderBuilder ver s hs needsChunked

236 header <- composeHeaderBuilder ver s hs needsChunked

215 let hdrBdy

237 let hdrBdy

216 | needsChunked = header <> chunkedTransferEncoding body

238 | needsChunked = header <> chunkedTransferEncoding body

@@ -223,9 +245,9 @@ sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

223

245

224----------------------------------------------------------------

246----------------------------------------------------------------

225

247

226−sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

248+sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

227 header <- composeHeaderBuilder ver s hs needsChunked

249 header <- composeHeaderBuilder ver s hs needsChunked

228− (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

250+ (recv, finish) <- newBlazeRecv $ reuseBufferStrategy

229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

251 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

230 let send builder = do

252 let send builder = do

231 popper <- recv builder

253 popper <- recv builder

@@ -247,7 +269,7 @@ sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

247

269

248----------------------------------------------------------------

270----------------------------------------------------------------

249

271

250−sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

272+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

251 withApp recv send

273 withApp recv send

252 return (Nothing, Nothing)

274 return (Nothing, Nothing)

253 where

275 where

@@ -261,8 +283,8 @@ sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

261

283

262-- Sophisticated WAI applications.

284-- Sophisticated WAI applications.

263-- We respect s0. s0 MUST be a proper value.

285-- We respect s0. s0 MUST be a proper value.

264−sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

286+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

287+ sendRspFile2XX conn ii ver s0 hs path beg len isHead hook

266 where

288 where

267 beg = filePartOffset part

289 beg = filePartOffset part

268 len = filePartByteCount part

290 len = filePartByteCount part

@@ -272,17 +294,17 @@ sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

272

294

273-- Simple WAI applications.

295-- Simple WAI applications.

274-- Status is ignored

296-- Status is ignored

275−sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do

297+sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do

276 efinfo <- E.try $ getFileInfo ii path

298 efinfo <- E.try $ getFileInfo ii path

277 case efinfo of

299 case efinfo of

278 Left (_ex :: E.IOException) ->

300 Left (_ex :: E.IOException) ->

279#ifdef WARP_DEBUG

301#ifdef WARP_DEBUG

280 print _ex >>

302 print _ex >>

281#endif

303#endif

282− sendRspFile404 conn ii ver hs0 rspidxhdr

304+ sendRspFile404 conn ii ver hs0

283− Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of

305+ Right finfo -> case conditionalRequest finfo hs0 idxhdr of

284− WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody

306+ 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

307+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook

286

308

287----------------------------------------------------------------

309----------------------------------------------------------------

288

310

@@ -291,15 +313,14 @@ sendRspFile2XX :: Connection

291 -> H.HttpVersion

313 -> H.HttpVersion

292 -> H.Status

314 -> H.Status

293 -> H.ResponseHeaders

315 -> H.ResponseHeaders

294− -> IndexedHeader

295 -> FilePath

316 -> FilePath

296 -> Integer

317 -> Integer

297 -> Integer

318 -> Integer

298 -> Bool

319 -> Bool

299 -> IO ()

320 -> IO ()

300 -> IO (Maybe H.Status, Maybe Integer)

321 -> IO (Maybe H.Status, Maybe Integer)

301−sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

322+sendRspFile2XX conn ii ver s hs path beg len isHead hook

302− | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody

323+ | isHead = sendRsp conn ii ver s hs RspNoBody

303 | otherwise = do

324 | otherwise = do

304 lheader <- composeHeader ver s hs

325 lheader <- composeHeader ver s hs

305 (mfd, fresher) <- getFd ii path

326 (mfd, fresher) <- getFd ii path

@@ -312,9 +333,8 @@ sendRspFile404 :: Connection

312 -> InternalInfo

333 -> InternalInfo

313 -> H.HttpVersion

334 -> H.HttpVersion

314 -> H.ResponseHeaders

335 -> H.ResponseHeaders

315− -> IndexedHeader

316 -> IO (Maybe H.Status, Maybe Integer)

336 -> IO (Maybe H.Status, Maybe Integer)

317−sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)

337+sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)

318 where

338 where

319 s = H.notFound404

339 s = H.notFound404

320 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

340 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

warp/Network/Wai/Handler/Warp/ResponseHeader.hs+5−3

@@ -3,15 +3,17 @@

3

4module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where

5

6+import Control.Monad

7+import Data.ByteString (ByteString)

6import qualified Data.ByteString as S

8import qualified Data.ByteString as S

7import Data.ByteString.Internal (create)

9import Data.ByteString.Internal (create)

8import qualified Data.CaseInsensitive as CI

10import qualified Data.CaseInsensitive as CI

11+import Data.List (foldl')

12+import Data.Word (Word8)

9import Foreign.Ptr

13import Foreign.Ptr

10import GHC.Storable

14import GHC.Storable

11import qualified Network.HTTP.Types as H

15import qualified Network.HTTP.Types as H

12−

13import Network.Wai.Handler.Warp.Buffer (copy)

16import Network.Wai.Handler.Warp.Buffer (copy)

14−import Network.Wai.Handler.Warp.Imports

15

17

16----------------------------------------------------------------

18----------------------------------------------------------------

17

19

@@ -22,7 +24,7 @@ composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do

22 void $ copyCRLF ptr2

24 void $ copyCRLF ptr2

23 where

25 where

24 !len = 17 + slen + foldl' fieldLength 0 responseHeaders

26 !len = 17 + slen + foldl' fieldLength 0 responseHeaders

25− fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4

27+ fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4

26 !slen = S.length $ H.statusMessage status

28 !slen = S.length $ H.statusMessage status

27

29

28httpVer11 :: ByteString

30httpVer11 :: ByteString

warp/Network/Wai/Handler/Warp/Run.hs+81−136

@@ -3,53 +3,50 @@

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

13

11

14−import "iproute" Data.IP (toHostAddress, toHostAddress6)

12+#if __GLASGOW_HASKELL__ < 709

13+import Control.Applicative ((<$>))

14+#endif

15import Control.Arrow (first)

16import qualified Control.Concurrent as Conc (yield)

17import Control.Exception as E

18+import Control.Monad (when, unless, void)

19+import Data.ByteString (ByteString)

18import qualified Data.ByteString as S

20import qualified Data.ByteString as S

19import Data.Char (chr)

21import Data.Char (chr)

22+import "iproute" Data.IP (toHostAddress, toHostAddress6)

20import Data.IORef (IORef, newIORef, readIORef, writeIORef)

23import Data.IORef (IORef, newIORef, readIORef, writeIORef)

21import Data.Streaming.Network (bindPortTCP)

24import Data.Streaming.Network (bindPortTCP)

22import Foreign.C.Error (Errno(..), eCONNABORTED)

25import Foreign.C.Error (Errno(..), eCONNABORTED)

23import GHC.IO.Exception (IOException(..))

26import GHC.IO.Exception (IOException(..))

24−import qualified Network.HTTP2 as H2

27+import Network (Socket)

25−import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

28+import Network.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

30import Network.Wai

31−import Network.Wai.Internal (ResponseReceived (ResponseReceived))

32−import System.Environment (lookupEnv)

33−import qualified System.TimeManager as T

34−import System.Timeout (timeout)

35−

36import Network.Wai.Handler.Warp.Buffer

31import Network.Wai.Handler.Warp.Buffer

37import Network.Wai.Handler.Warp.Counter

32import Network.Wai.Handler.Warp.Counter

38import qualified Network.Wai.Handler.Warp.Date as D

33import qualified Network.Wai.Handler.Warp.Date as D

39import qualified Network.Wai.Handler.Warp.FdCache as F

34import qualified Network.Wai.Handler.Warp.FdCache as F

40import qualified Network.Wai.Handler.Warp.FileInfoCache as I

35import qualified Network.Wai.Handler.Warp.FileInfoCache as I

41−import Network.Wai.Handler.Warp.HTTP2 (http2)

36+import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)

42−import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)

43import Network.Wai.Handler.Warp.Header

37import Network.Wai.Handler.Warp.Header

44−import Network.Wai.Handler.Warp.Imports hiding (readInt)

38+import Network.Wai.Handler.Warp.IORef

45import Network.Wai.Handler.Warp.ReadInt

39import Network.Wai.Handler.Warp.ReadInt

46import Network.Wai.Handler.Warp.Recv

40import Network.Wai.Handler.Warp.Recv

47import Network.Wai.Handler.Warp.Request

41import Network.Wai.Handler.Warp.Request

48import Network.Wai.Handler.Warp.Response

42import Network.Wai.Handler.Warp.Response

49import Network.Wai.Handler.Warp.SendFile

43import Network.Wai.Handler.Warp.SendFile

50import Network.Wai.Handler.Warp.Settings

44import Network.Wai.Handler.Warp.Settings

45+import qualified Network.Wai.Handler.Warp.Timeout as T

51import Network.Wai.Handler.Warp.Types

46import Network.Wai.Handler.Warp.Types

52−

47+import Network.Wai.Internal (ResponseReceived (ResponseReceived))

48+import System.Environment (getEnvironment)

49+import System.Timeout (timeout)

53

50

54#if WINDOWS

51#if WINDOWS

55import Network.Wai.Handler.Warp.Windows

52import Network.Wai.Handler.Warp.Windows

@@ -58,40 +55,28 @@ import Network.Socket (fdSocket)

58#endif

55#endif

59

56

60-- | Creating 'Connection' for plain HTTP based on a given socket.

57-- | Creating 'Connection' for plain HTTP based on a given socket.

61−socketConnection :: Settings -> Socket -> IO Connection

58+socketConnection :: Socket -> IO Connection

62−#if MIN_VERSION_network(3,1,1)

63−socketConnection set s = do

64−#else

65−socketConnection _ s = do

59+socketConnection s = do

66−#endif

67 bufferPool <- newBufferPool

60 bufferPool <- newBufferPool

68 writeBuf <- allocateBuffer bufferSize

61 writeBuf <- allocateBuffer bufferSize

69 let sendall = Sock.sendAll s

62 let sendall = Sock.sendAll s

70− isH2 <- newIORef False -- HTTP/1.x

71 return Connection {

63 return Connection {

72 connSendMany = Sock.sendMany s

64 connSendMany = Sock.sendMany s

73 , connSendAll = sendall

65 , connSendAll = sendall

74 , connSendFile = sendFile s writeBuf bufferSize sendall

66 , 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

67 , connClose = close s

86−#endif

87 , connFree = freeBuffer writeBuf

68 , connFree = freeBuffer writeBuf

88 , connRecv = receive s bufferPool

69 , connRecv = receive s bufferPool

89 , connRecvBuf = receiveBuf s

70 , connRecvBuf = receiveBuf s

90 , connWriteBuffer = writeBuf

71 , connWriteBuffer = writeBuf

91 , connBufferSize = bufferSize

72 , connBufferSize = bufferSize

92− , connHTTP2 = isH2

93 }

73 }

94

74

75+#if __GLASGOW_HASKELL__ < 702

76+allowInterrupt :: IO ()

77+allowInterrupt = unblock $ return ()

78+#endif

79+

95-- | Run an 'Application' on the given port.

80-- | Run an 'Application' on the given port.

96-- This calls 'runSettings' with 'defaultSettings'.

81-- This calls 'runSettings' with 'defaultSettings'.

97run :: Port -> Application -> IO ()

82run :: Port -> Application -> IO ()

@@ -104,7 +89,7 @@ run p = runSettings defaultSettings { settingsPort = p }

104-- Since 3.0.9

89-- Since 3.0.9

105runEnv :: Port -> Application -> IO ()

90runEnv :: Port -> Application -> IO ()

106runEnv p app = do

91runEnv p app = do

107− mp <- lookupEnv "PORT"

92+ mp <- lookup "PORT" <$> getEnvironment

108

93

109 maybe (run p app) runReadPort mp

94 maybe (run p app) runReadPort mp

110

95

@@ -151,7 +136,7 @@ runSettingsSocket set socket app = do

151 setSocketCloseOnExec s

136 setSocketCloseOnExec s

152 -- NoDelay causes an error for AF_UNIX.

137 -- NoDelay causes an error for AF_UNIX.

153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

138 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

154− conn <- socketConnection set s

139+ conn <- socketConnection s

155 return (conn, sa)

140 return (conn, sa)

156

141

157 closeListenSocket = close socket

142 closeListenSocket = close socket

@@ -192,15 +177,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),

192runSettingsConnectionMakerSecure set getConnMaker app = do

177runSettingsConnectionMakerSecure set getConnMaker app = do

193 settingsBeforeMainLoop set

178 settingsBeforeMainLoop set

194 counter <- newCounter

179 counter <- newCounter

195− withII $ acceptConnection set getConnMaker app counter

180+ withII0 $ acceptConnection set getConnMaker app counter

196 where

181 where

197− withII action =

182+ withII0 action =

198 withTimeoutManager $ \tm ->

183 withTimeoutManager $ \tm ->

199 D.withDateCache $ \dc ->

184 D.withDateCache $ \dc ->

200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

185 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

186 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

202− let ii = InternalInfo tm dc fdc fic

187+ let ii0 = InternalInfo0 tm dc fdc fic

203− action ii

188+ action ii0

204

189

205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

190 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

191 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

@@ -229,18 +214,13 @@ acceptConnection :: Settings

229 -> IO (IO (Connection, Transport), SockAddr)

214 -> IO (IO (Connection, Transport), SockAddr)

230 -> Application

215 -> Application

231 -> Counter

216 -> Counter

232− -> InternalInfo

217+ -> InternalInfo0

233 -> IO ()

218 -> IO ()

234−acceptConnection set getConnMaker app counter ii = do

219+acceptConnection set getConnMaker app counter ii0 = do

235 -- First mask all exceptions in acceptLoop. This is necessary to

220 -- First mask all exceptions in acceptLoop. This is necessary to

236 -- ensure that no async exception is throw between the call to

221 -- ensure that no async exception is throw between the call to

237 -- acceptNewConnection and the registering of connClose.

222 -- acceptNewConnection and the registering of connClose.

238− --

239− -- acceptLoop can be broken by closing the listing socket.

240 void $ mask_ acceptLoop

223 void $ mask_ acceptLoop

241− -- In some cases, we want to stop Warp here without graceful shutdown.

242− -- So, async exceptions are allowed here.

243− -- That's why `finally` is not used.

244 gracefulShutdown set counter

224 gracefulShutdown set counter

245 where

225 where

246 acceptLoop = do

226 acceptLoop = do

@@ -258,7 +238,7 @@ acceptConnection set getConnMaker app counter ii = do

258 case mx of

238 case mx of

259 Nothing -> return ()

239 Nothing -> return ()

260 Just (mkConn, addr) -> do

240 Just (mkConn, addr) -> do

261− fork set mkConn addr app counter ii

241+ fork set mkConn addr app counter ii0

262 acceptLoop

242 acceptLoop

263

243

264 acceptNewConnection = do

244 acceptNewConnection = do

@@ -281,12 +261,15 @@ fork :: Settings

281 -> SockAddr

261 -> SockAddr

282 -> Application

262 -> Application

283 -> Counter

263 -> Counter

284− -> InternalInfo

264+ -> InternalInfo0

285 -> IO ()

265 -> IO ()

286−fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

266+fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

287 -- Call the user-supplied on exception code if any

267 -- Call the user-supplied on exception code if any

288 -- exceptions are thrown.

268 -- exceptions are thrown.

289− handle (settingsOnException set Nothing) $

269+ handle (settingsOnException set Nothing) .

270+ -- Allocate a new IORef indicating whether the connection has been

271+ -- closed, to avoid double-freeing a connection

272+ withClosedRef $ \ref ->

290 -- Run the connection maker to get a new connection, and ensure

273 -- Run the connection maker to get a new connection, and ensure

291 -- that the connection is closed. If the mkConn call throws an

274 -- that the connection is closed. If the mkConn call throws an

292 -- exception, we will leak the connection. If the mkConn call is

275 -- exception, we will leak the connection. If the mkConn call is

@@ -297,15 +280,24 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

297 -- We grab the connection before registering timeouts since the

280 -- We grab the connection before registering timeouts since the

298 -- timeouts will be useless during connection creation, due to the

281 -- timeouts will be useless during connection creation, due to the

299 -- fact that async exceptions are still masked.

282 -- fact that async exceptions are still masked.

300− bracket mkConn cleanUp (serve unmask)

283+ bracket mkConn (cleanUp ref) (serve unmask ref)

301 where

284 where

285+ withClosedRef inner = newIORef False >>= inner

286+

287+ closeConn ref conn = do

288+ isClosed <- atomicModifyIORef' ref $ \x -> (True, x)

289+ unless isClosed $ connClose conn

290+

302− cleanUp (conn, _) = connClose conn `finally` connFree conn

291+ cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn

303

292

304 -- We need to register a timeout handler for this thread, and

293 -- We need to register a timeout handler for this thread, and

305− -- cancel that handler as soon as we exit.

294+ -- cancel that handler as soon as we exit. We additionally close

295+ -- the connection immediately in case the child thread catches the

296+ -- async exception or performs some long-running cleanup action.

306− serve unmask (conn, transport) = bracket register cancel $ \th -> do

297+ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do

298+ let ii1 = toInternalInfo1 ii0 th

307 -- We now have fully registered a connection close handler in

299 -- We now have fully registered a connection close handler in

308− -- the case of all exceptions, so it is safe to once again

300+ -- the case of all exceptions, so it is safe to one again

309 -- allow async exceptions.

301 -- allow async exceptions.

310 unmask .

302 unmask .

311 -- Call the user-supplied code for connection open and

303 -- Call the user-supplied code for connection open and

@@ -313,23 +305,23 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

313 bracket (onOpen addr) (onClose addr) $ \goingon ->

305 bracket (onOpen addr) (onClose addr) $ \goingon ->

314 -- Actually serve this connection. bracket with closeConn

306 -- Actually serve this connection. bracket with closeConn

315 -- above ensures the connection is closed.

307 -- above ensures the connection is closed.

316− when goingon $ serveConnection conn ii th addr transport set app

308+ when goingon $ serveConnection conn ii1 addr transport set app

317 where

309 where

318− register = T.registerKillThread (timeoutManager ii) (connClose conn)

310+ register = T.registerKillThread (timeoutManager0 ii0)

311+ (closeConn ref conn)

319 cancel = T.cancel

312 cancel = T.cancel

320

313

321 onOpen adr = increase counter >> settingsOnOpen set adr

314 onOpen adr = increase counter >> settingsOnOpen set adr

322 onClose adr _ = decrease counter >> settingsOnClose set adr

315 onClose adr _ = decrease counter >> settingsOnClose set adr

323

316

324serveConnection :: Connection

317serveConnection :: Connection

325− -> InternalInfo

318+ -> InternalInfo1

326− -> T.Handle

327 -> SockAddr

319 -> SockAddr

328 -> Transport

320 -> Transport

329 -> Settings

321 -> Settings

330 -> Application

322 -> Application

331 -> IO ()

323 -> IO ()

332−serveConnection conn ii th origAddr transport settings app = do

324+serveConnection conn ii1 origAddr transport settings app = do

333 -- fixme: Upgrading to HTTP/2 should be supported.

325 -- fixme: Upgrading to HTTP/2 should be supported.

334 (h2,bs) <- if isHTTP2 transport then

326 (h2,bs) <- if isHTTP2 transport then

335 return (True, "")

327 return (True, "")

@@ -342,36 +334,17 @@ serveConnection conn ii th origAddr transport settings app = do

342 istatus <- newIORef False

334 istatus <- newIORef False

343 if settingsHTTP2Enabled settings && h2 then do

335 if settingsHTTP2Enabled settings && h2 then do

344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

336 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

337 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

353− sendBS x = connSendAll conn x >> T.tickle th

354 -- fixme: origAddr

338 -- fixme: origAddr

355− checkTLS

356− setConnHTTP2 conn True

357− http2 conn transport ii origAddr settings recvN sendBS app

339+ http2 conn ii1 origAddr transport settings recvN app

358 else do

340 else do

359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

341 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

360 writeIORef istatus True

342 writeIORef istatus True

361 leftoverSource src bs

343 leftoverSource src bs

362 addr <- getProxyProtocolAddr src

344 addr <- getProxyProtocolAddr src

363− http1 True addr istatus src `E.catch` \e ->

345+ http1 True addr istatus src `E.catch` \e -> do

364− case () of

365− ()

366− -- See comment below referencing

367− -- https://github.com/yesodweb/wai/issues/618

368− | Just NoKeepAliveRequest <- fromException e -> return ()

369− -- No valid request

370− | Just (BadFirstLine _) <- fromException e -> return ()

371− | otherwise -> do

372− _ <- sendErrorResponse (dummyreq addr) istatus e

346+ sendErrorResponse addr istatus e

373− throwIO e

347+ throwIO (e :: SomeException)

374−

375 where

348 where

376 getProxyProtocolAddr src =

349 getProxyProtocolAddr src =

377 case settingsProxyProtocol settings of

350 case settingsProxyProtocol settings of

@@ -413,25 +386,30 @@ serveConnection conn ii th origAddr transport settings app = do

413

386

414 decodeAscii = map (chr . fromEnum) . S.unpack

387 decodeAscii = map (chr . fromEnum) . S.unpack

415

388

389+ th = threadHandle1 ii1

390+

416 shouldSendErrorResponse se

391 shouldSendErrorResponse se

417 | Just ConnectionClosedByPeer <- fromException se = False

392 | Just ConnectionClosedByPeer <- fromException se = False

418 | otherwise = True

393 | otherwise = True

419

394

420− sendErrorResponse req istatus e = do

395+ sendErrorResponse addr istatus e = do

421 status <- readIORef istatus

396 status <- readIORef istatus

422− if shouldSendErrorResponse e && status

397+ when (shouldSendErrorResponse e && status) $ do

423− then do

398+ let ii = toInternalInfo ii1 0 -- dummy

399+ dreq = dummyreq addr

424− sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

400+ void $ sendResponse settings conn ii dreq defaultIndexRequestHeader (return S.empty) (errorResponse e)

425− else return False

426

401

427 dummyreq addr = defaultRequest { remoteHost = addr }

402 dummyreq addr = defaultRequest { remoteHost = addr }

428

403

429 errorResponse e = settingsOnExceptionResponse settings e

404 errorResponse e = settingsOnExceptionResponse settings e

430

405

431 http1 firstRequest addr istatus src = do

406 http1 firstRequest addr istatus src = do

432− (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport

407+ (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src

408+ let req = req' { isSecure = isTransportSecure transport }

433− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

409+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii

434 `E.catch` \e -> do

410 `E.catch` \e -> do

411+ -- Call the user-supplied exception handlers, passing the request.

412+ sendErrorResponse addr istatus e

435 settingsOnException settings (Just req) e

413 settingsOnException settings (Just req) e

436 -- Don't throw the error again to prevent calling settingsOnException twice.

414 -- Don't throw the error again to prevent calling settingsOnException twice.

437 return False

415 return False

@@ -444,9 +422,9 @@ serveConnection conn ii th origAddr transport settings app = do

444 -- request headers, no data is available, recvRequest will

422 -- request headers, no data is available, recvRequest will

445 -- throw a NoKeepAliveRequest exception, which we catch here

423 -- throw a NoKeepAliveRequest exception, which we catch here

446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

424 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

447− when keepAlive $ http1 False addr istatus src

425+ when keepAlive $ http1 False addr istatus src `E.catch` \NoKeepAliveRequest -> return ()

448

426

449− processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

427+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do

450 -- Let the application run for as long as it wants

428 -- Let the application run for as long as it wants

451 T.pause th

429 T.pause th

452

430

@@ -454,38 +432,30 @@ serveConnection conn ii th origAddr transport settings app = do

454 -- creating the request, we need to make sure that we don't get

432 -- creating the request, we need to make sure that we don't get

455 -- an async exception before calling the ResponseSource.

433 -- an async exception before calling the ResponseSource.

456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

434 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

457− r <- E.try $ app req $ \res -> do

435+ _ <- app req $ \res -> do

458 T.resume th

436 T.resume th

459 -- FIXME consider forcing evaluation of the res here to

437 -- FIXME consider forcing evaluation of the res here to

460 -- send more meaningful error messages to the user.

438 -- send more meaningful error messages to the user.

461 -- However, it may affect performance.

439 -- However, it may affect performance.

462 writeIORef istatus False

440 writeIORef istatus False

463− keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

441+ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

464 writeIORef keepAliveRef keepAlive

442 writeIORef keepAliveRef keepAlive

465 return ResponseReceived

443 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

444 keepAlive <- readIORef keepAliveRef

476

445

477 -- We just send a Response and it takes a time to

446 -- We just send a Response and it takes a time to

478 -- receive a Request again. If we immediately call recv,

447 -- receive a Request again. If we immediately call recv,

479− -- it is likely to fail and cause the IO manager to do some work.

448+ -- it is likely to fail and the IO manager works.

480− -- It is very costly, so we yield to another Haskell

449+ -- It is very costly. So, we yield to another Haskell

481 -- thread hoping that the next Request will arrive

450 -- thread hoping that the next Request will arrive

482 -- when this Haskell thread will be re-scheduled.

451 -- when this Haskell thread will be re-scheduled.

483 -- This improves performance at least when

452 -- This improves performance at least when

484 -- the number of cores is small.

453 -- the number of cores is small.

485 Conc.yield

454 Conc.yield

486

455

487− if keepAlive

456+ if not keepAlive then

488− then

457+ return False

458+ else

489 -- If there is an unknown or large amount of data to still be read

459 -- 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

460 -- from the request body, simple drop this connection instead of

491 -- reading it all in to satisfy a keep-alive request.

461 -- reading it all in to satisfy a keep-alive request.

@@ -511,21 +481,6 @@ serveConnection conn ii th origAddr transport settings app = do

511 else

481 else

512 return False

482 return False

513 Nothing -> tryKeepAlive

483 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

484

530flushEntireBody :: IO ByteString -> IO ()

485flushEntireBody :: IO ByteString -> IO ()

531flushEntireBody src =

486flushEntireBody src =

@@ -571,22 +526,12 @@ wrappedRecvN th istatus slowlorisSize readN bufsize = do

571 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th

526 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th

572 return bs

527 return bs

573

528

574−-- | Set flag FileCloseOnExec flag on a socket (on Unix)

575−--

576-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

529-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

577−--

578−-- @since 3.2.17

579setSocketCloseOnExec :: Socket -> IO ()

530setSocketCloseOnExec :: Socket -> IO ()

580#if WINDOWS

531#if WINDOWS

581setSocketCloseOnExec _ = return ()

532setSocketCloseOnExec _ = return ()

582#else

533#else

583−setSocketCloseOnExec socket = do

584−#if MIN_VERSION_network(3,0,0)

585− fd <- fdSocket socket

586−#else

587− let fd = fdSocket socket

588−#endif

589− F.setFileCloseOnExec $ fromIntegral fd

534+setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket

590#endif

535#endif

591

536

592gracefulShutdown :: Settings -> Counter -> IO ()

537gracefulShutdown :: Settings -> Counter -> IO ()

warp/Network/Wai/Handler/Warp/SendFile.hs+8−4

@@ -9,14 +9,22 @@ module Network.Wai.Handler.Warp.SendFile (

9#endif

10 ) where

11

12+import Control.Monad (void, when)

13+import Data.ByteString (ByteString)

12import qualified Data.ByteString as BS

14import qualified Data.ByteString as BS

13import Network.Socket (Socket)

15import Network.Socket (Socket)

16+import Network.Wai.Handler.Warp.Buffer

17+import Network.Wai.Handler.Warp.Types

14

18

15#ifdef WINDOWS

19#ifdef WINDOWS

20+import Data.ByteString.Internal (ByteString(..))

16import Foreign.ForeignPtr (newForeignPtr_)

21import Foreign.ForeignPtr (newForeignPtr_)

17import Foreign.Ptr (plusPtr)

22import Foreign.Ptr (plusPtr)

18import qualified System.IO as IO

23import qualified System.IO as IO

19#else

24#else

25+# if __GLASGOW_HASKELL__ < 709

26+import Control.Applicative ((<$>))

27+# endif

20import Control.Exception

28import Control.Exception

21import Foreign.C.Error (throwErrno)

29import Foreign.C.Error (throwErrno)

22import Foreign.C.Types

30import Foreign.C.Types

@@ -26,10 +34,6 @@ import Network.Wai.Handler.Warp.FdCache (openFile, closeFile)

26import System.Posix.Types

34import System.Posix.Types

27#endif

35#endif

28

36

29−import Network.Wai.Handler.Warp.Buffer

30−import Network.Wai.Handler.Warp.Imports

31−import Network.Wai.Handler.Warp.Types

32−

33----------------------------------------------------------------

37----------------------------------------------------------------

34

38

35-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.

39-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.

warp/Network/Wai/Handler/Warp/Settings.hs+19−60

@@ -6,25 +6,26 @@ module Network.Wai.Handler.Warp.Settings where

6

7import Control.Concurrent (forkIOWithUnmask)

8import Control.Exception

9+import Control.Monad (when, void)

10+import Data.ByteString (ByteString)

11+import qualified Data.ByteString.Char8 as S8

9import Data.ByteString.Builder (byteString)

12import Data.ByteString.Builder (byteString)

10−import qualified Data.ByteString.Char8 as C8

13+#if __GLASGOW_HASKELL__ < 709

11−import Data.ByteString.Lazy (fromStrict)

14+import Data.Monoid (mappend)

15+#endif

12import Data.Streaming.Network (HostPreference)

16import Data.Streaming.Network (HostPreference)

13import qualified Data.Text as T

17import qualified Data.Text as T

14import qualified Data.Text.IO as TIO

18import qualified Data.Text.IO as TIO

15import Data.Version (showVersion)

19import Data.Version (showVersion)

16import GHC.IO.Exception (IOErrorType(..))

20import GHC.IO.Exception (IOErrorType(..))

17import qualified Network.HTTP.Types as H

21import qualified Network.HTTP.Types as H

18−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

19import Network.Socket (SockAddr)

22import Network.Socket (SockAddr)

20import Network.Wai

23import Network.Wai

24+import Network.Wai.Handler.Warp.Timeout

25+import Network.Wai.Handler.Warp.Types

21import qualified Paths_warp

26import qualified Paths_warp

22import System.IO (stderr)

27import System.IO (stderr)

23import System.IO.Error (ioeGetErrorType)

28import System.IO.Error (ioeGetErrorType)

24−import System.TimeManager

25−

26−import Network.Wai.Handler.Warp.Imports

27−import Network.Wai.Handler.Warp.Types

28

29

29-- | Various Warp server settings. This is purposely kept as an abstract data

30-- | Various Warp server settings. This is purposely kept as an abstract data

30-- type so that new settings can be added without breaking backwards

31-- type so that new settings can be added without breaking backwards

@@ -76,13 +77,6 @@ data Settings = Settings

76 --

77 --

77 -- Since 2.0.3

78 -- Since 2.0.3

78 , settingsInstallShutdownHandler :: IO () -> IO ()

79 , 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

80 , settingsServerName :: ByteString

87 -- ^ Default server name if application does not set one.

81 -- ^ Default server name if application does not set one.

88 --

82 --

@@ -94,44 +88,28 @@ data Settings = Settings

94 , settingsProxyProtocol :: ProxyProtocol

88 , settingsProxyProtocol :: ProxyProtocol

95 -- ^ Specify usage of the PROXY protocol.

89 -- ^ Specify usage of the PROXY protocol.

96 --

90 --

97− -- Since 3.0.5

91+ -- Since 3.0.5.

98 , settingsSlowlorisSize :: Int

92 , settingsSlowlorisSize :: Int

99 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

93 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

100 --

94 --

101− -- Since 3.1.2

95+ -- Since 3.1.2.

102 , settingsHTTP2Enabled :: Bool

96 , settingsHTTP2Enabled :: Bool

103 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

97 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

104 --

98 --

105− -- Since 3.1.7

99+ -- Since 3.1.7.

106 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

100 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

107 -- ^ A log function. Default: no action.

101 -- ^ A log function. Default: no action.

108 --

102 --

109− -- Since 3.1.10

103+ -- Since 3.X.X.

110 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

104 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

111 -- ^ A HTTP/2 server push log function. Default: no action.

105 -- ^ A HTTP/2 server push log function. Default: no action.

112 --

106 --

113− -- Since 3.2.7

107+ -- Since 3.X.X.

114 , settingsGracefulShutdownTimeout :: Maybe Int

108 , settingsGracefulShutdownTimeout :: Maybe Int

115 -- ^ An optional timeout to limit the time (in seconds) waiting for

109 -- ^ An optional timeout to limit the time (in seconds) waiting for

116 -- a graceful shutdown of the web server.

110 -- a graceful shutdown of the web server.

117 --

111 --

118 -- Since 3.2.8

112 -- 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 }

113 }

136

114

137-- | Specify usage of the PROXY protocol.

115-- | Specify usage of the PROXY protocol.

@@ -160,7 +138,7 @@ defaultSettings = Settings

160 , settingsFork = void . forkIOWithUnmask

138 , settingsFork = void . forkIOWithUnmask

161 , settingsNoParsePath = False

139 , settingsNoParsePath = False

162 , settingsInstallShutdownHandler = const $ return ()

140 , settingsInstallShutdownHandler = const $ return ()

163− , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version

141+ , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version

164 , settingsMaximumBodyFlush = Just 8192

142 , settingsMaximumBodyFlush = Just 8192

165 , settingsProxyProtocol = ProxyProtocolNone

143 , settingsProxyProtocol = ProxyProtocolNone

166 , settingsSlowlorisSize = 2048

144 , settingsSlowlorisSize = 2048

@@ -168,9 +146,6 @@ defaultSettings = Settings

168 , settingsLogger = \_ _ _ -> return ()

146 , settingsLogger = \_ _ _ -> return ()

169 , settingsServerPushLogger = \_ _ _ -> return ()

147 , settingsServerPushLogger = \_ _ _ -> return ()

170 , settingsGracefulShutdownTimeout = Nothing

148 , settingsGracefulShutdownTimeout = Nothing

171− , settingsGracefulCloseTimeout1 = 0

172− , settingsGracefulCloseTimeout2 = 2000

173− , settingsMaxTotalHeaderLength = 50 * 1024

174 }

149 }

175

150

176-- | Apply the logic provided by 'defaultOnException' to determine if an

151-- | Apply the logic provided by 'defaultOnException' to determine if an

@@ -196,29 +171,13 @@ defaultOnException _ e =

196 when (defaultShouldDisplayException e)

171 when (defaultShouldDisplayException e)

197 $ TIO.hPutStrLn stderr $ T.pack $ show e

172 $ TIO.hPutStrLn stderr $ T.pack $ show e

198

173

199−-- | Sending 400 for bad requests.

200−-- Sending 500 for internal server errors.

174+-- | Sending 400 for bad requests. Sending 500 for internal server errors.

175+--

201-- Since: 3.1.0

176-- 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

177defaultOnExceptionResponse :: SomeException -> Response

206defaultOnExceptionResponse e

178defaultOnExceptionResponse e

207− | Just (_ :: InvalidRequest) <-

208− fromException e = responseLBS H.badRequest400

179+ | 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

180+ | 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

181

223-- | Exception handler for the debugging purpose.

182-- | Exception handler for the debugging purpose.

224-- 500, text/plain, a showed exception.

183-- 500, text/plain, a showed exception.

@@ -228,4 +187,4 @@ exceptionResponseForDebug :: SomeException -> Response

228exceptionResponseForDebug e =

187exceptionResponseForDebug e =

229 responseBuilder H.internalServerError500

188 responseBuilder H.internalServerError500

230 [(H.hContentType, "text/plain; charset=utf-8")]

189 [(H.hContentType, "text/plain; charset=utf-8")]

231− $ byteString . C8.pack $ "Exception: " ++ show e

190+ $ byteString . S8.pack $ "Exception: " ++ show e

warp/Network/Wai/Handler/Warp/Some.hsnew file+73

@@ -0,0 +1,73 @@

1+{-# LANGUAGE BangPatterns #-}

2+

3+module Network.Wai.Handler.Warp.Some (

4+ Some

5+ , singleton

6+ , top

7+ , lookupWith

8+ , union

9+ , toList

10+ , prune

11+ ) where

12+

13+----------------------------------------------------------------

14+

15+-- | One ore more list to implement multimap.

16+data Some a = One !a

17+ | Tom !a !(Some a) -- Two or more

18+ deriving (Eq,Show)

19+

20+{-# INLINE singleton #-}

21+singleton :: a -> Some a

22+singleton x = One x

23+

24+{-# INLINE top #-}

25+top :: Some a -> a

26+top (One x) = x

27+top (Tom x _) = x

28+

29+{-# INLINE lookupWith #-}

30+lookupWith :: (a -> Bool) -> Some a -> Maybe a

31+lookupWith f s = go s

32+ where

33+ go (One x)

34+ | f x = Just x

35+ | otherwise = Nothing

36+ go (Tom x xs)

37+ | f x = Just x

38+ | otherwise = go xs

39+

40+{-# INLINE union #-}

41+union :: Some a -> Some a -> Some a

42+union s t = go s t

43+ where

44+ go (One x) u = Tom x u

45+ go (Tom x xs) u = go xs (Tom x u)

46+

47+{-# INLINE toList #-}

48+toList :: Some a -> [a]

49+toList s = go s []

50+ where

51+ go (One x) !acc = x : acc

52+ go (Tom x xs) !acc = go xs (x : acc)

53+

54+{-# INLINE prune #-}

55+prune :: (a -> IO Bool) -> Some a -> IO (Maybe (Some a))

56+prune act s = go s

57+ where

58+ go (One x) = do

59+ keep <- act x

60+ return $ if keep then

61+ Just (One x)

62+ else

63+ Nothing

64+ go (Tom x xs) = do

65+ keep <- act x

66+ mys <- go xs

67+ return $ if keep then

68+ case mys of

69+ Nothing -> Just (One x)

70+ Just ys -> Just (Tom x ys)

71+ else

72+ mys

73+

time-manager/System/TimeManager.hs → warp/Network/Wai/Handler/Warp/Timeout.hsrenamed+7−4

@@ -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

@@ -26,8 +27,8 @@ import Control.Concurrent (myThreadId)

26import qualified Control.Exception as E

27import qualified Control.Exception as E

27import Control.Reaper

28import Control.Reaper

28import Data.Typeable (Typeable)

29import Data.Typeable (Typeable)

29−import Data.IORef (IORef)

30+import Network.Wai.Handler.Warp.IORef (IORef)

30−import qualified Data.IORef as I

31+import qualified Network.Wai.Handler.Warp.IORef as I

31

32

32----------------------------------------------------------------

33----------------------------------------------------------------

33

34

@@ -111,10 +112,12 @@ registerKillThread m onTimeout = do

111data TimeoutThread = TimeoutThread

112data TimeoutThread = TimeoutThread

112 deriving Typeable

113 deriving Typeable

113instance E.Exception TimeoutThread where

114instance E.Exception TimeoutThread where

115+#if MIN_VERSION_base(4,7,0)

114 toException = E.asyncExceptionToException

116 toException = E.asyncExceptionToException

115 fromException = E.asyncExceptionFromException

117 fromException = E.asyncExceptionFromException

118+#endif

116instance Show TimeoutThread where

119instance Show TimeoutThread where

117− show TimeoutThread = "Thread killed by timeout manager"

120+ show TimeoutThread = "Thread killed by Warp's timeout reaper"

118

121

119----------------------------------------------------------------

122----------------------------------------------------------------

120

123

warp/Network/Wai/Handler/Warp/Types.hs+33−28

@@ -5,18 +5,17 @@

5module Network.Wai.Handler.Warp.Types where

6

7import Control.Exception

8+import Data.ByteString (ByteString)

8import qualified Data.ByteString as S

9import qualified Data.ByteString as S

9import Data.IORef (IORef, readIORef, writeIORef, newIORef)

10import Data.IORef (IORef, readIORef, writeIORef, newIORef)

10import Data.Typeable (Typeable)

11import Data.Typeable (Typeable)

11−import Data.X509

12+import Data.Word (Word16, Word8)

12import Foreign.Ptr (Ptr)

13import Foreign.Ptr (Ptr)

13−import System.Posix.Types (Fd)

14−import qualified System.TimeManager as T

15−

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

19−import Network.Wai.Handler.Warp.Imports

17+import qualified Network.Wai.Handler.Warp.Timeout as T

18+import System.Posix.Types (Fd)

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)

132

114

133−setConnHTTP2 :: Connection -> Bool -> IO ()

115+type Hash = Int

134−setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b

135

116

136−----------------------------------------------------------------

117+

118+data InternalInfo0 =

119+ InternalInfo0 T.Manager

120+ (IO D.GMTDate)

121+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

122+ (Hash -> FilePath -> IO I.FileInfo)

123+

124+timeoutManager0 :: InternalInfo0 -> T.Manager

125+timeoutManager0 (InternalInfo0 tm _ _ _) = tm

126+

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/Network/Wai/Handler/Warp/Windows.hs+1−5

@@ -7,12 +7,8 @@ module Network.Wai.Handler.Warp.Windows

7import Control.Exception

8import Control.Concurrent.MVar

9import Control.Concurrent

10+import Control.Monad

10

11

11−import Network.Wai.Handler.Warp.Imports

12−

13−-- | Allow main socket listening thread to be interrupted on Windows platform

14−--

15−-- @since 3.2.17

16windowsThreadBlockHack :: IO a -> IO a

12windowsThreadBlockHack :: IO a -> IO a

17windowsThreadBlockHack act = do

13windowsThreadBlockHack act = do

18 var <- newEmptyMVar :: IO (MVar (Either SomeException a))

14 var <- newEmptyMVar :: IO (MVar (Either SomeException a))

warp/Network/Wai/Handler/Warp/WithApplication.hs+12−10

@@ -1,4 +1,4 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+

2module Network.Wai.Handler.Warp.WithApplication (

3 withApplication,

4 withApplicationSettings,

@@ -11,8 +11,6 @@ module Network.Wai.Handler.Warp.WithApplication (

11import Control.Concurrent

12import Control.Concurrent.Async

13import Control.Exception

14−import Control.Monad (when)

15−import Data.Streaming.Network (bindRandomPortTCP)

16import Network.Socket

14import Network.Socket

17import Network.Wai

15import Network.Wai

18import Network.Wai.Handler.Warp.Run

16import Network.Wai.Handler.Warp.Run

@@ -68,16 +66,14 @@ testWithApplication = testWithApplicationSettings defaultSettings

68--

66--

69-- @since 3.2.7

67-- @since 3.2.7

70testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

68testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

71−testWithApplicationSettings settings mkApp action = do

69+testWithApplicationSettings _settings mkApp action = do

72 callingThread <- myThreadId

70 callingThread <- myThreadId

73 app <- mkApp

71 app <- mkApp

74 let wrappedApp request respond =

72 let wrappedApp request respond =

75 app request respond `catch` \ e -> do

73 app request respond `catch` \ e -> do

76− when

77− (defaultShouldDisplayException e)

78− (throwTo callingThread e)

74+ throwTo callingThread (e :: SomeException)

79 throwIO e

75 throwIO e

80− withApplicationSettings settings (return wrappedApp) action

76+ withApplication (return wrappedApp) action

81

77

82data Waiter a

78data Waiter a

83 = Waiter {

79 = Waiter {

@@ -88,7 +84,7 @@ data Waiter a

88mkWaiter :: IO (Waiter a)

84mkWaiter :: IO (Waiter a)

89mkWaiter = do

85mkWaiter = do

90 mvar <- newEmptyMVar

86 mvar <- newEmptyMVar

91− return Waiter {

87+ return $ Waiter {

92 notify = putMVar mvar,

88 notify = putMVar mvar,

93 waitFor = readMVar mvar

89 waitFor = readMVar mvar

94 }

90 }

@@ -97,7 +93,13 @@ mkWaiter = do

97--

93--

98-- @since 3.2.4

94-- @since 3.2.4

99openFreePort :: IO (Port, Socket)

95openFreePort :: IO (Port, Socket)

100−openFreePort = bindRandomPortTCP "127.0.0.1"

96+openFreePort = do

97+ s <- socket AF_INET Stream defaultProtocol

98+ localhost <- inet_addr "127.0.0.1"

99+ bind s (SockAddrInet aNY_PORT localhost)

100+ listen s 1

101+ port <- socketPort s

102+ return (fromIntegral port, s)

101

103

102-- | Like 'openFreePort' but closes the socket before exiting.

104-- | Like 'openFreePort' but closes the socket before exiting.

103withFreePort :: ((Port, Socket) -> IO a) -> IO a

105withFreePort :: ((Port, Socket) -> IO a) -> IO a

warp/bench/Parser.hs+10−15

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

4

3

@@ -19,11 +18,7 @@ import Foreign.ForeignPtr

19import Foreign.Ptr

18import Foreign.Ptr

20import Foreign.Storable

19import Foreign.Storable

21

20

22−#if MIN_VERSION_gauge(0, 2, 0)

23−import Gauge

21+import Criterion.Main

24−#else

25−import Gauge.Main

26−#endif

27

22

28-- $setup

23-- $setup

29-- >>> :set -XOverloadedStrings

24-- >>> :set -XOverloadedStrings

@@ -68,15 +63,15 @@ parseRequestLine3 :: ByteString

68 ,H.HttpVersion)

63 ,H.HttpVersion)

69parseRequestLine3 requestLine = ret

64parseRequestLine3 requestLine = ret

70 where

65 where

71− (!method,!rest) = S.break (== 32) requestLine -- ' '

66+ (!method,!rest) = S.breakByte 32 requestLine -- ' '

72 (!pathQuery,!httpVer')

67 (!pathQuery,!httpVer')

73 | rest == "" = throw badmsg

68 | rest == "" = throw badmsg

74− | otherwise = S.break (== 32) (S.drop 1 rest) -- ' '

69+ | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' '

75− (!path,!query) = S.break (== 63) pathQuery -- '?'

70+ (!path,!query) = S.breakByte 63 pathQuery -- '?'

76 !httpVer = S.drop 1 httpVer'

71 !httpVer = S.drop 1 httpVer'

77 (!http,!ver)

72 (!http,!ver)

78 | httpVer == "" = throw badmsg

73 | httpVer == "" = throw badmsg

79− | otherwise = S.break (== 47) httpVer -- '/'

74+ | otherwise = S.breakByte 47 httpVer -- '/'

80 !hv | http /= "HTTP" = throw NonHttp

75 !hv | http /= "HTTP" = throw NonHttp

81 | ver == "/1.1" = H.http11

76 | ver == "/1.1" = H.http11

82 | otherwise = H.http10

77 | otherwise = H.http10

@@ -174,13 +169,13 @@ parseRequestLine1 :: ByteString

174 ,ByteString -- Query

169 ,ByteString -- Query

175 ,H.HttpVersion)

170 ,H.HttpVersion)

176parseRequestLine1 requestLine = do

171parseRequestLine1 requestLine = do

177− let (!method,!rest) = S.break (== 32) requestLine -- ' '

172+ let (!method,!rest) = S.breakByte 32 requestLine -- ' '

178− (!pathQuery,!httpVer') = S.break (== 32) (S.drop 1 rest) -- ' '

173+ (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' '

179 !httpVer = S.drop 1 httpVer'

174 !httpVer = S.drop 1 httpVer'

180 when (rest == "" || httpVer == "") $

175 when (rest == "" || httpVer == "") $

181 throwIO $ BadFirstLine $ B.unpack requestLine

176 throwIO $ BadFirstLine $ B.unpack requestLine

182− let (!path,!query) = S.break (== 63) pathQuery -- '?'

177+ let (!path,!query) = S.breakByte 63 pathQuery -- '?'

183− (!http,!ver) = S.break (== 47) httpVer -- '/'

178+ (!http,!ver) = S.breakByte 47 httpVer -- '/'

184 when (http /= "HTTP") $ throwIO NonHttp

179 when (http /= "HTTP") $ throwIO NonHttp

185 let !hv | ver == "/1.1" = H.http11

180 let !hv | ver == "/1.1" = H.http11

186 | otherwise = H.http10

181 | otherwise = H.http10

@@ -210,7 +205,7 @@ parseRequestLine0 s =

210 !http' = S.concat http''

205 !http' = S.concat http''

211 (!hfirst, !hsecond) = S.splitAt 5 http'

206 (!hfirst, !hsecond) = S.splitAt 5 http'

212 if hfirst == "HTTP/"

207 if hfirst == "HTTP/"

213− then let (!rpath, !qstring) = S.break (== 63) query -- '?'

208+ then let (!rpath, !qstring) = S.breakByte 63 query -- '?'

214 !hv =

209 !hv =

215 case hsecond of

210 case hsecond of

216 "1.1" -> H.http11

211 "1.1" -> H.http11

warp/test/ExceptionSpec.hs+11−11

@@ -7,7 +7,7 @@ import Control.Applicative

7#endif

8import Control.Monad

9import Network.HTTP.Types hiding (Header)

10−import Network.Wai hiding (Response, responseStatus)

10+import Network.Wai hiding (Response)

11import Network.Wai.Internal (Request(..))

12import Network.Wai.Handler.Warp

13import Test.Hspec

@@ -49,18 +49,18 @@ spec :: Spec

49spec = describe "responds even if there is an exception" $ do

50 {- Disabling these tests. We can consider forcing evaluation in Warp.

51 it "statusError" $ do

52− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"

52+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError"

53− sc `shouldBe` internalServerError500

53+ sc `shouldBe` (5,0,0)

54 it "headersError" $ do

55− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"

55+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError"

56− sc `shouldBe` internalServerError500

56+ sc `shouldBe` (5,0,0)

57 it "headerError" $ do

58− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"

58+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError"

59− sc `shouldBe` internalServerError500

59+ sc `shouldBe` (5,0,0)

60 it "bodyError" $ do

61− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"

61+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError"

62− sc `shouldBe` internalServerError500

62+ sc `shouldBe` (5,0,0)

63 -}

64 it "ioException" $ withTestServer $ \prt -> do

65− sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

65+ sc <- rspCode <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

66− sc `shouldBe` internalServerError500

66+ sc `shouldBe` (5,0,0)

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/HTTP.hs+28−26

@@ -1,41 +1,43 @@

1+{-# LANGUAGE StandaloneDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

1module HTTP (

3module HTTP (

2 sendGET

4 sendGET

3 , sendGETwH

5 , sendGETwH

4 , sendHEAD

6 , sendHEAD

5 , sendHEADwH

7 , sendHEADwH

6− , responseBody

8+ , rspBody

7− , responseStatus

9+ , rspCode

8− , responseHeaders

10+ , rspHeaders

9 , getHeaderValue

11 , getHeaderValue

10− , HeaderName

12+ , HeaderName(..)

13+ , mkHeader

11 ) where

14 ) where

12

15

13−import Network.HTTP.Client

16+import Network.HTTP

14−import Network.HTTP.Types

17+import Network.Stream

15−import Data.ByteString

16−import qualified Data.ByteString.Lazy as BL

17

18

18−sendGET :: String -> IO (Response BL.ByteString)

19+sendGET :: String -> IO (Response String)

19sendGET url = sendGETwH url []

20sendGET url = sendGETwH url []

20

21

21−sendGETwH :: String -> [Header] -> IO (Response BL.ByteString)

22+sendGETwH :: String -> [Header] -> IO (Response String)

22−sendGETwH url hdr = do

23+sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }

23− manager <- newManager defaultManagerSettings

24− request <- parseRequest url

25− let request' = request { requestHeaders = hdr }

26− response <- httpLbs request' manager

27− return response

28

24

29−sendHEAD :: String -> IO (Response BL.ByteString)

25+sendHEAD :: String -> IO (Response String)

30sendHEAD url = sendHEADwH url []

26sendHEAD url = sendHEADwH url []

31

27

32−sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString)

28+sendHEADwH :: String -> [Header] -> IO (Response String)

33−sendHEADwH url hdr = do

29+sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr }

34− manager <- newManager defaultManagerSettings

35− request <- parseRequest url

36− let request' = request { requestHeaders = hdr, method = methodHead }

37− response <- httpLbs request' manager

38− return response

39

30

31+unResult :: IO (Result (Response String)) -> IO (Response String)

32+unResult action = do

33+ res <- action

34+ case res of

35+ Right rsp -> return rsp

36+ Left _ -> error "Connection error"

37+

40−getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString

38+getHeaderValue :: HasHeaders a => HeaderName -> a -> Maybe String

41−getHeaderValue = lookup

39+getHeaderValue key r = case retrieveHeaders key r of

40+ [] -> Nothing

41+ x:_ -> Just $ hdrValue x

42+

43+deriving instance Eq Header

warp/test/RequestSpec.hs+7−11

@@ -7,7 +7,6 @@ module RequestSpec (main, spec) where

7import Network.Wai.Handler.Warp.File (parseByteRanges)

8import Network.Wai.Handler.Warp.Request

9import Network.Wai.Handler.Warp.Types

10−import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings)

11import Test.Hspec

10import Test.Hspec

12import Test.Hspec.QuickCheck

11import Test.Hspec.QuickCheck

13import qualified Data.ByteString as S

12import qualified Data.ByteString as S

@@ -18,9 +17,6 @@ import Data.IORef

18main :: IO ()

17main :: IO ()

19main = hspec spec

18main = hspec spec

20

19

21−defaultMaxTotalHeaderLength :: Int

22−defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23−

24spec :: Spec

20spec :: Spec

25spec = do

21spec = do

26 describe "headerLines" $ do

22 describe "headerLines" $ do

@@ -67,29 +63,29 @@ spec = do

67 describe "headerLines" $ do

63 describe "headerLines" $ do

68 it "can handle a nomarl case" $ do

64 it "can handle a nomarl case" $ do

69 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

65 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

70− x <- headerLines defaultMaxTotalHeaderLength True src

66+ x <- headerLines True src

71 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

67 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

72

68

73 it "can handle a nasty case (1)" $ do

69 it "can handle a nasty case (1)" $ do

74 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

70 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

75− x <- headerLines defaultMaxTotalHeaderLength True src

71+ x <- headerLines True src

76 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

72 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

77

73

78 it "can handle a nasty case (1)" $ do

74 it "can handle a nasty case (1)" $ do

79 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

75 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

80− x <- headerLines defaultMaxTotalHeaderLength True src

76+ x <- headerLines True src

81 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

77 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

82

78

83 it "can handle a nasty case (1)" $ do

79 it "can handle a nasty case (1)" $ do

84 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

80 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

85− x <- headerLines defaultMaxTotalHeaderLength True src

81+ x <- headerLines True src

86 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

82 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

87

83

88 it "can handle an illegal case (1)" $ do

84 it "can handle an illegal case (1)" $ do

89 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

85 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

90− x <- headerLines defaultMaxTotalHeaderLength True src

86+ x <- headerLines True src

91 x `shouldBe` []

87 x `shouldBe` []

92− y <- headerLines defaultMaxTotalHeaderLength True src

88+ y <- headerLines True src

93 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

89 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

94

90

95 where

91 where

@@ -115,7 +111,7 @@ headerLinesList' orig = do

115 writeIORef ref z

111 writeIORef ref z

116 return y

112 return y

117 src' <- mkSource src

113 src' <- mkSource src

118− res <- headerLines defaultMaxTotalHeaderLength True src'

114+ res <- headerLines True src'

119 return (res, src')

115 return (res, src')

120

116

121consumeLen :: Int -> Source -> IO S8.ByteString

117consumeLen :: Int -> Source -> IO S8.ByteString

warp/test/ResponseHeaderSpec.hs+30−2

@@ -7,6 +7,9 @@ import qualified Network.HTTP.Types as H

7import Network.Wai.Handler.Warp.ResponseHeader

8import Network.Wai.Handler.Warp.Response

9import Network.Wai.Handler.Warp.Header

10+import Network.Wai.Handler.Warp.HTTP2.HPACK

11+import Network.HPACK

12+import Network.HPACK.Token

10import Test.Hspec

13import Test.Hspec

11

14

12main :: IO ()

15main :: IO ()

@@ -34,15 +37,40 @@ spec = do

34 let hdrs = [("Server","MyServer")]

37 let hdrs = [("Server","MyServer")]

35 rspidxhdr = indexResponseHeader hdrs

38 rspidxhdr = indexResponseHeader hdrs

36 addServer "" rspidxhdr hdrs `shouldBe` []

39 addServer "" rspidxhdr hdrs `shouldBe` []

40+ describe "addHeader" $ do

41+ it "adds Server if not exist" $ do

42+ let v = "MyServer"

43+ hdrs = []

44+ hdrs1 = [("Server",v)]

45+ (thl, vt) <- toHeaderTable hdrs

46+ (thl1, _) <- toHeaderTable hdrs1

47+ addHeader tokenServer v vt thl `shouldBe` thl1

48+ it "does not add Server if exists" $ do

49+ let v = "MyServer2"

50+ hdrs = [("Server","MyServer")]

51+ (thl, vt) <- toHeaderTable hdrs

52+ addHeader tokenServer v vt thl `shouldBe` thl

53+ it "does not add Server if empty" $ do

54+ let v = ""

55+ hdrs = []

56+ (thl, vt) <- toHeaderTable hdrs

57+ addHeader tokenServer v vt thl `shouldBe` thl

58+ it "deletes Server " $ do

59+ let v = ""

60+ hdrs = [("Server","MyServer")]

61+ hdrs1 = []

62+ (thl, vt) <- toHeaderTable hdrs

63+ (thl1, _) <- toHeaderTable hdrs1

64+ addHeader tokenServer v vt thl `shouldBe` thl1

37

65

38headers :: H.ResponseHeaders

66headers :: H.ResponseHeaders

39headers = [

67headers = [

40 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

68 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

41− , ("Content-Length", "151")

69+ , ("Content-Lenght", "151")

42 , ("Server", "Mighttpd/2.5.8")

70 , ("Server", "Mighttpd/2.5.8")

43 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

71 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

44 , ("Content-Type", "text/html")

72 , ("Content-Type", "text/html")

45 ]

73 ]

46

74

47composedHeader :: ByteString

75composedHeader :: ByteString

48−composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

76+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

warp/test/ResponseSpec.hs+23−15

@@ -6,13 +6,17 @@ import Control.Concurrent (threadDelay)

6import qualified Data.ByteString as S

7import qualified Data.ByteString.Char8 as S8

8import Data.Maybe (mapMaybe)

9+import Network (connectTo, PortID (PortNumber))

9import Network.HTTP.Types

10import Network.HTTP.Types

10−import Network.Wai hiding (responseHeaders)

11+import Network.Wai

11import Network.Wai.Handler.Warp

12import Network.Wai.Handler.Warp

12import Network.Wai.Handler.Warp.Response

13import Network.Wai.Handler.Warp.Response

13−import RunSpec (withApp, msWrite, msRead, withMySocket)

14+import RunSpec (withApp)

15+import System.IO (hClose, hFlush)

14import Test.Hspec

16import Test.Hspec

15

17

18+import HTTP

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" $ PortNumber $ fromIntegral 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" $ PortNumber $ fromIntegral 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)

@@ -63,15 +73,13 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ wit

63

73

64spec :: Spec

74spec :: Spec

65spec = do

75spec = do

66−{- http-client does not support this.

67 describe "preventing response splitting attack" $ do

76 describe "preventing response splitting attack" $ do

68 it "sanitizes header values" $ do

77 it "sanitizes header values" $ do

69 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

78 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

70 withApp defaultSettings app $ \port -> do

79 withApp defaultSettings app $ \port -> do

71 res <- sendGET $ "http://127.0.0.1:" ++ show port

80 res <- sendGET $ "http://127.0.0.1:" ++ show port

72− getHeaderValue "foo" (responseHeaders res) `shouldBe`

81+ getHeaderValue (HdrCustom "foo") res `shouldBe`

73 Just "foo bar" -- HTTP inserts two spaces for \r\n.

82 Just "foo bar" -- HTTP inserts two spaces for \r\n.

74−-}

75

83

76 describe "sanitizeHeaderValue" $ do

84 describe "sanitizeHeaderValue" $ do

77 it "doesn't alter valid multiline header values" $ do

85 it "doesn't alter valid multiline header values" $ do

@@ -83,7 +91,7 @@ spec = do

83 it "discards empty lines" $ do

91 it "discards empty lines" $ do

84 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

92 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

85

93

86− context "when sanitizing single occurrences of \n" $ do

94+ context "when sanitizing single occurences of \n" $ do

87 it "replaces \n with \r\n" $ do

95 it "replaces \n with \r\n" $ do

88 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

96 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

89

97

warp/test/RunSpec.hs+86−136

@@ -1,28 +1,29 @@

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) 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

17import qualified Data.ByteString.Lazy as L

18import qualified Data.IORef as I

19import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

20+import Network (connectTo, PortID (PortNumber))

20import Network.HTTP.Types

21import Network.HTTP.Types

21−import Network.Socket

22+import Network.Socket (close)

22import Network.Socket.ByteString (sendAll)

23import Network.Socket.ByteString (sendAll)

23−import Network.Wai hiding (responseHeaders)

24+import Network.Wai

24−import Network.Wai.Internal (getRequestBodyChunk)

25import Network.Wai.Handler.Warp

26+import System.IO (hFlush, hClose)

26import System.IO.Unsafe (unsafePerformIO)

27import System.IO.Unsafe (unsafePerformIO)

27import System.Timeout (timeout)

28import System.Timeout (timeout)

28import Test.Hspec

29import Test.Hspec

@@ -35,52 +36,6 @@ main = hspec spec

35type Counter = I.IORef (Either String Int)

36type Counter = I.IORef (Either String Int)

36type CounterApplication = Counter -> Application

37type CounterApplication = Counter -> Application

37

38

38−data MySocket = MySocket

39− { msSocket :: !Socket

40− , msBuffer :: !(I.IORef ByteString)

41− }

42−

43−msWrite :: MySocket -> ByteString -> IO ()

44−msWrite ms bs = sendAll (msSocket ms) bs

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−

84incr :: MonadIO m => Counter -> m ()

39incr :: MonadIO m => Counter -> m ()

85incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

40incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

86 ((case ecount of

41 ((case ecount of

@@ -92,7 +47,7 @@ err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

92

47

93readBody :: CounterApplication

48readBody :: CounterApplication

94readBody icount req f = do

49readBody icount req f = do

95− body <- consumeBody $ getRequestBodyChunk req

50+ body <- consumeBody $ requestBody req

96 case () of

51 case () of

97 ()

52 ()

98 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

53 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

@@ -113,8 +68,8 @@ ignoreBody icount req f = do

113

68

114doubleConnect :: CounterApplication

69doubleConnect :: CounterApplication

115doubleConnect icount req f = do

70doubleConnect icount req f = do

116− _ <- consumeBody $ getRequestBodyChunk req

71+ _ <- consumeBody $ requestBody req

117− _ <- consumeBody $ getRequestBodyChunk req

72+ _ <- consumeBody $ requestBody req

118 incr icount

73 incr icount

119 f $ responseLBS status200 [] "double connect"

74 f $ responseLBS status200 [] "double connect"

120

75

@@ -128,8 +83,8 @@ getPort = do

128 esocket <- try $ bindPortTCP port "127.0.0.1"

83 esocket <- try $ bindPortTCP port "127.0.0.1"

129 case esocket of

84 case esocket of

130 Left (_ :: IOException) -> RunSpec.getPort

85 Left (_ :: IOException) -> RunSpec.getPort

131− Right sock -> do

86+ Right socket -> do

132− close sock

87+ close socket

133 return port

88 return port

134

89

135withApp :: Settings -> Application -> (Int -> IO a) -> IO a

90withApp :: Settings -> Application -> (Int -> IO a) -> IO a

@@ -143,13 +98,7 @@ withApp settings app f = do

143 bracket

98 bracket

144 (forkIO $ runSettings settings' app `onException` putMVar baton ())

99 (forkIO $ runSettings settings' app `onException` putMVar baton ())

145 killThread

100 killThread

146− (const $ do

147− takeMVar baton

101+ (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

102

154runTest :: Int -- ^ expected number of requests

103runTest :: Int -- ^ expected number of requests

155 -> CounterApplication

104 -> CounterApplication

@@ -157,9 +106,10 @@ runTest :: Int -- ^ expected number of requests

157 -> IO ()

106 -> IO ()

158runTest expected app chunks = do

107runTest expected app chunks = do

159 ref <- I.newIORef (Right 0)

108 ref <- I.newIORef (Right 0)

160− withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

109+ withApp defaultSettings (app ref) $ \port -> do

110+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

161− forM_ chunks $ \chunk -> msWrite ms chunk

111+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle

162− _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

112+ _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096

163 res <- I.readIORef ref

113 res <- I.readIORef ref

164 case res of

114 case res of

165 Left s -> error s

115 Left s -> error s

@@ -174,9 +124,11 @@ runTerminateTest :: InvalidRequest

174runTerminateTest expected input = do

124runTerminateTest expected input = do

175 ref <- I.newIORef Nothing

125 ref <- I.newIORef Nothing

176 let onExc _ = I.writeIORef ref . Just

126 let onExc _ = I.writeIORef ref . Just

177− withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

127+ withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

178− msWrite ms input

128+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

179− msClose ms -- explicitly

129+ hPutStr handle input

130+ hFlush handle

131+ hClose handle

180 threadDelay 1000

132 threadDelay 1000

181 res <- I.readIORef ref

133 res <- I.readIORef ref

182 show res `shouldBe` show (Just expected)

134 show res `shouldBe` show (Just expected)

@@ -247,11 +199,14 @@ spec = do

247 let app req f = do

199 let app req f = do

248 liftIO $ I.writeIORef iheaders $ requestHeaders req

200 liftIO $ I.writeIORef iheaders $ requestHeaders req

249 f $ responseLBS status200 [] ""

201 f $ responseLBS status200 [] ""

250− withApp defaultSettings app $ withMySocket $ \ms -> do

202+ withApp defaultSettings app $ \port -> do

203+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

251 let input = S.concat

204 let input = S.concat

252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

205 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

253 ]

206 ]

254− msWrite ms input

207+ hPutStr handle input

208+ hFlush handle

209+ hClose handle

255 threadDelay 1000

210 threadDelay 1000

256 headers <- I.readIORef iheaders

211 headers <- I.readIORef iheaders

257 headers `shouldBe`

212 headers `shouldBe`

@@ -262,11 +217,14 @@ spec = do

262 let app req f = do

217 let app req f = do

263 liftIO $ I.writeIORef iheaders $ requestHeaders req

218 liftIO $ I.writeIORef iheaders $ requestHeaders req

264 f $ responseLBS status200 [] ""

219 f $ responseLBS status200 [] ""

265− withApp defaultSettings app $ withMySocket $ \ms -> do

220+ withApp defaultSettings app $ \port -> do

221+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

266 let input = S.concat

222 let input = S.concat

267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

223 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

268 ]

224 ]

269− msWrite ms input

225+ hPutStr handle input

226+ hFlush handle

227+ hClose handle

270 threadDelay 1000

228 threadDelay 1000

271 headers <- I.readIORef iheaders

229 headers <- I.readIORef iheaders

272 headers `shouldBe`

230 headers `shouldBe`

@@ -275,24 +233,23 @@ spec = do

275

233

276 describe "chunked bodies" $ do

234 describe "chunked bodies" $ do

277 it "works" $ do

235 it "works" $ do

278− countVar <- newTVarIO (0 :: Int)

279 ifront <- I.newIORef id

236 ifront <- I.newIORef id

280 let app req f = do

237 let app req f = do

281− bss <- consumeBody $ getRequestBodyChunk req

238+ bss <- consumeBody $ requestBody req

282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

239 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

283− atomically $ modifyTVar countVar (+ 1)

284 f $ responseLBS status200 [] ""

240 f $ responseLBS status200 [] ""

285− withApp defaultSettings app $ withMySocket $ \ms -> do

241+ withApp defaultSettings app $ \port -> do

242+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

286 let input = S.concat

243 let input = S.concat

287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

244 [ "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"

245 , "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"

246 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

290 , "b\r\nHello World\r\n0\r\n\r\n"

247 , "b\r\nHello World\r\n0\r\n\r\n"

291 ]

248 ]

292− msWrite ms input

249+ hPutStr handle input

293− atomically $ do

250+ hFlush handle

294− count <- readTVar countVar

251+ hClose handle

295− check $ count == 2

252+ threadDelay 1000

296 front <- I.readIORef ifront

253 front <- I.readIORef ifront

297 front [] `shouldBe`

254 front [] `shouldBe`

298 [ "Hello World\nBye"

255 [ "Hello World\nBye"

@@ -300,44 +257,38 @@ spec = do

300 ]

257 ]

301 it "lots of chunks" $ do

258 it "lots of chunks" $ do

302 ifront <- I.newIORef id

259 ifront <- I.newIORef id

303− countVar <- newTVarIO (0 :: Int)

304 let app req f = do

260 let app req f = do

305− bss <- consumeBody $ getRequestBodyChunk req

261+ bss <- consumeBody $ requestBody req

306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

262 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307− atomically $ modifyTVar countVar (+ 1)

308 f $ responseLBS status200 [] ""

263 f $ responseLBS status200 [] ""

309− withApp defaultSettings app $ withMySocket $ \ms -> do

264+ withApp defaultSettings app $ \port -> do

265+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

310 let input = concat $ replicate 2 $

266 let input = concat $ replicate 2 $

311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

267 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

312 (replicate 50 "5\r\n12345\r\n") ++

268 (replicate 50 "5\r\n12345\r\n") ++

313 ["0\r\n\r\n"]

269 ["0\r\n\r\n"]

314− mapM_ (msWrite ms) input

270+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input

315− atomically $ do

271+ hClose handle

316− count <- readTVar countVar

272+ threadDelay 100000 -- FIXME why does this delay need to be so high?

317− check $ count == 2

318 front <- I.readIORef ifront

273 front <- I.readIORef ifront

319 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

274 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

275 it "in chunks" $ do

323 ifront <- I.newIORef id

276 ifront <- I.newIORef id

324− countVar <- newTVarIO (0 :: Int)

325 let app req f = do

277 let app req f = do

326− bss <- consumeBody $ getRequestBodyChunk req

278+ bss <- consumeBody $ requestBody req

327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

279 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

328− atomically $ modifyTVar countVar (+ 1)

329 f $ responseLBS status200 [] ""

280 f $ responseLBS status200 [] ""

330− withApp defaultSettings app $ withMySocket $ \ms -> do

281+ withApp defaultSettings app $ \port -> do

282+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

331 let input = S.concat

283 let input = S.concat

332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

284 [ "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"

285 , "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"

286 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

335 , "b\r\nHello World\r\n0\r\n\r\n"

287 , "b\r\nHello World\r\n0\r\n\r\n"

336 ]

288 ]

337− mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

289+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input

338− atomically $ do

290+ hClose handle

339− count <- readTVar countVar

291+ threadDelay 1000

340− check $ count == 2

341 front <- I.readIORef ifront

292 front <- I.readIORef ifront

342 front [] `shouldBe`

293 front [] `shouldBe`

343 [ "Hello World\nBye"

294 [ "Hello World\nBye"

@@ -346,7 +297,7 @@ spec = do

346 it "timeout in request body" $ do

297 it "timeout in request body" $ do

347 ifront <- I.newIORef id

298 ifront <- I.newIORef id

348 let app req f = do

299 let app req f = do

349− bss <- (consumeBody $ getRequestBodyChunk req) `onException`

300+ bss <- (consumeBody $ requestBody req) `onException`

350 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

301 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

351 liftIO $ threadDelay 4000000 `E.catch` \e -> do

302 liftIO $ threadDelay 4000000 `E.catch` \e -> do

352 I.atomicModifyIORef ifront (\front ->

303 I.atomicModifyIORef ifront (\front ->

@@ -355,18 +306,20 @@ spec = do

355 E.throwIO (e :: E.SomeException)

306 E.throwIO (e :: E.SomeException)

356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

357 f $ responseLBS status200 [] ""

308 f $ responseLBS status200 [] ""

358− withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

309+ withApp (setTimeout 1 defaultSettings) app $ \port -> do

359 let bs1 = S.replicate 2048 88

310 let bs1 = S.replicate 2048 88

360 bs2 = "This is short"

311 bs2 = "This is short"

361 bs = S.append bs1 bs2

312 bs = S.append bs1 bs2

313+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

362− msWrite ms "POST / HTTP/1.1\r\n"

314+ hPutStr handle "POST / HTTP/1.1\r\n"

363− msWrite ms "content-length: "

315+ hPutStr handle "content-length: "

364− msWrite ms $ S8.pack $ show $ S.length bs

316+ hPutStr handle $ S8.pack $ show $ S.length bs

365− msWrite ms "\r\n\r\n"

317+ hPutStr handle "\r\n\r\n"

366 threadDelay 100000

318 threadDelay 100000

367− msWrite ms bs1

319+ hPutStr handle bs1

368 threadDelay 100000

320 threadDelay 100000

369− msWrite ms bs2

321+ hPutStr handle bs2

322+ hClose handle

370 threadDelay 5000000

323 threadDelay 5000000

371 front <- I.readIORef ifront

324 front <- I.readIORef ifront

372 S.concat (front []) `shouldBe` bs

325 S.concat (front []) `shouldBe` bs

@@ -382,42 +335,39 @@ spec = do

382 loop

335 loop

383 loop

336 loop

384 doubleBS = S.concatMap $ \w -> S.pack [w, w]

337 doubleBS = S.concatMap $ \w -> S.pack [w, w]

385− withApp defaultSettings app $ withMySocket $ \ms -> do

338+ withApp defaultSettings app $ \port -> do

339+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

386− msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

340+ hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"

341+ hFlush handle

387− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

342+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")

388− msWrite ms "67890"

343+ hPutStr handle "67890"

344+ hFlush handle

389− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")

345+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")

346+

390 it "only one date and server header" $ do

347 it "only one date and server header" $ do

391 let app _ f = f $ responseLBS status200

348 let app _ f = f $ responseLBS status200

392 [ ("server", "server")

349 [ ("server", "server")

393 , ("date", "date")

350 , ("date", "date")

394 ] ""

351 ] ""

395− getValues key = map snd

396− . filter (\(key', _) -> key == key')

397− . responseHeaders

398 withApp defaultSettings app $ \port -> do

352 withApp defaultSettings app $ \port -> do

399 res <- sendGET $ "http://127.0.0.1:" ++ show port

353 res <- sendGET $ "http://127.0.0.1:" ++ show port

400− getValues hServer res `shouldBe` ["server"]

354+ getHeaderValue HdrServer res `shouldBe` Just "server"

401− getValues hDate res `shouldBe` ["date"]

355+ getHeaderValue HdrDate res `shouldBe` Just "date"

402

356

403 it "streaming echo #249" $ do

357 it "streaming echo #249" $ do

404− countVar <- newTVarIO (0 :: Int)

405 let app req f = f $ responseStream status200 [] $ \write _ -> do

358 let app req f = f $ responseStream status200 [] $ \write _ -> do

406− let loop = do

359+ let loop = do

407− bs <- getRequestBodyChunk req

360+ bs <- requestBody req

408 unless (S.null bs) $ do

361 unless (S.null bs) $ do

409 write $ byteString bs

362 write $ byteString bs

410− atomically $ modifyTVar countVar (+ 1)

411 loop

363 loop

412− loop

364+ loop

413− withApp defaultSettings app $ withMySocket $ \ms -> do

365+ withApp defaultSettings app $ \port -> do

366+ (socket, _addr) <- getSocketTCP "127.0.0.1" port

414− msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

367+ sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

415 threadDelay 10000

368 threadDelay 10000

416− msWrite ms "5\r\nhello\r\n0\r\n\r\n"

369+ sendAll socket "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

370+ bs <- safeRecv socket 4096

421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

371 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

422

372

423 it "streaming response with length" $ do

373 it "streaming response with length" $ do

@@ -425,7 +375,7 @@ spec = do

425 replicateM_ 4 $ write $ byteString "Hello"

375 replicateM_ 4 $ write $ byteString "Hello"

426 withApp defaultSettings app $ \port -> do

376 withApp defaultSettings app $ \port -> do

427 res <- sendGET $ "http://127.0.0.1:" ++ show port

377 res <- sendGET $ "http://127.0.0.1:" ++ show port

428− responseBody res `shouldBe` "HelloHelloHelloHello"

378+ rspBody res `shouldBe` "HelloHelloHelloHello"

429

379

430 describe "head requests" $ do

380 describe "head requests" $ do

431 let fp = "test/head-response"

381 let fp = "test/head-response"

@@ -438,19 +388,19 @@ spec = do

438 _ -> error "invalid path"

388 _ -> error "invalid path"

439 it "builder" $ withApp defaultSettings app $ \port -> do

389 it "builder" $ withApp defaultSettings app $ \port -> do

440 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

390 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

441− responseBody res `shouldBe` ""

391+ rspBody res `shouldBe` ""

442 it "streaming" $ withApp defaultSettings app $ \port -> do

392 it "streaming" $ withApp defaultSettings app $ \port -> do

443 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

393 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

444− responseBody res `shouldBe` ""

394+ rspBody res `shouldBe` ""

445 it "file, no range" $ withApp defaultSettings app $ \port -> do

395 it "file, no range" $ withApp defaultSettings app $ \port -> do

446 bs <- S.readFile fp

396 bs <- S.readFile fp

447 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

397 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

448− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs)

398+ getHeaderValue HdrContentLength res `shouldBe` Just (show $ S.length bs)

449 it "file, with range" $ withApp defaultSettings app $ \port -> do

399 it "file, with range" $ withApp defaultSettings app $ \port -> do

450 res <- sendHEADwH

400 res <- sendHEADwH

451 (concat ["http://127.0.0.1:", show port, "/file"])

401 (concat ["http://127.0.0.1:", show port, "/file"])

452− [(hRange, "bytes=0-1")]

402+ [mkHeader HdrRange "bytes=0-1"]

453− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2"

403+ getHeaderValue HdrContentLength res `shouldBe` Just "2"

454

404

455consumeBody :: IO ByteString -> IO [ByteString]

405consumeBody :: IO ByteString -> IO [ByteString]

456consumeBody body =

406consumeBody body =

warp/test/WithApplicationSpec.hs+16−16

@@ -2,10 +2,13 @@

2

3module WithApplicationSpec where

4

5+import Control.Concurrent

5import Control.Exception

6import Control.Exception

6import Network.HTTP.Types

7import Network.HTTP.Types

8+import Network.Socket

7import Network.Wai

9import Network.Wai

8−import System.Environment

10+import System.IO

11+import System.IO.Silently

9import System.Process

12import System.Process

10import Test.Hspec

13import Test.Hspec

11

14

@@ -13,9 +16,6 @@ import Network.Wai.Handler.Warp.WithApplication

13

16

14spec :: Spec

17spec :: Spec

15spec = do

18spec = do

16− runIO $ do

17− unsetEnv "http_proxy"

18− unsetEnv "https_proxy"

19 describe "withApplication" $ do

20 it "runs a wai Application while executing the given action" $ do

21 let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"

@@ -23,23 +23,23 @@ spec = do

23 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

24 output `shouldBe` "foo"

25

26− it "does not propagate exceptions from the server to the executing thread" $ do

26+ it "does not propagate exceptions from the server to the executing thread" $

27+ hSilence [stderr] $ do

27− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

28+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

28− withApplication mkApp $ \ port -> do

29+ withApplication mkApp $ \ port -> do

29− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

30+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

30− output `shouldContain` "Something went wron"

31+ output `shouldContain` "Something went wron"

31

32

32 describe "testWithApplication" $ do

33 describe "testWithApplication" $ do

33− it "propagates exceptions from the server to the executing thread" $ do

34+ it "propagates exceptions from the server to the executing thread" $

35+ hSilence [stderr] $ do

34− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

36+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

35− (testWithApplication mkApp $ \ port -> do

37+ (testWithApplication mkApp $ \ port -> do

36− readProcess "curl" ["-s", "localhost:" ++ show port] "")

38+ readProcess "curl" ["-s", "localhost:" ++ show port] "")

37− `shouldThrow` (errorCall "foo")

39+ `shouldThrow` (errorCall "foo")

38

40

39−{- The future netwrok library will not export MkSocket.

40 describe "withFreePort" $ do

41 describe "withFreePort" $ do

41 it "closes the socket before exiting" $ do

42 it "closes the socket before exiting" $ do

42 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

43 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

43 return sock

44 return sock

44 readMVar statusMVar `shouldReturn` Closed

45 readMVar statusMVar `shouldReturn` Closed

45−-}

warp/warp.cabal+51−113

@@ -1,5 +1,5 @@

1Name: warp

2−Version: 3.3.9

2+Version: 3.2.13

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)

@@ -33,32 +33,29 @@ Flag warp-debug

33 Default: False

34

35Library

36− Build-Depends: base >= 4.8 && < 5

36+ Build-Depends: base >= 3 && < 5

37 , array

38 , async

39 , auto-update >= 0.1.3 && < 0.2

40− , bsb-http-chunked < 0.1

40+ , blaze-builder >= 0.4

41 , bytestring >= 0.9.1.4

42+ , bytestring-builder

42 , case-insensitive >= 0.2

43 , case-insensitive >= 0.2

43 , containers

44 , containers

44 , ghc-prim

45 , ghc-prim

45− , hashable

46− , http-date

47− , http-types >= 0.12

46+ , http-types >= 0.9.1

48− , http2 >= 2.0 && < 2.1

49 , iproute >= 1.3.1

47 , iproute >= 1.3.1

48+ , http2 >= 1.6 && < 1.7

50 , simple-sendfile >= 0.2.7 && < 0.3

49 , 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

50 , unix-compat >= 0.2

56− , vault >= 0.3

57 , wai >= 3.2 && < 3.3

51 , wai >= 3.2 && < 3.3

52+ , text

53+ , streaming-commons >= 0.1.10

54+ , vault >= 0.3

55+ , stm >= 2.3

58 , word8

56 , word8

59− , x509

57+ , hashable

60− if impl(ghc < 8)

58+ , http-date

61− Build-Depends: semigroups

62 if flag(network-bytestring)

59 if flag(network-bytestring)

63 Build-Depends: network >= 2.2.1.5 && < 2.2.3

60 Build-Depends: network >= 2.2.1.5 && < 2.2.3

64 , network-bytestring >= 0.1.3 && < 0.1.4

61 , network-bytestring >= 0.1.3 && < 0.1.4

@@ -75,14 +72,18 @@ Library

75 Network.Wai.Handler.Warp.FileInfoCache

72 Network.Wai.Handler.Warp.FileInfoCache

76 Network.Wai.Handler.Warp.HashMap

73 Network.Wai.Handler.Warp.HashMap

77 Network.Wai.Handler.Warp.HTTP2

74 Network.Wai.Handler.Warp.HTTP2

75+ Network.Wai.Handler.Warp.HTTP2.EncodeFrame

78 Network.Wai.Handler.Warp.HTTP2.File

76 Network.Wai.Handler.Warp.HTTP2.File

79− Network.Wai.Handler.Warp.HTTP2.PushPromise

77+ Network.Wai.Handler.Warp.HTTP2.HPACK

78+ Network.Wai.Handler.Warp.HTTP2.Manager

79+ Network.Wai.Handler.Warp.HTTP2.Receiver

80 Network.Wai.Handler.Warp.HTTP2.Request

81− Network.Wai.Handler.Warp.HTTP2.Response

81+ Network.Wai.Handler.Warp.HTTP2.Sender

82 Network.Wai.Handler.Warp.HTTP2.Types

83+ Network.Wai.Handler.Warp.HTTP2.Worker

83 Network.Wai.Handler.Warp.Header

84 Network.Wai.Handler.Warp.Header

84 Network.Wai.Handler.Warp.IO

85 Network.Wai.Handler.Warp.IO

85− Network.Wai.Handler.Warp.Imports

86+ Network.Wai.Handler.Warp.IORef

86 Network.Wai.Handler.Warp.PackInt

87 Network.Wai.Handler.Warp.PackInt

87 Network.Wai.Handler.Warp.ReadInt

88 Network.Wai.Handler.Warp.ReadInt

88 Network.Wai.Handler.Warp.Recv

89 Network.Wai.Handler.Warp.Recv

@@ -93,6 +94,8 @@ Library

93 Network.Wai.Handler.Warp.Run

94 Network.Wai.Handler.Warp.Run

94 Network.Wai.Handler.Warp.SendFile

95 Network.Wai.Handler.Warp.SendFile

95 Network.Wai.Handler.Warp.Settings

96 Network.Wai.Handler.Warp.Settings

97+ Network.Wai.Handler.Warp.Some

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

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

@@ -142,128 +136,72 @@ Test-Suite spec

142 SendFileSpec

136 SendFileSpec

143 WithApplicationSpec

137 WithApplicationSpec

144 HTTP

138 HTTP

145− Network.Wai.Handler.Warp

146− Network.Wai.Handler.Warp.Buffer

147− Network.Wai.Handler.Warp.Conduit

148− Network.Wai.Handler.Warp.Counter

149− Network.Wai.Handler.Warp.Date

150− Network.Wai.Handler.Warp.FdCache

151− Network.Wai.Handler.Warp.File

152− Network.Wai.Handler.Warp.FileInfoCache

153− Network.Wai.Handler.Warp.HTTP2

154− Network.Wai.Handler.Warp.HTTP2.File

155− Network.Wai.Handler.Warp.HTTP2.PushPromise

156− Network.Wai.Handler.Warp.HTTP2.Request

157− Network.Wai.Handler.Warp.HTTP2.Response

158− Network.Wai.Handler.Warp.HTTP2.Types

159− Network.Wai.Handler.Warp.HashMap

160− Network.Wai.Handler.Warp.Header

161− Network.Wai.Handler.Warp.IO

162− Network.Wai.Handler.Warp.Imports

163− Network.Wai.Handler.Warp.MultiMap

164− Network.Wai.Handler.Warp.PackInt

165− Network.Wai.Handler.Warp.ReadInt

166− Network.Wai.Handler.Warp.Recv

167− Network.Wai.Handler.Warp.Request

168− Network.Wai.Handler.Warp.RequestHeader

169− Network.Wai.Handler.Warp.Response

170− Network.Wai.Handler.Warp.ResponseHeader

171− Network.Wai.Handler.Warp.Run

172− Network.Wai.Handler.Warp.SendFile

173− Network.Wai.Handler.Warp.Settings

174− Network.Wai.Handler.Warp.Types

175− Network.Wai.Handler.Warp.Windows

176− Network.Wai.Handler.Warp.WithApplication

177− Paths_warp

178−

179 Hs-Source-Dirs: test, .

139 Hs-Source-Dirs: test, .

180 Type: exitcode-stdio-1.0

140 Type: exitcode-stdio-1.0

181

141

182− Ghc-Options: -Wall -threaded

142+ Ghc-Options: -Wall

183− Build-Depends: base >= 4.8 && < 5

143+ Build-Depends: base >= 4 && < 5

184− , HUnit

185− , QuickCheck

186 , array

144 , array

187− , async

188 , auto-update

145 , auto-update

189− , bsb-http-chunked < 0.1

146+ , blaze-builder >= 0.4

190 , bytestring >= 0.9.1.4

147 , bytestring >= 0.9.1.4

148+ , bytestring-builder

191 , case-insensitive >= 0.2

149 , case-insensitive >= 0.2

192− , containers

193− , directory

194 , ghc-prim

150 , ghc-prim

195− , hashable

151+ , HTTP

196− , hspec >= 1.3

197− , http-client

198− , http-date

199− , http-types >= 0.12

152+ , http-types >= 0.8.5

200− , http2 >= 2.0 && < 2.1

201 , iproute >= 1.3.1

153 , iproute >= 1.3.1

202 , lifted-base >= 0.1

154 , lifted-base >= 0.1

203− , network

204− , process

205 , simple-sendfile >= 0.2.4 && < 0.3

155 , simple-sendfile >= 0.2.4 && < 0.3

206− , stm >= 2.3

156+ , transformers >= 0.2.2

207− , streaming-commons >= 0.1.10

208− , text

209− , time

210− , time-manager

211 , unix-compat >= 0.2

157 , unix-compat >= 0.2

212− , vault

213 , wai >= 3.2 && < 3.3

158 , wai >= 3.2 && < 3.3

159+ , network

160+ , HUnit

161+ , QuickCheck

162+ , hspec >= 1.3

163+ , time

164+ , text

165+ , streaming-commons >= 0.1.10

166+ , silently

167+ , async

168+ , vault

169+ , stm >= 2.3

170+ , directory

171+ , process

172+ , containers

173+ , http2 >= 1.6 && < 1.7

214 , word8

174 , word8

215− , x509

175+ , hashable

216− -- Build-Tool-Depends: hspec-discover:hspec-discover

176+ , http-date

217− if impl(ghc < 8)

218− Build-Depends: semigroups

219− , transformers

220

177

221 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

178 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

222 Cpp-Options: -DSENDFILEFD

179 Cpp-Options: -DSENDFILEFD

223 Build-Depends: unix

180 Build-Depends: unix

224 if os(windows)

181 if os(windows)

225− Cpp-Options: -DWINDOWS

182+ Cpp-Options: -DWINDOWS

226− Build-Depends: time

227− if impl(ghc >= 8)

228− Default-Extensions: Strict StrictData

229− Default-Language: Haskell2010

230

183

231Benchmark parser

184Benchmark parser

232 Type: exitcode-stdio-1.0

185 Type: exitcode-stdio-1.0

233 Main-Is: Parser.hs

186 Main-Is: Parser.hs

234− other-modules: Network.Wai.Handler.Warp.Date

235− Network.Wai.Handler.Warp.FdCache

236− Network.Wai.Handler.Warp.FileInfoCache

237− Network.Wai.Handler.Warp.HashMap

238− Network.Wai.Handler.Warp.Imports

239− Network.Wai.Handler.Warp.MultiMap

240− Network.Wai.Handler.Warp.Types

241 HS-Source-Dirs: bench .

187 HS-Source-Dirs: bench .

242− Build-Depends: base >= 4.8 && < 5

188+ Build-Depends: base

243 , auto-update

189 , auto-update

244 , bytestring

190 , bytestring

245 , containers

191 , containers

246− , gauge

192+ , criterion >= 1

247 , hashable

193 , hashable

248 , http-date

194 , http-date

249 , http-types

195 , http-types

250 , network

196 , network

251 , network

197 , network

252− , time-manager

253 , unix-compat

198 , unix-compat

254− , x509

255− if impl(ghc < 8)

256− Build-Depends: semigroups

257

199

258 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

200 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

259 Cpp-Options: -DSENDFILEFD

201 Cpp-Options: -DSENDFILEFD

260 Build-Depends: unix

202 Build-Depends: unix

261 if os(windows)

203 if os(windows)

262− Cpp-Options: -DWINDOWS

204+ Cpp-Options: -DWINDOWS

263− Build-Depends: time

264− if impl(ghc >= 8)

265− Default-Extensions: Strict StrictData

266− Default-Language: Haskell2010

267

205

268Source-Repository head

206Source-Repository head

269 Type: git

207 Type: git