d95518d...master · typeable/wai

.azure/azure-linux-template.ymlnew file+93

since splitsnapshots

unifiedsplit

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

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.ymlnew file+30

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

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.ymlnew file+30

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

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.ymlnew file+23

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

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.mdnew file+28

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

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.mdnew file+14

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

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,3 +8,5 @@ tarballs/

8.cabal-sandbox/

9cabal.sandbox.config

10.stack-work/

11+*~

12+stack*.yaml.lock

.travis.ymldeleted−219

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

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 --reorder-goals --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 --reorder-goals --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.mdnew file+94

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

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://travis-ci.org/yesodweb/wai.svg?branch=master)](https://travis-ci.org/yesodweb/wai)

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)

auto-update/ChangeLog.md+19

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

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+

1## 0.1.4

20## 0.1.4

2

21

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

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

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

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

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

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

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

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

14-- }

15-- }

15-- @

16-- @

16--

17--

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

25-- @since 0.1.2

26-- @since 0.1.2

26module Control.Debounce

27module Control.Debounce

27 ( -- * Type

28 ( -- * Type

28− DebounceSettings

29+ DI.DebounceSettings

29 , defaultDebounceSettings

30 , defaultDebounceSettings

30 -- * Accessors

31 -- * Accessors

31− , debounceFreq

32+ , DI.debounceFreq

32− , debounceAction

33+ , DI.debounceAction

34+ , DI.debounceEdge

35+ , DI.leadingEdge

36+ , DI.trailingEdge

33 -- * Creation

37 -- * Creation

34 , mkDebounce

38 , mkDebounce

35 ) where

39 ) where

36

40

37−import Control.Concurrent (forkIO, threadDelay)

41+import Control.Concurrent (newEmptyMVar, threadDelay)

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

42+import qualified Control.Debounce.Internal as DI

39−import Control.Exception (SomeException, handle, mask_)

40−import Control.Monad (forever, void)

41−

42−-- | Settings to control how debouncing should work.

43−--

44−-- This should be constructed using 'defaultDebounceSettings' and record

45−-- update syntax, e.g.:

46−--

47−-- @

48−-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }

49−-- @

50−--

51−-- @since 0.1.2

52−data DebounceSettings = DebounceSettings

53− { debounceFreq :: Int

54− -- ^ Microseconds lag required between subsequence calls to the debounced

55− -- action.

56− --

57− -- Default: 1 second (1000000)

58− --

59− -- @since 0.1.2

60− , debounceAction :: IO ()

61− -- ^ Action to be performed.

62− --

63− -- Note: all exceptions thrown by this action will be silently discarded.

64− --

65− -- Default: does nothing.

66− --

67− -- @since 0.1.2

68− }

69

43

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

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

71--

45--

72-- @since 0.1.2

46-- @since 0.1.2

73−defaultDebounceSettings :: DebounceSettings

47+defaultDebounceSettings :: DI.DebounceSettings

74−defaultDebounceSettings = DebounceSettings

48+defaultDebounceSettings = DI.DebounceSettings

75− { debounceFreq = 1000000

49+ { DI.debounceFreq = 1000000

76− , debounceAction = return ()

50+ , DI.debounceAction = return ()

51+ , DI.debounceEdge = DI.leadingEdge

77 }

52 }

78

53

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

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

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

81−-- current cooldown period has expired.

82--

55--

83-- @since 0.1.2

56-- @since 0.1.2

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

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

85−mkDebounce (DebounceSettings freq action) = do

58+mkDebounce settings = do

86− baton <- newEmptyMVar

59+ baton <- newEmptyMVar

87− mask_ $ void $ forkIO $ forever $ do

60+ DI.mkDebounceInternal baton threadDelay settings

88− takeMVar baton

89− ignoreExc action

90− threadDelay freq

91− return $ void $ tryPutMVar baton ()

92−

93−ignoreExc :: IO () -> IO ()

94−ignoreExc = handle $ \(_ :: SomeException) -> return ()

auto-update/Control/Debounce/Internal.hsnew file+98

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

1+{-# LANGUAGE ScopedTypeVariables #-}

2+

3+-- | Unstable API which exposes internals for testing.

4+module Control.Debounce.Internal (

5+ DebounceSettings(..)

6+ , DebounceEdge(..)

7+ , leadingEdge

8+ , trailingEdge

9+ , mkDebounceInternal

10+ ) where

11+

12+import Control.Concurrent (forkIO)

13+import Control.Concurrent.MVar (takeMVar, tryPutMVar, tryTakeMVar, MVar)

14+import Control.Exception (SomeException, handle, mask_)

15+import Control.Monad (forever, void)

16+

17+-- | Settings to control how debouncing should work.

18+--

19+-- This should be constructed using 'defaultDebounceSettings' and record

20+-- update syntax, e.g.:

21+--

22+-- @

23+-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }

24+-- @

25+--

26+-- @since 0.1.2

27+data DebounceSettings = DebounceSettings

28+ { debounceFreq :: Int

29+ -- ^ Length of the debounce timeout period in microseconds.

30+ --

31+ -- Default: 1 second (1000000)

32+ --

33+ -- @since 0.1.2

34+ , debounceAction :: IO ()

35+ -- ^ Action to be performed.

36+ --

37+ -- Note: all exceptions thrown by this action will be silently discarded.

38+ --

39+ -- Default: does nothing.

40+ --

41+ -- @since 0.1.2

42+ , debounceEdge :: DebounceEdge

43+ -- ^ Whether to perform the action on the leading edge or trailing edge of

44+ -- the timeout.

45+ --

46+ -- Default: 'trailingEdge'.

47+ --

48+ -- @since 0.1.6

49+ }

50+

51+-- | Setting to control whether the action happens at the leading and/or trailing

52+-- edge of the timeout.

53+--

54+-- @since 0.1.6

55+data DebounceEdge =

56+ Leading

57+ -- ^ Perform the action immediately, and then begin a cooldown period.

58+ -- If the trigger happens again during the cooldown, wait until the end of the cooldown

59+ -- and then perform the action again, then enter a new cooldown period.

60+ | Trailing

61+ -- ^ Start a cooldown period and perform the action when the period ends. If another trigger

62+ -- happens during the cooldown, it has no effect.

63+ deriving (Show, Eq)

64+

65+

66+-- | Perform the action immediately, and then begin a cooldown period.

67+-- If the trigger happens again during the cooldown, wait until the end of the cooldown

68+-- and then perform the action again, then enter a new cooldown period.

69+--

70+-- @since 0.1.6

71+leadingEdge :: DebounceEdge

72+leadingEdge = Leading

73+

74+-- | Start a cooldown period and perform the action when the period ends. If another trigger

75+-- happens during the cooldown, it has no effect.

76+--

77+-- @since 0.1.6

78+trailingEdge :: DebounceEdge

79+trailingEdge = Trailing

80+

81+mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())

82+mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do

83+ mask_ $ void $ forkIO $ forever $ do

84+ takeMVar baton

85+ case edge of

86+ Leading -> do

87+ ignoreExc action

88+ delayFn freq

89+ Trailing -> do

90+ delayFn freq

91+ -- Empty the baton of any other activations during the interval

92+ void $ tryTakeMVar baton

93+ ignoreExc action

94+

95+ return $ void $ tryPutMVar baton ()

96+

97+ignoreExc :: IO () -> IO ()

98+ignoreExc = handle $ \(_ :: SomeException) -> return ()

auto-update/Control/Reaper.hs+5−4

@@ -49,8 +49,9 @@ 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. For help with setting up such

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

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

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

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

54 --

55 --

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

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

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

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

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

112

113

113-- | State of reaper.

114-- | State of reaper.

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

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

115− | Workload workload -- ^ The current jobs

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

116

117

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

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

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

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

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

153 next <- atomicModifyIORef' stateRef cons

154 next <- atomicModifyIORef' stateRef cons

154 next

155 next

155 where

156 where

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

157+ cons NoReaper = let wl = reaperCons item reaperEmpty

157 in (Workload wl, spawn settings stateRef tidRef)

158 in (Workload wl, spawn settings stateRef tidRef)

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

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

159 in (Workload wl', return ())

160 in (Workload wl', return ())

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

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

1name: auto-update

2−version: 0.1.4

2+version: 0.1.6

3synopsis: Efficiently run periodic, on-demand actions

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

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

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

17 ghc-options: -Wall

18 exposed-modules: Control.AutoUpdate

19 Control.Debounce

20+ Control.Debounce.Internal

20 Control.Reaper

21 Control.Reaper

21 other-modules: Control.AutoUpdate.Util

22 other-modules: Control.AutoUpdate.Util

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

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

23 default-language: Haskell2010

24 default-language: Haskell2010

25+ if impl(ghc >= 8)

26+ default-extensions: Strict StrictData

24

27

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

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

26

29

27−-- test-suite spec

30+test-suite spec

28−-- main-is: Spec.hs

31+ main-is: Spec.hs

29−-- other-modules: Control.AutoUpdateSpec

32+ other-modules: Control.AutoUpdateSpec

33+ Control.DebounceSpec

30−-- Control.ReaperSpec

34+ Control.ReaperSpec

31−-- hs-source-dirs: test

35+ hs-source-dirs: test

32−-- type: exitcode-stdio-1.0

36+ type: exitcode-stdio-1.0

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

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

34−-- default-language: Haskell2010

38+ default-language: Haskell2010

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

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

1module Control.AutoUpdateSpec (spec) where

2

3−import Test.Hspec

3+import Control.AutoUpdate

4−import Test.Hspec.QuickCheck

5−import Data.IORef

6import Control.Concurrent (threadDelay)

4import Control.Concurrent (threadDelay)

7import Control.Monad (replicateM_, forM_)

5import Control.Monad (replicateM_, forM_)

8−import Control.AutoUpdate

6+import Data.IORef

7+import Test.Hspec

8+import Test.Hspec.QuickCheck

9

10spec :: Spec

11−spec = do

11+spec = return ()

12+ -- do

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

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

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

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

14− ref <- newIORef 0

15+ -- ref <- newIORef 0

15− next <- mkAutoUpdate defaultUpdateSettings

16+ -- next <- mkAutoUpdate defaultUpdateSettings

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

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

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

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

18− , updateSpawnThreshold = st

19+ -- , updateSpawnThreshold = st

19− , updateFreq = 10000

20+ -- , updateFreq = 10000

20− }

21+ -- }

21

22

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

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

23− j <- next

24+ -- j <- next

24− j `shouldBe` i

25+ -- j `shouldBe` i

25

26

26− replicateM_ 50 $ do

27+ -- replicateM_ 50 $ do

27− i <- next

28+ -- i <- next

28− i `shouldBe` st + 2

29+ -- i `shouldBe` st + 2

29

30

30− threadDelay 60000

31+ -- threadDelay 60000

31− last1 <- readIORef ref

32+ -- last1 <- readIORef ref

32− threadDelay 20000

33+ -- threadDelay 20000

33− last2 <- readIORef ref

34+ -- last2 <- readIORef ref

34− last2 `shouldBe` last1

35+ -- last2 `shouldBe` last1

auto-update/test/Control/DebounceSpec.hsnew file+120

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

1+{-# LANGUAGE ScopedTypeVariables #-}

2+module Control.DebounceSpec (spec) where

3+

4+import Control.Concurrent

5+import Control.Debounce

6+import qualified Control.Debounce.Internal as DI

7+import Control.Monad

8+import Control.Monad.Catch

9+import Control.Retry

10+import Data.IORef

11+import Test.HUnit.Lang

12+import Test.Hspec

13+

14+spec :: Spec

15+spec = describe "mkDebounce" $ do

16+ describe "Leading edge" $ do

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

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

19+

20+ debounced

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

22+

23+ returnFromWait

24+ pause

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

26+

27+ -- Try another round

28+ debounced

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

30+

31+ returnFromWait

32+ pause

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

34+

35+ it "works for multiple events" $ do

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

37+

38+ debounced

39+ waitForBatonToBeTaken baton

40+ debounced

41+ pause

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

43+

44+ returnFromWait

45+ pause

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

47+

48+ describe "Trailing edge" $ do

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

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

51+

52+ debounced

53+ pause

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

55+

56+ returnFromWait

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

58+

59+ -- Try another round

60+ debounced

61+ pause

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

63+

64+ returnFromWait

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

66+

67+ it "works for multiple events" $ do

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

69+

70+ debounced

71+ waitForBatonToBeTaken baton

72+ debounced

73+ pause

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

75+

76+ returnFromWait

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

78+

79+

80+-- | Make a controllable delay function

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

82+getWaitAction = do

83+ waitVar <- newEmptyMVar

84+ let waitAction _ = takeMVar waitVar

85+ let returnFromWait = putMVar waitVar ()

86+ return (waitAction, returnFromWait)

87+

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

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

90+getDebounce edge = do

91+ ref :: IORef Int <- newIORef 0

92+ let action = modifyIORef ref (+ 1)

93+

94+ (waitAction, returnFromWait) <- getWaitAction

95+

96+ baton <- newEmptyMVar

97+

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

99+ debounceFreq = 5000000 -- unused

100+ , debounceAction = action

101+ , debounceEdge = edge

102+ }

103+

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

105+

106+-- | Pause briefly (100ms)

107+pause :: IO ()

108+pause = threadDelay 100000

109+

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

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

112+

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

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

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

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

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

118+

119+main :: IO ()

120+main = hspec spec

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

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

1module Control.ReaperSpec (spec) where

2

3−import Control.Reaper

4import Control.Concurrent

3import Control.Concurrent

4+import Control.Reaper

5+import Data.IORef

5import Test.Hspec

6import Test.Hspec

6import Test.Hspec.QuickCheck

7import Test.Hspec.QuickCheck

7−import Data.IORef

8

9−type Item = (Int, IORef Int)

10−

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

12− modifyIORef ref succ

13− return $ if i > 1

14− then Just (pred i, ref)

15− else Nothing

16

9

17spec :: Spec

10spec :: Spec

11+spec = return ()

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

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

19− reaper <- mkReaper defaultReaperSettings

13+-- reaper <- mkReaper defaultReaperSettings

20− { reaperAction = action

14+-- { reaperAction = action

21− , reaperDelay = 1000

15+-- , reaperDelay = 1000

22− }

16+-- }

17+

18+-- let mkTestCase i = do

19+-- ref <- newIORef 0

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

21+-- reaperAdd reaper (expected, ref)

22+-- return (expected, ref)

23+-- testCases <- mapM mkTestCase is

24+

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

26+-- actual <- readIORef ref

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

28+-- threadDelay 100000

29+-- mapM_ test testCases

30+-- [] <- reaperRead reaper

31+-- return ()

23

32

24− let mkTestCase i = do

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

25− ref <- newIORef 0

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

27− reaperAdd reaper (expected, ref)

28− return (expected, ref)

29− testCases <- mapM mkTestCase is

30

34

31− let test (expected, ref) = do

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

32− actual <- readIORef ref

36+-- modifyIORef ref succ

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

34− threadDelay 100000

35− mapM_ test testCases

36− [] <- reaperRead reaper

37− return ()

37+-- return $ if i > 1

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

39+-- else Nothing

hcar-wai.texdeleted−52

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

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.texdeleted−28

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

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

1+## 0.1.0.9

2+

3+* Add mjs mime type

4+

5+## 0.1.0.8

6+

7+* Add wasm mime type

8+

1## 0.1.0.7

9## 0.1.0.7

2

10

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

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

mime-types/Network/Mime.hs+2

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1name: mime-types

2−version: 0.1.0.7

2+version: 0.1.0.9

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.txtdeleted−11

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

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.yamlnew file+27

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

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.yamlnew file+26

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

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.yamlnew file+20

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

1+resolver: nightly-2020-01-08

2+packages:

3+- ./auto-update

4+- ./mime-types

5+- ./wai

6+- ./wai-extra

7+- ./warp

8+- ./warp-tls

9+- ./wai-app-static

10+- ./wai-websockets

11+- ./wai-conduit

12+- ./time-manager

13+flags:

14+ wai-extra:

15+ build-example: true

16+nix:

17+ enable: false

18+ packages:

19+ - fcgi

20+ - zlib

stack.yaml+12−24

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

1−resolver: lts-4.1

1+resolver: lts-14.22

2packages:

3+- ./auto-update

4+- ./mime-types

3- ./wai

5- ./wai

4- ./wai-extra

6- ./wai-extra

5- ./warp

7- ./warp

6- ./warp-tls

8- ./warp-tls

7- ./wai-app-static

9- ./wai-app-static

8−- ./wai-handler-fastcgi

9−- ./wai-handler-launch

10- ./wai-websockets

11- ./wai-conduit

12−- ./mime-types

12+- ./time-manager

13−- ./auto-update

13+flags:

14−extra-deps:

14+ wai-extra:

15−- http2-1.6.0

15+ build-example: true

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

25−- tls-session-manager-0.0.0.1

26−- psqueues-0.2.3

27nix:

16nix:

28 enable: false

17 enable: false

29 packages:

18 packages:

30 - fcgi

19 - fcgi

31 - zlib

20 - zlib

32−image:

21+extra-deps:

33− containers:

22+- http2-2.0.0

34− - base: "fpco/pid1"

23+- network-byte-order-0.1.1.0

35− name: "yesodweb/warp"

24+- tls-1.5.3

36− executables:

25+- tls-session-manager-0.0.4

37− - warp

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

The content is the same.

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

3

2

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

3+module System.TimeManager (

5 -- ** Types

4 -- ** Types

6 Manager

5 Manager

7 , TimeoutAction

6 , TimeoutAction

@@ -27,8 +26,8 @@ import Control.Concurrent (myThreadId)

27import qualified Control.Exception as E

26import qualified Control.Exception as E

28import Control.Reaper

27import Control.Reaper

29import Data.Typeable (Typeable)

28import Data.Typeable (Typeable)

30−import Network.Wai.Handler.Warp.IORef (IORef)

29+import Data.IORef (IORef)

31−import qualified Network.Wai.Handler.Warp.IORef as I

30+import qualified Data.IORef as I

32

31

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

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

34

33

@@ -112,12 +111,10 @@ registerKillThread m onTimeout = do

112data TimeoutThread = TimeoutThread

111data TimeoutThread = TimeoutThread

113 deriving Typeable

112 deriving Typeable

114instance E.Exception TimeoutThread where

113instance E.Exception TimeoutThread where

115−#if MIN_VERSION_base(4,7,0)

116 toException = E.asyncExceptionToException

114 toException = E.asyncExceptionToException

117 fromException = E.asyncExceptionFromException

115 fromException = E.asyncExceptionFromException

118−#endif

119instance Show TimeoutThread where

116instance Show TimeoutThread where

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

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

121

118

122----------------------------------------------------------------

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

123

120

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

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

1+Name: time-manager

2+Version: 0.0.0

3+Synopsis: Scalable timer

4+License: MIT

5+License-file: LICENSE

6+Author: Michael Snoyman and Kazu Yamamoto

7+Maintainer: kazu@iij.ad.jp

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

9+Category: System

10+Build-Type: Simple

11+Cabal-Version: >=1.8

12+Stability: Stable

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

14+

15+Library

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

17+ , auto-update

18+ Exposed-modules: System.TimeManager

19+ Ghc-Options: -Wall

tls-session-manager/ChangeLog.mddeleted−2

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

1−# 0.0.0.0

2−- A first release.

tls-session-manager/LICENSEdeleted−29

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

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

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

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

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

1−import Distribution.Simple

2−main = defaultMain

tls-session-manager/tls-session-manager.cabaldeleted−26

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

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

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+

1## 3.1.6.1

21## 3.1.6.1

2

22

3* Add `<>` import

23* Add `<>` import

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

@@ -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 Blaze.ByteString.Builder (toByteString)

37+import Data.ByteString.Builder (toLazyByteString)

38

39import Data.FileEmbed (embedFile)

40

@@ -164,11 +164,13 @@ serveFile StaticSettings {..} req file

164 -- Didn't match, but we have a hash value. Send the file contents

165 -- with an ETag header.

166 --

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

167+ -- RFC7232 (HTTP 1.1):

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

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

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

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

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

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

171− -- new file being sent anyway.

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

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

173+ -- > If-None-Match.

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

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

173

175

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

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

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

243 response :: StaticResponse -> IO W.ResponseReceived

245 response :: StaticResponse -> IO W.ResponseReceived

244 response (FileResponse file ch) = do

246 response (FileResponse file ch) = do

245 mimetype <- ssGetMimeType ss file

247 mimetype <- ssGetMimeType ss file

246− let filesize = fileGetSize file

248+ -- let filesize = fileGetSize file

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

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

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

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

249 -- range requests into account

251 -- range requests into account

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

262 ] lbs

264 ] lbs

263

265

264 response (Redirect pieces' mHash) = do

266 response (Redirect pieces' mHash) = do

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

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

266 let qString = case mHash of

268 let qString = case mHash of

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

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

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

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

269

271

270− sendResponse $ W.responseLBS H.status301

272+ sendResponse $ W.responseLBS H.status302

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

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

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

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

273 ] "Redirect"

275 ] "Redirect"

274

276

275 response (RawRedirect path) =

277 response (RawRedirect path) =

276− sendResponse $ W.responseLBS H.status301

278+ sendResponse $ W.responseLBS H.status302

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

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

278 , ("Location", path)

280 , ("Location", path)

279 ] "Redirect"

281 ] "Redirect"

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

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

39 }

40

41#if MIN_VERSION_optparse_applicative(0, 10, 0)

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

42option' = option auto

43option' = option auto

43#else

44#else

44option' = option

45option' = option

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

93-- Since 2.0.1

94-- Since 2.0.1

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

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

95runCommandLine middleware = do

96runCommandLine middleware = do

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

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

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

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

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

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

99 docroot' <- canonicalizePath docroot

100 docroot' <- canonicalizePath docroot

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

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

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

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

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

112 }

113 }

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 Blaze.ByteString.Builder (fromByteString)

11+import Data.ByteString.Builder (byteString)

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 $ fromByteString bs

53+ , fileToResponse = \s h -> W.responseBuilder s h $ byteString 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 $ fromByteString bs

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

91 , fileName = name

92 , fileGetHash = return $ Just $ runHash bs

93 , fileGetModified = Nothing

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

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

5 , mkSettings

6) where

7

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

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

9import Codec.Compression.GZip (compress)

10−import Control.Applicative

11import Data.ByteString.Unsafe (unsafePackAddressLen)

10import Data.ByteString.Unsafe (unsafePackAddressLen)

12import Data.Either (lefts, rights)

11import Data.Either (lefts, rights)

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

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

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

130 let h' = if embCompressed entry

129 let h' = if embCompressed entry

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

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

132 else h

131 else h

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

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

134

133

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

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

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

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

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

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

1−{-# LANGUAGE OverloadedStrings #-}

2module WaiAppStatic.Types

1module WaiAppStatic.Types

3 ( -- * Pieces

2 ( -- * Pieces

4 Piece

3 Piece

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

25import Data.ByteString (ByteString)

24import Data.ByteString (ByteString)

26import System.Posix.Types (EpochTime)

25import System.Posix.Types (EpochTime)

27import qualified Data.Text as T

26import qualified Data.Text as T

28−import Blaze.ByteString.Builder (Builder)

27+import Data.ByteString.Builder (Builder)

29import Network.Mime (MimeType)

28import Network.Mime (MimeType)

30

29

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

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

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

60toPieces = mapM toPiece

59toPieces = mapM toPiece

61

60

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

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

62+--

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

63type Pieces = [Piece]

64type Pieces = [Piece]

64

65

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

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

wai-app-static/test/WaiAppStaticTest.hs+9−9

@@ -57,22 +57,22 @@ spec = do

57 assertStatus 200 =<<

58 request (setRawPathInfo defRequest path)

59

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

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

61 assertStatus 404 =<<

62 request (setRawPathInfo defRequest "doesNotExist")

63

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

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

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

66− assertStatus 301 req

66+ assertStatus 302 req

67 assertHeader "Location" "../../a/b/c" req

68

69 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {

70 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u

71 }

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

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

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

74 req <- request (setRawPathInfo defRequest path)

75− assertStatus 301 req

75+ assertStatus 302 req

76 assertHeader "Location" "http://www.example.com/a/b/c" req

77

78 describe "webApp when requesting a static asset" $ do

@@ -131,10 +131,10 @@ spec = do

131 assertStatus 304 req

132 assertNoHeader "Cache-Control" req

133

134− context "301 redirect to add a trailing slash on directories if missing" $ do

134+ context "302 redirect to add a trailing slash on directories if missing" $ do

135 it "works at the root" $ fileServerApp $ do

136 req <- request (setRawPathInfo defRequest "/a")

137− assertStatus 301 req

137+ assertStatus 302 req

138 assertHeader "Location" "/a/" req

139

140 it "works when an index.html is delivered" $ do

@@ -144,7 +144,7 @@ spec = do

144 inTempDirectory $ fileServerAppWithSettings settings $ do

145 liftIO $ touch "foo/index.html"

146 req <- request (setRawPathInfo defRequest "/foo")

147− assertStatus 301 req

147+ assertStatus 302 req

148 assertHeader "Location" "/foo/" req

149

150 let urlMapApp = flip runSession $ \req send ->

@@ -158,7 +158,7 @@ spec = do

158 "urlMapApp: only works at subPath"

159 it "works with subpath at the root of the file server" $ urlMapApp $ do

160 req <- request (setRawPathInfo defRequest "/subPath")

161− assertStatus 301 req

161+ assertStatus 302 req

162 assertHeader "Location" "/subPath/" req

163

164 context "with defaultWebAppSettings" $ do

wai-app-static/wai-app-static.cabal+5−6

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

1name: wai-app-static

2−version: 3.1.6.1

2+version: 3.1.7.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.9.1.4

30+ , bytestring >= 0.10.4

31 , http-types >= 0.7

32 , transformers >= 0.2.2

33 , unix-compat >= 0.2

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

41 , cryptonite >= 0.6

40 , cryptonite >= 0.6

42 , memory >= 0.7

41 , memory >= 0.7

43 , http-date

42 , http-date

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

50 , filepath

49 , filepath

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

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

52 , optparse-applicative >= 0.7

51 , optparse-applicative >= 0.7

53− , warp >= 3.0.11 && < 3.3

52+ , warp >= 3.0.11 && < 3.4

54

53

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

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

56 WaiAppStatic.Storage.Filesystem

55 WaiAppStatic.Storage.Filesystem

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

74 , wai-app-static

73 , wai-app-static

75 , directory >= 1.0

74 , directory >= 1.0

76 , containers >= 0.2

75 , containers >= 0.2

77− , bytestring >= 0.9.1.4

76+ , bytestring >= 0.10.4

78 , text >= 0.7

77 , text >= 0.7

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

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

80

79

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

103 , temporary

102 , temporary

104 , mockery

103 , mockery

105 -- , containers

104 -- , containers

106− ghc-options: -Wall

105+ ghc-options: -Wall

107

106

108source-repository head

107source-repository head

109 type: git

108 type: git

wai-conduit/ChangeLog.md+4

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

1+## 3.0.0.4

2+

3+* Drop dependency on blaze-builder

4+

1## 3.0.0.3

5## 3.0.0.3

2

6

3* Support wai 3.2

7* Support wai 3.2

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

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

16import qualified Data.ByteString as S

17import Control.Monad (unless)

18import Network.HTTP.Types

19−import Blaze.ByteString.Builder (Builder)

19+import Data.ByteString.Builder (Builder)

20−import Data.IORef

21import qualified Data.Conduit.List as CL

20import qualified Data.Conduit.List as CL

22

21

23-- | Stream the request body.

22-- | Stream the request body.

24--

23--

25-- Since 3.0.0

24-- Since 3.0.0

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

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

27sourceRequestBody req =

26sourceRequestBody req =

28 loop

27 loop

29 where

28 where

30− go = liftIO (requestBody req)

29+ go = liftIO (getRequestBodyChunk req)

31

30

32 loop = do

31 loop = do

33 bs <- go

32 bs <- go

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

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

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

39--

38--

40-- Since 3.0.0

39-- Since 3.0.0

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

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

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

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

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

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

44 case mbuilder of

43 case mbuilder of

45 Chunk b -> send b

44 Chunk b -> send b

46 Flush -> flush)

45 Flush -> flush)

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

50--

49--

51-- Since 3.0.0

50-- Since 3.0.0

52responseRawSource :: (MonadIO m, MonadIO n)

51responseRawSource :: (MonadIO m, MonadIO n)

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

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

54 -> Response

53 -> Response

55 -> Response

54 -> Response

56responseRawSource app =

55responseRawSource app =

wai-conduit/example/Main.hsnew file+19

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

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

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

1name: wai-conduit

2−version: 3.0.0.3

2+version: 3.0.0.4

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

18 , wai >= 3.0 && < 3.3

19 , conduit

20 , transformers

21− , bytestring

21+ , bytestring >= 0.10.4

22 , http-types

23− , blaze-builder

24 default-language: Haskell2010

23 default-language: Haskell2010

wai-extra/ChangeLog.md+76

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

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+

1## 3.0.20.0

77## 3.0.20.0

2

78

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

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

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

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

5 headers:

6

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

8+

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

8-}

10-}

9module Network.Wai.EventSource (

11module Network.Wai.EventSource (

10 ServerEvent(..),

12 ServerEvent(..),

11 eventSourceAppChan,

13 eventSourceAppChan,

12− eventSourceAppIO

14+ eventSourceAppIO,

15+ eventStreamAppRaw

13 ) where

16 ) where

14

17

15import Data.Function (fix)

18import Data.Function (fix)

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

39 case eventToBuilder se of

42 case eventToBuilder se of

40 Nothing -> return ()

43 Nothing -> return ()

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

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

45+

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

47+--

48+-- @since 3.0.28

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

50+eventStreamAppRaw handler _ sendResponse =

51+ sendResponse $ responseStream

52+ status200

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

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

55+ where

56+ sendEvent sendChunk event =

57+ case eventToBuilder event of

58+ Nothing -> return ()

59+ Just b -> sendChunk b

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

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

1{-# LANGUAGE CPP #-}

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

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

3

4{-|

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

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

9 eventToBuilder

10 ) where

11

12−import Blaze.ByteString.Builder

13−import Blaze.ByteString.Builder.Char8

12+import Data.ByteString.Builder

14#if __GLASGOW_HASKELL__ < 710

13#if __GLASGOW_HASKELL__ < 710

15import Data.Monoid

14import Data.Monoid

16#endif

15#endif

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

39 Newline as a Builder.

38 Newline as a Builder.

40-}

39-}

41nl :: Builder

40nl :: Builder

42−nl = fromChar '\n'

41+nl = char7 '\n'

43

42

44

43

45{-|

44{-|

46 Field names as Builder

45 Field names as Builder

47-}

46-}

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

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

49−nameField = fromString "event:"

48+nameField = string7 "event:"

50−idField = fromString "id:"

49+idField = string7 "id:"

51−dataField = fromString "data:"

50+dataField = string7 "data:"

52−retryField = fromString "retry:"

51+retryField = string7 "retry:"

53−commentField = fromChar ':'

52+commentField = char7 ':'

54

53

55

54

56{-|

55{-|

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

66-}

65-}

67eventToBuilder :: ServerEvent -> Maybe Builder

66eventToBuilder :: ServerEvent -> Maybe Builder

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

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

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

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

70eventToBuilder (CloseEvent) = Nothing

69eventToBuilder (CloseEvent) = Nothing

71eventToBuilder (ServerEvent n i d)= Just $

70eventToBuilder (ServerEvent n i d)= Just $

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

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

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

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

19import Data.Char (toLower)

20import qualified System.IO

21import qualified Data.String as String

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

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

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

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

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

25import System.IO (Handle)

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

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

29#if __GLASGOW_HASKELL__ < 710

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

31#endif

32+

32−import qualified Data.Streaming.Blaze as Blaze

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

33import Data.Function (fix)

34import Data.Function (fix)

34import Control.Monad (unless, void)

35import Control.Monad (unless, void)

35

36

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

130 return ResponseReceived

131 return ResponseReceived

131 _ -> do

132 _ -> do

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

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

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

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

134 wb $ \b -> do

135 wb $ \b -> do

135 let sendBuilder builder = do

136 let sendBuilder builder = do

136 popper <- blazeRecv builder

137 popper <- blazeRecv builder

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

139 unless (B.null bs) $ do

140 unless (B.null bs) $ do

140 outputH bs

141 outputH bs

141 loop

142 loop

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

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

143 b sendBuilder (sendBuilder flush)

144 b sendBuilder (sendBuilder flush)

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

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

145 return ResponseReceived

146 return ResponseReceived

146 where

147 where

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

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

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

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

149− [ fromString $ show i

150+ [ string8 $ show i

150− , fromChar ' '

151+ , char7 ' '

151− , fromByteString m

152+ , byteString m

152 ])

153 ])

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

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

154 header (x, y) = mconcat

155 header (x, y) = mconcat

155 [ x

156 [ x

156− , fromByteString ": "

157+ , byteString ": "

157 , y

158 , y

158− , fromChar '\n'

159+ , char7 '\n'

159 ]

160 ]

160 sfBuilder s hs sf fp = mconcat

161 sfBuilder s hs sf fp = mconcat

161 [ headers s hs

162 [ headers s hs

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

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

163− , fromChar '\n'

164+ , char7 '\n'

164− , fromByteString sf

165+ , byteString sf

165− , fromByteString " not supported"

166+ , byteString " not supported"

166 ]

167 ]

167 fixHeaders h =

168 fixHeaders h =

168 case lookup hContentType h of

169 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, "") -> Just i

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

18 _ -> Nothing

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

@@ -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 Blaze.ByteString.Builder (fromByteString)

33+import Data.ByteString.Builder (byteString)

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

34import Control.Exception (try, SomeException)

35import Control.Exception (try, SomeException)

35import qualified Data.Set as Set

36import qualified Data.Set as Set

36import Network.Wai.Header

37import Network.Wai.Header

37import Network.Wai.Internal

38import Network.Wai.Internal

38−import qualified Data.Streaming.Blaze as B

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

39import qualified Data.Streaming.Zlib as Z

40import 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,6 +89,9 @@ defaultCheckMime bs =

89-- if gzip is supported.

90--

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

92+--

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

94+-- behavior, see 'defaultCheckMime'.

92gzip :: GzipSettings -> Middleware

95gzip :: GzipSettings -> Middleware

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

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

94 case res of

97 case res of

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

101 let

104 let

102 compressedVersion = file ++ ".gz"

105 compressedVersion = file ++ ".gz"

103 in

106 in

104− doesFileExist compressedVersion >>= \x ->

107+ doesFileExist compressedVersion >>= \y ->

105− if x

108+ if y

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

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

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

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

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

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

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

182 Just m | gzipCheckMime set m ->

185 Just m | gzipCheckMime set m ->

183 let hs' = fixHeaders hs

186 let hs' = fixHeaders hs

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

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

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

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

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

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

187 let sendBuilder builder = do

190 let sendBuilder builder = do

188 popper <- blazeRecv builder

191 popper <- blazeRecv builder

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

201 case result of

204 case result of

202 Z.PRDone -> return ()

205 Z.PRDone -> return ()

203 Z.PRNext bs' -> do

206 Z.PRNext bs' -> do

204− sendChunk $ fromByteString bs'

207+ sendChunk $ byteString bs'

205 loop

208 loop

206 Z.PRError e -> throwIO e

209 Z.PRError e -> throwIO e

207

210

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 Blaze.ByteString.Builder (copyByteString)

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

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

22+import Data.ByteString.Builder (char7)

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

63+ byteStringCopy c

64− `mappend` fromChar '('

64+ `mappend` char7 '('

65 `mappend` b

66− `mappend` fromChar ')'

66+ `mappend` char7 ')'

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 $ copyByteString cb `mappend` fromChar '('

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

85 _ <- body sendChunk flush

86− sendChunk $ fromChar ')'

86+ sendChunk $ char7 ')'

87

88changeVal :: Eq a

89 => a

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

@@ -14,15 +14,16 @@ module Network.Wai.Middleware.RequestLogger

14 , OutputFormat (..)

15 , OutputFormatter

16 , OutputFormatterWithDetails

17+ , OutputFormatterWithDetailsAndHeaders

17 , Destination (..)

18 , Destination (..)

18 , Callback

19 , Callback

19 , IPAddrSource (..)

20 , IPAddrSource (..)

20 ) where

21 ) where

21

22

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

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

23−import qualified Blaze.ByteString.Builder as B

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

24import qualified Data.ByteString as BS

25import qualified Data.ByteString as BS

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

26+import Data.ByteString.Char8 (pack)

26import Control.Monad (when)

27import Control.Monad (when)

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

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

28import Network.Wai

29import Network.Wai

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

40import qualified Data.ByteString.Lazy as LBS

41import qualified Data.ByteString.Lazy as LBS

41import qualified Data.ByteString.Char8 as S8

42import qualified Data.ByteString.Char8 as S8

42import System.Console.ANSI

43import System.Console.ANSI

43−import Data.IORef.Lifted

44+import Data.IORef

44import System.IO.Unsafe

45import System.IO.Unsafe

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

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

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

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

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

49import Network.Wai.Header (contentLength)

50import Network.Wai.Header (contentLength)

50import Data.Text.Encoding (decodeUtf8')

51import Data.Text.Encoding (decodeUtf8')

51

52

53+data OutputFormat

52−data OutputFormat = Apache IPAddrSource

54+ = Apache IPAddrSource

53− | Detailed Bool -- ^ use colors?

55+ | Detailed Bool -- ^ use colors?

54− | CustomOutputFormat OutputFormatter

56+ | CustomOutputFormat OutputFormatter

55− | CustomOutputFormatWithDetails OutputFormatterWithDetails

57+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

58+ | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

56

59

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

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

61+

58−type OutputFormatterWithDetails =

62+type OutputFormatterWithDetails

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

63+ = ZonedDate

64+ -> Request

65+ -> Status

66+ -> Maybe Integer

67+ -> NominalDiffTime

68+ -> [S8.ByteString]

69+ -> B.Builder

70+ -> LogStr

71+

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

73+--

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

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

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

77+--

78+-- @since 3.0.27

79+type OutputFormatterWithDetailsAndHeaders

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

81+ -> Request -- ^ The WAI request

82+ -> Status -- ^ HTTP status code

83+ -> Maybe Integer -- ^ Response size

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

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

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

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

88+ -> LogStr

60

89

61data Destination = Handle Handle

90data Destination = Handle Handle

62 | Logger LoggerSet

91 | Logger LoggerSet

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

108 CustomOutputFormatWithDetails formatter -> do

137 CustomOutputFormatWithDetails formatter -> do

109 getdate <- getDateGetter flusher

138 getdate <- getDateGetter flusher

110 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

139 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

140+ CustomOutputFormatWithDetailsAndHeaders formatter -> do

141+ getdate <- getDateGetter flusher

142+ return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

111

143

112apacheMiddleware :: ApacheLoggerActions -> Middleware

144apacheMiddleware :: ApacheLoggerActions -> Middleware

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

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

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

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

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

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

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

120 date <- liftIO getdate

152 date <- liftIO getdate

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

153+ let msize = contentLength (responseHeaders res)

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

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

123 sendResponse res

155 sendResponse res

124

156

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

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

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

129 app req' $ \res -> do

161 app req' $ \res -> do

130 t1 <- getCurrentTime

162 t1 <- getCurrentTime

131 date <- liftIO getdate

163 date <- liftIO getdate

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

164+ let msize = contentLength (responseHeaders res)

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

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

134 res' <- recordChunks builderIO res

166 res' <- recordChunks builderIO res

135 rspRcv <- sendResponse res'

167 rspRcv <- sendResponse res'

136 _ <- liftIO . cb .

168 _ <- liftIO . cb .

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

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

138 readIORef builderIO

170 readIORef builderIO

139 return rspRcv

171 return rspRcv

140

172

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

174+customMiddlewareWithDetailsAndHeaders cb getdate formatter app req sendResponse = do

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

176+ t0 <- getCurrentTime

177+ app req' $ \res -> do

178+ t1 <- getCurrentTime

179+ date <- liftIO getdate

180+ let msize = contentLength (responseHeaders res)

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

182+ res' <- recordChunks builderIO res

183+ rspRcv <- sendResponse res'

184+ _ <- do

185+ rawResponse <- readIORef builderIO

186+ let status = responseStatus res'

187+ duration = t1 `diffUTCTime` t0

188+ resHeaders = responseHeaders res'

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

190+ return rspRcv

141-- | Production request logger middleware.

191-- | Production request logger middleware.

142--

192--

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

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

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

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

1{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

2

3

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

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

5+ ( formatAsJSON

6+ , formatAsJSONWithHeaders

7+ ) where

4

8

5−import qualified Blaze.ByteString.Builder as BB

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

10+import Data.ByteString.Lazy (toStrict)

6import Data.Aeson

11import Data.Aeson

7import Data.CaseInsensitive (original)

12import Data.CaseInsensitive (original)

8import Data.Monoid ((<>))

13import Data.Monoid ((<>))

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

10import Data.IP

15import Data.IP

11import qualified Data.Text as T

16import qualified Data.Text as T

12import Data.Text (Text)

17import Data.Text (Text)

13−import Data.Text.Encoding (decodeUtf8)

18+import Data.Text.Encoding (decodeUtf8With)

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

14import Data.Time (NominalDiffTime)

20import Data.Time (NominalDiffTime)

15import Data.Word (Word32)

21import Data.Word (Word32)

16import Network.HTTP.Types as H

22import Network.HTTP.Types as H

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

31 , "size" .= responseSize

37 , "size" .= responseSize

32 , "body" .=

38 , "body" .=

33 if statusCode status >= 400

39 if statusCode status >= 400

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

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

35 else Nothing

41 else Nothing

36 ]

42 ]

37− , "time" .= decodeUtf8 date

43+ , "time" .= decodeUtf8With lenientDecode 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

38 ]) <> "\n"

68 ]) <> "\n"

39

69

40word32ToHostAddress :: Word32 -> Text

70word32ToHostAddress :: Word32 -> Text

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

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

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

47requestToJSON duration req reqBody =

77requestToJSON duration req reqBody =

48 object

78 object

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

73 ]

103 ]

74sockToJSON (SockAddrUnix sock) =

104sockToJSON (SockAddrUnix sock) =

75 object [ "unix" .= sock ]

105 object [ "unix" .= sock ]

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

76sockToJSON (SockAddrCan i) =

107sockToJSON (SockAddrCan i) =

77 object [ "can" .= i ]

108 object [ "can" .= i ]

109+#endif

78

110

79queryItemToJSON :: QueryItem -> Value

111queryItemToJSON :: QueryItem -> Value

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

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

81

113

82requestHeadersToJSON :: RequestHeaders -> Value

114requestHeadersToJSON :: RequestHeaders -> Value

83requestHeadersToJSON = toJSON . map hToJ where

115requestHeadersToJSON = toJSON . map hToJ where

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

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

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

86 hToJ hd = headerToJSON hd

118 hToJ hd = headerToJSON hd

87

119

120+responseHeadersToJSON :: [Header] -> Value

121+responseHeadersToJSON = toJSON . map hToJ where

122+ -- Redact cookies

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

124+ hToJ hd = headerToJSON hd

125+

88headerToJSON :: Header -> Value

126headerToJSON :: Header -> Value

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

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

90

128

91portToJSON :: PortNumber -> Value

129portToJSON :: PortNumber -> Value

92portToJSON = toJSON . toInteger

130portToJSON = toJSON . toInteger

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

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

27 -- ** Recommended functions

28 , rewriteWithQueries

29 , rewritePureWithQueries

30+ , rewriteRoot

30

31

31 -- ** Deprecated

32 -- ** Deprecated

32 , rewrite

33 , rewrite

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

168--

169--

169-- as the following example demonstrates.

170-- as the following example demonstrates.

170--

171--

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

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

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

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

173--

174--

174-- @

175-- @

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

263 -> Middleware

264 -> Middleware

264rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req

265rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req

265

266

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+

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

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

267-- * Modifying 'Request's directly

283-- * Modifying 'Request's directly

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

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

wai-extra/Network/Wai/Middleware/Timeout.hsnew file+33

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

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

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

22 , parseContentType

23 , ParseRequestBodyOptions

24 , defaultParseRequestBodyOptions

25+ , noLimitParseRequestBodyOptions

25 , parseRequestBodyEx

26 , parseRequestBodyEx

26 , setMaxRequestKeyLength

27 , setMaxRequestKeyLength

27 , clearMaxRequestKeyLength

28 , clearMaxRequestKeyLength

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

47#endif

48#endif

48 ) where

49 ) where

49

50

50−import qualified Data.ByteString.Search as Search

51+import qualified Control.Exception as E

51import qualified Data.ByteString as S

52import qualified Data.ByteString as S

52import qualified Data.ByteString.Lazy as L

53import qualified Data.ByteString.Lazy as L

53import qualified Data.ByteString.Char8 as S8

54import qualified Data.ByteString.Char8 as S8

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

58import Data.Function (on, fix)

59import Data.Function (on, fix)

59import System.Directory (removeFile, getTemporaryDirectory)

60import System.Directory (removeFile, getTemporaryDirectory)

60import System.IO (hClose, openBinaryTempFile)

61import System.IO (hClose, openBinaryTempFile)

62+import System.IO.Error (isDoesNotExistError)

61import Network.Wai

63import Network.Wai

62import qualified Network.HTTP.Types as H

64import qualified Network.HTTP.Types as H

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

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

66+import Control.Exception (catchJust)

64−import Control.Monad (when, unless)

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

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

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

66import Data.IORef

69import Data.IORef

67import Network.HTTP.Types (hContentType)

70import Network.HTTP.Types (hContentType)

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

68import Data.CaseInsensitive (mk)

72import Data.CaseInsensitive (mk)

69

73

70import Prelude hiding (lines)

74import Prelude hiding (lines)

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

127 -> IO FilePath

131 -> IO FilePath

128tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

132tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

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

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

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

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

131 fix $ \loop -> do

135 fix $ \loop -> do

132 bs <- popper

136 bs <- popper

133 unless (S.null bs) $ do

137 unless (S.null bs) $ do

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

139 it = do

143 it = do

140 tempDir <- getTmpDir

144 tempDir <- getTmpDir

141 openBinaryTempFile tempDir pattrn

145 openBinaryTempFile tempDir pattrn

146+ removeFileQuiet fp = catchJust (guard . isDoesNotExistError)

147+ (removeFile fp)

148+ (const $ return ())

142

149

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

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

144-- the parseRequestBodyEx function.

151-- the parseRequestBodyEx function.

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

266

273

267-- | Do not impose any memory limits.

274-- | Do not impose any memory limits.

268--

275--

269−-- @since 3.0.16.0

276+-- @since 3.0.21.0

270noLimitParseRequestBodyOptions :: ParseRequestBodyOptions

277noLimitParseRequestBodyOptions :: ParseRequestBodyOptions

271noLimitParseRequestBodyOptions = ParseRequestBodyOptions

278noLimitParseRequestBodyOptions = ParseRequestBodyOptions

272 { prboKeyLength=Nothing

279 { prboKeyLength=Nothing

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

330 semicolon = 59

337 semicolon = 59

331 equals = 61

338 equals = 61

332 space = 32

339 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

333 goAttrs front bs

343 goAttrs front bs

334 | S.null bs = front []

344 | S.null bs = front []

335 | otherwise =

345 | otherwise =

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

338 goAttr bs =

348 goAttr bs =

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

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

340 v = S.drop 1 v'

350 v = S.drop 1 v'

341− in (strip k, strip v)

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

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

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

343

353

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

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

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

418

428

419

429

420-- | Take one header or subheader line.

430-- | Take one header or subheader line.

431+-- Since: 3.0.26

432+-- Throw 431 if headers too large.

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

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

422takeLine maxlen src =

434takeLine maxlen src =

423 go ""

435 go ""

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

426 bs <- readSource src

438 bs <- readSource src

427 case maxlen of

439 case maxlen of

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

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

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

441+ E.throwIO $ ConnectionError (UnknownErrorCode 431)

442+ "Request Header Fields Too Large"

430 Nothing -> return ()

443 Nothing -> return ()

431 if S.null bs

444 if S.null bs

432 then close front

445 then close front

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

442 let res = front `S.append` x

455 let res = front `S.append` x

443 case maxlen of

456 case maxlen of

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

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

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

458+ E.throwIO $ ConnectionError (UnknownErrorCode 431)

459+ "Request Header Fields Too Large"

446 Nothing -> return ()

460 Nothing -> return ()

447 return $ Just $ killCR $ res

461 return $ Just $ killCR $ res

448

462

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

568 deriving (Eq, Show)

582 deriving (Eq, Show)

569

583

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

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

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

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

572 where

586 where

573 handleBreak (h, t)

587 handleBreak (h, t)

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

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

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

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

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

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

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

633 case max' of

647 case max' of

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

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

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

635− _ -> return ()

650+ _ -> return ()

636 if S.null bs

651 if S.null bs

637 then do

652 then do

638 writeIORef ref $ WTBDone False

653 writeIORef ref $ WTBDone False

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

@@ -52,8 +52,7 @@ 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 Blaze.ByteString.Builder (toLazyByteString, toByteString)

55+import Data.ByteString.Builder (toLazyByteString)

56−import qualified Blaze.ByteString.Builder as B

57import qualified Data.ByteString.Lazy as L

56import qualified Data.ByteString.Lazy as L

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

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

59import qualified Network.HTTP.Types as H

58import qualified Network.HTTP.Types as H

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

100data SRequest = SRequest

99data SRequest = SRequest

101 { simpleRequest :: Request

100 { simpleRequest :: Request

102 , simpleRequestBody :: L.ByteString

101 , simpleRequestBody :: L.ByteString

102+ -- ^ Request body that will override the one set in 'simpleRequest'.

103+ --

104+ -- This is usually simpler than setting the body as a stateful IO-action

105+ -- in 'simpleRequest'.

103 }

106 }

104data SResponse = SResponse

107data SResponse = SResponse

105 { simpleStatus :: H.Status

108 { simpleStatus :: H.Status

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

107 , simpleBody :: L.ByteString

110 , simpleBody :: L.ByteString

108 }

111 }

109 deriving (Show, Eq)

112 deriving (Show, Eq)

113+

110request :: Request -> Session SResponse

114request :: Request -> Session SResponse

111−request = srequest . flip SRequest L.empty

115+request req = do

116+ app <- ask

117+ req' <- addCookiesToRequest req

118+ response <- liftIO $ do

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

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

121+ readIORef ref

122+ extractSetCookieFromSResponse response

112

123

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

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

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

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

115setPath req path = req {

126setPath req path = req {

116 pathInfo = segments

127 pathInfo = segments

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

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

118 , queryString = query

129 , queryString = query

119 , rawQueryString = (H.renderQuery True query)

130 , rawQueryString = (H.renderQuery True query)

120 }

131 }

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

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

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

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

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

145 ]

156 ]

146− let cookieValue = toByteString $ Cookie.renderCookies cookiePairs

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

147 addCookieHeader rest

158 addCookieHeader rest

148 | null cookiePairs = rest

159 | null cookiePairs = rest

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

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

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

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

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

168 return response

179 return response

169

180

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

182+-- 'L.ByteString'.

170srequest :: SRequest -> Session SResponse

183srequest :: SRequest -> Session SResponse

171srequest (SRequest req bod) = do

184srequest (SRequest req bod) = do

172− app <- ask

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

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

186+ request $

174− let req' = req

187+ req

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

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

176− case bss of

189+ case bss of

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

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

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

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

179− }

192+ }

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

186

193

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

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

188runResponse ref res = do

195runResponse ref res = do

wai-extra/README.md+14−1

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

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

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

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/Main.hsnew file+62

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

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/app/index.html → wai-extra/example/index.htmlrenamed+3−2

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

1<!doctype html>

2<head>

3− <title>Hello</title>

3+ <title>Example</title>

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

4</head>

5</head>

5−<h1>Testing</h1>

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

6

7

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

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

8

9

wai-extra/test/Network/Wai/Middleware/TimeoutSpec.hsnew file+57

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

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

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

13import qualified Data.Text as TS

14import qualified Data.Text.Encoding as TE

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

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

16

17

17import Network.Wai

18import Network.Wai

18import Network.Wai.Test

19import Network.Wai.Test

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

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

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

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

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

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

33 , ("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")])

33 ]

35 ]

34 it "parseHttpAccept" caseParseHttpAccept

36 it "parseHttpAccept" caseParseHttpAccept

35 describe "parseRequestBody" $ do

37 describe "parseRequestBody" $ do

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

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

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

94 let expected3 = (expectedsmap3, expectedfile3)

96 let expected3 = (expectedsmap3, expectedfile3)

95

97

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

99+ unknownErrorException _ _ = False

100+

96

101

97 let def = defaultParseRequestBodyOptions

102 let def = defaultParseRequestBodyOptions

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

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

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

118

123

119 it "exceeding file size" $ do

124 it "exceeding file size" $ do

120 SRequest req4 _bod4 <- toRequest'' ctype3 content3

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

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

127+ `shouldThrow` unknownErrorException 413

122

128

123 it "exceeding total file size" $ do

129 it "exceeding total file size" $ do

124 SRequest req4 _bod4 <- toRequest'' ctype3 content3

130 SRequest req4 _bod4 <- toRequest'' ctype3 content3

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

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

132+ `shouldThrow` unknownErrorException 413

126 SRequest req5 _bod5 <- toRequest'' ctype3 content5

133 SRequest req5 _bod5 <- toRequest'' ctype3 content5

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

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

135+ `shouldThrow` unknownErrorException 413

128

136

129 it "exceeding max parm value size" $ do

137 it "exceeding max parm value size" $ do

130 SRequest req4 _bod4 <- toRequest'' ctype2 content2

138 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

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

140+ `shouldThrow` unknownErrorException 413

132

141

133 it "exceeding max header lines" $ do

142 it "exceeding max header lines" $ do

134 SRequest req4 _bod4 <- toRequest'' ctype2 content2

143 SRequest req4 _bod4 <- toRequest'' ctype2 content2

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

136

145

137 it "exceeding header line size" $ do

146 it "exceeding header line size" $ do

138 SRequest req4 _bod4 <- toRequest'' ctype3 content4

147 SRequest req4 _bod4 <- toRequest'' ctype3 content4

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

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

149+ `shouldThrow` unknownErrorException 431

140

150

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

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

142 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

152 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

wai-extra/test/Network/Wai/TestSpec.hs+46−12

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

3

4import Control.Monad (void)

5

6+import qualified Data.IORef as IORef

7+

6import qualified Data.Text.Encoding as TE

8import qualified Data.Text.Encoding as TE

7

9

8import Data.Time.Calendar (fromGregorian)

10import Data.Time.Calendar (fromGregorian)

@@ -16,13 +18,17 @@ import Network.Wai.Test

16import Network.HTTP.Types (status200)

18import Network.HTTP.Types (status200)

17

19

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

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

19−import Blaze.ByteString.Builder (toByteString)

21+import Data.ByteString.Builder (Builder, toLazyByteString)

22+import Data.ByteString (ByteString)

20

23

21import qualified Web.Cookie as Cookie

24import qualified Web.Cookie as Cookie

22

25

23main :: IO ()

26main :: IO ()

24main = hspec spec

27main = hspec spec

25

28

29+toByteString :: Builder -> ByteString

30+toByteString = L8.toStrict . toLazyByteString

31+

26spec :: Spec

32spec :: Spec

27spec = do

33spec = do

28 describe "setPath" $ do

34 describe "setPath" $ do

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

49 it "sets rawQueryString to empty string" $ do

55 it "sets rawQueryString to empty string" $ do

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

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

51

57

58+ describe "srequest" $ do

59+

60+ let echoApp req respond = do

61+ reqBody <- L8.fromStrict <$> getRequestBodyChunk req

62+ let reqHeaders = requestHeaders req

63+ respond $

64+ responseLBS

65+ status200

66+ reqHeaders

67+ reqBody

68+

69+ it "returns the response body of an echo app" $ do

70+ sresp <- flip runSession echoApp $

71+ srequest $ SRequest defaultRequest "request body"

72+ simpleBody sresp `shouldBe` "request body"

73+

52 describe "request" $ do

74 describe "request" $ do

53

75

54− let simpleApp _req respond =

76+ let echoApp req respond = do

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

78+ let reqHeaders = requestHeaders req

55 respond $

79 respond $

56 responseLBS

80 responseLBS

57 status200

81 status200

58− [("foo", "bar")]

82+ reqHeaders

59− "simple"

83+ reqBody

60

84

61− it "returns the status code of a simple app on default request" $ do

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

62− sresp <- runSession (request defaultRequest) simpleApp

86+ sresp <- runSession (request defaultRequest) echoApp

63 simpleStatus sresp `shouldBe` status200

87 simpleStatus sresp `shouldBe` status200

64

88

65− it "returns the response body of a simple app on default request" $ do

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

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

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

92+ sresp <- flip runSession echoApp $

93+ request $

66− sresp <- runSession (request defaultRequest) simpleApp

94+ defaultRequest

95+ { requestBody = getBodyChunk

96+ }

67− simpleBody sresp `shouldBe` "simple"

97+ simpleBody sresp `shouldBe` "request body"

68−

98+

69− it "returns the response headers of a simple app on default request" $ do

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

100+ sresp <- flip runSession echoApp $

101+ request $

70− sresp <- runSession (request defaultRequest) simpleApp

102+ defaultRequest

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

104+ }

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

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

72

106

73 let cookieApp req respond =

107 let cookieApp req respond =

wai-extra/wai-extra.cabal+32−11

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

1Name: wai-extra

2−Version: 3.0.20.0

2+Version: 3.0.29.1

3Synopsis: Provides some basic WAI handlers and middleware.

4description:

5 Provides basic WAI handler and middleware functionality:

@@ -81,38 +81,41 @@ 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+

84Library

89Library

85− Build-Depends: base >= 4.6 && < 5

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

86− , bytestring >= 0.9.1.4

91+ , bytestring >= 0.10.4

87 , wai >= 3.0.3.0 && < 3.3

92 , wai >= 3.0.3.0 && < 3.3

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

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

89 , time >= 1.1.4

94 , time >= 1.1.4

90 , network >= 2.6.1.0

95 , network >= 2.6.1.0

91 , directory >= 1.0.1

96 , directory >= 1.0.1

92 , transformers >= 0.2.2

97 , transformers >= 0.2.2

93− , blaze-builder >= 0.2.1.4 && < 0.5

94 , http-types >= 0.7

98 , http-types >= 0.7

95 , text >= 0.7

99 , text >= 0.7

96 , case-insensitive >= 0.2

100 , case-insensitive >= 0.2

97 , data-default-class

101 , data-default-class

98− , fast-logger >= 2.4.5 && < 2.5

102+ , fast-logger >= 2.4.5

99− , wai-logger >= 2.2.6 && < 2.4

103+ , wai-logger >= 2.3.2

100 , ansi-terminal

104 , ansi-terminal

101− , resourcet >= 0.4.6 && < 1.2

105+ , resourcet >= 0.4.6 && < 1.3

102 , void >= 0.5

106 , void >= 0.5

103− , stringsearch >= 0.3 && < 0.4

104 , containers

107 , containers

105 , base64-bytestring

108 , base64-bytestring

106 , word8

109 , word8

107− , lifted-base >= 0.1.2

108 , deepseq

110 , deepseq

109− , streaming-commons

111+ , streaming-commons >= 0.2

110 , unix-compat

112 , unix-compat

111 , cookie

113 , cookie

112 , vault

114 , vault

113 , zlib

115 , zlib

114 , aeson

116 , aeson

115 , iproute

117 , iproute

118+ , http2

116

119

117 if os(windows)

120 if os(windows)

118 cpp-options: -DWINDOWS

121 cpp-options: -DWINDOWS

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

144 Network.Wai.Middleware.ForceDomain

147 Network.Wai.Middleware.ForceDomain

145 Network.Wai.Middleware.ForceSSL

148 Network.Wai.Middleware.ForceSSL

146 Network.Wai.Middleware.Routed

149 Network.Wai.Middleware.Routed

150+ Network.Wai.Middleware.Timeout

147 Network.Wai.Parse

151 Network.Wai.Parse

148 Network.Wai.Request

152 Network.Wai.Request

149 Network.Wai.UrlMap

153 Network.Wai.UrlMap

@@ -155,6 +159,22 @@ Library

155 default-language: Haskell2010

159 default-language: Haskell2010

156 ghc-options: -Wall

160 ghc-options: -Wall

157

161

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+

158test-suite spec

178test-suite spec

159 type: exitcode-stdio-1.0

179 type: exitcode-stdio-1.0

160 hs-source-dirs: test

180 hs-source-dirs: test

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

166 Network.Wai.Middleware.ForceSSLSpec

186 Network.Wai.Middleware.ForceSSLSpec

167 Network.Wai.Middleware.RoutedSpec

187 Network.Wai.Middleware.RoutedSpec

168 Network.Wai.Middleware.StripHeadersSpec

188 Network.Wai.Middleware.StripHeadersSpec

189+ Network.Wai.Middleware.TimeoutSpec

169 WaiExtraSpec

190 WaiExtraSpec

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

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

171 , wai-extra

192 , wai-extra

@@ -179,10 +200,10 @@ test-suite spec

179 , resourcet

200 , resourcet

180 , bytestring

201 , bytestring

181 , HUnit

202 , HUnit

182− , blaze-builder

183 , cookie

203 , cookie

184 , time

204 , time

185 , case-insensitive

205 , case-insensitive

206+ , http2

186 ghc-options: -Wall

207 ghc-options: -Wall

187 default-language: Haskell2010

208 default-language: Haskell2010

188

209

wai-handler-fastcgi/.gitignoredeleted−4

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

1−/dist/

2−*.swp

3−*.hi

4−*.o

wai-handler-fastcgi/ChangeLog.mddeleted−3

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

1−## 3.0.0.2

2−

3−* Support wai 3.2

wai-handler-fastcgi/Network/Wai/Handler/FastCGI.hscdeleted−192

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

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/READMEdeleted

No changes to the content.

wai-handler-fastcgi/README.mddeleted−3

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

1−## wai-handler-fastcgi

2−

3−Calls out to the libfcgi C library.

wai-handler-fastcgi/Setup.lhsdeleted−7

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

1−#!/usr/bin/env runhaskell

2−

3−> module Main where

4−> import Distribution.Simple

5−

6−> main :: IO ()

7−> main = defaultMain

wai-handler-fastcgi/configuredeleted−9

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

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

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

1−ghc-options: -optc@CPPFLAGS@

2−cc-options: @CPPFLAGS@

3−ld-options: @LDFLAGS@

wai-handler-fastcgi/lighttpd.confdeleted−19

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

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

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

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.cabaldeleted−31

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

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/.gitignoredeleted−2

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

1−dist/

2−*.swp

wai-handler-launch/ChangeLog.mddeleted−27

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

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/LICENSEdeleted−20

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

2−

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

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

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

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

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

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

9−the following conditions:

10−

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

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

13−

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

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

16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

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

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

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

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

wai-handler-launch/Network/Wai/Handler/Launch.hsdeleted−222

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

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/READMEdeleted

No changes to the content.

wai-handler-launch/README.mddeleted−4

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

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

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

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

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

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

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

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.cabaldeleted−37

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

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.cdeleted−12

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

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/.gitignoredeleted−2

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

1−dist

2−*.swp

wai-handler-webkit/ChangeLog.mddeleted−3

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

1−## 3.0.0.3

2−

3−* Support for wai/warp 3.2

wai-handler-webkit/LICENSEdeleted−20

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

2−

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

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

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

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

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

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

9−the following conditions:

10−

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

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

13−

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

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

16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

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

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

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

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

wai-handler-webkit/Network/Wai/Handler/Webkit.hsdeleted−21

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

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.mddeleted−53

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

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

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

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

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

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.cabaldeleted−30

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

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.cppdeleted−19

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

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

@@ -120,10 +120,12 @@ pushOnReferer settings@Settings{..} app req sendResponse = do

120 when (isNothing mauth

121 || requestHeaderHost req == mauth) $ do

122 when (path /= refPath) $ do -- just in case

123+ let !path' = BS.copy path

124+ !refPath' = BS.copy refPath

123− mpp <- makePushPromise refPath path file

125+ mpp <- makePushPromise refPath' path' file

124 case mpp of

126 case mpp of

125 Nothing -> return ()

127 Nothing -> return ()

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

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

127 ps -> do

129 ps -> do

128 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

130 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

129 setHTTP2Data req (Just h2d)

131 setHTTP2Data req (Just h2d)

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

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

1Name: wai-http2-extra

2−Version: 0.1.0

2+Version: 0.1.2

3Synopsis: WAI utilities for HTTP/2

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: kazu@iij.ad.jp

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

9Category: Web

10Build-Type: Simple

11−Cabal-Version: >=1.8

11+Cabal-Version: >=1.10

12Stability: Stable

13Description: WAI utilities for HTTP/2

14

@@ -24,6 +24,9 @@ Library

24 Exposed-modules: Network.Wai.Middleware.Push.Referer

25 Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap

26 Ghc-Options: -Wall

27+ if impl(ghc >= 8)

28+ default-extensions: Strict StrictData

29+ default-language: Haskell2010

27

30

28Test-Suite doctest

31Test-Suite doctest

29 Type: exitcode-stdio-1.0

32 Type: exitcode-stdio-1.0

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

32 Main-Is: doctests.hs

35 Main-Is: doctests.hs

33 Build-Depends: base

36 Build-Depends: base

34 , doctest >= 0.10.1

37 , doctest >= 0.10.1

38+ if impl(ghc >= 8)

39+ default-extensions: Strict StrictData

40+ default-language: Haskell2010

41+

35Source-Repository head

42Source-Repository head

36 Type: git

43 Type: git

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

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

wai-websockets/ChangeLog.md+4

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

1+## 3.0.1.2

2+

3+* Drop unused dependency on blaze-builder

4+

1## 3.0.1.1

5## 3.0.1.1

2

6

3* Doc improvement

7* Doc improvement

wai-websockets/server.lhs+7−1

@@ -8,6 +8,8 @@ this example, keep the [reference](http://jaspervdj.be/websockets/reference)

8nearby to check out the functions we use.

9

10> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}

11+> {-# LANGUAGE CPP #-}

12+> {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- for numClients

11> import Data.Char (isPunctuation, isSpace)

13> import Data.Char (isPunctuation, isSpace)

12> import Data.Monoid (mappend)

14> import Data.Monoid (mappend)

13> import Data.Text (Text)

15> import Data.Text (Text)

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

99

101

100> application state pending = do

102> application state pending = do

101> conn <- WS.acceptRequest pending

103> conn <- WS.acceptRequest pending

104+#if __GLASGOW_HASKELL__ >= 806

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

106+#else

102> WS.forkPingThread conn 30

107> WS.forkPingThread conn 30

108+#endif

103

109

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

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

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

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

106

112

107> msg <- WS.receiveData conn

113> msg <- WS.receiveData conn

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

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

1Name: wai-websockets

2−Version: 3.0.1.1

2+Version: 3.0.1.2

3Synopsis: Provide a bridge between WAI and the websockets package.

4License: MIT

5License-file: LICENSE

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

25 , case-insensitive >= 0.2

24 , case-insensitive >= 0.2

26 , network >= 2.2.1.5

25 , network >= 2.2.1.5

27 , transformers >= 0.2

26 , transformers >= 0.2

@@ -41,12 +40,12 @@ Executable wai-websockets-example

41 , wai-app-static

40 , wai-app-static

42 , bytestring

41 , bytestring

43 , case-insensitive

42 , case-insensitive

44− , blaze-builder

45 , transformers

43 , transformers

46 , network

44 , network

47 , text

45 , text

48 , file-embed

46 , file-embed

49 , http-types

47 , http-types

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

50 else

49 else

51 buildable: False

50 buildable: False

52

51

wai/ChangeLog.md+14

@@ -1,3 +1,17 @@

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+

1## 3.2.1.1

15## 3.2.1.1

2

16

3* Relax upper bound on bytestring-builder

17* Relax upper bound on bytestring-builder

wai/Network/Wai.hs+20−21

@@ -1,15 +1,14 @@

1−{-# LANGUAGE Rank2Types #-}

2−{-# LANGUAGE CPP #-}

3{-|

1{-|

4

2

5This module defines a generic web application interface. It is a common

3This module defines a generic web application interface. It is a common

6protocol between web servers and web applications.

4protocol between web servers and web applications.

7

5

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

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

9−address performance, this library is built on top of the conduit and

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

10−blaze-builder packages. The advantages of conduits over lazy IO have been

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

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

11−debated elsewhere and so will not be addressed here. However, helper functions

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

12−like 'responseLBS' allow you to continue using lazy IO if you so desire.

11+continue using lazy IO if you so desire.

13

12

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

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

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

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

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

31

30

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

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

33

32

34−[wai-test] <http://hackage.haskell.org/package/wai-test>

35−

36-}

33-}

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

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

37module Network.Wai

36module Network.Wai

38 (

37 (

39 -- * Types

38 -- * Types

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

54 , remoteHost

53 , remoteHost

55 , pathInfo

54 , pathInfo

56 , queryString

55 , queryString

56+ , getRequestBodyChunk

57 , requestBody

58 , vault

59 , requestBodyLength

@@ -85,8 +85,8 @@ module Network.Wai

85 , modifyResponse

86 ) where

87

88−import Blaze.ByteString.Builder (Builder, fromLazyByteString)

88+import Data.ByteString.Builder (Builder, lazyByteString)

89−import Blaze.ByteString.Builder (fromByteString)

89+import Data.ByteString.Builder (byteString)

90import Control.Monad (unless)

91import qualified Data.ByteString as B

92import qualified Data.ByteString.Lazy as L

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

98import qualified Network.HTTP.Types as H

97import qualified Network.HTTP.Types as H

99import Network.Socket (SockAddr (SockAddrInet))

98import Network.Socket (SockAddr (SockAddrInet))

100import Network.Wai.Internal

99import Network.Wai.Internal

@@ -122,13 +121,13 @@ responseFile = ResponseFile

122--

121--

123-- A2. No. If the ByteStrings are small, then they will be copied into a larger

122-- A2. No. If the ByteStrings are small, then they will be copied into a larger

124-- buffer, which should be a performance gain overall (less system calls). If

123-- buffer, which should be a performance gain overall (less system calls). If

125−-- they are already large, then blaze-builder uses an InsertByteString

124+-- they are already large, then an insert operation is used

126−-- instruction to avoid copying.

125+-- to avoid copying.

127--

126--

128-- Q3. Doesn't this prevent us from creating comet-style servers, since data

127-- Q3. Doesn't this prevent us from creating comet-style servers, since data

129-- will be cached?

128-- will be cached?

130--

129--

131−-- A3. You can force blaze-builder to output a ByteString before it is an

130+-- A3. You can force a Builder to output a ByteString before it is an

132-- optimal size by sending a flush command.

131-- optimal size by sending a flush command.

133responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

132responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

134responseBuilder = ResponseBuilder

133responseBuilder = ResponseBuilder

@@ -136,7 +135,7 @@ responseBuilder = ResponseBuilder

136-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for

135-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for

137-- 'responseBuilder'.

136-- 'responseBuilder'.

138responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

137responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

139−responseLBS s h = ResponseBuilder s h . fromLazyByteString

138+responseLBS s h = ResponseBuilder s h . lazyByteString

140

139

141-- | Creating 'Response' from a stream of values.

140-- | Creating 'Response' from a stream of values.

142--

141--

@@ -150,9 +149,9 @@ responseLBS s h = ResponseBuilder s h . fromLazyByteString

150-- (putStrLn \"Allocating scarce resource\")

149-- (putStrLn \"Allocating scarce resource\")

151-- (putStrLn \"Cleaning up\")

150-- (putStrLn \"Cleaning up\")

152-- $ respond $ responseStream status200 [] $ \\write flush -> do

151-- $ respond $ responseStream status200 [] $ \\write flush -> do

153−-- write $ fromByteString \"Hello\\n\"

152+-- write $ byteString \"Hello\\n\"

154-- flush

153-- flush

155−-- write $ fromByteString \"World\\n\"

154+-- write $ byteString \"World\\n\"

156-- @

155-- @

157--

156--

158-- Note that in some cases you can use @bracket@ from inside @responseStream@

157-- Note that in some cases you can use @bracket@ from inside @responseStream@

@@ -215,7 +214,7 @@ responseToStream (ResponseFile s h fp (Just part)) =

215 bs <- B.hGetSome handle defaultChunkSize

214 bs <- B.hGetSome handle defaultChunkSize

216 unless (B.null bs) $ do

215 unless (B.null bs) $ do

217 let x = B.take remaining bs

216 let x = B.take remaining bs

218− sendChunk $ fromByteString x

217+ sendChunk $ byteString x

219 loop $ remaining - B.length x

218 loop $ remaining - B.length x

220 loop $ fromIntegral $ filePartByteCount part

219 loop $ fromIntegral $ filePartByteCount part

221 )

220 )

@@ -226,7 +225,7 @@ responseToStream (ResponseFile s h fp Nothing) =

226 withBody $ \sendChunk _flush -> fix $ \loop -> do

225 withBody $ \sendChunk _flush -> fix $ \loop -> do

227 bs <- B.hGetSome handle defaultChunkSize

226 bs <- B.hGetSome handle defaultChunkSize

228 unless (B.null bs) $ do

227 unless (B.null bs) $ do

229− sendChunk $ fromByteString bs

228+ sendChunk $ byteString bs

230 loop

229 loop

231 )

230 )

232responseToStream (ResponseBuilder s h b) =

231responseToStream (ResponseBuilder s h b) =

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

327 loop id

326 loop id

328 where

327 where

329 loop front = do

328 loop front = do

330− bs <- requestBody req

329+ bs <- getRequestBodyChunk req

331 if B.null bs

330 if B.null bs

332 then return $ front LI.Empty

331 then return $ front LI.Empty

333 else loop (front . LI.Chunk bs)

332 else loop (front . LI.Chunk bs)

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

341 loop

340 loop

342 where

341 where

343 loop = unsafeInterleaveIO $ do

342 loop = unsafeInterleaveIO $ do

344− bs <- requestBody req

343+ bs <- getRequestBodyChunk req

345 if B.null bs

344 if B.null bs

346 then return LI.Empty

345 then return LI.Empty

347 else do

346 else do

wai/Network/Wai/Internal.hs+10−7

@@ -1,17 +1,12 @@

1{-# OPTIONS_HADDOCK not-home #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

4−{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

6-- | Internal constructors and helper functions. Note that no guarantees are

4-- | Internal constructors and helper functions. Note that no guarantees are

7-- given for stability of these interfaces.

5-- given for stability of these interfaces.

8module Network.Wai.Internal where

6module Network.Wai.Internal where

9

7

10−import Blaze.ByteString.Builder (Builder)

8+import Data.ByteString.Builder (Builder)

11import qualified Data.ByteString as B hiding (pack)

9import qualified Data.ByteString as B hiding (pack)

12−#if __GLASGOW_HASKELL__ < 709

13−import Data.Functor ((<$>))

14−#endif

15import Data.Text (Text)

10import Data.Text (Text)

16import Data.Typeable (Typeable)

11import Data.Typeable (Typeable)

17import Data.Vault.Lazy (Vault)

12import Data.Vault.Lazy (Vault)

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

22

17

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

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

24-- details of the underlying implementation.

19-- details of the underlying implementation.

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

25data Request = Request {

21data Request = Request {

26 -- | Request method such as GET.

22 -- | Request method such as GET.

27 requestMethod :: H.Method

23 requestMethod :: H.Method

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

67 -- | Parsed query string information.

63 -- | Parsed query string information.

68 , queryString :: H.Query

64 , queryString :: H.Query

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

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

70− -- body is fully consumed.

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

71 , requestBody :: IO B.ByteString

67 , requestBody :: IO B.ByteString

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

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

73 , vault :: Vault

69 , vault :: Vault

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

95 }

91 }

96 deriving (Typeable)

92 deriving (Typeable)

97

93

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+

98instance Show Request where

101instance Show Request where

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

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

100 where

103 where

wai/test/Network/WaiSpec.hs+7−9

@@ -3,12 +3,10 @@ module Network.WaiSpec (spec) where

3import Test.Hspec

4import Test.Hspec.QuickCheck (prop)

5import Network.Wai

6−import Network.Wai.Internal (Request (Request))

7import Data.IORef

6import Data.IORef

8−import Data.Monoid

9import qualified Data.ByteString as S

7import qualified Data.ByteString as S

10import qualified Data.ByteString.Lazy as L

8import qualified Data.ByteString.Lazy as L

11−import Blaze.ByteString.Builder (toByteString, Builder, fromWord8)

9+import Data.ByteString.Builder (Builder, toLazyByteString, word8)

12import Control.Monad (forM_)

10import Control.Monad (forM_)

13

11

14spec :: Spec

12spec :: Spec

@@ -24,17 +22,17 @@ spec = do

24 flush :: IO ()

22 flush :: IO ()

25 flush = return ()

23 flush = return ()

26 streamingBody add flush

24 streamingBody add flush

27− fmap toByteString $ readIORef builderRef

25+ fmap (L.toStrict . toLazyByteString) $ readIORef builderRef

28 prop "responseLBS" $ \bytes -> do

26 prop "responseLBS" $ \bytes -> do

29 body <- getBody $ responseLBS undefined undefined $ L.pack bytes

27 body <- getBody $ responseLBS undefined undefined $ L.pack bytes

30 body `shouldBe` S.pack bytes

28 body `shouldBe` S.pack bytes

31 prop "responseBuilder" $ \bytes -> do

29 prop "responseBuilder" $ \bytes -> do

32 body <- getBody $ responseBuilder undefined undefined

30 body <- getBody $ responseBuilder undefined undefined

33− $ mconcat $ map fromWord8 bytes

31+ $ mconcat $ map word8 bytes

34 body `shouldBe` S.pack bytes

32 body `shouldBe` S.pack bytes

35 prop "responseStream" $ \chunks -> do

33 prop "responseStream" $ \chunks -> do

36 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

34 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

37− forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk

35+ forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk

38 body `shouldBe` S.concat (map S.pack chunks)

36 body `shouldBe` S.concat (map S.pack chunks)

39 it "responseFile total" $ do

37 it "responseFile total" $ do

40 let fp = "wai.cabal"

38 let fp = "wai.cabal"

@@ -57,7 +55,7 @@ spec = do

57 describe "lazyRequestBody" $ do

55 describe "lazyRequestBody" $ do

58 prop "works" $ \chunks -> do

56 prop "works" $ \chunks -> do

59 ref <- newIORef $ map S.pack $ filter (not . null) chunks

57 ref <- newIORef $ map S.pack $ filter (not . null) chunks

60− let req = Request

58+ let req = defaultRequest

61 { requestBody = atomicModifyIORef ref $ \bss ->

59 { requestBody = atomicModifyIORef ref $ \bss ->

62 case bss of

60 case bss of

63 [] -> ([], S.empty)

61 [] -> ([], S.empty)

@@ -66,7 +64,7 @@ spec = do

66 body <- lazyRequestBody req

64 body <- lazyRequestBody req

67 body `shouldBe` L.fromChunks (map S.pack chunks)

65 body `shouldBe` L.fromChunks (map S.pack chunks)

68 it "is lazy" $ do

66 it "is lazy" $ do

69− let req = Request

67+ let req = defaultRequest

70 { requestBody = error "requestBody"

68 { requestBody = error "requestBody"

71 }

69 }

72 _ <- lazyRequestBody req

70 _ <- lazyRequestBody req

@@ -74,7 +72,7 @@ spec = do

74 describe "strictRequestBody" $ do

72 describe "strictRequestBody" $ do

75 prop "works" $ \chunks -> do

73 prop "works" $ \chunks -> do

76 ref <- newIORef $ map S.pack $ filter (not . null) chunks

74 ref <- newIORef $ map S.pack $ filter (not . null) chunks

77− let req = Request

75+ let req = defaultRequest

78 { requestBody = atomicModifyIORef ref $ \bss ->

76 { requestBody = atomicModifyIORef ref $ \bss ->

79 case bss of

77 case bss of

80 [] -> ([], S.empty)

78 [] -> ([], S.empty)

wai/wai.cabal+8−10

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

1Name: wai

2−Version: 3.2.1.1

2+Version: 3.2.2.1

3Synopsis: Web Application Interface.

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

5+ .

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

6+ API docs and the README are available at <http://www.stackage.org/package/wai>.

6License: MIT

7License: MIT

7License-file: LICENSE

8License-file: LICENSE

8Author: Michael Snoyman

9Author: Michael Snoyman

@@ -19,14 +20,11 @@ Source-repository head

19 location: git://github.com/yesodweb/wai.git

20 location: git://github.com/yesodweb/wai.git

20

21

21Library

22Library

22− Build-Depends: base >= 4 && < 5

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

23− , bytestring >= 0.10

24+ , bytestring >= 0.10.4

24− , bytestring-builder >= 0.10.4.0 && < 0.11

25− , blaze-builder >= 0.2.1.4 && < 0.5

26 , network >= 2.2.1.5

25 , network >= 2.2.1.5

27 , http-types >= 0.7

26 , http-types >= 0.7

28 , text >= 0.7

27 , text >= 0.7

29− , transformers >= 0.0

30 , vault >= 0.3 && < 0.4

28 , vault >= 0.3 && < 0.4

31 Exposed-modules: Network.Wai

29 Exposed-modules: Network.Wai

32 Network.Wai.Internal

30 Network.Wai.Internal

@@ -36,14 +34,14 @@ test-suite test

36 hs-source-dirs: test

34 hs-source-dirs: test

37 main-is: Spec.hs

35 main-is: Spec.hs

38 type: exitcode-stdio-1.0

36 type: exitcode-stdio-1.0

39− ghc-options: -threaded

37+ ghc-options: -threaded -Wall

40 cpp-options: -DTEST

38 cpp-options: -DTEST

41− build-depends: base

39+ build-depends: base >= 4.8 && < 5

42 , wai

40 , wai

43 , hspec

41 , hspec

44− , blaze-builder

45 , bytestring

42 , bytestring

46 other-modules: Network.WaiSpec

43 other-modules: Network.WaiSpec

44+ build-tool-depends: hspec-discover:hspec-discover

47

45

48source-repository head

46source-repository head

49 type: git

47 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 Blaze.ByteString.Builder (fromLazyByteString)

8+import Data.ByteString.Builder (lazyByteString)

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− (fromLazyByteString lbs)

30+ (lazyByteString lbs)

warp-tls/ChangeLog.md+47

@@ -1,3 +1,50 @@

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+

1## 3.2.2

48## 3.2.2

2

49

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

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

warp-tls/Network/Wai/Handler/WarpTLS.hs+74−22

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

4{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE DeriveDataTypeable #-}

6{-# LANGUAGE PatternGuards #-}

7−{-# LANGUAGE CPP #-}

8

7

9-- | HTTP over TLS support for Warp via the TLS package.

8-- | HTTP over TLS support for Warp via the TLS package.

10--

9--

@@ -43,13 +42,10 @@ module Network.Wai.Handler.WarpTLS (

43 , DH.generateParams

42 , DH.generateParams

44 ) where

43 ) where

45

44

46−#if __GLASGOW_HASKELL__ < 709

47−import Control.Applicative ((<$>))

48−#endif

49import Control.Applicative ((<|>))

45import Control.Applicative ((<|>))

50−import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..))

46+import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)

51import qualified Control.Exception as E

47import qualified Control.Exception as E

52−import Control.Monad (void)

48+import Control.Monad (void, guard)

53import qualified Data.ByteString as S

49import qualified Data.ByteString as S

54import qualified Data.ByteString.Lazy as L

50import qualified Data.ByteString.Lazy as L

55import Data.Default.Class (def)

51import Data.Default.Class (def)

@@ -57,6 +53,9 @@ import qualified Data.IORef as I

57import Data.Streaming.Network (bindPortTCP, safeRecv)

53import Data.Streaming.Network (bindPortTCP, safeRecv)

58import Data.Typeable (Typeable)

54import Data.Typeable (Typeable)

59import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)

55import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)

56+#if MIN_VERSION_network(3,1,1)

57+import Network.Socket (gracefulClose)

58+#endif

60import Network.Socket.ByteString (sendAll)

59import Network.Socket.ByteString (sendAll)

61import qualified Network.TLS as TLS

60import qualified Network.TLS as TLS

62import qualified Crypto.PubKey.DH as DH

61import qualified Crypto.PubKey.DH as DH

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

94 --

93 --

95 -- Since 1.4.0

94 -- Since 1.4.0

96 , tlsAllowedVersions :: [TLS.Version]

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

97 -- ^ The TLS versions this server accepts.

104 -- ^ The TLS versions this server accepts.

98 --

105 --

99 -- >>> tlsAllowedVersions defaultTlsSettings

106 -- >>> tlsAllowedVersions defaultTlsSettings

100 -- [TLS12,TLS11,TLS10]

107 -- [TLS12,TLS11,TLS10]

101 --

108 --

102 -- Since 1.4.2

109 -- Since 1.4.2

110+#endif

103 , tlsCiphers :: [TLS.Cipher]

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

104 -- ^ The TLS ciphers this server accepts.

120 -- ^ The TLS ciphers this server accepts.

105 --

121 --

106 -- >>> tlsCiphers defaultTlsSettings

122 -- >>> tlsCiphers defaultTlsSettings

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]

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]

108 --

124 --

109 -- Since 1.4.2

125 -- Since 1.4.2

126+#endif

110 , tlsWantClientCert :: Bool

127 , tlsWantClientCert :: Bool

111 -- ^ Whether or not to demand a certificate from the client. If this

128 -- ^ Whether or not to demand a certificate from the client. If this

112 -- is set to True, you must handle received certificates in a server hook

129 -- is set to True, you must handle received certificates in a server hook

@@ -153,7 +170,11 @@ defaultTlsSettings = TLSSettings {

153 , keyMemory = Nothing

170 , keyMemory = Nothing

154 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

171 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

155 , tlsLogging = def

172 , tlsLogging = def

173+#if MIN_VERSION_tls(1,5,0)

174+ , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]

175+#else

156 , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]

176 , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]

177+#endif

157 , tlsCiphers = ciphers

178 , tlsCiphers = ciphers

158 , tlsWantClientCert = False

179 , tlsWantClientCert = False

159 , tlsServerHooks = def

180 , tlsServerHooks = def

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

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

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

261 runSettingsConnectionMakerSecure set get app

282 runSettingsConnectionMakerSecure set get app

262 where

283 where

263− get = getter tlsset sock params

284+ get = getter tlsset set sock params

264 params = def { -- TLS.ServerParams

285 params = def { -- TLS.ServerParams

265 TLS.serverWantClientCert = tlsWantClientCert

286 TLS.serverWantClientCert = tlsWantClientCert

266 , TLS.serverCACertificates = []

287 , TLS.serverCACertificates = []

@@ -268,6 +289,9 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

268 , TLS.serverHooks = hooks

289 , TLS.serverHooks = hooks

269 , TLS.serverShared = shared

290 , TLS.serverShared = shared

270 , TLS.serverSupported = supported

291 , TLS.serverSupported = supported

292+#if MIN_VERSION_tls(1,5,0)

293+ , TLS.serverEarlyDataSize = 2018

294+#endif

271 }

295 }

272 -- Adding alpn to user's tlsServerHooks.

296 -- Adding alpn to user's tlsServerHooks.

273 hooks = tlsServerHooks {

297 hooks = tlsServerHooks {

@@ -286,6 +310,9 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

286 , TLS.supportedClientInitiatedRenegotiation = False

310 , TLS.supportedClientInitiatedRenegotiation = False

287 , TLS.supportedSession = True

311 , TLS.supportedSession = True

288 , TLS.supportedFallbackScsv = True

312 , TLS.supportedFallbackScsv = True

313+#if MIN_VERSION_tls(1,5,0)

314+ , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]

315+#endif

289 }

316 }

290

317

291alpn :: [S.ByteString] -> IO S.ByteString

318alpn :: [S.ByteString] -> IO S.ByteString

@@ -295,44 +322,55 @@ alpn xs

295

322

296----------------------------------------------------------------

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

297

324

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

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

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

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

327+#if WINDOWS

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

329+#else

300 (s, sa) <- accept sock

330 (s, sa) <- accept sock

331+#endif

332+ setSocketCloseOnExec s

301− return (mkConn tlsset s params, sa)

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

302

334

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

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

304−mkConn tlsset s params = switch `onException` close s

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

305 where

337 where

306 switch = do

338 switch = do

307 firstBS <- safeRecv s 4096

339 firstBS <- safeRecv s 4096

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

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

309− httpOverTls tlsset s firstBS params

341+ httpOverTls tlsset set s firstBS params

310 else

342 else

311− plainHTTP tlsset s firstBS

343+ plainHTTP tlsset set s firstBS

312

344

313----------------------------------------------------------------

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

314

346

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

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

316−httpOverTls TLSSettings{..} s bs0 params = do

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

317 recvN <- makePlainReceiveN s bs0

349 recvN <- makePlainReceiveN s bs0

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

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

319 TLS.contextHookSetLogging ctx tlsLogging

351 TLS.contextHookSetLogging ctx tlsLogging

320 TLS.handshake ctx

352 TLS.handshake ctx

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

354+ isH2 <- I.newIORef h2

321 writeBuf <- allocateBuffer bufferSize

355 writeBuf <- allocateBuffer bufferSize

322 -- Creating a cache for leftover input data.

356 -- Creating a cache for leftover input data.

323 ref <- I.newIORef ""

357 ref <- I.newIORef ""

324 tls <- getTLSinfo ctx

358 tls <- getTLSinfo ctx

325− return (conn ctx writeBuf ref, tls)

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

326 where

360 where

327 backend recvN = TLS.Backend {

361 backend recvN = TLS.Backend {

328 TLS.backendFlush = return ()

362 TLS.backendFlush = return ()

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

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

365+#else

329 , TLS.backendClose = close s

366 , TLS.backendClose = close s

367+#endif

330 , TLS.backendSend = sendAll' s

368 , TLS.backendSend = sendAll' s

331 , TLS.backendRecv = recvN

369 , TLS.backendRecv = recvN

332 }

370 }

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

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

334 throwIO ConnectionClosedByPeer

372 throwIO ConnectionClosedByPeer

335− conn ctx writeBuf ref = Connection {

373+ conn ctx writeBuf ref isH2 = Connection {

336 connSendMany = TLS.sendData ctx . L.fromChunks

374 connSendMany = TLS.sendData ctx . L.fromChunks

337 , connSendAll = sendall

375 , connSendAll = sendall

338 , connSendFile = sendfile

376 , connSendFile = sendfile

@@ -342,15 +380,24 @@ httpOverTls TLSSettings{..} s bs0 params = do

342 , connRecvBuf = recvBuf ref

380 , connRecvBuf = recvBuf ref

343 , connWriteBuffer = writeBuf

381 , connWriteBuffer = writeBuf

344 , connBufferSize = bufferSize

382 , connBufferSize = bufferSize

383+ , connHTTP2 = isH2

345 }

384 }

346 where

385 where

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

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

348 sendfile fid offset len hook headers =

387 sendfile fid offset len hook headers =

349 readSendFile writeBuf bufferSize sendall fid offset len hook headers

388 readSendFile writeBuf bufferSize sendall fid offset len hook headers

350

389

351− close' = void (tryIO $ TLS.bye ctx) `finally`

390+ close' = void (tryIO sendBye) `finally`

352 TLS.contextClose ctx

391 TLS.contextClose ctx

353

392

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+

354 -- TLS version of recv with a cache for leftover input data.

401 -- TLS version of recv with a cache for leftover input data.

355 -- The cache is shared with recvBuf.

402 -- The cache is shared with recvBuf.

356 recv cref = do

403 recv cref = do

@@ -418,11 +465,16 @@ getTLSinfo ctx = do

418 TLS.TLS10 -> (3,1)

465 TLS.TLS10 -> (3,1)

419 TLS.TLS11 -> (3,2)

466 TLS.TLS11 -> (3,2)

420 TLS.TLS12 -> (3,3)

467 TLS.TLS12 -> (3,3)

468+#if MIN_VERSION_tls(1,5,0)

469+ TLS.TLS13 -> (3,4)

470+#endif

471+ clientCert <- TLS.getClientCertificateChain ctx

421 return TLS {

472 return TLS {

422 tlsMajorVersion = major

473 tlsMajorVersion = major

423 , tlsMinorVersion = minor

474 , tlsMinorVersion = minor

424 , tlsNegotiatedProtocol = proto

475 , tlsNegotiatedProtocol = proto

425 , tlsChiperID = TLS.cipherID infoCipher

476 , tlsChiperID = TLS.cipherID infoCipher

477+ , tlsClientCertificate = clientCert

426 }

478 }

427

479

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

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

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

430

482

431----------------------------------------------------------------

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

432

484

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

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

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

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

435 AllowInsecure -> do

487 AllowInsecure -> do

436− conn' <- socketConnection s

488+ conn' <- socketConnection set s

437 cachedRef <- I.newIORef bs0

489 cachedRef <- I.newIORef bs0

438 let conn'' = conn'

490 let conn'' = conn'

439 { connRecv = recvPlain cachedRef (connRecv conn')

491 { connRecv = recvPlain cachedRef (connRecv conn')

warp-tls/warp-tls.cabal+12−6

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

1Name: warp-tls

2−Version: 3.2.4

2+Version: 3.2.11

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

4License: MIT

5License-file: LICENSE

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

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

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >=1.6

11+Cabal-Version: >= 1.10

12Stability: Stable

13description: SSLv1 and SSLv2 are obsoleted by IETF.

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

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

18extra-source-files: ChangeLog.md README.md

19

20Library

21− Build-Depends: base >= 4 && < 5

21+ Build-Depends: base >= 4.10 && < 5

22 , bytestring >= 0.9

23 , wai >= 3.2 && < 3.3

24− , warp >= 3.2.10 && < 3.3

24+ , warp >= 3.3.6 && < 3.4

25 , data-default-class >= 0.0.1

26− , tls >= 1.3.10

26+ , tls >= 1.5.3

27 , cryptonite >= 0.12

28 , network >= 2.2.1

29 , streaming-commons

30− , tls-session-manager >= 0.0.0.1

30+ , tls-session-manager >= 0.0.4

31 Exposed-modules: Network.Wai.Handler.WarpTLS

32 ghc-options: -Wall

33+ if os(windows)

34+ Cpp-Options: -DWINDOWS

35+ if impl(ghc >= 8)

36+ Default-Extensions: Strict StrictData

37+ Default-Language: Haskell2010

38+

33

39

34source-repository head

40source-repository head

35 type: git

41 type: git

warp/ChangeLog.md+150

@@ -1,3 +1,153 @@

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+

1## 3.2.13

151## 3.2.13

2

152

3* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)

153* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)

warp/Network/Wai/Handler/Warp.hs+72−6

@@ -72,6 +72,9 @@ module Network.Wai.Handler.Warp (

72 , setLogger

73 , setServerPushLogger

74 , setGracefulShutdownTimeout

75+ , setGracefulCloseTimeout1

76+ , setGracefulCloseTimeout2

77+ , setMaxTotalHeaderLength

75 -- ** Getters

78 -- ** Getters

76 , getPort

79 , getPort

77 , getHost

80 , getHost

@@ -79,6 +82,8 @@ module Network.Wai.Handler.Warp (

79 , getOnClose

82 , getOnClose

80 , getOnException

83 , getOnException

81 , getGracefulShutdownTimeout

84 , getGracefulShutdownTimeout

85+ , getGracefulCloseTimeout1

86+ , getGracefulCloseTimeout2

82 -- ** Exception handler

87 -- ** Exception handler

83 , defaultOnException

88 , defaultOnException

84 , defaultShouldDisplayException

89 , defaultShouldDisplayException

@@ -93,6 +98,7 @@ module Network.Wai.Handler.Warp (

93 , pauseTimeout

98 , pauseTimeout

94 , FileInfo(..)

99 , FileInfo(..)

95 , getFileInfo

100 , getFileInfo

101+ , clientCertificate

96 , withApplication

102 , withApplication

97 , withApplicationSettings

103 , withApplicationSettings

98 , testWithApplication

104 , testWithApplication

@@ -119,21 +125,22 @@ module Network.Wai.Handler.Warp (

119 ) where

125 ) where

120

126

121import Control.Exception (SomeException, throwIO)

127import Control.Exception (SomeException, throwIO)

122−import Data.ByteString (ByteString)

123−import Data.Maybe (fromMaybe)

124import Data.Streaming.Network (HostPreference)

128import Data.Streaming.Network (HostPreference)

125import qualified Data.Vault.Lazy as Vault

129import qualified Data.Vault.Lazy as Vault

130+import Data.X509

126import qualified Network.HTTP.Types as H

131import qualified Network.HTTP.Types as H

127import Network.Socket (SockAddr)

132import Network.Socket (SockAddr)

128import Network.Wai (Request, Response, vault)

133import Network.Wai (Request, Response, vault)

134+import System.TimeManager

135+

129import Network.Wai.Handler.Warp.FileInfoCache

136import 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

130import Network.Wai.Handler.Warp.Request

140import Network.Wai.Handler.Warp.Request

131import Network.Wai.Handler.Warp.Response (warpVersion)

141import Network.Wai.Handler.Warp.Response (warpVersion)

132import Network.Wai.Handler.Warp.Run

142import Network.Wai.Handler.Warp.Run

133import Network.Wai.Handler.Warp.Settings

143import 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

137import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

144import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

138import Network.Wai.Handler.Warp.WithApplication

145import Network.Wai.Handler.Warp.WithApplication

139

146

@@ -296,6 +303,18 @@ getGracefulShutdownTimeout = settingsGracefulShutdownTimeout

296-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

303-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

297-- @

304-- @

298--

305--

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+--

299-- Default: does not install any code.

318-- Default: does not install any code.

300--

319--

301-- Since 3.0.1

320-- Since 3.0.1

@@ -366,7 +385,7 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }

366--

385--

367-- WARNING: This is contrary to the PROXY protocol specification and

386-- WARNING: This is contrary to the PROXY protocol specification and

368-- using it can indicate a security problem with your

387-- using it can indicate a security problem with your

369−-- architecture if the web server is directly accessable

388+-- architecture if the web server is directly accessible

370-- to the public, since it would allow easy IP address

389-- to the public, since it would allow easy IP address

371-- spoofing. However, it can be useful in some cases,

390-- spoofing. However, it can be useful in some cases,

372-- such as if a load balancer health check uses regular

391-- such as if a load balancer health check uses regular

@@ -409,11 +428,22 @@ setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }

409-- wait indefinitely, and a number, if provided, will be treated as seconds

428-- wait indefinitely, and a number, if provided, will be treated as seconds

410-- to wait for requests to finish, before shutting down the server entirely.

429-- to wait for requests to finish, before shutting down the server entirely.

411--

430--

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+--

412-- Since 3.2.8

435-- Since 3.2.8

413setGracefulShutdownTimeout :: Maybe Int

436setGracefulShutdownTimeout :: Maybe Int

414 -> Settings -> Settings

437 -> Settings -> Settings

415setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

416

439

440+-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.

441+--

442+-- Since 3.3.8

443+setMaxTotalHeaderLength :: Int -> Settings -> Settings

444+setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445+ { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446+

417-- | Explicitly pause the slowloris timeout.

447-- | Explicitly pause the slowloris timeout.

418--

448--

419-- This is useful for cases where you partially consume a request body. For

449-- This is useful for cases where you partially consume a request body. For

@@ -441,3 +471,39 @@ pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

441-- Since 3.1.10

471-- Since 3.1.10

442getFileInfo :: Request -> FilePath -> IO FileInfo

472getFileInfo :: Request -> FilePath -> IO FileInfo

443getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

473getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

474+

475+-- | A timeout to limit the time (in milliseconds) waiting for

476+-- FIN for HTTP/1.x. 0 means uses immediate close.

477+-- Default: 0.

478+--

479+-- Since 3.3.5

480+setGracefulCloseTimeout1 :: Int -> Settings -> Settings

481+setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }

482+

483+-- | A timeout to limit the time (in milliseconds) waiting for

484+-- FIN for HTTP/1.x. 0 means uses immediate close.

485+--

486+-- Since 3.3.5

487+getGracefulCloseTimeout1 :: Settings -> Int

488+getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489+

490+-- | A timeout to limit the time (in milliseconds) waiting for

491+-- FIN for HTTP/2. 0 means uses immediate close.

492+-- Default: 2000.

493+--

494+-- Since 3.3.5

495+setGracefulCloseTimeout2 :: Int -> Settings -> Settings

496+setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }

497+

498+-- | A timeout to limit the time (in milliseconds) waiting for

499+-- FIN for HTTP/2. 0 means uses immediate close.

500+--

501+-- Since 3.3.5

502+getGracefulCloseTimeout2 :: Settings -> Int

503+getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504+

505+-- | Getting information of client certificate.

506+--

507+-- Since 3.3.5

508+clientCertificate :: Request -> Maybe CertificateChain

509+clientCertificate = join . Vault.lookup getClientCertificateKey . vault

warp/Network/Wai/Handler/Warp/Buffer.hs+4−2

@@ -1,4 +1,4 @@

1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}

1+{-# LANGUAGE BangPatterns #-}

2

3module Network.Wai.Handler.Warp.Buffer (

4 bufferSize

@@ -13,13 +13,15 @@ module Network.Wai.Handler.Warp.Buffer (

13 ) where

14

15import qualified Data.ByteString as BS

16−import Data.ByteString.Internal (ByteString(..), memcpy)

16+import Data.ByteString.Internal (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

23import Network.Wai.Handler.Warp.Types

25import Network.Wai.Handler.Warp.Types

24

26

25----------------------------------------------------------------

27----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Conduit.hs+2−6

@@ -3,14 +3,10 @@

3module Network.Wai.Handler.Warp.Conduit where

4

5import Control.Exception

6−import Control.Monad (when, unless)

7−import Data.ByteString (ByteString)

8import qualified Data.ByteString as S

6import qualified Data.ByteString as S

9import qualified Data.IORef as I

7import qualified Data.IORef as I

10−#if __GLASGOW_HASKELL__ < 709

8+

11−import Data.Word (Word)

9+import Network.Wai.Handler.Warp.Imports

12−#endif

13−import Data.Word (Word8)

14import Network.Wai.Handler.Warp.Types

10import Network.Wai.Handler.Warp.Types

15

11

16----------------------------------------------------------------

12----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Counter.hs+3−4

@@ -8,11 +8,10 @@ module Network.Wai.Handler.Warp.Counter (

8 , decrease

9 ) where

10

11−#if __GLASGOW_HASKELL__ < 709

12−import Control.Applicative ((<$>))

13−#endif

14import Control.Concurrent.STM

11import Control.Concurrent.STM

15−import Control.Monad (unless)

12+

13+import Network.Wai.Handler.Warp.Imports

14+

16

15

17newtype Counter = Counter (TVar Int)

16newtype Counter = Counter (TVar Int)

18

17

warp/Network/Wai/Handler/Warp/Date.hs+1−4

@@ -5,11 +5,8 @@ module Network.Wai.Handler.Warp.Date (

5 , GMTDate

6 ) where

7

8−#if __GLASGOW_HASKELL__ < 709

9−import Control.Applicative

10−#endif

11import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

8import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

12−import Data.ByteString.Char8

9+import Data.ByteString

13import Network.HTTP.Date

10import Network.HTTP.Date

14

11

15#if WINDOWS

12#if WINDOWS

warp/Network/Wai/Handler/Warp/FdCache.hs+20−27

@@ -14,39 +14,34 @@ module Network.Wai.Handler.Warp.FdCache (

14 ) where

15

16#ifndef WINDOWS

17−#if __GLASGOW_HASKELL__ < 709

18−import Control.Applicative ((<$>), (<*>))

19−#endif

20import Control.Exception (bracket)

17import Control.Exception (bracket)

21−import Network.Wai.Handler.Warp.IORef

22−import Network.Wai.Handler.Warp.MultiMap

23import Control.Reaper

18import Control.Reaper

19+import Data.IORef

20+import Network.Wai.Handler.Warp.MultiMap as MM

24import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)

21import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)

25#endif

22#endif

26import System.Posix.Types (Fd)

23import System.Posix.Types (Fd)

27

24

28----------------------------------------------------------------

25----------------------------------------------------------------

29

26

30−type Hash = Int

31−

32-- | An action to activate a Fd cache entry.

27-- | An action to activate a Fd cache entry.

33type Refresh = IO ()

28type Refresh = IO ()

34

29

35−getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)

30+getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)

36−getFdNothing _ _ = return (Nothing, return ())

31+getFdNothing _ = return (Nothing, return ())

37

32

38----------------------------------------------------------------

33----------------------------------------------------------------

39

34

40-- | Creating 'MutableFdCache' and executing the action in the second

35-- | Creating 'MutableFdCache' and executing the action in the second

41-- argument. The first argument is a cache duration in second.

36-- argument. The first argument is a cache duration in second.

42−withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

37+withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

43#ifdef WINDOWS

38#ifdef WINDOWS

44withFdCache _ action = action getFdNothing

39withFdCache _ action = action getFdNothing

45#else

40#else

46withFdCache 0 action = action getFdNothing

41withFdCache 0 action = action getFdNothing

47withFdCache duration action = bracket (initialize duration)

42withFdCache duration action = bracket (initialize duration)

48 terminate

43 terminate

49− (\mfc -> action (getFd mfc))

44+ (action . getFd)

50

45

51----------------------------------------------------------------

46----------------------------------------------------------------

52

47

@@ -68,7 +63,7 @@ inactive (MutableStatus ref) = writeIORef ref Inactive

68

63

69----------------------------------------------------------------

64----------------------------------------------------------------

70

65

71−data FdEntry = FdEntry !FilePath !Fd !MutableStatus

66+data FdEntry = FdEntry !Fd !MutableStatus

72

67

73openFile :: FilePath -> IO Fd

68openFile :: FilePath -> IO Fd

74openFile path = do

69openFile path = do

@@ -80,25 +75,23 @@ closeFile :: Fd -> IO ()

80closeFile = closeFd

75closeFile = closeFd

81

76

82newFdEntry :: FilePath -> IO FdEntry

77newFdEntry :: FilePath -> IO FdEntry

83−newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus

78+newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus

84

79

85setFileCloseOnExec :: Fd -> IO ()

80setFileCloseOnExec :: Fd -> IO ()

86setFileCloseOnExec fd = setFdOption fd CloseOnExec True

81setFileCloseOnExec fd = setFdOption fd CloseOnExec True

87

82

88----------------------------------------------------------------

83----------------------------------------------------------------

89

84

90−type FdCache = MMap FdEntry

85+type FdCache = MultiMap FdEntry

91

86

92-- | Mutable Fd cacher.

87-- | Mutable Fd cacher.

93−newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))

88+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))

94

89

95fdCache :: MutableFdCache -> IO FdCache

90fdCache :: MutableFdCache -> IO FdCache

96fdCache (MutableFdCache reaper) = reaperRead reaper

91fdCache (MutableFdCache reaper) = reaperRead reaper

97

92

98−look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)

93+look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)

99−look mfc path key = searchWith key check <$> fdCache mfc

94+look mfc path = MM.lookup path <$> fdCache mfc

100− where

101− check (FdEntry path' _ _) = path == path'

102

95

103----------------------------------------------------------------

96----------------------------------------------------------------

104

97

@@ -119,7 +112,7 @@ clean old = do

119 new <- pruneWith old prune

112 new <- pruneWith old prune

120 return $ merge new

113 return $ merge new

121 where

114 where

122− prune (FdEntry _ fd mst) = status mst >>= act

115+ prune (_,FdEntry fd mst) = status mst >>= act

123 where

116 where

124 act Active = inactive mst >> return True

117 act Active = inactive mst >> return True

125 act Inactive = closeFd fd >> return False

118 act Inactive = closeFd fd >> return False

@@ -129,21 +122,21 @@ clean old = do

129terminate :: MutableFdCache -> IO ()

122terminate :: MutableFdCache -> IO ()

130terminate (MutableFdCache reaper) = do

123terminate (MutableFdCache reaper) = do

131 !t <- reaperStop reaper

124 !t <- reaperStop reaper

132− mapM_ closeIt $ toList t

125+ mapM_ (closeIt . snd) $ toList t

133 where

126 where

134− closeIt (FdEntry _ fd _) = closeFd fd

127+ closeIt (FdEntry fd _) = closeFd fd

135

128

136----------------------------------------------------------------

129----------------------------------------------------------------

137

130

138-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

131-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

139−getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)

132+getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)

140−getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get

133+getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get

141 where

134 where

142 get Nothing = do

135 get Nothing = do

143− ent@(FdEntry _ fd mst) <- newFdEntry path

136+ ent@(FdEntry fd mst) <- newFdEntry path

144− reaperAdd reaper (h, ent)

137+ reaperAdd reaper (path,ent)

145 return (Just fd, refresh mst)

138 return (Just fd, refresh mst)

146− get (Just (FdEntry _ fd mst)) = do

139+ get (Just (FdEntry fd mst)) = do

147 refresh mst

140 refresh mst

148 return (Just fd, refresh mst)

141 return (Just fd, refresh mst)

149#endif

142#endif

warp/Network/Wai/Handler/Warp/File.hs+12−10

@@ -9,19 +9,18 @@ module Network.Wai.Handler.Warp.File (

9 , H.parseByteRanges

10 ) where

11

12−import Control.Applicative ((<|>))

13import Data.Array ((!))

12import Data.Array ((!))

14−import qualified Data.ByteString.Char8 as B (pack)

13+import qualified Data.ByteString.Char8 as C8 (pack)

15−import Data.ByteString (ByteString)

16−import Data.Maybe (fromMaybe)

17import Network.HTTP.Date

14import Network.HTTP.Date

18import qualified Network.HTTP.Types as H

15import qualified Network.HTTP.Types as H

19import qualified Network.HTTP.Types.Header as H

16import qualified Network.HTTP.Types.Header as H

20import Network.Wai

17import Network.Wai

18+

21import qualified Network.Wai.Handler.Warp.FileInfoCache as I

19import qualified Network.Wai.Handler.Warp.FileInfoCache as I

22import Network.Wai.Handler.Warp.Header

20import Network.Wai.Handler.Warp.Header

21+import Network.Wai.Handler.Warp.Imports

23import Network.Wai.Handler.Warp.PackInt

22import Network.Wai.Handler.Warp.PackInt

24−import Numeric (showInt)

23+

25

24

26-- $setup

25-- $setup

27-- >>> import Test.QuickCheck

26-- >>> import Test.QuickCheck

@@ -35,12 +34,15 @@ data RspFileInfo = WithoutBody H.Status

35----------------------------------------------------------------

34----------------------------------------------------------------

36

35

37conditionalRequest :: I.FileInfo

36conditionalRequest :: I.FileInfo

38− -> H.ResponseHeaders -> IndexedHeader

37+ -> H.ResponseHeaders

38+ -> IndexedHeader -- ^ Response

39+ -> IndexedHeader -- ^ Request

39 -> RspFileInfo

40 -> RspFileInfo

40−conditionalRequest finfo hs0 reqidx = case condition of

41+conditionalRequest finfo hs0 rspidx reqidx = case condition of

41 nobody@(WithoutBody _) -> nobody

42 nobody@(WithoutBody _) -> nobody

43+ WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size

44+ !hasLM = isJust $ rspidx ! fromEnum ResLastModified

42− WithBody s _ off len -> let !hs = (H.hLastModified,date) :

45+ !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1

43− addContentHeaders hs0 off len size

44 in WithBody s hs off len

46 in WithBody s hs off len

45 where

47 where

46 !mtime = I.fileInfoTime finfo

48 !mtime = I.fileInfoTime finfo

@@ -117,7 +119,7 @@ checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)

117contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

119contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

118contentRangeHeader beg end total = (H.hContentRange, range)

120contentRangeHeader beg end total = (H.hContentRange, range)

119 where

121 where

120− range = B.pack

122+ range = C8.pack

121 -- building with ShowS

123 -- building with ShowS

122 $ 'b' : 'y': 't' : 'e' : 's' : ' '

124 $ 'b' : 'y': 't' : 'e' : 's' : ' '

123 : (if beg > end then ('*':) else

125 : (if beg > end then ('*':) else

warp/Network/Wai/Handler/Warp/FileInfoCache.hs+23−26

@@ -2,24 +2,21 @@

2

3module Network.Wai.Handler.Warp.FileInfoCache (

4 FileInfo(..)

5− , Hash

6 , withFileInfoCache

5 , withFileInfoCache

7 , getInfo -- test purpose only

6 , getInfo -- test purpose only

8 ) where

7 ) where

9

8

10import Control.Exception as E

9import Control.Exception as E

11−import Control.Monad (void)

12import Control.Reaper

10import Control.Reaper

13−import Data.ByteString (ByteString)

14import Network.HTTP.Date

11import Network.HTTP.Date

12+import System.PosixCompat.Files

13+

15import Network.Wai.Handler.Warp.HashMap (HashMap)

14import Network.Wai.Handler.Warp.HashMap (HashMap)

16import qualified Network.Wai.Handler.Warp.HashMap as M

15import qualified Network.Wai.Handler.Warp.HashMap as M

17−import System.PosixCompat.Files

16+import Network.Wai.Handler.Warp.Imports

18

17

19----------------------------------------------------------------

18----------------------------------------------------------------

20

19

21−type Hash = Int

22−

23-- | File information.

20-- | File information.

24data FileInfo = FileInfo {

21data FileInfo = FileInfo {

25 fileInfoName :: !FilePath

22 fileInfoName :: !FilePath

@@ -29,8 +26,8 @@ data FileInfo = FileInfo {

29 } deriving (Eq, Show)

26 } deriving (Eq, Show)

30

27

31data Entry = Negative | Positive FileInfo

28data Entry = Negative | Positive FileInfo

32−type Cache = HashMap FilePath Entry

29+type Cache = HashMap Entry

33−type FileInfoCache = Reaper Cache (Int,FilePath,Entry)

30+type FileInfoCache = Reaper Cache (FilePath,Entry)

34

31

35----------------------------------------------------------------

32----------------------------------------------------------------

36

33

@@ -54,29 +51,29 @@ getInfo path = do

54 else

51 else

55 throwIO (userError "FileInfoCache:getInfo")

52 throwIO (userError "FileInfoCache:getInfo")

56

53

57−getInfoNaive :: Hash -> FilePath -> IO FileInfo

54+getInfoNaive :: FilePath -> IO FileInfo

58−getInfoNaive _ = getInfo

55+getInfoNaive = getInfo

59

56

60----------------------------------------------------------------

57----------------------------------------------------------------

61

58

62−getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

59+getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo

63−getAndRegisterInfo reaper@Reaper{..} h path = do

60+getAndRegisterInfo reaper@Reaper{..} path = do

64 cache <- reaperRead

61 cache <- reaperRead

65− case M.lookup h path cache of

62+ case M.lookup path cache of

66 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

63 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

67 Just (Positive x) -> return x

64 Just (Positive x) -> return x

68− Nothing -> positive reaper h path

65+ Nothing -> positive reaper path

69− `E.onException` negative reaper h path

66+ `E.onException` negative reaper path

70

67

71−positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

68+positive :: FileInfoCache -> FilePath -> IO FileInfo

72−positive Reaper{..} h path = do

69+positive Reaper{..} path = do

73 info <- getInfo path

70 info <- getInfo path

74− reaperAdd (h, path, Positive info)

71+ reaperAdd (path, Positive info)

75 return info

72 return info

76

73

77−negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

74+negative :: FileInfoCache -> FilePath -> IO FileInfo

78−negative Reaper{..} h path = do

75+negative Reaper{..} path = do

79− reaperAdd (h, path,Negative)

76+ reaperAdd (path, Negative)

80 throwIO (userError "FileInfoCache:negative")

77 throwIO (userError "FileInfoCache:negative")

81

78

82----------------------------------------------------------------

79----------------------------------------------------------------

@@ -85,22 +82,22 @@ negative Reaper{..} h path = do

85-- and executing the action in the second argument.

82-- and executing the action in the second argument.

86-- The first argument is a cache duration in second.

83-- The first argument is a cache duration in second.

87withFileInfoCache :: Int

84withFileInfoCache :: Int

88− -> ((Hash -> FilePath -> IO FileInfo) -> IO a)

85+ -> ((FilePath -> IO FileInfo) -> IO a)

89 -> IO a

86 -> IO a

90withFileInfoCache 0 action = action getInfoNaive

87withFileInfoCache 0 action = action getInfoNaive

91withFileInfoCache duration action =

88withFileInfoCache duration action =

92 E.bracket (initialize duration)

89 E.bracket (initialize duration)

93 terminate

90 terminate

94− (\r -> action (getAndRegisterInfo r))

91+ (action . getAndRegisterInfo)

95

92

96−initialize :: Hash -> IO FileInfoCache

93+initialize :: Int -> IO FileInfoCache

97initialize duration = mkReaper settings

94initialize duration = mkReaper settings

98 where

95 where

99 settings = defaultReaperSettings {

96 settings = defaultReaperSettings {

100 reaperAction = override

97 reaperAction = override

101 , reaperDelay = duration

98 , reaperDelay = duration

102− , reaperCons = \(h,k,v) -> M.insert h k v

99+ , reaperCons = \(path,v) -> M.insert path v

103− , reaperNull = M.null

100+ , reaperNull = M.isEmpty

104 , reaperEmpty = M.empty

101 , reaperEmpty = M.empty

105 }

102 }

106

103

warp/Network/Wai/Handler/Warp/HTTP2.hs+72−56

@@ -1,69 +1,85 @@

1−{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE PatternGuards #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

3

6

4−module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where

7+module Network.Wai.Handler.Warp.HTTP2 (http2) where

5

8

6−import Control.Concurrent (forkIO, killThread)

9+import qualified Data.IORef as I

7import qualified Control.Exception as E

10import qualified Control.Exception as E

8−import Control.Monad (when, unless, replicateM_)

9−import Data.ByteString (ByteString)

10−import Network.HTTP2

11+import qualified Network.HTTP2.Server as H2

11import Network.Socket (SockAddr)

12import Network.Socket (SockAddr)

12import Network.Wai

13import Network.Wai

13−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

14+import Network.Wai.Internal (ResponseReceived(..))

15+import qualified System.TimeManager as T

16+

14−import Network.Wai.Handler.Warp.HTTP2.Manager

17+import Network.Wai.Handler.Warp.HTTP2.File

15−import Network.Wai.Handler.Warp.HTTP2.Receiver

18+import Network.Wai.Handler.Warp.HTTP2.PushPromise

16import Network.Wai.Handler.Warp.HTTP2.Request

19import Network.Wai.Handler.Warp.HTTP2.Request

17−import Network.Wai.Handler.Warp.HTTP2.Sender

20+import Network.Wai.Handler.Warp.HTTP2.Response

18−import Network.Wai.Handler.Warp.HTTP2.Types

21+import Network.Wai.Handler.Warp.Imports

19−import Network.Wai.Handler.Warp.HTTP2.Worker

20−import qualified Network.Wai.Handler.Warp.Settings as S (Settings)

22+import qualified Network.Wai.Handler.Warp.Settings as S

21import Network.Wai.Handler.Warp.Types

23import Network.Wai.Handler.Warp.Types

22

24

23----------------------------------------------------------------

25----------------------------------------------------------------

24

26

25−http2 :: Connection -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()

27+http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> (ByteString -> IO ()) -> Application -> IO ()

26−http2 conn ii1 addr transport settings readN app = do

28+http2 conn transport ii addr settings readN send app =

27− checkTLS

29+ H2.run conf http2server

28− ok <- checkPreface

29− when ok $ do

30− ctx <- newContext

31− -- Workers, worker manager and timer manager

32− mgr <- start settings

33− let responder = response settings ctx mgr

34− action = worker ctx settings app responder

35− setAction mgr action

36− -- The number of workers is 3.

37− -- This was carefully chosen based on a lot of benchmarks.

38− -- If it is 1, we cannot avoid head-of-line blocking.

39− -- If it is large, huge memory is consumed and many

40− -- context switches happen.

41− replicateM_ 3 $ spawnAction mgr

42− -- Receiver

43− let mkreq = mkRequest ii1 settings addr

44− tid <- forkIO $ frameReceiver ctx mkreq readN

45− -- Sender

46− -- frameSender is the main thread because it ensures to send

47− -- a goway frame.

48− frameSender ctx conn settings mgr `E.finally` do

49− clearContext ctx

50− stop mgr

51− killThread tid

52 where

30 where

53− checkTLS = case transport of

31+ conf = H2.Config {

54− TCP -> return () -- direct

32+ confWriteBuffer = connWriteBuffer conn

55− tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"

33+ , confBufferSize = connBufferSize conn

56− tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

34+ , confSendAll = send

57− checkPreface = do

35+ , confReadN = readN

58− preface <- readN connectionPrefaceLength

36+ , confPositionReadMaker = pReadMaker ii

59− if connectionPreface /= preface then do

37+ }

60− goaway conn ProtocolError "Preface mismatch"

61− return False

62− else

63− return True

64

38

65−-- connClose must not be called here since Run:fork calls it

39+ http2server h2req aux response = do

66−goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()

40+ req <- toWAIRequest h2req aux

67−goaway Connection{..} etype debugmsg = connSendAll bytestream

41+ ref <- I.newIORef Nothing

42+ eResponseReceived <- E.try $ app req $ \rsp -> do

43+ h2rsp <- fromResponse settings ii req rsp

44+ pps <- fromPushPromises ii req

45+ I.writeIORef ref $ Just (h2rsp, pps)

46+ _ <- response h2rsp pps

47+ return ResponseReceived

48+ case eResponseReceived of

49+ Right ResponseReceived -> do

50+ Just (h2rsp, pps) <- I.readIORef ref

51+ logResponse h2rsp req

52+ mapM_ (logPushPromise req) pps

53+ Left e@(E.SomeException _)

54+ -- killed by the local worker manager

55+ | Just E.ThreadKilled <- E.fromException e -> return ()

56+ -- killed by the local timeout manager

57+ | Just T.TimeoutThread <- E.fromException e -> return ()

58+ | otherwise -> do

59+ S.settingsOnException settings (Just req) e

60+ let ersp = S.settingsOnExceptionResponse settings e

61+ h2rsp' <- fromResponse settings ii req ersp

62+ _ <- response h2rsp' []

63+ logResponse h2rsp' req

64+ return ()

65+

66+ toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport

67+ where

68+ !hdr = H2.requestHeaders h2req

69+ !bdy = H2.getRequestBodyChunk h2req

70+ !bdylen = H2.requestBodySize h2req

71+ !th = H2.auxTimeHandle aux

72+

73+ logResponse h2rsp req = logger req st msiz

68− where

74+ where

69− bytestream = goawayFrame 0 etype debugmsg

75+ !logger = S.settingsLogger settings

76+ !st = H2.responseStatus h2rsp

77+ !msiz = fromIntegral <$> H2.responseBodySize h2rsp

78+

79+ logPushPromise req pp = logger req path siz

80+ where

81+ !logger = S.settingsServerPushLogger settings

82+ !path = H2.promiseRequestPath pp

83+ !siz = case H2.responseBodySize $ H2.promiseResponse pp of

84+ Nothing -> 0

85+ Just s -> fromIntegral s

warp/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hsdeleted−35

@@ -1,35 +0,0 @@

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+23−152

@@ -1,159 +1,30 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE BangPatterns, RecordWildCards #-}

4

2

5−module Network.Wai.Handler.Warp.HTTP2.File (

3+module Network.Wai.Handler.Warp.HTTP2.File where

6− RspFileInfo(..)

7− , conditionalRequest

8− , addContentHeadersForFilePart

9− , H.parseByteRanges

10− ) where

11

4

12−import Control.Applicative ((<|>))

5+import Network.HTTP2.Server

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

24

6

25−-- $setup

7+import Network.Wai.Handler.Warp.Types

26−-- >>> import Test.QuickCheck

27

8

28−----------------------------------------------------------------

9+#ifdef WINDOWS

10+pReadMaker :: InternalInfo -> PositionReadMaker

11+pReadMaker _ = defaultPositionReadMaker

12+#else

13+import Network.Wai.Handler.Warp.FdCache

14+import Network.Wai.Handler.Warp.SendFile (positionRead)

29

15

30−data RspFileInfo = WithoutBody !H.Status

16+pReadMaker :: InternalInfo -> PositionReadMaker

31− | WithBody !H.Status !TokenHeaderList !Integer !Integer

17+pReadMaker ii path = do

32− deriving (Eq,Show)

18+ (mfd, refresh) <- getFd ii path

33−

19+ case mfd of

34−----------------------------------------------------------------

20+ Just fd -> return (pread fd, Refresher refresh)

35−

21+ Nothing -> do

36−conditionalRequest :: I.FileInfo

22+ fd <- openFile path

37− -> TokenHeaderList -- Response

23+ return (pread fd, Closer $ closeFile fd)

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

156 where

24 where

157− off = filePartOffset part

25+ pread :: Fd -> PositionRead

158− len = filePartByteCount part

26+ pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'

159− size = filePartFileSize part

27+ where

28+ bytes' = fromIntegral bytes

29+ off' = fromIntegral off

30+#endif

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hsdeleted−112

@@ -1,112 +0,0 @@

1−{-# LANGUAGE OverloadedStrings, BangPatterns #-}

2−{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

3−

4−module Network.Wai.Handler.Warp.HTTP2.HPACK (

5− hpackEncodeHeader

6− , hpackEncodeHeaderLoop

7− , hpackDecodeHeader

8− , just

9− , 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.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# LANGUAGE CPP, BangPatterns #-}

2−

3−-- | A thread pool manager.

4−-- The manager has responsibility to spawn and kill

5−-- worker threads.

6−module Network.Wai.Handler.Warp.HTTP2.Manager (

7− Manager

8− , start

9− , setAction

10− , stop

11− , spawnAction

12− , addMyId

13− , deleteMyId

14− ) where

15−

16−#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.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+

5+module Network.Wai.Handler.Warp.HTTP2.PushPromise where

6+

7+import qualified Control.Exception as E

8+import qualified Network.HTTP.Types as H

9+import qualified Network.HTTP2.Server as H2

10+

11+import Network.Wai

12+import Network.Wai.Handler.Warp.FileInfoCache

13+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

14+import Network.Wai.Handler.Warp.HTTP2.Types

15+import Network.Wai.Handler.Warp.Imports

16+import Network.Wai.Handler.Warp.Types

17+

18+fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]

19+fromPushPromises ii req = do

20+ mh2data <- getHTTP2Data req

21+ let pp = case mh2data of

22+ Nothing -> []

23+ Just h2data -> http2dataPushPromise h2data

24+ catMaybes <$> mapM (fromPushPromise ii) pp

25+

26+fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)

27+fromPushPromise ii (PushPromise path file rsphdr w) = do

28+ efinfo <- E.try $ getFileInfo ii file

29+ case efinfo of

30+ Left (_ex :: E.IOException) -> return Nothing

31+ Right finfo -> do

32+ let !siz = fromIntegral $ fileInfoSize finfo

33+ !fileSpec = H2.FileSpec file 0 siz

34+ !rsp = H2.responseFile H.ok200 rsphdr fileSpec

35+ !pp = H2.pushPromise path rsp w

36+ return $ Just pp

warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hsdeleted−400

@@ -1,400 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE BangPatterns #-}

4−{-# LANGUAGE CPP #-}

5−{-# LANGUAGE PatternGuards #-}

6−

7−module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where

8−

9−#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+28−31

@@ -1,56 +1,54 @@

1−{-# LANGUAGE OverloadedStrings, CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3

2

4module Network.Wai.Handler.Warp.HTTP2.Request (

3module Network.Wai.Handler.Warp.HTTP2.Request (

5− mkRequest

4+ toRequest

6− , MkReq

7 , getHTTP2Data

5 , getHTTP2Data

8 , setHTTP2Data

6 , setHTTP2Data

9 , modifyHTTP2Data

7 , modifyHTTP2Data

10 ) where

8 ) where

11

9

12−import Control.Applicative ((<|>))

13import Control.Arrow (first)

10import Control.Arrow (first)

14−import Data.ByteString (ByteString)

15−import qualified Data.ByteString.Char8 as B8

11+import qualified Data.ByteString.Char8 as C8

16−import Data.Maybe (fromJust)

12+import Data.IORef

17import qualified Data.Vault.Lazy as Vault

13import qualified Data.Vault.Lazy as Vault

18import Network.HPACK

14import Network.HPACK

19import Network.HPACK.Token

15import Network.HPACK.Token

20import qualified Network.HTTP.Types as H

16import qualified Network.HTTP.Types as H

21import Network.Socket (SockAddr)

17import Network.Socket (SockAddr)

22import Network.Wai

18import 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.HashMap (hashByteString)

24+import Network.Wai.Handler.Warp.Imports

25−import Network.Wai.Handler.Warp.IORef

26−import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)

25+import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey, getClientCertificateKey)

27import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

26import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

28−import qualified Network.Wai.Handler.Warp.Timeout as Timeout

29import Network.Wai.Handler.Warp.Types

27import Network.Wai.Handler.Warp.Types

30−import Network.Wai.Internal (Request(..))

31−import System.IO.Unsafe (unsafePerformIO)

32

28

33−type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)

29+type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request

30+

31+----------------------------------------------------------------

34

32

35−mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq

33+toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq

36−mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do

34+toRequest ii settings addr ht bodylen body th transport = do

37 ref <- newIORef Nothing

35 ref <- newIORef Nothing

38− mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)

36+ toRequest' ii settings addr ref ht bodylen body th transport

39

37

40−mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr

38+toRequest' :: InternalInfo -> S.Settings -> SockAddr

41 -> IORef (Maybe HTTP2Data)

39 -> IORef (Maybe HTTP2Data)

42− -> MkReq

40+ -> ToReq

43−mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)

41+toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req

44 where

42 where

45 !req = Request {

43 !req = Request {

46 requestMethod = colonMethod

44 requestMethod = colonMethod

47− , httpVersion = http2ver

45+ , httpVersion = H.http20

48 , rawPathInfo = rawPath

46 , rawPathInfo = rawPath

49 , pathInfo = H.decodePathSegments path

47 , pathInfo = H.decodePathSegments path

50 , rawQueryString = query

48 , rawQueryString = query

51 , queryString = H.parseQuery query

49 , queryString = H.parseQuery query

52 , requestHeaders = headers

50 , requestHeaders = headers

53− , isSecure = True

51+ , isSecure = isTransportSecure transport

54 , remoteHost = addr

52 , remoteHost = addr

55 , requestBody = body

53 , requestBody = body

56 , vault = vaultValue

54 , vault = vaultValue

@@ -76,22 +74,21 @@ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)

76 !mUserAgent = getHeaderValue tokenUserAgent reqvt

74 !mUserAgent = getHeaderValue tokenUserAgent reqvt

77 -- CONNECT request will have ":path" omitted, use ":authority" as unparsed

75 -- CONNECT request will have ":path" omitted, use ":authority" as unparsed

78 -- path instead so that it will have consistent behavior compare to HTTP 1.0

76 -- path instead so that it will have consistent behavior compare to HTTP 1.0

79− (unparsedPath,query) = B8.break (=='?') $ fromJust (mPath <|> mAuth)

77+ (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)

80 !path = H.extractPath unparsedPath

78 !path = H.extractPath unparsedPath

81 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

79 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

82− !h = hashByteString rawPath

80+ -- fixme: pauseTimeout. th is not available here.

83− !ii = toInternalInfo ii1 h

84− !th = threadHandle ii

85− !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

86− $ Vault.insert getFileInfoKey (getFileInfo ii)

81+ !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)

87 $ Vault.insert getHTTP2DataKey (readIORef ref)

82 $ Vault.insert getHTTP2DataKey (readIORef ref)

88 $ Vault.insert setHTTP2DataKey (writeIORef ref)

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

89 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

85+ $ Vault.insert pauseTimeoutKey (T.pause th)

86+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

90 Vault.empty

87 Vault.empty

91

88

92getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

89getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

93getHTTP2DataKey = unsafePerformIO Vault.newKey

90getHTTP2DataKey = unsafePerformIO Vault.newKey

94−{-# NOINLINE getHTTP2Data #-}

91+{-# NOINLINE getHTTP2DataKey #-}

95

92

96-- | Getting 'HTTP2Data' through vault of the request.

93-- | Getting 'HTTP2Data' through vault of the request.

97-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.

94-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.

@@ -104,7 +101,7 @@ getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of

104

101

105setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())

102setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())

106setHTTP2DataKey = unsafePerformIO Vault.newKey

103setHTTP2DataKey = unsafePerformIO Vault.newKey

107−{-# NOINLINE setHTTP2Data #-}

104+{-# NOINLINE setHTTP2DataKey #-}

108

105

109-- | Setting 'HTTP2Data' through vault of the request.

106-- | Setting 'HTTP2Data' through vault of the request.

110-- 'Application' or 'Middleware' should use this.

107-- 'Application' or 'Middleware' should use this.

@@ -117,7 +114,7 @@ setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of

117

114

118modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

115modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

119modifyHTTP2DataKey = unsafePerformIO Vault.newKey

116modifyHTTP2DataKey = unsafePerformIO Vault.newKey

120−{-# NOINLINE modifyHTTP2Data #-}

117+{-# NOINLINE modifyHTTP2DataKey #-}

121

118

122-- | Modifying 'HTTP2Data' through vault of the request.

119-- | Modifying 'HTTP2Data' through vault of the request.

123-- 'Application' or 'Middleware' should use this.

120-- 'Application' or 'Middleware' should use this.

warp/Network/Wai/Handler/Warp/HTTP2/Response.hsnew file+127

@@ -0,0 +1,127 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE BangPatterns #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+

6+module Network.Wai.Handler.Warp.HTTP2.Response (

7+ fromResponse

8+ ) where

9+

10+import qualified Control.Exception as E

11+import qualified Data.ByteString.Builder as BB

12+import qualified Network.HTTP.Types as H

13+import qualified Network.HTTP2.Server as H2

14+import Network.Wai hiding (responseFile, responseBuilder, responseStream)

15+import Network.Wai.Internal (Response(..))

16+

17+import Network.Wai.Handler.Warp.File

18+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

19+import Network.Wai.Handler.Warp.HTTP2.Types

20+import Network.Wai.Handler.Warp.Header

21+import qualified Network.Wai.Handler.Warp.Response as R

22+import qualified Network.Wai.Handler.Warp.Settings as S

23+import Network.Wai.Handler.Warp.Types

24+

25+----------------------------------------------------------------

26+

27+fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response

28+fromResponse settings ii req rsp = do

29+ date <- getDate ii

30+ h2rsp <- case rsp of

31+ ResponseFile st rsphdr path mpart -> do

32+ let rsphdr' = add date svr rsphdr

33+ responseFile st rsphdr' isHead path mpart ii reqhdr

34+ ResponseBuilder st rsphdr builder -> do

35+ let rsphdr' = add date svr rsphdr

36+ return $ responseBuilder st rsphdr' isHead builder

37+ ResponseStream st rsphdr strmbdy -> do

38+ let rsphdr' = add date svr rsphdr

39+ return $ responseStream st rsphdr' isHead strmbdy

40+ _ -> error "ResponseRaw is not supported in HTTP/2"

41+ mh2data <- getHTTP2Data req

42+ case mh2data of

43+ Nothing -> return h2rsp

44+ Just h2data -> do

45+ let !trailers = http2dataTrailers h2data

46+ return $ H2.setResponseTrailersMaker h2rsp trailers

47+ where

48+ !isHead = requestMethod req == H.methodHead

49+ !reqhdr = requestHeaders req

50+ !svr = S.settingsServerName settings

51+ add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr

52+ -- fixme: not adding svr if already exists

53+

54+----------------------------------------------------------------

55+

56+responseFile :: H.Status -> H.ResponseHeaders -> Bool

57+ -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders

58+ -> IO H2.Response

59+responseFile st rsphdr _ _ _ _ _

60+ | noBody st = return $ responseNoBody st rsphdr

61+

62+responseFile st rsphdr isHead path (Just fp) _ _ =

63+ return $ responseFile2XX st rsphdr isHead fileSpec

64+ where

65+ !off' = fromIntegral $ filePartOffset fp

66+ !bytes' = fromIntegral $ filePartByteCount fp

67+ !fileSpec = H2.FileSpec path off' bytes'

68+

69+responseFile _ rsphdr isHead path Nothing ii reqhdr = do

70+ efinfo <- E.try $ getFileInfo ii path

71+ case efinfo of

72+ Left (_ex :: E.IOException) -> return $ response404 rsphdr

73+ Right finfo -> do

74+ let reqidx = indexRequestHeader reqhdr

75+ rspidx = indexResponseHeader rsphdr

76+ case conditionalRequest finfo rsphdr rspidx reqidx of

77+ WithoutBody s -> return $ responseNoBody s rsphdr

78+ WithBody s rsphdr' off bytes -> do

79+ let !off' = fromIntegral off

80+ !bytes' = fromIntegral bytes

81+ !fileSpec = H2.FileSpec path off' bytes'

82+ return $ responseFile2XX s rsphdr' isHead fileSpec

83+

84+----------------------------------------------------------------

85+

86+responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response

87+responseFile2XX st rsphdr isHead fileSpec

88+ | isHead = responseNoBody st rsphdr

89+ | otherwise = H2.responseFile st rsphdr fileSpec

90+

91+----------------------------------------------------------------

92+

93+responseBuilder :: H.Status -> H.ResponseHeaders -> Bool

94+ -> BB.Builder

95+ -> H2.Response

96+responseBuilder st rsphdr isHead builder

97+ | noBody st = responseNoBody st rsphdr

98+ | isHead = responseNoBody st rsphdr

99+ | otherwise = H2.responseBuilder st rsphdr builder

100+

101+----------------------------------------------------------------

102+

103+responseStream :: H.Status -> H.ResponseHeaders -> Bool

104+ -> StreamingBody

105+ -> H2.Response

106+responseStream st rsphdr isHead strmbdy

107+ | noBody st = responseNoBody st rsphdr

108+ | isHead = responseNoBody st rsphdr

109+ | otherwise = H2.responseStreaming st rsphdr strmbdy

110+

111+----------------------------------------------------------------

112+

113+responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response

114+responseNoBody st rsphdr = H2.responseNoBody st rsphdr

115+

116+----------------------------------------------------------------

117+

118+response404 :: H.ResponseHeaders -> H2.Response

119+response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body

120+ where

121+ !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr

122+ !body = BB.byteString "File not found"

123+

124+----------------------------------------------------------------

125+

126+noBody :: H.Status -> Bool

127+noBody = not . R.hasBody

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hsdeleted−541

@@ -1,541 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE BangPatterns, CPP #-}

3−{-# LANGUAGE NamedFieldPuns #-}

4−

5−module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where

6−

7−#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+16−272

@@ -1,35 +1,18 @@

1+{-# LANGUAGE NamedFieldPuns #-}

1−{-# LANGUAGE OverloadedStrings, CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

3+{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE BangPatterns #-}

4

5module Network.Wai.Handler.Warp.HTTP2.Types where

6

7−import 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)

16import qualified Data.ByteString as BS

7import qualified Data.ByteString as BS

17−import Data.IntMap.Strict (IntMap, IntMap)

18−import qualified Data.IntMap.Strict as M

19import qualified Network.HTTP.Types as H

8import qualified Network.HTTP.Types as H

20−import Network.Wai (Request, FilePart)

21−import Network.Wai.Handler.Warp.HTTP2.Manager

22−import Network.Wai.Handler.Warp.IORef

23−import Network.Wai.Handler.Warp.Types

24−

25import Network.HTTP2

9import Network.HTTP2

26−import Network.HTTP2.Priority

10+import qualified Network.HTTP2.Server as H2

27−import Network.HPACK hiding (Buffer)

28

11

29−----------------------------------------------------------------

12+import Network.Wai.Handler.Warp.Imports

13+import Network.Wai.Handler.Warp.Types

30

14

31−http2ver :: H.HttpVersion

15+----------------------------------------------------------------

32−http2ver = H.HttpVersion 2 0

33

16

34isHTTP2 :: Transport -> Bool

17isHTTP2 :: Transport -> Bool

35isHTTP2 TCP = False

18isHTTP2 TCP = False

@@ -37,250 +20,7 @@ isHTTP2 tls = useHTTP2

37 where

20 where

38 useHTTP2 = case tlsNegotiatedProtocol tls of

21 useHTTP2 = case tlsNegotiatedProtocol tls of

39 Nothing -> False

22 Nothing -> False

40− Just proto -> "h2-" `BS.isPrefixOf` proto

23+ 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

284

24

285----------------------------------------------------------------

25----------------------------------------------------------------

286

26

@@ -292,17 +32,21 @@ data HTTP2Data = HTTP2Data {

292 --

32 --

293 -- Since: 3.2.7

33 -- Since: 3.2.7

294 http2dataPushPromise :: [PushPromise]

34 http2dataPushPromise :: [PushPromise]

35+ -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.

36+ --

295− -- Since: 3.2.8

37+ -- Since: 3.2.8 but the type changed in 3.3.0

296− , http2dataTrailers :: H.ResponseHeaders

38+ , http2dataTrailers :: H2.TrailersMaker

297− } deriving (Eq,Show)

39+ }

298

40

299-- | Default HTTP/2 specific data.

41-- | Default HTTP/2 specific data.

300--

42--

301-- Since: 3.2.7

43-- Since: 3.2.7

302defaultHTTP2Data :: HTTP2Data

44defaultHTTP2Data :: HTTP2Data

303−defaultHTTP2Data = HTTP2Data [] []

45+defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

304

46

305-- | HTTP/2 push promise or sever push.

47-- | HTTP/2 push promise or sever push.

48+-- This allows files only for backward-compatibility

49+-- while the HTTP/2 library supports other types.

306--

50--

307-- Since: 3.2.7

51-- Since: 3.2.7

308data PushPromise = PushPromise {

52data PushPromise = PushPromise {

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hsdeleted−320

@@ -1,320 +0,0 @@

1−{-# LANGUAGE NamedFieldPuns #-}

2−{-# LANGUAGE PatternGuards #-}

3−{-# LANGUAGE CPP #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE BangPatterns #-}

7−

8−module Network.Wai.Handler.Warp.HTTP2.Worker (

9− Responder

10− , response

11− , worker

12− ) where

13−

14−#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+26−16

@@ -1,6 +1,7 @@

1+{-# LANGUAGE BangPatterns #-}

2+

1module Network.Wai.Handler.Warp.HashMap where

3module Network.Wai.Handler.Warp.HashMap where

2

4

3−import Data.ByteString (ByteString)

4import Data.Hashable (hash)

5import Data.Hashable (hash)

5import Data.IntMap.Strict (IntMap)

6import Data.IntMap.Strict (IntMap)

6import qualified Data.IntMap.Strict as I

7import qualified Data.IntMap.Strict as I

@@ -8,25 +9,34 @@ import Data.Map.Strict (Map)

8import qualified Data.Map.Strict as M

9import qualified Data.Map.Strict as M

9import Prelude hiding (lookup)

10import Prelude hiding (lookup)

10

11

11−type Hash = Int

12+----------------------------------------------------------------

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.

12−newtype HashMap k v = HashMap (IntMap (Map k v))

20+newtype HashMap v = HashMap (IntMap (Map FilePath v))

13

21

14−hashByteString :: ByteString -> Hash

22+----------------------------------------------------------------

15−hashByteString = hash

16

23

17−empty :: HashMap k v

24+empty :: HashMap v

18−empty = HashMap $ I.empty

25+empty = HashMap I.empty

19

26

20−null :: HashMap k v -> Bool

27+isEmpty :: HashMap v -> Bool

21−null (HashMap hm) = I.null hm

28+isEmpty (HashMap hm) = I.null hm

22

29

30+----------------------------------------------------------------

31+

23−insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v

32+insert :: FilePath -> v -> HashMap v -> HashMap v

24−insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm

33+insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm

25 where

34 where

35+ !h = hash path

26− m = M.singleton k v

36+ !m = M.singleton path v

27 f = M.union -- fimxe

37 f = M.union -- fimxe

28−{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}

29

38

30−lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v

39+lookup :: FilePath -> HashMap v -> Maybe v

31−lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k

40+lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path

32−{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}

41+ where

42+ !h = hash path

warp/Network/Wai/Handler/Warp/Header.hs+3

@@ -7,6 +7,7 @@ import Data.Array.ST

7import qualified Data.ByteString as BS

8import Data.CaseInsensitive (foldedCase)

9import Network.HTTP.Types

10+

10import Network.Wai.Handler.Warp.Types

11import Network.Wai.Handler.Warp.Types

11

12

12----------------------------------------------------------------

13----------------------------------------------------------------

@@ -68,6 +69,7 @@ indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex

68data ResponseHeaderIndex = ResContentLength

69data ResponseHeaderIndex = ResContentLength

69 | ResServer

70 | ResServer

70 | ResDate

71 | ResDate

72+ | ResLastModified

71 deriving (Enum,Bounded)

73 deriving (Enum,Bounded)

72

74

73-- | The size for 'IndexedHeader' for HTTP Response.

75-- | The size for 'IndexedHeader' for HTTP Response.

@@ -78,6 +80,7 @@ responseKeyIndex :: HeaderName -> Int

78responseKeyIndex hn = case BS.length bs of

80responseKeyIndex hn = case BS.length bs of

79 4 -> if bs == "date" then fromEnum ResDate else -1

81 4 -> if bs == "date" then fromEnum ResDate else -1

80 6 -> if bs == "server" then fromEnum ResServer else -1

82 6 -> if bs == "server" then fromEnum ResServer else -1

83+ 13 -> if bs == "last-modified" then fromEnum ResLastModified else -1

81 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

84 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

82 _ -> -1

85 _ -> -1

83 where

86 where

warp/Network/Wai/Handler/Warp/IO.hs+2−1

@@ -3,10 +3,11 @@

3

4module Network.Wai.Handler.Warp.IO where

5

6−import Data.ByteString (ByteString)

7import Data.ByteString.Builder (Builder)

6import Data.ByteString.Builder (Builder)

8import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

7import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

8+

9import Network.Wai.Handler.Warp.Buffer

10+import Network.Wai.Handler.Warp.Imports

10import Network.Wai.Handler.Warp.Types

11import Network.Wai.Handler.Warp.Types

11

12

12toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

13toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

warp/Network/Wai/Handler/Warp/IORef.hsdeleted−26

@@ -1,26 +0,0 @@

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.hsnew file+27

@@ -0,0 +1,27 @@

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+7−2

@@ -53,7 +53,7 @@ module Network.Wai.Handler.Warp.Internal (

53 -- resumed as soon as we return from user code.

54 --

55 -- * Every time data is successfully sent to the client, the timeout is tickled.

56− , module Network.Wai.Handler.Warp.Timeout

56+ , module System.TimeManager

57 -- * File descriptor cache

58 , module Network.Wai.Handler.Warp.FdCache

59 -- * File information cache

@@ -64,8 +64,13 @@ module Network.Wai.Handler.Warp.Internal (

64 , Source

65 , recvRequest

66 , sendResponse

67+ -- * Platform dependent helper functions

68+ , setSocketCloseOnExec

69+ , windowsThreadBlockHack

67 ) where

70 ) where

68

71

72+import System.TimeManager

73+

69import Network.Wai.Handler.Warp.Buffer

74import Network.Wai.Handler.Warp.Buffer

70import Network.Wai.Handler.Warp.Date

75import Network.Wai.Handler.Warp.Date

71import Network.Wai.Handler.Warp.FdCache

76import Network.Wai.Handler.Warp.FdCache

@@ -77,5 +82,5 @@ import Network.Wai.Handler.Warp.Response

77import Network.Wai.Handler.Warp.Run

82import Network.Wai.Handler.Warp.Run

78import Network.Wai.Handler.Warp.SendFile

83import Network.Wai.Handler.Warp.SendFile

79import Network.Wai.Handler.Warp.Settings

84import Network.Wai.Handler.Warp.Settings

80−import Network.Wai.Handler.Warp.Timeout

81import Network.Wai.Handler.Warp.Types

85import Network.Wai.Handler.Warp.Types

86+import Network.Wai.Handler.Warp.Windows

warp/Network/Wai/Handler/Warp/MultiMap.hs+64−43

@@ -1,90 +1,111 @@

1−{-# LANGUAGE CPP, BangPatterns #-}

1+{-# LANGUAGE BangPatterns #-}

2

3module Network.Wai.Handler.Warp.MultiMap (

4− MMap

4+ MultiMap

5 , isEmpty

6 , empty

7 , singleton

8 , insert

9− , search

9+ , Network.Wai.Handler.Warp.MultiMap.lookup

10− , searchWith

11 , pruneWith

10 , pruneWith

12 , toList

11 , toList

13 , merge

12 , merge

14 ) where

13 ) where

15

14

16−#if __GLASGOW_HASKELL__ < 709

15+import Data.Hashable (hash)

17−import Control.Applicative ((<$>))

18−#endif

19import Data.IntMap.Strict (IntMap)

16import Data.IntMap.Strict (IntMap)

20import qualified Data.IntMap.Strict as I

17import qualified Data.IntMap.Strict as I

21−import qualified Network.Wai.Handler.Warp.Some as S

18+import Data.Semigroup

19+import Prelude -- Silence redundant import warnings

22

20

23----------------------------------------------------------------

21----------------------------------------------------------------

24

22

25−type MMap v = IntMap (S.Some v)

23+-- | 'MultiMap' is used for cache of file descriptors.

24+-- Since multiple threads would open file descriptors for

25+-- the same file simultaneously, multiple entries must

26+-- be contained for the file.

27+-- Since hash values of file pathes are used as outer keys,

28+-- collison would happen for multiple file pathes.

29+-- Becase only positive entries are contained,

30+-- a bad guy cannot be cause the hash collision intentinally.

31+-- So, lists are good enough.

32+newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])

26

33

27----------------------------------------------------------------

34----------------------------------------------------------------

28

35

29-- | O(1)

36-- | O(1)

30−isEmpty :: MMap v -> Bool

37+empty :: MultiMap v

31−isEmpty = I.null

38+empty = MultiMap $ I.empty

32

39

33-- | O(1)

40-- | O(1)

34−empty :: MMap v

41+isEmpty :: MultiMap v -> Bool

35−empty = I.empty

42+isEmpty (MultiMap mm) = I.null mm

36

43

37----------------------------------------------------------------

44----------------------------------------------------------------

38

45

39-- | O(1)

46-- | O(1)

40−singleton :: Int -> v -> MMap v

47+singleton :: FilePath -> v -> MultiMap v

48+singleton path v = MultiMap mm

49+ where

50+ !h = hash path

41−singleton k v = I.singleton k (S.singleton v)

51+ !mm = I.singleton h [(path,v)]

42

52

43----------------------------------------------------------------

53----------------------------------------------------------------

44

54

45−-- | O(log n)

55+-- | O(N)

46−search :: Int -> MMap v -> Maybe v

56+lookup :: FilePath -> MultiMap v -> Maybe v

47−search k m = case I.lookup k m of

57+lookup path (MultiMap mm) = case I.lookup h mm of

48 Nothing -> Nothing

58 Nothing -> Nothing

49− Just s -> Just $! S.top s

59+ Just s -> Prelude.lookup path s

50−

60+ where

51−-- | O(log n)

61+ !h = hash path

52−searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v

53−searchWith k f m = case I.lookup k m of

54− Nothing -> Nothing

55− Just s -> S.lookupWith f s

56

62

57----------------------------------------------------------------

63----------------------------------------------------------------

58

64

59-- | O(log n)

65-- | O(log n)

60−insert :: Int -> v -> MMap v -> MMap v

66+insert :: FilePath -> v -> MultiMap v -> MultiMap v

67+insert path v (MultiMap mm) = MultiMap mm'

68+ where

69+ !h = hash path

61−insert k v m = I.insertWith S.union k (S.singleton v) m

70+ !mm' = I.insertWith (<>) h [(path,v)] mm

62

71

63----------------------------------------------------------------

72----------------------------------------------------------------

64

73

65-- | O(n)

74-- | O(n)

66−toList :: MMap v -> [v]

75+toList :: MultiMap v -> [(FilePath,v)]

67−toList m = concatMap f $ I.toAscList m

76+toList (MultiMap mm) = concatMap snd $ I.toAscList mm

68− where

69− f (_,s) = S.toList s

70

77

71----------------------------------------------------------------

78----------------------------------------------------------------

72

79

73-- | O(n)

80-- | O(n)

74−pruneWith :: MMap v

81+pruneWith :: MultiMap v

75− -> (v -> IO Bool)

82+ -> ((FilePath,v) -> IO Bool)

76− -> IO (MMap v)

83+ -> IO (MultiMap v)

77−pruneWith m action = I.fromAscList <$> go (I.toDescList m) []

84+pruneWith (MultiMap mm) action = MultiMap <$> mm'

78 where

85 where

86+ !mm' = I.fromAscList <$> go (I.toDescList mm) []

79− go [] acc = return acc

87+ go [] !acc = return acc

80− go ((k,s):kss) acc = do

88+ go ((h,s):kss) !acc = do

81− mt <- S.prune action s

89+ rs <- prune action s

82− case mt of

90+ case rs of

83− Nothing -> go kss acc

91+ [] -> go kss acc

84− Just t -> go kss ((k,t) : acc)

92+ _ -> go kss ((h,rs) : acc)

85

93

86----------------------------------------------------------------

94----------------------------------------------------------------

87

95

88-- O(n + m) where N is the size of the second argument

96-- O(n + m) where N is the size of the second argument

89−merge :: MMap v -> MMap v -> MMap v

97+merge :: MultiMap v -> MultiMap v -> MultiMap v

98+merge (MultiMap m1) (MultiMap m2) = MultiMap mm

99+ where

90−merge m1 m2 = I.unionWith S.union m1 m2

100+ !mm = I.unionWith (<>) m1 m2

101+

102+----------------------------------------------------------------

103+

104+prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]

105+prune action xs0 = go xs0

106+ where

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)

6−import Data.ByteString.Internal (ByteString(..), unsafeCreate)

5+import Data.ByteString.Internal (unsafeCreate)

7−import Data.Word8 (Word8)

8import Foreign.Ptr (Ptr, plusPtr)

6import Foreign.Ptr (Ptr, plusPtr)

9import Foreign.Storable (poke)

7import Foreign.Storable (poke)

10import qualified Network.HTTP.Types as H

8import qualified Network.HTTP.Types as H

11

9

10+import Network.Wai.Handler.Warp.Imports

11+

12-- $setup

13−-- >>> import Data.ByteString.Char8 as B

13+-- >>> import Data.ByteString.Char8 as C8

14-- >>> import Test.QuickCheck (Large(..))

15

16-- |

17--

18−-- prop> packIntegral (abs n) == B.pack (show (abs n))

18+-- prop> packIntegral (abs n) == C8.pack (show (abs n))

19−-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == B.pack (show n')

19+-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.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)

17import qualified Data.ByteString as S

16import qualified Data.ByteString as S

18−import Data.Int (Int64)

19import GHC.Prim

17import GHC.Prim

20import GHC.Types

18import GHC.Types

21import GHC.Word

19import GHC.Word

22

20

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+44−17

@@ -9,23 +9,27 @@ module Network.Wai.Handler.Warp.Recv (

9 , spell

10 ) where

11

12−#if __GLASGOW_HASKELL__ < 709

13−import Control.Applicative ((<$>))

14−#endif

15import qualified Control.Exception as E

12import qualified Control.Exception as E

16import qualified Data.ByteString as BS

13import qualified Data.ByteString as BS

17−import Data.ByteString.Internal (ByteString(..))

14+import Data.IORef

18−import Data.Word (Word8)

19import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

15import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

20import Foreign.C.Types

16import Foreign.C.Types

21import Foreign.ForeignPtr (withForeignPtr)

17import Foreign.ForeignPtr (withForeignPtr)

22import Foreign.Ptr (Ptr, castPtr, plusPtr)

18import Foreign.Ptr (Ptr, castPtr, plusPtr)

23import GHC.Conc (threadWaitRead)

19import GHC.Conc (threadWaitRead)

20+import qualified GHC.IO.Exception as E

24−import Network.Socket (Socket, fdSocket)

21+import Network.Socket (Socket)

22+import qualified System.IO.Error as E

23+#if MIN_VERSION_network(3,1,0)

24+import Network.Socket (withFdSocket)

25+#else

26+import Network.Socket (fdSocket)

27+#endif

28+import System.Posix.Types (Fd(..))

29+

25import Network.Wai.Handler.Warp.Buffer

30import Network.Wai.Handler.Warp.Buffer

26−import Network.Wai.Handler.Warp.IORef

31+import Network.Wai.Handler.Warp.Imports

27import Network.Wai.Handler.Warp.Types

32import Network.Wai.Handler.Warp.Types

28−import System.Posix.Types (Fd(..))

29

33

30#ifdef mingw32_HOST_OS

34#ifdef mingw32_HOST_OS

31import GHC.IO.FD (FD(..), readRawBufferPtr)

35import GHC.IO.FD (FD(..), readRawBufferPtr)

@@ -92,24 +96,45 @@ spell init0 siz0 recv recvBuf

92 siz' = siz - len

96 siz' = siz - len

93 loop bss' siz'

97 loop bss' siz'

94

98

99+-- The timeout manager may close the socket.

100+-- In that case, an error of "Bad file descriptor" occurs.

101+-- We ignores it because we expect TimeoutThread.

95receive :: Socket -> BufferPool -> Recv

102receive :: Socket -> BufferPool -> Recv

96−receive sock pool = withBufferPool pool $ \ (ptr, size) -> do

103+receive sock pool = E.handle handler $ 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

97− let sock' = fdSocket sock

109+ let fd = fdSocket sock

110+#endif

98− size' = fromIntegral size

111+ let size' = fromIntegral size

99− fromIntegral <$> receiveloop sock' ptr size'

112+ fromIntegral <$> receiveloop fd ptr size'

113+ where

114+ handler :: E.IOException -> IO ByteString

115+ handler e

116+ | E.ioeGetErrorType e == E.InvalidArgument = return ""

117+ | otherwise = E.throwIO e

100

118

101receiveBuf :: Socket -> RecvBuf

119receiveBuf :: Socket -> RecvBuf

102−receiveBuf sock buf0 siz0 = loop buf0 siz0

120+receiveBuf sock buf0 siz0 = do

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

103 where

129 where

104− loop _ 0 = return True

130+ loop _ _ 0 = return True

105− loop buf siz = do

131+ loop fd buf siz = do

106 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

132 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

107 -- fixme: what should we do in the case of n == 0

133 -- fixme: what should we do in the case of n == 0

108 if n == 0 then

134 if n == 0 then

109 return False

135 return False

110 else

136 else

111− loop (buf `plusPtr` n) (siz - n)

137+ loop fd (buf `plusPtr` n) (siz - n)

112− fd = fdSocket sock

113

138

114receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

139receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

115receiveloop sock ptr size = do

140receiveloop sock ptr size = do

@@ -128,6 +153,8 @@ receiveloop sock ptr size = do

128 else

153 else

129 return bytes

154 return bytes

130

155

156+#ifndef mingw32_HOST_OS

131-- fixme: the type of the return value

157-- fixme: the type of the return value

132foreign import ccall unsafe "recv"

158foreign import ccall unsafe "recv"

133 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

159 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

160+#endif

warp/Network/Wai/Handler/Warp/Request.hs+34−36

@@ -9,41 +9,36 @@ module Network.Wai.Handler.Warp.Request (

9 , headerLines

10 , pauseTimeoutKey

11 , getFileInfoKey

12+ , getClientCertificateKey

12 , NoKeepAliveRequest (..)

13 , NoKeepAliveRequest (..)

13 ) where

14 ) where

14

15

15import qualified Control.Concurrent as Conc (yield)

16import qualified Control.Concurrent as Conc (yield)

16import Control.Exception (throwIO, Exception)

17import Control.Exception (throwIO, Exception)

17import Data.Array ((!))

18import Data.Array ((!))

18−import Data.ByteString (ByteString)

19−import Data.Typeable (Typeable)

20import qualified Data.ByteString as S

19import qualified Data.ByteString as S

21import qualified Data.ByteString.Unsafe as SU

20import qualified Data.ByteString.Unsafe as SU

22import qualified Data.CaseInsensitive as CI

21import qualified Data.CaseInsensitive as CI

23import qualified Data.IORef as I

22import qualified Data.IORef as I

23+import Data.Typeable (Typeable)

24+import qualified Data.Vault.Lazy as Vault

25+import Data.X509

24import qualified Network.HTTP.Types as H

26import qualified Network.HTTP.Types as H

25import Network.Socket (SockAddr)

27import Network.Socket (SockAddr)

26import Network.Wai

28import Network.Wai

27−import Network.Wai.Handler.Warp.Conduit

28−import Network.Wai.Handler.Warp.FileInfoCache

29−import Network.Wai.Handler.Warp.HashMap (hashByteString)

30−import Network.Wai.Handler.Warp.Header

31−import Network.Wai.Handler.Warp.ReadInt

32−import Network.Wai.Handler.Warp.RequestHeader

33−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)

34−import qualified Network.Wai.Handler.Warp.Timeout as Timeout

35import Network.Wai.Handler.Warp.Types

29import Network.Wai.Handler.Warp.Types

36import Network.Wai.Internal

30import Network.Wai.Internal

37import Prelude hiding (lines)

31import Prelude hiding (lines)

38−import Control.Monad (when)

39−import qualified Data.Vault.Lazy as Vault

40import System.IO.Unsafe (unsafePerformIO)

32import System.IO.Unsafe (unsafePerformIO)

33+import qualified System.TimeManager as Timeout

41

34

42−----------------------------------------------------------------

35+import Network.Wai.Handler.Warp.Conduit

43−

36+import Network.Wai.Handler.Warp.FileInfoCache

44−-- FIXME come up with good values here

37+import Network.Wai.Handler.Warp.Header

45−maxTotalHeaderLength :: Int

38+import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

46−maxTotalHeaderLength = 50 * 1024

39+import Network.Wai.Handler.Warp.ReadInt

40+import Network.Wai.Handler.Warp.RequestHeader

41+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)

47

42

48----------------------------------------------------------------

43----------------------------------------------------------------

49

44

@@ -52,21 +47,22 @@ maxTotalHeaderLength = 50 * 1024

52recvRequest :: Bool -- ^ first request on this connection?

47recvRequest :: Bool -- ^ first request on this connection?

53 -> Settings

48 -> Settings

54 -> Connection

49 -> Connection

55− -> InternalInfo1

50+ -> InternalInfo

51+ -> Timeout.Handle

56 -> SockAddr -- ^ Peer's address.

52 -> SockAddr -- ^ Peer's address.

57 -> Source -- ^ Where HTTP request comes from.

53 -> Source -- ^ Where HTTP request comes from.

54+ -> Transport

58 -> IO (Request

55 -> IO (Request

59 ,Maybe (I.IORef Int)

56 ,Maybe (I.IORef Int)

60 ,IndexedHeader

57 ,IndexedHeader

61− ,IO ByteString

58+ ,IO ByteString) -- ^

62− ,InternalInfo) -- ^

63 -- 'Request' passed to 'Application',

59 -- 'Request' passed to 'Application',

64 -- how many bytes remain to be consumed, if known

60 -- how many bytes remain to be consumed, if known

65 -- 'IndexedHeader' of HTTP request for internal use,

61 -- 'IndexedHeader' of HTTP request for internal use,

66 -- Body producing action used for flushing the request body

62 -- Body producing action used for flushing the request body

67

63

68−recvRequest firstRequest settings conn ii1 addr src = do

64+recvRequest firstRequest settings conn ii th addr src transport = do

69− hdrlines <- headerLines firstRequest src

65+ hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src

70 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

66 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

71 let idxhdr = indexRequestHeader hdr

67 let idxhdr = indexRequestHeader hdr

72 expect = idxhdr ! fromEnum ReqExpect

68 expect = idxhdr ! fromEnum ReqExpect

@@ -74,11 +70,9 @@ recvRequest firstRequest settings conn ii1 addr src = do

74 te = idxhdr ! fromEnum ReqTransferEncoding

70 te = idxhdr ! fromEnum ReqTransferEncoding

75 handle100Continue = handleExpect conn httpversion expect

71 handle100Continue = handleExpect conn httpversion expect

76 rawPath = if settingsNoParsePath settings then unparsedPath else path

72 rawPath = if settingsNoParsePath settings then unparsedPath else path

77− h = hashByteString rawPath

78− ii = toInternalInfo ii1 h

79− th = threadHandle ii

80 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

73 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

81 $ Vault.insert getFileInfoKey (getFileInfo ii)

74 $ Vault.insert getFileInfoKey (getFileInfo ii)

75+ $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

82 Vault.empty

76 Vault.empty

83 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te

77 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te

84 -- body producing function which will produce '100-continue', if needed

78 -- body producing function which will produce '100-continue', if needed

@@ -93,7 +87,7 @@ recvRequest firstRequest settings conn ii1 addr src = do

93 , rawQueryString = query

87 , rawQueryString = query

94 , queryString = H.parseQuery query

88 , queryString = H.parseQuery query

95 , requestHeaders = hdr

89 , requestHeaders = hdr

96− , isSecure = False

90+ , isSecure = isTransportSecure transport

97 , remoteHost = addr

91 , remoteHost = addr

98 , requestBody = rbody'

92 , requestBody = rbody'

99 , vault = vaultValue

93 , vault = vaultValue

@@ -103,12 +97,12 @@ recvRequest firstRequest settings conn ii1 addr src = do

103 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

97 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

104 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

98 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

105 }

99 }

106− return (req, remainingRef, idxhdr, rbodyFlush, ii)

100+ return (req, remainingRef, idxhdr, rbodyFlush)

107

101

108----------------------------------------------------------------

102----------------------------------------------------------------

109

103

110−headerLines :: Bool -> Source -> IO [ByteString]

104+headerLines :: Int -> Bool -> Source -> IO [ByteString]

111−headerLines firstRequest src = do

105+headerLines maxTotalHeaderLength firstRequest src = do

112 bs <- readSource src

106 bs <- readSource src

113 if S.null bs

107 if S.null bs

114 -- When we're working on a keep-alive connection and trying to

108 -- When we're working on a keep-alive connection and trying to

@@ -116,7 +110,7 @@ headerLines firstRequest src = do

116 -- lack of data as a real exception. See the http1 function in

110 -- lack of data as a real exception. See the http1 function in

117 -- the Run module for more details.

111 -- the Run module for more details.

118 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

119− else push src (THStatus 0 id id) bs

113+ else push maxTotalHeaderLength src (THStatus 0 id id) bs

120

114

121data NoKeepAliveRequest = NoKeepAliveRequest

115data NoKeepAliveRequest = NoKeepAliveRequest

122 deriving (Show, Typeable)

116 deriving (Show, Typeable)

@@ -226,8 +220,8 @@ close :: Sink ByteString IO a

226close = throwIO IncompleteHeaders

220close = throwIO IncompleteHeaders

227-}

221-}

228

222

229−push :: Source -> THStatus -> ByteString -> IO [ByteString]

223+push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]

230−push src (THStatus len lines prepend) bs'

224+push maxTotalHeaderLength src (THStatus len lines prepend) bs'

231 -- Too many bytes

225 -- Too many bytes

232 | len > maxTotalHeaderLength = throwIO OverLargeHeader

226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

233 | otherwise = push' mnl

227 | otherwise = push' mnl

@@ -255,13 +249,13 @@ push src (THStatus len lines prepend) bs'

255 push' Nothing = do

249 push' Nothing = do

256 bst <- readSource' src

250 bst <- readSource' src

257 when (S.null bst) $ throwIO IncompleteHeaders

251 when (S.null bst) $ throwIO IncompleteHeaders

258− push src status bst

252+ push maxTotalHeaderLength src status bst

259 where

253 where

260 len' = len + bsLen

254 len' = len + bsLen

261 prepend' = S.append bs

255 prepend' = S.append bs

262 status = THStatus len' lines prepend'

256 status = THStatus len' lines prepend'

263 -- Found a newline, but next line continues as a multiline header

257 -- Found a newline, but next line continues as a multiline header

264− push' (Just (end, True)) = push src status rest

258+ push' (Just (end, True)) = push maxTotalHeaderLength src status rest

265 where

259 where

266 rest = S.drop (end + 1) bs

260 rest = S.drop (end + 1) bs

267 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

261 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

@@ -280,12 +274,12 @@ push src (THStatus len lines prepend) bs'

280 in if start < bsLen then

274 in if start < bsLen then

281 -- more bytes in this chunk, push again

275 -- more bytes in this chunk, push again

282 let bs'' = SU.unsafeDrop start bs

276 let bs'' = SU.unsafeDrop start bs

283− in push src status bs''

277+ in push maxTotalHeaderLength src status bs''

284 else do

278 else do

285 -- no more bytes in this chunk, ask for more

279 -- no more bytes in this chunk, ask for more

286 bst <- readSource' src

280 bst <- readSource' src

287 when (S.null bs) $ throwIO IncompleteHeaders

281 when (S.null bs) $ throwIO IncompleteHeaders

288− push src status bst

282+ push maxTotalHeaderLength src status bst

289 where

283 where

290 start = end + 1 -- start of next chunk

284 start = end + 1 -- start of next chunk

291 line = SU.unsafeTake (checkCR bs end) bs

285 line = SU.unsafeTake (checkCR bs end) bs

@@ -303,3 +297,7 @@ pauseTimeoutKey = unsafePerformIO Vault.newKey

303getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

297getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

304getFileInfoKey = unsafePerformIO Vault.newKey

298getFileInfoKey = unsafePerformIO Vault.newKey

305{-# NOINLINE getFileInfoKey #-}

299{-# NOINLINE getFileInfoKey #-}

300+

301+getClientCertificateKey :: Vault.Key (Maybe CertificateChain)

302+getClientCertificateKey = unsafePerformIO Vault.newKey

303+{-# NOINLINE getClientCertificateKey #-}

warp/Network/Wai/Handler/Warp/RequestHeader.hs+5−6

@@ -1,4 +1,3 @@

1−{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3

2

4module Network.Wai.Handler.Warp.RequestHeader (

3module Network.Wai.Handler.Warp.RequestHeader (

@@ -6,16 +5,16 @@ module Network.Wai.Handler.Warp.RequestHeader (

6 ) where

5 ) where

7

6

8import Control.Exception (throwIO)

7import Control.Exception (throwIO)

9−import Control.Monad (when)

10import qualified Data.ByteString as S

8import qualified Data.ByteString as S

11−import qualified Data.ByteString.Char8 as B (unpack)

9+import qualified Data.ByteString.Char8 as C8 (unpack)

12−import Data.ByteString.Internal (ByteString(..), memchr)

10+import Data.ByteString.Internal (memchr)

13import qualified Data.CaseInsensitive as CI

11import qualified Data.CaseInsensitive as CI

14−import Data.Word (Word8)

15import Foreign.ForeignPtr (withForeignPtr)

12import Foreign.ForeignPtr (withForeignPtr)

16import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

13import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

17import Foreign.Storable (peek)

14import Foreign.Storable (peek)

18import qualified Network.HTTP.Types as H

15import qualified Network.HTTP.Types as H

16+

17+import Network.Wai.Handler.Warp.Imports

19import Network.Wai.Handler.Warp.Types

18import Network.Wai.Handler.Warp.Types

20

19

21-- $setup

20-- $setup

@@ -89,7 +88,7 @@ parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> d

89

88

90 return (method,path,query,hv)

89 return (method,path,query,hv)

91 where

90 where

92− baderr = BadFirstLine $ B.unpack requestLine

91+ baderr = BadFirstLine $ C8.unpack requestLine

93 check :: Ptr Word8 -> Int -> Word8 -> IO ()

92 check :: Ptr Word8 -> Int -> Word8 -> IO ()

94 check p n w = do

93 check p n w = do

95 w0 <- peek $ p `plusPtr` n

94 w0 <- peek $ p `plusPtr` n

warp/Network/Wai/Handler/Warp/Response.hs+33−53

@@ -1,6 +1,5 @@

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE TupleSections #-}

4{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE CPP #-}

4{-# LANGUAGE CPP #-}

6{-# LANGUAGE BangPatterns #-}

5{-# LANGUAGE BangPatterns #-}

@@ -14,56 +13,34 @@ module Network.Wai.Handler.Warp.Response (

14 , addServer -- testing

13 , addServer -- testing

15 ) where

14 ) where

16

15

17−#ifndef MIN_VERSION_base

18−#define MIN_VERSION_base(x,y,z) 1

19−#endif

20−

21−import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)

16+import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)

22−#if __GLASGOW_HASKELL__ < 709

23−import Control.Applicative

24−#endif

25import qualified Control.Exception as E

17import qualified Control.Exception as E

26−import Control.Monad (unless, when)

27import Data.Array ((!))

18import Data.Array ((!))

28−import Data.ByteString (ByteString)

29import qualified Data.ByteString as S

19import qualified Data.ByteString as S

30−import qualified Data.ByteString.Char8 as S8

31import Data.ByteString.Builder (byteString, Builder)

20import Data.ByteString.Builder (byteString, Builder)

32import Data.ByteString.Builder.Extra (flush)

21import Data.ByteString.Builder.Extra (flush)

22+import qualified Data.ByteString.Char8 as C8

33import qualified Data.CaseInsensitive as CI

23import qualified Data.CaseInsensitive as CI

34import Data.Function (on)

24import 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

45−import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)

25+import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)

46import Data.Version (showVersion)

26import Data.Version (showVersion)

47import Data.Word8 (_cr, _lf)

27import Data.Word8 (_cr, _lf)

48import qualified Network.HTTP.Types as H

28import qualified Network.HTTP.Types as H

49import qualified Network.HTTP.Types.Header as H

29import qualified Network.HTTP.Types.Header as H

50import Network.Wai

30import Network.Wai

31+import Network.Wai.Internal

32+import qualified Paths_warp

33+import qualified System.TimeManager as T

34+

51import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

35import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

52import qualified Network.Wai.Handler.Warp.Date as D

36import qualified Network.Wai.Handler.Warp.Date as D

53import Network.Wai.Handler.Warp.File

37import Network.Wai.Handler.Warp.File

54import Network.Wai.Handler.Warp.Header

38import Network.Wai.Handler.Warp.Header

55import Network.Wai.Handler.Warp.IO (toBufIOWith)

39import Network.Wai.Handler.Warp.IO (toBufIOWith)

40+import Network.Wai.Handler.Warp.Imports

56import Network.Wai.Handler.Warp.ResponseHeader

41import Network.Wai.Handler.Warp.ResponseHeader

57import Network.Wai.Handler.Warp.Settings

42import Network.Wai.Handler.Warp.Settings

58−import qualified Network.Wai.Handler.Warp.Timeout as T

59import Network.Wai.Handler.Warp.Types

43import 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

67

44

68-- $setup

45-- $setup

69-- >>> :set -XOverloadedStrings

46-- >>> :set -XOverloadedStrings

@@ -124,12 +101,13 @@ import qualified Paths_warp

124sendResponse :: Settings

101sendResponse :: Settings

125 -> Connection

102 -> Connection

126 -> InternalInfo

103 -> InternalInfo

104+ -> T.Handle

127 -> Request -- ^ HTTP request.

105 -> Request -- ^ HTTP request.

128 -> IndexedHeader -- ^ Indexed header of HTTP request.

106 -> IndexedHeader -- ^ Indexed header of HTTP request.

129 -> IO ByteString -- ^ source from client, for raw response

107 -> IO ByteString -- ^ source from client, for raw response

130 -> Response -- ^ HTTP response including status code and response header.

108 -> Response -- ^ HTTP response including status code and response header.

131 -> IO Bool -- ^ Returing True if the connection is persistent.

109 -> IO Bool -- ^ Returing True if the connection is persistent.

132−sendResponse settings conn ii req reqidxhdr src response = do

110+sendResponse settings conn ii th req reqidxhdr src response = do

133 hs <- addServerAndDate hs0

111 hs <- addServerAndDate hs0

134 if hasBody s then do

112 if hasBody s then do

135 -- The response to HEAD does not have body.

113 -- The response to HEAD does not have body.

@@ -138,14 +116,14 @@ sendResponse settings conn ii req reqidxhdr src response = do

138 -- and status, the response to HEAD is processed here.

116 -- and status, the response to HEAD is processed here.

139 --

117 --

140 -- See definition of rsp below for proper body stripping.

118 -- See definition of rsp below for proper body stripping.

141− (ms, mlen) <- sendRsp conn ii ver s hs rsp

119+ (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp

142 case ms of

120 case ms of

143 Nothing -> return ()

121 Nothing -> return ()

144 Just realStatus -> logger req realStatus mlen

122 Just realStatus -> logger req realStatus mlen

145 T.tickle th

123 T.tickle th

146 return ret

124 return ret

147 else do

125 else do

148− _ <- sendRsp conn ii ver s hs RspNoBody

126+ _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody

149 logger req s Nothing

127 logger req s Nothing

150 T.tickle th

128 T.tickle th

151 return isPersist

129 return isPersist

@@ -156,7 +134,6 @@ sendResponse settings conn ii req reqidxhdr src response = do

156 s = responseStatus response

134 s = responseStatus response

157 hs0 = sanitizeHeaders $ responseHeaders response

135 hs0 = sanitizeHeaders $ responseHeaders response

158 rspidxhdr = indexResponseHeader hs0

136 rspidxhdr = indexResponseHeader hs0

159− th = threadHandle ii

160 getdate = getDate ii

137 getdate = getDate ii

161 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

162 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

@@ -194,11 +171,11 @@ containsNewlines = S.any (\w -> w == _cr || w == _lf)

194

171

195{-# INLINE sanitizeHeaderValue #-}

172{-# INLINE sanitizeHeaderValue #-}

196sanitizeHeaderValue :: ByteString -> ByteString

173sanitizeHeaderValue :: ByteString -> ByteString

197−sanitizeHeaderValue v = case S8.lines $ S.filter (/= _cr) v of

174+sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of

198 [] -> ""

175 [] -> ""

199− x : xs -> S8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)

176+ x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)

200 where

177 where

201− addSpaceIfMissing line = case S8.uncons line of

178+ addSpaceIfMissing line = case C8.uncons line of

202 Nothing -> Nothing

179 Nothing -> Nothing

203 Just (first, _)

180 Just (first, _)

204 | first == ' ' || first == '\t' -> Just line

181 | first == ' ' || first == '\t' -> Just line

@@ -219,12 +196,13 @@ sendRsp :: Connection

219 -> H.HttpVersion

196 -> H.HttpVersion

220 -> H.Status

197 -> H.Status

221 -> H.ResponseHeaders

198 -> H.ResponseHeaders

199+ -> IndexedHeader -- Response

222 -> Rsp

200 -> Rsp

223 -> IO (Maybe H.Status, Maybe Integer)

201 -> IO (Maybe H.Status, Maybe Integer)

224

202

225----------------------------------------------------------------

203----------------------------------------------------------------

226

204

227−sendRsp conn _ ver s hs RspNoBody = do

205+sendRsp conn _ ver s hs _ RspNoBody = do

228 -- Not adding Content-Length.

206 -- Not adding Content-Length.

229 -- User agents treats it as Content-Length: 0.

207 -- User agents treats it as Content-Length: 0.

230 composeHeader ver s hs >>= connSendAll conn

208 composeHeader ver s hs >>= connSendAll conn

@@ -232,7 +210,7 @@ sendRsp conn _ ver s hs RspNoBody = do

232

210

233----------------------------------------------------------------

211----------------------------------------------------------------

234

212

235−sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

213+sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

236 header <- composeHeaderBuilder ver s hs needsChunked

214 header <- composeHeaderBuilder ver s hs needsChunked

237 let hdrBdy

215 let hdrBdy

238 | needsChunked = header <> chunkedTransferEncoding body

216 | needsChunked = header <> chunkedTransferEncoding body

@@ -245,9 +223,9 @@ sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

245

223

246----------------------------------------------------------------

224----------------------------------------------------------------

247

225

248−sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

226+sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

249 header <- composeHeaderBuilder ver s hs needsChunked

227 header <- composeHeaderBuilder ver s hs needsChunked

250− (recv, finish) <- newBlazeRecv $ reuseBufferStrategy

228+ (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

251 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

252 let send builder = do

230 let send builder = do

253 popper <- recv builder

231 popper <- recv builder

@@ -269,7 +247,7 @@ sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

269

247

270----------------------------------------------------------------

248----------------------------------------------------------------

271

249

272−sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

250+sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

273 withApp recv send

251 withApp recv send

274 return (Nothing, Nothing)

252 return (Nothing, Nothing)

275 where

253 where

@@ -283,8 +261,8 @@ sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

283

261

284-- Sophisticated WAI applications.

262-- Sophisticated WAI applications.

285-- We respect s0. s0 MUST be a proper value.

263-- We respect s0. s0 MUST be a proper value.

286−sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =

264+sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

287− sendRspFile2XX conn ii ver s0 hs path beg len isHead hook

265+ sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook

288 where

266 where

289 beg = filePartOffset part

267 beg = filePartOffset part

290 len = filePartByteCount part

268 len = filePartByteCount part

@@ -294,17 +272,17 @@ sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =

294

272

295-- Simple WAI applications.

273-- Simple WAI applications.

296-- Status is ignored

274-- Status is ignored

297−sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do

275+sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do

298 efinfo <- E.try $ getFileInfo ii path

276 efinfo <- E.try $ getFileInfo ii path

299 case efinfo of

277 case efinfo of

300 Left (_ex :: E.IOException) ->

278 Left (_ex :: E.IOException) ->

301#ifdef WARP_DEBUG

279#ifdef WARP_DEBUG

302 print _ex >>

280 print _ex >>

303#endif

281#endif

304− sendRspFile404 conn ii ver hs0

282+ sendRspFile404 conn ii ver hs0 rspidxhdr

305− Right finfo -> case conditionalRequest finfo hs0 idxhdr of

283+ Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of

306− WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody

284+ WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody

307− WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook

285+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

308

286

309----------------------------------------------------------------

287----------------------------------------------------------------

310

288

@@ -313,14 +291,15 @@ sendRspFile2XX :: Connection

313 -> H.HttpVersion

291 -> H.HttpVersion

314 -> H.Status

292 -> H.Status

315 -> H.ResponseHeaders

293 -> H.ResponseHeaders

294+ -> IndexedHeader

316 -> FilePath

295 -> FilePath

317 -> Integer

296 -> Integer

318 -> Integer

297 -> Integer

319 -> Bool

298 -> Bool

320 -> IO ()

299 -> IO ()

321 -> IO (Maybe H.Status, Maybe Integer)

300 -> IO (Maybe H.Status, Maybe Integer)

322−sendRspFile2XX conn ii ver s hs path beg len isHead hook

301+sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

323− | isHead = sendRsp conn ii ver s hs RspNoBody

302+ | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody

324 | otherwise = do

303 | otherwise = do

325 lheader <- composeHeader ver s hs

304 lheader <- composeHeader ver s hs

326 (mfd, fresher) <- getFd ii path

305 (mfd, fresher) <- getFd ii path

@@ -333,8 +312,9 @@ sendRspFile404 :: Connection

333 -> InternalInfo

312 -> InternalInfo

334 -> H.HttpVersion

313 -> H.HttpVersion

335 -> H.ResponseHeaders

314 -> H.ResponseHeaders

315+ -> IndexedHeader

336 -> IO (Maybe H.Status, Maybe Integer)

316 -> IO (Maybe H.Status, Maybe Integer)

337−sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)

317+sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)

338 where

318 where

339 s = H.notFound404

319 s = H.notFound404

340 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

320 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

warp/Network/Wai/Handler/Warp/ResponseHeader.hs+3−5

@@ -3,17 +3,15 @@

3

4module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where

5

6−import Control.Monad

7−import Data.ByteString (ByteString)

8import qualified Data.ByteString as S

6import qualified Data.ByteString as S

9import Data.ByteString.Internal (create)

7import Data.ByteString.Internal (create)

10import qualified Data.CaseInsensitive as CI

8import qualified Data.CaseInsensitive as CI

11−import Data.List (foldl')

12−import Data.Word (Word8)

13import Foreign.Ptr

9import Foreign.Ptr

14import GHC.Storable

10import GHC.Storable

15import qualified Network.HTTP.Types as H

11import qualified Network.HTTP.Types as H

12+

16import Network.Wai.Handler.Warp.Buffer (copy)

13import Network.Wai.Handler.Warp.Buffer (copy)

14+import Network.Wai.Handler.Warp.Imports

17

15

18----------------------------------------------------------------

16----------------------------------------------------------------

19

17

@@ -24,7 +22,7 @@ composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do

24 void $ copyCRLF ptr2

22 void $ copyCRLF ptr2

25 where

23 where

26 !len = 17 + slen + foldl' fieldLength 0 responseHeaders

24 !len = 17 + slen + foldl' fieldLength 0 responseHeaders

27− fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4

25+ fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4

28 !slen = S.length $ H.statusMessage status

26 !slen = S.length $ H.statusMessage status

29

27

30httpVer11 :: ByteString

28httpVer11 :: ByteString

warp/Network/Wai/Handler/Warp/Run.hs+136−81

@@ -3,50 +3,53 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PackageImports #-}

5{-# LANGUAGE PatternGuards #-}

6+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TupleSections #-}

8{-# LANGUAGE TupleSections #-}

9+{-# LANGUAGE ViewPatterns #-}

8{-# OPTIONS_GHC -fno-warn-deprecations #-}

10{-# OPTIONS_GHC -fno-warn-deprecations #-}

9

11

10module Network.Wai.Handler.Warp.Run where

12module Network.Wai.Handler.Warp.Run where

11

13

12−#if __GLASGOW_HASKELL__ < 709

14+import "iproute" Data.IP (toHostAddress, toHostAddress6)

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)

20import qualified Data.ByteString as S

18import qualified Data.ByteString as S

21import Data.Char (chr)

19import Data.Char (chr)

22−import "iproute" Data.IP (toHostAddress, toHostAddress6)

23import Data.IORef (IORef, newIORef, readIORef, writeIORef)

20import Data.IORef (IORef, newIORef, readIORef, writeIORef)

24import Data.Streaming.Network (bindPortTCP)

21import Data.Streaming.Network (bindPortTCP)

25import Foreign.C.Error (Errno(..), eCONNABORTED)

22import Foreign.C.Error (Errno(..), eCONNABORTED)

26import GHC.IO.Exception (IOException(..))

23import GHC.IO.Exception (IOException(..))

27−import Network (Socket)

24+import qualified Network.HTTP2 as H2

28−import Network.Socket (close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

25+import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

26+#if MIN_VERSION_network(3,1,1)

27+import Network.Socket (gracefulClose)

28+#endif

29import qualified Network.Socket.ByteString as Sock

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+

31import Network.Wai.Handler.Warp.Buffer

36import Network.Wai.Handler.Warp.Buffer

32import Network.Wai.Handler.Warp.Counter

37import Network.Wai.Handler.Warp.Counter

33import qualified Network.Wai.Handler.Warp.Date as D

38import qualified Network.Wai.Handler.Warp.Date as D

34import qualified Network.Wai.Handler.Warp.FdCache as F

39import qualified Network.Wai.Handler.Warp.FdCache as F

35import qualified Network.Wai.Handler.Warp.FileInfoCache as I

40import qualified Network.Wai.Handler.Warp.FileInfoCache as I

36−import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)

41+import Network.Wai.Handler.Warp.HTTP2 (http2)

42+import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)

37import Network.Wai.Handler.Warp.Header

43import Network.Wai.Handler.Warp.Header

38−import Network.Wai.Handler.Warp.IORef

44+import Network.Wai.Handler.Warp.Imports hiding (readInt)

39import Network.Wai.Handler.Warp.ReadInt

45import Network.Wai.Handler.Warp.ReadInt

40import Network.Wai.Handler.Warp.Recv

46import Network.Wai.Handler.Warp.Recv

41import Network.Wai.Handler.Warp.Request

47import Network.Wai.Handler.Warp.Request

42import Network.Wai.Handler.Warp.Response

48import Network.Wai.Handler.Warp.Response

43import Network.Wai.Handler.Warp.SendFile

49import Network.Wai.Handler.Warp.SendFile

44import Network.Wai.Handler.Warp.Settings

50import Network.Wai.Handler.Warp.Settings

45−import qualified Network.Wai.Handler.Warp.Timeout as T

46import Network.Wai.Handler.Warp.Types

51import Network.Wai.Handler.Warp.Types

47−import Network.Wai.Internal (ResponseReceived (ResponseReceived))

52+

48−import System.Environment (getEnvironment)

49−import System.Timeout (timeout)

50

53

51#if WINDOWS

54#if WINDOWS

52import Network.Wai.Handler.Warp.Windows

55import Network.Wai.Handler.Warp.Windows

@@ -55,28 +58,40 @@ import Network.Socket (fdSocket)

55#endif

58#endif

56

59

57-- | Creating 'Connection' for plain HTTP based on a given socket.

60-- | Creating 'Connection' for plain HTTP based on a given socket.

58−socketConnection :: Socket -> IO Connection

61+socketConnection :: Settings -> Socket -> IO Connection

62+#if MIN_VERSION_network(3,1,1)

63+socketConnection set s = do

64+#else

59−socketConnection s = do

65+socketConnection _ s = do

66+#endif

60 bufferPool <- newBufferPool

67 bufferPool <- newBufferPool

61 writeBuf <- allocateBuffer bufferSize

68 writeBuf <- allocateBuffer bufferSize

62 let sendall = Sock.sendAll s

69 let sendall = Sock.sendAll s

70+ isH2 <- newIORef False -- HTTP/1.x

63 return Connection {

71 return Connection {

64 connSendMany = Sock.sendMany s

72 connSendMany = Sock.sendMany s

65 , connSendAll = sendall

73 , connSendAll = sendall

66 , connSendFile = sendFile s writeBuf bufferSize sendall

74 , connSendFile = sendFile s writeBuf bufferSize sendall

75+#if MIN_VERSION_network(3,1,1)

76+ , connClose = do

77+ h2 <- readIORef isH2

78+ let tm = if h2 then settingsGracefulCloseTimeout2 set

79+ else settingsGracefulCloseTimeout1 set

80+ if tm == 0 then

81+ close s

82+ else

83+ gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()

84+#else

67 , connClose = close s

85 , connClose = close s

86+#endif

68 , connFree = freeBuffer writeBuf

87 , connFree = freeBuffer writeBuf

69 , connRecv = receive s bufferPool

88 , connRecv = receive s bufferPool

70 , connRecvBuf = receiveBuf s

89 , connRecvBuf = receiveBuf s

71 , connWriteBuffer = writeBuf

90 , connWriteBuffer = writeBuf

72 , connBufferSize = bufferSize

91 , connBufferSize = bufferSize

92+ , connHTTP2 = isH2

73 }

93 }

74

94

75−#if __GLASGOW_HASKELL__ < 702

76−allowInterrupt :: IO ()

77−allowInterrupt = unblock $ return ()

78−#endif

79−

80-- | Run an 'Application' on the given port.

95-- | Run an 'Application' on the given port.

81-- This calls 'runSettings' with 'defaultSettings'.

96-- This calls 'runSettings' with 'defaultSettings'.

82run :: Port -> Application -> IO ()

97run :: Port -> Application -> IO ()

@@ -89,7 +104,7 @@ run p = runSettings defaultSettings { settingsPort = p }

89-- Since 3.0.9

104-- Since 3.0.9

90runEnv :: Port -> Application -> IO ()

105runEnv :: Port -> Application -> IO ()

91runEnv p app = do

106runEnv p app = do

92− mp <- lookup "PORT" <$> getEnvironment

107+ mp <- lookupEnv "PORT"

93

108

94 maybe (run p app) runReadPort mp

109 maybe (run p app) runReadPort mp

95

110

@@ -136,7 +151,7 @@ runSettingsSocket set socket app = do

136 setSocketCloseOnExec s

151 setSocketCloseOnExec s

137 -- NoDelay causes an error for AF_UNIX.

152 -- NoDelay causes an error for AF_UNIX.

138 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

139− conn <- socketConnection s

154+ conn <- socketConnection set s

140 return (conn, sa)

155 return (conn, sa)

141

156

142 closeListenSocket = close socket

157 closeListenSocket = close socket

@@ -177,15 +192,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),

177runSettingsConnectionMakerSecure set getConnMaker app = do

192runSettingsConnectionMakerSecure set getConnMaker app = do

178 settingsBeforeMainLoop set

193 settingsBeforeMainLoop set

179 counter <- newCounter

194 counter <- newCounter

180− withII0 $ acceptConnection set getConnMaker app counter

195+ withII $ acceptConnection set getConnMaker app counter

181 where

196 where

182− withII0 action =

197+ withII action =

183 withTimeoutManager $ \tm ->

198 withTimeoutManager $ \tm ->

184 D.withDateCache $ \dc ->

199 D.withDateCache $ \dc ->

185 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

186 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

187− let ii0 = InternalInfo0 tm dc fdc fic

202+ let ii = InternalInfo tm dc fdc fic

188− action ii0

203+ action ii

189

204

190 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

191 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

@@ -214,13 +229,18 @@ acceptConnection :: Settings

214 -> IO (IO (Connection, Transport), SockAddr)

229 -> IO (IO (Connection, Transport), SockAddr)

215 -> Application

230 -> Application

216 -> Counter

231 -> Counter

217− -> InternalInfo0

232+ -> InternalInfo

218 -> IO ()

233 -> IO ()

219−acceptConnection set getConnMaker app counter ii0 = do

234+acceptConnection set getConnMaker app counter ii = do

220 -- First mask all exceptions in acceptLoop. This is necessary to

235 -- First mask all exceptions in acceptLoop. This is necessary to

221 -- ensure that no async exception is throw between the call to

236 -- ensure that no async exception is throw between the call to

222 -- acceptNewConnection and the registering of connClose.

237 -- acceptNewConnection and the registering of connClose.

238+ --

239+ -- acceptLoop can be broken by closing the listing socket.

223 void $ mask_ acceptLoop

240 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.

224 gracefulShutdown set counter

244 gracefulShutdown set counter

225 where

245 where

226 acceptLoop = do

246 acceptLoop = do

@@ -238,7 +258,7 @@ acceptConnection set getConnMaker app counter ii0 = do

238 case mx of

258 case mx of

239 Nothing -> return ()

259 Nothing -> return ()

240 Just (mkConn, addr) -> do

260 Just (mkConn, addr) -> do

241− fork set mkConn addr app counter ii0

261+ fork set mkConn addr app counter ii

242 acceptLoop

262 acceptLoop

243

263

244 acceptNewConnection = do

264 acceptNewConnection = do

@@ -261,15 +281,12 @@ fork :: Settings

261 -> SockAddr

281 -> SockAddr

262 -> Application

282 -> Application

263 -> Counter

283 -> Counter

264− -> InternalInfo0

284+ -> InternalInfo

265 -> IO ()

285 -> IO ()

266−fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

286+fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

267 -- Call the user-supplied on exception code if any

287 -- Call the user-supplied on exception code if any

268 -- exceptions are thrown.

288 -- exceptions are thrown.

269− handle (settingsOnException set Nothing) .

289+ 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 ->

273 -- Run the connection maker to get a new connection, and ensure

290 -- Run the connection maker to get a new connection, and ensure

274 -- that the connection is closed. If the mkConn call throws an

291 -- that the connection is closed. If the mkConn call throws an

275 -- exception, we will leak the connection. If the mkConn call is

292 -- exception, we will leak the connection. If the mkConn call is

@@ -280,24 +297,15 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

280 -- We grab the connection before registering timeouts since the

297 -- We grab the connection before registering timeouts since the

281 -- timeouts will be useless during connection creation, due to the

298 -- timeouts will be useless during connection creation, due to the

282 -- fact that async exceptions are still masked.

299 -- fact that async exceptions are still masked.

283− bracket mkConn (cleanUp ref) (serve unmask ref)

300+ bracket mkConn cleanUp (serve unmask)

284 where

301 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−

291− cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn

302+ cleanUp (conn, _) = connClose conn `finally` connFree conn

292

303

293 -- We need to register a timeout handler for this thread, and

304 -- We need to register a timeout handler for this thread, and

294− -- cancel that handler as soon as we exit. We additionally close

305+ -- cancel that handler as soon as we exit.

295− -- the connection immediately in case the child thread catches the

296− -- async exception or performs some long-running cleanup action.

297− serve unmask ref (conn, transport) = bracket register cancel $ \th -> do

306+ serve unmask (conn, transport) = bracket register cancel $ \th -> do

298− let ii1 = toInternalInfo1 ii0 th

299 -- We now have fully registered a connection close handler in

307 -- We now have fully registered a connection close handler in

300− -- the case of all exceptions, so it is safe to one again

308+ -- the case of all exceptions, so it is safe to once again

301 -- allow async exceptions.

309 -- allow async exceptions.

302 unmask .

310 unmask .

303 -- Call the user-supplied code for connection open and

311 -- Call the user-supplied code for connection open and

@@ -305,23 +313,23 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

305 bracket (onOpen addr) (onClose addr) $ \goingon ->

313 bracket (onOpen addr) (onClose addr) $ \goingon ->

306 -- Actually serve this connection. bracket with closeConn

314 -- Actually serve this connection. bracket with closeConn

307 -- above ensures the connection is closed.

315 -- above ensures the connection is closed.

308− when goingon $ serveConnection conn ii1 addr transport set app

316+ when goingon $ serveConnection conn ii th addr transport set app

309 where

317 where

310− register = T.registerKillThread (timeoutManager0 ii0)

318+ register = T.registerKillThread (timeoutManager ii) (connClose conn)

311− (closeConn ref conn)

312 cancel = T.cancel

319 cancel = T.cancel

313

320

314 onOpen adr = increase counter >> settingsOnOpen set adr

321 onOpen adr = increase counter >> settingsOnOpen set adr

315 onClose adr _ = decrease counter >> settingsOnClose set adr

322 onClose adr _ = decrease counter >> settingsOnClose set adr

316

323

317serveConnection :: Connection

324serveConnection :: Connection

318− -> InternalInfo1

325+ -> InternalInfo

326+ -> T.Handle

319 -> SockAddr

327 -> SockAddr

320 -> Transport

328 -> Transport

321 -> Settings

329 -> Settings

322 -> Application

330 -> Application

323 -> IO ()

331 -> IO ()

324−serveConnection conn ii1 origAddr transport settings app = do

332+serveConnection conn ii th origAddr transport settings app = do

325 -- fixme: Upgrading to HTTP/2 should be supported.

333 -- fixme: Upgrading to HTTP/2 should be supported.

326 (h2,bs) <- if isHTTP2 transport then

334 (h2,bs) <- if isHTTP2 transport then

327 return (True, "")

335 return (True, "")

@@ -334,17 +342,36 @@ serveConnection conn ii1 origAddr transport settings app = do

334 istatus <- newIORef False

342 istatus <- newIORef False

335 if settingsHTTP2Enabled settings && h2 then do

343 if settingsHTTP2Enabled settings && h2 then do

336 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

345+ -- This thread becomes the sender in http2 library.

346+ -- In the case of event source, one request comes and one

347+ -- worker gets busy. But it is likely that the receiver does

348+ -- not receive any data at all while the sender is sending

349+ -- output data from the worker. It's not good enough to tickle

350+ -- the time handler in the receiver only. So, we should tickle

351+ -- the time handler in both the receiver and the sender.

337 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

352 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

353+ sendBS x = connSendAll conn x >> T.tickle th

338 -- fixme: origAddr

354 -- fixme: origAddr

355+ checkTLS

356+ setConnHTTP2 conn True

339− http2 conn ii1 origAddr transport settings recvN app

357+ http2 conn transport ii origAddr settings recvN sendBS app

340 else do

358 else do

341 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

342 writeIORef istatus True

360 writeIORef istatus True

343 leftoverSource src bs

361 leftoverSource src bs

344 addr <- getProxyProtocolAddr src

362 addr <- getProxyProtocolAddr src

345− http1 True addr istatus src `E.catch` \e -> do

363+ http1 True addr istatus src `E.catch` \e ->

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

346− sendErrorResponse addr istatus e

372+ _ <- sendErrorResponse (dummyreq addr) istatus e

347− throwIO (e :: SomeException)

373+ throwIO e

374+

348 where

375 where

349 getProxyProtocolAddr src =

376 getProxyProtocolAddr src =

350 case settingsProxyProtocol settings of

377 case settingsProxyProtocol settings of

@@ -386,30 +413,25 @@ serveConnection conn ii1 origAddr transport settings app = do

386

413

387 decodeAscii = map (chr . fromEnum) . S.unpack

414 decodeAscii = map (chr . fromEnum) . S.unpack

388

415

389− th = threadHandle1 ii1

390−

391 shouldSendErrorResponse se

416 shouldSendErrorResponse se

392 | Just ConnectionClosedByPeer <- fromException se = False

417 | Just ConnectionClosedByPeer <- fromException se = False

393 | otherwise = True

418 | otherwise = True

394

419

395− sendErrorResponse addr istatus e = do

420+ sendErrorResponse req istatus e = do

396 status <- readIORef istatus

421 status <- readIORef istatus

397− when (shouldSendErrorResponse e && status) $ do

422+ if shouldSendErrorResponse e && status

398− let ii = toInternalInfo ii1 0 -- dummy

423+ then do

399− dreq = dummyreq addr

400− void $ sendResponse settings conn ii dreq defaultIndexRequestHeader (return S.empty) (errorResponse e)

424+ sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

425+ else return False

401

426

402 dummyreq addr = defaultRequest { remoteHost = addr }

427 dummyreq addr = defaultRequest { remoteHost = addr }

403

428

404 errorResponse e = settingsOnExceptionResponse settings e

429 errorResponse e = settingsOnExceptionResponse settings e

405

430

406 http1 firstRequest addr istatus src = do

431 http1 firstRequest addr istatus src = do

407− (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src

432+ (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport

408− let req = req' { isSecure = isTransportSecure transport }

409− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii

433+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

410 `E.catch` \e -> do

434 `E.catch` \e -> do

411− -- Call the user-supplied exception handlers, passing the request.

412− sendErrorResponse addr istatus e

413 settingsOnException settings (Just req) e

435 settingsOnException settings (Just req) e

414 -- Don't throw the error again to prevent calling settingsOnException twice.

436 -- Don't throw the error again to prevent calling settingsOnException twice.

415 return False

437 return False

@@ -422,9 +444,9 @@ serveConnection conn ii1 origAddr transport settings app = do

422 -- request headers, no data is available, recvRequest will

444 -- request headers, no data is available, recvRequest will

423 -- throw a NoKeepAliveRequest exception, which we catch here

445 -- throw a NoKeepAliveRequest exception, which we catch here

424 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

425− when keepAlive $ http1 False addr istatus src `E.catch` \NoKeepAliveRequest -> return ()

447+ when keepAlive $ http1 False addr istatus src

426

448

427− processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do

449+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

428 -- Let the application run for as long as it wants

450 -- Let the application run for as long as it wants

429 T.pause th

451 T.pause th

430

452

@@ -432,30 +454,38 @@ serveConnection conn ii1 origAddr transport settings app = do

432 -- creating the request, we need to make sure that we don't get

454 -- creating the request, we need to make sure that we don't get

433 -- an async exception before calling the ResponseSource.

455 -- an async exception before calling the ResponseSource.

434 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

435− _ <- app req $ \res -> do

457+ r <- E.try $ app req $ \res -> do

436 T.resume th

458 T.resume th

437 -- FIXME consider forcing evaluation of the res here to

459 -- FIXME consider forcing evaluation of the res here to

438 -- send more meaningful error messages to the user.

460 -- send more meaningful error messages to the user.

439 -- However, it may affect performance.

461 -- However, it may affect performance.

440 writeIORef istatus False

462 writeIORef istatus False

441− keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

463+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

442 writeIORef keepAliveRef keepAlive

464 writeIORef keepAliveRef keepAlive

443 return ResponseReceived

465 return ResponseReceived

466+ case r of

467+ Right ResponseReceived -> return ()

468+ Left e@(SomeException _)

469+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'

470+ | otherwise -> do

471+ keepAlive <- sendErrorResponse req istatus e

472+ settingsOnException settings (Just req) e

473+ writeIORef keepAliveRef keepAlive

474+

444 keepAlive <- readIORef keepAliveRef

475 keepAlive <- readIORef keepAliveRef

445

476

446 -- We just send a Response and it takes a time to

477 -- We just send a Response and it takes a time to

447 -- receive a Request again. If we immediately call recv,

478 -- receive a Request again. If we immediately call recv,

448− -- it is likely to fail and the IO manager works.

479+ -- it is likely to fail and cause the IO manager to do some work.

449− -- It is very costly. So, we yield to another Haskell

480+ -- It is very costly, so we yield to another Haskell

450 -- thread hoping that the next Request will arrive

481 -- thread hoping that the next Request will arrive

451 -- when this Haskell thread will be re-scheduled.

482 -- when this Haskell thread will be re-scheduled.

452 -- This improves performance at least when

483 -- This improves performance at least when

453 -- the number of cores is small.

484 -- the number of cores is small.

454 Conc.yield

485 Conc.yield

455

486

456− if not keepAlive then

487+ if keepAlive

457− return False

488+ then

458− else

459 -- If there is an unknown or large amount of data to still be read

489 -- If there is an unknown or large amount of data to still be read

460 -- from the request body, simple drop this connection instead of

490 -- from the request body, simple drop this connection instead of

461 -- reading it all in to satisfy a keep-alive request.

491 -- reading it all in to satisfy a keep-alive request.

@@ -481,6 +511,21 @@ serveConnection conn ii1 origAddr transport settings app = do

481 else

511 else

482 return False

512 return False

483 Nothing -> tryKeepAlive

513 Nothing -> tryKeepAlive

514+ else

515+ return False

516+

517+ checkTLS = case transport of

518+ TCP -> return () -- direct

519+ tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"

520+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

521+

522+-- connClose must not be called here since Run:fork calls it

523+goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()

524+goaway Connection{..} etype debugmsg = connSendAll bytestream

525+ where

526+ einfo = H2.encodeInfo id 0

527+ frame = H2.GoAwayFrame 0 etype debugmsg

528+ bytestream = H2.encodeFrame einfo frame

484

529

485flushEntireBody :: IO ByteString -> IO ()

530flushEntireBody :: IO ByteString -> IO ()

486flushEntireBody src =

531flushEntireBody src =

@@ -526,12 +571,22 @@ wrappedRecvN th istatus slowlorisSize readN bufsize = do

526 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th

571 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th

527 return bs

572 return bs

528

573

574+-- | Set flag FileCloseOnExec flag on a socket (on Unix)

575+--

529-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

576-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

577+--

578+-- @since 3.2.17

530setSocketCloseOnExec :: Socket -> IO ()

579setSocketCloseOnExec :: Socket -> IO ()

531#if WINDOWS

580#if WINDOWS

532setSocketCloseOnExec _ = return ()

581setSocketCloseOnExec _ = return ()

533#else

582#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

534−setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket

589+ F.setFileCloseOnExec $ fromIntegral fd

535#endif

590#endif

536

591

537gracefulShutdown :: Settings -> Counter -> IO ()

592gracefulShutdown :: Settings -> Counter -> IO ()

warp/Network/Wai/Handler/Warp/SendFile.hs+4−8

@@ -9,22 +9,14 @@ module Network.Wai.Handler.Warp.SendFile (

9#endif

10 ) where

11

12−import Control.Monad (void, when)

13−import Data.ByteString (ByteString)

14import qualified Data.ByteString as BS

12import qualified Data.ByteString as BS

15import Network.Socket (Socket)

13import Network.Socket (Socket)

16−import Network.Wai.Handler.Warp.Buffer

17−import Network.Wai.Handler.Warp.Types

18

14

19#ifdef WINDOWS

15#ifdef WINDOWS

20−import Data.ByteString.Internal (ByteString(..))

21import Foreign.ForeignPtr (newForeignPtr_)

16import Foreign.ForeignPtr (newForeignPtr_)

22import Foreign.Ptr (plusPtr)

17import Foreign.Ptr (plusPtr)

23import qualified System.IO as IO

18import qualified System.IO as IO

24#else

19#else

25−# if __GLASGOW_HASKELL__ < 709

26−import Control.Applicative ((<$>))

27−# endif

28import Control.Exception

20import Control.Exception

29import Foreign.C.Error (throwErrno)

21import Foreign.C.Error (throwErrno)

30import Foreign.C.Types

22import Foreign.C.Types

@@ -34,6 +26,10 @@ import Network.Wai.Handler.Warp.FdCache (openFile, closeFile)

34import System.Posix.Types

26import System.Posix.Types

35#endif

27#endif

36

28

29+import Network.Wai.Handler.Warp.Buffer

30+import Network.Wai.Handler.Warp.Imports

31+import Network.Wai.Handler.Warp.Types

32+

37----------------------------------------------------------------

33----------------------------------------------------------------

38

34

39-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.

35-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.

warp/Network/Wai/Handler/Warp/Settings.hs+60−19

@@ -6,26 +6,25 @@ 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

12import Data.ByteString.Builder (byteString)

9import Data.ByteString.Builder (byteString)

13−#if __GLASGOW_HASKELL__ < 709

10+import qualified Data.ByteString.Char8 as C8

14−import Data.Monoid (mappend)

11+import Data.ByteString.Lazy (fromStrict)

15−#endif

16import Data.Streaming.Network (HostPreference)

12import Data.Streaming.Network (HostPreference)

17import qualified Data.Text as T

13import qualified Data.Text as T

18import qualified Data.Text.IO as TIO

14import qualified Data.Text.IO as TIO

19import Data.Version (showVersion)

15import Data.Version (showVersion)

20import GHC.IO.Exception (IOErrorType(..))

16import GHC.IO.Exception (IOErrorType(..))

21import qualified Network.HTTP.Types as H

17import qualified Network.HTTP.Types as H

18+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

22import Network.Socket (SockAddr)

19import Network.Socket (SockAddr)

23import Network.Wai

20import Network.Wai

24−import Network.Wai.Handler.Warp.Timeout

25−import Network.Wai.Handler.Warp.Types

26import qualified Paths_warp

21import qualified Paths_warp

27import System.IO (stderr)

22import System.IO (stderr)

28import System.IO.Error (ioeGetErrorType)

23import System.IO.Error (ioeGetErrorType)

24+import System.TimeManager

25+

26+import Network.Wai.Handler.Warp.Imports

27+import Network.Wai.Handler.Warp.Types

29

28

30-- | Various Warp server settings. This is purposely kept as an abstract data

29-- | Various Warp server settings. This is purposely kept as an abstract data

31-- type so that new settings can be added without breaking backwards

30-- type so that new settings can be added without breaking backwards

@@ -77,6 +76,13 @@ data Settings = Settings

77 --

76 --

78 -- Since 2.0.3

77 -- Since 2.0.3

79 , settingsInstallShutdownHandler :: IO () -> IO ()

78 , settingsInstallShutdownHandler :: IO () -> IO ()

79+ -- ^ An action to install a handler (e.g. Unix signal handler)

80+ -- to close a listen socket.

81+ -- The first argument is an action to close the listen socket.

82+ --

83+ -- Default: no action

84+ --

85+ -- Since 3.0.1

80 , settingsServerName :: ByteString

86 , settingsServerName :: ByteString

81 -- ^ Default server name if application does not set one.

87 -- ^ Default server name if application does not set one.

82 --

88 --

@@ -88,28 +94,44 @@ data Settings = Settings

88 , settingsProxyProtocol :: ProxyProtocol

94 , settingsProxyProtocol :: ProxyProtocol

89 -- ^ Specify usage of the PROXY protocol.

95 -- ^ Specify usage of the PROXY protocol.

90 --

96 --

91− -- Since 3.0.5.

97+ -- Since 3.0.5

92 , settingsSlowlorisSize :: Int

98 , settingsSlowlorisSize :: Int

93 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

99 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

94 --

100 --

95− -- Since 3.1.2.

101+ -- Since 3.1.2

96 , settingsHTTP2Enabled :: Bool

102 , settingsHTTP2Enabled :: Bool

97 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

103 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

98 --

104 --

99− -- Since 3.1.7.

105+ -- Since 3.1.7

100 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

106 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

101 -- ^ A log function. Default: no action.

107 -- ^ A log function. Default: no action.

102 --

108 --

103− -- Since 3.X.X.

109+ -- Since 3.1.10

104 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

110 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

105 -- ^ A HTTP/2 server push log function. Default: no action.

111 -- ^ A HTTP/2 server push log function. Default: no action.

106 --

112 --

107− -- Since 3.X.X.

113+ -- Since 3.2.7

108 , settingsGracefulShutdownTimeout :: Maybe Int

114 , settingsGracefulShutdownTimeout :: Maybe Int

109 -- ^ An optional timeout to limit the time (in seconds) waiting for

115 -- ^ An optional timeout to limit the time (in seconds) waiting for

110 -- a graceful shutdown of the web server.

116 -- a graceful shutdown of the web server.

111 --

117 --

112 -- Since 3.2.8

118 -- Since 3.2.8

119+ , settingsGracefulCloseTimeout1 :: Int

120+ -- ^ A timeout to limit the time (in milliseconds) waiting for

121+ -- FIN for HTTP/1.x. 0 means uses immediate close.

122+ -- Default: 0.

123+ --

124+ -- Since 3.3.5

125+ , settingsGracefulCloseTimeout2 :: Int

126+ -- ^ A timeout to limit the time (in milliseconds) waiting for

127+ -- FIN for HTTP/2. 0 means uses immediate close.

128+ -- Default: 2000.

129+ --

130+ -- Since 3.3.5

131+ , settingsMaxTotalHeaderLength :: Int

132+ -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.

133+ --

134+ -- Since 3.3.8

113 }

135 }

114

136

115-- | Specify usage of the PROXY protocol.

137-- | Specify usage of the PROXY protocol.

@@ -138,7 +160,7 @@ defaultSettings = Settings

138 , settingsFork = void . forkIOWithUnmask

160 , settingsFork = void . forkIOWithUnmask

139 , settingsNoParsePath = False

161 , settingsNoParsePath = False

140 , settingsInstallShutdownHandler = const $ return ()

162 , settingsInstallShutdownHandler = const $ return ()

141− , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version

163+ , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version

142 , settingsMaximumBodyFlush = Just 8192

164 , settingsMaximumBodyFlush = Just 8192

143 , settingsProxyProtocol = ProxyProtocolNone

165 , settingsProxyProtocol = ProxyProtocolNone

144 , settingsSlowlorisSize = 2048

166 , settingsSlowlorisSize = 2048

@@ -146,6 +168,9 @@ defaultSettings = Settings

146 , settingsLogger = \_ _ _ -> return ()

168 , settingsLogger = \_ _ _ -> return ()

147 , settingsServerPushLogger = \_ _ _ -> return ()

169 , settingsServerPushLogger = \_ _ _ -> return ()

148 , settingsGracefulShutdownTimeout = Nothing

170 , settingsGracefulShutdownTimeout = Nothing

171+ , settingsGracefulCloseTimeout1 = 0

172+ , settingsGracefulCloseTimeout2 = 2000

173+ , settingsMaxTotalHeaderLength = 50 * 1024

149 }

174 }

150

175

151-- | Apply the logic provided by 'defaultOnException' to determine if an

176-- | Apply the logic provided by 'defaultOnException' to determine if an

@@ -171,13 +196,29 @@ defaultOnException _ e =

171 when (defaultShouldDisplayException e)

196 when (defaultShouldDisplayException e)

172 $ TIO.hPutStrLn stderr $ T.pack $ show e

197 $ TIO.hPutStrLn stderr $ T.pack $ show e

173

198

199+-- | Sending 400 for bad requests.

174−-- | Sending 400 for bad requests. Sending 500 for internal server errors.

200+-- Sending 500 for internal server errors.

175−--

176-- Since: 3.1.0

201-- Since: 3.1.0

202+-- Sending 413 for too large payload.

203+-- Sending 431 for too large headers.

204+-- Since 3.2.27

177defaultOnExceptionResponse :: SomeException -> Response

205defaultOnExceptionResponse :: SomeException -> Response

178defaultOnExceptionResponse e

206defaultOnExceptionResponse e

207+ | Just (_ :: InvalidRequest) <-

179− | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request"

208+ fromException e = responseLBS H.badRequest400

209+ [(H.hContentType, "text/plain; charset=utf-8")]

210+ "Bad Request"

211+ | Just (ConnectionError (UnknownErrorCode 413) t) <-

212+ fromException e = responseLBS H.status413

213+ [(H.hContentType, "text/plain; charset=utf-8")]

214+ (fromStrict t)

215+ | Just (ConnectionError (UnknownErrorCode 431) t) <-

216+ fromException e = responseLBS H.status431

217+ [(H.hContentType, "text/plain; charset=utf-8")]

218+ (fromStrict t)

180− | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"

219+ | otherwise = responseLBS H.internalServerError500

220+ [(H.hContentType, "text/plain; charset=utf-8")]

221+ "Something went wrong"

181

222

182-- | Exception handler for the debugging purpose.

223-- | Exception handler for the debugging purpose.

183-- 500, text/plain, a showed exception.

224-- 500, text/plain, a showed exception.

@@ -187,4 +228,4 @@ exceptionResponseForDebug :: SomeException -> Response

187exceptionResponseForDebug e =

228exceptionResponseForDebug e =

188 responseBuilder H.internalServerError500

229 responseBuilder H.internalServerError500

189 [(H.hContentType, "text/plain; charset=utf-8")]

230 [(H.hContentType, "text/plain; charset=utf-8")]

190− $ byteString . S8.pack $ "Exception: " ++ show e

231+ $ byteString . C8.pack $ "Exception: " ++ show e

warp/Network/Wai/Handler/Warp/Some.hsdeleted−73

@@ -1,73 +0,0 @@

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−

warp/Network/Wai/Handler/Warp/Types.hs+28−33

@@ -5,17 +5,18 @@

5module Network.Wai.Handler.Warp.Types where

6

7import Control.Exception

8−import Data.ByteString (ByteString)

9import qualified Data.ByteString as S

8import qualified Data.ByteString as S

10import Data.IORef (IORef, readIORef, writeIORef, newIORef)

9import Data.IORef (IORef, readIORef, writeIORef, newIORef)

11import Data.Typeable (Typeable)

10import Data.Typeable (Typeable)

12−import Data.Word (Word16, Word8)

11+import Data.X509

13import Foreign.Ptr (Ptr)

12import Foreign.Ptr (Ptr)

13+import System.Posix.Types (Fd)

14+import qualified System.TimeManager as T

15+

14import qualified Network.Wai.Handler.Warp.Date as D

16import qualified Network.Wai.Handler.Warp.Date as D

15import qualified Network.Wai.Handler.Warp.FdCache as F

17import qualified Network.Wai.Handler.Warp.FdCache as F

16import qualified Network.Wai.Handler.Warp.FileInfoCache as I

18import qualified Network.Wai.Handler.Warp.FileInfoCache as I

17−import qualified Network.Wai.Handler.Warp.Timeout as T

19+import Network.Wai.Handler.Warp.Imports

18−import System.Posix.Types (Fd)

19

20

20----------------------------------------------------------------

21----------------------------------------------------------------

21

22

@@ -52,6 +53,20 @@ instance Exception InvalidRequest

52

53

53----------------------------------------------------------------

54----------------------------------------------------------------

54

55

56+-- | Exception thrown if something goes wrong while in the midst of

57+-- sending a response, since the status code can't be altered at that

58+-- point.

59+--

60+-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe

61+-- or irrecoverable.

62+

63+newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException

64+ deriving (Show, Typeable)

65+

66+instance Exception ExceptionInsideResponseBody

67+

68+----------------------------------------------------------------

69+

55-- | Data type to abstract file identifiers.

70-- | Data type to abstract file identifiers.

56-- On Unix, a file descriptor would be specified to make use of

71-- On Unix, a file descriptor would be specified to make use of

57-- the file descriptor cache.

72-- the file descriptor cache.

@@ -108,46 +123,25 @@ data Connection = Connection {

108 , connWriteBuffer :: Buffer

123 , connWriteBuffer :: Buffer

109 -- | The size of the write buffer.

124 -- | The size of the write buffer.

110 , connBufferSize :: BufSize

125 , connBufferSize :: BufSize

126+ -- | Is this connection HTTP/2?

127+ , connHTTP2 :: IORef Bool

111 }

128 }

112

129

113−----------------------------------------------------------------

130+getConnHTTP2 :: Connection -> IO Bool

114−

131+getConnHTTP2 conn = readIORef (connHTTP2 conn)

115−type Hash = Int

116−

117−

118−data InternalInfo0 =

119− InternalInfo0 T.Manager

120− (IO D.GMTDate)

121− (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

122− (Hash -> FilePath -> IO I.FileInfo)

123

132

124−timeoutManager0 :: InternalInfo0 -> T.Manager

133+setConnHTTP2 :: Connection -> Bool -> IO ()

125−timeoutManager0 (InternalInfo0 tm _ _ _) = tm

134+setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b

126

135

127−data InternalInfo1 =

136+----------------------------------------------------------------

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

139

137

140data InternalInfo = InternalInfo {

138data InternalInfo = InternalInfo {

141− threadHandle :: T.Handle

142− , timeoutManager :: T.Manager

139+ timeoutManager :: T.Manager

143 , getDate :: IO D.GMTDate

140 , getDate :: IO D.GMTDate

144 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

141 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

145 , getFileInfo :: FilePath -> IO I.FileInfo

142 , getFileInfo :: FilePath -> IO I.FileInfo

146 }

143 }

147

144

148−toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo

149−toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h)

150−

151----------------------------------------------------------------

145----------------------------------------------------------------

152

146

153-- | Type for input streaming.

147-- | Type for input streaming.

@@ -186,6 +180,7 @@ data Transport = TCP -- ^ Plain channel: TCP

186 , tlsMinorVersion :: Int

180 , tlsMinorVersion :: Int

187 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

181 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

188 , tlsChiperID :: Word16

182 , tlsChiperID :: Word16

183+ , tlsClientCertificate :: Maybe CertificateChain

189 } -- ^ Encrypted channel: TLS or SSL

184 } -- ^ Encrypted channel: TLS or SSL

190

185

191isTransportSecure :: Transport -> Bool

186isTransportSecure :: Transport -> Bool

warp/Network/Wai/Handler/Warp/Windows.hs+5−1

@@ -7,8 +7,12 @@ module Network.Wai.Handler.Warp.Windows

7import Control.Exception

8import Control.Concurrent.MVar

9import Control.Concurrent

10−import Control.Monad

11

10

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

12windowsThreadBlockHack :: IO a -> IO a

16windowsThreadBlockHack :: IO a -> IO a

13windowsThreadBlockHack act = do

17windowsThreadBlockHack act = do

14 var <- newEmptyMVar :: IO (MVar (Either SomeException a))

18 var <- newEmptyMVar :: IO (MVar (Either SomeException a))

warp/Network/Wai/Handler/Warp/WithApplication.hs+10−12

@@ -1,4 +1,4 @@

1−

1+{-# LANGUAGE OverloadedStrings #-}

2module Network.Wai.Handler.Warp.WithApplication (

3 withApplication,

4 withApplicationSettings,

@@ -11,6 +11,8 @@ 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)

14import Network.Socket

16import Network.Socket

15import Network.Wai

17import Network.Wai

16import Network.Wai.Handler.Warp.Run

18import Network.Wai.Handler.Warp.Run

@@ -66,14 +68,16 @@ testWithApplication = testWithApplicationSettings defaultSettings

66--

68--

67-- @since 3.2.7

69-- @since 3.2.7

68testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

70testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

69−testWithApplicationSettings _settings mkApp action = do

71+testWithApplicationSettings settings mkApp action = do

70 callingThread <- myThreadId

72 callingThread <- myThreadId

71 app <- mkApp

73 app <- mkApp

72 let wrappedApp request respond =

74 let wrappedApp request respond =

73 app request respond `catch` \ e -> do

75 app request respond `catch` \ e -> do

76+ when

77+ (defaultShouldDisplayException e)

74− throwTo callingThread (e :: SomeException)

78+ (throwTo callingThread e)

75 throwIO e

79 throwIO e

76− withApplication (return wrappedApp) action

80+ withApplicationSettings settings (return wrappedApp) action

77

81

78data Waiter a

82data Waiter a

79 = Waiter {

83 = Waiter {

@@ -84,7 +88,7 @@ data Waiter a

84mkWaiter :: IO (Waiter a)

88mkWaiter :: IO (Waiter a)

85mkWaiter = do

89mkWaiter = do

86 mvar <- newEmptyMVar

90 mvar <- newEmptyMVar

87− return $ Waiter {

91+ return Waiter {

88 notify = putMVar mvar,

92 notify = putMVar mvar,

89 waitFor = readMVar mvar

93 waitFor = readMVar mvar

90 }

94 }

@@ -93,13 +97,7 @@ mkWaiter = do

93--

97--

94-- @since 3.2.4

98-- @since 3.2.4

95openFreePort :: IO (Port, Socket)

99openFreePort :: IO (Port, Socket)

96−openFreePort = do

100+openFreePort = bindRandomPortTCP "127.0.0.1"

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)

103

101

104-- | Like 'openFreePort' but closes the socket before exiting.

102-- | Like 'openFreePort' but closes the socket before exiting.

105withFreePort :: ((Port, Socket) -> IO a) -> IO a

103withFreePort :: ((Port, Socket) -> IO a) -> IO a

warp/bench/Parser.hs+15−10

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE BangPatterns #-}

3

4

@@ -18,7 +19,11 @@ import Foreign.ForeignPtr

18import Foreign.Ptr

19import Foreign.Ptr

19import Foreign.Storable

20import Foreign.Storable

20

21

22+#if MIN_VERSION_gauge(0, 2, 0)

21−import Criterion.Main

23+import Gauge

24+#else

25+import Gauge.Main

26+#endif

22

27

23-- $setup

28-- $setup

24-- >>> :set -XOverloadedStrings

29-- >>> :set -XOverloadedStrings

@@ -63,15 +68,15 @@ parseRequestLine3 :: ByteString

63 ,H.HttpVersion)

68 ,H.HttpVersion)

64parseRequestLine3 requestLine = ret

69parseRequestLine3 requestLine = ret

65 where

70 where

66− (!method,!rest) = S.breakByte 32 requestLine -- ' '

71+ (!method,!rest) = S.break (== 32) requestLine -- ' '

67 (!pathQuery,!httpVer')

72 (!pathQuery,!httpVer')

68 | rest == "" = throw badmsg

73 | rest == "" = throw badmsg

69− | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' '

74+ | otherwise = S.break (== 32) (S.drop 1 rest) -- ' '

70− (!path,!query) = S.breakByte 63 pathQuery -- '?'

75+ (!path,!query) = S.break (== 63) pathQuery -- '?'

71 !httpVer = S.drop 1 httpVer'

76 !httpVer = S.drop 1 httpVer'

72 (!http,!ver)

77 (!http,!ver)

73 | httpVer == "" = throw badmsg

78 | httpVer == "" = throw badmsg

74− | otherwise = S.breakByte 47 httpVer -- '/'

79+ | otherwise = S.break (== 47) httpVer -- '/'

75 !hv | http /= "HTTP" = throw NonHttp

80 !hv | http /= "HTTP" = throw NonHttp

76 | ver == "/1.1" = H.http11

81 | ver == "/1.1" = H.http11

77 | otherwise = H.http10

82 | otherwise = H.http10

@@ -169,13 +174,13 @@ parseRequestLine1 :: ByteString

169 ,ByteString -- Query

174 ,ByteString -- Query

170 ,H.HttpVersion)

175 ,H.HttpVersion)

171parseRequestLine1 requestLine = do

176parseRequestLine1 requestLine = do

172− let (!method,!rest) = S.breakByte 32 requestLine -- ' '

177+ let (!method,!rest) = S.break (== 32) requestLine -- ' '

173− (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' '

178+ (!pathQuery,!httpVer') = S.break (== 32) (S.drop 1 rest) -- ' '

174 !httpVer = S.drop 1 httpVer'

179 !httpVer = S.drop 1 httpVer'

175 when (rest == "" || httpVer == "") $

180 when (rest == "" || httpVer == "") $

176 throwIO $ BadFirstLine $ B.unpack requestLine

181 throwIO $ BadFirstLine $ B.unpack requestLine

177− let (!path,!query) = S.breakByte 63 pathQuery -- '?'

182+ let (!path,!query) = S.break (== 63) pathQuery -- '?'

178− (!http,!ver) = S.breakByte 47 httpVer -- '/'

183+ (!http,!ver) = S.break (== 47) httpVer -- '/'

179 when (http /= "HTTP") $ throwIO NonHttp

184 when (http /= "HTTP") $ throwIO NonHttp

180 let !hv | ver == "/1.1" = H.http11

185 let !hv | ver == "/1.1" = H.http11

181 | otherwise = H.http10

186 | otherwise = H.http10

@@ -205,7 +210,7 @@ parseRequestLine0 s =

205 !http' = S.concat http''

210 !http' = S.concat http''

206 (!hfirst, !hsecond) = S.splitAt 5 http'

211 (!hfirst, !hsecond) = S.splitAt 5 http'

207 if hfirst == "HTTP/"

212 if hfirst == "HTTP/"

208− then let (!rpath, !qstring) = S.breakByte 63 query -- '?'

213+ then let (!rpath, !qstring) = S.break (== 63) query -- '?'

209 !hv =

214 !hv =

210 case hsecond of

215 case hsecond of

211 "1.1" -> H.http11

216 "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)

10+import Network.Wai hiding (Response, responseStatus)

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 <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError"

52+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"

53− sc `shouldBe` (5,0,0)

53+ sc `shouldBe` internalServerError500

54 it "headersError" $ do

55− sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError"

55+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"

56− sc `shouldBe` (5,0,0)

56+ sc `shouldBe` internalServerError500

57 it "headerError" $ do

58− sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError"

58+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"

59− sc `shouldBe` (5,0,0)

59+ sc `shouldBe` internalServerError500

60 it "bodyError" $ do

61− sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError"

61+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"

62− sc `shouldBe` (5,0,0)

62+ sc `shouldBe` internalServerError500

63 -}

64 it "ioException" $ withTestServer $ \prt -> do

65− sc <- rspCode <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

65+ sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

66− sc `shouldBe` (5,0,0)

66+ sc `shouldBe` internalServerError500

warp/test/FdCacheSpec.hs+1−1

@@ -17,7 +17,7 @@ spec = describe "withFdCache" $ do

17 it "clean up Fd" $ do

18 ref <- newIORef (Fd (-1))

19 withFdCache 30000000 $ \getFd -> do

20− (Just fd,_) <- getFd 0 "warp.cabal"

20+ (Just fd,_) <- getFd "warp.cabal"

21 writeIORef ref fd

22 nfd <- readIORef ref

23 fdRead nfd 1 `shouldThrow` anyIOException

warp/test/FileSpec.hs+1−1

@@ -21,7 +21,7 @@ testFileRange desc reqhs file ans = it desc $ do

21 let WithBody s hs off len = ans

22 hs' = ("Last-Modified",fileInfoDate finfo) : hs

23 ans' = WithBody s hs' off len

24− conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'

24+ conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans'

25

26spec :: Spec

27spec = do

warp/test/HTTP.hs+26−28

@@ -1,43 +1,41 @@

1−{-# LANGUAGE StandaloneDeriving #-}

2−{-# OPTIONS_GHC -fno-warn-orphans #-}

3module HTTP (

1module HTTP (

4 sendGET

2 sendGET

5 , sendGETwH

3 , sendGETwH

6 , sendHEAD

4 , sendHEAD

7 , sendHEADwH

5 , sendHEADwH

8− , rspBody

6+ , responseBody

9− , rspCode

7+ , responseStatus

10− , rspHeaders

8+ , responseHeaders

11 , getHeaderValue

9 , getHeaderValue

12− , HeaderName(..)

10+ , HeaderName

13− , mkHeader

14 ) where

11 ) where

15

12

16−import Network.HTTP

13+import Network.HTTP.Client

17−import Network.Stream

14+import Network.HTTP.Types

15+import Data.ByteString

16+import qualified Data.ByteString.Lazy as BL

18

17

19−sendGET :: String -> IO (Response String)

18+sendGET :: String -> IO (Response BL.ByteString)

20sendGET url = sendGETwH url []

19sendGET url = sendGETwH url []

21

20

22−sendGETwH :: String -> [Header] -> IO (Response String)

21+sendGETwH :: String -> [Header] -> IO (Response BL.ByteString)

23−sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }

22+sendGETwH url hdr = do

23+ manager <- newManager defaultManagerSettings

24+ request <- parseRequest url

25+ let request' = request { requestHeaders = hdr }

26+ response <- httpLbs request' manager

27+ return response

24

28

25−sendHEAD :: String -> IO (Response String)

29+sendHEAD :: String -> IO (Response BL.ByteString)

26sendHEAD url = sendHEADwH url []

30sendHEAD url = sendHEADwH url []

27

31

28−sendHEADwH :: String -> [Header] -> IO (Response String)

32+sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString)

29−sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr }

33+sendHEADwH url hdr = do

34+ manager <- newManager defaultManagerSettings

35+ request <- parseRequest url

36+ let request' = request { requestHeaders = hdr, method = methodHead }

37+ response <- httpLbs request' manager

38+ return response

30

39

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−

38−getHeaderValue :: HasHeaders a => HeaderName -> a -> Maybe String

40+getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString

39−getHeaderValue key r = case retrieveHeaders key r of

41+getHeaderValue = lookup

40− [] -> Nothing

41− x:_ -> Just $ hdrValue x

42−

43−deriving instance Eq Header

warp/test/RequestSpec.hs+11−7

@@ -7,6 +7,7 @@ module RequestSpec (main, spec) where

7import Network.Wai.Handler.Warp.File (parseByteRanges)

8import Network.Wai.Handler.Warp.Request

9import Network.Wai.Handler.Warp.Types

10+import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings)

10import Test.Hspec

11import Test.Hspec

11import Test.Hspec.QuickCheck

12import Test.Hspec.QuickCheck

12import qualified Data.ByteString as S

13import qualified Data.ByteString as S

@@ -17,6 +18,9 @@ import Data.IORef

17main :: IO ()

18main :: IO ()

18main = hspec spec

19main = hspec spec

19

20

21+defaultMaxTotalHeaderLength :: Int

22+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23+

20spec :: Spec

24spec :: Spec

21spec = do

25spec = do

22 describe "headerLines" $ do

26 describe "headerLines" $ do

@@ -63,29 +67,29 @@ spec = do

63 describe "headerLines" $ do

67 describe "headerLines" $ do

64 it "can handle a nomarl case" $ do

68 it "can handle a nomarl case" $ do

65 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

69 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

66− x <- headerLines True src

70+ x <- headerLines defaultMaxTotalHeaderLength True src

67 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

71 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

68

72

69 it "can handle a nasty case (1)" $ do

73 it "can handle a nasty case (1)" $ do

70 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

74 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

71− x <- headerLines True src

75+ x <- headerLines defaultMaxTotalHeaderLength True src

72 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

76 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

73

77

74 it "can handle a nasty case (1)" $ do

78 it "can handle a nasty case (1)" $ do

75 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

79 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

76− x <- headerLines True src

80+ x <- headerLines defaultMaxTotalHeaderLength True src

77 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

81 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

78

82

79 it "can handle a nasty case (1)" $ do

83 it "can handle a nasty case (1)" $ do

80 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

84 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

81− x <- headerLines True src

85+ x <- headerLines defaultMaxTotalHeaderLength True src

82 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

86 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

83

87

84 it "can handle an illegal case (1)" $ do

88 it "can handle an illegal case (1)" $ do

85 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

89 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

86− x <- headerLines True src

90+ x <- headerLines defaultMaxTotalHeaderLength True src

87 x `shouldBe` []

91 x `shouldBe` []

88− y <- headerLines True src

92+ y <- headerLines defaultMaxTotalHeaderLength True src

89 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

93 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

90

94

91 where

95 where

@@ -111,7 +115,7 @@ headerLinesList' orig = do

111 writeIORef ref z

115 writeIORef ref z

112 return y

116 return y

113 src' <- mkSource src

117 src' <- mkSource src

114− res <- headerLines True src'

118+ res <- headerLines defaultMaxTotalHeaderLength True src'

115 return (res, src')

119 return (res, src')

116

120

117consumeLen :: Int -> Source -> IO S8.ByteString

121consumeLen :: Int -> Source -> IO S8.ByteString

warp/test/ResponseHeaderSpec.hs+2−30

@@ -7,9 +7,6 @@ import qualified Network.HTTP.Types as H

7import Network.Wai.Handler.Warp.ResponseHeader

8import Network.Wai.Handler.Warp.Response

9import Network.Wai.Handler.Warp.Header

10−import Network.Wai.Handler.Warp.HTTP2.HPACK

11−import Network.HPACK

12−import Network.HPACK.Token

13import Test.Hspec

10import Test.Hspec

14

11

15main :: IO ()

12main :: IO ()

@@ -37,40 +34,15 @@ spec = do

37 let hdrs = [("Server","MyServer")]

34 let hdrs = [("Server","MyServer")]

38 rspidxhdr = indexResponseHeader hdrs

35 rspidxhdr = indexResponseHeader hdrs

39 addServer "" rspidxhdr hdrs `shouldBe` []

36 addServer "" rspidxhdr hdrs `shouldBe` []

40− describe "addHeader" $ do

41− it "adds Server if not exist" $ do

42− let v = "MyServer"

43− hdrs = []

44− hdrs1 = [("Server",v)]

45− (thl, vt) <- toHeaderTable hdrs

46− (thl1, _) <- toHeaderTable hdrs1

47− addHeader tokenServer v vt thl `shouldBe` thl1

48− it "does not add Server if exists" $ do

49− let v = "MyServer2"

50− hdrs = [("Server","MyServer")]

51− (thl, vt) <- toHeaderTable hdrs

52− addHeader tokenServer v vt thl `shouldBe` thl

53− it "does not add Server if empty" $ do

54− let v = ""

55− hdrs = []

56− (thl, vt) <- toHeaderTable hdrs

57− addHeader tokenServer v vt thl `shouldBe` thl

58− it "deletes Server " $ do

59− let v = ""

60− hdrs = [("Server","MyServer")]

61− hdrs1 = []

62− (thl, vt) <- toHeaderTable hdrs

63− (thl1, _) <- toHeaderTable hdrs1

64− addHeader tokenServer v vt thl `shouldBe` thl1

65

37

66headers :: H.ResponseHeaders

38headers :: H.ResponseHeaders

67headers = [

39headers = [

68 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

40 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

69− , ("Content-Lenght", "151")

41+ , ("Content-Length", "151")

70 , ("Server", "Mighttpd/2.5.8")

42 , ("Server", "Mighttpd/2.5.8")

71 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

43 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

72 , ("Content-Type", "text/html")

44 , ("Content-Type", "text/html")

73 ]

45 ]

74

46

75composedHeader :: ByteString

47composedHeader :: ByteString

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"

48+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

warp/test/ResponseSpec.hs+15−23

@@ -6,17 +6,13 @@ 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))

10import Network.HTTP.Types

9import Network.HTTP.Types

11−import Network.Wai

10+import Network.Wai hiding (responseHeaders)

12import Network.Wai.Handler.Warp

11import Network.Wai.Handler.Warp

13import Network.Wai.Handler.Warp.Response

12import Network.Wai.Handler.Warp.Response

14−import RunSpec (withApp)

13+import RunSpec (withApp, msWrite, msRead, withMySocket)

15−import System.IO (hClose, hFlush)

16import Test.Hspec

14import Test.Hspec

17

15

18−import HTTP

19−

20main :: IO ()

16main :: IO ()

21main = hspec spec

17main = hspec spec

22

18

@@ -24,16 +20,13 @@ testRange :: S.ByteString -- ^ range value

24 -> String -- ^ expected output

20 -> String -- ^ expected output

25 -> Maybe String -- ^ expected content-range value

21 -> Maybe String -- ^ expected content-range value

26 -> Spec

22 -> Spec

27−testRange range out crange = it title $ withApp defaultSettings app $ \port -> do

23+testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

28− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

29− S.hPutStr handle "GET / HTTP/1.0\r\n"

24+ msWrite ms "GET / HTTP/1.0\r\n"

30− S.hPutStr handle "Range: bytes="

25+ msWrite ms "Range: bytes="

31− S.hPutStr handle range

26+ msWrite ms range

32− S.hPutStr handle "\r\n\r\n"

27+ msWrite ms "\r\n\r\n"

33− hFlush handle

34 threadDelay 10000

28 threadDelay 10000

35− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

29+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

36− hClose handle

37 last bss `shouldBe` out

30 last bss `shouldBe` out

38 let hs = mapMaybe toHeader bss

31 let hs = mapMaybe toHeader bss

39 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

32 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

@@ -51,13 +44,10 @@ testPartial :: Integer -- ^ file size

51 -> Integer -- ^ byte count

44 -> Integer -- ^ byte count

52 -> String -- ^ expected output

45 -> String -- ^ expected output

53 -> Spec

46 -> Spec

54−testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do

47+testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

55− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

56− S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"

48+ msWrite ms "GET / HTTP/1.0\r\n\r\n"

57− hFlush handle

58 threadDelay 10000

49 threadDelay 10000

59− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

50+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

60− hClose handle

61 out `shouldBe` last bss

51 out `shouldBe` last bss

62 let hs = mapMaybe toHeader bss

52 let hs = mapMaybe toHeader bss

63 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

53 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

@@ -73,13 +63,15 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ \po

73

63

74spec :: Spec

64spec :: Spec

75spec = do

65spec = do

66+{- http-client does not support this.

76 describe "preventing response splitting attack" $ do

67 describe "preventing response splitting attack" $ do

77 it "sanitizes header values" $ do

68 it "sanitizes header values" $ do

78 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

69 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

79 withApp defaultSettings app $ \port -> do

70 withApp defaultSettings app $ \port -> do

80 res <- sendGET $ "http://127.0.0.1:" ++ show port

71 res <- sendGET $ "http://127.0.0.1:" ++ show port

81− getHeaderValue (HdrCustom "foo") res `shouldBe`

72+ getHeaderValue "foo" (responseHeaders res) `shouldBe`

82 Just "foo bar" -- HTTP inserts two spaces for \r\n.

73 Just "foo bar" -- HTTP inserts two spaces for \r\n.

74+-}

83

75

84 describe "sanitizeHeaderValue" $ do

76 describe "sanitizeHeaderValue" $ do

85 it "doesn't alter valid multiline header values" $ do

77 it "doesn't alter valid multiline header values" $ do

@@ -91,7 +83,7 @@ spec = do

91 it "discards empty lines" $ do

83 it "discards empty lines" $ do

92 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

84 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

93

85

94− context "when sanitizing single occurences of \n" $ do

86+ context "when sanitizing single occurrences of \n" $ do

95 it "replaces \n with \r\n" $ do

87 it "replaces \n with \r\n" $ do

96 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

88 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

97

89

warp/test/RunSpec.hs+136−86

@@ -1,29 +1,28 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4

3

5−module RunSpec (main, spec, withApp) where

4+module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where

6

5

7import Control.Concurrent (forkIO, killThread, threadDelay)

6import Control.Concurrent (forkIO, killThread, threadDelay)

8import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

7import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

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, hPutStr, hGetSome)

13+import Data.ByteString (ByteString)

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))

21import Network.HTTP.Types

20import Network.HTTP.Types

22−import Network.Socket (close)

21+import Network.Socket

23import Network.Socket.ByteString (sendAll)

22import Network.Socket.ByteString (sendAll)

24−import Network.Wai

23+import Network.Wai hiding (responseHeaders)

24+import Network.Wai.Internal (getRequestBodyChunk)

25import Network.Wai.Handler.Warp

26−import System.IO (hFlush, hClose)

27import System.IO.Unsafe (unsafePerformIO)

26import System.IO.Unsafe (unsafePerformIO)

28import System.Timeout (timeout)

27import System.Timeout (timeout)

29import Test.Hspec

28import Test.Hspec

@@ -36,6 +35,52 @@ main = hspec spec

36type Counter = I.IORef (Either String Int)

35type Counter = I.IORef (Either String Int)

37type CounterApplication = Counter -> Application

36type CounterApplication = Counter -> Application

38

37

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+

39incr :: MonadIO m => Counter -> m ()

84incr :: MonadIO m => Counter -> m ()

40incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

85incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

41 ((case ecount of

86 ((case ecount of

@@ -47,7 +92,7 @@ err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

47

92

48readBody :: CounterApplication

93readBody :: CounterApplication

49readBody icount req f = do

94readBody icount req f = do

50− body <- consumeBody $ requestBody req

95+ body <- consumeBody $ getRequestBodyChunk req

51 case () of

96 case () of

52 ()

97 ()

53 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

98 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

@@ -68,8 +113,8 @@ ignoreBody icount req f = do

68

113

69doubleConnect :: CounterApplication

114doubleConnect :: CounterApplication

70doubleConnect icount req f = do

115doubleConnect icount req f = do

71− _ <- consumeBody $ requestBody req

116+ _ <- consumeBody $ getRequestBodyChunk req

72− _ <- consumeBody $ requestBody req

117+ _ <- consumeBody $ getRequestBodyChunk req

73 incr icount

118 incr icount

74 f $ responseLBS status200 [] "double connect"

119 f $ responseLBS status200 [] "double connect"

75

120

@@ -83,8 +128,8 @@ getPort = do

83 esocket <- try $ bindPortTCP port "127.0.0.1"

128 esocket <- try $ bindPortTCP port "127.0.0.1"

84 case esocket of

129 case esocket of

85 Left (_ :: IOException) -> RunSpec.getPort

130 Left (_ :: IOException) -> RunSpec.getPort

86− Right socket -> do

131+ Right sock -> do

87− close socket

132+ close sock

88 return port

133 return port

89

134

90withApp :: Settings -> Application -> (Int -> IO a) -> IO a

135withApp :: Settings -> Application -> (Int -> IO a) -> IO a

@@ -98,7 +143,13 @@ withApp settings app f = do

98 bracket

143 bracket

99 (forkIO $ runSettings settings' app `onException` putMVar baton ())

144 (forkIO $ runSettings settings' app `onException` putMVar baton ())

100 killThread

145 killThread

146+ (const $ do

101− (const $ takeMVar baton >> f port)

147+ takeMVar baton

148+ -- use timeout to make sure we don't take too long

149+ mres <- timeout (60 * 1000 * 1000) (f port)

150+ case mres of

151+ Nothing -> error "Timeout triggered, too slow!"

152+ Just a -> pure a)

102

153

103runTest :: Int -- ^ expected number of requests

154runTest :: Int -- ^ expected number of requests

104 -> CounterApplication

155 -> CounterApplication

@@ -106,10 +157,9 @@ runTest :: Int -- ^ expected number of requests

106 -> IO ()

157 -> IO ()

107runTest expected app chunks = do

158runTest expected app chunks = do

108 ref <- I.newIORef (Right 0)

159 ref <- I.newIORef (Right 0)

109− withApp defaultSettings (app ref) $ \port -> do

160+ withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

110− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

111− forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle

161+ forM_ chunks $ \chunk -> msWrite ms chunk

112− _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096

162+ _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

113 res <- I.readIORef ref

163 res <- I.readIORef ref

114 case res of

164 case res of

115 Left s -> error s

165 Left s -> error s

@@ -124,11 +174,9 @@ runTerminateTest :: InvalidRequest

124runTerminateTest expected input = do

174runTerminateTest expected input = do

125 ref <- I.newIORef Nothing

175 ref <- I.newIORef Nothing

126 let onExc _ = I.writeIORef ref . Just

176 let onExc _ = I.writeIORef ref . Just

127− withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

177+ withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

128− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

178+ msWrite ms input

129− hPutStr handle input

179+ msClose ms -- explicitly

130− hFlush handle

131− hClose handle

132 threadDelay 1000

180 threadDelay 1000

133 res <- I.readIORef ref

181 res <- I.readIORef ref

134 show res `shouldBe` show (Just expected)

182 show res `shouldBe` show (Just expected)

@@ -199,14 +247,11 @@ spec = do

199 let app req f = do

247 let app req f = do

200 liftIO $ I.writeIORef iheaders $ requestHeaders req

248 liftIO $ I.writeIORef iheaders $ requestHeaders req

201 f $ responseLBS status200 [] ""

249 f $ responseLBS status200 [] ""

202− withApp defaultSettings app $ \port -> do

250+ withApp defaultSettings app $ withMySocket $ \ms -> do

203− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

204 let input = S.concat

251 let input = S.concat

205 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

206 ]

253 ]

207− hPutStr handle input

254+ msWrite ms input

208− hFlush handle

209− hClose handle

210 threadDelay 1000

255 threadDelay 1000

211 headers <- I.readIORef iheaders

256 headers <- I.readIORef iheaders

212 headers `shouldBe`

257 headers `shouldBe`

@@ -217,14 +262,11 @@ spec = do

217 let app req f = do

262 let app req f = do

218 liftIO $ I.writeIORef iheaders $ requestHeaders req

263 liftIO $ I.writeIORef iheaders $ requestHeaders req

219 f $ responseLBS status200 [] ""

264 f $ responseLBS status200 [] ""

220− withApp defaultSettings app $ \port -> do

265+ withApp defaultSettings app $ withMySocket $ \ms -> do

221− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

222 let input = S.concat

266 let input = S.concat

223 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

224 ]

268 ]

225− hPutStr handle input

269+ msWrite ms input

226− hFlush handle

227− hClose handle

228 threadDelay 1000

270 threadDelay 1000

229 headers <- I.readIORef iheaders

271 headers <- I.readIORef iheaders

230 headers `shouldBe`

272 headers `shouldBe`

@@ -233,23 +275,24 @@ spec = do

233

275

234 describe "chunked bodies" $ do

276 describe "chunked bodies" $ do

235 it "works" $ do

277 it "works" $ do

278+ countVar <- newTVarIO (0 :: Int)

236 ifront <- I.newIORef id

279 ifront <- I.newIORef id

237 let app req f = do

280 let app req f = do

238− bss <- consumeBody $ requestBody req

281+ bss <- consumeBody $ getRequestBodyChunk req

239 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

283+ atomically $ modifyTVar countVar (+ 1)

240 f $ responseLBS status200 [] ""

284 f $ responseLBS status200 [] ""

241− withApp defaultSettings app $ \port -> do

285+ withApp defaultSettings app $ withMySocket $ \ms -> do

242− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

243 let input = S.concat

286 let input = S.concat

244 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

245 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

288 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

246 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

289 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

247 , "b\r\nHello World\r\n0\r\n\r\n"

290 , "b\r\nHello World\r\n0\r\n\r\n"

248 ]

291 ]

249− hPutStr handle input

292+ msWrite ms input

250− hFlush handle

293+ atomically $ do

251− hClose handle

294+ count <- readTVar countVar

252− threadDelay 1000

295+ check $ count == 2

253 front <- I.readIORef ifront

296 front <- I.readIORef ifront

254 front [] `shouldBe`

297 front [] `shouldBe`

255 [ "Hello World\nBye"

298 [ "Hello World\nBye"

@@ -257,38 +300,44 @@ spec = do

257 ]

300 ]

258 it "lots of chunks" $ do

301 it "lots of chunks" $ do

259 ifront <- I.newIORef id

302 ifront <- I.newIORef id

303+ countVar <- newTVarIO (0 :: Int)

260 let app req f = do

304 let app req f = do

261− bss <- consumeBody $ requestBody req

305+ bss <- consumeBody $ getRequestBodyChunk req

262 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307+ atomically $ modifyTVar countVar (+ 1)

263 f $ responseLBS status200 [] ""

308 f $ responseLBS status200 [] ""

264− withApp defaultSettings app $ \port -> do

309+ withApp defaultSettings app $ withMySocket $ \ms -> do

265− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

266 let input = concat $ replicate 2 $

310 let input = concat $ replicate 2 $

267 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

268 (replicate 50 "5\r\n12345\r\n") ++

312 (replicate 50 "5\r\n12345\r\n") ++

269 ["0\r\n\r\n"]

313 ["0\r\n\r\n"]

270− mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input

314+ mapM_ (msWrite ms) input

271− hClose handle

315+ atomically $ do

272− threadDelay 100000 -- FIXME why does this delay need to be so high?

316+ count <- readTVar countVar

317+ check $ count == 2

273 front <- I.readIORef ifront

318 front <- I.readIORef ifront

274 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

319 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.

275 it "in chunks" $ do

322 it "in chunks" $ do

276 ifront <- I.newIORef id

323 ifront <- I.newIORef id

324+ countVar <- newTVarIO (0 :: Int)

277 let app req f = do

325 let app req f = do

278− bss <- consumeBody $ requestBody req

326+ bss <- consumeBody $ getRequestBodyChunk req

279 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

328+ atomically $ modifyTVar countVar (+ 1)

280 f $ responseLBS status200 [] ""

329 f $ responseLBS status200 [] ""

281− withApp defaultSettings app $ \port -> do

330+ withApp defaultSettings app $ withMySocket $ \ms -> do

282− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

283 let input = S.concat

331 let input = S.concat

284 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

285 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

333 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

286 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

334 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

287 , "b\r\nHello World\r\n0\r\n\r\n"

335 , "b\r\nHello World\r\n0\r\n\r\n"

288 ]

336 ]

289− mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input

337+ mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

290− hClose handle

338+ atomically $ do

291− threadDelay 1000

339+ count <- readTVar countVar

340+ check $ count == 2

292 front <- I.readIORef ifront

341 front <- I.readIORef ifront

293 front [] `shouldBe`

342 front [] `shouldBe`

294 [ "Hello World\nBye"

343 [ "Hello World\nBye"

@@ -297,7 +346,7 @@ spec = do

297 it "timeout in request body" $ do

346 it "timeout in request body" $ do

298 ifront <- I.newIORef id

347 ifront <- I.newIORef id

299 let app req f = do

348 let app req f = do

300− bss <- (consumeBody $ requestBody req) `onException`

349+ bss <- (consumeBody $ getRequestBodyChunk req) `onException`

301 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

350 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

302 liftIO $ threadDelay 4000000 `E.catch` \e -> do

351 liftIO $ threadDelay 4000000 `E.catch` \e -> do

303 I.atomicModifyIORef ifront (\front ->

352 I.atomicModifyIORef ifront (\front ->

@@ -306,20 +355,18 @@ spec = do

306 E.throwIO (e :: E.SomeException)

355 E.throwIO (e :: E.SomeException)

307 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

308 f $ responseLBS status200 [] ""

357 f $ responseLBS status200 [] ""

309− withApp (setTimeout 1 defaultSettings) app $ \port -> do

358+ withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

310 let bs1 = S.replicate 2048 88

359 let bs1 = S.replicate 2048 88

311 bs2 = "This is short"

360 bs2 = "This is short"

312 bs = S.append bs1 bs2

361 bs = S.append bs1 bs2

313− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

314− hPutStr handle "POST / HTTP/1.1\r\n"

362+ msWrite ms "POST / HTTP/1.1\r\n"

315− hPutStr handle "content-length: "

363+ msWrite ms "content-length: "

316− hPutStr handle $ S8.pack $ show $ S.length bs

364+ msWrite ms $ S8.pack $ show $ S.length bs

317− hPutStr handle "\r\n\r\n"

365+ msWrite ms "\r\n\r\n"

318 threadDelay 100000

366 threadDelay 100000

319− hPutStr handle bs1

367+ msWrite ms bs1

320 threadDelay 100000

368 threadDelay 100000

321− hPutStr handle bs2

369+ msWrite ms bs2

322− hClose handle

323 threadDelay 5000000

370 threadDelay 5000000

324 front <- I.readIORef ifront

371 front <- I.readIORef ifront

325 S.concat (front []) `shouldBe` bs

372 S.concat (front []) `shouldBe` bs

@@ -335,39 +382,42 @@ spec = do

335 loop

382 loop

336 loop

383 loop

337 doubleBS = S.concatMap $ \w -> S.pack [w, w]

384 doubleBS = S.concatMap $ \w -> S.pack [w, w]

338− withApp defaultSettings app $ \port -> do

385+ withApp defaultSettings app $ withMySocket $ \ms -> do

339− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

340− hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"

386+ msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

341− hFlush handle

342− timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")

387+ timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

343− hPutStr handle "67890"

388+ msWrite ms "67890"

344− hFlush handle

345− timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")

389+ timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")

346−

347 it "only one date and server header" $ do

390 it "only one date and server header" $ do

348 let app _ f = f $ responseLBS status200

391 let app _ f = f $ responseLBS status200

349 [ ("server", "server")

392 [ ("server", "server")

350 , ("date", "date")

393 , ("date", "date")

351 ] ""

394 ] ""

395+ getValues key = map snd

396+ . filter (\(key', _) -> key == key')

397+ . responseHeaders

352 withApp defaultSettings app $ \port -> do

398 withApp defaultSettings app $ \port -> do

353 res <- sendGET $ "http://127.0.0.1:" ++ show port

399 res <- sendGET $ "http://127.0.0.1:" ++ show port

354− getHeaderValue HdrServer res `shouldBe` Just "server"

400+ getValues hServer res `shouldBe` ["server"]

355− getHeaderValue HdrDate res `shouldBe` Just "date"

401+ getValues hDate res `shouldBe` ["date"]

356

402

357 it "streaming echo #249" $ do

403 it "streaming echo #249" $ do

404+ countVar <- newTVarIO (0 :: Int)

358 let app req f = f $ responseStream status200 [] $ \write _ -> do

405 let app req f = f $ responseStream status200 [] $ \write _ -> do

359− let loop = do

406+ let loop = do

360− bs <- requestBody req

407+ bs <- getRequestBodyChunk req

361 unless (S.null bs) $ do

408 unless (S.null bs) $ do

362 write $ byteString bs

409 write $ byteString bs

410+ atomically $ modifyTVar countVar (+ 1)

363 loop

411 loop

364− loop

412+ loop

365− withApp defaultSettings app $ \port -> do

413+ withApp defaultSettings app $ withMySocket $ \ms -> do

366− (socket, _addr) <- getSocketTCP "127.0.0.1" port

367− sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

414+ msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

368 threadDelay 10000

415 threadDelay 10000

369− sendAll socket "5\r\nhello\r\n0\r\n\r\n"

416+ msWrite ms "5\r\nhello\r\n0\r\n\r\n"

417+ atomically $ do

418+ count <- readTVar countVar

419+ check $ count >= 1

370− bs <- safeRecv socket 4096

420+ bs <- safeRecv (msSocket ms) 4096 -- must not use msRead

371 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

372

422

373 it "streaming response with length" $ do

423 it "streaming response with length" $ do

@@ -375,7 +425,7 @@ spec = do

375 replicateM_ 4 $ write $ byteString "Hello"

425 replicateM_ 4 $ write $ byteString "Hello"

376 withApp defaultSettings app $ \port -> do

426 withApp defaultSettings app $ \port -> do

377 res <- sendGET $ "http://127.0.0.1:" ++ show port

427 res <- sendGET $ "http://127.0.0.1:" ++ show port

378− rspBody res `shouldBe` "HelloHelloHelloHello"

428+ responseBody res `shouldBe` "HelloHelloHelloHello"

379

429

380 describe "head requests" $ do

430 describe "head requests" $ do

381 let fp = "test/head-response"

431 let fp = "test/head-response"

@@ -388,19 +438,19 @@ spec = do

388 _ -> error "invalid path"

438 _ -> error "invalid path"

389 it "builder" $ withApp defaultSettings app $ \port -> do

439 it "builder" $ withApp defaultSettings app $ \port -> do

390 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

440 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

391− rspBody res `shouldBe` ""

441+ responseBody res `shouldBe` ""

392 it "streaming" $ withApp defaultSettings app $ \port -> do

442 it "streaming" $ withApp defaultSettings app $ \port -> do

393 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

443 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

394− rspBody res `shouldBe` ""

444+ responseBody res `shouldBe` ""

395 it "file, no range" $ withApp defaultSettings app $ \port -> do

445 it "file, no range" $ withApp defaultSettings app $ \port -> do

396 bs <- S.readFile fp

446 bs <- S.readFile fp

397 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

447 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

398− getHeaderValue HdrContentLength res `shouldBe` Just (show $ S.length bs)

448+ getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs)

399 it "file, with range" $ withApp defaultSettings app $ \port -> do

449 it "file, with range" $ withApp defaultSettings app $ \port -> do

400 res <- sendHEADwH

450 res <- sendHEADwH

401 (concat ["http://127.0.0.1:", show port, "/file"])

451 (concat ["http://127.0.0.1:", show port, "/file"])

402− [mkHeader HdrRange "bytes=0-1"]

452+ [(hRange, "bytes=0-1")]

403− getHeaderValue HdrContentLength res `shouldBe` Just "2"

453+ getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2"

404

454

405consumeBody :: IO ByteString -> IO [ByteString]

455consumeBody :: IO ByteString -> IO [ByteString]

406consumeBody body =

456consumeBody body =

warp/test/WithApplicationSpec.hs+16−16

@@ -2,13 +2,10 @@

2

3module WithApplicationSpec where

4

5−import Control.Concurrent

6import Control.Exception

5import Control.Exception

7import Network.HTTP.Types

6import Network.HTTP.Types

8−import Network.Socket

9import Network.Wai

7import Network.Wai

10−import System.IO

8+import System.Environment

11−import System.IO.Silently

12import System.Process

9import System.Process

13import Test.Hspec

10import Test.Hspec

14

11

@@ -16,6 +13,9 @@ import Network.Wai.Handler.Warp.WithApplication

16

13

17spec :: Spec

14spec :: Spec

18spec = do

15spec = 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" $

26+ it "does not propagate exceptions from the server to the executing thread" $ do

27− hSilence [stderr] $ do

28− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

27+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

29− withApplication mkApp $ \ port -> do

28+ withApplication mkApp $ \ port -> do

30− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

29+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

31− output `shouldContain` "Something went wron"

30+ output `shouldContain` "Something went wron"

32

31

33 describe "testWithApplication" $ do

32 describe "testWithApplication" $ do

34− it "propagates exceptions from the server to the executing thread" $

33+ it "propagates exceptions from the server to the executing thread" $ do

35− hSilence [stderr] $ do

36− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

34+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

37− (testWithApplication mkApp $ \ port -> do

35+ (testWithApplication mkApp $ \ port -> do

38− readProcess "curl" ["-s", "localhost:" ++ show port] "")

36+ readProcess "curl" ["-s", "localhost:" ++ show port] "")

39− `shouldThrow` (errorCall "foo")

37+ `shouldThrow` (errorCall "foo")

40

38

39+{- The future netwrok library will not export MkSocket.

41 describe "withFreePort" $ do

40 describe "withFreePort" $ do

42 it "closes the socket before exiting" $ do

41 it "closes the socket before exiting" $ do

43 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

42 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

44 return sock

43 return sock

45 readMVar statusMVar `shouldReturn` Closed

44 readMVar statusMVar `shouldReturn` Closed

45+-}

warp/warp.cabal+113−51

@@ -1,5 +1,5 @@

1Name: warp

2−Version: 3.2.13

2+Version: 3.3.9

3Synopsis: A fast, light-weight web server for WAI applications.

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

8Homepage: http://github.com/yesodweb/wai

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >=1.8

11+Cabal-Version: >= 1.10

12Stability: Stable

13description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.

14 For HTTP\/2, Warp supports direct and ALPN (in TLS)

@@ -33,29 +33,32 @@ Flag warp-debug

33 Default: False

34

35Library

36− Build-Depends: base >= 3 && < 5

36+ Build-Depends: base >= 4.8 && < 5

37 , array

38 , async

39 , auto-update >= 0.1.3 && < 0.2

40− , blaze-builder >= 0.4

40+ , bsb-http-chunked < 0.1

41 , bytestring >= 0.9.1.4

42− , bytestring-builder

43 , case-insensitive >= 0.2

42 , case-insensitive >= 0.2

44 , containers

43 , containers

45 , ghc-prim

44 , ghc-prim

45+ , hashable

46+ , http-date

46− , http-types >= 0.9.1

47+ , http-types >= 0.12

48+ , http2 >= 2.0 && < 2.1

47 , iproute >= 1.3.1

49 , iproute >= 1.3.1

48− , http2 >= 1.6 && < 1.7

49 , simple-sendfile >= 0.2.7 && < 0.3

50 , simple-sendfile >= 0.2.7 && < 0.3

50− , unix-compat >= 0.2

51+ , stm >= 2.3

51− , wai >= 3.2 && < 3.3

52− , text

53 , streaming-commons >= 0.1.10

52 , streaming-commons >= 0.1.10

53+ , text

54+ , time-manager

55+ , unix-compat >= 0.2

54 , vault >= 0.3

56 , vault >= 0.3

55− , stm >= 2.3

57+ , wai >= 3.2 && < 3.3

56 , word8

58 , word8

57− , hashable

59+ , x509

58− , http-date

60+ if impl(ghc < 8)

61+ Build-Depends: semigroups

59 if flag(network-bytestring)

62 if flag(network-bytestring)

60 Build-Depends: network >= 2.2.1.5 && < 2.2.3

63 Build-Depends: network >= 2.2.1.5 && < 2.2.3

61 , network-bytestring >= 0.1.3 && < 0.1.4

64 , network-bytestring >= 0.1.3 && < 0.1.4

@@ -72,18 +75,14 @@ Library

72 Network.Wai.Handler.Warp.FileInfoCache

75 Network.Wai.Handler.Warp.FileInfoCache

73 Network.Wai.Handler.Warp.HashMap

76 Network.Wai.Handler.Warp.HashMap

74 Network.Wai.Handler.Warp.HTTP2

77 Network.Wai.Handler.Warp.HTTP2

75− Network.Wai.Handler.Warp.HTTP2.EncodeFrame

76 Network.Wai.Handler.Warp.HTTP2.File

78 Network.Wai.Handler.Warp.HTTP2.File

77− Network.Wai.Handler.Warp.HTTP2.HPACK

79+ Network.Wai.Handler.Warp.HTTP2.PushPromise

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.Sender

81+ Network.Wai.Handler.Warp.HTTP2.Response

82 Network.Wai.Handler.Warp.HTTP2.Types

83− Network.Wai.Handler.Warp.HTTP2.Worker

84 Network.Wai.Handler.Warp.Header

83 Network.Wai.Handler.Warp.Header

85 Network.Wai.Handler.Warp.IO

84 Network.Wai.Handler.Warp.IO

86− Network.Wai.Handler.Warp.IORef

85+ Network.Wai.Handler.Warp.Imports

87 Network.Wai.Handler.Warp.PackInt

86 Network.Wai.Handler.Warp.PackInt

88 Network.Wai.Handler.Warp.ReadInt

87 Network.Wai.Handler.Warp.ReadInt

89 Network.Wai.Handler.Warp.Recv

88 Network.Wai.Handler.Warp.Recv

@@ -94,8 +93,6 @@ Library

94 Network.Wai.Handler.Warp.Run

93 Network.Wai.Handler.Warp.Run

95 Network.Wai.Handler.Warp.SendFile

94 Network.Wai.Handler.Warp.SendFile

96 Network.Wai.Handler.Warp.Settings

95 Network.Wai.Handler.Warp.Settings

97− Network.Wai.Handler.Warp.Some

98− Network.Wai.Handler.Warp.Timeout

99 Network.Wai.Handler.Warp.Types

96 Network.Wai.Handler.Warp.Types

100 Network.Wai.Handler.Warp.Windows

97 Network.Wai.Handler.Warp.Windows

101 Network.Wai.Handler.Warp.WithApplication

98 Network.Wai.Handler.Warp.WithApplication

@@ -112,14 +109,23 @@ Library

112 else

109 else

113 Build-Depends: unix

110 Build-Depends: unix

114 Other-modules: Network.Wai.Handler.Warp.MultiMap

111 Other-modules: Network.Wai.Handler.Warp.MultiMap

112+ if impl(ghc >= 8)

113+ Default-Extensions: Strict StrictData

114+ Default-Language: Haskell2010

115

116Test-Suite doctest

117+ buildable: False

117 Type: exitcode-stdio-1.0

118 Type: exitcode-stdio-1.0

118 HS-Source-Dirs: test

119 HS-Source-Dirs: test

119 Ghc-Options: -threaded -Wall

120 Ghc-Options: -threaded -Wall

120 Main-Is: doctests.hs

121 Main-Is: doctests.hs

121− Build-Depends: base

122+ Build-Depends: base >= 4.8 && < 5

122 , doctest >= 0.10.1

123 , 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

123

129

124Test-Suite spec

130Test-Suite spec

125 Main-Is: Spec.hs

131 Main-Is: Spec.hs

@@ -136,72 +142,128 @@ Test-Suite spec

136 SendFileSpec

142 SendFileSpec

137 WithApplicationSpec

143 WithApplicationSpec

138 HTTP

144 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+

139 Hs-Source-Dirs: test, .

179 Hs-Source-Dirs: test, .

140 Type: exitcode-stdio-1.0

180 Type: exitcode-stdio-1.0

141

181

142− Ghc-Options: -Wall

182+ Ghc-Options: -Wall -threaded

143− Build-Depends: base >= 4 && < 5

183+ Build-Depends: base >= 4.8 && < 5

184+ , HUnit

185+ , QuickCheck

144 , array

186 , array

187+ , async

145 , auto-update

188 , auto-update

146− , blaze-builder >= 0.4

189+ , bsb-http-chunked < 0.1

147 , bytestring >= 0.9.1.4

190 , bytestring >= 0.9.1.4

148− , bytestring-builder

149 , case-insensitive >= 0.2

191 , case-insensitive >= 0.2

192+ , containers

193+ , directory

150 , ghc-prim

194 , ghc-prim

151− , HTTP

195+ , hashable

196+ , hspec >= 1.3

197+ , http-client

198+ , http-date

152− , http-types >= 0.8.5

199+ , http-types >= 0.12

200+ , http2 >= 2.0 && < 2.1

153 , iproute >= 1.3.1

201 , iproute >= 1.3.1

154 , lifted-base >= 0.1

202 , lifted-base >= 0.1

155− , simple-sendfile >= 0.2.4 && < 0.3

156− , transformers >= 0.2.2

157− , unix-compat >= 0.2

158− , wai >= 3.2 && < 3.3

159 , network

203 , network

160− , HUnit

204+ , process

161− , QuickCheck

205+ , simple-sendfile >= 0.2.4 && < 0.3

162− , hspec >= 1.3

206+ , stm >= 2.3

163− , time

164− , text

165 , streaming-commons >= 0.1.10

207 , streaming-commons >= 0.1.10

166− , silently

208+ , text

167− , async

209+ , time

210+ , time-manager

211+ , unix-compat >= 0.2

168 , vault

212 , vault

169− , stm >= 2.3

213+ , wai >= 3.2 && < 3.3

170− , directory

171− , process

172− , containers

173− , http2 >= 1.6 && < 1.7

174 , word8

214 , word8

175− , hashable

215+ , x509

176− , http-date

216+ -- Build-Tool-Depends: hspec-discover:hspec-discover

217+ if impl(ghc < 8)

218+ Build-Depends: semigroups

219+ , transformers

177

220

178 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

221 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

179 Cpp-Options: -DSENDFILEFD

222 Cpp-Options: -DSENDFILEFD

180 Build-Depends: unix

223 Build-Depends: unix

181 if os(windows)

224 if os(windows)

182− Cpp-Options: -DWINDOWS

225+ Cpp-Options: -DWINDOWS

226+ Build-Depends: time

227+ if impl(ghc >= 8)

228+ Default-Extensions: Strict StrictData

229+ Default-Language: Haskell2010

183

230

184Benchmark parser

231Benchmark parser

185 Type: exitcode-stdio-1.0

232 Type: exitcode-stdio-1.0

186 Main-Is: Parser.hs

233 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

187 HS-Source-Dirs: bench .

241 HS-Source-Dirs: bench .

188− Build-Depends: base

242+ Build-Depends: base >= 4.8 && < 5

189 , auto-update

243 , auto-update

190 , bytestring

244 , bytestring

191 , containers

245 , containers

192− , criterion >= 1

246+ , gauge

193 , hashable

247 , hashable

194 , http-date

248 , http-date

195 , http-types

249 , http-types

196 , network

250 , network

197 , network

251 , network

252+ , time-manager

198 , unix-compat

253 , unix-compat

254+ , x509

255+ if impl(ghc < 8)

256+ Build-Depends: semigroups

199

257

200 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

258 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

201 Cpp-Options: -DSENDFILEFD

259 Cpp-Options: -DSENDFILEFD

202 Build-Depends: unix

260 Build-Depends: unix

203 if os(windows)

261 if os(windows)

204− Cpp-Options: -DWINDOWS

262+ Cpp-Options: -DWINDOWS

263+ Build-Depends: time

264+ if impl(ghc >= 8)

265+ Default-Extensions: Strict StrictData

266+ Default-Language: Haskell2010

205

267

206Source-Repository head

268Source-Repository head

207 Type: git

269 Type: git