master..699de97 · typeable/wai

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

since splitsnapshots

unifiedsplit

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

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

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

6− strategy:

7− matrix:

8− stack-lts-11:

9− BUILD: stack

10− STACK_YAML: stack-lts-11.yaml

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

12− stack-lts-12:

13− BUILD: stack

14− STACK_YAML: stack-lts-12.yaml

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

16− stack-lts-14:

17− BUILD: stack

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

19− stack-nightly:

20− BUILD: stack

21− STACK_YAML: stack-nightly.yaml

22− ARGS: "--resolver nightly"

23− cabal-8.2.2:

24− BUILD: cabal

25− GHCVER: 8.4.4

26− CABALVER: 2.0

27− cabal-8.4.4:

28− BUILD: cabal

29− GHCVER: 8.4.4

30− CABALVER: 2.2

31− cabal-8.6.5:

32− BUILD: cabal

33− GHCVER: 8.6.5

34− CABALVER: 2.4

35− maxParallel: 6

36− steps:

37− - script: |

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

39− mkdir -p ~/.local/bin

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

41− case "$BUILD" in

42− cabal)

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

44− sudo apt-get update

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

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

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

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

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

50− else

51− sudo apt-get install happy alex

52− fi

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

54− cabal --version

55− cabal update

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

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

58− ;;

59− *)

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

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

62− ;;

63− esac

64− set -ex

65− case "$BUILD" in

66− cabal)

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

68−

69− ORIGDIR=$(pwd)

70− for dir in $PACKAGES

71− do

72− cd $dir

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

74− cabal sdist

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

76− SRC_TGZ=$PKGVER.tar.gz

77− cd dist

78− tar zxfv "$SRC_TGZ"

79− cd "$PKGVER"

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

81− cabal build

82− cabal test --show-details=streaming

83− cd $ORIGDIR

84− done

85− ;;

86− *)

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

88− ;;

89− esac

90− set +ex

91− env:

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

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

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

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

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

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

6− strategy:

7− matrix:

8− stack-lts-11:

9− BUILD: stack

10− STACK_YAML: stack-lts-11.yaml

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

12− stack-lts-12:

13− BUILD: stack

14− STACK_YAML: stack-lts-12.yaml

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

16− stack-lts-14:

17− BUILD: stack

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

19− maxParallel: 3

20− steps:

21− - script: |

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

23− mkdir -p ~/.local/bin

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

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

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

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

28− env:

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

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

.azure/azure-pipelines.ymldeleted−30

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

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

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

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

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

5−#

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

7−#

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

9−# named azure-pipelines.yml

10−#

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

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

13−jobs:

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

15− parameters:

16− name: Linux

17− vmImage: ubuntu-16.04

18− os: linux

19−

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

21− parameters:

22− name: macOS

23− vmImage: macOS-10.13

24− os: osx

25−

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

27− parameters:

28− name: Windows

29− vmImage: vs2017-win2016

30− os: windows

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

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

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

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

6− strategy:

7− matrix:

8− stack-lts-14:

9− BUILD: stack

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

11− maxParallel: 3

12− steps:

13− - bash: |

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

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

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

17− stack setup $ARGS > /dev/null

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

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

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

21− env:

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

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

.github/ISSUE_TEMPLATE.mddeleted−28

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

1−<!---

2−

3−### Bug Reports

4−

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

6−

7−* Your OS name and version

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

9−* The versions of dependencies you're using

10−

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

12−

13−```

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

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

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

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

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

19−```

20−

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

22−

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

24−

25−### Support

26−

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

28−-->

.github/PULL_REQUEST_TEMPLATE.mddeleted−14

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

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

2−

3−- [ ] Bumped the version number

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

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

6−

7−After submitting your PR:

8−

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

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

11−

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

13−

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

.gitignore−2

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

8.cabal-sandbox/

9cabal.sandbox.config

10.stack-work/

11−*~

12−stack*.yaml.lock

.travis.ymlnew file+206

@@ -0,0 +1,206 @@

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

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

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

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

5+#

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

7+#

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

9+# named .travis.yml

10+

11+# Use new container infrastructure to enable caching

12+sudo: false

13+

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

15+language: c

16+

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

18+cache:

19+ directories:

20+ - $HOME/.ghc

21+ - $HOME/.cabal

22+ - $HOME/.stack

23+

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

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

26+# of those below.

27+#

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

29+# cache file per set of arguments.

30+#

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

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

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

34+matrix:

35+ include:

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

37+ compiler: ": #GHC 7.10.3"

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

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

40+ compiler: ": #GHC 8.0.2"

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

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

43+ compiler: ": #GHC 8.2.1"

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

45+

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

47+ # see below.

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

49+ compiler: ": #GHC HEAD"

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

51+

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

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

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

55+ compiler: ": #stack default"

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

57+

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

59+ # compiler: ": #stack 7.8.4"

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

61+

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

63+ compiler: ": #stack 7.10.2"

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

65+

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

67+ compiler: ": #stack 7.10.3"

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

69+

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

71+ compiler: ": #stack 8.0.1"

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

73+

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

75+ compiler: ": #stack 8.0.2"

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

77+

78+ # Nightly builds are allowed to fail

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

80+ compiler: ": #stack nightly"

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

82+

83+ # Build on OS X in addition to Linux

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

85+ compiler: ": #stack default osx"

86+ os: osx

87+

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

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

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

91+ # os: osx

92+

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

94+ compiler: ": #stack 7.10.2 osx"

95+ os: osx

96+

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

98+ compiler: ": #stack 7.10.3 osx"

99+ os: osx

100+

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

102+ compiler: ": #stack 8.0.1 osx"

103+ os: osx

104+

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

106+ compiler: ": #stack 8.0.2 osx"

107+ os: osx

108+

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

110+ compiler: ": #stack nightly osx"

111+ os: osx

112+

113+ allow_failures:

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

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

116+

117+before_install:

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

119+- unset CC

120+

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

122+- CABALARGS=""

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

124+

125+# Download and unpack the stack executable

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

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

128+- |

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

130+ then

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

132+

133+ # brew no longer has fcgi

134+ # brew install fcgi

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

136+ mv tmp stack.yaml

137+ else

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

139+ fi

140+

141+ # Use the more reliable S3 mirror of Hackage

142+ mkdir -p $HOME/.cabal

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

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

145+

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

147+ then

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

149+ fi

150+

151+install:

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

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

154+- |

155+ set -ex

156+ case "$BUILD" in

157+ stack)

158+ # Avoid out of memory condition

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

160+

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

162+ ;;

163+ cabal)

164+ cabal --version

165+ travis_retry cabal update

166+

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

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

169+

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

171+ # we can't build just dependencies

172+ #

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

174+ cabal install hspec-discover

175+ ;;

176+ esac

177+ set +ex

178+

179+script:

180+- |

181+ set -ex

182+ case "$BUILD" in

183+ stack)

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

185+ ;;

186+ cabal)

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

188+

189+ ORIGDIR=$(pwd)

190+ for dir in $PACKAGES

191+ do

192+ cd $dir

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

194+ cabal sdist

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

196+ SRC_TGZ=$PKGVER.tar.gz

197+ cd dist

198+ tar zxfv "$SRC_TGZ"

199+ cd "$PKGVER"

200+ cabal configure --enable-tests

201+ cabal build

202+ cd $ORIGDIR

203+ done

204+ ;;

205+ esac

206+ set +ex

CONTRIBUTING.mddeleted−94

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

1−# Contributing

2−

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

4−

5−## Development

6−

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

8−

9−* `stack build mime-types`

10−* `stack test auto-update`

11−* `stack haddock warp`

12−

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

14−

15−```

16−packages:

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

18−```

19−

20−## Coding Guidelines

21−

22−### Safety

23−

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

25−

26−### Style

27−

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

29−

30−### Dependencies

31−

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

33−

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

35−

36−### Backwards Compatibility

37−

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

39−

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

41−

42−## PR Guidelines

43−

44−### PR Scope

45−

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

47−

48−### Testing

49−

50−Tests are recommended, but not required.

51−

52−### Documentation

53−

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

55−

56−```

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

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

59−--

60−-- ==== __Examples__

61−--

62−-- > getTime <- mkAutoUpdate defaultUpdateSettings

63−--

64−-- @since 0.1.0

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

66−```

67−

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

69−

70−### Versioning

71−

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

73−

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

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

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

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

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

79−

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

81−

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

83−

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

85−

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

87−

88−### Changelog

89−

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

91−

92−### Releases

93−

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

README.md+1−1

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

10

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

12

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

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

auto-update/ChangeLog.md−19

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

1−# ChangeLog for auto-update

2−

3−## 0.1.6

4−

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

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

7−

8−## 0.1.5

9−

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

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

12−

13−## 0.1.4.1

14−

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

16− Improve documentation for `reaperAction` function.

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

18− Fixed memory leak in `reaperAdd` function.

19−

20## 0.1.4

1## 0.1.4

21

2

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

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

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

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

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

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

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

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

15-- }

14-- }

16-- @

15-- @

17--

16--

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

26-- @since 0.1.2

25-- @since 0.1.2

27module Control.Debounce

26module Control.Debounce

28 ( -- * Type

27 ( -- * Type

29− DI.DebounceSettings

28+ DebounceSettings

30 , defaultDebounceSettings

29 , defaultDebounceSettings

31 -- * Accessors

30 -- * Accessors

32− , DI.debounceFreq

31+ , debounceFreq

33− , DI.debounceAction

32+ , debounceAction

34− , DI.debounceEdge

35− , DI.leadingEdge

36− , DI.trailingEdge

37 -- * Creation

33 -- * Creation

38 , mkDebounce

34 , mkDebounce

39 ) where

35 ) where

40

36

41−import Control.Concurrent (newEmptyMVar, threadDelay)

37+import Control.Concurrent (forkIO, threadDelay)

42−import qualified Control.Debounce.Internal as DI

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

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

40+import Control.Monad (forever, void)

41+

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

43+--

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

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

46+--

47+-- @

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

49+-- @

50+--

51+-- @since 0.1.2

52+data DebounceSettings = DebounceSettings

53+ { debounceFreq :: Int

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

55+ -- action.

56+ --

57+ -- Default: 1 second (1000000)

58+ --

59+ -- @since 0.1.2

60+ , debounceAction :: IO ()

61+ -- ^ Action to be performed.

62+ --

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

64+ --

65+ -- Default: does nothing.

66+ --

67+ -- @since 0.1.2

68+ }

43

69

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

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

45--

71--

46-- @since 0.1.2

72-- @since 0.1.2

47−defaultDebounceSettings :: DI.DebounceSettings

73+defaultDebounceSettings :: DebounceSettings

48−defaultDebounceSettings = DI.DebounceSettings

74+defaultDebounceSettings = DebounceSettings

49− { DI.debounceFreq = 1000000

75+ { debounceFreq = 1000000

50− , DI.debounceAction = return ()

76+ , debounceAction = return ()

51− , DI.debounceEdge = DI.leadingEdge

52 }

77 }

53

78

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

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

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

81+-- current cooldown period has expired.

55--

82--

56-- @since 0.1.2

83-- @since 0.1.2

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

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

58−mkDebounce settings = do

85+mkDebounce (DebounceSettings freq action) = do

59− baton <- newEmptyMVar

86+ baton <- newEmptyMVar

60− DI.mkDebounceInternal baton threadDelay settings

87+ mask_ $ void $ forkIO $ forever $ do

88+ takeMVar baton

89+ ignoreExc action

90+ threadDelay freq

91+ return $ void $ tryPutMVar baton ()

92+

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

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

auto-update/Control/Debounce/Internal.hsdeleted−98

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

1−{-# LANGUAGE ScopedTypeVariables #-}

2−

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

4−module Control.Debounce.Internal (

5− DebounceSettings(..)

6− , DebounceEdge(..)

7− , leadingEdge

8− , trailingEdge

9− , mkDebounceInternal

10− ) where

11−

12−import Control.Concurrent (forkIO)

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

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

15−import Control.Monad (forever, void)

16−

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

18−--

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

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

21−--

22−-- @

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

24−-- @

25−--

26−-- @since 0.1.2

27−data DebounceSettings = DebounceSettings

28− { debounceFreq :: Int

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

30− --

31− -- Default: 1 second (1000000)

32− --

33− -- @since 0.1.2

34− , debounceAction :: IO ()

35− -- ^ Action to be performed.

36− --

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

38− --

39− -- Default: does nothing.

40− --

41− -- @since 0.1.2

42− , debounceEdge :: DebounceEdge

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

44− -- the timeout.

45− --

46− -- Default: 'trailingEdge'.

47− --

48− -- @since 0.1.6

49− }

50−

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

52−-- edge of the timeout.

53−--

54−-- @since 0.1.6

55−data DebounceEdge =

56− Leading

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

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

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

60− | Trailing

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

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

63− deriving (Show, Eq)

64−

65−

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

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

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

69−--

70−-- @since 0.1.6

71−leadingEdge :: DebounceEdge

72−leadingEdge = Leading

73−

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

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

76−--

77−-- @since 0.1.6

78−trailingEdge :: DebounceEdge

79−trailingEdge = Trailing

80−

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

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

83− mask_ $ void $ forkIO $ forever $ do

84− takeMVar baton

85− case edge of

86− Leading -> do

87− ignoreExc action

88− delayFn freq

89− Trailing -> do

90− delayFn freq

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

92− void $ tryTakeMVar baton

93− ignoreExc action

94−

95− return $ void $ tryPutMVar baton ()

96−

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

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

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

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

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

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

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

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

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

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

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

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

55 --

54 --

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

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

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

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

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

113

112

114-- | State of reaper.

113-- | State of reaper.

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

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

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

115+ | Workload workload -- ^ The current jobs

117

116

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

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

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

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

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

154 next <- atomicModifyIORef' stateRef cons

153 next <- atomicModifyIORef' stateRef cons

155 next

154 next

156 where

155 where

157− cons NoReaper = let wl = reaperCons item reaperEmpty

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

158 in (Workload wl, spawn settings stateRef tidRef)

157 in (Workload wl, spawn settings stateRef tidRef)

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

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

160 in (Workload wl', return ())

159 in (Workload wl', return ())

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

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

1name: auto-update

2−version: 0.1.6

2+version: 0.1.4

3synopsis: Efficiently run periodic, on-demand actions

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

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

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

17 ghc-options: -Wall

18 exposed-modules: Control.AutoUpdate

19 Control.Debounce

20− Control.Debounce.Internal

21 Control.Reaper

20 Control.Reaper

22 other-modules: Control.AutoUpdate.Util

21 other-modules: Control.AutoUpdate.Util

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

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

24 default-language: Haskell2010

23 default-language: Haskell2010

25− if impl(ghc >= 8)

26− default-extensions: Strict StrictData

27

24

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

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

29

26

30−test-suite spec

27+-- test-suite spec

31− main-is: Spec.hs

28+-- main-is: Spec.hs

32− other-modules: Control.AutoUpdateSpec

29+-- other-modules: Control.AutoUpdateSpec

33− Control.DebounceSpec

34− Control.ReaperSpec

30+-- Control.ReaperSpec

35− hs-source-dirs: test

31+-- hs-source-dirs: test

36− type: exitcode-stdio-1.0

32+-- type: exitcode-stdio-1.0

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

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

38− default-language: Haskell2010

34+-- default-language: Haskell2010

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

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

1module Control.AutoUpdateSpec (spec) where

2

3−import Control.AutoUpdate

4−import Control.Concurrent (threadDelay)

5−import Control.Monad (replicateM_, forM_)

6−import Data.IORef

7import Test.Hspec

3import Test.Hspec

8import Test.Hspec.QuickCheck

4import Test.Hspec.QuickCheck

5+import Data.IORef

6+import Control.Concurrent (threadDelay)

7+import Control.Monad (replicateM_, forM_)

8+import Control.AutoUpdate

9

10spec :: Spec

11−spec = return ()

11+spec = do

12− -- do

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

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

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

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

15− -- ref <- newIORef 0

14+ ref <- newIORef 0

16− -- next <- mkAutoUpdate defaultUpdateSettings

15+ next <- mkAutoUpdate defaultUpdateSettings

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

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

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

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

19− -- , updateSpawnThreshold = st

18+ , updateSpawnThreshold = st

20− -- , updateFreq = 10000

19+ , updateFreq = 10000

21− -- }

20+ }

22

21

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

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

24− -- j <- next

23+ j <- next

25− -- j `shouldBe` i

24+ j `shouldBe` i

26

25

27− -- replicateM_ 50 $ do

26+ replicateM_ 50 $ do

28− -- i <- next

27+ i <- next

29− -- i `shouldBe` st + 2

28+ i `shouldBe` st + 2

30

29

31− -- threadDelay 60000

30+ threadDelay 60000

32− -- last1 <- readIORef ref

31+ last1 <- readIORef ref

33− -- threadDelay 20000

32+ threadDelay 20000

34− -- last2 <- readIORef ref

33+ last2 <- readIORef ref

35− -- last2 `shouldBe` last1

34+ last2 `shouldBe` last1

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

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

1−{-# LANGUAGE ScopedTypeVariables #-}

2−module Control.DebounceSpec (spec) where

3−

4−import Control.Concurrent

5−import Control.Debounce

6−import qualified Control.Debounce.Internal as DI

7−import Control.Monad

8−import Control.Monad.Catch

9−import Control.Retry

10−import Data.IORef

11−import Test.HUnit.Lang

12−import Test.Hspec

13−

14−spec :: Spec

15−spec = describe "mkDebounce" $ do

16− describe "Leading edge" $ do

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

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

19−

20− debounced

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

22−

23− returnFromWait

24− pause

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

26−

27− -- Try another round

28− debounced

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

30−

31− returnFromWait

32− pause

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

34−

35− it "works for multiple events" $ do

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

37−

38− debounced

39− waitForBatonToBeTaken baton

40− debounced

41− pause

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

43−

44− returnFromWait

45− pause

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

47−

48− describe "Trailing edge" $ do

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

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

51−

52− debounced

53− pause

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

55−

56− returnFromWait

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

58−

59− -- Try another round

60− debounced

61− pause

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

63−

64− returnFromWait

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

66−

67− it "works for multiple events" $ do

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

69−

70− debounced

71− waitForBatonToBeTaken baton

72− debounced

73− pause

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

75−

76− returnFromWait

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

78−

79−

80−-- | Make a controllable delay function

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

82−getWaitAction = do

83− waitVar <- newEmptyMVar

84− let waitAction _ = takeMVar waitVar

85− let returnFromWait = putMVar waitVar ()

86− return (waitAction, returnFromWait)

87−

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

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

90−getDebounce edge = do

91− ref :: IORef Int <- newIORef 0

92− let action = modifyIORef ref (+ 1)

93−

94− (waitAction, returnFromWait) <- getWaitAction

95−

96− baton <- newEmptyMVar

97−

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

99− debounceFreq = 5000000 -- unused

100− , debounceAction = action

101− , debounceEdge = edge

102− }

103−

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

105−

106−-- | Pause briefly (100ms)

107−pause :: IO ()

108−pause = threadDelay 100000

109−

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

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

112−

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

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

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

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

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

118−

119−main :: IO ()

120−main = hspec spec

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

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

1module Control.ReaperSpec (spec) where

2

3−import Control.Concurrent

4import Control.Reaper

3import Control.Reaper

5−import Data.IORef

4+import Control.Concurrent

6import Test.Hspec

5import Test.Hspec

7import Test.Hspec.QuickCheck

6import Test.Hspec.QuickCheck

7+import Data.IORef

8

9+type Item = (Int, IORef Int)

9

10

10−spec :: Spec

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

11−spec = return ()

12+ modifyIORef ref succ

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

13+ return $ if i > 1

13−-- reaper <- mkReaper defaultReaperSettings

14+ then Just (pred i, ref)

14−-- { reaperAction = action

15+ else Nothing

15−-- , reaperDelay = 1000

16−-- }

17−

18−-- let mkTestCase i = do

19−-- ref <- newIORef 0

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

21−-- reaperAdd reaper (expected, ref)

22−-- return (expected, ref)

23−-- testCases <- mapM mkTestCase is

24

16

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

17+spec :: Spec

26−-- actual <- readIORef ref

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

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

19+ reaper <- mkReaper defaultReaperSettings

28−-- threadDelay 100000

20+ { reaperAction = action

29−-- mapM_ test testCases

21+ , reaperDelay = 1000

30−-- [] <- reaperRead reaper

22+ }

31−-- return ()

32

23

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

24+ let mkTestCase i = do

25+ ref <- newIORef 0

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

27+ reaperAdd reaper (expected, ref)

28+ return (expected, ref)

29+ testCases <- mapM mkTestCase is

34

30

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

31+ let test (expected, ref) = do

36−-- modifyIORef ref succ

32+ actual <- readIORef ref

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

34+ threadDelay 100000

35+ mapM_ test testCases

36+ [] <- reaperRead reaper

37−-- return $ if i > 1

37+ return ()

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

39−-- else Nothing

hcar-wai.texnew file+52

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

1+% WAI-KW.tex

2+\begin{hcarentry}{WAI}

3+\label{wai}

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

5+\participants{Michael Snoyman, Greg Weber}

6+\status{stable}

7+\makeheader

8+

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

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

11+defined as follows:

12+

13+\begin{verbatim}

14+type Application

15+ = Request

16+ -> (Response -> IO ResponseReceived)

17+ -> IO ResponseReceived

18+\end{verbatim}

19+

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

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

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

23+response to the function.

24+

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

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

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

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

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

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

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

32+

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

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

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

36+

37+WAI also provides \texttt{Middleware}:

38+

39+\begin{verbatim}

40+type Middleware = Application -> Application

41+\end{verbatim}

42+

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

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

45+

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

47+

48+\FurtherReading

49+\begin{compactitem}

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

51+\end{compactitem}

52+\end{hcarentry}

hcar-warp.texnew file+30

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

1+% Warp-KW.tex

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

3+\label{warp}

4+\report{Kazu Yamamoto}%11/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, some bugs of Warp have been fixed.

13+Also, Warp TLS incorporated the tls-session-manager package

14+which enables TLS session cache in the server side.

15+

16+\FurtherReading

17+\begin{compactitem}

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

19+ \begin{compactitem}

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

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

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

23+ \end{compactitem}

24+\item ``Warp''

25+ \begin{compactitem}

26+ \item The Performance of Open Source Applications

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

28+ \end{compactitem}

29+\end{compactitem}

30+\end{hcarentry}

mime-types/ChangeLog.md−8

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

1−## 0.1.0.9

2−

3−* Add mjs mime type

4−

5−## 0.1.0.8

6−

7−* Add wasm mime type

8−

9## 0.1.0.7

1## 0.1.0.7

10

2

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

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

mime-types/Network/Mime.hs−2

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1name: mime-types

2−version: 0.1.0.9

2+version: 0.1.0.7

3synopsis: Basic mime-type handling types and functions

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

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

sources.txtnew file+11

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

1+./wai

2+./wai-extra

3+./warp

4+./warp-tls

5+./wai-app-static

6+./wai-handler-fastcgi

7+./wai-handler-launch

8+./wai-websockets

9+./wai-conduit

10+./mime-types

11+./auto-update

stack-lts-11.yamldeleted−27

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

1−resolver: lts-11.21

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−extra-deps:

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

18−- http2-2.0.0

19−- network-byte-order-0.1.1.0

20−- tls-1.5.3

21−- tls-session-manager-0.0.4

22−- x509-1.7.5

23−nix:

24− enable: false

25− packages:

26− - fcgi

27− - zlib

stack-lts-12.yamldeleted−26

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

1−resolver: lts-12.6

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−nix:

17− enable: false

18− packages:

19− - fcgi

20− - zlib

21−extra-deps:

22−- http2-2.0.0

23−- network-byte-order-0.1.1.0

24−- tls-1.5.3

25−- tls-session-manager-0.0.4

26−- x509-1.7.5

stack-nightly.yamldeleted−20

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

1−resolver: nightly-2020-01-08

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−nix:

17− enable: false

18− packages:

19− - fcgi

20− - zlib

stack.yaml+21−7

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

1−resolver: lts-14.22

1+resolver: lts-4.1

2packages:

3- ./auto-update

4- ./mime-types

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

7- ./warp

8- ./warp-tls

9- ./wai-app-static

10+- ./wai-handler-fastcgi

10- ./wai-websockets

11- ./wai-websockets

11- ./wai-conduit

12- ./wai-conduit

12−- ./time-manager

13+- ./tls-session-manager

13flags:

14flags:

14 wai-extra:

15 wai-extra:

15 build-example: true

16 build-example: true

17+extra-deps:

18+- http2-1.6.0

19+- cryptonite-0.23

20+- memory-0.14.6

21+- tls-1.3.11

22+- fast-logger-2.4.5

23+- wai-logger-2.2.7

24+- http-types-0.9.1

25+- x509-1.6.5

26+- x509-validation-1.6.5

27+- foundation-0.0.12

28+- psqueues-0.2.3.0

16nix:

29nix:

17 enable: false

30 enable: false

18 packages:

31 packages:

19 - fcgi

32 - fcgi

20 - zlib

33 - zlib

21−extra-deps:

34+image:

22−- http2-2.0.0

35+ containers:

23−- network-byte-order-0.1.1.0

36+ - base: "fpco/pid1"

24−- tls-1.5.3

37+ name: "yesodweb/warp"

25−- tls-session-manager-0.0.4

38+ executables:

39+ - warp

time-manager/time-manager.cabaldeleted−19

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

1−Name: time-manager

2−Version: 0.0.0

3−Synopsis: Scalable timer

4−License: MIT

5−License-file: LICENSE

6−Author: Michael Snoyman and Kazu Yamamoto

7−Maintainer: kazu@iij.ad.jp

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

9−Category: System

10−Build-Type: Simple

11−Cabal-Version: >=1.8

12−Stability: Stable

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

14−

15−Library

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

17− , auto-update

18− Exposed-modules: System.TimeManager

19− Ghc-Options: -Wall

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

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

1+# 0.0.0.0

2+- A first release.

tls-session-manager/LICENSEnew file+29

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

3+

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

5+modification, are permitted provided that the following conditions

6+are met:

7+

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

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

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

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

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

13+ distribution.

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

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

16+ from this software without specific prior written permission.

17+

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

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

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

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

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

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

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

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

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

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

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

29+POSSIBILITY OF SUCH DAMAGE.

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

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

1+{-# LANGUAGE BangPatterns #-}

2+

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

4+--

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

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

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

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

9+

10+module Network.TLS.SessionManager (

11+ Config(..)

12+ , defaultConfig

13+ , newSessionManager

14+ ) where

15+

16+import Control.Exception (assert)

17+import Control.Reaper

18+import Data.IORef

19+import Data.Int (Int64)

20+import Data.List (foldl')

21+import Data.OrdPSQ (OrdPSQ)

22+import qualified Data.OrdPSQ as Q

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

24+import qualified System.Clock as C

25+

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

27+

28+-- | Configuration for session managers.

29+data Config = Config {

30+ -- | Ticket lifetime in seconds.

31+ ticketLifetime :: !Int

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

33+ , pruningDelay :: !Int

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

35+ , dbMaxSize :: !Int

36+ }

37+

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

39+defaultConfig :: Config

40+defaultConfig = Config {

41+ ticketLifetime = 86400

42+ , pruningDelay = 6000

43+ , dbMaxSize = 10000

44+ }

45+

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

47+

48+type Sec = Int64

49+type Value = (SessionData, IORef Availability)

50+type DB = OrdPSQ SessionID Sec Value

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

52+

53+data Operation = Add | Del

54+data Use = SingleUse | MultipleUse

55+data Availability = Fresh | Used

56+

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

58+

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

60+newSessionManager :: Config -> IO SessionManager

61+newSessionManager conf = do

62+ let lifetime = fromIntegral $ ticketLifetime conf

63+ maxsiz = dbMaxSize conf

64+ reaper <- mkReaper defaultReaperSettings {

65+ reaperEmpty = Q.empty

66+ , reaperCons = cons maxsiz

67+ , reaperAction = clean

68+ , reaperNull = Q.null

69+ , reaperDelay = pruningDelay conf * 1000000

70+ }

71+ return SessionManager {

72+ sessionResume = resume reaper MultipleUse

73+ , sessionEstablish = establish reaper lifetime

74+ , sessionInvalidate = invalidate reaper

75+ }

76+

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

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

79+ | lim <= 0 = Q.empty

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

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

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

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

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

85+

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

87+clean olddb = do

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

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

90+ return $ merge pruned

91+ where

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

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

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

95+ merge pruned newdb = foldl' ins pruned entries

96+ where

97+ entries = Q.toList newdb

98+

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

100+

101+establish :: Reaper DB Item -> Sec

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

103+establish reaper lifetime k sd = do

104+ ref <- newIORef Fresh

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

106+ let !v = (sd,ref)

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

108+

109+resume :: Reaper DB Item -> Use

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

111+resume reaper use k = do

112+ db <- reaperRead reaper

113+ case Q.lookup k db of

114+ Nothing -> return Nothing

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

116+ case use of

117+ SingleUse -> do

118+ available <- atomicModifyIORef' ref check

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

120+ return $ if available then Just sd else Nothing

121+ MultipleUse -> return $ Just sd

122+ where

123+ check Fresh = (Used,True)

124+ check Used = (Used,False)

125+

126+invalidate :: Reaper DB Item

127+ -> SessionID -> IO ()

128+invalidate reaper k = do

129+ db <- reaperRead reaper

130+ case Q.lookup k db of

131+ Nothing -> return ()

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

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

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

1+import Distribution.Simple

2+main = defaultMain

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

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

1+name: tls-session-manager

2+version: 0.0.0.1

3+synopsis: In-memory TLS session manager

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

5+license: BSD3

6+license-file: LICENSE

7+author: Kazu Yamamoto

8+maintainer: kazu@iij.ad.jp

9+-- copyright:

10+category: Web

11+build-type: Simple

12+extra-source-files: ChangeLog.md

13+cabal-version: >= 1.10

14+

15+library

16+ exposed-modules: Network.TLS.SessionManager

17+ -- other-modules:

18+ -- other-extensions:

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

20+ , auto-update

21+ , clock

22+ , psqueues >= 0.2.3

23+ , tls

24+ -- hs-source-dirs:

25+ default-language: Haskell2010

26+ ghc-options: -Wall

wai-app-static/ChangeLog.md−20

@@ -1,23 +1,3 @@

1−# wai-app-static changelog

2−

3−## 3.1.7.1

4−

5−* Update the test suite too

6−

7−## 3.1.7

8−

9−* Use 302 instead of 301 redirect, to avoid caching the presence of an index.html file

10−

11−## 3.1.6.3

12−

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

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

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

16−

17−## 3.1.6.2

18−

19−* Drop dependency on blaze-builder

20−

21## 3.1.6.1

1## 3.1.6.1

22

2

23* Add `<>` import

3* Add `<>` import

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

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

34import Data.ByteString.Lazy.Char8 ()

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

36

37−import Data.ByteString.Builder (toLazyByteString)

37+import Blaze.ByteString.Builder (toByteString)

38

39import Data.FileEmbed (embedFile)

40

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

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

165 -- with an ETag header.

166 --

167− -- RFC7232 (HTTP 1.1):

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

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

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

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

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

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

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

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

171+ -- new file being sent anyway.

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

173− -- > If-None-Match.

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

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

175

173

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

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

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

245 response :: StaticResponse -> IO W.ResponseReceived

243 response :: StaticResponse -> IO W.ResponseReceived

246 response (FileResponse file ch) = do

244 response (FileResponse file ch) = do

247 mimetype <- ssGetMimeType ss file

245 mimetype <- ssGetMimeType ss file

248− -- let filesize = fileGetSize file

246+ let filesize = fileGetSize file

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

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

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

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

251 -- range requests into account

249 -- range requests into account

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

264 ] lbs

262 ] lbs

265

263

266 response (Redirect pieces' mHash) = do

264 response (Redirect pieces' mHash) = do

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

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

268 let qString = case mHash of

266 let qString = case mHash of

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

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

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

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

271

269

272− sendResponse $ W.responseLBS H.status302

270+ sendResponse $ W.responseLBS H.status301

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

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

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

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

275 ] "Redirect"

273 ] "Redirect"

276

274

277 response (RawRedirect path) =

275 response (RawRedirect path) =

278− sendResponse $ W.responseLBS H.status302

276+ sendResponse $ W.responseLBS H.status301

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

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

280 , ("Location", path)

278 , ("Location", path)

281 ] "Redirect"

279 ] "Redirect"

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

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

39 }

40

41#if MIN_VERSION_optparse_applicative(0, 10, 0)

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

43option' = option auto

42option' = option auto

44#else

43#else

45option' = option

44option' = option

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

94-- Since 2.0.1

93-- Since 2.0.1

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

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

96runCommandLine middleware = do

95runCommandLine middleware = do

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

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

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

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

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

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

100 docroot' <- canonicalizePath docroot

99 docroot' <- canonicalizePath docroot

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

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

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

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

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

113 }

112 }

114− where

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

116− helperOption =

117− abortOption ShowHelpText $

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

wai-app-static/WaiAppStatic/Listing.hs+1−1

@@ -64,7 +64,7 @@ defaultListing pieces (Folder contents) = do

64

65 -- Add a link to the root of the tree

66 showFolder' :: Bool -> Pieces -> H.Html

67− showFolder' hasTrailingSlash pieces' = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces')

67+ showFolder' hasTrailingSlash pieces = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces)

68

69 showFolder :: Bool -> Pieces -> H.Html

70 showFolder _ [] = "/" -- won't happen

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

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

8import Data.ByteString (ByteString)

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

10import Data.List

11−import Data.ByteString.Builder (byteString)

11+import Blaze.ByteString.Builder (fromByteString)

12import qualified Network.Wai as W

13import qualified Data.Map as Map

14import Data.Function (on)

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

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

51toEntry (name, EEFile bs) = Right File

52 { fileGetSize = fromIntegral $ S.length bs

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

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

54 , fileName = name

55 , fileGetHash = return $ Just $ runHash bs

56 , fileGetModified = Nothing

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

87bsToFile :: Piece -> ByteString -> File

88bsToFile name bs = File

89 { fileGetSize = fromIntegral $ S.length bs

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

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

91 , fileName = name

92 , fileGetHash = return $ Just $ runHash bs

93 , fileGetModified = Nothing

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

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

5 , mkSettings

6) where

7

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

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

9import Codec.Compression.GZip (compress)

10+import Control.Applicative

10import Data.ByteString.Unsafe (unsafePackAddressLen)

11import Data.ByteString.Unsafe (unsafePackAddressLen)

11import Data.Either (lefts, rights)

12import Data.Either (lefts, rights)

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

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

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

129 let h' = if embCompressed entry

130 let h' = if embCompressed entry

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

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

131 else h

132 else h

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

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

133

134

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

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

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

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

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

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

1+{-# LANGUAGE OverloadedStrings #-}

1module WaiAppStatic.Types

2module WaiAppStatic.Types

2 ( -- * Pieces

3 ( -- * Pieces

3 Piece

4 Piece

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

24import Data.ByteString (ByteString)

25import Data.ByteString (ByteString)

25import System.Posix.Types (EpochTime)

26import System.Posix.Types (EpochTime)

26import qualified Data.Text as T

27import qualified Data.Text as T

27−import Data.ByteString.Builder (Builder)

28+import Blaze.ByteString.Builder (Builder)

28import Network.Mime (MimeType)

29import Network.Mime (MimeType)

29

30

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

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

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

59toPieces = mapM toPiece

60toPieces = mapM toPiece

60

61

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

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

62−--

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

64type Pieces = [Piece]

63type Pieces = [Piece]

65

64

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

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

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

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

57 assertStatus 200 =<<

58 request (setRawPathInfo defRequest path)

59

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

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

61 assertStatus 404 =<<

62 request (setRawPathInfo defRequest "doesNotExist")

63

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

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

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

66− assertStatus 302 req

66+ assertStatus 301 req

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

68

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

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

71 }

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

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

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

74 req <- request (setRawPathInfo defRequest path)

75− assertStatus 302 req

75+ assertStatus 301 req

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

77

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

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

131 assertStatus 304 req

132 assertNoHeader "Cache-Control" req

133

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

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

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

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

137− assertStatus 302 req

137+ assertStatus 301 req

138 assertHeader "Location" "/a/" req

139

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

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

144 inTempDirectory $ fileServerAppWithSettings settings $ do

145 liftIO $ touch "foo/index.html"

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

147− assertStatus 302 req

147+ assertStatus 301 req

148 assertHeader "Location" "/foo/" req

149

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

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

158 "urlMapApp: only works at subPath"

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

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

161− assertStatus 302 req

161+ assertStatus 301 req

162 assertHeader "Location" "/subPath/" req

163

164 context "with defaultWebAppSettings" $ do

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

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

1name: wai-app-static

2−version: 3.1.7.1

2+version: 3.1.6.1

3license: MIT

4license-file: LICENSE

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

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

27library

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

29 , wai >= 3.0 && < 3.3

30− , bytestring >= 0.10.4

30+ , bytestring >= 0.9.1.4

31 , http-types >= 0.7

32 , transformers >= 0.2.2

33 , unix-compat >= 0.2

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

37 , old-locale >= 1.0.0.2

38 , file-embed >= 0.0.3.1

39 , text >= 0.7

40+ , blaze-builder >= 0.2.1.4

40 , cryptonite >= 0.6

41 , cryptonite >= 0.6

41 , memory >= 0.7

42 , memory >= 0.7

42 , http-date

43 , http-date

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

49 , filepath

50 , filepath

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

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

51 , optparse-applicative >= 0.7

52 , optparse-applicative >= 0.7

52− , warp >= 3.0.11 && < 3.4

53+ , warp >= 3.0.11 && < 3.3

53

54

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

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

55 WaiAppStatic.Storage.Filesystem

56 WaiAppStatic.Storage.Filesystem

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

73 , wai-app-static

74 , wai-app-static

74 , directory >= 1.0

75 , directory >= 1.0

75 , containers >= 0.2

76 , containers >= 0.2

76− , bytestring >= 0.10.4

77+ , bytestring >= 0.9.1.4

77 , text >= 0.7

78 , text >= 0.7

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

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

79

80

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

102 , temporary

103 , temporary

103 , mockery

104 , mockery

104 -- , containers

105 -- , containers

105− ghc-options: -Wall

106+ ghc-options: -Wall

106

107

107source-repository head

108source-repository head

108 type: git

109 type: git

wai-conduit/ChangeLog.md−4

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

1−## 3.0.0.4

2−

3−* Drop dependency on blaze-builder

4−

5## 3.0.0.3

1## 3.0.0.3

6

2

7* Support wai 3.2

3* Support wai 3.2

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

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

16import qualified Data.ByteString as S

17import Control.Monad (unless)

18import Network.HTTP.Types

19−import Data.ByteString.Builder (Builder)

19+import Blaze.ByteString.Builder (Builder)

20+import Data.IORef

20import qualified Data.Conduit.List as CL

21import qualified Data.Conduit.List as CL

21

22

22-- | Stream the request body.

23-- | Stream the request body.

23--

24--

24-- Since 3.0.0

25-- Since 3.0.0

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

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

26sourceRequestBody req =

27sourceRequestBody req =

27 loop

28 loop

28 where

29 where

29− go = liftIO (getRequestBodyChunk req)

30+ go = liftIO (requestBody req)

30

31

31 loop = do

32 loop = do

32 bs <- go

33 bs <- go

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

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

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

38--

39--

39-- Since 3.0.0

40-- Since 3.0.0

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

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

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

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

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

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

43 case mbuilder of

44 case mbuilder of

44 Chunk b -> send b

45 Chunk b -> send b

45 Flush -> flush)

46 Flush -> flush)

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

49--

50--

50-- Since 3.0.0

51-- Since 3.0.0

51responseRawSource :: (MonadIO m, MonadIO n)

52responseRawSource :: (MonadIO m, MonadIO n)

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

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

53 -> Response

54 -> Response

55 -> Response

55responseRawSource app =

56responseRawSource app =

wai-conduit/example/Main.hsdeleted−19

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

1−#!/usr/bin/env stack

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

3−import Network.Wai

4−import Network.Wai.Handler.Warp

5−import Network.Wai.Conduit

6−import Network.HTTP.Types

7−import Conduit

8−import Data.ByteString.Builder (byteString)

9−import Control.Monad.Trans.Resource

10−

11−main :: IO ()

12−main = run 3000 app

13−

14−app :: Application

15−app _req respond =

16− runResourceT $ withInternalState $ \is ->

17− respond $ responseSource status200 [] $

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

19− mapC (Chunk . byteString)

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

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

1name: wai-conduit

2−version: 3.0.0.4

2+version: 3.0.0.3

3synopsis: conduit wrappers for WAI

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

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

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

18 , wai >= 3.0 && < 3.3

19 , conduit

20 , transformers

21− , bytestring >= 0.10.4

21+ , bytestring

22 , http-types

23+ , blaze-builder

23 default-language: Haskell2010

24 default-language: Haskell2010

wai-extra/ChangeLog.md−72

@@ -1,75 +1,3 @@

1−# Changelog for wai-extra

2−

3−## 3.0.29.1

4−

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

6−

7−## 3.0.29

8−

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

10−

11−## 3.0.28

12−

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

14−

15−## 3.0.27

16−

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

18−

19−## 3.0.26.1

20−

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

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

23−

24−## 3.0.26

25−

26−* Throw 413 for too large payload

27−* Throw 431 for too large headers

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

29−

30−## 3.0.25

31−

32−* Supporting `network` version 3.0.

33−

34−## 3.0.24.3

35−

36−* Drop unnecessary `lifted-base` dependency

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

38−

39−## 3.0.24.2

40−

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

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

43−

44−## 3.0.24.1

45−

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

47−

48−## 3.0.24.0

49−

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

51−

52−## 3.0.23.0

53−

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

55−

56−## 3.0.22.1

57−

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

59−

60−## 3.0.22.0

61−

62−* Support for streaming-commons 0.2

63−* Support for resourcet 1.2

64−

65−## 3.0.21.0

66−

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

68−

69−## 3.0.20.2

70−

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

72−

73## 3.0.20.1

1## 3.0.20.1

74

2

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

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

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

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

5 headers:

6

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

8−

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

10-}

8-}

11module Network.Wai.EventSource (

9module Network.Wai.EventSource (

12 ServerEvent(..),

10 ServerEvent(..),

13 eventSourceAppChan,

11 eventSourceAppChan,

14− eventSourceAppIO,

12+ eventSourceAppIO

15− eventStreamAppRaw

16 ) where

13 ) where

17

14

18import Data.Function (fix)

15import Data.Function (fix)

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

42 case eventToBuilder se of

39 case eventToBuilder se of

43 Nothing -> return ()

40 Nothing -> return ()

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

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

45−

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

47−--

48−-- @since 3.0.28

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

50−eventStreamAppRaw handler _ sendResponse =

51− sendResponse $ responseStream

52− status200

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

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

55− where

56− sendEvent sendChunk event =

57− case eventToBuilder event of

58− Nothing -> return ()

59− Just b -> sendChunk b

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

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

1{-# LANGUAGE CPP #-}

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

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

3

4{-|

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

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

9 eventToBuilder

10 ) where

11

12+import Blaze.ByteString.Builder

12−import Data.ByteString.Builder

13+import Blaze.ByteString.Builder.Char8

13#if __GLASGOW_HASKELL__ < 710

14#if __GLASGOW_HASKELL__ < 710

14import Data.Monoid

15import Data.Monoid

15#endif

16#endif

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

38 Newline as a Builder.

39 Newline as a Builder.

39-}

40-}

40nl :: Builder

41nl :: Builder

41−nl = char7 '\n'

42+nl = fromChar '\n'

42

43

44

44{-|

45{-|

45 Field names as Builder

46 Field names as Builder

46-}

47-}

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

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

48−nameField = string7 "event:"

49+nameField = fromString "event:"

49−idField = string7 "id:"

50+idField = fromString "id:"

50−dataField = string7 "data:"

51+dataField = fromString "data:"

51−retryField = string7 "retry:"

52+retryField = fromString "retry:"

52−commentField = char7 ':'

53+commentField = fromChar ':'

53

54

55

55{-|

56{-|

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

65-}

66-}

66eventToBuilder :: ServerEvent -> Maybe Builder

67eventToBuilder :: ServerEvent -> Maybe Builder

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

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

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

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

69eventToBuilder (CloseEvent) = Nothing

70eventToBuilder (CloseEvent) = Nothing

70eventToBuilder (ServerEvent n i d)= Just $

71eventToBuilder (ServerEvent n i d)= Just $

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

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

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

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

19import Data.Char (toLower)

20import qualified System.IO

21import qualified Data.String as String

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

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

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

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

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

25import System.IO (Handle)

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

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

29#if __GLASGOW_HASKELL__ < 710

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

31#endif

32−

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

32+import qualified Data.Streaming.Blaze as Blaze

34import Data.Function (fix)

33import Data.Function (fix)

35import Control.Monad (unless, void)

34import Control.Monad (unless, void)

36

35

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

131 return ResponseReceived

130 return ResponseReceived

132 _ -> do

131 _ -> do

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

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

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

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

135 wb $ \b -> do

134 wb $ \b -> do

136 let sendBuilder builder = do

135 let sendBuilder builder = do

137 popper <- blazeRecv builder

136 popper <- blazeRecv builder

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

140 unless (B.null bs) $ do

139 unless (B.null bs) $ do

141 outputH bs

140 outputH bs

142 loop

141 loop

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

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

144 b sendBuilder (sendBuilder flush)

143 b sendBuilder (sendBuilder flush)

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

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

146 return ResponseReceived

145 return ResponseReceived

147 where

146 where

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

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

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

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

150− [ string8 $ show i

149+ [ fromString $ show i

151− , char7 ' '

150+ , fromChar ' '

152− , byteString m

151+ , fromByteString m

153 ])

152 ])

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

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

155 header (x, y) = mconcat

154 header (x, y) = mconcat

156 [ x

155 [ x

157− , byteString ": "

156+ , fromByteString ": "

158 , y

157 , y

159− , char7 '\n'

158+ , fromChar '\n'

160 ]

159 ]

161 sfBuilder s hs sf fp = mconcat

160 sfBuilder s hs sf fp = mconcat

162 [ headers s hs

161 [ headers s hs

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

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

164− , char7 '\n'

163+ , fromChar '\n'

165− , byteString sf

164+ , fromByteString sf

166− , byteString " not supported"

165+ , fromByteString " not supported"

167 ]

166 ]

168 fixHeaders h =

167 fixHeaders h =

169 case lookup hContentType h of

168 case lookup hContentType h of

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

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

14readInt :: S8.ByteString -> Maybe Integer

15readInt bs =

16 case S8.readInteger bs of

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

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

18 _ -> Nothing

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

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

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

31 , hContentType, hContentLength)

32import System.Directory (doesFileExist, createDirectoryIfMissing)

33−import Data.ByteString.Builder (byteString)

33+import Blaze.ByteString.Builder (fromByteString)

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

35import Control.Exception (try, SomeException)

34import Control.Exception (try, SomeException)

36import qualified Data.Set as Set

35import qualified Data.Set as Set

37import Network.Wai.Header

36import Network.Wai.Header

38import Network.Wai.Internal

37import Network.Wai.Internal

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

38+import qualified Data.Streaming.Blaze as B

40import qualified Data.Streaming.Zlib as Z

39import qualified Data.Streaming.Zlib as Z

40+import qualified Blaze.ByteString.Builder as Blaze

41import Control.Monad (unless)

42import Data.Function (fix)

43import Control.Exception (throwIO)

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

69 def = GzipSettings GzipIgnore defaultCheckMime

70

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

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

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

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

74defaultCheckMime :: S.ByteString -> Bool

75defaultCheckMime bs =

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

89-- if gzip is supported.

90--

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

92−--

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

94−-- behavior, see 'defaultCheckMime'.

95gzip :: GzipSettings -> Middleware

92gzip :: GzipSettings -> Middleware

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

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

97 case res of

94 case res of

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

104 let

101 let

105 compressedVersion = file ++ ".gz"

102 compressedVersion = file ++ ".gz"

106 in

103 in

107− doesFileExist compressedVersion >>= \y ->

104+ doesFileExist compressedVersion >>= \x ->

108− if y

105+ if x

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

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

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

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

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

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

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

185 Just m | gzipCheckMime set m ->

182 Just m | gzipCheckMime set m ->

186 let hs' = fixHeaders hs

183 let hs' = fixHeaders hs

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

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

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

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

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

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

190 let sendBuilder builder = do

187 let sendBuilder builder = do

191 popper <- blazeRecv builder

188 popper <- blazeRecv builder

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

204 case result of

201 case result of

205 Z.PRDone -> return ()

202 Z.PRDone -> return ()

206 Z.PRNext bs' -> do

203 Z.PRNext bs' -> do

207− sendChunk $ byteString bs'

204+ sendChunk $ fromByteString bs'

208 loop

205 loop

209 Z.PRError e -> throwIO e

206 Z.PRError e -> throwIO e

210

207

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

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

18import Network.Wai.Internal

19import Data.ByteString (ByteString)

20import qualified Data.ByteString.Char8 as B8

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

21+import Blaze.ByteString.Builder (copyByteString)

22−import Data.ByteString.Builder (char7)

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

23#if __GLASGOW_HASKELL__ < 710

24import Data.Monoid (mappend)

25#endif

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

60 sendResponse $ case checkJSON hs of

61 Nothing -> r

62 Just hs' -> responseBuilder s hs' $

63− byteStringCopy c

63+ copyByteString c

64− `mappend` char7 '('

64+ `mappend` fromChar '('

65 `mappend` b

66− `mappend` char7 ')'

66+ `mappend` fromChar ')'

67 go c r =

68 case checkJSON hs of

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

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

81

82 addCallback cb s hs wb =

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

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

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

85 _ <- body sendChunk flush

86− sendChunk $ char7 ')'

86+ sendChunk $ fromChar ')'

87

88changeVal :: Eq a

89 => a

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

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

14 , OutputFormat (..)

15 , OutputFormatter

16 , OutputFormatterWithDetails

17− , OutputFormatterWithDetailsAndHeaders

18 , Destination (..)

17 , Destination (..)

19 , Callback

18 , Callback

20 , IPAddrSource (..)

19 , IPAddrSource (..)

21 ) where

20 ) where

22

21

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

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

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

23+import qualified Blaze.ByteString.Builder as B

25import qualified Data.ByteString as BS

24import qualified Data.ByteString as BS

26−import Data.ByteString.Char8 (pack)

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

27import Control.Monad (when)

26import Control.Monad (when)

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

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

29import Network.Wai

28import Network.Wai

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

41import qualified Data.ByteString.Lazy as LBS

40import qualified Data.ByteString.Lazy as LBS

42import qualified Data.ByteString.Char8 as S8

41import qualified Data.ByteString.Char8 as S8

43import System.Console.ANSI

42import System.Console.ANSI

44−import Data.IORef

43+import Data.IORef.Lifted

45import System.IO.Unsafe

44import System.IO.Unsafe

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

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

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

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

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

50import Network.Wai.Header (contentLength)

49import Network.Wai.Header (contentLength)

51import Data.Text.Encoding (decodeUtf8')

50import Data.Text.Encoding (decodeUtf8')

52

51

53−data OutputFormat

54− = Apache IPAddrSource

52+data OutputFormat = Apache IPAddrSource

55− | Detailed Bool -- ^ use colors?

53+ | Detailed Bool -- ^ use colors?

56− | CustomOutputFormat OutputFormatter

54+ | CustomOutputFormat OutputFormatter

57− | CustomOutputFormatWithDetails OutputFormatterWithDetails

55+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

58− | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

59

56

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

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

61−

62−type OutputFormatterWithDetails

58+type OutputFormatterWithDetails =

63− = ZonedDate

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

64− -> Request

65− -> Status

66− -> Maybe Integer

67− -> NominalDiffTime

68− -> [S8.ByteString]

69− -> B.Builder

70− -> LogStr

71−

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

73−--

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

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

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

77−--

78−-- @since 3.0.27

79−type OutputFormatterWithDetailsAndHeaders

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

81− -> Request -- ^ The WAI request

82− -> Status -- ^ HTTP status code

83− -> Maybe Integer -- ^ Response size

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

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

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

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

88− -> LogStr

89

60

90data Destination = Handle Handle

61data Destination = Handle Handle

91 | Logger LoggerSet

62 | Logger LoggerSet

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

137 CustomOutputFormatWithDetails formatter -> do

108 CustomOutputFormatWithDetails formatter -> do

138 getdate <- getDateGetter flusher

109 getdate <- getDateGetter flusher

139 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

110 return $ customMiddlewareWithDetails callbackAndFlush getdate formatter

140− CustomOutputFormatWithDetailsAndHeaders formatter -> do

141− getdate <- getDateGetter flusher

142− return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

143

111

144apacheMiddleware :: ApacheLoggerActions -> Middleware

112apacheMiddleware :: ApacheLoggerActions -> Middleware

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

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

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

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

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

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

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

152 date <- liftIO getdate

120 date <- liftIO getdate

153− let msize = contentLength (responseHeaders res)

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

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

122+ liftIO $ cb $ formatter date req (responseStatus res) Nothing

155 sendResponse res

123 sendResponse res

156

124

157customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware

125customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware

@@ -161,33 +129,15 @@ customMiddlewareWithDetails cb getdate formatter app req sendResponse = do

161 app req' $ \res -> do

129 app req' $ \res -> do

162 t1 <- getCurrentTime

130 t1 <- getCurrentTime

163 date <- liftIO getdate

131 date <- liftIO getdate

164− let msize = contentLength (responseHeaders res)

132+ -- We use Nothing for the response size since we generally don't know it

165− builderIO <- newIORef $ B.byteString ""

133+ builderIO <- newIORef $ B.fromByteString ""

166 res' <- recordChunks builderIO res

134 res' <- recordChunks builderIO res

167 rspRcv <- sendResponse res'

135 rspRcv <- sendResponse res'

168 _ <- liftIO . cb .

136 _ <- liftIO . cb .

169− formatter date req' (responseStatus res') msize (t1 `diffUTCTime` t0) reqBody =<<

137+ formatter date req' (responseStatus res') Nothing (t1 `diffUTCTime` t0) reqBody =<<

170 readIORef builderIO

138 readIORef builderIO

171 return rspRcv

139 return rspRcv

172

140

173−customMiddlewareWithDetailsAndHeaders :: Callback -> IO ZonedDate -> OutputFormatterWithDetailsAndHeaders -> Middleware

174−customMiddlewareWithDetailsAndHeaders cb getdate formatter app req sendResponse = do

175− (req', reqBody) <- getRequestBody req

176− t0 <- getCurrentTime

177− app req' $ \res -> do

178− t1 <- getCurrentTime

179− date <- liftIO getdate

180− let msize = contentLength (responseHeaders res)

181− builderIO <- newIORef $ B.byteString ""

182− res' <- recordChunks builderIO res

183− rspRcv <- sendResponse res'

184− _ <- do

185− rawResponse <- readIORef builderIO

186− let status = responseStatus res'

187− duration = t1 `diffUTCTime` t0

188− resHeaders = responseHeaders res'

189− liftIO . cb $ formatter date req' status msize duration reqBody rawResponse resHeaders

190− return rspRcv

191-- | Production request logger middleware.

141-- | Production request logger middleware.

192--

142--

193-- This uses the 'Apache' logging format, and takes IP addresses for clients from

143-- This uses the 'Apache' logging format, and takes IP addresses for clients from

wai-extra/Network/Wai/Middleware/RequestLogger/JSON.hs+10−48

@@ -1,13 +1,8 @@

1{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE CPP #-}

3

2

4−module Network.Wai.Middleware.RequestLogger.JSON

3+module Network.Wai.Middleware.RequestLogger.JSON (formatAsJSON) where

5− ( formatAsJSON

6− , formatAsJSONWithHeaders

7− ) where

8

4

9−import qualified Data.ByteString.Builder as BB (toLazyByteString)

5+import qualified Blaze.ByteString.Builder as BB

10−import Data.ByteString.Lazy (toStrict)

11import Data.Aeson

6import Data.Aeson

12import Data.CaseInsensitive (original)

7import Data.CaseInsensitive (original)

13import Data.Monoid ((<>))

8import Data.Monoid ((<>))

@@ -15,8 +10,7 @@ import qualified Data.ByteString.Char8 as S8

15import Data.IP

10import Data.IP

16import qualified Data.Text as T

11import qualified Data.Text as T

17import Data.Text (Text)

12import Data.Text (Text)

18−import Data.Text.Encoding (decodeUtf8With)

13+import Data.Text.Encoding (decodeUtf8)

19−import Data.Text.Encoding.Error (lenientDecode)

20import Data.Time (NominalDiffTime)

14import Data.Time (NominalDiffTime)

21import Data.Word (Word32)

15import Data.Word (Word32)

22import Network.HTTP.Types as H

16import Network.HTTP.Types as H

@@ -37,34 +31,10 @@ formatAsJSON date req status responseSize duration reqBody response =

37 , "size" .= responseSize

31 , "size" .= responseSize

38 , "body" .=

32 , "body" .=

39 if statusCode status >= 400

33 if statusCode status >= 400

40− then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ response

34+ then Just . decodeUtf8 . BB.toByteString $ response

41 else Nothing

35 else Nothing

42 ]

36 ]

43− , "time" .= decodeUtf8With lenientDecode date

37+ , "time" .= decodeUtf8 date

44− ]) <> "\n"

45−

46−-- | Same as @formatAsJSON@ but with response headers included

47−--

48−-- This is useful for passing arbitrary data from your application out to the

49−-- WAI layer for it to be logged, but you may need to be careful to

50−-- subsequently redact any headers which may contain sensitive data.

51−--

52−-- @since 3.0.27

53−formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders

54−formatAsJSONWithHeaders date req status resSize duration reqBody res resHeaders =

55− toLogStr (encode $

56− object

57− [ "request" .= requestToJSON duration req reqBody

58− , "response" .= object

59− [ "status" .= statusCode status

60− , "size" .= resSize

61− , "headers" .= responseHeadersToJSON resHeaders

62− , "body" .=

63− if statusCode status >= 400

64− then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ res

65− else Nothing

66− ]

67− , "time" .= decodeUtf8With lenientDecode date

68 ]) <> "\n"

38 ]) <> "\n"

69

39

70word32ToHostAddress :: Word32 -> Text

40word32ToHostAddress :: Word32 -> Text

@@ -76,12 +46,12 @@ readAsDouble = read

76requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value

46requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value

77requestToJSON duration req reqBody =

47requestToJSON duration req reqBody =

78 object

48 object

79− [ "method" .= decodeUtf8With lenientDecode (requestMethod req)

49+ [ "method" .= decodeUtf8 (requestMethod req)

80− , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)

50+ , "path" .= decodeUtf8 (rawPathInfo req)

81 , "queryString" .= map queryItemToJSON (queryString req)

51 , "queryString" .= map queryItemToJSON (queryString req)

82 , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)

52 , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)

83 , "size" .= requestBodyLengthToJSON (requestBodyLength req)

53 , "size" .= requestBodyLengthToJSON (requestBodyLength req)

84− , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody)

54+ , "body" .= decodeUtf8 (S8.concat reqBody)

85 , "remoteHost" .= sockToJSON (remoteHost req)

55 , "remoteHost" .= sockToJSON (remoteHost req)

86 , "httpVersion" .= httpVersionToJSON (httpVersion req)

56 , "httpVersion" .= httpVersionToJSON (httpVersion req)

87 , "headers" .= requestHeadersToJSON (requestHeaders req)

57 , "headers" .= requestHeadersToJSON (requestHeaders req)

@@ -103,13 +73,11 @@ sockToJSON (SockAddrInet6 pn _ ha _) =

103 ]

73 ]

104sockToJSON (SockAddrUnix sock) =

74sockToJSON (SockAddrUnix sock) =

105 object [ "unix" .= sock ]

75 object [ "unix" .= sock ]

106−#if !MIN_VERSION_network(3,0,0)

107sockToJSON (SockAddrCan i) =

76sockToJSON (SockAddrCan i) =

108 object [ "can" .= i ]

77 object [ "can" .= i ]

109−#endif

110

78

111queryItemToJSON :: QueryItem -> Value

79queryItemToJSON :: QueryItem -> Value

112−queryItemToJSON (name, mValue) = toJSON (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue)

80+queryItemToJSON (name, mValue) = toJSON (decodeUtf8 name, fmap decodeUtf8 mValue)

113

81

114requestHeadersToJSON :: RequestHeaders -> Value

82requestHeadersToJSON :: RequestHeaders -> Value

115requestHeadersToJSON = toJSON . map hToJ where

83requestHeadersToJSON = toJSON . map hToJ where

@@ -117,14 +85,8 @@ requestHeadersToJSON = toJSON . map hToJ where

117 hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)

85 hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)

118 hToJ hd = headerToJSON hd

86 hToJ hd = headerToJSON hd

119

87

120−responseHeadersToJSON :: [Header] -> Value

121−responseHeadersToJSON = toJSON . map hToJ where

122− -- Redact cookies

123− hToJ ("Set-Cookie", _) = toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)

124− hToJ hd = headerToJSON hd

125−

126headerToJSON :: Header -> Value

88headerToJSON :: Header -> Value

127−headerToJSON (headerName, header) = toJSON (decodeUtf8With lenientDecode . original $ headerName, decodeUtf8With lenientDecode header)

89+headerToJSON (headerName, header) = toJSON (decodeUtf8 . original $ headerName, decodeUtf8 header)

128

90

129portToJSON :: PortNumber -> Value

91portToJSON :: PortNumber -> Value

130portToJSON = toJSON . toInteger

92portToJSON = toJSON . toInteger

wai-extra/Network/Wai/Middleware/Rewrite.hs+1−17

@@ -27,7 +27,6 @@ module Network.Wai.Middleware.Rewrite

27 -- ** Recommended functions

28 , rewriteWithQueries

29 , rewritePureWithQueries

30− , rewriteRoot

31

30

32 -- ** Deprecated

31 -- ** Deprecated

33 , rewrite

32 , rewrite

@@ -169,7 +168,7 @@ import Control.Applicative

169--

168--

170-- as the following example demonstrates.

169-- as the following example demonstrates.

171--

170--

172−-- Old versions of the library could only handle path pieces, not queries.

171+-- Old versions of the libary could only handle path pieces, not queries.

173-- This could have been supplied to 'rewritePure'.

172-- This could have been supplied to 'rewritePure'.

174--

173--

175-- @

174-- @

@@ -264,21 +263,6 @@ rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQuerie

264 -> Middleware

263 -> Middleware

265rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req

264rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req

266

265

267−-- | Rewrite root requests (/) to a specified path

268−--

269−-- Note that /index.html/ in example below should already be a valid route.

270−--

271−-- @

272−-- rewriteRoot "index.html" :: Middleware

273−-- @

274−--

275−-- @since 3.0.23.0

276−rewriteRoot :: Text -> Middleware

277−rewriteRoot root = rewritePureWithQueries onlyRoot

278− where

279− onlyRoot ([], q) _ = ([root], q)

280− onlyRoot paths _ = paths

281−

282--------------------------------------------------

266--------------------------------------------------

283-- * Modifying 'Request's directly

267-- * Modifying 'Request's directly

284--------------------------------------------------

268--------------------------------------------------

wai-extra/Network/Wai/Middleware/Timeout.hsdeleted−33

@@ -1,33 +0,0 @@

1−-- | Timeout requests

2−module Network.Wai.Middleware.Timeout

3− ( timeout

4− , timeoutStatus

5− , timeoutAs

6− ) where

7−

8−import Network.HTTP.Types (Status, status503)

9−import Network.Wai

10−import qualified System.Timeout as Timeout

11−

12−-- | Time out the request after the given number of seconds

13−--

14−-- Timeouts respond with @'status503'@. See @'timeoutStatus'@ or @'timeoutAs'@

15−-- to customize the behavior of the timed-out case.

16−--

17−-- @since 3.0.24.0@

18−timeout :: Int -> Middleware

19−timeout = timeoutStatus status503

20−

21−-- | Time out with the given @'Status'@

22−--

23−-- @since 3.0.24.0@

24−timeoutStatus :: Status -> Int -> Middleware

25−timeoutStatus status = timeoutAs $ responseLBS status [] ""

26−

27−-- | Time out with the given @'Response'@

28−--

29−-- @since 3.0.24.0@

30−timeoutAs :: Response -> Int -> Middleware

31−timeoutAs timeoutReponse seconds app req respond =

32− maybe (respond timeoutReponse) pure

33− =<< Timeout.timeout (seconds * 1000000) (app req respond)

wai-extra/Network/Wai/Parse.hs+10−25

@@ -22,7 +22,6 @@ module Network.Wai.Parse

22 , parseContentType

23 , ParseRequestBodyOptions

24 , defaultParseRequestBodyOptions

25− , noLimitParseRequestBodyOptions

26 , parseRequestBodyEx

25 , parseRequestBodyEx

27 , setMaxRequestKeyLength

26 , setMaxRequestKeyLength

28 , clearMaxRequestKeyLength

27 , clearMaxRequestKeyLength

@@ -48,7 +47,7 @@ module Network.Wai.Parse

48#endif

47#endif

49 ) where

48 ) where

50

49

51−import qualified Control.Exception as E

50+import qualified Data.ByteString.Search as Search

52import qualified Data.ByteString as S

51import qualified Data.ByteString as S

53import qualified Data.ByteString.Lazy as L

52import qualified Data.ByteString.Lazy as L

54import qualified Data.ByteString.Char8 as S8

53import qualified Data.ByteString.Char8 as S8

@@ -59,16 +58,13 @@ import Data.List (sortBy)

59import Data.Function (on, fix)

58import Data.Function (on, fix)

60import System.Directory (removeFile, getTemporaryDirectory)

59import System.Directory (removeFile, getTemporaryDirectory)

61import System.IO (hClose, openBinaryTempFile)

60import System.IO (hClose, openBinaryTempFile)

62−import System.IO.Error (isDoesNotExistError)

63import Network.Wai

61import Network.Wai

64import qualified Network.HTTP.Types as H

62import qualified Network.HTTP.Types as H

65import Control.Applicative ((<$>))

63import Control.Applicative ((<$>))

66−import Control.Exception (catchJust)

67−import Control.Monad (when, unless, guard)

64+import Control.Monad (when, unless)

68import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

65import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

69import Data.IORef

66import Data.IORef

70import Network.HTTP.Types (hContentType)

67import Network.HTTP.Types (hContentType)

71−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

72import Data.CaseInsensitive (mk)

68import Data.CaseInsensitive (mk)

73

69

74import Prelude hiding (lines)

70import Prelude hiding (lines)

@@ -131,7 +127,7 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory

131 -> IO FilePath

127 -> IO FilePath

132tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

128tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

133 (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)

129 (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)

134− _ <- runInternalState (register $ removeFileQuiet fp) internalState

130+ _ <- runInternalState (register $ removeFile fp) internalState

135 fix $ \loop -> do

131 fix $ \loop -> do

136 bs <- popper

132 bs <- popper

137 unless (S.null bs) $ do

133 unless (S.null bs) $ do

@@ -143,9 +139,6 @@ tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

143 it = do

139 it = do

144 tempDir <- getTmpDir

140 tempDir <- getTmpDir

145 openBinaryTempFile tempDir pattrn

141 openBinaryTempFile tempDir pattrn

146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)

147− (removeFile fp)

148− (const $ return ())

149

142

150-- | A data structure that describes the behavior of

143-- | A data structure that describes the behavior of

151-- the parseRequestBodyEx function.

144-- the parseRequestBodyEx function.

@@ -273,7 +266,7 @@ defaultParseRequestBodyOptions = ParseRequestBodyOptions

273

266

274-- | Do not impose any memory limits.

267-- | Do not impose any memory limits.

275--

268--

276−-- @since 3.0.21.0

269+-- @since 3.0.16.0

277noLimitParseRequestBodyOptions :: ParseRequestBodyOptions

270noLimitParseRequestBodyOptions :: ParseRequestBodyOptions

278noLimitParseRequestBodyOptions = ParseRequestBodyOptions

271noLimitParseRequestBodyOptions = ParseRequestBodyOptions

279 { prboKeyLength=Nothing

272 { prboKeyLength=Nothing

@@ -337,9 +330,6 @@ parseContentType a = do

337 semicolon = 59

330 semicolon = 59

338 equals = 61

331 equals = 61

339 space = 32

332 space = 32

340− dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote

341− then S.tail $ S.init s

342− else s

343 goAttrs front bs

333 goAttrs front bs

344 | S.null bs = front []

334 | S.null bs = front []

345 | otherwise =

335 | otherwise =

@@ -348,7 +338,7 @@ parseContentType a = do

348 goAttr bs =

338 goAttr bs =

349 let (k, v') = S.break (== equals) bs

339 let (k, v') = S.break (== equals) bs

350 v = S.drop 1 v'

340 v = S.drop 1 v'

351− in (strip k, dq $ strip v)

341+ in (strip k, strip v)

352 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)

342 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)

353

343

354-- | Parse the body of an HTTP request.

344-- | Parse the body of an HTTP request.

@@ -428,8 +418,6 @@ conduitRequestBodyEx o backend (Multipart bound) rbody add =

428

418

429

419

430-- | Take one header or subheader line.

420-- | Take one header or subheader line.

431−-- Since: 3.0.26

432−-- Throw 431 if headers too large.

433takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)

421takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)

434takeLine maxlen src =

422takeLine maxlen src =

435 go ""

423 go ""

@@ -438,8 +426,7 @@ takeLine maxlen src =

438 bs <- readSource src

426 bs <- readSource src

439 case maxlen of

427 case maxlen of

440 Just maxlen' -> when (S.length front > maxlen') $

428 Just maxlen' -> when (S.length front > maxlen') $

441− E.throwIO $ ConnectionError (UnknownErrorCode 431)

429+ error "Header line length exceeds allowed maximum."

442− "Request Header Fields Too Large"

443 Nothing -> return ()

430 Nothing -> return ()

444 if S.null bs

431 if S.null bs

445 then close front

432 then close front

@@ -455,8 +442,7 @@ takeLine maxlen src =

455 let res = front `S.append` x

442 let res = front `S.append` x

456 case maxlen of

443 case maxlen of

457 Just maxlen' -> when (S.length res > maxlen') $

444 Just maxlen' -> when (S.length res > maxlen') $

458− E.throwIO $ ConnectionError (UnknownErrorCode 431)

445+ error "Header line length exceeds allowed maximum."

459− "Request Header Fields Too Large"

460 Nothing -> return ()

446 Nothing -> return ()

461 return $ Just $ killCR $ res

447 return $ Just $ killCR $ res

462

448

@@ -582,7 +568,7 @@ data Bound = FoundBound S.ByteString S.ByteString

582 deriving (Eq, Show)

568 deriving (Eq, Show)

583

569

584findBound :: S.ByteString -> S.ByteString -> Bound

570findBound :: S.ByteString -> S.ByteString -> Bound

585−findBound b bs = handleBreak $ S.breakSubstring b bs

571+findBound b bs = handleBreak $ Search.breakOn b bs

586 where

572 where

587 handleBreak (h, t)

573 handleBreak (h, t)

588 | S.null t = go [lowBound..S.length bs - 1]

574 | S.null t = go [lowBound..S.length bs - 1]

@@ -645,9 +631,8 @@ wrapTillBound bound src max' = do

645 cur <- atomicModifyIORef' sref $ \ cur ->

631 cur <- atomicModifyIORef' sref $ \ cur ->

646 let new = cur + fromIntegral (S.length bs) in (new, new)

632 let new = cur + fromIntegral (S.length bs) in (new, new)

647 case max' of

633 case max' of

648− Just max'' | cur > max'' ->

634+ Just max'' | cur > max'' -> error "Maximum size exceeded"

649− E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"

650− _ -> return ()

635+ _ -> return ()

651 if S.null bs

636 if S.null bs

652 then do

637 then do

653 writeIORef ref $ WTBDone False

638 writeIORef ref $ WTBDone False

wai-extra/Network/Wai/Test.hs+19−25

@@ -52,7 +52,8 @@ import qualified Data.Map as Map

52import qualified Web.Cookie as Cookie

53import Data.ByteString (ByteString)

54import qualified Data.ByteString.Char8 as S8

55−import Data.ByteString.Builder (toLazyByteString)

55+import Blaze.ByteString.Builder (toLazyByteString, toByteString)

56+import qualified Blaze.ByteString.Builder as B

56import qualified Data.ByteString.Lazy as L

57import qualified Data.ByteString.Lazy as L

57import qualified Data.ByteString.Lazy.Char8 as L8

58import qualified Data.ByteString.Lazy.Char8 as L8

58import qualified Network.HTTP.Types as H

59import qualified Network.HTTP.Types as H

@@ -99,10 +100,6 @@ runSession session app = ST.evalStateT (runReaderT session app) initState

99data SRequest = SRequest

100data SRequest = SRequest

100 { simpleRequest :: Request

101 { simpleRequest :: Request

101 , simpleRequestBody :: L.ByteString

102 , simpleRequestBody :: L.ByteString

102− -- ^ Request body that will override the one set in 'simpleRequest'.

103− --

104− -- This is usually simpler than setting the body as a stateful IO-action

105− -- in 'simpleRequest'.

106 }

103 }

107data SResponse = SResponse

104data SResponse = SResponse

108 { simpleStatus :: H.Status

105 { simpleStatus :: H.Status

@@ -110,22 +107,14 @@ data SResponse = SResponse

110 , simpleBody :: L.ByteString

107 , simpleBody :: L.ByteString

111 }

108 }

112 deriving (Show, Eq)

109 deriving (Show, Eq)

113−

114request :: Request -> Session SResponse

110request :: Request -> Session SResponse

115−request req = do

111+request = srequest . flip SRequest L.empty

116− app <- ask

117− req' <- addCookiesToRequest req

118− response <- liftIO $ do

119− ref <- newIORef $ error "runResponse gave no result"

120− ResponseReceived <- app req' (runResponse ref)

121− readIORef ref

122− extractSetCookieFromSResponse response

123

112

124-- | Set whole path (request path + query string).

113-- | Set whole path (request path + query string).

125setPath :: Request -> S8.ByteString -> Request

114setPath :: Request -> S8.ByteString -> Request

126setPath req path = req {

115setPath req path = req {

127 pathInfo = segments

116 pathInfo = segments

128− , rawPathInfo = (L8.toStrict . toLazyByteString) (H.encodePathSegments segments)

117+ , rawPathInfo = B.toByteString (H.encodePathSegments segments)

129 , queryString = query

118 , queryString = query

130 , rawQueryString = (H.renderQuery True query)

119 , rawQueryString = (H.renderQuery True query)

131 }

120 }

@@ -154,7 +143,7 @@ addCookiesToRequest req = do

154 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)

143 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)

155 | c <- map snd $ Map.toList cookiesForRequest

144 | c <- map snd $ Map.toList cookiesForRequest

156 ]

145 ]

157− let cookieValue = L8.toStrict . toLazyByteString $ Cookie.renderCookies cookiePairs

146+ let cookieValue = toByteString $ Cookie.renderCookies cookiePairs

158 addCookieHeader rest

147 addCookieHeader rest

159 | null cookiePairs = rest

148 | null cookiePairs = rest

160 | otherwise = ("Cookie", cookieValue) : rest

149 | otherwise = ("Cookie", cookieValue) : rest

@@ -178,18 +167,23 @@ extractSetCookieFromSResponse response = do

178 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))

167 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))

179 return response

168 return response

180

169

181−-- | Similar to 'request', but allows setting the request body as a plain

182−-- 'L.ByteString'.

183srequest :: SRequest -> Session SResponse

170srequest :: SRequest -> Session SResponse

184srequest (SRequest req bod) = do

171srequest (SRequest req bod) = do

172+ app <- ask

185 refChunks <- liftIO $ newIORef $ L.toChunks bod

173 refChunks <- liftIO $ newIORef $ L.toChunks bod

186− request $

187− req

174+ let req' = req

188− { requestBody = atomicModifyIORef refChunks $ \bss ->

175+ { requestBody = atomicModifyIORef refChunks $ \bss ->

189− case bss of

176+ case bss of

190− [] -> ([], S.empty)

177+ [] -> ([], S.empty)

191− x:y -> (y, x)

178+ x:y -> (y, x)

179+ , requestBodyLength = KnownLength $ fromIntegral $ L.length bod

192− }

180+ }

181+ req'' <- addCookiesToRequest req'

182+ response <- liftIO $ do

183+ ref <- newIORef $ error "runResponse gave no result"

184+ ResponseReceived <- app req'' (runResponse ref)

185+ readIORef ref

186+ extractSetCookieFromSResponse response

193

187

194runResponse :: IORef SResponse -> Response -> IO ResponseReceived

188runResponse :: IORef SResponse -> Response -> IO ResponseReceived

195runResponse ref res = do

189runResponse ref res = do

wai-extra/example/Main.hs+4−15

@@ -1,7 +1,7 @@

1{-# LANGUAGE OverloadedStrings #-}

2module Main where

3

4−import Data.ByteString.Builder (string8)

4+import Blaze.ByteString.Builder.Char.Utf8 (fromString)

5import Control.Concurrent (forkIO, threadDelay)

6import Control.Concurrent.Chan

7import Control.Monad

@@ -27,26 +27,15 @@ eventChan :: Chan ServerEvent -> IO ()

27eventChan chan = forever $ do

28 threadDelay 1000000

29 time <- getPOSIXTime

30− writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time])

30+ writeChan chan (ServerEvent Nothing Nothing [fromString . show $ time])

31

32eventIO :: IO ServerEvent

33eventIO = do

34 threadDelay 1000000

35 time <- getPOSIXTime

36− return $ ServerEvent (Just $ string8 "io")

36+ return $ ServerEvent (Just $ fromString "io")

37 Nothing

38− [string8 . show $ time]

38+ [fromString . 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

39

51main :: IO ()

40main :: IO ()

52main = do

41main = do

wai-extra/test/Network/Wai/Middleware/TimeoutSpec.hsdeleted−57

@@ -1,57 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module Network.Wai.Middleware.TimeoutSpec

4− ( spec

5− ) where

6−

7−import Test.Hspec

8−

9−import Control.Concurrent (threadDelay)

10−import Network.HTTP.Types (status200, status503, status504)

11−import Network.Wai

12−import Network.Wai.Middleware.Timeout

13−import Network.Wai.Test

14−

15−spec :: Spec

16−spec = do

17− describe "timeout" $ do

18− it "times out slow requests with 503" $ do

19− let app _req respond = do

20− threadDelay $ 2 * 1000000

21− respond $ responseLBS status200 [] ""

22−

23− resp <- runApp $ timeout 1 app

24−

25− simpleStatus resp `shouldBe` status503

26−

27− it "does not time out fast requests" $ do

28− let app _req respond = respond $ responseLBS status200 [] ""

29−

30− resp <- runApp $ timeout 3 app

31−

32− simpleStatus resp `shouldBe` status200

33−

34− describe "timeoutStatus" $ do

35− it "allows customizing the timeout response status" $ do

36− let app _req respond = do

37− threadDelay $ 2 * 1000000

38− respond $ responseLBS status200 [] ""

39−

40− resp <- runApp $ timeoutStatus status504 1 app

41−

42− simpleStatus resp `shouldBe` status504

43−

44− describe "timeoutAs" $ do

45− it "allows customizing the timeout response" $ do

46− let app _req respond = do

47− threadDelay $ 2 * 1000000

48− respond $ responseLBS status200 [] ""

49− timeoutResponse = responseLBS status503 [("X-Timeout", "1")] ""

50−

51− resp <- runApp $ timeoutAs timeoutResponse 1 app

52−

53− simpleStatus resp `shouldBe` status503

54− simpleHeaders resp `shouldBe` [("X-Timeout", "1")]

55−

56−runApp :: Application -> IO SResponse

57−runApp = runSession $ request defaultRequest

wai-extra/test/Network/Wai/ParseSpec.hs+5−15

@@ -13,7 +13,6 @@ import qualified Data.ByteString.Lazy as L

13import qualified Data.Text as TS

14import qualified Data.Text.Encoding as TE

15import Control.Monad.Trans.Resource (withInternalState, runResourceT)

16−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

17

16

18import Network.Wai

17import Network.Wai

19import Network.Wai.Test

18import Network.Wai.Test

@@ -31,7 +30,6 @@ spec = do

31 [ ("text/plain", "text/plain", [])

30 [ ("text/plain", "text/plain", [])

32 , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])

31 , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])

33 , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")])

32 , ("text/plain; charset=UTF-8 ; boundary = foo", "text/plain", [("charset", "UTF-8"), ("boundary", "foo")])

34− , ("text/plain; charset=UTF-8 ; boundary = \"quoted\"", "text/plain", [("charset", "UTF-8"), ("boundary", "quoted")])

35 ]

33 ]

36 it "parseHttpAccept" caseParseHttpAccept

34 it "parseHttpAccept" caseParseHttpAccept

37 describe "parseRequestBody" $ do

35 describe "parseRequestBody" $ do

@@ -95,9 +93,6 @@ caseParseRequestBody = do

95 let expectedfile3 = [("yaml", FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n")]

93 let expectedfile3 = [("yaml", FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n")]

96 let expected3 = (expectedsmap3, expectedfile3)

94 let expected3 = (expectedsmap3, expectedfile3)

97

95

98− let unknownErrorException c (ConnectionError (UnknownErrorCode code) _) = c == code

99− unknownErrorException _ _ = False

100−

101

96

102 let def = defaultParseRequestBodyOptions

97 let def = defaultParseRequestBodyOptions

103 it "parsing actual post multipart/form-data" $ do

98 it "parsing actual post multipart/form-data" $ do

@@ -123,21 +118,17 @@ caseParseRequestBody = do

123

118

124 it "exceeding file size" $ do

119 it "exceeding file size" $ do

125 SRequest req4 _bod4 <- toRequest'' ctype3 content3

120 SRequest req4 _bod4 <- toRequest'' ctype3 content3

126− (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4)

121+ (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

127− `shouldThrow` unknownErrorException 413

128

122

129 it "exceeding total file size" $ do

123 it "exceeding total file size" $ do

130 SRequest req4 _bod4 <- toRequest'' ctype3 content3

124 SRequest req4 _bod4 <- toRequest'' ctype3 content3

131− (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4)

125+ (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

132− `shouldThrow` unknownErrorException 413

133 SRequest req5 _bod5 <- toRequest'' ctype3 content5

126 SRequest req5 _bod5 <- toRequest'' ctype3 content5

134− (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5)

127+ (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5) `shouldThrow` anyErrorCall

135− `shouldThrow` unknownErrorException 413

136

128

137 it "exceeding max parm value size" $ do

129 it "exceeding max parm value size" $ do

138 SRequest req4 _bod4 <- toRequest'' ctype2 content2

130 SRequest req4 _bod4 <- toRequest'' ctype2 content2

139− (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4)

131+ (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

140− `shouldThrow` unknownErrorException 413

141

132

142 it "exceeding max header lines" $ do

133 it "exceeding max header lines" $ do

143 SRequest req4 _bod4 <- toRequest'' ctype2 content2

134 SRequest req4 _bod4 <- toRequest'' ctype2 content2

@@ -145,8 +136,7 @@ caseParseRequestBody = do

145

136

146 it "exceeding header line size" $ do

137 it "exceeding header line size" $ do

147 SRequest req4 _bod4 <- toRequest'' ctype3 content4

138 SRequest req4 _bod4 <- toRequest'' ctype3 content4

148− (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4)

139+ (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall

149− `shouldThrow` unknownErrorException 431

150

140

151 it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do

141 it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do

152 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

142 let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"

wai-extra/test/Network/Wai/TestSpec.hs+12−46

@@ -3,8 +3,6 @@ module Network.Wai.TestSpec (main, spec) where

3

4import Control.Monad (void)

5

6−import qualified Data.IORef as IORef

7−

8import qualified Data.Text.Encoding as TE

6import qualified Data.Text.Encoding as TE

9

7

10import Data.Time.Calendar (fromGregorian)

8import Data.Time.Calendar (fromGregorian)

@@ -18,17 +16,13 @@ import Network.Wai.Test

18import Network.HTTP.Types (status200)

16import Network.HTTP.Types (status200)

19

17

20import qualified Data.ByteString.Lazy.Char8 as L8

18import qualified Data.ByteString.Lazy.Char8 as L8

21−import Data.ByteString.Builder (Builder, toLazyByteString)

19+import Blaze.ByteString.Builder (toByteString)

22−import Data.ByteString (ByteString)

23

20

24import qualified Web.Cookie as Cookie

21import qualified Web.Cookie as Cookie

25

22

26main :: IO ()

23main :: IO ()

27main = hspec spec

24main = hspec spec

28

25

29−toByteString :: Builder -> ByteString

30−toByteString = L8.toStrict . toLazyByteString

31−

32spec :: Spec

26spec :: Spec

33spec = do

27spec = do

34 describe "setPath" $ do

28 describe "setPath" $ do

@@ -55,53 +49,25 @@ spec = do

55 it "sets rawQueryString to empty string" $ do

49 it "sets rawQueryString to empty string" $ do

56 rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""

50 rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""

57

51

58− describe "srequest" $ do

59−

60− let echoApp req respond = do

61− reqBody <- L8.fromStrict <$> getRequestBodyChunk req

62− let reqHeaders = requestHeaders req

63− respond $

64− responseLBS

65− status200

66− reqHeaders

67− reqBody

68−

69− it "returns the response body of an echo app" $ do

70− sresp <- flip runSession echoApp $

71− srequest $ SRequest defaultRequest "request body"

72− simpleBody sresp `shouldBe` "request body"

73−

74 describe "request" $ do

52 describe "request" $ do

75

53

76− let echoApp req respond = do

54+ let simpleApp _req respond =

77− reqBody <- L8.fromStrict <$> getRequestBodyChunk req

78− let reqHeaders = requestHeaders req

79 respond $

55 respond $

80 responseLBS

56 responseLBS

81 status200

57 status200

82− reqHeaders

58+ [("foo", "bar")]

83− reqBody

59+ "simple"

84

60

85− it "returns the status code of an echo app on default request" $ do

61+ it "returns the status code of a simple app on default request" $ do

86− sresp <- runSession (request defaultRequest) echoApp

62+ sresp <- runSession (request defaultRequest) simpleApp

87 simpleStatus sresp `shouldBe` status200

63 simpleStatus sresp `shouldBe` status200

88

64

89− it "returns the response body of an echo app" $ do

65+ it "returns the response body of a simple app on default request" $ do

90− bodyRef <- IORef.newIORef "request body"

91− let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover)

92− sresp <- flip runSession echoApp $

93− request $

94− defaultRequest

66+ sresp <- runSession (request defaultRequest) simpleApp

95− { requestBody = getBodyChunk

96− }

97− simpleBody sresp `shouldBe` "request body"

67+ simpleBody sresp `shouldBe` "simple"

98−

68+

99− it "returns the response headers of an echo app" $ do

69+ it "returns the response headers of a simple app on default request" $ do

100− sresp <- flip runSession echoApp $

101− request $

102− defaultRequest

70+ sresp <- runSession (request defaultRequest) simpleApp

103− { requestHeaders = [("foo", "bar")]

104− }

105 simpleHeaders sresp `shouldBe` [("foo", "bar")]

71 simpleHeaders sresp `shouldBe` [("foo", "bar")]

106

72

107 let cookieApp req respond =

73 let cookieApp req respond =

wai-extra/wai-extra.cabal+12−12

@@ -1,5 +1,5 @@

1Name: wai-extra

2−Version: 3.0.29.1

2+Version: 3.0.20.1

3Synopsis: Provides some basic WAI handlers and middleware.

4description:

5 Provides basic WAI handler and middleware functionality:

@@ -87,35 +87,37 @@ flag build-example

87 default: False

88

89Library

90− Build-Depends: base >= 4.8 && < 5

90+ Build-Depends: base >= 4.6 && < 5

91− , bytestring >= 0.10.4

91+ , bytestring >= 0.9.1.4

92 , wai >= 3.0.3.0 && < 3.3

93 , old-locale >= 1.0.0.2 && < 1.1

94 , time >= 1.1.4

95 , network >= 2.6.1.0

96 , directory >= 1.0.1

97 , transformers >= 0.2.2

98+ , blaze-builder >= 0.2.1.4 && < 0.5

98 , http-types >= 0.7

99 , http-types >= 0.7

99 , text >= 0.7

100 , text >= 0.7

100 , case-insensitive >= 0.2

101 , case-insensitive >= 0.2

101 , data-default-class

102 , data-default-class

102− , fast-logger >= 2.4.5

103+ , fast-logger >= 2.4.5 && < 2.5

103− , wai-logger >= 2.3.2

104+ , wai-logger >= 2.2.6 && < 2.4

104 , ansi-terminal

105 , ansi-terminal

105− , resourcet >= 0.4.6 && < 1.3

106+ , resourcet >= 0.4.6 && < 1.2

106 , void >= 0.5

107 , void >= 0.5

108+ , stringsearch >= 0.3 && < 0.4

107 , containers

109 , containers

108 , base64-bytestring

110 , base64-bytestring

109 , word8

111 , word8

112+ , lifted-base >= 0.1.2

110 , deepseq

113 , deepseq

111− , streaming-commons >= 0.2

114+ , streaming-commons

112 , unix-compat

115 , unix-compat

113 , cookie

116 , cookie

114 , vault

117 , vault

115 , zlib

118 , zlib

116 , aeson

119 , aeson

117 , iproute

120 , iproute

118− , http2

119

121

120 if os(windows)

122 if os(windows)

121 cpp-options: -DWINDOWS

123 cpp-options: -DWINDOWS

@@ -147,7 +149,6 @@ Library

147 Network.Wai.Middleware.ForceDomain

149 Network.Wai.Middleware.ForceDomain

148 Network.Wai.Middleware.ForceSSL

150 Network.Wai.Middleware.ForceSSL

149 Network.Wai.Middleware.Routed

151 Network.Wai.Middleware.Routed

150− Network.Wai.Middleware.Timeout

151 Network.Wai.Parse

152 Network.Wai.Parse

152 Network.Wai.Request

153 Network.Wai.Request

153 Network.Wai.UrlMap

154 Network.Wai.UrlMap

@@ -170,7 +171,7 @@ executable example

170 , wai

171 , wai

171 , time

172 , time

172 , http-types

173 , http-types

173− , bytestring

174+ , blaze-builder

174 else

175 else

175 buildable: False

176 buildable: False

176 default-language: Haskell2010

177 default-language: Haskell2010

@@ -186,7 +187,6 @@ test-suite spec

186 Network.Wai.Middleware.ForceSSLSpec

187 Network.Wai.Middleware.ForceSSLSpec

187 Network.Wai.Middleware.RoutedSpec

188 Network.Wai.Middleware.RoutedSpec

188 Network.Wai.Middleware.StripHeadersSpec

189 Network.Wai.Middleware.StripHeadersSpec

189− Network.Wai.Middleware.TimeoutSpec

190 WaiExtraSpec

191 build-depends: base >= 4 && < 5

192 , wai-extra

@@ -200,10 +200,10 @@ test-suite spec

200 , resourcet

201 , bytestring

202 , HUnit

203+ , blaze-builder

203 , cookie

204 , cookie

204 , time

205 , time

205 , case-insensitive

206 , case-insensitive

206− , http2

207 ghc-options: -Wall

208 default-language: Haskell2010

209

wai-handler-fastcgi/.gitignorenew file+4

@@ -0,0 +1,4 @@

1+/dist/

2+*.swp

3+*.hi

4+*.o

wai-handler-fastcgi/ChangeLog.mdnew file+3

@@ -0,0 +1,3 @@

1+## 3.0.0.2

2+

3+* Support wai 3.2

time-manager/LICENSE → wai-handler-fastcgi/LICENSErenamed

The content is the same.

wai-handler-fastcgi/Network/Wai/Handler/FastCGI.hscnew file+192

@@ -0,0 +1,192 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+{-# LANGUAGE EmptyDataDecls #-}

3+{-# LANGUAGE CPP #-}

4+-----------------------------------------------------------------------------

5+-- |

6+-- Module : Network.Wai.Handler.FastCGI

7+-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006, (c) Michael Snoyman 2010

8+-- License : BSD-style (see the file libraries/network/LICENSE)

9+--

10+-- Maintainer : michael@snoyman.com

11+-- Stability : experimental

12+-- Portability : non-portable (uses FFI)

13+--

14+-- Interface for FastCGI <http://fastcgi.com/>, using the fcgiapp API.

15+-- Totally ripped off by Michael Snoyman to work with Hack, then WAI.

16+--

17+-----------------------------------------------------------------------------

18+module Network.Wai.Handler.FastCGI

19+ ( run

20+ , runSendfile

21+ , runFork

22+ ) where

23+

24+import Control.Monad ( liftM, forever )

25+import Data.Word (Word8)

26+import Foreign ( Ptr, castPtr, nullPtr, peekArray0

27+ , throwIfNeg_, mallocBytes, free )

28+#ifdef GHC_7_4

29+import Foreign.C (CInt(..), CString, CStringLen)

30+#else

31+import Foreign.C (CInt, CString, CStringLen)

32+#endif

33+import Control.Exception (finally)

34+import Foreign.Storable ( Storable (..) )

35+

36+import qualified Network.Wai as W

37+import qualified Network.Wai.Handler.CGI as CGI

38+

39+import qualified Data.ByteString as S

40+import qualified Data.ByteString.Char8 as S8

41+import qualified Data.ByteString as BS

42+import qualified Data.ByteString.Internal as BSB

43+import qualified Data.ByteString.Unsafe as BSB

44+

45+import Control.Arrow ((***))

46+

47+#include <fcgiapp.h>

48+

49+------------------------------------------------------------------------

50+

51+data FCGX_Stream

52+type StreamPtr = Ptr FCGX_Stream

53+type Environ = Ptr CString

54+

55+------------------------------------------------------------------------

56+

57+foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr

58+ :: CString -> CInt -> StreamPtr -> IO CInt

59+

60+foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr

61+ :: CString -> CInt -> StreamPtr -> IO CInt

62+

63+

64+------------------------------------------------------------------------

65+

66+foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init

67+ :: IO CInt

68+

69+runFork :: Maybe S.ByteString -> (IO () -> IO a) -> Int -> W.Application -> IO ()

70+runFork sf fork threads app = do

71+ testReturn "FCGX_Init" $ fcgx_init

72+ let oneThread = forever $ oneRequest app sf

73+ mapM_ fork $ replicate (threads - 1) oneThread

74+ oneThread

75+

76+-- | Handle FastCGI requests in an infinite loop.

77+run :: W.Application -> IO ()

78+run = runFork Nothing id 1

79+

80+-- | Handle FastCGI requests in an infinite loop. For a server which supports

81+-- the X-Sendfile header.

82+runSendfile :: S.ByteString -> W.Application -> IO ()

83+runSendfile sf = runFork (Just sf) id 1

84+

85+oneRequest :: W.Application

86+ -> Maybe S.ByteString -- X-Sendfile

87+ -> IO ()

88+oneRequest app xsendfile = withRequest $ \r -> do

89+ putStrLn "Received 1 request"

90+ env <- peekEnvp r

91+ ins <- peekIn r

92+ outs <- peekOut r

93+ handleRequest app ins outs env xsendfile

94+

95+peekIn, peekOut :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)

96+peekIn = (#peek FCGX_Request, in)

97+peekOut = (#peek FCGX_Request, out)

98+

99+peekEnvp :: Ptr FCGX_Request -> IO Environ

100+peekEnvp = (#peek FCGX_Request, envp)

101+

102+foreign import ccall unsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest

103+ :: Ptr FCGX_Request -> CInt -> CInt -> IO CInt

104+

105+foreign import ccall safe "fcgiapp.h FCGX_Accept_r" fcgx_accept_r

106+ :: Ptr FCGX_Request -> IO CInt

107+

108+acceptRequest :: IO (Ptr FCGX_Request)

109+acceptRequest = do

110+ reqp <- mallocBytes (#size FCGX_Request)

111+ initAndAccept reqp

112+ return reqp

113+ where initAndAccept reqp = do

114+ testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0

115+ testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp

116+

117+withRequest :: (Ptr FCGX_Request -> IO ()) -> IO ()

118+withRequest f = do

119+ req <- acceptRequest

120+ f req `finally` finishRequest req

121+

122+foreign import ccall unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r

123+ :: Ptr FCGX_Request -> IO ()

124+

125+finishRequest :: Ptr FCGX_Request -> IO ()

126+finishRequest reqp = do

127+ fcgx_finish_r reqp

128+ free reqp

129+

130+handleRequest :: W.Application

131+ -> StreamPtr

132+ -> StreamPtr

133+ -> Environ

134+ -> Maybe S.ByteString -- sendfile

135+ -> IO ()

136+handleRequest f ins outs env xsendfile = do

137+ vars <- environToTable env

138+ let vars' = map (S8.unpack *** S8.unpack) vars

139+ let input = const $ sRead ins

140+ let hPut = sPutStr' outs

141+ CGI.runGeneric vars' (CGI.requestBodyFunc input) hPut xsendfile f

142+

143+data FCGX_Request

144+

145+--

146+-- * Stream IO

147+--

148+

149+sPutStr' :: StreamPtr -> BS.ByteString -> IO ()

150+sPutStr' h str =

151+ BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h

152+

153+fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO ()

154+fcgxPutCStringLen h (cs,len) =

155+ testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h

156+

157+sRead :: StreamPtr -> IO (Maybe BS.ByteString)

158+sRead h = buildByteString (fcgxGetBuf h) 4096

159+

160+fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int

161+fcgxGetBuf h p c =

162+ liftM fromIntegral $ fcgx_getStr (castPtr p) (fromIntegral c) h

163+

164+--

165+-- * ByteString utilities

166+--

167+

168+-- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary

169+-- reading functions.

170+buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO (Maybe BS.ByteString)

171+buildByteString f k = do

172+ ps <- BSB.createAndTrim k $ \p -> f p k

173+ case BS.length ps of

174+ 0 -> return Nothing

175+ _ -> return $ Just ps

176+

177+--

178+-- * Utilities

179+--

180+

181+testReturn :: String -> IO CInt -> IO ()

182+testReturn e = throwIfNeg_ (\n -> e ++ " failed with error code: "++ show n)

183+

184+environToTable :: Environ -> IO [(S.ByteString, S.ByteString)]

185+environToTable arr = do

186+ css <- peekArray0 nullPtr arr

187+ ss <- mapM S.packCString css

188+ return $ map splitEq ss

189+ where

190+ splitEq s =

191+ let (a, b) = S.breakByte 61 s

192+ in (a, S.drop 1 b)

wai-handler-fastcgi/READMEnew file

No changes to the content.

wai-handler-fastcgi/README.mdnew file+3

@@ -0,0 +1,3 @@

1+## wai-handler-fastcgi

2+

3+Calls out to the libfcgi C library.

wai-handler-fastcgi/Setup.lhsnew file+7

@@ -0,0 +1,7 @@

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-fastcgi/configurenew file+9

@@ -0,0 +1,9 @@

1+#!/bin/sh

2+#

3+

4+# subst standard header path variables

5+if test -n "$CPPFLAGS" ; then

6+ echo "Found CPPFLAGS in environment: '$CPPFLAGS'"

7+ sed 's,@CPPFLAGS@,'"$CPPFLAGS"',g;s,@LDFLAGS@,'"$LDFLAGS"',g' \

8+ < fastcgi.buildinfo.in > fastcgi.buildinfo

9+fi

wai-handler-fastcgi/fastcgi.buildinfo.innew file+3

@@ -0,0 +1,3 @@

1+ghc-options: -optc@CPPFLAGS@

2+cc-options: @CPPFLAGS@

3+ld-options: @LDFLAGS@

wai-handler-fastcgi/lighttpd.confnew file+19

@@ -0,0 +1,19 @@

1+# Run with lighttpd -D -f lighttpd.conf

2+server.port = 3000

3+server.document-root = "."

4+server.modules = ("mod_fastcgi", "mod_rewrite")

5+

6+url.rewrite-once = (

7+ "(.*)" => "/app/$1"

8+)

9+

10+fastcgi.server = (

11+ "/app" => ((

12+ "socket" => "/tmp/test.fastcgi.socket",

13+ "check-local" => "disable",

14+ "bin-path" => "./test",

15+ "min-procs" => 1,

16+ "max-procs" => 12,

17+ "idle-timeout" => 30

18+ ))

19+)

wai-handler-fastcgi/test.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.FastCGI

4+import Control.Monad.IO.Class

5+import qualified Data.ByteString.Lazy as L

6+import qualified Data.ByteString.Lazy.Char8 as L8

7+import qualified Data.Enumerator as E

8+

9+main = run app

10+

11+app req

12+ | pathInfo req == "/" = return $ responseLBS status200 [("Content-Type", "text/html")] "<form method='post' action='/post'><input type='text' name='name'><input type='submit'></form>"

13+app req = do

14+ bss <- E.consume

15+ return $ responseLBS status200 [("Content-Type", "text/plain")] $ L.concat

16+ [ L8.pack $ show $ requestHeaders req

17+ , "\n"

18+ , L.fromChunks bss

19+ ]

wai-handler-fastcgi/wai-handler-fastcgi.cabalnew file+31

@@ -0,0 +1,31 @@

1+name: wai-handler-fastcgi

2+version: 3.0.0.2

3+license: MIT

4+license-file: LICENSE

5+author: Michael Snoyman <michael@snoyman.com>

6+maintainer: Michael Snoyman <michael@snoyman.com>

7+synopsis: Wai handler to fastcgi

8+description: API docs and the README are available at <http://www.stackage.org/package/wai-handler-fastcgi>.

9+category: Web

10+stability: stable

11+cabal-version: >= 1.6

12+build-type: Configure

13+extra-source-files: configure fastcgi.buildinfo.in README.md ChangeLog.md

14+homepage: http://www.yesodweb.com/book/web-application-interface

15+

16+library

17+ build-depends: base >= 4 && < 5

18+ , wai >= 3.0 && < 3.3

19+ , wai-extra >= 3.0 && < 3.1

20+ , bytestring >= 0.9.1.4

21+ exposed-modules: Network.Wai.Handler.FastCGI

22+ ghc-options: -Wall

23+ includes: fcgiapp.h

24+ extra-libraries: fcgi

25+

26+ if impl(ghc >= 7.4)

27+ cpp-options: -DGHC_7_4

28+

29+source-repository head

30+ type: git

31+ location: git://github.com/yesodweb/wai.git

wai-handler-launch/.gitignorenew file+2

@@ -0,0 +1,2 @@

1+dist/

2+*.swp

wai-handler-launch/ChangeLog.mdnew file+31

@@ -0,0 +1,31 @@

1+## 3.0.2.3

2+

3+* `process` package bump

4+

5+## 3.0.2.2

6+

7+* Improvements to ping's javascript script. [#494](https://github.com/yesodweb/wai/pull/494)

8+

9+## 3.0.2.1

10+

11+* Relax upper bound on process

12+

13+## 3.0.2

14+

15+* 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)

16+

17+## 3.0.1

18+

19+* make host configurable too (fixes #538) [#539](https://github.com/yesodweb/wai/pull/539)

20+

21+## 3.0.0.5

22+

23+* Support wai/warp 3.2

24+

25+## 3.0.0.3

26+

27+Allow blaze-builder 0.4

28+

29+## 3.0.0.2

30+

31+* Support for Win64

wai-handler-launch/LICENSEnew file+20

@@ -0,0 +1,20 @@

2+

3+Permission is hereby granted, free of charge, to any person obtaining

4+a copy of this software and associated documentation files (the

5+"Software"), to deal in the Software without restriction, including

6+without limitation the rights to use, copy, modify, merge, publish,

7+distribute, sublicense, and/or sell copies of the Software, and to

8+permit persons to whom the Software is furnished to do so, subject to

9+the following conditions:

10+

11+The above copyright notice and this permission notice shall be

12+included in all copies or substantial portions of the Software.

13+

14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE

18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION

19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION

20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

wai-handler-launch/Network/Wai/Handler/Launch.hsnew file+222

@@ -0,0 +1,222 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ForeignFunctionInterface #-}

3+{-# LANGUAGE CPP #-}

4+module Network.Wai.Handler.Launch

5+ ( run

6+ , runUrl

7+ , runUrlPort

8+ , runHostPortUrl

9+ ) where

10+

11+import Network.Wai

12+import Network.Wai.Internal

13+import Network.HTTP.Types

14+import qualified Network.Wai.Handler.Warp as Warp

15+import Data.IORef

16+import Data.Monoid (mappend)

17+import Data.String (fromString)

18+import Control.Concurrent (forkIO, threadDelay, newEmptyMVar, putMVar, takeMVar)

19+import Control.Concurrent.Async (race)

20+import Control.Monad.IO.Class (liftIO)

21+import Control.Monad (unless)

22+import Control.Exception (throwIO)

23+import Data.Function (fix)

24+import qualified Data.ByteString as S

25+import Blaze.ByteString.Builder (fromByteString, Builder, flush)

26+import qualified Blaze.ByteString.Builder as Blaze

27+#if WINDOWS

28+import Foreign

29+import Foreign.C.String

30+#else

31+import System.Process (rawSystem)

32+#endif

33+import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)

34+import qualified Data.Streaming.Zlib as Z

35+

36+ping :: IORef Bool -> Middleware

37+ping active app req sendResponse

38+ | pathInfo req == ["_ping"] = do

39+ liftIO $ writeIORef active True

40+ sendResponse $ responseLBS status200 [] ""

41+ | otherwise = app req $ \res -> do

42+ let isHtml hs =

43+ case lookup "content-type" hs of

44+ Just ct -> "text/html" `S.isPrefixOf` ct

45+ Nothing -> False

46+ if isHtml $ responseHeaders res

47+ then do

48+ let (s, hs, withBody) = responseToStream res

49+ (isEnc, headers') = fixHeaders id hs

50+ headers'' = filter (\(x, _) -> x /= "content-length") headers'

51+ withBody $ \body ->

52+ sendResponse $ responseStream s headers'' $ \sendChunk flush ->

53+ addInsideHead sendChunk flush $ \sendChunk' flush' ->

54+ if isEnc

55+ then decode sendChunk' flush' body

56+ else body sendChunk' flush'

57+ else sendResponse res

58+

59+decode :: (Builder -> IO ()) -> IO ()

60+ -> StreamingBody

61+ -> IO ()

62+decode sendInner flushInner streamingBody = do

63+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

64+ inflate <- Z.initInflate $ Z.WindowBits 31

65+ let send builder = blazeRecv builder >>= goBuilderPopper

66+ goBuilderPopper popper = fix $ \loop -> do

67+ bs <- popper

68+ unless (S.null bs) $ do

69+ Z.feedInflate inflate bs >>= goZlibPopper

70+ loop

71+ goZlibPopper popper = fix $ \loop -> do

72+ res <- popper

73+ case res of

74+ Z.PRDone -> return ()

75+ Z.PRNext bs -> do

76+ sendInner $ fromByteString bs

77+ loop

78+ Z.PRError e -> throwIO e

79+ streamingBody send (send flush)

80+ mbs <- blazeFinish

81+ case mbs of

82+ Nothing -> return ()

83+ Just bs -> Z.feedInflate inflate bs >>= goZlibPopper

84+ Z.finishInflate inflate >>= sendInner . fromByteString

85+

86+toInsert :: S.ByteString

87+toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping?\" + (new Date()).getTime(),true);x.send();},60000)</script>"

88+

89+addInsideHead :: (Builder -> IO ())

90+ -> IO ()

91+ -> StreamingBody

92+ -> IO ()

93+addInsideHead sendInner flushInner streamingBody = do

94+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

95+ ref <- newIORef $ Just (S.empty, whole)

96+ streamingBody (inner blazeRecv ref) (flush blazeRecv ref)

97+ state <- readIORef ref

98+ mbs <- blazeFinish

99+ held <- case mbs of

100+ Nothing -> return state

101+ Just bs -> push state bs

102+ case state of

103+ Nothing -> return ()

104+ Just (held, _) -> sendInner $ fromByteString held `mappend` fromByteString toInsert

105+ where

106+ whole = "<head>"

107+

108+ flush blazeRecv ref = inner blazeRecv ref Blaze.flush

109+

110+ inner blazeRecv ref builder = do

111+ state0 <- readIORef ref

112+ popper <- blazeRecv builder

113+ let loop state = do

114+ bs <- popper

115+ if S.null bs

116+ then writeIORef ref state

117+ else push state bs >>= loop

118+ loop state0

119+

120+ push Nothing x = sendInner (fromByteString x) >> return Nothing

121+ push (Just (held, atFront)) x

122+ | atFront `S.isPrefixOf` x = do

123+ let y = S.drop (S.length atFront) x

124+ sendInner $ fromByteString held

125+ `mappend` fromByteString atFront

126+ `mappend` fromByteString toInsert

127+ `mappend` fromByteString y

128+ return Nothing

129+ | whole `S.isInfixOf` x = do

130+ let (before, rest) = S.breakSubstring whole x

131+ let after = S.drop (S.length whole) rest

132+ sendInner $ fromByteString held

133+ `mappend` fromByteString before

134+ `mappend` fromByteString whole

135+ `mappend` fromByteString toInsert

136+ `mappend` fromByteString after

137+ return Nothing

138+ | x `S.isPrefixOf` atFront = do

139+ let held' = held `S.append` x

140+ atFront' = S.drop (S.length x) atFront

141+ return $ Just (held', atFront')

142+ | otherwise = do

143+ let (held', atFront', x') = getOverlap whole x

144+ sendInner $ fromByteString held `mappend` fromByteString x'

145+ return $ Just (held', atFront')

146+

147+getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)

148+getOverlap whole x =

149+ go whole

150+ where

151+ go piece

152+ | S.null piece = ("", whole, x)

153+ | piece `S.isSuffixOf` x =

154+ let x' = S.take (S.length x - S.length piece) x

155+ atFront = S.drop (S.length piece) whole

156+ in (piece, atFront, x')

157+ | otherwise = go $ S.init piece

158+

159+fixHeaders :: ([Header] -> [Header])

160+ -> [Header]

161+ -> (Bool, [Header])

162+fixHeaders front [] = (False, front [])

163+fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)

164+fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs

165+

166+#if WINDOWS

167+foreign import ccall "launch"

168+ launch' :: Int -> CString -> IO ()

169+#endif

170+

171+launch :: Int -> String -> IO ()

172+

173+#if WINDOWS

174+launch port s = withCString s $ launch' port

175+#else

176+launch port s = forkIO (rawSystem

177+#if MAC

178+ "open"

179+#else

180+ "xdg-open"

181+#endif

182+ ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return ()

183+#endif

184+

185+run :: Application -> IO ()

186+run = runUrl ""

187+

188+runUrl :: String -> Application -> IO ()

189+runUrl = runUrlPort 4587

190+

191+runUrlPort :: Int -> String -> Application -> IO ()

192+runUrlPort = runHostPortUrl "*4"

193+

194+-- |

195+--

196+-- @since 3.0.1

197+runHostPortUrl :: String -> Int -> String -> Application -> IO ()

198+runHostPortUrl host port url app = do

199+ ready <- newEmptyMVar

200+ active <- newIORef True

201+ let settings =

202+ Warp.setPort port $

203+ Warp.setOnException (\_ _ -> return ()) $

204+ Warp.setHost (fromString host) $

205+ Warp.setBeforeMainLoop (putMVar ready ()) $

206+ Warp.defaultSettings

207+ -- Run these threads concurrently; when either one terminates or

208+ -- raises an exception, the same happens to the other.

209+ fmap (either id id) $ race

210+ -- serve app, keep updating the activity flag

211+ (Warp.runSettings settings (ping active app))

212+ -- wait for server startup, launch browser, poll until server idle

213+ (takeMVar ready >> launch port url >> loop active)

214+

215+loop :: IORef Bool -> IO ()

216+loop active = do

217+ let seconds = 120

218+ threadDelay $ 1000000 * seconds

219+ b <- readIORef active

220+ if b

221+ then writeIORef active False >> loop active

222+ else return ()

wai-handler-launch/READMEnew file

No changes to the content.

wai-handler-launch/README.mdnew file+4

@@ -0,0 +1,4 @@

1+## wai-handler-launch

2+

3+This handles cross-platform launching and inserts Javascript code to ping the

4+server. When the server no longer receives pings, it shuts down.

wai-handler-launch/Setup.lhsnew file+7

@@ -0,0 +1,7 @@

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-launch/runtests.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai.Handler.Launch (insideHead)

3+import Test.Hspec

4+import Test.Hspec.HUnit

5+import Data.Enumerator hiding (map)

6+import Test.HUnit

7+import qualified Data.ByteString as S

8+

9+main :: IO ()

10+main = hspec $ describe "insideHead"

11+ [ it "handles single chunks" $ helper "bar<head>foobaz" ["bar<head>baz"]

12+ , it "handles single chunks, no <head>" $ helper "barfoo" ["bar"]

13+ , it "handles whole chunks" $ helper "bar<head>foobaz" ["bar", "<head>", "baz"]

14+ , it "handles split chunks" $ helper "bar<head>foobaz" ["bar", "<he", "ad>", "baz"]

15+ , it "handles many chunks" $ helper "bar<head>foobaz1234567890" ["bar", "<he", "ad>", "baz", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"]

16+ , it "handles many pieces" $ helper "bar<head>foobaz" $ map S.singleton $ S.unpack "bar<head>baz"

17+ ]

18+

19+helper :: S.ByteString -> [S.ByteString] -> Assertion

20+helper res pieces = do

21+ x <- run_ $ enumList 1 pieces $$ joinI $ insideHead "foo" $$ consume

22+ S.concat x @?= res

wai-handler-launch/test.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.HTTP.Types

4+import Network.Wai.Handler.Launch

5+import Network.Wai.Middleware.Gzip

6+

7+main = runUrl "FIXME" $ gzip def $ \_ f -> f $ responseLBS status200 [("Content-Type", "text/html; charset=utf8")] "<html><head></head><body>HELLO THERE"

wai-handler-launch/wai-handler-launch.cabalnew file+37

@@ -0,0 +1,37 @@

1+Name: wai-handler-launch

2+Version: 3.0.2.3

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.7

32+ if os(darwin)

33+ cpp-options: -DMAC

34+

35+source-repository head

36+ type: git

37+ location: git://github.com/yesodweb/wai.git

wai-handler-launch/windows.cnew file+12

@@ -0,0 +1,12 @@

1+#include <windows.h>

2+#include <shellapi.h>

3+#include <stdio.h>

4+

5+void launch(int port, char *s)

6+{

7+ int len = 8 + strlen("http://127.0.0.1:") + strlen(s);

8+ char *buff = malloc(len);

9+ _snprintf(buff, len, "http://127.0.0.1:%d/%s", port, s);

10+ ShellExecute(NULL, "open", buff, NULL, NULL, SW_SHOWNORMAL);

11+ free(buff);

12+}

wai-handler-webkit/.gitignorenew file+2

@@ -0,0 +1,2 @@

1+dist

2+*.swp

wai-handler-webkit/ChangeLog.mdnew file+3

@@ -0,0 +1,3 @@

1+## 3.0.0.3

2+

3+* Support for wai/warp 3.2

wai-handler-webkit/LICENSEnew file+20

@@ -0,0 +1,20 @@

2+

3+Permission is hereby granted, free of charge, to any person obtaining

4+a copy of this software and associated documentation files (the

5+"Software"), to deal in the Software without restriction, including

6+without limitation the rights to use, copy, modify, merge, publish,

7+distribute, sublicense, and/or sell copies of the Software, and to

8+permit persons to whom the Software is furnished to do so, subject to

9+the following conditions:

10+

11+The above copyright notice and this permission notice shall be

12+included in all copies or substantial portions of the Software.

13+

14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE

18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION

19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION

20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

wai-handler-webkit/Network/Wai/Handler/Webkit.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+module Network.Wai.Handler.Webkit (run) where

3+

4+import Network.Wai (Application)

5+import qualified Network.Wai.Handler.Warp as S

6+import Control.Concurrent (forkOS)

7+import Control.Concurrent.MVar

8+import Foreign.C.String (CString, withCString)

9+import Control.Exception (finally)

10+

11+run :: String -- ^ Title to show in titlebar

12+ -> Application -> IO ()

13+run title app = do

14+ mvar <- newEmptyMVar

15+ _ <- forkOS $ finally (S.run 3000 app) (putMVar mvar ())

16+ _ <- forkOS $ finally (withCString title startBrowser) (putMVar mvar ())

17+ _ <- takeMVar mvar

18+ return ()

19+

20+foreign import ccall "start_browser"

21+ startBrowser :: CString -> IO ()

wai-handler-webkit/README.mdnew file+53

@@ -0,0 +1,53 @@

1+wai-handler-webkit

2+==================

3+

4+Turn WAI applications into standalone GUIs using Qt WebKit.

5+

6+

7+Linux

8+-----

9+

10+You'll need the appropriate system libraries, on Ubuntu:

11+

12+ apt-get install libqtwebkit-dev

13+

14+On Lucid, this required adding a PPA:

15+

16+ sudo add-apt-repository ppa:kubuntu-ppa/backports

17+

18+

19+Windows

20+-------

21+

22+Install the Qt SDK from <http://qt.nokia.com/downloads/>

23+

24+Your application's Cabal file will require certain options for Windows,

25+shown below. In particular, we need to link with `g++`, so make sure

26+it's in your `PATH`. The option `-optl-mwindows` ensures that the

27+application does not open a terminal.

28+

29+ if os(windows)

30+ ghc-options: -Wall -threaded -pgml g++ -optl-static -optl-mwindows

31+ else

32+ ghc-options: -Wall

33+

34+Run `cabal-install` with the Qt `include` and `lib` directories.

35+

36+ export QT_PATH=c:/QtSDK/Desktop/Qt/4.7.3/mingw

37+

38+ cabal-dev install \

39+ --extra-include-dirs=$QT_PATH/include \

40+ --extra-include-dirs=$QT_PATH/include/QtCore \

41+ --extra-include-dirs=$QT_PATH/include/QtNetwork \

42+ --extra-include-dirs=$QT_PATH/include/QtGui \

43+ --extra-include-dirs=$QT_PATH/include/QtWebKit \

44+ --extra-lib-dirs=$QT_PATH/lib

45+

46+You'll need to include these DLLs with your application:

47+

48+ phonon4.dll

49+ libgcc_s_dw2-1.dll

50+ QtCore4.dll

51+ QtGui4.dll

52+ QtNetwork4.dll

53+ QtWebKit4.dll

wai-handler-webkit/Setup.lhsnew file+7

@@ -0,0 +1,7 @@

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-webkit/sample.hsnew file+10

@@ -0,0 +1,10 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.Webkit

4+import Network.HTTP.Types

5+

6+main :: IO ()

7+main = run "Sample App" app

8+

9+app :: Application

10+app _ response = response $ responseLBS status200 [("Content-Type", "text/html")] "<h1>Hello World!</h1>"

wai-handler-webkit/wai-handler-webkit.cabalnew file+30

@@ -0,0 +1,30 @@

1+name: wai-handler-webkit

2+version: 3.0.0.3

3+license: MIT

4+license-file: LICENSE

5+author: Michael Snoyman <michael@snoyman.com>

6+maintainer: Michael Snoyman <michael@snoyman.com>

7+synopsis: Turn WAI applications into standalone GUIs using QtWebkit.

8+description: API docs and the README are available at <http://www.stackage.org/package/wai-handler-webkit>.

9+category: Web

10+stability: unstable

11+cabal-version: >= 1.6

12+build-type: Simple

13+homepage: https://github.com/yesodweb/wai/tree/master/wai-handler-webkit

14+extra-source-files: README.md ChangeLog.md

15+

16+library

17+ build-depends: base >= 4 && < 5

18+ , wai >= 3.0 && < 3.3

19+ , warp >= 3.0 && < 3.3

20+ ghc-options: -Wall

21+ exposed-modules: Network.Wai.Handler.Webkit

22+ c-sources: webkit.cpp

23+ if os(windows)

24+ extra-libraries: QtCore4, QtGui4, QtNetwork4, QtWebKit4

25+ else

26+ pkgconfig-depends: QtWebKit

27+

28+source-repository head

29+ type: git

30+ location: git://github.com/yesodweb/wai.git

wai-handler-webkit/webkit.cppnew file+19

@@ -0,0 +1,19 @@

1+#include <QApplication>

2+#include <QPushButton>

3+#include <QtWebKit>

4+

5+extern "C" {

6+ int start_browser(char *title)

7+ {

8+ char *argv[1];

9+ argv[0] = title;

10+ int argc = 1;

11+

12+ QApplication app(argc, argv);

13+ QWebView *view = new QWebView();

14+ view->load(QUrl("http://localhost:3000/"));

15+ view->show();

16+

17+ return app.exec();

18+ }

19+}

wai-http2-extra/Network/Wai/Middleware/Push/Referer.hs+2−4

@@ -120,12 +120,10 @@ pushOnReferer settings@Settings{..} app req sendResponse = do

120 when (isNothing mauth

121 || requestHeaderHost req == mauth) $ do

122 when (path /= refPath) $ do -- just in case

123− let !path' = BS.copy path

124− !refPath' = BS.copy refPath

125− mpp <- makePushPromise refPath' path' file

123+ mpp <- makePushPromise refPath path file

126 case mpp of

124 case mpp of

127 Nothing -> return ()

125 Nothing -> return ()

128− Just pp -> reaperAdd reaper (refPath',pp)

126+ Just pp -> reaperAdd reaper (refPath,pp)

129 ps -> do

127 ps -> do

130 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

128 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

131 setHTTP2Data req (Just h2d)

129 setHTTP2Data req (Just h2d)

wai-http2-extra/wai-http2-extra.cabal+2−9

@@ -1,5 +1,5 @@

1Name: wai-http2-extra

2−Version: 0.1.2

2+Version: 0.1.0

3Synopsis: WAI utilities for HTTP/2

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: kazu@iij.ad.jp

8Homepage: http://github.com/yesodweb/wai

9Category: Web

10Build-Type: Simple

11−Cabal-Version: >=1.10

11+Cabal-Version: >=1.8

12Stability: Stable

13Description: WAI utilities for HTTP/2

14

@@ -24,9 +24,6 @@ Library

24 Exposed-modules: Network.Wai.Middleware.Push.Referer

25 Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap

26 Ghc-Options: -Wall

27− if impl(ghc >= 8)

28− default-extensions: Strict StrictData

29− default-language: Haskell2010

30

27

31Test-Suite doctest

28Test-Suite doctest

32 Type: exitcode-stdio-1.0

29 Type: exitcode-stdio-1.0

@@ -35,10 +32,6 @@ Test-Suite doctest

35 Main-Is: doctests.hs

32 Main-Is: doctests.hs

36 Build-Depends: base

33 Build-Depends: base

37 , doctest >= 0.10.1

34 , doctest >= 0.10.1

38− if impl(ghc >= 8)

39− default-extensions: Strict StrictData

40− default-language: Haskell2010

41−

42Source-Repository head

35Source-Repository head

43 Type: git

36 Type: git

44 Location: git://github.com/yesodweb/wai.git

37 Location: git://github.com/yesodweb/wai.git

wai-websockets/ChangeLog.md−4

@@ -1,7 +1,3 @@

1−## 3.0.1.2

2−

3−* Drop unused dependency on blaze-builder

4−

5## 3.0.1.1

1## 3.0.1.1

6

2

7* Doc improvement

3* Doc improvement

wai-websockets/server.lhs+1−7

@@ -8,8 +8,6 @@ this example, keep the [reference](http://jaspervdj.be/websockets/reference)

8nearby to check out the functions we use.

9

10> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}

11−> {-# LANGUAGE CPP #-}

12−> {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- for numClients

13> import Data.Char (isPunctuation, isSpace)

11> import Data.Char (isPunctuation, isSpace)

14> import Data.Monoid (mappend)

12> import Data.Monoid (mappend)

15> import Data.Text (Text)

13> import Data.Text (Text)

@@ -101,13 +99,9 @@ stays alive on some browsers.

101

99

102> application state pending = do

100> application state pending = do

103> conn <- WS.acceptRequest pending

101> conn <- WS.acceptRequest pending

104−#if __GLASGOW_HASKELL__ >= 806

105−> WS.withPingThread conn 30 (return ()) $ do

106−#else

107> WS.forkPingThread conn 30

102> WS.forkPingThread conn 30

108−#endif

109

103

110−When a client is successfully connected, we read the first message. This should

104+When a client is succesfully connected, we read the first message. This should

111be in the format of "Hi! I am Jasper", where Jasper is the requested username.

105be in the format of "Hi! I am Jasper", where Jasper is the requested username.

112

106

113> msg <- WS.receiveData conn

107> msg <- WS.receiveData conn

wai-websockets/wai-websockets.cabal+3−2

@@ -1,5 +1,5 @@

1Name: wai-websockets

2−Version: 3.0.1.2

2+Version: 3.0.1.1

3Synopsis: Provide a bridge between WAI and the websockets package.

4License: MIT

5License-file: LICENSE

@@ -21,6 +21,7 @@ Library

21 Build-Depends: base >= 3 && < 5

22 , bytestring >= 0.9.1.4

23 , wai >= 3.0 && < 3.3

24+ , blaze-builder >= 0.2.1.4 && < 0.5

24 , case-insensitive >= 0.2

25 , case-insensitive >= 0.2

25 , network >= 2.2.1.5

26 , network >= 2.2.1.5

26 , transformers >= 0.2

27 , transformers >= 0.2

@@ -40,12 +41,12 @@ Executable wai-websockets-example

40 , wai-app-static

41 , wai-app-static

41 , bytestring

42 , bytestring

42 , case-insensitive

43 , case-insensitive

44+ , blaze-builder

43 , transformers

45 , transformers

44 , network

46 , network

45 , text

47 , text

46 , file-embed

48 , file-embed

47 , http-types

49 , http-types

48− other-modules: Network.Wai.Handler.WebSockets

49 else

50 else

50 buildable: False

51 buildable: False

51

52

wai/ChangeLog.md−14

@@ -1,17 +1,3 @@

1−# ChangeLog for wai

2−

3−## 3.2.2.1

4−

5−* Fix missing reexport of `getRequestBodyChunk` [#753](https://github.com/yesodweb/wai/issues/753)

6−

7−## 3.2.2

8−

9−* Deprecate `requestBody` in favor of the more clearly named `getRequestBodyChunk`. [#726](https://github.com/yesodweb/wai/pull/726)

10−

11−## 3.2.1.2

12−

13−* Remove dependency on blaze-builder [#683](https://github.com/yesodweb/wai/pull/683)

14−

15## 3.2.1.1

1## 3.2.1.1

16

2

17* Relax upper bound on bytestring-builder

3* Relax upper bound on bytestring-builder

wai/Network/Wai.hs+19−20

@@ -4,11 +4,10 @@ This module defines a generic web application interface. It is a common

4protocol between web servers and web applications.

5

6The overriding design principles here are performance and generality. To

7−address performance, this library uses a streaming interface for request and

7+address performance, this library is built on top of the conduit and

8−response bodies, paired with bytestring's 'Builder' type. The advantages of a

8+blaze-builder packages. The advantages of conduits over lazy IO have been

9−streaming API over lazy IO have been debated elsewhere and so will not be

10−addressed here. However, helper functions like 'responseLBS' allow you to

9+debated elsewhere and so will not be addressed here. However, helper functions

11−continue using lazy IO if you so desire.

10+like 'responseLBS' allow you to continue using lazy IO if you so desire.

12

11

13Generality is achieved by removing many variables commonly found in similar

12Generality is achieved by removing many variables commonly found in similar

14projects that are not universal to all servers. The goal is that the 'Request'

13projects that are not universal to all servers. The goal is that the 'Request'

@@ -30,9 +29,9 @@ include:

30

29

31[wai-extra] <http://hackage.haskell.org/package/wai-extra>

30[wai-extra] <http://hackage.haskell.org/package/wai-extra>

32

31

32+[wai-test] <http://hackage.haskell.org/package/wai-test>

33+

33-}

34-}

34−-- Ignore deprecations, because this module needs to use the deprecated requestBody to construct a response.

35−{-# OPTIONS_GHC -fno-warn-deprecations #-}

36module Network.Wai

35module Network.Wai

37 (

36 (

38 -- * Types

37 -- * Types

@@ -53,7 +52,6 @@ module Network.Wai

53 , remoteHost

52 , remoteHost

54 , pathInfo

53 , pathInfo

55 , queryString

54 , queryString

56− , getRequestBodyChunk

57 , requestBody

55 , requestBody

58 , vault

56 , vault

59 , requestBodyLength

57 , requestBodyLength

@@ -85,8 +83,8 @@ module Network.Wai

85 , modifyResponse

83 , modifyResponse

86 ) where

84 ) where

87

85

88−import Data.ByteString.Builder (Builder, lazyByteString)

86+import Blaze.ByteString.Builder (Builder, fromLazyByteString)

89−import Data.ByteString.Builder (byteString)

87+import Blaze.ByteString.Builder (fromByteString)

90import Control.Monad (unless)

88import Control.Monad (unless)

91import qualified Data.ByteString as B

89import qualified Data.ByteString as B

92import qualified Data.ByteString.Lazy as L

90import qualified Data.ByteString.Lazy as L

@@ -94,6 +92,7 @@ import qualified Data.ByteString.Lazy.Internal as LI

94import Data.ByteString.Lazy.Internal (defaultChunkSize)

92import Data.ByteString.Lazy.Internal (defaultChunkSize)

95import Data.ByteString.Lazy.Char8 ()

93import Data.ByteString.Lazy.Char8 ()

96import Data.Function (fix)

94import Data.Function (fix)

95+import Data.Monoid (mempty)

97import qualified Network.HTTP.Types as H

96import qualified Network.HTTP.Types as H

98import Network.Socket (SockAddr (SockAddrInet))

97import Network.Socket (SockAddr (SockAddrInet))

99import Network.Wai.Internal

98import Network.Wai.Internal

@@ -121,13 +120,13 @@ responseFile = ResponseFile

121--

120--

122-- A2. No. If the ByteStrings are small, then they will be copied into a larger

121-- A2. No. If the ByteStrings are small, then they will be copied into a larger

123-- buffer, which should be a performance gain overall (less system calls). If

122-- buffer, which should be a performance gain overall (less system calls). If

124−-- they are already large, then an insert operation is used

123+-- they are already large, then blaze-builder uses an InsertByteString

125−-- to avoid copying.

124+-- instruction to avoid copying.

126--

125--

127-- Q3. Doesn't this prevent us from creating comet-style servers, since data

126-- Q3. Doesn't this prevent us from creating comet-style servers, since data

128-- will be cached?

127-- will be cached?

129--

128--

130−-- A3. You can force a Builder to output a ByteString before it is an

129+-- A3. You can force blaze-builder to output a ByteString before it is an

131-- optimal size by sending a flush command.

130-- optimal size by sending a flush command.

132responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

131responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

133responseBuilder = ResponseBuilder

132responseBuilder = ResponseBuilder

@@ -135,7 +134,7 @@ responseBuilder = ResponseBuilder

135-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for

134-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for

136-- 'responseBuilder'.

135-- 'responseBuilder'.

137responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

136responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

138−responseLBS s h = ResponseBuilder s h . lazyByteString

137+responseLBS s h = ResponseBuilder s h . fromLazyByteString

139

138

140-- | Creating 'Response' from a stream of values.

139-- | Creating 'Response' from a stream of values.

141--

140--

@@ -149,9 +148,9 @@ responseLBS s h = ResponseBuilder s h . lazyByteString

149-- (putStrLn \"Allocating scarce resource\")

148-- (putStrLn \"Allocating scarce resource\")

150-- (putStrLn \"Cleaning up\")

149-- (putStrLn \"Cleaning up\")

151-- $ respond $ responseStream status200 [] $ \\write flush -> do

150-- $ respond $ responseStream status200 [] $ \\write flush -> do

152−-- write $ byteString \"Hello\\n\"

151+-- write $ fromByteString \"Hello\\n\"

153-- flush

152-- flush

154−-- write $ byteString \"World\\n\"

153+-- write $ fromByteString \"World\\n\"

155-- @

154-- @

156--

155--

157-- Note that in some cases you can use @bracket@ from inside @responseStream@

156-- Note that in some cases you can use @bracket@ from inside @responseStream@

@@ -214,7 +213,7 @@ responseToStream (ResponseFile s h fp (Just part)) =

214 bs <- B.hGetSome handle defaultChunkSize

213 bs <- B.hGetSome handle defaultChunkSize

215 unless (B.null bs) $ do

214 unless (B.null bs) $ do

216 let x = B.take remaining bs

215 let x = B.take remaining bs

217− sendChunk $ byteString x

216+ sendChunk $ fromByteString x

218 loop $ remaining - B.length x

217 loop $ remaining - B.length x

219 loop $ fromIntegral $ filePartByteCount part

218 loop $ fromIntegral $ filePartByteCount part

220 )

219 )

@@ -225,7 +224,7 @@ responseToStream (ResponseFile s h fp Nothing) =

225 withBody $ \sendChunk _flush -> fix $ \loop -> do

224 withBody $ \sendChunk _flush -> fix $ \loop -> do

226 bs <- B.hGetSome handle defaultChunkSize

225 bs <- B.hGetSome handle defaultChunkSize

227 unless (B.null bs) $ do

226 unless (B.null bs) $ do

228− sendChunk $ byteString bs

227+ sendChunk $ fromByteString bs

229 loop

228 loop

230 )

229 )

231responseToStream (ResponseBuilder s h b) =

230responseToStream (ResponseBuilder s h b) =

@@ -326,7 +325,7 @@ strictRequestBody req =

326 loop id

325 loop id

327 where

326 where

328 loop front = do

327 loop front = do

329− bs <- getRequestBodyChunk req

328+ bs <- requestBody req

330 if B.null bs

329 if B.null bs

331 then return $ front LI.Empty

330 then return $ front LI.Empty

332 else loop (front . LI.Chunk bs)

331 else loop (front . LI.Chunk bs)

@@ -340,7 +339,7 @@ lazyRequestBody req =

340 loop

339 loop

341 where

340 where

342 loop = unsafeInterleaveIO $ do

341 loop = unsafeInterleaveIO $ do

343− bs <- getRequestBodyChunk req

342+ bs <- requestBody req

344 if B.null bs

343 if B.null bs

345 then return LI.Empty

344 then return LI.Empty

346 else do

345 else do

wai/Network/Wai/Internal.hs+2−10

@@ -5,7 +5,7 @@

5-- given for stability of these interfaces.

6module Network.Wai.Internal where

7

8−import Data.ByteString.Builder (Builder)

8+import Blaze.ByteString.Builder (Builder)

9import qualified Data.ByteString as B hiding (pack)

10import Data.Text (Text)

11import Data.Typeable (Typeable)

@@ -17,7 +17,6 @@ import Data.List (intercalate)

17

18-- | Information on the request sent by the client. This abstracts away the

19-- details of the underlying implementation.

20−{-# DEPRECATED requestBody "requestBody's name is misleading because it only gets a partial chunk of the body. Use getRequestBodyChunk instead." #-}

21data Request = Request {

20data Request = Request {

22 -- | Request method such as GET.

21 -- | Request method such as GET.

23 requestMethod :: H.Method

22 requestMethod :: H.Method

@@ -63,7 +62,7 @@ data Request = Request {

63 -- | Parsed query string information.

62 -- | Parsed query string information.

64 , queryString :: H.Query

63 , queryString :: H.Query

65 -- | Get the next chunk of the body. Returns 'B.empty' when the

64 -- | Get the next chunk of the body. Returns 'B.empty' when the

66− -- body is fully consumed. Since 3.2.2, this is deprecated in favor of 'getRequestBodyChunk'.

65+ -- body is fully consumed.

67 , requestBody :: IO B.ByteString

66 , requestBody :: IO B.ByteString

68 -- | A location for arbitrary data to be shared by applications and middleware.

67 -- | A location for arbitrary data to be shared by applications and middleware.

69 , vault :: Vault

68 , vault :: Vault

@@ -91,13 +90,6 @@ data Request = Request {

91 }

90 }

92 deriving (Typeable)

91 deriving (Typeable)

93

92

94−-- | Get the next chunk of the body. Returns 'B.empty' when the

95−-- body is fully consumed.

96−--

97−-- @since 3.2.2

98−getRequestBodyChunk :: Request -> IO B.ByteString

99−getRequestBodyChunk = requestBody

100−

101instance Show Request where

93instance Show Request where

102 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"

94 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"

103 where

95 where

wai/test/Network/WaiSpec.hs+9−7

@@ -3,10 +3,12 @@ module Network.WaiSpec (spec) where

3import Test.Hspec

4import Test.Hspec.QuickCheck (prop)

5import Network.Wai

6+import Network.Wai.Internal (Request (Request))

6import Data.IORef

7import Data.IORef

8+import Data.Monoid

7import qualified Data.ByteString as S

9import qualified Data.ByteString as S

8import qualified Data.ByteString.Lazy as L

10import qualified Data.ByteString.Lazy as L

9−import Data.ByteString.Builder (Builder, toLazyByteString, word8)

11+import Blaze.ByteString.Builder (toByteString, Builder, fromWord8)

10import Control.Monad (forM_)

12import Control.Monad (forM_)

11

13

12spec :: Spec

14spec :: Spec

@@ -22,17 +24,17 @@ spec = do

22 flush :: IO ()

24 flush :: IO ()

23 flush = return ()

25 flush = return ()

24 streamingBody add flush

26 streamingBody add flush

25− fmap (L.toStrict . toLazyByteString) $ readIORef builderRef

27+ fmap toByteString $ readIORef builderRef

26 prop "responseLBS" $ \bytes -> do

28 prop "responseLBS" $ \bytes -> do

27 body <- getBody $ responseLBS undefined undefined $ L.pack bytes

29 body <- getBody $ responseLBS undefined undefined $ L.pack bytes

28 body `shouldBe` S.pack bytes

30 body `shouldBe` S.pack bytes

29 prop "responseBuilder" $ \bytes -> do

31 prop "responseBuilder" $ \bytes -> do

30 body <- getBody $ responseBuilder undefined undefined

32 body <- getBody $ responseBuilder undefined undefined

31− $ mconcat $ map word8 bytes

33+ $ mconcat $ map fromWord8 bytes

32 body `shouldBe` S.pack bytes

34 body `shouldBe` S.pack bytes

33 prop "responseStream" $ \chunks -> do

35 prop "responseStream" $ \chunks -> do

34 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

36 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

35− forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk

37+ forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk

36 body `shouldBe` S.concat (map S.pack chunks)

38 body `shouldBe` S.concat (map S.pack chunks)

37 it "responseFile total" $ do

39 it "responseFile total" $ do

38 let fp = "wai.cabal"

40 let fp = "wai.cabal"

@@ -55,7 +57,7 @@ spec = do

55 describe "lazyRequestBody" $ do

57 describe "lazyRequestBody" $ do

56 prop "works" $ \chunks -> do

58 prop "works" $ \chunks -> do

57 ref <- newIORef $ map S.pack $ filter (not . null) chunks

59 ref <- newIORef $ map S.pack $ filter (not . null) chunks

58− let req = defaultRequest

60+ let req = Request

59 { requestBody = atomicModifyIORef ref $ \bss ->

61 { requestBody = atomicModifyIORef ref $ \bss ->

60 case bss of

62 case bss of

61 [] -> ([], S.empty)

63 [] -> ([], S.empty)

@@ -64,7 +66,7 @@ spec = do

64 body <- lazyRequestBody req

66 body <- lazyRequestBody req

65 body `shouldBe` L.fromChunks (map S.pack chunks)

67 body `shouldBe` L.fromChunks (map S.pack chunks)

66 it "is lazy" $ do

68 it "is lazy" $ do

67− let req = defaultRequest

69+ let req = Request

68 { requestBody = error "requestBody"

70 { requestBody = error "requestBody"

69 }

71 }

70 _ <- lazyRequestBody req

72 _ <- lazyRequestBody req

@@ -72,7 +74,7 @@ spec = do

72 describe "strictRequestBody" $ do

74 describe "strictRequestBody" $ do

73 prop "works" $ \chunks -> do

75 prop "works" $ \chunks -> do

74 ref <- newIORef $ map S.pack $ filter (not . null) chunks

76 ref <- newIORef $ map S.pack $ filter (not . null) chunks

75− let req = defaultRequest

77+ let req = Request

76 { requestBody = atomicModifyIORef ref $ \bss ->

78 { requestBody = atomicModifyIORef ref $ \bss ->

77 case bss of

79 case bss of

78 [] -> ([], S.empty)

80 [] -> ([], S.empty)

wai/wai.cabal+7−6

@@ -1,9 +1,8 @@

1Name: wai

2−Version: 3.2.2.1

2+Version: 3.2.1.1

3Synopsis: Web Application Interface.

4Description: Provides a common protocol for communication between web applications and web servers.

5− .

6− API docs and the README are available at <http://www.stackage.org/package/wai>.

5+description: API docs and the README are available at <http://www.stackage.org/package/wai>.

7License: MIT

6License: MIT

8License-file: LICENSE

7License-file: LICENSE

9Author: Michael Snoyman

8Author: Michael Snoyman

@@ -21,10 +20,12 @@ Source-repository head

21

20

22Library

21Library

23 Build-Depends: base >= 4.8 && < 5

22 Build-Depends: base >= 4.8 && < 5

24− , bytestring >= 0.10.4

23+ , bytestring >= 0.10

24+ , blaze-builder >= 0.2.1.4 && < 0.5

25 , network >= 2.2.1.5

26 , http-types >= 0.7

27 , text >= 0.7

28+ , transformers >= 0.0

28 , vault >= 0.3 && < 0.4

29 , vault >= 0.3 && < 0.4

29 Exposed-modules: Network.Wai

30 Exposed-modules: Network.Wai

30 Network.Wai.Internal

31 Network.Wai.Internal

@@ -34,14 +35,14 @@ test-suite test

34 hs-source-dirs: test

35 hs-source-dirs: test

35 main-is: Spec.hs

36 main-is: Spec.hs

36 type: exitcode-stdio-1.0

37 type: exitcode-stdio-1.0

37− ghc-options: -threaded -Wall

38+ ghc-options: -threaded

38 cpp-options: -DTEST

39 cpp-options: -DTEST

39 build-depends: base >= 4.8 && < 5

40 build-depends: base >= 4.8 && < 5

40 , wai

41 , wai

41 , hspec

42 , hspec

43+ , blaze-builder

42 , bytestring

44 , bytestring

43 other-modules: Network.WaiSpec

45 other-modules: Network.WaiSpec

44− build-tool-depends: hspec-discover:hspec-discover

45

46

46source-repository head

47source-repository head

47 type: git

48 type: git

wai/webkit-sample/webkit-sample.hs+2−2

@@ -5,7 +5,7 @@ import Network.Wai.Handler.Webkit

5import Data.ByteString (ByteString)

6import qualified Data.ByteString.Lazy as L

7import Data.Enumerator (consume, Iteratee)

8−import Data.ByteString.Builder (lazyByteString)

8+import Blaze.ByteString.Builder (fromLazyByteString)

9

10main :: IO ()

11main = putStrLn "http://localhost:3000/" >> run "Webkit Sample" app

@@ -27,4 +27,4 @@ postResponse :: L.ByteString -> Iteratee ByteString IO Response

27postResponse lbs = return $ ResponseBuilder

28 status200

29 [("Content-Type", "text/plain")]

30− (lazyByteString lbs)

30+ (fromLazyByteString lbs)

warp-tls/ChangeLog.md+1−44

@@ -1,50 +1,7 @@

1−## 3.2.11

1+## 3.2.4.1

2−

3−* Ignoring an exception from shutdown (gracefulClose).

4−

5−## 3.2.10

6−

7−* Passing client certificate, if any, to Warp

8− [#783](https://github.com/yesodweb/wai/pull/783)

9−

10−## 3.2.9

11−

12−* Cooperating setGracefulCloseTimeout1 and setGracefulCloseTimeout2 of Warp.

13− [#782](https://github.com/yesodweb/wai/pull/782)

14−

15−## 3.2.8

16−

17−* Using gracefullClose of network 3.1.1 or later if available.

18−

19−## 3.2.7

20−

21−* Relaxing version constraint.

22−

23−## 3.2.6

24−

25−* Using the Strict and StrictData language extensions for GHC >8.

26− [#752](https://github.com/yesodweb/wai/pull/752)

27−

28−## 3.2.5

29−

30−* When tls 1.5.0 is available, TLS 1.3 is automatically supported.

31−

32−## 3.2.4.3

33−

34−* Using warp >= 3.2.17.

35−

36−## 3.2.4.2

37

2

38* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640)

3* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640)

39

4

40−## 3.2.4

41−

42−* Using tls-session-manager.

43−

44−## 3.2.3

45−

46−* Stop using obsoleted APIs of network.

47−

48## 3.2.2

5## 3.2.2

49

6

50* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)

7* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)

warp-tls/Network/Wai/Handler/WarpTLS.hs+15−63

@@ -53,9 +53,6 @@ import qualified Data.IORef as I

53import Data.Streaming.Network (bindPortTCP, safeRecv)

54import Data.Typeable (Typeable)

55import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)

56−#if MIN_VERSION_network(3,1,1)

57−import Network.Socket (gracefulClose)

58−#endif

59import Network.Socket.ByteString (sendAll)

56import Network.Socket.ByteString (sendAll)

60import qualified Network.TLS as TLS

57import qualified Network.TLS as TLS

61import qualified Crypto.PubKey.DH as DH

58import qualified Crypto.PubKey.DH as DH

@@ -93,37 +90,19 @@ data TLSSettings = TLSSettings {

93 --

90 --

94 -- Since 1.4.0

91 -- Since 1.4.0

95 , tlsAllowedVersions :: [TLS.Version]

92 , tlsAllowedVersions :: [TLS.Version]

96−#if MIN_VERSION_tls(1,5,0)

97− -- ^ The TLS versions this server accepts.

98− --

99− -- >>> tlsAllowedVersions defaultTlsSettings

100− -- [TLS13,TLS12,TLS11,TLS10]

101− --

102− -- Since 1.4.2

103−#else

104 -- ^ The TLS versions this server accepts.

93 -- ^ The TLS versions this server accepts.

105 --

94 --

106 -- >>> tlsAllowedVersions defaultTlsSettings

95 -- >>> tlsAllowedVersions defaultTlsSettings

107 -- [TLS12,TLS11,TLS10]

96 -- [TLS12,TLS11,TLS10]

108 --

97 --

109 -- Since 1.4.2

98 -- Since 1.4.2

110−#endif

111 , tlsCiphers :: [TLS.Cipher]

99 , tlsCiphers :: [TLS.Cipher]

112−#if MIN_VERSION_tls(1,5,0)

113− -- ^ The TLS ciphers this server accepts.

114− --

115− -- >>> tlsCiphers defaultTlsSettings

116− -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1,AES128GCM-SHA256,AES256GCM-SHA384]

117− --

118− -- Since 1.4.2

119−#else

120 -- ^ The TLS ciphers this server accepts.

100 -- ^ The TLS ciphers this server accepts.

121 --

101 --

122 -- >>> tlsCiphers defaultTlsSettings

102 -- >>> tlsCiphers defaultTlsSettings

123 -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1]

103 -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1]

124 --

104 --

125 -- Since 1.4.2

105 -- Since 1.4.2

126−#endif

127 , tlsWantClientCert :: Bool

106 , tlsWantClientCert :: Bool

128 -- ^ Whether or not to demand a certificate from the client. If this

107 -- ^ Whether or not to demand a certificate from the client. If this

129 -- is set to True, you must handle received certificates in a server hook

108 -- is set to True, you must handle received certificates in a server hook

@@ -170,11 +149,7 @@ defaultTlsSettings = TLSSettings {

170 , keyMemory = Nothing

149 , keyMemory = Nothing

171 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

150 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

172 , tlsLogging = def

151 , tlsLogging = def

173−#if MIN_VERSION_tls(1,5,0)

174− , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]

175−#else

176 , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]

152 , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]

177−#endif

178 , tlsCiphers = ciphers

153 , tlsCiphers = ciphers

179 , tlsWantClientCert = False

154 , tlsWantClientCert = False

180 , tlsServerHooks = def

155 , tlsServerHooks = def

@@ -281,7 +256,7 @@ runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager

281runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

256runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

282 runSettingsConnectionMakerSecure set get app

257 runSettingsConnectionMakerSecure set get app

283 where

258 where

284− get = getter tlsset set sock params

259+ get = getter tlsset sock params

285 params = def { -- TLS.ServerParams

260 params = def { -- TLS.ServerParams

286 TLS.serverWantClientCert = tlsWantClientCert

261 TLS.serverWantClientCert = tlsWantClientCert

287 , TLS.serverCACertificates = []

262 , TLS.serverCACertificates = []

@@ -289,9 +264,6 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

289 , TLS.serverHooks = hooks

264 , TLS.serverHooks = hooks

290 , TLS.serverShared = shared

265 , TLS.serverShared = shared

291 , TLS.serverSupported = supported

266 , TLS.serverSupported = supported

292−#if MIN_VERSION_tls(1,5,0)

293− , TLS.serverEarlyDataSize = 2018

294−#endif

295 }

267 }

296 -- Adding alpn to user's tlsServerHooks.

268 -- Adding alpn to user's tlsServerHooks.

297 hooks = tlsServerHooks {

269 hooks = tlsServerHooks {

@@ -310,9 +282,6 @@ runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

310 , TLS.supportedClientInitiatedRenegotiation = False

282 , TLS.supportedClientInitiatedRenegotiation = False

311 , TLS.supportedSession = True

283 , TLS.supportedSession = True

312 , TLS.supportedFallbackScsv = True

284 , TLS.supportedFallbackScsv = True

313−#if MIN_VERSION_tls(1,5,0)

314− , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]

315−#endif

316 }

285 }

317

286

318alpn :: [S.ByteString] -> IO S.ByteString

287alpn :: [S.ByteString] -> IO S.ByteString

@@ -322,55 +291,44 @@ alpn xs

322

291

323----------------------------------------------------------------

292----------------------------------------------------------------

324

293

325−getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

294+getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

326−getter tlsset@TLSSettings{..} set sock params = do

295+getter tlsset@TLSSettings{..} sock params = do

327−#if WINDOWS

328− (s, sa) <- windowsThreadBlockHack $ accept sock

329−#else

330 (s, sa) <- accept sock

296 (s, sa) <- accept sock

331−#endif

332− setSocketCloseOnExec s

333− return (mkConn tlsset set s params, sa)

297+ return (mkConn tlsset s params, sa)

334

298

335−mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)

299+mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)

336−mkConn tlsset set s params = switch `onException` close s

300+mkConn tlsset s params = switch `onException` close s

337 where

301 where

338 switch = do

302 switch = do

339 firstBS <- safeRecv s 4096

303 firstBS <- safeRecv s 4096

340 if not (S.null firstBS) && S.head firstBS == 0x16 then

304 if not (S.null firstBS) && S.head firstBS == 0x16 then

341− httpOverTls tlsset set s firstBS params

305+ httpOverTls tlsset s firstBS params

342 else

306 else

343− plainHTTP tlsset set s firstBS

307+ plainHTTP tlsset s firstBS

344

308

345----------------------------------------------------------------

309----------------------------------------------------------------

346

310

347−httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)

311+httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)

348−httpOverTls TLSSettings{..} _set s bs0 params = do

312+httpOverTls TLSSettings{..} s bs0 params = do

349 recvN <- makePlainReceiveN s bs0

313 recvN <- makePlainReceiveN s bs0

350 ctx <- TLS.contextNew (backend recvN) params

314 ctx <- TLS.contextNew (backend recvN) params

351 TLS.contextHookSetLogging ctx tlsLogging

315 TLS.contextHookSetLogging ctx tlsLogging

352 TLS.handshake ctx

316 TLS.handshake ctx

353− h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx

354− isH2 <- I.newIORef h2

355 writeBuf <- allocateBuffer bufferSize

317 writeBuf <- allocateBuffer bufferSize

356 -- Creating a cache for leftover input data.

318 -- Creating a cache for leftover input data.

357 ref <- I.newIORef ""

319 ref <- I.newIORef ""

358 tls <- getTLSinfo ctx

320 tls <- getTLSinfo ctx

359− return (conn ctx writeBuf ref isH2, tls)

321+ return (conn ctx writeBuf ref, tls)

360 where

322 where

361 backend recvN = TLS.Backend {

323 backend recvN = TLS.Backend {

362 TLS.backendFlush = return ()

324 TLS.backendFlush = return ()

363−#if MIN_VERSION_network(3,1,1)

364− , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()

365−#else

366 , TLS.backendClose = close s

325 , TLS.backendClose = close s

367−#endif

368 , TLS.backendSend = sendAll' s

326 , TLS.backendSend = sendAll' s

369 , TLS.backendRecv = recvN

327 , TLS.backendRecv = recvN

370 }

328 }

371 sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->

329 sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->

372 throwIO ConnectionClosedByPeer

330 throwIO ConnectionClosedByPeer

373− conn ctx writeBuf ref isH2 = Connection {

331+ conn ctx writeBuf ref = Connection {

374 connSendMany = TLS.sendData ctx . L.fromChunks

332 connSendMany = TLS.sendData ctx . L.fromChunks

375 , connSendAll = sendall

333 , connSendAll = sendall

376 , connSendFile = sendfile

334 , connSendFile = sendfile

@@ -380,7 +338,6 @@ httpOverTls TLSSettings{..} _set s bs0 params = do

380 , connRecvBuf = recvBuf ref

338 , connRecvBuf = recvBuf ref

381 , connWriteBuffer = writeBuf

339 , connWriteBuffer = writeBuf

382 , connBufferSize = bufferSize

340 , connBufferSize = bufferSize

383− , connHTTP2 = isH2

384 }

341 }

385 where

342 where

386 sendall = TLS.sendData ctx . L.fromChunks . return

343 sendall = TLS.sendData ctx . L.fromChunks . return

@@ -465,16 +422,11 @@ getTLSinfo ctx = do

465 TLS.TLS10 -> (3,1)

422 TLS.TLS10 -> (3,1)

466 TLS.TLS11 -> (3,2)

423 TLS.TLS11 -> (3,2)

467 TLS.TLS12 -> (3,3)

424 TLS.TLS12 -> (3,3)

468−#if MIN_VERSION_tls(1,5,0)

469− TLS.TLS13 -> (3,4)

470−#endif

471− clientCert <- TLS.getClientCertificateChain ctx

472 return TLS {

425 return TLS {

473 tlsMajorVersion = major

426 tlsMajorVersion = major

474 , tlsMinorVersion = minor

427 , tlsMinorVersion = minor

475 , tlsNegotiatedProtocol = proto

428 , tlsNegotiatedProtocol = proto

476 , tlsChiperID = TLS.cipherID infoCipher

429 , tlsChiperID = TLS.cipherID infoCipher

477− , tlsClientCertificate = clientCert

478 }

430 }

479

431

480tryIO :: IO a -> IO (Either IOException a)

432tryIO :: IO a -> IO (Either IOException a)

@@ -482,10 +434,10 @@ tryIO = try

482

434

483----------------------------------------------------------------

435----------------------------------------------------------------

484

436

485−plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)

437+plainHTTP :: TLSSettings -> Socket -> S.ByteString -> IO (Connection, Transport)

486−plainHTTP TLSSettings{..} set s bs0 = case onInsecure of

438+plainHTTP TLSSettings{..} s bs0 = case onInsecure of

487 AllowInsecure -> do

439 AllowInsecure -> do

488− conn' <- socketConnection set s

440+ conn' <- socketConnection s

489 cachedRef <- I.newIORef bs0

441 cachedRef <- I.newIORef bs0

490 let conn'' = conn'

442 let conn'' = conn'

491 { connRecv = recvPlain cachedRef (connRecv conn')

443 { connRecv = recvPlain cachedRef (connRecv conn')

warp-tls/warp-tls.cabal+6−12

@@ -1,5 +1,5 @@

1Name: warp-tls

2−Version: 3.2.11

2+Version: 3.2.4.1

3Synopsis: HTTP over TLS support for Warp via the TLS package

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

8Homepage: http://github.com/yesodweb/wai

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >= 1.10

11+Cabal-Version: >=1.6

12Stability: Stable

13description: SSLv1 and SSLv2 are obsoleted by IETF.

14 We should use TLS 1.2 (or TLS 1.1 or TLS 1.0 if necessary).

@@ -18,24 +18,18 @@ description: SSLv1 and SSLv2 are obsoleted by IETF.

18extra-source-files: ChangeLog.md README.md

19

20Library

21− Build-Depends: base >= 4.10 && < 5

21+ Build-Depends: base >= 4.8 && < 5

22 , bytestring >= 0.9

23 , wai >= 3.2 && < 3.3

24− , warp >= 3.3.6 && < 3.4

24+ , warp >= 3.2.10 && < 3.3

25 , data-default-class >= 0.0.1

26− , tls >= 1.5.3

26+ , tls >= 1.3.10

27 , cryptonite >= 0.12

28 , network >= 2.2.1

29 , streaming-commons

30− , tls-session-manager >= 0.0.4

30+ , tls-session-manager >= 0.0.0.1

31 Exposed-modules: Network.Wai.Handler.WarpTLS

32 ghc-options: -Wall

33− if os(windows)

34− Cpp-Options: -DWINDOWS

35− if impl(ghc >= 8)

36− Default-Extensions: Strict StrictData

37− Default-Language: Haskell2010

38−

39

33

40source-repository head

34source-repository head

41 type: git

35 type: git

warp/ChangeLog.md−150

@@ -1,153 +1,3 @@

1−## 3.3.9

2−

3−* Don't insert Last-Modified: if exists.

4− [#791](https://github.com/yesodweb/wai/pull/791)

5−

6−## 3.3.8

7−

8−* Maximum header size is configurable.

9− [#781](https://github.com/yesodweb/wai/pull/781)

10−* Ignoring an exception from shutdown (gracefulClose).

11−

12−## 3.3.7

13−

14−* InvalidArgument (Bad file descriptor) is ignored in `receive`.

15− [#787](https://github.com/yesodweb/wai/pull/787)

16−

17−## 3.3.6

18−

19−* Fixing a bug of thread killed in the case of event source with

20− HTTP/2 (fixing #692 and #785)

21−* New APIs: clientCertificate to get client's certificate

22− [#783](https://github.com/yesodweb/wai/pull/783)

23−

24−## 3.3.5

25−

26−* New APIs: setGracefulCloseTimeout1 and setGracefulCloseTimeout2.

27− For HTTP/1.x, connections are closed immediately by default.

28− gracefullClose is used for HTTP/2 by default.

29− [#782](https://github.com/yesodweb/wai/pull/782)

30−

31−## 3.3.4

32−

33−* Setting isSecure of HTTP/2 correctly.

34−

35−## 3.3.3

36−

37−* Calling setOnException in HTTP/2.

38− [#771](https://github.com/yesodweb/wai/pull/771)

39−

40−## 3.3.2

41−

42−* Fixing a bug of HTTP/2 without fd cache.

43−

44−## 3.3.1

45−

46−* Using gracefullClose of network 3.1.1 or later if available.

47−* If the first line of an HTTP request is really invalid,

48− don't send an error response

49−

50−## 3.3.0

51−

52−* Switching from the original implementation to HTTP/2 server library.

53− [#754](https://github.com/yesodweb/wai/pull/754)

54−* Breaking change: The type of `http2dataTrailers` is now

55− `HTTP2Data -> TrailersMaker`.

56−

57−## 3.2.28

58−

59−* Using the Strict and StrictData language extensions for GHC >8.

60− [#752](https://github.com/yesodweb/wai/pull/752)

61−* System.TimeManager is now in a separate package: time-manager.

62− [#750](https://github.com/yesodweb/wai/pull/750)

63−* Fixing a bug of ALPN.

64−* Introducing the half closed state for HTTP/2.

65− [#717](https://github.com/yesodweb/wai/pull/717)

66−

67−## 3.2.27

68−

69−* Internally, use `lookupEnv` instead of `getEnvironment` to get the

70− value of the `PORT` environment variable

71− [#736](https://github.com/yesodweb/wai/pull/736)

72−* Throw 413 for too large payload

73−* Throw 431 for too large headers

74− [#741](https://github.com/yesodweb/wai/pull/741)

75−* Use exception response handler in HTTP/2 & improve connection preservation

76− in HTTP/1.x if uncaught exceptions are thrown in an `Application`.

77− [#738](https://github.com/yesodweb/wai/pull/738)

78−

79−## 3.2.26

80−

81−* Support network package version 3

82−

83−## 3.2.25

84−

85−* Removing Connection: and Transfer-Encoding: from HTTP/2

86− response header

87− [#707](https://github.com/yesodweb/wai/pull/707)

88−

89−## 3.2.24

90−

91−* Fix HTTP2 unwanted GoAways on late WindowUpdate frames.

92− [#711](https://github.com/yesodweb/wai/pull/711)

93−

94−## 3.2.23

95−

96−* Log real requsts when an app throws an error.

97− [#698](https://github.com/yesodweb/wai/pull/698)

98−

99−## 3.2.22

100−

101−* Fixing large request body in HTTP/2.

102−

103−## 3.2.21

104−

105−* Fixing HTTP/2's timeout handler in request's vault.

106−

107−## 3.2.20

108−

109−* Fixing large request body in HTTP/2

110− [#593](https://github.com/yesodweb/wai/issues/593)

111−

112−## 3.2.19

113−

114−* Fixing 0-byte request body in HTTP/2

115− [#597](https://github.com/yesodweb/wai/issues/597)

116− [#679](https://github.com/yesodweb/wai/issues/679)

117−

118−## 3.2.18.2

119−

120−* Replace dependency on `blaze-builder` with `bsb-http-chunked`

121−

122−## 3.2.18.1

123−

124−* Fix benchmark compilation [#681](https://github.com/yesodweb/wai/issues/681)

125−

126−## 3.2.18

127−

128−* Make `testWithApplicationSettings` actually use the settings passed.

129− [#677](https://github.com/yesodweb/wai/pull/677).

130−

131−## 3.2.17

132−* Add support for windows thread block hack and closeOnExec to TLS.

133− [#674](https://github.com/yesodweb/wai/pull/674).

134−

135−## 3.2.16

136−

137−* In `testWithApplication`, don't `throwTo` ignorable exceptions

138− [#671](https://github.com/yesodweb/wai/issues/671), and

139− reuse `bindRandomPortTCP`

140−

141−## 3.2.15

142−

143−* Address space leak from exception handlers

144− [#649](https://github.com/yesodweb/wai/issues/649)

145−

146−## 3.2.14

147−

148−* Support streaming-commons 0.2

149−* Warnings cleanup

150−

151## 3.2.13

1## 3.2.13

152

2

153* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)

3* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)

warp/Network/Wai/Handler/Warp.hs+6−72

@@ -72,9 +72,6 @@ module Network.Wai.Handler.Warp (

72 , setLogger

73 , setServerPushLogger

74 , setGracefulShutdownTimeout

75− , setGracefulCloseTimeout1

76− , setGracefulCloseTimeout2

77− , setMaxTotalHeaderLength

78 -- ** Getters

75 -- ** Getters

79 , getPort

76 , getPort

80 , getHost

77 , getHost

@@ -82,8 +79,6 @@ module Network.Wai.Handler.Warp (

82 , getOnClose

79 , getOnClose

83 , getOnException

80 , getOnException

84 , getGracefulShutdownTimeout

81 , getGracefulShutdownTimeout

85− , getGracefulCloseTimeout1

86− , getGracefulCloseTimeout2

87 -- ** Exception handler

82 -- ** Exception handler

88 , defaultOnException

83 , defaultOnException

89 , defaultShouldDisplayException

84 , defaultShouldDisplayException

@@ -98,7 +93,6 @@ module Network.Wai.Handler.Warp (

98 , pauseTimeout

93 , pauseTimeout

99 , FileInfo(..)

94 , FileInfo(..)

100 , getFileInfo

95 , getFileInfo

101− , clientCertificate

102 , withApplication

96 , withApplication

103 , withApplicationSettings

97 , withApplicationSettings

104 , testWithApplication

98 , testWithApplication

@@ -125,22 +119,21 @@ module Network.Wai.Handler.Warp (

125 ) where

119 ) where

126

120

127import Control.Exception (SomeException, throwIO)

121import Control.Exception (SomeException, throwIO)

122+import Data.ByteString (ByteString)

123+import Data.Maybe (fromMaybe)

128import Data.Streaming.Network (HostPreference)

124import Data.Streaming.Network (HostPreference)

129import qualified Data.Vault.Lazy as Vault

125import qualified Data.Vault.Lazy as Vault

130−import Data.X509

131import qualified Network.HTTP.Types as H

126import qualified Network.HTTP.Types as H

132import Network.Socket (SockAddr)

127import Network.Socket (SockAddr)

133import Network.Wai (Request, Response, vault)

128import Network.Wai (Request, Response, vault)

134−import System.TimeManager

135−

136import Network.Wai.Handler.Warp.FileInfoCache

129import Network.Wai.Handler.Warp.FileInfoCache

137−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

138−import Network.Wai.Handler.Warp.HTTP2.Types

139−import Network.Wai.Handler.Warp.Imports

140import Network.Wai.Handler.Warp.Request

130import Network.Wai.Handler.Warp.Request

141import Network.Wai.Handler.Warp.Response (warpVersion)

131import Network.Wai.Handler.Warp.Response (warpVersion)

142import Network.Wai.Handler.Warp.Run

132import Network.Wai.Handler.Warp.Run

143import Network.Wai.Handler.Warp.Settings

133import Network.Wai.Handler.Warp.Settings

134+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

135+import Network.Wai.Handler.Warp.HTTP2.Types

136+import Network.Wai.Handler.Warp.Timeout

144import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

137import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

145import Network.Wai.Handler.Warp.WithApplication

138import Network.Wai.Handler.Warp.WithApplication

146

139

@@ -303,18 +296,6 @@ getGracefulShutdownTimeout = settingsGracefulShutdownTimeout

303-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

296-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

304-- @

297-- @

305--

298--

306−-- Note that by default, the graceful shutdown mode lasts indefinitely

307−-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,

308−-- upon receiving that signal, the custon shutdown action will run /and/ all

309−-- outstanding requests will be handled.

310−--

311−-- You may instead prefer to do one or both of the following:

312−--

313−-- * Only wait a finite amount of time for outstanding requests to complete,

314−-- using 'setGracefulShutdownTimeout'.

315−-- * Only catch one signal, so the second hard-kills the Warp server, using

316−-- 'System.Posix.Signals.CatchOnce'.

317−--

318-- Default: does not install any code.

299-- Default: does not install any code.

319--

300--

320-- Since 3.0.1

301-- Since 3.0.1

@@ -385,7 +366,7 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }

385--

366--

386-- WARNING: This is contrary to the PROXY protocol specification and

367-- WARNING: This is contrary to the PROXY protocol specification and

387-- using it can indicate a security problem with your

368-- using it can indicate a security problem with your

388−-- architecture if the web server is directly accessible

369+-- architecture if the web server is directly accessable

389-- to the public, since it would allow easy IP address

370-- to the public, since it would allow easy IP address

390-- spoofing. However, it can be useful in some cases,

371-- spoofing. However, it can be useful in some cases,

391-- such as if a load balancer health check uses regular

372-- such as if a load balancer health check uses regular

@@ -428,22 +409,11 @@ setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }

428-- wait indefinitely, and a number, if provided, will be treated as seconds

409-- wait indefinitely, and a number, if provided, will be treated as seconds

429-- to wait for requests to finish, before shutting down the server entirely.

410-- to wait for requests to finish, before shutting down the server entirely.

430--

411--

431−-- Graceful shutdown mode is entered when the server socket is closed; see

432−-- 'setInstallShutdownHandler' for an example of how this could be done in

433−-- response to a UNIX signal.

434−--

435-- Since 3.2.8

412-- Since 3.2.8

436setGracefulShutdownTimeout :: Maybe Int

413setGracefulShutdownTimeout :: Maybe Int

437 -> Settings -> Settings

414 -> Settings -> Settings

438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

415setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

439

416

440−-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.

441−--

442−-- Since 3.3.8

443−setMaxTotalHeaderLength :: Int -> Settings -> Settings

444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446−

447-- | Explicitly pause the slowloris timeout.

417-- | Explicitly pause the slowloris timeout.

448--

418--

449-- This is useful for cases where you partially consume a request body. For

419-- This is useful for cases where you partially consume a request body. For

@@ -471,39 +441,3 @@ pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

471-- Since 3.1.10

441-- Since 3.1.10

472getFileInfo :: Request -> FilePath -> IO FileInfo

442getFileInfo :: Request -> FilePath -> IO FileInfo

473getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

443getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

474−

475−-- | A timeout to limit the time (in milliseconds) waiting for

476−-- FIN for HTTP/1.x. 0 means uses immediate close.

477−-- Default: 0.

478−--

479−-- Since 3.3.5

480−setGracefulCloseTimeout1 :: Int -> Settings -> Settings

481−setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }

482−

483−-- | A timeout to limit the time (in milliseconds) waiting for

484−-- FIN for HTTP/1.x. 0 means uses immediate close.

485−--

486−-- Since 3.3.5

487−getGracefulCloseTimeout1 :: Settings -> Int

488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489−

490−-- | A timeout to limit the time (in milliseconds) waiting for

491−-- FIN for HTTP/2. 0 means uses immediate close.

492−-- Default: 2000.

493−--

494−-- Since 3.3.5

495−setGracefulCloseTimeout2 :: Int -> Settings -> Settings

496−setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }

497−

498−-- | A timeout to limit the time (in milliseconds) waiting for

499−-- FIN for HTTP/2. 0 means uses immediate close.

500−--

501−-- Since 3.3.5

502−getGracefulCloseTimeout2 :: Settings -> Int

503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504−

505−-- | Getting information of client certificate.

506−--

507−-- Since 3.3.5

508−clientCertificate :: Request -> Maybe CertificateChain

509−clientCertificate = join . Vault.lookup getClientCertificateKey . vault

warp/Network/Wai/Handler/Warp/Buffer.hs+2−4

@@ -1,4 +1,4 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2

3module Network.Wai.Handler.Warp.Buffer (

4 bufferSize

@@ -13,15 +13,13 @@ module Network.Wai.Handler.Warp.Buffer (

13 ) where

14

15import qualified Data.ByteString as BS

16−import Data.ByteString.Internal (memcpy)

16+import Data.ByteString.Internal (ByteString(..), memcpy)

17import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)

18import Data.IORef (newIORef, readIORef, writeIORef)

19import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))

20import Foreign.ForeignPtr

21import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)

22import Foreign.Ptr (castPtr, plusPtr)

23−

24−import Network.Wai.Handler.Warp.Imports

25import Network.Wai.Handler.Warp.Types

23import Network.Wai.Handler.Warp.Types

26

24

27----------------------------------------------------------------

25----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Conduit.hs+3−2

@@ -3,10 +3,11 @@

3module Network.Wai.Handler.Warp.Conduit where

4

5import Control.Exception

6+import Control.Monad (when, unless)

7+import Data.ByteString (ByteString)

6import qualified Data.ByteString as S

8import qualified Data.ByteString as S

7import qualified Data.IORef as I

9import qualified Data.IORef as I

8−

10+import Data.Word (Word8)

9−import Network.Wai.Handler.Warp.Imports

10import Network.Wai.Handler.Warp.Types

11import Network.Wai.Handler.Warp.Types

11

12

12----------------------------------------------------------------

13----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Counter.hs+1−3

@@ -9,9 +9,7 @@ module Network.Wai.Handler.Warp.Counter (

9 ) where

10

11import Control.Concurrent.STM

12−

12+import Control.Monad (unless)

13−import Network.Wai.Handler.Warp.Imports

14−

15

13

16newtype Counter = Counter (TVar Int)

14newtype Counter = Counter (TVar Int)

17

15

warp/Network/Wai/Handler/Warp/Date.hs+1−1

@@ -6,7 +6,7 @@ module Network.Wai.Handler.Warp.Date (

6 ) where

7

8import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

9−import Data.ByteString

9+import Data.ByteString.Char8

10import Network.HTTP.Date

11

12#if WINDOWS

warp/Network/Wai/Handler/Warp/FdCache.hs+23−19

@@ -17,31 +17,33 @@ module Network.Wai.Handler.Warp.FdCache (

17import Control.Exception (bracket)

18import Control.Reaper

19import Data.IORef

20−import Network.Wai.Handler.Warp.MultiMap as MM

20+import Network.Wai.Handler.Warp.MultiMap

21import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)

22#endif

23import System.Posix.Types (Fd)

24

25----------------------------------------------------------------

26

27+type Hash = Int

28+

27-- | An action to activate a Fd cache entry.

29-- | An action to activate a Fd cache entry.

28type Refresh = IO ()

30type Refresh = IO ()

29

31

30−getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)

32+getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)

31−getFdNothing _ = return (Nothing, return ())

33+getFdNothing _ _ = return (Nothing, return ())

32

34

33----------------------------------------------------------------

35----------------------------------------------------------------

34

36

35-- | Creating 'MutableFdCache' and executing the action in the second

37-- | Creating 'MutableFdCache' and executing the action in the second

36-- argument. The first argument is a cache duration in second.

38-- argument. The first argument is a cache duration in second.

37−withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

39+withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

38#ifdef WINDOWS

40#ifdef WINDOWS

39withFdCache _ action = action getFdNothing

41withFdCache _ action = action getFdNothing

40#else

42#else

41withFdCache 0 action = action getFdNothing

43withFdCache 0 action = action getFdNothing

42withFdCache duration action = bracket (initialize duration)

44withFdCache duration action = bracket (initialize duration)

43 terminate

45 terminate

44− (action . getFd)

46+ (\mfc -> action (getFd mfc))

45

47

46----------------------------------------------------------------

48----------------------------------------------------------------

47

49

@@ -63,7 +65,7 @@ inactive (MutableStatus ref) = writeIORef ref Inactive

63

65

64----------------------------------------------------------------

66----------------------------------------------------------------

65

67

66−data FdEntry = FdEntry !Fd !MutableStatus

68+data FdEntry = FdEntry !FilePath !Fd !MutableStatus

67

69

68openFile :: FilePath -> IO Fd

70openFile :: FilePath -> IO Fd

69openFile path = do

71openFile path = do

@@ -75,23 +77,25 @@ closeFile :: Fd -> IO ()

75closeFile = closeFd

77closeFile = closeFd

76

78

77newFdEntry :: FilePath -> IO FdEntry

79newFdEntry :: FilePath -> IO FdEntry

78−newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus

80+newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus

79

81

80setFileCloseOnExec :: Fd -> IO ()

82setFileCloseOnExec :: Fd -> IO ()

81setFileCloseOnExec fd = setFdOption fd CloseOnExec True

83setFileCloseOnExec fd = setFdOption fd CloseOnExec True

82

84

83----------------------------------------------------------------

85----------------------------------------------------------------

84

86

85−type FdCache = MultiMap FdEntry

87+type FdCache = MMap FdEntry

86

88

87-- | Mutable Fd cacher.

89-- | Mutable Fd cacher.

88−newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))

90+newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))

89

91

90fdCache :: MutableFdCache -> IO FdCache

92fdCache :: MutableFdCache -> IO FdCache

91fdCache (MutableFdCache reaper) = reaperRead reaper

93fdCache (MutableFdCache reaper) = reaperRead reaper

92

94

93−look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)

95+look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)

94−look mfc path = MM.lookup path <$> fdCache mfc

96+look mfc path key = searchWith key check <$> fdCache mfc

97+ where

98+ check (FdEntry path' _ _) = path == path'

95

99

96----------------------------------------------------------------

100----------------------------------------------------------------

97

101

@@ -112,7 +116,7 @@ clean old = do

112 new <- pruneWith old prune

116 new <- pruneWith old prune

113 return $ merge new

117 return $ merge new

114 where

118 where

115− prune (_,FdEntry fd mst) = status mst >>= act

119+ prune (FdEntry _ fd mst) = status mst >>= act

116 where

120 where

117 act Active = inactive mst >> return True

121 act Active = inactive mst >> return True

118 act Inactive = closeFd fd >> return False

122 act Inactive = closeFd fd >> return False

@@ -122,21 +126,21 @@ clean old = do

122terminate :: MutableFdCache -> IO ()

126terminate :: MutableFdCache -> IO ()

123terminate (MutableFdCache reaper) = do

127terminate (MutableFdCache reaper) = do

124 !t <- reaperStop reaper

128 !t <- reaperStop reaper

125− mapM_ (closeIt . snd) $ toList t

129+ mapM_ closeIt $ toList t

126 where

130 where

127− closeIt (FdEntry fd _) = closeFd fd

131+ closeIt (FdEntry _ fd _) = closeFd fd

128

132

129----------------------------------------------------------------

133----------------------------------------------------------------

130

134

131-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

135-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

132−getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)

136+getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)

133−getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get

137+getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get

134 where

138 where

135 get Nothing = do

139 get Nothing = do

136− ent@(FdEntry fd mst) <- newFdEntry path

140+ ent@(FdEntry _ fd mst) <- newFdEntry path

137− reaperAdd reaper (path,ent)

141+ reaperAdd reaper (h, ent)

138 return (Just fd, refresh mst)

142 return (Just fd, refresh mst)

139− get (Just (FdEntry fd mst)) = do

143+ get (Just (FdEntry _ fd mst)) = do

140 refresh mst

144 refresh mst

141 return (Just fd, refresh mst)

145 return (Just fd, refresh mst)

142#endif

146#endif

warp/Network/Wai/Handler/Warp/File.hs+10−12

@@ -9,18 +9,19 @@ module Network.Wai.Handler.Warp.File (

9 , H.parseByteRanges

10 ) where

11

12+import Control.Applicative ((<|>))

12import Data.Array ((!))

13import Data.Array ((!))

13−import qualified Data.ByteString.Char8 as C8 (pack)

14+import qualified Data.ByteString.Char8 as B (pack)

15+import Data.ByteString (ByteString)

16+import Data.Maybe (fromMaybe)

14import Network.HTTP.Date

17import Network.HTTP.Date

15import qualified Network.HTTP.Types as H

18import qualified Network.HTTP.Types as H

16import qualified Network.HTTP.Types.Header as H

19import qualified Network.HTTP.Types.Header as H

17import Network.Wai

20import Network.Wai

18−

19import qualified Network.Wai.Handler.Warp.FileInfoCache as I

21import qualified Network.Wai.Handler.Warp.FileInfoCache as I

20import Network.Wai.Handler.Warp.Header

22import Network.Wai.Handler.Warp.Header

21−import Network.Wai.Handler.Warp.Imports

22import Network.Wai.Handler.Warp.PackInt

23import Network.Wai.Handler.Warp.PackInt

23−

24+import Numeric (showInt)

24

25

25-- $setup

26-- $setup

26-- >>> import Test.QuickCheck

27-- >>> import Test.QuickCheck

@@ -34,15 +35,12 @@ data RspFileInfo = WithoutBody H.Status

34----------------------------------------------------------------

35----------------------------------------------------------------

35

36

36conditionalRequest :: I.FileInfo

37conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders

38+ -> H.ResponseHeaders -> IndexedHeader

38− -> IndexedHeader -- ^ Response

39− -> IndexedHeader -- ^ Request

40 -> RspFileInfo

39 -> RspFileInfo

41−conditionalRequest finfo hs0 rspidx reqidx = case condition of

40+conditionalRequest finfo hs0 reqidx = case condition of

42 nobody@(WithoutBody _) -> nobody

41 nobody@(WithoutBody _) -> nobody

43− WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size

44− !hasLM = isJust $ rspidx ! fromEnum ResLastModified

45− !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1

42+ WithBody s _ off len -> let !hs = (H.hLastModified,date) :

43+ addContentHeaders hs0 off len size

46 in WithBody s hs off len

44 in WithBody s hs off len

47 where

45 where

48 !mtime = I.fileInfoTime finfo

46 !mtime = I.fileInfoTime finfo

@@ -119,7 +117,7 @@ checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)

119contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

117contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

120contentRangeHeader beg end total = (H.hContentRange, range)

118contentRangeHeader beg end total = (H.hContentRange, range)

121 where

119 where

122− range = C8.pack

120+ range = B.pack

123 -- building with ShowS

121 -- building with ShowS

124 $ 'b' : 'y': 't' : 'e' : 's' : ' '

122 $ 'b' : 'y': 't' : 'e' : 's' : ' '

125 : (if beg > end then ('*':) else

123 : (if beg > end then ('*':) else

warp/Network/Wai/Handler/Warp/FileInfoCache.hs+26−23

@@ -2,21 +2,24 @@

2

3module Network.Wai.Handler.Warp.FileInfoCache (

4 FileInfo(..)

5+ , Hash

5 , withFileInfoCache

6 , withFileInfoCache

6 , getInfo -- test purpose only

7 , getInfo -- test purpose only

7 ) where

8 ) where

8

9

9import Control.Exception as E

10import Control.Exception as E

11+import Control.Monad (void)

10import Control.Reaper

12import Control.Reaper

13+import Data.ByteString (ByteString)

11import Network.HTTP.Date

14import Network.HTTP.Date

12−import System.PosixCompat.Files

13−

14import Network.Wai.Handler.Warp.HashMap (HashMap)

15import Network.Wai.Handler.Warp.HashMap (HashMap)

15import qualified Network.Wai.Handler.Warp.HashMap as M

16import qualified Network.Wai.Handler.Warp.HashMap as M

16−import Network.Wai.Handler.Warp.Imports

17+import System.PosixCompat.Files

17

18

18----------------------------------------------------------------

19----------------------------------------------------------------

19

20

21+type Hash = Int

22+

20-- | File information.

23-- | File information.

21data FileInfo = FileInfo {

24data FileInfo = FileInfo {

22 fileInfoName :: !FilePath

25 fileInfoName :: !FilePath

@@ -26,8 +29,8 @@ data FileInfo = FileInfo {

26 } deriving (Eq, Show)

29 } deriving (Eq, Show)

27

30

28data Entry = Negative | Positive FileInfo

31data Entry = Negative | Positive FileInfo

29−type Cache = HashMap Entry

32+type Cache = HashMap FilePath Entry

30−type FileInfoCache = Reaper Cache (FilePath,Entry)

33+type FileInfoCache = Reaper Cache (Int,FilePath,Entry)

31

34

32----------------------------------------------------------------

35----------------------------------------------------------------

33

36

@@ -51,29 +54,29 @@ getInfo path = do

51 else

54 else

52 throwIO (userError "FileInfoCache:getInfo")

55 throwIO (userError "FileInfoCache:getInfo")

53

56

54−getInfoNaive :: FilePath -> IO FileInfo

57+getInfoNaive :: Hash -> FilePath -> IO FileInfo

55−getInfoNaive = getInfo

58+getInfoNaive _ = getInfo

56

59

57----------------------------------------------------------------

60----------------------------------------------------------------

58

61

59−getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo

62+getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

60−getAndRegisterInfo reaper@Reaper{..} path = do

63+getAndRegisterInfo reaper@Reaper{..} h path = do

61 cache <- reaperRead

64 cache <- reaperRead

62− case M.lookup path cache of

65+ case M.lookup h path cache of

63 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

66 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

64 Just (Positive x) -> return x

67 Just (Positive x) -> return x

65− Nothing -> positive reaper path

68+ Nothing -> positive reaper h path

66− `E.onException` negative reaper path

69+ `E.onException` negative reaper h path

67

70

68−positive :: FileInfoCache -> FilePath -> IO FileInfo

71+positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

69−positive Reaper{..} path = do

72+positive Reaper{..} h path = do

70 info <- getInfo path

73 info <- getInfo path

71− reaperAdd (path, Positive info)

74+ reaperAdd (h, path, Positive info)

72 return info

75 return info

73

76

74−negative :: FileInfoCache -> FilePath -> IO FileInfo

77+negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

75−negative Reaper{..} path = do

78+negative Reaper{..} h path = do

76− reaperAdd (path, Negative)

79+ reaperAdd (h, path,Negative)

77 throwIO (userError "FileInfoCache:negative")

80 throwIO (userError "FileInfoCache:negative")

78

81

79----------------------------------------------------------------

82----------------------------------------------------------------

@@ -82,22 +85,22 @@ negative Reaper{..} path = do

82-- and executing the action in the second argument.

85-- and executing the action in the second argument.

83-- The first argument is a cache duration in second.

86-- The first argument is a cache duration in second.

84withFileInfoCache :: Int

87withFileInfoCache :: Int

85− -> ((FilePath -> IO FileInfo) -> IO a)

88+ -> ((Hash -> FilePath -> IO FileInfo) -> IO a)

86 -> IO a

89 -> IO a

87withFileInfoCache 0 action = action getInfoNaive

90withFileInfoCache 0 action = action getInfoNaive

88withFileInfoCache duration action =

91withFileInfoCache duration action =

89 E.bracket (initialize duration)

92 E.bracket (initialize duration)

90 terminate

93 terminate

91− (action . getAndRegisterInfo)

94+ (\r -> action (getAndRegisterInfo r))

92

95

93−initialize :: Int -> IO FileInfoCache

96+initialize :: Hash -> IO FileInfoCache

94initialize duration = mkReaper settings

97initialize duration = mkReaper settings

95 where

98 where

96 settings = defaultReaperSettings {

99 settings = defaultReaperSettings {

97 reaperAction = override

100 reaperAction = override

98 , reaperDelay = duration

101 , reaperDelay = duration

99− , reaperCons = \(path,v) -> M.insert path v

102+ , reaperCons = \(h,k,v) -> M.insert h k v

100− , reaperNull = M.isEmpty

103+ , reaperNull = M.null

101 , reaperEmpty = M.empty

104 , reaperEmpty = M.empty

102 }

105 }

103

106

warp/Network/Wai/Handler/Warp/HTTP2.hs+56−72

@@ -1,85 +1,69 @@

1−{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE PatternGuards #-}

2+{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6

3

7−module Network.Wai.Handler.Warp.HTTP2 (http2) where

4+module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where

8

5

9−import qualified Data.IORef as I

6+import Control.Concurrent (forkIO, killThread)

10import qualified Control.Exception as E

7import qualified Control.Exception as E

8+import Control.Monad (when, unless, replicateM_)

9+import Data.ByteString (ByteString)

11−import qualified Network.HTTP2.Server as H2

10+import Network.HTTP2

12import Network.Socket (SockAddr)

11import Network.Socket (SockAddr)

13import Network.Wai

12import Network.Wai

14−import Network.Wai.Internal (ResponseReceived(..))

13+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

15−import qualified System.TimeManager as T

16−

17−import Network.Wai.Handler.Warp.HTTP2.File

14+import Network.Wai.Handler.Warp.HTTP2.Manager

18−import Network.Wai.Handler.Warp.HTTP2.PushPromise

15+import Network.Wai.Handler.Warp.HTTP2.Receiver

19import Network.Wai.Handler.Warp.HTTP2.Request

16import Network.Wai.Handler.Warp.HTTP2.Request

20−import Network.Wai.Handler.Warp.HTTP2.Response

17+import Network.Wai.Handler.Warp.HTTP2.Sender

18+import Network.Wai.Handler.Warp.HTTP2.Types

21−import Network.Wai.Handler.Warp.Imports

19+import Network.Wai.Handler.Warp.HTTP2.Worker

22−import qualified Network.Wai.Handler.Warp.Settings as S

20+import qualified Network.Wai.Handler.Warp.Settings as S (Settings)

23import Network.Wai.Handler.Warp.Types

21import Network.Wai.Handler.Warp.Types

24

22

25----------------------------------------------------------------

23----------------------------------------------------------------

26

24

27−http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> (ByteString -> IO ()) -> Application -> IO ()

25+http2 :: Connection -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()

28−http2 conn transport ii addr settings readN send app =

26+http2 conn ii1 addr transport settings readN app = do

29− H2.run conf http2server

27+ checkTLS

28+ ok <- checkPreface

29+ when ok $ do

30+ ctx <- newContext

31+ -- Workers, worker manager and timer manager

32+ mgr <- start settings

33+ let responder = response settings ctx mgr

34+ action = worker ctx settings app responder

35+ setAction mgr action

36+ -- The number of workers is 3.

37+ -- This was carefully chosen based on a lot of benchmarks.

38+ -- If it is 1, we cannot avoid head-of-line blocking.

39+ -- If it is large, huge memory is consumed and many

40+ -- context switches happen.

41+ replicateM_ 3 $ spawnAction mgr

42+ -- Receiver

43+ let mkreq = mkRequest ii1 settings addr

44+ tid <- forkIO $ frameReceiver ctx mkreq readN

45+ -- Sender

46+ -- frameSender is the main thread because it ensures to send

47+ -- a goway frame.

48+ frameSender ctx conn settings mgr `E.finally` do

49+ clearContext ctx

50+ stop mgr

51+ killThread tid

30 where

52 where

31− conf = H2.Config {

53+ checkTLS = case transport of

32− confWriteBuffer = connWriteBuffer conn

54+ TCP -> return () -- direct

33− , confBufferSize = connBufferSize conn

55+ tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"

34− , confSendAll = send

56+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

35− , confReadN = readN

57+ checkPreface = do

36− , confPositionReadMaker = pReadMaker ii

58+ preface <- readN connectionPrefaceLength

37− }

59+ if connectionPreface /= preface then do

38−

60+ goaway conn ProtocolError "Preface mismatch"

39− http2server h2req aux response = do

61+ return False

40− req <- toWAIRequest h2req aux

62+ else

41− ref <- I.newIORef Nothing

42− eResponseReceived <- E.try $ app req $ \rsp -> do

43− h2rsp <- fromResponse settings ii req rsp

44− pps <- fromPushPromises ii req

45− I.writeIORef ref $ Just (h2rsp, pps)

46− _ <- response h2rsp pps

47− return ResponseReceived

48− case eResponseReceived of

49− Right ResponseReceived -> do

50− Just (h2rsp, pps) <- I.readIORef ref

51− logResponse h2rsp req

52− mapM_ (logPushPromise req) pps

53− Left e@(E.SomeException _)

54− -- killed by the local worker manager

55− | Just E.ThreadKilled <- E.fromException e -> return ()

56− -- killed by the local timeout manager

57− | Just T.TimeoutThread <- E.fromException e -> return ()

58− | otherwise -> do

59− S.settingsOnException settings (Just req) e

60− let ersp = S.settingsOnExceptionResponse settings e

61− h2rsp' <- fromResponse settings ii req ersp

62− _ <- response h2rsp' []

63− logResponse h2rsp' req

64− return ()

63+ return True

65

64

66− toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport

65+-- connClose must not be called here since Run:fork calls it

67− where

66+goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()

68− !hdr = H2.requestHeaders h2req

67+goaway Connection{..} etype debugmsg = connSendAll bytestream

69− !bdy = H2.getRequestBodyChunk h2req

68+ where

70− !bdylen = H2.requestBodySize h2req

69+ bytestream = goawayFrame 0 etype debugmsg

71− !th = H2.auxTimeHandle aux

72−

73− logResponse h2rsp req = logger req st msiz

74− where

75− !logger = S.settingsLogger settings

76− !st = H2.responseStatus h2rsp

77− !msiz = fromIntegral <$> H2.responseBodySize h2rsp

78−

79− logPushPromise req pp = logger req path siz

80− where

81− !logger = S.settingsServerPushLogger settings

82− !path = H2.promiseRequestPath pp

83− !siz = case H2.responseBodySize $ H2.promiseResponse pp of

84− Nothing -> 0

85− Just s -> fromIntegral s

warp/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+

3+module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where

4+

5+import Data.ByteString (ByteString)

6+import Network.HTTP2

7+

8+----------------------------------------------------------------

9+

10+goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString

11+goawayFrame sid etype debugmsg = encodeFrame einfo frame

12+ where

13+ einfo = encodeInfo id 0

14+ frame = GoAwayFrame sid etype debugmsg

15+

16+resetFrame :: ErrorCodeId -> StreamId -> ByteString

17+resetFrame etype sid = encodeFrame einfo frame

18+ where

19+ einfo = encodeInfo id sid

20+ frame = RSTStreamFrame etype

21+

22+settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString

23+settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist

24+ where

25+ einfo = encodeInfo func 0

26+

27+pingFrame :: ByteString -> ByteString

28+pingFrame bs = encodeFrame einfo $ PingFrame bs

29+ where

30+ einfo = encodeInfo setAck 0

31+

32+windowUpdateFrame :: StreamId -> WindowSize -> ByteString

33+windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz

34+ where

35+ einfo = encodeInfo id sid

warp/Network/Wai/Handler/Warp/HTTP2/File.hs+152−23

@@ -1,30 +1,159 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE BangPatterns, RecordWildCards #-}

2

4

3−module Network.Wai.Handler.Warp.HTTP2.File where

5+module Network.Wai.Handler.Warp.HTTP2.File (

6+ RspFileInfo(..)

7+ , conditionalRequest

8+ , addContentHeadersForFilePart

9+ , H.parseByteRanges

10+ ) where

4

11

5−import Network.HTTP2.Server

12+import Control.Applicative ((<|>))

13+import qualified Data.ByteString.Char8 as B (pack)

14+import Data.ByteString (ByteString)

15+import Data.Maybe (fromMaybe)

16+import Network.HTTP.Date

17+import qualified Network.HTTP.Types as H

18+import Network.Wai

19+import qualified Network.Wai.Handler.Warp.FileInfoCache as I

20+import Network.Wai.Handler.Warp.PackInt

21+import Numeric (showInt)

22+import Network.HPACK

23+import Network.HPACK.Token

6

24

7−import Network.Wai.Handler.Warp.Types

25+-- $setup

26+-- >>> import Test.QuickCheck

8

27

9−#ifdef WINDOWS

28+----------------------------------------------------------------

10−pReadMaker :: InternalInfo -> PositionReadMaker

11−pReadMaker _ = defaultPositionReadMaker

12−#else

13−import Network.Wai.Handler.Warp.FdCache

14−import Network.Wai.Handler.Warp.SendFile (positionRead)

15

29

16−pReadMaker :: InternalInfo -> PositionReadMaker

30+data RspFileInfo = WithoutBody !H.Status

17−pReadMaker ii path = do

31+ | WithBody !H.Status !TokenHeaderList !Integer !Integer

18− (mfd, refresh) <- getFd ii path

32+ deriving (Eq,Show)

19− case mfd of

33+

20− Just fd -> return (pread fd, Refresher refresh)

34+----------------------------------------------------------------

21− Nothing -> do

35+

22− fd <- openFile path

36+conditionalRequest :: I.FileInfo

23− return (pread fd, Closer $ closeFile fd)

37+ -> TokenHeaderList -- Response

38+ -> ValueTable -- Request

39+ -> RspFileInfo

40+conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of

41+ nobody@(WithoutBody _) -> nobody

42+ WithBody s _ off len -> let !hs = (tokenLastModified,date) :

43+ addContentHeaders ths0 off len size

44+ in WithBody s hs off len

45+ where

46+ !mcondition = ifmodified reqtbl size mtime

47+ <|> ifunmodified reqtbl size mtime

48+ <|> ifrange reqtbl size mtime

49+ !condition = fromMaybe (unconditional reqtbl size) mcondition

50+

51+----------------------------------------------------------------

52+

53+{-# INLINE ifModifiedSince #-}

54+ifModifiedSince :: ValueTable -> Maybe HTTPDate

55+ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate

56+

57+{-# INLINE ifUnmodifiedSince #-}

58+ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate

59+ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate

60+

61+{-# INLINE ifRange #-}

62+ifRange :: ValueTable -> Maybe HTTPDate

63+ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate

64+

65+----------------------------------------------------------------

66+

67+{-# INLINE ifmodified #-}

68+ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

69+ifmodified reqtbl size mtime = do

70+ date <- ifModifiedSince reqtbl

71+ return $ if date /= mtime

72+ then unconditional reqtbl size

73+ else WithoutBody H.notModified304

74+

75+{-# INLINE ifunmodified #-}

76+ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

77+ifunmodified reqtbl size mtime = do

78+ date <- ifUnmodifiedSince reqtbl

79+ return $ if date == mtime

80+ then unconditional reqtbl size

81+ else WithoutBody H.preconditionFailed412

82+

83+{-# INLINE ifrange #-}

84+ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo

85+ifrange reqtbl size mtime = do

86+ date <- ifRange reqtbl

87+ rng <- getHeaderValue tokenRange reqtbl

88+ return $ if date == mtime

89+ then parseRange rng size

90+ else WithBody H.ok200 [] 0 size

91+

92+{-# INLINE unconditional #-}

93+unconditional :: ValueTable -> Integer -> RspFileInfo

94+unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of

95+ Nothing -> WithBody H.ok200 [] 0 size

96+ Just rng -> parseRange rng size

97+

98+----------------------------------------------------------------

99+

100+{-# INLINE parseRange #-}

101+parseRange :: ByteString -> Integer -> RspFileInfo

102+parseRange rng size = case H.parseByteRanges rng of

103+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416

104+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416

105+ Just (r:_) -> let (!beg, !end) = checkRange r size

106+ !len = end - beg + 1

107+ s = if beg == 0 && end == size - 1 then

108+ H.ok200

109+ else

110+ H.partialContent206

111+ in WithBody s [] beg len

112+

113+{-# INLINE checkRange #-}

114+checkRange :: H.ByteRange -> Integer -> (Integer, Integer)

115+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)

116+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)

117+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)

118+

119+----------------------------------------------------------------

120+

121+{-# INLINE contentRangeHeader #-}

122+-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'

123+-- for the range specified.

124+contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader

125+contentRangeHeader beg end total = (tokenContentRange, range)

126+ where

127+ range = B.pack

128+ -- building with ShowS

129+ $ 'b' : 'y': 't' : 'e' : 's' : ' '

130+ : (if beg > end then ('*':) else

131+ showInt beg

132+ . ('-' :)

133+ . showInt end)

134+ ( '/'

135+ : showInt total "")

136+

137+{-# INLINE addContentHeaders #-}

138+addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList

139+addContentHeaders ths off len size

140+ | len == size = ths'

141+ | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size

142+ in ctrng:ths'

143+ where

144+ !lengthBS = packIntegral len

145+ !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths

146+

147+{-# INLINE addContentHeadersForFilePart #-}

148+-- |

149+--

150+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)

151+-- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]

152+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)

153+-- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]

154+addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList

155+addContentHeadersForFilePart hs part = addContentHeaders hs off len size

24 where

156 where

25− pread :: Fd -> PositionRead

157+ off = filePartOffset part

26− pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'

158+ len = filePartByteCount part

27− where

159+ size = filePartFileSize part

28− bytes' = fromIntegral bytes

29− off' = fromIntegral off

30−#endif

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hsnew file+112

@@ -0,0 +1,112 @@

1+{-# LANGUAGE OverloadedStrings, BangPatterns #-}

2+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

3+

4+module Network.Wai.Handler.Warp.HTTP2.HPACK (

5+ hpackEncodeHeader

6+ , hpackEncodeHeaderLoop

7+ , hpackDecodeHeader

8+ , just

9+ , addNecessaryHeaders

10+ , addHeader -- testing

11+ ) where

12+

13+import qualified Control.Exception as E

14+import Control.Monad (unless)

15+import Data.ByteString (ByteString)

16+import Network.HPACK hiding (Buffer)

17+import Network.HPACK.Token

18+import Network.HTTP2

19+import Network.Wai.Handler.Warp.HTTP2.Types

20+import Network.Wai.Handler.Warp.PackInt

21+import qualified Network.Wai.Handler.Warp.Settings as S

22+import Network.Wai.Handler.Warp.Types

23+

24+-- $setup

25+-- >>> :set -XOverloadedStrings

26+

27+----------------------------------------------------------------

28+

29+{-# INLINE addHeader #-}

30+addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList

31+addHeader t "" tbl ths = case getHeaderValue t tbl of

32+ Nothing -> ths

33+ _ -> filter ((/= tokenServer) . fst) ths

34+addHeader t v tbl ths = case getHeaderValue t tbl of

35+ Nothing -> (t,v) : ths

36+ _ -> ths

37+

38+addNecessaryHeaders :: Context

39+ -> Rspn

40+ -> InternalInfo

41+ -> S.Settings

42+ -> IO TokenHeaderList

43+addNecessaryHeaders Context{..} rspn ii settings = do

44+ date <- getDate ii

45+ let !s = rspnStatus rspn

46+ !status = packStatus s

47+ !defServer = S.settingsServerName settings

48+ (!ths0,tbl) = rspnHeaders rspn

49+ !ths1 = addHeader tokenServer defServer tbl ths0

50+ !ths2 = addHeader tokenDate date tbl ths1

51+ !ths3 = (tokenStatus, status) : ths2

52+ return ths3

53+

54+----------------------------------------------------------------

55+

56+strategy :: EncodeStrategy

57+strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }

58+

59+-- Set-Cookie: contains only one cookie value.

60+-- So, we don't need to split it.

61+hpackEncodeHeader :: Context -> Buffer -> BufSize

62+ -> TokenHeaderList

63+ -> IO (TokenHeaderList, Int)

64+hpackEncodeHeader Context{..} buf siz ths =

65+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths

66+

67+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize

68+ -> TokenHeaderList

69+ -> IO (TokenHeaderList, Int)

70+hpackEncodeHeaderLoop Context{..} buf siz hs =

71+ encodeTokenHeader buf siz strategy False encodeDynamicTable hs

72+

73+----------------------------------------------------------------

74+

75+hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)

76+hpackDecodeHeader hdrblk Context{..} = do

77+ tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl

78+ unless (checkRequestHeader vt) $

79+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

80+ return tbl

81+ where

82+ handl IllegalHeaderName =

83+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"

84+ handl _ =

85+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"

86+

87+{-# INLINE checkRequestHeader #-}

88+checkRequestHeader :: ValueTable -> Bool

89+checkRequestHeader reqvt

90+ | just mMethod (== "CONNECT") = mPath == Nothing && mScheme == Nothing

91+ | mStatus /= Nothing = False

92+ | mMethod == Nothing = False

93+ | mScheme == Nothing = False

94+ | mPath == Nothing = False

95+ | mPath == Just "" = False

96+ | mConnection /= Nothing = False

97+ | just mTE (/= "trailers") = False

98+ | otherwise = True

99+ where

100+ mStatus = getHeaderValue tokenStatus reqvt

101+ mScheme = getHeaderValue tokenScheme reqvt

102+ mPath = getHeaderValue tokenPath reqvt

103+ mMethod = getHeaderValue tokenMethod reqvt

104+ mConnection = getHeaderValue tokenConnection reqvt

105+ mTE = getHeaderValue tokenTE reqvt

106+

107+{-# INLINE just #-}

108+just :: Maybe a -> (a -> Bool) -> Bool

109+just Nothing _ = False

110+just (Just x) p

111+ | p x = True

112+ | otherwise = False

warp/Network/Wai/Handler/Warp/HTTP2/Manager.hsnew file+94

@@ -0,0 +1,94 @@

1+{-# LANGUAGE CPP, BangPatterns #-}

2+

3+-- | A thread pool manager.

4+-- The manager has responsibility to spawn and kill

5+-- worker threads.

6+module Network.Wai.Handler.Warp.HTTP2.Manager (

7+ Manager

8+ , start

9+ , setAction

10+ , stop

11+ , spawnAction

12+ , addMyId

13+ , deleteMyId

14+ ) where

15+

16+import Control.Concurrent

17+import Control.Concurrent.STM

18+import Control.Monad (void)

19+import Data.Foldable

20+import Data.IORef

21+import Data.Set (Set)

22+import qualified Data.Set as Set

23+import Network.Wai.Handler.Warp.Settings

24+import qualified Network.Wai.Handler.Warp.Timeout as T

25+

26+----------------------------------------------------------------

27+

28+type Action = T.Manager -> IO ()

29+

30+data Command = Stop | Spawn | Add ThreadId | Delete ThreadId

31+

32+data Manager = Manager (TQueue Command) (IORef Action)

33+

34+-- | Starting a thread pool manager.

35+-- Its action is initially set to 'return ()' and should be set

36+-- by 'setAction'. This allows that the action can include

37+-- the manager itself.

38+start :: Settings -> IO Manager

39+start set = do

40+ q <- newTQueueIO

41+ ref <- newIORef (\_ -> return ())

42+ timmgr <- T.initialize $ settingsTimeout set * 1000000

43+ void $ forkIO $ go q Set.empty ref timmgr

44+ return $ Manager q ref

45+ where

46+ go q !tset0 ref timmgr = do

47+ x <- atomically $ readTQueue q

48+ case x of

49+ Stop -> kill tset0 >> T.killManager timmgr

50+ Spawn -> next tset0

51+ Add newtid -> let !tset = add newtid tset0

52+ in go q tset ref timmgr

53+ Delete oldtid -> let !tset = del oldtid tset0

54+ in go q tset ref timmgr

55+ where

56+ next tset = do

57+ action <- readIORef ref

58+ newtid <- forkIO (action timmgr)

59+ let !tset' = add newtid tset

60+ go q tset' ref timmgr

61+

62+setAction :: Manager -> Action -> IO ()

63+setAction (Manager _ ref) action = writeIORef ref action

64+

65+stop :: Manager -> IO ()

66+stop (Manager q _) = atomically $ writeTQueue q Stop

67+

68+spawnAction :: Manager -> IO ()

69+spawnAction (Manager q _) = atomically $ writeTQueue q Spawn

70+

71+addMyId :: Manager -> IO ()

72+addMyId (Manager q _) = do

73+ tid <- myThreadId

74+ atomically $ writeTQueue q $ Add tid

75+

76+deleteMyId :: Manager -> IO ()

77+deleteMyId (Manager q _) = do

78+ tid <- myThreadId

79+ atomically $ writeTQueue q $ Delete tid

80+

81+----------------------------------------------------------------

82+

83+add :: ThreadId -> Set ThreadId -> Set ThreadId

84+add tid set = set'

85+ where

86+ !set' = Set.insert tid set

87+

88+del :: ThreadId -> Set ThreadId -> Set ThreadId

89+del tid set = set'

90+ where

91+ !set' = Set.delete tid set

92+

93+kill :: Set ThreadId -> IO ()

94+kill set = traverse_ killThread set

warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hsdeleted−36

@@ -1,36 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Network.Wai.Handler.Warp.HTTP2.PushPromise where

6−

7−import qualified Control.Exception as E

8−import qualified Network.HTTP.Types as H

9−import qualified Network.HTTP2.Server as H2

10−

11−import Network.Wai

12−import Network.Wai.Handler.Warp.FileInfoCache

13−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

14−import Network.Wai.Handler.Warp.HTTP2.Types

15−import Network.Wai.Handler.Warp.Imports

16−import Network.Wai.Handler.Warp.Types

17−

18−fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]

19−fromPushPromises ii req = do

20− mh2data <- getHTTP2Data req

21− let pp = case mh2data of

22− Nothing -> []

23− Just h2data -> http2dataPushPromise h2data

24− catMaybes <$> mapM (fromPushPromise ii) pp

25−

26−fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)

27−fromPushPromise ii (PushPromise path file rsphdr w) = do

28− efinfo <- E.try $ getFileInfo ii file

29− case efinfo of

30− Left (_ex :: E.IOException) -> return Nothing

31− Right finfo -> do

32− let !siz = fromIntegral $ fileInfoSize finfo

33− !fileSpec = H2.FileSpec file 0 siz

34− !rsp = H2.responseFile H.ok200 rsphdr fileSpec

35− !pp = H2.pushPromise path rsp w

36− return $ Just pp

warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hsnew file+397

@@ -0,0 +1,397 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE NamedFieldPuns #-}

3+{-# LANGUAGE BangPatterns #-}

4+{-# LANGUAGE CPP #-}

5+{-# LANGUAGE PatternGuards #-}

6+

7+module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where

8+

9+import Control.Concurrent

10+import Control.Concurrent.STM

11+import qualified Control.Exception as E

12+import Control.Monad (when, unless, void)

13+import Data.ByteString (ByteString)

14+import qualified Data.ByteString as BS

15+import Data.IORef

16+import Network.HPACK

17+import Network.HPACK.Token

18+import Network.HTTP2

19+import Network.HTTP2.Priority (toPrecedence, delete, prepare)

20+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

21+import Network.Wai.Handler.Warp.HTTP2.HPACK

22+import Network.Wai.Handler.Warp.HTTP2.Request

23+import Network.Wai.Handler.Warp.HTTP2.Types

24+import Network.Wai.Handler.Warp.ReadInt

25+import Network.Wai.Handler.Warp.Types

26+

27+----------------------------------------------------------------

28+

29+frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()

30+frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway

31+ where

32+ Context{ http2settings

33+ , streamTable

34+ , concurrency

35+ , continued

36+ , clientStreamId

37+ , inputQ

38+ , controlQ

39+ } = ctx

40+ sendGoaway e

41+ | Just (ConnectionError err msg) <- E.fromException e = do

42+ csid <- readIORef clientStreamId

43+ let !frame = goawayFrame csid err msg

44+ enqueueControl controlQ $ CGoaway frame

45+ | otherwise = return ()

46+

47+ sendReset err sid = do

48+ let !frame = resetFrame err sid

49+ enqueueControl controlQ $ CFrame frame

50+

51+ loop :: Int -> IO ()

52+ loop !n

53+ | n == 6 = do

54+ yield

55+ loop 0

56+ | otherwise = do

57+ hd <- recvN frameHeaderLength

58+ if BS.null hd then

59+ enqueueControl controlQ CFinish

60+ else do

61+ cont <- processStreamGuardingError $ decodeFrameHeader hd

62+ when cont $ loop (n + 1)

63+

64+ processStreamGuardingError (fid, FrameHeader{streamId})

65+ | isResponse streamId &&

66+ (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =

67+ E.throwIO $ ConnectionError ProtocolError "stream id should be odd"

68+ processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do

69+ mx <- readIORef continued

70+ case mx of

71+ Nothing -> do

72+ -- ignoring unknown frame

73+ consume payloadLength

74+ return True

75+ Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"

76+ processStreamGuardingError (FramePushPromise, _) =

77+ E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"

78+ processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do

79+ settings <- readIORef http2settings

80+ case checkFrameHeader settings typhdr of

81+ Left h2err -> case h2err of

82+ StreamError err sid -> do

83+ sendReset err sid

84+ consume payloadLength

85+ return True

86+ connErr -> E.throwIO connErr

87+ Right _ -> do

88+ ex <- E.try $ controlOrStream ftyp header

89+ case ex of

90+ Left (StreamError err sid) -> do

91+ sendReset err sid

92+ return True

93+ Left connErr -> E.throw connErr

94+ Right cont -> return cont

95+

96+ controlOrStream ftyp header@FrameHeader{streamId, payloadLength}

97+ | isControl streamId = do

98+ pl <- recvN payloadLength

99+ control ftyp header pl ctx

100+ | otherwise = do

101+ checkContinued

102+ !mstrm <- getStream

103+ pl <- recvN payloadLength

104+ case mstrm of

105+ Nothing -> do

106+ -- for h2spec only

107+ when (ftyp == FramePriority) $ do

108+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl

109+ checkPriority newpri streamId

110+ return True -- just ignore this frame

111+ Just strm@Stream{streamState,streamPrecedence} -> do

112+ state <- readIORef streamState

113+ state' <- stream ftyp header pl ctx state strm

114+ case state' of

115+ Open (NoBody tbl@(_,reqvt) pri) -> do

116+ resetContinued

117+ let mcl = readInt <$> getHeaderValue tokenContentLength reqvt

118+ when (just mcl (== (0 :: Int))) $

119+ E.throwIO $ StreamError ProtocolError streamId

120+ writeIORef streamPrecedence $ toPrecedence pri

121+ writeIORef streamState HalfClosed

122+ (!req, !ii) <- mkreq tbl (Just 0, return "")

123+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii

124+ Open (HasBody tbl@(_,reqvt) pri) -> do

125+ resetContinued

126+ q <- newTQueueIO

127+ let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt

128+ writeIORef streamPrecedence $ toPrecedence pri

129+ bodyLength <- newIORef 0

130+ writeIORef streamState $ Open (Body q mcl bodyLength)

131+ readQ <- newReadBody q

132+ bodySource <- mkSource readQ

133+ (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)

134+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii

135+ s@(Open Continued{}) -> do

136+ setContinued

137+ writeIORef streamState s

138+ s -> do -- Idle, Open Body, HalfClosed, Closed

139+ resetContinued

140+ writeIORef streamState s

141+ return True

142+ where

143+ setContinued = writeIORef continued (Just streamId)

144+ resetContinued = writeIORef continued Nothing

145+ checkContinued = do

146+ mx <- readIORef continued

147+ case mx of

148+ Nothing -> return ()

149+ Just sid

150+ | sid == streamId && ftyp == FrameContinuation -> return ()

151+ | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"

152+ getStream = do

153+ mstrm0 <- search streamTable streamId

154+ case mstrm0 of

155+ js@(Just strm0) -> do

156+ when (ftyp == FrameHeaders) $ do

157+ st <- readIORef $ streamState strm0

158+ when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed"

159+ -- Priority made an idele stream

160+ when (isIdle st) $ opened ctx strm0

161+ return js

162+ Nothing

163+ | isResponse streamId -> return Nothing

164+ | otherwise -> do

165+ when (ftyp `notElem` [FrameHeaders,FramePriority]) $

166+ E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream"

167+ csid <- readIORef clientStreamId

168+ if streamId <= csid then do

169+ if ftyp == FramePriority then

170+ return Nothing -- will be ignored

171+ else

172+ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"

173+ else do

174+ when (ftyp == FrameHeaders) $ do

175+ writeIORef clientStreamId streamId

176+ cnt <- readIORef concurrency

177+ -- Checking the limitation of concurrency

178+ when (cnt >= maxConcurrency) $

179+ E.throwIO $ StreamError RefusedStream streamId

180+ ws <- initialWindowSize <$> readIORef http2settings

181+ newstrm <- newStream streamId (fromIntegral ws)

182+ when (ftyp == FrameHeaders) $ opened ctx newstrm

183+ insert streamTable streamId newstrm

184+ return $ Just newstrm

185+

186+ consume = void . recvN

187+

188+maxConcurrency :: Int

189+maxConcurrency = recommendedConcurrency

190+

191+initialFrame :: ByteString

192+initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]

193+

194+----------------------------------------------------------------

195+

196+control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool

197+control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do

198+ SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs

199+ case checkSettingsList alist of

200+ Just x -> E.throwIO x

201+ Nothing -> return ()

202+ -- HTTP/2 Setting from a browser

203+ unless (testAck flags) $ do

204+ oldws <- initialWindowSize <$> readIORef http2settings

205+ modifyIORef' http2settings $ \old -> updateSettings old alist

206+ newws <- initialWindowSize <$> readIORef http2settings

207+ let diff = newws - oldws

208+ when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable

209+ let !frame = settingsFrame setAck []

210+ sent <- readIORef firstSettings

211+ let !setframe

212+ | sent = CSettings frame alist

213+ | otherwise = CSettings0 initialFrame frame alist

214+ unless sent $ writeIORef firstSettings True

215+ enqueueControl controlQ setframe

216+ return True

217+

218+control FramePing FrameHeader{flags} bs Context{controlQ} =

219+ if testAck flags then

220+ return True -- just ignore

221+ else do

222+ let !frame = pingFrame bs

223+ enqueueControl controlQ $ CFrame frame

224+ return True

225+

226+control FrameGoAway _ _ Context{controlQ} = do

227+ enqueueControl controlQ CFinish

228+ return False

229+

230+control FrameWindowUpdate header bs Context{connectionWindow} = do

231+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

232+ !w <- atomically $ do

233+ w0 <- readTVar connectionWindow

234+ let !w1 = w0 + n

235+ writeTVar connectionWindow w1

236+ return w1

237+ when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"

238+ return True

239+

240+control _ _ _ _ =

241+ -- must not reach here

242+ return False

243+

244+----------------------------------------------------------------

245+

246+{-# INLINE guardIt #-}

247+guardIt :: Either HTTP2Error a -> IO a

248+guardIt x = case x of

249+ Left err -> E.throwIO err

250+ Right frame -> return frame

251+

252+

253+{-# INLINE checkPriority #-}

254+checkPriority :: Priority -> StreamId -> IO ()

255+checkPriority p me

256+ | dep == me = E.throwIO $ StreamError ProtocolError me

257+ | otherwise = return ()

258+ where

259+ dep = streamDependency p

260+

261+stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState

262+stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do

263+ HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs

264+ pri <- case mp of

265+ Nothing -> return defaultPriority

266+ Just p -> do

267+ checkPriority p streamNumber

268+ return p

269+ let !endOfStream = testEndStream flags

270+ !endOfHeader = testEndHeader flags

271+ if endOfHeader then do

272+ tbl <- hpackDecodeHeader frag ctx -- fixme

273+ return $ if endOfStream then

274+ Open (NoBody tbl pri)

275+ else

276+ Open (HasBody tbl pri)

277+ else do

278+ let !siz = BS.length frag

279+ return $ Open $ Continued [frag] siz 1 endOfStream pri

280+

281+stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do

282+ -- trailer is not supported.

283+ -- let's read and ignore it.

284+ HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs

285+ let !endOfStream = testEndStream flags

286+ if endOfStream then do

287+ atomically $ writeTQueue q ""

288+ return HalfClosed

289+ else

290+ -- we don't support continuation here.

291+ E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"

292+

293+stream FrameData

294+ header@FrameHeader{flags,payloadLength,streamId}

295+ bs

296+ Context{controlQ} s@(Open (Body q mcl bodyLength))

297+ Stream{streamNumber} = do

298+ DataFrame body <- guardIt $ decodeDataFrame header bs

299+ let !endOfStream = testEndStream flags

300+ len0 <- readIORef bodyLength

301+ let !len = len0 + payloadLength

302+ writeIORef bodyLength len

303+ when (payloadLength /= 0) $ do

304+ let !frame1 = windowUpdateFrame 0 payloadLength

305+ !frame2 = windowUpdateFrame streamNumber payloadLength

306+ !frame = frame1 `BS.append` frame2

307+ enqueueControl controlQ $ CFrame frame

308+ atomically $ writeTQueue q body

309+ if endOfStream then do

310+ case mcl of

311+ Nothing -> return ()

312+ Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId

313+ atomically $ writeTQueue q ""

314+ return HalfClosed

315+ else

316+ return s

317+

318+stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do

319+ let !endOfHeader = testEndHeader flags

320+ !rfrags' = frag : rfrags

321+ !siz' = siz + BS.length frag

322+ !n' = n + 1

323+ when (siz' > 51200) $ -- fixme: hard coding: 50K

324+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"

325+ when (n' > 10) $ -- fixme: hard coding

326+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"

327+ if endOfHeader then do

328+ let !hdrblk = BS.concat $ reverse rfrags'

329+ tbl <- hpackDecodeHeader hdrblk ctx

330+ return $ if endOfStream then

331+ Open (NoBody tbl pri)

332+ else

333+ Open (HasBody tbl pri)

334+ else

335+ return $ Open $ Continued rfrags' siz' n' endOfStream pri

336+

337+stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do

338+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs

339+ !w <- atomically $ do

340+ w0 <- readTVar streamWindow

341+ let !w1 = w0 + n

342+ writeTVar streamWindow w1

343+ return w1

344+ when (isWindowOverflow w) $

345+ E.throwIO $ StreamError FlowControlError streamId

346+ return s

347+

348+stream FrameRSTStream header bs ctx _ strm = do

349+ RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs

350+ let !cc = Reset e

351+ closed ctx strm cc

352+ return $ Closed cc -- will be written to streamState again

353+

354+stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do

355+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs

356+ checkPriority newpri streamNumber

357+ oldpre <- readIORef streamPrecedence

358+ let !newpre = toPrecedence newpri

359+ writeIORef streamPrecedence newpre

360+ if isIdle s then do

361+ n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))

362+ -- fixme hard coding

363+ when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"

364+ prepare outputQ streamNumber newpri

365+ else do

366+ mx <- delete outputQ streamNumber oldpre

367+ case mx of

368+ Nothing -> return ()

369+ Just out -> enqueueOutput outputQ out

370+ return s

371+

372+-- this ordering is important

373+stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"

374+stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"

375+-- Ignore frames to streams we have just reset, per section 5.1.

376+stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st

377+stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId

378+stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId

379+

380+----------------------------------------------------------------

381+

382+{-# INLINE newReadBody #-}

383+newReadBody :: TQueue ByteString -> IO (IO ByteString)

384+newReadBody q = do

385+ ref <- newIORef False

386+ return $ readBody q ref

387+

388+{-# INLINE readBody #-}

389+readBody :: TQueue ByteString -> IORef Bool -> IO ByteString

390+readBody q ref = do

391+ eof <- readIORef ref

392+ if eof then

393+ return ""

394+ else do

395+ bs <- atomically $ readTQueue q

396+ when (bs == "") $ writeIORef ref True

397+ return bs

warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+30−27

@@ -1,54 +1,56 @@

1+{-# LANGUAGE OverloadedStrings, CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2

3

3module Network.Wai.Handler.Warp.HTTP2.Request (

4module Network.Wai.Handler.Warp.HTTP2.Request (

4− toRequest

5+ mkRequest

6+ , MkReq

5 , getHTTP2Data

7 , getHTTP2Data

6 , setHTTP2Data

8 , setHTTP2Data

7 , modifyHTTP2Data

9 , modifyHTTP2Data

8 ) where

10 ) where

9

11

12+import Control.Applicative ((<|>))

10import Control.Arrow (first)

13import Control.Arrow (first)

14+import Data.ByteString (ByteString)

11−import qualified Data.ByteString.Char8 as C8

15+import qualified Data.ByteString.Char8 as B8

12import Data.IORef

16import Data.IORef

17+import Data.Maybe (fromJust)

13import qualified Data.Vault.Lazy as Vault

18import qualified Data.Vault.Lazy as Vault

14import Network.HPACK

19import Network.HPACK

15import Network.HPACK.Token

20import Network.HPACK.Token

16import qualified Network.HTTP.Types as H

21import qualified Network.HTTP.Types as H

17import Network.Socket (SockAddr)

22import Network.Socket (SockAddr)

18import Network.Wai

23import 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

24import Network.Wai.Handler.Warp.HTTP2.Types

24−import Network.Wai.Handler.Warp.Imports

25+import Network.Wai.Handler.Warp.HashMap (hashByteString)

25−import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey, getClientCertificateKey)

26+import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)

26import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

27import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

28+import qualified Network.Wai.Handler.Warp.Timeout as Timeout

27import Network.Wai.Handler.Warp.Types

29import Network.Wai.Handler.Warp.Types

30+import Network.Wai.Internal (Request(..))

31+import System.IO.Unsafe (unsafePerformIO)

28

32

29−type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request

33+type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)

30−

31−----------------------------------------------------------------

32

34

33−toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq

35+mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq

34−toRequest ii settings addr ht bodylen body th transport = do

36+mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do

35 ref <- newIORef Nothing

37 ref <- newIORef Nothing

36− toRequest' ii settings addr ref ht bodylen body th transport

38+ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)

37

39

38−toRequest' :: InternalInfo -> S.Settings -> SockAddr

40+mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr

39 -> IORef (Maybe HTTP2Data)

41 -> IORef (Maybe HTTP2Data)

40− -> ToReq

42+ -> MkReq

41−toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req

43+mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)

42 where

44 where

43 !req = Request {

45 !req = Request {

44 requestMethod = colonMethod

46 requestMethod = colonMethod

45− , httpVersion = H.http20

47+ , httpVersion = http2ver

46 , rawPathInfo = rawPath

48 , rawPathInfo = rawPath

47 , pathInfo = H.decodePathSegments path

49 , pathInfo = H.decodePathSegments path

48 , rawQueryString = query

50 , rawQueryString = query

49 , queryString = H.parseQuery query

51 , queryString = H.parseQuery query

50 , requestHeaders = headers

52 , requestHeaders = headers

51− , isSecure = isTransportSecure transport

53+ , isSecure = True

52 , remoteHost = addr

54 , remoteHost = addr

53 , requestBody = body

55 , requestBody = body

54 , vault = vaultValue

56 , vault = vaultValue

@@ -74,21 +76,22 @@ toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = retur

74 !mUserAgent = getHeaderValue tokenUserAgent reqvt

76 !mUserAgent = getHeaderValue tokenUserAgent reqvt

75 -- CONNECT request will have ":path" omitted, use ":authority" as unparsed

77 -- CONNECT request will have ":path" omitted, use ":authority" as unparsed

76 -- path instead so that it will have consistent behavior compare to HTTP 1.0

78 -- path instead so that it will have consistent behavior compare to HTTP 1.0

77− (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)

79+ (unparsedPath,query) = B8.break (=='?') $ fromJust (mPath <|> mAuth)

78 !path = H.extractPath unparsedPath

80 !path = H.extractPath unparsedPath

79 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

81 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

80− -- fixme: pauseTimeout. th is not available here.

82+ !h = hashByteString rawPath

83+ !ii = toInternalInfo ii1 h

84+ !th = threadHandle ii

85+ !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

81− !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)

86+ $ Vault.insert getFileInfoKey (getFileInfo ii)

82 $ Vault.insert getHTTP2DataKey (readIORef ref)

87 $ Vault.insert getHTTP2DataKey (readIORef ref)

83 $ Vault.insert setHTTP2DataKey (writeIORef ref)

88 $ Vault.insert setHTTP2DataKey (writeIORef ref)

84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

89 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

85− $ Vault.insert pauseTimeoutKey (T.pause th)

86− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

87 Vault.empty

90 Vault.empty

88

91

89getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

92getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

90getHTTP2DataKey = unsafePerformIO Vault.newKey

93getHTTP2DataKey = unsafePerformIO Vault.newKey

91−{-# NOINLINE getHTTP2DataKey #-}

94+{-# NOINLINE getHTTP2Data #-}

92

95

93-- | Getting 'HTTP2Data' through vault of the request.

96-- | Getting 'HTTP2Data' through vault of the request.

94-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.

97-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.

@@ -101,7 +104,7 @@ getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of

101

104

102setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())

105setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())

103setHTTP2DataKey = unsafePerformIO Vault.newKey

106setHTTP2DataKey = unsafePerformIO Vault.newKey

104−{-# NOINLINE setHTTP2DataKey #-}

107+{-# NOINLINE setHTTP2Data #-}

105

108

106-- | Setting 'HTTP2Data' through vault of the request.

109-- | Setting 'HTTP2Data' through vault of the request.

107-- 'Application' or 'Middleware' should use this.

110-- 'Application' or 'Middleware' should use this.

@@ -114,7 +117,7 @@ setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of

114

117

115modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

118modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

116modifyHTTP2DataKey = unsafePerformIO Vault.newKey

119modifyHTTP2DataKey = unsafePerformIO Vault.newKey

117−{-# NOINLINE modifyHTTP2DataKey #-}

120+{-# NOINLINE modifyHTTP2Data #-}

118

121

119-- | Modifying 'HTTP2Data' through vault of the request.

122-- | Modifying 'HTTP2Data' through vault of the request.

120-- 'Application' or 'Middleware' should use this.

123-- 'Application' or 'Middleware' should use this.

warp/Network/Wai/Handler/Warp/HTTP2/Response.hsdeleted−127

@@ -1,127 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE BangPatterns #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−

6−module Network.Wai.Handler.Warp.HTTP2.Response (

7− fromResponse

8− ) where

9−

10−import qualified Control.Exception as E

11−import qualified Data.ByteString.Builder as BB

12−import qualified Network.HTTP.Types as H

13−import qualified Network.HTTP2.Server as H2

14−import Network.Wai hiding (responseFile, responseBuilder, responseStream)

15−import Network.Wai.Internal (Response(..))

16−

17−import Network.Wai.Handler.Warp.File

18−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

19−import Network.Wai.Handler.Warp.HTTP2.Types

20−import Network.Wai.Handler.Warp.Header

21−import qualified Network.Wai.Handler.Warp.Response as R

22−import qualified Network.Wai.Handler.Warp.Settings as S

23−import Network.Wai.Handler.Warp.Types

24−

25−----------------------------------------------------------------

26−

27−fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response

28−fromResponse settings ii req rsp = do

29− date <- getDate ii

30− h2rsp <- case rsp of

31− ResponseFile st rsphdr path mpart -> do

32− let rsphdr' = add date svr rsphdr

33− responseFile st rsphdr' isHead path mpart ii reqhdr

34− ResponseBuilder st rsphdr builder -> do

35− let rsphdr' = add date svr rsphdr

36− return $ responseBuilder st rsphdr' isHead builder

37− ResponseStream st rsphdr strmbdy -> do

38− let rsphdr' = add date svr rsphdr

39− return $ responseStream st rsphdr' isHead strmbdy

40− _ -> error "ResponseRaw is not supported in HTTP/2"

41− mh2data <- getHTTP2Data req

42− case mh2data of

43− Nothing -> return h2rsp

44− Just h2data -> do

45− let !trailers = http2dataTrailers h2data

46− return $ H2.setResponseTrailersMaker h2rsp trailers

47− where

48− !isHead = requestMethod req == H.methodHead

49− !reqhdr = requestHeaders req

50− !svr = S.settingsServerName settings

51− add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr

52− -- fixme: not adding svr if already exists

53−

54−----------------------------------------------------------------

55−

56−responseFile :: H.Status -> H.ResponseHeaders -> Bool

57− -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders

58− -> IO H2.Response

59−responseFile st rsphdr _ _ _ _ _

60− | noBody st = return $ responseNoBody st rsphdr

61−

62−responseFile st rsphdr isHead path (Just fp) _ _ =

63− return $ responseFile2XX st rsphdr isHead fileSpec

64− where

65− !off' = fromIntegral $ filePartOffset fp

66− !bytes' = fromIntegral $ filePartByteCount fp

67− !fileSpec = H2.FileSpec path off' bytes'

68−

69−responseFile _ rsphdr isHead path Nothing ii reqhdr = do

70− efinfo <- E.try $ getFileInfo ii path

71− case efinfo of

72− Left (_ex :: E.IOException) -> return $ response404 rsphdr

73− Right finfo -> do

74− let reqidx = indexRequestHeader reqhdr

75− rspidx = indexResponseHeader rsphdr

76− case conditionalRequest finfo rsphdr rspidx reqidx of

77− WithoutBody s -> return $ responseNoBody s rsphdr

78− WithBody s rsphdr' off bytes -> do

79− let !off' = fromIntegral off

80− !bytes' = fromIntegral bytes

81− !fileSpec = H2.FileSpec path off' bytes'

82− return $ responseFile2XX s rsphdr' isHead fileSpec

83−

84−----------------------------------------------------------------

85−

86−responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response

87−responseFile2XX st rsphdr isHead fileSpec

88− | isHead = responseNoBody st rsphdr

89− | otherwise = H2.responseFile st rsphdr fileSpec

90−

91−----------------------------------------------------------------

92−

93−responseBuilder :: H.Status -> H.ResponseHeaders -> Bool

94− -> BB.Builder

95− -> H2.Response

96−responseBuilder st rsphdr isHead builder

97− | noBody st = responseNoBody st rsphdr

98− | isHead = responseNoBody st rsphdr

99− | otherwise = H2.responseBuilder st rsphdr builder

100−

101−----------------------------------------------------------------

102−

103−responseStream :: H.Status -> H.ResponseHeaders -> Bool

104− -> StreamingBody

105− -> H2.Response

106−responseStream st rsphdr isHead strmbdy

107− | noBody st = responseNoBody st rsphdr

108− | isHead = responseNoBody st rsphdr

109− | otherwise = H2.responseStreaming st rsphdr strmbdy

110−

111−----------------------------------------------------------------

112−

113−responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response

114−responseNoBody st rsphdr = H2.responseNoBody st rsphdr

115−

116−----------------------------------------------------------------

117−

118−response404 :: H.ResponseHeaders -> H2.Response

119−response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body

120− where

121− !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr

122− !body = BB.byteString "File not found"

123−

124−----------------------------------------------------------------

125−

126−noBody :: H.Status -> Bool

127−noBody = not . R.hasBody

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hsnew file+538

@@ -0,0 +1,538 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE BangPatterns, CPP #-}

3+{-# LANGUAGE NamedFieldPuns #-}

4+

5+module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where

6+

7+import Control.Concurrent.STM

8+import qualified Control.Exception as E

9+import Control.Monad (void, when)

10+import Data.Bits

11+import qualified Data.ByteString as BS

12+import Data.ByteString.Builder (Builder)

13+import qualified Data.ByteString.Builder.Extra as B

14+import Data.IORef

15+import Data.Maybe (isNothing)

16+import Data.Word (Word8, Word32)

17+import Foreign.Ptr (Ptr, plusPtr)

18+import Foreign.Storable (poke)

19+import Network.HPACK (setLimitForEncoding, toHeaderTable)

20+import Network.HTTP2

21+import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)

22+import Network.Wai

23+import Network.Wai.Handler.Warp.Buffer

24+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

25+import Network.Wai.Handler.Warp.HTTP2.HPACK

26+import Network.Wai.Handler.Warp.HTTP2.Manager (Manager)

27+import Network.Wai.Handler.Warp.HTTP2.Types

28+import qualified Network.Wai.Handler.Warp.Settings as S

29+import Network.Wai.Handler.Warp.Types

30+

31+#ifdef WINDOWS

32+import qualified System.IO as IO

33+#else

34+import Network.Wai.Handler.Warp.FdCache

35+import Network.Wai.Handler.Warp.SendFile (positionRead)

36+import qualified Network.Wai.Handler.Warp.Timeout as T

37+#endif

38+

39+----------------------------------------------------------------

40+

41+data Leftover = LZero

42+ | LOne B.BufferWriter

43+ | LTwo BS.ByteString B.BufferWriter

44+

45+----------------------------------------------------------------

46+

47+{-# INLINE getStreamWindowSize #-}

48+getStreamWindowSize :: Stream -> IO WindowSize

49+getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow

50+

51+{-# INLINE waitStreamWindowSize #-}

52+waitStreamWindowSize :: Stream -> IO ()

53+waitStreamWindowSize Stream{streamWindow} = atomically $ do

54+ w <- readTVar streamWindow

55+ check (w > 0)

56+

57+{-# INLINE waitStreaming #-}

58+waitStreaming :: TBQueue a -> IO ()

59+waitStreaming tbq = atomically $ do

60+ isEmpty <- isEmptyTBQueue tbq

61+ check (isEmpty == False)

62+

63+data Switch = C Control

64+ | O (StreamId,Precedence,Output)

65+ | Flush

66+

67+frameSender :: Context -> Connection -> S.Settings -> Manager -> IO ()

68+frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}

69+ conn@Connection{connWriteBuffer,connBufferSize,connSendAll}

70+ settings mgr = loop 0 `E.catch` ignore

71+ where

72+ dequeue off = do

73+ isEmpty <- isEmptyTQueue controlQ

74+ if isEmpty then do

75+ w <- readTVar connectionWindow

76+ check (w > 0)

77+ emp <- isEmptySTM outputQ

78+ if emp then

79+ if off /= 0 then return Flush else retry

80+ else

81+ O <$> dequeueSTM outputQ

82+ else

83+ C <$> readTQueue controlQ

84+

85+ loop off = do

86+ x <- atomically $ dequeue off

87+ case x of

88+ C ctl -> do

89+ when (off /= 0) $ flushN off

90+ off' <- control ctl off

91+ when (off' >= 0) $ loop off'

92+ O (_,pre,out) -> do

93+ let strm = outputStream out

94+ writeIORef (streamPrecedence strm) pre

95+ off' <- outputOrEnqueueAgain out off

96+ case off' of

97+ 0 -> loop 0

98+ _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding

99+ | otherwise -> loop off'

100+ Flush -> flushN off >> loop 0

101+

102+ control CFinish _ = return (-1)

103+ control (CGoaway frame) _ = connSendAll frame >> return (-1)

104+ control (CFrame frame) _ = connSendAll frame >> return 0

105+ control (CSettings frame alist) _ = do

106+ connSendAll frame

107+ setLimit alist

108+ return 0

109+ control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case

110+ let !buf = connWriteBuffer `plusPtr` off

111+ !off' = off + BS.length frame1 + BS.length frame2

112+ buf' <- copy buf frame1

113+ void $ copy buf' frame2

114+ setLimit alist

115+ return off'

116+

117+ {-# INLINE setLimit #-}

118+ setLimit alist = case lookup SettingsHeaderTableSize alist of

119+ Nothing -> return ()

120+ Just siz -> setLimitForEncoding siz encodeDynamicTable

121+

122+ output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do

123+ -- Data frame payload

124+ let !buf = connWriteBuffer `plusPtr` off0

125+ !siz = connBufferSize - off0

126+ Next datPayloadLen mnext <- curr buf siz lim

127+ off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D

128+ maybeEnqueueNext out mnext

129+ return off

130+

131+ output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do

132+ -- Header frame and Continuation frame

133+ let !sid = streamNumber strm

134+ !endOfStream = case rspn of

135+ RspnNobody _ _ -> True

136+ _ -> False

137+ ths <- addNecessaryHeaders ctx rspn ii settings

138+ kvlen <- headerContinue sid ths endOfStream off0

139+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

140+ case rspn of

141+ RspnNobody _ _ -> do

142+ closed ctx strm Finished

143+ return off

144+ RspnFile _ _ path mpart -> do

145+ -- Data frame payload

146+ let payloadOff = off + frameHeaderLength

147+ Next datPayloadLen mnext <-

148+ fillFileBodyGetNext conn ii payloadOff lim path mpart

149+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

150+ maybeEnqueueNext out mnext

151+ return off'

152+ RspnBuilder _ _ builder -> do

153+ -- Data frame payload

154+ let payloadOff = off + frameHeaderLength

155+ Next datPayloadLen mnext <-

156+ fillBuilderBodyGetNext conn ii payloadOff lim builder

157+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

158+ maybeEnqueueNext out mnext

159+ return off'

160+ RspnStreaming _ _ tbq -> do

161+ let payloadOff = off + frameHeaderLength

162+ Next datPayloadLen mnext <-

163+ fillStreamBodyGetNext conn payloadOff lim tbq strm

164+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D

165+ maybeEnqueueNext out mnext

166+ return off'

167+

168+ output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do

169+ -- Creating a push promise header

170+ -- Frame id should be associated stream id from the client.

171+ let !sid = streamNumber strm

172+ len <- pushPromise pid sid ths off0

173+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len

174+ output out{ outputType = ORspn } off lim

175+

176+ output _ _ _ = undefined -- never reach

177+

178+ outputOrEnqueueAgain out off = E.handle resetStream $ do

179+ state <- readIORef $ streamState strm

180+ if isClosed state then

181+ return off

182+ else case out of

183+ Output _ _ _ wait _ OWait -> do

184+ -- Checking if all push are done.

185+ let out' = out {

186+ outputHook = return ()

187+ , outputType = ORspn

188+ }

189+ forkAndEnqueueWhenReady wait outputQ out' mgr

190+ return off

191+ _ -> case mtbq of

192+ Just tbq -> checkStreaming tbq

193+ _ -> checkStreamWindowSize

194+ where

195+ strm = outputStream out

196+ mtbq = outputMaybeTBQueue out

197+ checkStreaming tbq = do

198+ isEmpty <- atomically $ isEmptyTBQueue tbq

199+ if isEmpty then do

200+ forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr

201+ return off

202+ else

203+ checkStreamWindowSize

204+ checkStreamWindowSize = do

205+ sws <- getStreamWindowSize strm

206+ if sws == 0 then do

207+ forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr

208+ return off

209+ else do

210+ cws <- atomically $ readTVar connectionWindow -- not 0

211+ let !lim = min cws sws

212+ output out off lim

213+ resetStream e = do

214+ closed ctx strm (ResetByMe e)

215+ let !rst = resetFrame InternalError $ streamNumber strm

216+ enqueueControl controlQ $ CFrame rst

217+ return off

218+

219+ {-# INLINE flushN #-}

220+ -- Flush the connection buffer to the socket, where the first 'n' bytes of

221+ -- the buffer are filled.

222+ flushN :: Int -> IO ()

223+ flushN n = bufferIO connWriteBuffer n connSendAll

224+

225+ headerContinue sid ths endOfStream off = do

226+ let !offkv = off + frameHeaderLength

227+ let !bufkv = connWriteBuffer `plusPtr` offkv

228+ !limkv = connBufferSize - offkv

229+ (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths

230+ let flag0 = case hs of

231+ [] -> setEndHeader defaultFlags

232+ _ -> defaultFlags

233+ flag = if endOfStream then setEndStream flag0 else flag0

234+ let buf = connWriteBuffer `plusPtr` off

235+ fillFrameHeader FrameHeaders kvlen sid flag buf

236+ continue sid kvlen hs

237+

238+ !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength

239+ !headerPayloadLim = connBufferSize - frameHeaderLength

240+

241+ continue _ kvlen [] = return kvlen

242+ continue sid kvlen ths = do

243+ flushN $ kvlen + frameHeaderLength

244+ -- Now off is 0

245+ (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths

246+ when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"

247+ let flag = case ths' of

248+ [] -> setEndHeader defaultFlags

249+ _ -> defaultFlags

250+ fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer

251+ continue sid kvlen' ths'

252+

253+ {-# INLINE maybeEnqueueNext #-}

254+ -- Re-enqueue the stream in the output queue.

255+ maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()

256+ maybeEnqueueNext _ Nothing = return ()

257+ maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'

258+ where

259+ !out' = out { outputType = ONext next }

260+

261+ {-# INLINE sendHeadersIfNecessary #-}

262+ -- Send headers if there is not room for a 1-byte data frame, and return

263+ -- the offset of the next frame's first header byte.

264+ sendHeadersIfNecessary off

265+ -- True if the connection buffer has room for a 1-byte data frame.

266+ | off + frameHeaderLength < connBufferSize = return off

267+ | otherwise = do

268+ flushN off

269+ return 0

270+

271+ fillDataHeader strm@Stream{streamWindow,streamNumber}

272+ off datPayloadLen mnext tell getH2D = do

273+ -- Data frame header

274+ mh2d <- getH2D

275+ let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of

276+ Nothing -> ([], True)

277+ Just ts -> (ts, null ts)

278+ !buf = connWriteBuffer `plusPtr` off

279+ !off' = off + frameHeaderLength + datPayloadLen

280+ !noMoreBody = isNothing mnext

281+ flag | noMoreBody && noTrailers = setEndStream defaultFlags

282+ | otherwise = defaultFlags

283+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf

284+ off'' <- handleEndOfBody noMoreBody off' noTrailers trailers

285+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)

286+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)

287+ return off''

288+ where

289+ handleTrailers True off0 _ = return off0

290+ handleTrailers _ off0 trailers = do

291+ (ths,_) <- toHeaderTable trailers

292+ kvlen <- headerContinue streamNumber ths True off0

293+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen

294+ handleEndOfBody True off0 noTrailers trailers = do

295+ off1 <- handleTrailers noTrailers off0 trailers

296+ void $ tell

297+ closed ctx strm Finished

298+ return off1

299+ handleEndOfBody False off0 _ _ = return off0

300+

301+

302+ pushPromise pid sid ths off = do

303+ let !offsid = off + frameHeaderLength

304+ !bufsid = connWriteBuffer `plusPtr` offsid

305+ poke32 bufsid $ fromIntegral sid

306+ let !offkv = offsid + 4

307+ !bufkv = connWriteBuffer `plusPtr` offkv

308+ !limkv = connBufferSize - offkv

309+ (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths

310+ let !flag = setEndHeader defaultFlags -- No EndStream flag

311+ !buf = connWriteBuffer `plusPtr` off

312+ !len = kvlen + 4

313+ fillFrameHeader FramePushPromise len pid flag buf

314+ return len

315+

316+ {-# INLINE fillFrameHeader #-}

317+ fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf

318+ where

319+ hinfo = FrameHeader len flag sid

320+

321+ {-# INLINE ignore #-}

322+ ignore :: E.SomeException -> IO ()

323+ ignore _ = return ()

324+

325+----------------------------------------------------------------

326+

327+{-

328+ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)

329+ResponseBuilder Status ResponseHeaders Builder

330+ResponseStream Status ResponseHeaders StreamingBody

331+ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response

332+-}

333+

334+fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next

335+fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}

336+ _ off lim bb = do

337+ let datBuf = connWriteBuffer `plusPtr` off

338+ room = min (connBufferSize - off) lim

339+ (len, signal) <- B.runBuilder bb datBuf room

340+ return $ nextForBuilder len signal

341+

342+fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next

343+#ifdef WINDOWS

344+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

345+ _ off lim path mpart = do

346+ let datBuf = connWriteBuffer `plusPtr` off

347+ room = min (connBufferSize - off) lim

348+ (start, bytes) <- fileStartEnd path mpart

349+ -- fixme: how to close Handle? GC does it at this moment.

350+ hdl <- IO.openBinaryFile path IO.ReadMode

351+ IO.hSeek hdl IO.AbsoluteSeek start

352+ len <- IO.hGetBufSome hdl datBuf (mini room bytes)

353+ let bytes' = bytes - fromIntegral len

354+ -- fixme: connWriteBuffer connBufferSize

355+ return $ nextForFile len hdl bytes' (return ())

356+#else

357+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}

358+ ii off lim path mpart = do

359+ (mfd, refresh') <- getFd ii path

360+ (fd, refresh) <- case mfd of

361+ Nothing -> do

362+ fd' <- openFile path

363+ th <- T.register (timeoutManager ii) (closeFile fd')

364+ return (fd', T.tickle th)

365+ Just fd -> return (fd, refresh')

366+ let datBuf = connWriteBuffer `plusPtr` off

367+ room = min (connBufferSize - off) lim

368+ (start, bytes) <- fileStartEnd path mpart

369+ len <- positionRead fd datBuf (mini room bytes) start

370+ refresh

371+ let len' = fromIntegral len

372+ return $ nextForFile len fd (start + len') (bytes - len') refresh

373+#endif

374+

375+fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)

376+fileStartEnd _ (Just part) =

377+ return (filePartOffset part, filePartByteCount part)

378+fileStartEnd _ _ = error "fileStartEnd"

379+

380+----------------------------------------------------------------

381+

382+fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next

383+fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

384+ off lim sq strm = do

385+ let datBuf = connWriteBuffer `plusPtr` off

386+ room = min (connBufferSize - off) lim

387+ (leftover, cont, len) <- runStreamBuilder datBuf room sq

388+ return $ nextForStream sq strm leftover cont len

389+

390+----------------------------------------------------------------

391+

392+fillBufBuilder :: Leftover -> DynaNext

393+fillBufBuilder leftover buf0 siz0 lim = do

394+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

395+ room = min (siz0 - frameHeaderLength) lim

396+ case leftover of

397+ LZero -> error "fillBufBuilder: LZero"

398+ LOne writer -> do

399+ (len, signal) <- writer payloadBuf room

400+ getNext len signal

401+ LTwo bs writer

402+ | BS.length bs <= room -> do

403+ buf1 <- copy payloadBuf bs

404+ let len1 = BS.length bs

405+ (len2, signal) <- writer buf1 (room - len1)

406+ getNext (len1 + len2) signal

407+ | otherwise -> do

408+ let (bs1,bs2) = BS.splitAt room bs

409+ void $ copy payloadBuf bs1

410+ getNext room (B.Chunk bs2 writer)

411+ where

412+ getNext l s = return $ nextForBuilder l s

413+

414+nextForBuilder :: BytesFilled -> B.Next -> Next

415+nextForBuilder len B.Done

416+ = Next len Nothing

417+nextForBuilder len (B.More _ writer)

418+ = Next len $ Just (fillBufBuilder (LOne writer))

419+nextForBuilder len (B.Chunk bs writer)

420+ = Next len $ Just (fillBufBuilder (LTwo bs writer))

421+

422+----------------------------------------------------------------

423+

424+runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence

425+ -> IO (Leftover, Bool, BytesFilled)

426+runStreamBuilder buf0 room0 sq = loop buf0 room0 0

427+ where

428+ loop !buf !room !total = do

429+ mbuilder <- atomically $ tryReadTBQueue sq

430+ case mbuilder of

431+ Nothing -> return (LZero, True, total)

432+ Just (SBuilder builder) -> do

433+ (len, signal) <- B.runBuilder builder buf room

434+ let !total' = total + len

435+ case signal of

436+ B.Done -> loop (buf `plusPtr` len) (room - len) total'

437+ B.More _ writer -> return (LOne writer, True, total')

438+ B.Chunk bs writer -> return (LTwo bs writer, True, total')

439+ Just SFlush -> return (LZero, True, total)

440+ Just SFinish -> return (LZero, False, total)

441+

442+fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext

443+fillBufStream leftover0 sq strm buf0 siz0 lim0 = do

444+ let payloadBuf = buf0 `plusPtr` frameHeaderLength

445+ room0 = min (siz0 - frameHeaderLength) lim0

446+ case leftover0 of

447+ LZero -> do

448+ (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq

449+ getNext leftover cont len

450+ LOne writer -> write writer payloadBuf room0 0

451+ LTwo bs writer

452+ | BS.length bs <= room0 -> do

453+ buf1 <- copy payloadBuf bs

454+ let len = BS.length bs

455+ write writer buf1 (room0 - len) len

456+ | otherwise -> do

457+ let (bs1,bs2) = BS.splitAt room0 bs

458+ void $ copy payloadBuf bs1

459+ getNext (LTwo bs2 writer) True room0

460+ where

461+ getNext l b r = return $ nextForStream sq strm l b r

462+ write writer1 buf room sofar = do

463+ (len, signal) <- writer1 buf room

464+ case signal of

465+ B.Done -> do

466+ (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq

467+ let !total = sofar + len + extra

468+ getNext leftover cont total

469+ B.More _ writer -> do

470+ let !total = sofar + len

471+ getNext (LOne writer) True total

472+ B.Chunk bs writer -> do

473+ let !total = sofar + len

474+ getNext (LTwo bs writer) True total

475+

476+nextForStream :: TBQueue Sequence -> Stream

477+ -> Leftover -> Bool -> BytesFilled

478+ -> Next

479+nextForStream _ _ _ False len = Next len Nothing

480+nextForStream sq strm leftOrZero True len =

481+ Next len $ Just (fillBufStream leftOrZero sq strm)

482+

483+----------------------------------------------------------------

484+

485+#ifdef WINDOWS

486+fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext

487+fillBufFile h bytes refresh buf siz lim = do

488+ let payloadBuf = buf `plusPtr` frameHeaderLength

489+ room = min (siz - frameHeaderLength) lim

490+ len <- IO.hGetBufSome h payloadBuf room

491+ refresh

492+ let bytes' = bytes - fromIntegral len

493+ return $ nextForFile len h bytes' refresh

494+

495+nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next

496+nextForFile 0 _ _ _ = Next 0 Nothing

497+nextForFile len _ 0 _ = Next len Nothing

498+nextForFile len h bytes refresh =

499+ Next len $ Just (fillBufFile h bytes refresh)

500+#else

501+fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext

502+fillBufFile fd start bytes refresh buf siz lim = do

503+ let payloadBuf = buf `plusPtr` frameHeaderLength

504+ room = min (siz - frameHeaderLength) lim

505+ len <- positionRead fd payloadBuf (mini room bytes) start

506+ let len' = fromIntegral len

507+ refresh

508+ return $ nextForFile len fd (start + len') (bytes - len') refresh

509+

510+nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next

511+nextForFile 0 _ _ _ _ = Next 0 Nothing

512+nextForFile len _ _ 0 _ = Next len Nothing

513+nextForFile len fd start bytes refresh =

514+ Next len $ Just (fillBufFile fd start bytes refresh)

515+#endif

516+

517+{-# INLINE mini #-}

518+mini :: Int -> Integer -> Int

519+mini i n

520+ | fromIntegral i < n = i

521+ | otherwise = fromIntegral n

522+

523+

524+----------------------------------------------------------------

525+

526+poke32 :: Ptr Word8 -> Word32 -> IO ()

527+poke32 ptr i = do

528+ poke ptr w0

529+ poke8 ptr 1 w1

530+ poke8 ptr 2 w2

531+ poke8 ptr 3 w3

532+ where

533+ w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)

534+ w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)

535+ w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)

536+ w3 = fromIntegral (i .&. 0xff)

537+ poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()

538+ poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+269−16

@@ -1,26 +1,283 @@

1−{-# LANGUAGE NamedFieldPuns #-}

1+{-# LANGUAGE OverloadedStrings, CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

3+{-# LANGUAGE BangPatterns #-}

4

5module Network.Wai.Handler.Warp.HTTP2.Types where

6

7+import Control.Concurrent (forkIO)

8+import Control.Concurrent.STM

9+import Control.Exception (SomeException, bracket)

10+import Control.Monad (void, forM_)

11+import Data.ByteString (ByteString)

7import qualified Data.ByteString as BS

12import qualified Data.ByteString as BS

13+import Data.ByteString.Builder (Builder)

14+import Data.IORef

15+import Data.IntMap.Strict (IntMap, IntMap)

16+import qualified Data.IntMap.Strict as M

8import qualified Network.HTTP.Types as H

17import qualified Network.HTTP.Types as H

9−import Network.HTTP2

18+import Network.Wai (Request, FilePart)

10−import qualified Network.HTTP2.Server as H2

11−

12−import Network.Wai.Handler.Warp.Imports

19+import Network.Wai.Handler.Warp.HTTP2.Manager

13import Network.Wai.Handler.Warp.Types

20import Network.Wai.Handler.Warp.Types

14

21

22+import Network.HTTP2

23+import Network.HTTP2.Priority

24+import Network.HPACK hiding (Buffer)

25+

15----------------------------------------------------------------

26----------------------------------------------------------------

16

27

28+http2ver :: H.HttpVersion

29+http2ver = H.HttpVersion 2 0

30+

17isHTTP2 :: Transport -> Bool

31isHTTP2 :: Transport -> Bool

18isHTTP2 TCP = False

32isHTTP2 TCP = False

19isHTTP2 tls = useHTTP2

33isHTTP2 tls = useHTTP2

20 where

34 where

21 useHTTP2 = case tlsNegotiatedProtocol tls of

35 useHTTP2 = case tlsNegotiatedProtocol tls of

22 Nothing -> False

36 Nothing -> False

23− Just proto -> "h2" `BS.isPrefixOf` proto

37+ Just proto -> "h2-" `BS.isPrefixOf` proto

38+

39+----------------------------------------------------------------

40+

41+data Input = Input Stream Request ValueTable InternalInfo

42+

43+----------------------------------------------------------------

44+

45+type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next

46+

47+type BytesFilled = Int

48+

49+data Next = Next !BytesFilled (Maybe DynaNext)

50+

51+data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)

52+ | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)

53+ | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder

54+ | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)

55+

56+rspnStatus :: Rspn -> H.Status

57+rspnStatus (RspnNobody s _) = s

58+rspnStatus (RspnStreaming s _ _) = s

59+rspnStatus (RspnBuilder s _ _) = s

60+rspnStatus (RspnFile s _ _ _ ) = s

61+

62+rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)

63+rspnHeaders (RspnNobody _ t) = t

64+rspnHeaders (RspnStreaming _ t _) = t

65+rspnHeaders (RspnBuilder _ t _) = t

66+rspnHeaders (RspnFile _ t _ _ ) = t

67+

68+data Output = Output {

69+ outputStream :: !Stream

70+ , outputRspn :: !Rspn

71+ , outputII :: !InternalInfo

72+ , outputHook :: IO () -- OPush: wait for done, O*: telling done

73+ , outputH2Data :: IO (Maybe HTTP2Data)

74+ , outputType :: !OutputType

75+ }

76+

77+data OutputType = ORspn

78+ | OWait

79+ | OPush !TokenHeaderList !StreamId -- associated stream id from client

80+ | ONext !DynaNext

81+

82+outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)

83+outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq

84+outputMaybeTBQueue _ = Nothing

85+

86+data Control = CFinish

87+ | CGoaway !ByteString

88+ | CFrame !ByteString

89+ | CSettings !ByteString !SettingsList

90+ | CSettings0 !ByteString !ByteString !SettingsList

91+

92+----------------------------------------------------------------

93+

94+data Sequence = SFinish

95+ | SFlush

96+ | SBuilder Builder

97+

98+----------------------------------------------------------------

99+

100+-- | The context for HTTP/2 connection.

101+data Context = Context {

102+ -- HTTP/2 settings received from a browser

103+ http2settings :: !(IORef Settings)

104+ , firstSettings :: !(IORef Bool)

105+ , streamTable :: !StreamTable

106+ , concurrency :: !(IORef Int)

107+ , priorityTreeSize :: !(IORef Int)

108+ -- | RFC 7540 says "Other frames (from any stream) MUST NOT

109+ -- occur between the HEADERS frame and any CONTINUATION

110+ -- frames that might follow". This field is used to implement

111+ -- this requirement.

112+ , continued :: !(IORef (Maybe StreamId))

113+ , clientStreamId :: !(IORef StreamId)

114+ , serverStreamId :: !(IORef StreamId)

115+ , inputQ :: !(TQueue Input)

116+ , outputQ :: !(PriorityTree Output)

117+ , controlQ :: !(TQueue Control)

118+ , encodeDynamicTable :: !DynamicTable

119+ , decodeDynamicTable :: !DynamicTable

120+ -- the connection window for data from a server to a browser.

121+ , connectionWindow :: !(TVar WindowSize)

122+ }

123+

124+----------------------------------------------------------------

125+

126+newContext :: IO Context

127+newContext = Context <$> newIORef defaultSettings

128+ <*> newIORef False

129+ <*> newStreamTable

130+ <*> newIORef 0

131+ <*> newIORef 0

132+ <*> newIORef Nothing

133+ <*> newIORef 0

134+ <*> newIORef 0

135+ <*> newTQueueIO

136+ <*> newPriorityTree

137+ <*> newTQueueIO

138+ <*> newDynamicTableForEncoding defaultDynamicTableSize

139+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096

140+ <*> newTVarIO defaultInitialWindowSize

141+

142+clearContext :: Context -> IO ()

143+clearContext _ctx = return ()

144+

145+----------------------------------------------------------------

146+

147+data OpenState =

148+ JustOpened

149+ | Continued [HeaderBlockFragment]

150+ !Int -- Total size

151+ !Int -- The number of continuation frames

152+ !Bool -- End of stream

153+ !Priority

154+ | NoBody (TokenHeaderList,ValueTable) !Priority

155+ | HasBody (TokenHeaderList,ValueTable) !Priority

156+ | Body !(TQueue ByteString)

157+ !(Maybe Int) -- received Content-Length

158+ -- compared the body length for error checking

159+ !(IORef Int) -- actual body length

160+

161+data ClosedCode = Finished

162+ | Killed

163+ | Reset !ErrorCodeId

164+ | ResetByMe SomeException

165+ deriving Show

166+

167+data StreamState =

168+ Idle

169+ | Open !OpenState

170+ | HalfClosed

171+ | Closed !ClosedCode

172+ | Reserved

173+

174+isIdle :: StreamState -> Bool

175+isIdle Idle = True

176+isIdle _ = False

177+

178+isOpen :: StreamState -> Bool

179+isOpen Open{} = True

180+isOpen _ = False

181+

182+isHalfClosed :: StreamState -> Bool

183+isHalfClosed HalfClosed = True

184+isHalfClosed _ = False

185+

186+isClosed :: StreamState -> Bool

187+isClosed Closed{} = True

188+isClosed _ = False

189+

190+instance Show StreamState where

191+ show Idle = "Idle"

192+ show Open{} = "Open"

193+ show HalfClosed = "HalfClosed"

194+ show (Closed e) = "Closed: " ++ show e

195+ show Reserved = "Reserved"

196+

197+----------------------------------------------------------------

198+

199+data Stream = Stream {

200+ streamNumber :: !StreamId

201+ , streamState :: !(IORef StreamState)

202+ , streamWindow :: !(TVar WindowSize)

203+ , streamPrecedence :: !(IORef Precedence)

204+ }

205+

206+instance Show Stream where

207+ show s = show (streamNumber s)

208+

209+newStream :: StreamId -> WindowSize -> IO Stream

210+newStream sid win = Stream sid <$> newIORef Idle

211+ <*> newTVarIO win

212+ <*> newIORef defaultPrecedence

213+

214+newPushStream :: Context -> WindowSize -> Precedence -> IO Stream

215+newPushStream Context{serverStreamId} win pre = do

216+ sid <- atomicModifyIORef' serverStreamId inc2

217+ Stream sid <$> newIORef Reserved

218+ <*> newTVarIO win

219+ <*> newIORef pre

220+ where

221+ inc2 x = let !x' = x + 2 in (x', x')

222+

223+----------------------------------------------------------------

224+

225+opened :: Context -> Stream -> IO ()

226+opened Context{concurrency} Stream{streamState} = do

227+ atomicModifyIORef' concurrency (\x -> (x+1,()))

228+ writeIORef streamState (Open JustOpened)

229+

230+closed :: Context -> Stream -> ClosedCode -> IO ()

231+closed Context{concurrency,streamTable} Stream{streamState,streamNumber} cc = do

232+ remove streamTable streamNumber

233+ atomicModifyIORef' concurrency (\x -> (x-1,()))

234+ writeIORef streamState (Closed cc) -- anyway

235+

236+----------------------------------------------------------------

237+

238+newtype StreamTable = StreamTable (IORef (IntMap Stream))

239+

240+newStreamTable :: IO StreamTable

241+newStreamTable = StreamTable <$> newIORef M.empty

242+

243+insert :: StreamTable -> M.Key -> Stream -> IO ()

244+insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->

245+ let !m' = M.insert k v m

246+ in (m', ())

247+

248+remove :: StreamTable -> M.Key -> IO ()

249+remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->

250+ let !m' = M.delete k m

251+ in (m', ())

252+

253+search :: StreamTable -> M.Key -> IO (Maybe Stream)

254+search (StreamTable ref) k = M.lookup k <$> readIORef ref

255+

256+updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()

257+updateAllStreamWindow adst (StreamTable ref) = do

258+ strms <- M.elems <$> readIORef ref

259+ forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst

260+

261+{-# INLINE forkAndEnqueueWhenReady #-}

262+forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()

263+forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->

264+ void . forkIO $ do

265+ wait

266+ enqueueOutput outQ out

267+ where

268+ setup = addMyId mgr

269+ teardown _ = deleteMyId mgr

270+

271+{-# INLINE enqueueOutput #-}

272+enqueueOutput :: PriorityTree Output -> Output -> IO ()

273+enqueueOutput outQ out = do

274+ let Stream{..} = outputStream out

275+ pre <- readIORef streamPrecedence

276+ enqueue outQ streamNumber pre out

277+

278+{-# INLINE enqueueControl #-}

279+enqueueControl :: TQueue Control -> Control -> IO ()

280+enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl

24

281

25----------------------------------------------------------------

282----------------------------------------------------------------

26

283

@@ -32,21 +289,17 @@ data HTTP2Data = HTTP2Data {

32 --

289 --

33 -- Since: 3.2.7

290 -- Since: 3.2.7

34 http2dataPushPromise :: [PushPromise]

291 http2dataPushPromise :: [PushPromise]

35− -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.

36− --

37− -- Since: 3.2.8 but the type changed in 3.3.0

292+ -- Since: 3.2.8

38− , http2dataTrailers :: H2.TrailersMaker

293+ , http2dataTrailers :: H.ResponseHeaders

39− }

294+ } deriving (Eq,Show)

40

295

41-- | Default HTTP/2 specific data.

296-- | Default HTTP/2 specific data.

42--

297--

43-- Since: 3.2.7

298-- Since: 3.2.7

44defaultHTTP2Data :: HTTP2Data

299defaultHTTP2Data :: HTTP2Data

45−defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

300+defaultHTTP2Data = HTTP2Data [] []

46

301

47-- | HTTP/2 push promise or sever push.

302-- | HTTP/2 push promise or sever push.

48−-- This allows files only for backward-compatibility

49−-- while the HTTP/2 library supports other types.

50--

303--

51-- Since: 3.2.7

304-- Since: 3.2.7

52data PushPromise = PushPromise {

305data PushPromise = PushPromise {

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hsnew file+316

@@ -0,0 +1,316 @@

1+{-# LANGUAGE NamedFieldPuns #-}

2+{-# LANGUAGE PatternGuards #-}

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE BangPatterns #-}

7+

8+module Network.Wai.Handler.Warp.HTTP2.Worker (

9+ Responder

10+ , response

11+ , worker

12+ ) where

13+

14+import Control.Applicative ((<|>))

15+import Control.Concurrent.STM

16+import Control.Exception (SomeException(..), AsyncException(..))

17+import qualified Control.Exception as E

18+import Control.Monad (when)

19+import Data.ByteString.Builder (byteString)

20+import Data.IORef

21+import Data.Maybe (fromJust)

22+import Network.HPACK

23+import Network.HPACK.Token

24+import qualified Network.HTTP.Types as H

25+import Network.HTTP2

26+import Network.HTTP2.Priority

27+import Network.Wai

28+import Network.Wai.Handler.Warp.FileInfoCache

29+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

30+import Network.Wai.Handler.Warp.HTTP2.File

31+import Network.Wai.Handler.Warp.HTTP2.Manager

32+import Network.Wai.Handler.Warp.HTTP2.Request

33+import Network.Wai.Handler.Warp.HTTP2.Types

34+import qualified Network.Wai.Handler.Warp.Response as R

35+import qualified Network.Wai.Handler.Warp.Settings as S

36+import qualified Network.Wai.Handler.Warp.Timeout as T

37+import Network.Wai.Handler.Warp.Types

38+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))

39+

40+----------------------------------------------------------------

41+

42+-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.

43+-- This type implements the second argument (Response -> IO ResponseReceived)

44+-- with extra arguments.

45+type Responder = InternalInfo

46+ -> ValueTable -- for Request

47+ -> ThreadContinue

48+ -> Stream

49+ -> Request

50+ -> Response

51+ -> IO ResponseReceived

52+

53+pushStream :: Context -> S.Settings

54+ -> StreamId -> ValueTable -> Request -> InternalInfo

55+ -> Maybe HTTP2Data

56+ -> IO (OutputType, IO ())

57+pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())

58+pushStream ctx@Context{http2settings,outputQ,streamTable}

59+ settings pid reqvt req ii (Just h2d)

60+ | len == 0 = return (ORspn, return ())

61+ | otherwise = do

62+ pushable <- enablePush <$> readIORef http2settings

63+ if pushable then do

64+ tvar <- newTVarIO 0

65+ lim <- push tvar pps0 0

66+ if lim == 0 then

67+ return (ORspn, return ())

68+ else

69+ return (OWait, waiter lim tvar)

70+ else

71+ return (ORspn, return ())

72+ where

73+ !pps0 = http2dataPushPromise h2d

74+ !len = length pps0

75+ !pushLogger = S.settingsServerPushLogger settings

76+ increment tvar = atomically $ modifyTVar' tvar (+1)

77+ waiter lim tvar = atomically $ do

78+ n <- readTVar tvar

79+ check (n >= lim)

80+ !h2data = getHTTP2Data req

81+ push _ [] !n = return (n :: Int)

82+ push tvar (pp:pps) !n = do

83+ let !file = promisedFile pp

84+ efinfo <- E.try $ getFileInfo ii file

85+ case efinfo of

86+ Left (_ex :: E.IOException) -> push tvar pps n

87+ Right (FileInfo _ size _ date) -> do

88+ ws <- initialWindowSize <$> readIORef http2settings

89+ let !w = promisedWeight pp

90+ !pri = defaultPriority { weight = w }

91+ !pre = toPrecedence pri

92+ strm <- newPushStream ctx ws pre

93+ let !sid = streamNumber strm

94+ insert streamTable sid strm

95+ (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)

96+ let !scheme = fromJust $ getHeaderValue tokenScheme reqvt

97+ -- fixme: this value can be Nothing

98+ !auth = fromJust (getHeaderValue tokenHost reqvt

99+ <|> getHeaderValue tokenAuthority reqvt)

100+ !path = promisedPath pp

101+ !promisedRequest = [(tokenMethod, H.methodGet)

102+ ,(tokenScheme, scheme)

103+ ,(tokenAuthority, auth)

104+ ,(tokenPath, path)]

105+ !part = FilePart 0 size size

106+ !rsp = RspnFile H.ok200 (ths,vt) file (Just part)

107+ !ths = (tokenLastModified,date) :

108+ addContentHeadersForFilePart ths0 part

109+ pushLogger req path size

110+ let !ot = OPush promisedRequest pid

111+ !out = Output strm rsp ii (increment tvar) h2data ot

112+ enqueueOutput outputQ out

113+ push tvar pps (n + 1)

114+

115+

116+-- | This function is passed to workers.

117+-- They also pass 'Response's from 'Application's to this function.

118+-- This function enqueues commands for the HTTP/2 sender.

119+response :: S.Settings -> Context -> Manager -> Responder

120+response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of

121+ ResponseStream s0 hs0 strmbdy

122+ | noBody s0 -> responseNoBody s0 hs0

123+ | isHead -> responseNoBody s0 hs0

124+ | otherwise -> getHTTP2Data req

125+ >>= pushStream ctx settings sid reqvt req ii

126+ >>= responseStreaming s0 hs0 strmbdy

127+ ResponseBuilder s0 hs0 b

128+ | noBody s0 -> responseNoBody s0 hs0

129+ | isHead -> responseNoBody s0 hs0

130+ | otherwise -> getHTTP2Data req

131+ >>= pushStream ctx settings sid reqvt req ii

132+ >>= responseBuilderBody s0 hs0 b

133+ ResponseFile s0 hs0 p mp

134+ | noBody s0 -> responseNoBody s0 hs0

135+ | otherwise -> getHTTP2Data req

136+ >>= pushStream ctx settings sid reqvt req ii

137+ >>= responseFileXXX s0 hs0 p mp

138+ ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"

139+ where

140+ noBody = not . R.hasBody

141+ !isHead = requestMethod req == H.methodHead

142+ !logger = S.settingsLogger settings

143+ !th = threadHandle ii

144+ sid = streamNumber strm

145+ !h2data = getHTTP2Data req

146+

147+ -- Ideally, log messages should be written when responses are

148+ -- actually sent. But there is no way to keep good memory usage

149+ -- (resist to Request leak) and throughput. By compromise,

150+ -- log message are written here even the window size of streams

151+ -- is 0.

152+

153+ responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s

154+

155+ responseNoBody' s tbl = do

156+ logger req s Nothing

157+ setThreadContinue tconf True

158+ let !rspn = RspnNobody s tbl

159+ !out = Output strm rspn ii (return ()) h2data ORspn

160+ enqueueOutput outputQ out

161+ return ResponseReceived

162+

163+ responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do

164+ logger req s Nothing

165+ setThreadContinue tconf True

166+ tbl <- toHeaderTable hs0

167+ let !rspn = RspnBuilder s tbl bdy

168+ !out = Output strm rspn ii tell h2data rspnOrWait

169+ enqueueOutput outputQ out

170+ return ResponseReceived

171+

172+ responseFileXXX _ hs0 path Nothing aux = do

173+ efinfo <- E.try $ getFileInfo ii path

174+ case efinfo of

175+ Left (_ex :: E.IOException) -> response404 hs0

176+ Right finfo -> do

177+ (rspths0,vt) <- toHeaderTable hs0

178+ case conditionalRequest finfo rspths0 reqvt of

179+ WithoutBody s -> responseNoBody s hs0

180+ WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux

181+

182+ responseFileXXX s0 hs0 path mpart aux = do

183+ tbl <- toHeaderTable hs0

184+ responseFile2XX s0 tbl path mpart aux

185+

186+ responseFile2XX s tbl path mpart (rspnOrWait,tell)

187+ | isHead = do

188+ logger req s Nothing

189+ responseNoBody' s tbl

190+ | otherwise = do

191+ logger req s (filePartByteCount <$> mpart)

192+ setThreadContinue tconf True

193+ let !rspn = RspnFile s tbl path mpart

194+ !out = Output strm rspn ii tell h2data rspnOrWait

195+ enqueueOutput outputQ out

196+ return ResponseReceived

197+

198+ response404 hs0 = responseBuilderBody s hs body (ORspn, return ())

199+ where

200+ s = H.notFound404

201+ hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

202+ body = byteString "File not found"

203+

204+ responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do

205+ logger req s0 Nothing

206+ -- We must not exit this WAI application.

207+ -- If the application exits, streaming would be also closed.

208+ -- So, this work occupies this thread.

209+ --

210+ -- We need to increase the number of workers.

211+ spawnAction mgr

212+ -- After this work, this thread stops to decease

213+ -- the number of workers.

214+ setThreadContinue tconf False

215+ -- Since 'StreamingBody' is loop, we cannot control it.

216+ -- So, let's serialize 'Builder' with a designated queue.

217+ tbq <- newTBQueueIO 10 -- fixme: hard coding: 10

218+ tbl <- toHeaderTable hs0

219+ let !rspn = RspnStreaming s0 tbl tbq

220+ !out = Output strm rspn ii tell h2data rspnOrWait

221+ enqueueOutput outputQ out

222+ let push b = do

223+ atomically $ writeTBQueue tbq (SBuilder b)

224+ T.tickle th

225+ flush = atomically $ writeTBQueue tbq SFlush

226+ _ <- strmbdy push flush

227+ atomically $ writeTBQueue tbq SFinish

228+ deleteMyId mgr

229+ return ResponseReceived

230+

231+worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO ()

232+worker ctx@Context{inputQ,controlQ} set app responder tm = do

233+ sinfo <- newStreamInfo

234+ tcont <- newThreadContinue

235+ let timeoutAction = return () -- cannot close the shared connection

236+ E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont

237+ where

238+ go sinfo tcont th = do

239+ setThreadContinue tcont True

240+ ex <- E.try $ do

241+ T.pause th

242+ inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ

243+ setStreamInfo sinfo inp

244+ T.resume th

245+ T.tickle th

246+ app req $ responder ii reqvt tcont strm req

247+ cont1 <- case ex of

248+ Right ResponseReceived -> return True

249+ Left e@(SomeException _)

250+ -- killed by the local worker manager

251+ | Just ThreadKilled <- E.fromException e -> return False

252+ -- killed by the local timeout manager

253+ | Just T.TimeoutThread <- E.fromException e -> do

254+ cleanup sinfo Nothing

255+ return True

256+ | otherwise -> do

257+ cleanup sinfo $ Just e

258+ return True

259+ cont2 <- getThreadContinue tcont

260+ clearStreamInfo sinfo

261+ when (cont1 && cont2) $ go sinfo tcont th

262+ cleanup sinfo me = do

263+ minp <- getStreamInfo sinfo

264+ case minp of

265+ Nothing -> return ()

266+ Just (Input strm req _reqvt _ii) -> do

267+ closed ctx strm Killed

268+ let !frame = resetFrame InternalError (streamNumber strm)

269+ enqueueControl controlQ $ CFrame frame

270+ case me of

271+ Nothing -> return ()

272+ Just e -> S.settingsOnException set (Just req) e

273+

274+----------------------------------------------------------------

275+

276+-- | It would nice if responders could return values to workers.

277+-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.

278+-- It is not wise to change this type.

279+-- So, a reference is shared by a responder and its worker.

280+-- The reference refers a value of this type as a return value.

281+-- If 'True', the worker continue to serve requests.

282+-- Otherwise, the worker get finished.

283+newtype ThreadContinue = ThreadContinue (IORef Bool)

284+

285+{-# INLINE newThreadContinue #-}

286+newThreadContinue :: IO ThreadContinue

287+newThreadContinue = ThreadContinue <$> newIORef True

288+

289+{-# INLINE setThreadContinue #-}

290+setThreadContinue :: ThreadContinue -> Bool -> IO ()

291+setThreadContinue (ThreadContinue ref) x = writeIORef ref x

292+

293+{-# INLINE getThreadContinue #-}

294+getThreadContinue :: ThreadContinue -> IO Bool

295+getThreadContinue (ThreadContinue ref) = readIORef ref

296+

297+----------------------------------------------------------------

298+

299+-- | The type to store enough information for 'settingsOnException'.

300+newtype StreamInfo = StreamInfo (IORef (Maybe Input))

301+

302+{-# INLINE newStreamInfo #-}

303+newStreamInfo :: IO StreamInfo

304+newStreamInfo = StreamInfo <$> newIORef Nothing

305+

306+{-# INLINE clearStreamInfo #-}

307+clearStreamInfo :: StreamInfo -> IO ()

308+clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing

309+

310+{-# INLINE setStreamInfo #-}

311+setStreamInfo :: StreamInfo -> Input -> IO ()

312+setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp

313+

314+{-# INLINE getStreamInfo #-}

315+getStreamInfo :: StreamInfo -> IO (Maybe Input)

316+getStreamInfo (StreamInfo ref) = readIORef ref

warp/Network/Wai/Handler/Warp/HashMap.hs+16−26

@@ -1,7 +1,6 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3module Network.Wai.Handler.Warp.HashMap where

1module Network.Wai.Handler.Warp.HashMap where

4

2

3+import Data.ByteString (ByteString)

5import Data.Hashable (hash)

4import Data.Hashable (hash)

6import Data.IntMap.Strict (IntMap)

5import Data.IntMap.Strict (IntMap)

7import qualified Data.IntMap.Strict as I

6import qualified Data.IntMap.Strict as I

@@ -9,34 +8,25 @@ import Data.Map.Strict (Map)

9import qualified Data.Map.Strict as M

8import qualified Data.Map.Strict as M

10import Prelude hiding (lookup)

9import Prelude hiding (lookup)

11

10

12−----------------------------------------------------------------

11+type Hash = Int

13−

14−-- | 'HashMap' is used for cache of file information.

15−-- Hash values of file pathes are used as outer keys.

16−-- Because negative entries are also contained,

17−-- a bad guy can intentionally cause the hash collison.

18−-- So, 'Map' is used internally to prevent

19−-- the hash collision attack.

20−newtype HashMap v = HashMap (IntMap (Map FilePath v))

12+newtype HashMap k v = HashMap (IntMap (Map k v))

21

13

22−----------------------------------------------------------------

14+hashByteString :: ByteString -> Hash

15+hashByteString = hash

23

16

24−empty :: HashMap v

17+empty :: HashMap k v

25−empty = HashMap I.empty

18+empty = HashMap $ I.empty

26

19

27−isEmpty :: HashMap v -> Bool

20+null :: HashMap k v -> Bool

28−isEmpty (HashMap hm) = I.null hm

21+null (HashMap hm) = I.null hm

29

22

30−----------------------------------------------------------------

31−

32−insert :: FilePath -> v -> HashMap v -> HashMap v

23+insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v

33−insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm

24+insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm

34 where

25 where

35− !h = hash path

36− !m = M.singleton path v

26+ m = M.singleton k v

37 f = M.union -- fimxe

27 f = M.union -- fimxe

28+{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}

38

29

39−lookup :: FilePath -> HashMap v -> Maybe v

30+lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v

40−lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path

31+lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k

41− where

32+{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}

42− !h = hash path

warp/Network/Wai/Handler/Warp/Header.hs−3

@@ -7,7 +7,6 @@ import Data.Array.ST

7import qualified Data.ByteString as BS

8import Data.CaseInsensitive (foldedCase)

9import Network.HTTP.Types

10−

11import Network.Wai.Handler.Warp.Types

10import Network.Wai.Handler.Warp.Types

12

11

13----------------------------------------------------------------

12----------------------------------------------------------------

@@ -69,7 +68,6 @@ indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex

69data ResponseHeaderIndex = ResContentLength

68data ResponseHeaderIndex = ResContentLength

70 | ResServer

69 | ResServer

71 | ResDate

70 | ResDate

72− | ResLastModified

73 deriving (Enum,Bounded)

71 deriving (Enum,Bounded)

74

72

75-- | The size for 'IndexedHeader' for HTTP Response.

73-- | The size for 'IndexedHeader' for HTTP Response.

@@ -80,7 +78,6 @@ responseKeyIndex :: HeaderName -> Int

80responseKeyIndex hn = case BS.length bs of

78responseKeyIndex hn = case BS.length bs of

81 4 -> if bs == "date" then fromEnum ResDate else -1

79 4 -> if bs == "date" then fromEnum ResDate else -1

82 6 -> if bs == "server" then fromEnum ResServer else -1

80 6 -> if bs == "server" then fromEnum ResServer else -1

83− 13 -> if bs == "last-modified" then fromEnum ResLastModified else -1

84 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

81 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

85 _ -> -1

82 _ -> -1

86 where

83 where

warp/Network/Wai/Handler/Warp/IO.hs+1−2

@@ -3,11 +3,10 @@

3

4module Network.Wai.Handler.Warp.IO where

5

6+import Data.ByteString (ByteString)

6import Data.ByteString.Builder (Builder)

7import Data.ByteString.Builder (Builder)

7import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

8import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

8−

9import Network.Wai.Handler.Warp.Buffer

10−import Network.Wai.Handler.Warp.Imports

11import Network.Wai.Handler.Warp.Types

10import Network.Wai.Handler.Warp.Types

12

11

13toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

12toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

warp/Network/Wai/Handler/Warp/Imports.hsdeleted−27

@@ -1,27 +0,0 @@

1−module Network.Wai.Handler.Warp.Imports (

2− ByteString(..)

3− , NonEmpty(..)

4− , module Control.Applicative

5− , module Control.Monad

6− , module Data.Bits

7− , module Data.List

8− , module Data.Int

9− , module Data.Monoid

10− , module Data.Ord

11− , module Data.Word

12− , module Data.Maybe

13− , module Numeric

14− ) where

15−

16−import Control.Applicative

17−import Control.Monad

18−import Data.Bits

19−import Data.ByteString.Internal (ByteString(..))

20−import Data.Int

21−import Data.List

22−import Data.List.NonEmpty (NonEmpty(..))

23−import Data.Maybe

24−import Data.Monoid

25−import Data.Ord

26−import Data.Word

27−import Numeric

warp/Network/Wai/Handler/Warp/Internal.hs+2−7

@@ -53,7 +53,7 @@ module Network.Wai.Handler.Warp.Internal (

53 -- resumed as soon as we return from user code.

54 --

55 -- * Every time data is successfully sent to the client, the timeout is tickled.

56− , module System.TimeManager

56+ , module Network.Wai.Handler.Warp.Timeout

57 -- * File descriptor cache

58 , module Network.Wai.Handler.Warp.FdCache

59 -- * File information cache

@@ -64,13 +64,8 @@ module Network.Wai.Handler.Warp.Internal (

64 , Source

65 , recvRequest

66 , sendResponse

67− -- * Platform dependent helper functions

68− , setSocketCloseOnExec

69− , windowsThreadBlockHack

70 ) where

67 ) where

71

68

72−import System.TimeManager

73−

74import Network.Wai.Handler.Warp.Buffer

69import Network.Wai.Handler.Warp.Buffer

75import Network.Wai.Handler.Warp.Date

70import Network.Wai.Handler.Warp.Date

76import Network.Wai.Handler.Warp.FdCache

71import Network.Wai.Handler.Warp.FdCache

@@ -82,5 +77,5 @@ import Network.Wai.Handler.Warp.Response

82import Network.Wai.Handler.Warp.Run

77import Network.Wai.Handler.Warp.Run

83import Network.Wai.Handler.Warp.SendFile

78import Network.Wai.Handler.Warp.SendFile

84import Network.Wai.Handler.Warp.Settings

79import Network.Wai.Handler.Warp.Settings

80+import Network.Wai.Handler.Warp.Timeout

85import Network.Wai.Handler.Warp.Types

81import Network.Wai.Handler.Warp.Types

86−import Network.Wai.Handler.Warp.Windows

warp/Network/Wai/Handler/Warp/MultiMap.hs+40−64

@@ -1,111 +1,87 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE CPP, BangPatterns #-}

2

3module Network.Wai.Handler.Warp.MultiMap (

4− MultiMap

4+ MMap

5 , isEmpty

6 , empty

7 , singleton

8 , insert

9− , Network.Wai.Handler.Warp.MultiMap.lookup

9+ , search

10+ , searchWith

10 , pruneWith

11 , pruneWith

11 , toList

12 , toList

12 , merge

13 , merge

13 ) where

14 ) where

14

15

15−import Data.Hashable (hash)

16import Data.IntMap.Strict (IntMap)

17import qualified Data.IntMap.Strict as I

18−import Data.Semigroup

18+import qualified Network.Wai.Handler.Warp.Some as S

19−import Prelude -- Silence redundant import warnings

20

19

21----------------------------------------------------------------

20----------------------------------------------------------------

22

21

23−-- | 'MultiMap' is used for cache of file descriptors.

22+type MMap v = IntMap (S.Some v)

24−-- Since multiple threads would open file descriptors for

25−-- the same file simultaneously, multiple entries must

26−-- be contained for the file.

27−-- Since hash values of file pathes are used as outer keys,

28−-- collison would happen for multiple file pathes.

29−-- Becase only positive entries are contained,

30−-- a bad guy cannot be cause the hash collision intentinally.

31−-- So, lists are good enough.

32−newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])

33

23

34----------------------------------------------------------------

24----------------------------------------------------------------

35

25

36-- | O(1)

26-- | O(1)

37−empty :: MultiMap v

27+isEmpty :: MMap v -> Bool

38−empty = MultiMap $ I.empty

28+isEmpty = I.null

39

29

40-- | O(1)

30-- | O(1)

41−isEmpty :: MultiMap v -> Bool

31+empty :: MMap v

42−isEmpty (MultiMap mm) = I.null mm

32+empty = I.empty

43

33

44----------------------------------------------------------------

34----------------------------------------------------------------

45

35

46-- | O(1)

36-- | O(1)

47−singleton :: FilePath -> v -> MultiMap v

37+singleton :: Int -> v -> MMap v

48−singleton path v = MultiMap mm

49− where

50− !h = hash path

51− !mm = I.singleton h [(path,v)]

38+singleton k v = I.singleton k (S.singleton v)

52

39

53----------------------------------------------------------------

40----------------------------------------------------------------

54

41

55−-- | O(N)

42+-- | O(log n)

56−lookup :: FilePath -> MultiMap v -> Maybe v

43+search :: Int -> MMap v -> Maybe v

57−lookup path (MultiMap mm) = case I.lookup h mm of

44+search k m = case I.lookup k m of

58 Nothing -> Nothing

45 Nothing -> Nothing

59− Just s -> Prelude.lookup path s

46+ Just s -> Just $! S.top s

60− where

61− !h = hash path

62−

63−----------------------------------------------------------------

64

47

65-- | O(log n)

48-- | O(log n)

66−insert :: FilePath -> v -> MultiMap v -> MultiMap v

49+searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v

67−insert path v (MultiMap mm) = MultiMap mm'

50+searchWith k f m = case I.lookup k m of

68− where

51+ Nothing -> Nothing

69− !h = hash path

52+ Just s -> S.lookupWith f s

70− !mm' = I.insertWith (<>) h [(path,v)] mm

71

53

72----------------------------------------------------------------

54----------------------------------------------------------------

73

55

74−-- | O(n)

56+-- | O(log n)

75−toList :: MultiMap v -> [(FilePath,v)]

57+insert :: Int -> v -> MMap v -> MMap v

76−toList (MultiMap mm) = concatMap snd $ I.toAscList mm

58+insert k v m = I.insertWith S.union k (S.singleton v) m

77

59

78----------------------------------------------------------------

60----------------------------------------------------------------

79

61

80-- | O(n)

62-- | O(n)

81−pruneWith :: MultiMap v

63+toList :: MMap v -> [v]

82− -> ((FilePath,v) -> IO Bool)

64+toList m = concatMap f $ I.toAscList m

83− -> IO (MultiMap v)

84−pruneWith (MultiMap mm) action = MultiMap <$> mm'

85 where

65 where

86− !mm' = I.fromAscList <$> go (I.toDescList mm) []

66+ f (_,s) = S.toList s

87− go [] !acc = return acc

88− go ((h,s):kss) !acc = do

89− rs <- prune action s

90− case rs of

91− [] -> go kss acc

92− _ -> go kss ((h,rs) : acc)

93

67

94----------------------------------------------------------------

68----------------------------------------------------------------

95

69

96−-- O(n + m) where N is the size of the second argument

70+-- | O(n)

97−merge :: MultiMap v -> MultiMap v -> MultiMap v

71+pruneWith :: MMap v

98−merge (MultiMap m1) (MultiMap m2) = MultiMap mm

72+ -> (v -> IO Bool)

73+ -> IO (MMap v)

74+pruneWith m action = I.fromAscList <$> go (I.toDescList m) []

99 where

75 where

100− !mm = I.unionWith (<>) m1 m2

76+ go [] acc = return acc

77+ go ((k,s):kss) acc = do

78+ mt <- S.prune action s

79+ case mt of

80+ Nothing -> go kss acc

81+ Just t -> go kss ((k,t) : acc)

101

82

102----------------------------------------------------------------

83----------------------------------------------------------------

103

84

104−prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]

85+-- O(n + m) where N is the size of the second argument

105−prune action xs0 = go xs0

86+merge :: MMap v -> MMap v -> MMap v

106− where

87+merge m1 m2 = I.unionWith S.union m1 m2

107− go [] = return []

108− go (x:xs) = do

109− keep <- action x

110− rs <- go xs

111− return $ if keep then x:rs else rs

warp/Network/Wai/Handler/Warp/PackInt.hs+6−6

@@ -2,21 +2,21 @@

2

3module Network.Wai.Handler.Warp.PackInt where

4

5+import Control.Monad (when)

5−import Data.ByteString.Internal (unsafeCreate)

6+import Data.ByteString.Internal (ByteString(..), unsafeCreate)

7+import Data.Word8 (Word8)

6import Foreign.Ptr (Ptr, plusPtr)

8import Foreign.Ptr (Ptr, plusPtr)

7import Foreign.Storable (poke)

9import Foreign.Storable (poke)

8import qualified Network.HTTP.Types as H

10import qualified Network.HTTP.Types as H

9

11

10−import Network.Wai.Handler.Warp.Imports

11−

12-- $setup

13−-- >>> import Data.ByteString.Char8 as C8

13+-- >>> import Data.ByteString.Char8 as B

14-- >>> import Test.QuickCheck (Large(..))

15

16-- |

17--

18−-- prop> packIntegral (abs n) == C8.pack (show (abs n))

18+-- prop> packIntegral (abs n) == B.pack (show (abs n))

19−-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.pack (show n')

19+-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == B.pack (show n')

20

21packIntegral :: Integral a => a -> ByteString

22packIntegral 0 = "0"

warp/Network/Wai/Handler/Warp/ReadInt.hs+2−2

@@ -13,13 +13,13 @@ module Network.Wai.Handler.Warp.ReadInt (

13-- This function lives in its own file because the MagicHash pragma interacts

14-- poorly with the CPP pragma.

15

16+import Data.ByteString (ByteString)

16import qualified Data.ByteString as S

17import qualified Data.ByteString as S

18+import Data.Int (Int64)

17import GHC.Prim

19import GHC.Prim

18import GHC.Types

20import GHC.Types

19import GHC.Word

21import GHC.Word

20

22

21−import Network.Wai.Handler.Warp.Imports hiding (readInt)

22−

23{-# INLINE readInt #-}

24readInt :: Integral a => ByteString -> a

25readInt bs = fromIntegral $ readInt64 bs

warp/Network/Wai/Handler/Warp/Recv.hs+13−43

@@ -11,25 +11,18 @@ module Network.Wai.Handler.Warp.Recv (

11

12import qualified Control.Exception as E

13import qualified Data.ByteString as BS

14+import Data.ByteString.Internal (ByteString(..))

14import Data.IORef

15import Data.IORef

16+import Data.Word (Word8)

15import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

17import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

16import Foreign.C.Types

18import Foreign.C.Types

17import Foreign.ForeignPtr (withForeignPtr)

19import Foreign.ForeignPtr (withForeignPtr)

18import Foreign.Ptr (Ptr, castPtr, plusPtr)

20import Foreign.Ptr (Ptr, castPtr, plusPtr)

19import GHC.Conc (threadWaitRead)

21import GHC.Conc (threadWaitRead)

20−import qualified GHC.IO.Exception as E

21−import Network.Socket (Socket)

22+import Network.Socket (Socket, fdSocket)

22−import qualified System.IO.Error as E

23−#if MIN_VERSION_network(3,1,0)

24−import Network.Socket (withFdSocket)

25−#else

26−import Network.Socket (fdSocket)

27−#endif

28−import System.Posix.Types (Fd(..))

29−

30import Network.Wai.Handler.Warp.Buffer

23import Network.Wai.Handler.Warp.Buffer

31−import Network.Wai.Handler.Warp.Imports

32import Network.Wai.Handler.Warp.Types

24import Network.Wai.Handler.Warp.Types

25+import System.Posix.Types (Fd(..))

33

26

34#ifdef mingw32_HOST_OS

27#ifdef mingw32_HOST_OS

35import GHC.IO.FD (FD(..), readRawBufferPtr)

28import GHC.IO.FD (FD(..), readRawBufferPtr)

@@ -96,45 +89,24 @@ spell init0 siz0 recv recvBuf

96 siz' = siz - len

89 siz' = siz - len

97 loop bss' siz'

90 loop bss' siz'

98

91

99−-- The timeout manager may close the socket.

100−-- In that case, an error of "Bad file descriptor" occurs.

101−-- We ignores it because we expect TimeoutThread.

102receive :: Socket -> BufferPool -> Recv

92receive :: Socket -> BufferPool -> Recv

103−receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do

93+receive sock pool = withBufferPool pool $ \ (ptr, size) -> do

104−#if MIN_VERSION_network(3,1,0)

105− withFdSocket sock $ \fd -> do

106−#elif MIN_VERSION_network(3,0,0)

107− fd <- fdSocket sock

108−#else

109− let fd = fdSocket sock

94+ let sock' = fdSocket sock

110−#endif

111− let size' = fromIntegral size

95+ size' = fromIntegral size

112− fromIntegral <$> receiveloop fd ptr size'

96+ fromIntegral <$> receiveloop sock' ptr size'

113− where

114− handler :: E.IOException -> IO ByteString

115− handler e

116− | E.ioeGetErrorType e == E.InvalidArgument = return ""

117− | otherwise = E.throwIO e

118

97

119receiveBuf :: Socket -> RecvBuf

98receiveBuf :: Socket -> RecvBuf

120−receiveBuf sock buf0 siz0 = do

99+receiveBuf sock buf0 siz0 = loop buf0 siz0

121−#if MIN_VERSION_network(3,1,0)

122− withFdSocket sock $ \fd -> do

123−#elif MIN_VERSION_network(3,0,0)

124− fd <- fdSocket sock

125−#else

126− let fd = fdSocket sock

127−#endif

128− loop fd buf0 siz0

129 where

100 where

130− loop _ _ 0 = return True

101+ loop _ 0 = return True

131− loop fd buf siz = do

102+ loop buf siz = do

132 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

103 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

133 -- fixme: what should we do in the case of n == 0

104 -- fixme: what should we do in the case of n == 0

134 if n == 0 then

105 if n == 0 then

135 return False

106 return False

136 else

107 else

137− loop fd (buf `plusPtr` n) (siz - n)

108+ loop (buf `plusPtr` n) (siz - n)

109+ fd = fdSocket sock

138

110

139receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

111receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

140receiveloop sock ptr size = do

112receiveloop sock ptr size = do

@@ -153,8 +125,6 @@ receiveloop sock ptr size = do

153 else

125 else

154 return bytes

126 return bytes

155

127

156−#ifndef mingw32_HOST_OS

157-- fixme: the type of the return value

128-- fixme: the type of the return value

158foreign import ccall unsafe "recv"

129foreign import ccall unsafe "recv"

159 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

130 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

160−#endif

warp/Network/Wai/Handler/Warp/Request.hs+36−34

@@ -9,36 +9,41 @@ module Network.Wai.Handler.Warp.Request (

9 , headerLines

10 , pauseTimeoutKey

11 , getFileInfoKey

12− , getClientCertificateKey

13 , NoKeepAliveRequest (..)

12 , NoKeepAliveRequest (..)

14 ) where

13 ) where

15

14

16import qualified Control.Concurrent as Conc (yield)

15import qualified Control.Concurrent as Conc (yield)

17import Control.Exception (throwIO, Exception)

16import Control.Exception (throwIO, Exception)

18import Data.Array ((!))

17import Data.Array ((!))

18+import Data.ByteString (ByteString)

19+import Data.Typeable (Typeable)

19import qualified Data.ByteString as S

20import qualified Data.ByteString as S

20import qualified Data.ByteString.Unsafe as SU

21import qualified Data.ByteString.Unsafe as SU

21import qualified Data.CaseInsensitive as CI

22import qualified Data.CaseInsensitive as CI

22import qualified Data.IORef as I

23import qualified Data.IORef as I

23−import Data.Typeable (Typeable)

24−import qualified Data.Vault.Lazy as Vault

25−import Data.X509

26import qualified Network.HTTP.Types as H

24import qualified Network.HTTP.Types as H

27import Network.Socket (SockAddr)

25import Network.Socket (SockAddr)

28import Network.Wai

26import Network.Wai

29−import Network.Wai.Handler.Warp.Types

30−import Network.Wai.Internal

31−import Prelude hiding (lines)

32−import System.IO.Unsafe (unsafePerformIO)

33−import qualified System.TimeManager as Timeout

34−

35import Network.Wai.Handler.Warp.Conduit

27import Network.Wai.Handler.Warp.Conduit

36import Network.Wai.Handler.Warp.FileInfoCache

28import Network.Wai.Handler.Warp.FileInfoCache

29+import Network.Wai.Handler.Warp.HashMap (hashByteString)

37import Network.Wai.Handler.Warp.Header

30import Network.Wai.Handler.Warp.Header

38−import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

39import Network.Wai.Handler.Warp.ReadInt

31import Network.Wai.Handler.Warp.ReadInt

40import Network.Wai.Handler.Warp.RequestHeader

32import Network.Wai.Handler.Warp.RequestHeader

41−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)

33+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)

34+import qualified Network.Wai.Handler.Warp.Timeout as Timeout

35+import Network.Wai.Handler.Warp.Types

36+import Network.Wai.Internal

37+import Prelude hiding (lines)

38+import Control.Monad (when)

39+import qualified Data.Vault.Lazy as Vault

40+import System.IO.Unsafe (unsafePerformIO)

41+

42+----------------------------------------------------------------

43+

44+-- FIXME come up with good values here

45+maxTotalHeaderLength :: Int

46+maxTotalHeaderLength = 50 * 1024

42

47

43----------------------------------------------------------------

48----------------------------------------------------------------

44

49

@@ -47,22 +52,21 @@ import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, setting

47recvRequest :: Bool -- ^ first request on this connection?

52recvRequest :: Bool -- ^ first request on this connection?

48 -> Settings

53 -> Settings

49 -> Connection

54 -> Connection

50− -> InternalInfo

55+ -> InternalInfo1

51− -> Timeout.Handle

52 -> SockAddr -- ^ Peer's address.

56 -> SockAddr -- ^ Peer's address.

53 -> Source -- ^ Where HTTP request comes from.

57 -> Source -- ^ Where HTTP request comes from.

54− -> Transport

55 -> IO (Request

58 -> IO (Request

56 ,Maybe (I.IORef Int)

59 ,Maybe (I.IORef Int)

57 ,IndexedHeader

60 ,IndexedHeader

58− ,IO ByteString) -- ^

61+ ,IO ByteString

62+ ,InternalInfo) -- ^

59 -- 'Request' passed to 'Application',

63 -- 'Request' passed to 'Application',

60 -- how many bytes remain to be consumed, if known

64 -- how many bytes remain to be consumed, if known

61 -- 'IndexedHeader' of HTTP request for internal use,

65 -- 'IndexedHeader' of HTTP request for internal use,

62 -- Body producing action used for flushing the request body

66 -- Body producing action used for flushing the request body

63

67

64−recvRequest firstRequest settings conn ii th addr src transport = do

68+recvRequest firstRequest settings conn ii1 addr src = do

65− hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src

69+ hdrlines <- headerLines firstRequest src

66 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

70 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

67 let idxhdr = indexRequestHeader hdr

71 let idxhdr = indexRequestHeader hdr

68 expect = idxhdr ! fromEnum ReqExpect

72 expect = idxhdr ! fromEnum ReqExpect

@@ -70,9 +74,11 @@ recvRequest firstRequest settings conn ii th addr src transport = do

70 te = idxhdr ! fromEnum ReqTransferEncoding

74 te = idxhdr ! fromEnum ReqTransferEncoding

71 handle100Continue = handleExpect conn httpversion expect

75 handle100Continue = handleExpect conn httpversion expect

72 rawPath = if settingsNoParsePath settings then unparsedPath else path

76 rawPath = if settingsNoParsePath settings then unparsedPath else path

77+ h = hashByteString rawPath

78+ ii = toInternalInfo ii1 h

79+ th = threadHandle ii

73 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

80 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

74 $ Vault.insert getFileInfoKey (getFileInfo ii)

81 $ Vault.insert getFileInfoKey (getFileInfo ii)

75− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

76 Vault.empty

82 Vault.empty

77 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te

83 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te

78 -- body producing function which will produce '100-continue', if needed

84 -- body producing function which will produce '100-continue', if needed

@@ -87,7 +93,7 @@ recvRequest firstRequest settings conn ii th addr src transport = do

87 , rawQueryString = query

93 , rawQueryString = query

88 , queryString = H.parseQuery query

94 , queryString = H.parseQuery query

89 , requestHeaders = hdr

95 , requestHeaders = hdr

90− , isSecure = isTransportSecure transport

96+ , isSecure = False

91 , remoteHost = addr

97 , remoteHost = addr

92 , requestBody = rbody'

98 , requestBody = rbody'

93 , vault = vaultValue

99 , vault = vaultValue

@@ -97,12 +103,12 @@ recvRequest firstRequest settings conn ii th addr src transport = do

97 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

103 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

98 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

104 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

99 }

105 }

100− return (req, remainingRef, idxhdr, rbodyFlush)

106+ return (req, remainingRef, idxhdr, rbodyFlush, ii)

101

107

102----------------------------------------------------------------

108----------------------------------------------------------------

103

109

104−headerLines :: Int -> Bool -> Source -> IO [ByteString]

110+headerLines :: Bool -> Source -> IO [ByteString]

105−headerLines maxTotalHeaderLength firstRequest src = do

111+headerLines firstRequest src = do

106 bs <- readSource src

112 bs <- readSource src

107 if S.null bs

113 if S.null bs

108 -- When we're working on a keep-alive connection and trying to

114 -- When we're working on a keep-alive connection and trying to

@@ -110,7 +116,7 @@ headerLines maxTotalHeaderLength firstRequest src = do

110 -- lack of data as a real exception. See the http1 function in

116 -- lack of data as a real exception. See the http1 function in

111 -- the Run module for more details.

117 -- the Run module for more details.

112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

118 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

113− else push maxTotalHeaderLength src (THStatus 0 id id) bs

119+ else push src (THStatus 0 id id) bs

114

120

115data NoKeepAliveRequest = NoKeepAliveRequest

121data NoKeepAliveRequest = NoKeepAliveRequest

116 deriving (Show, Typeable)

122 deriving (Show, Typeable)

@@ -220,8 +226,8 @@ close :: Sink ByteString IO a

220close = throwIO IncompleteHeaders

226close = throwIO IncompleteHeaders

221-}

227-}

222

228

223−push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]

229+push :: Source -> THStatus -> ByteString -> IO [ByteString]

224−push maxTotalHeaderLength src (THStatus len lines prepend) bs'

230+push src (THStatus len lines prepend) bs'

225 -- Too many bytes

231 -- Too many bytes

226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

232 | len > maxTotalHeaderLength = throwIO OverLargeHeader

227 | otherwise = push' mnl

233 | otherwise = push' mnl

@@ -249,13 +255,13 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'

249 push' Nothing = do

255 push' Nothing = do

250 bst <- readSource' src

256 bst <- readSource' src

251 when (S.null bst) $ throwIO IncompleteHeaders

257 when (S.null bst) $ throwIO IncompleteHeaders

252− push maxTotalHeaderLength src status bst

258+ push src status bst

253 where

259 where

254 len' = len + bsLen

260 len' = len + bsLen

255 prepend' = S.append bs

261 prepend' = S.append bs

256 status = THStatus len' lines prepend'

262 status = THStatus len' lines prepend'

257 -- Found a newline, but next line continues as a multiline header

263 -- Found a newline, but next line continues as a multiline header

258− push' (Just (end, True)) = push maxTotalHeaderLength src status rest

264+ push' (Just (end, True)) = push src status rest

259 where

265 where

260 rest = S.drop (end + 1) bs

266 rest = S.drop (end + 1) bs

261 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

267 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

@@ -274,12 +280,12 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'

274 in if start < bsLen then

280 in if start < bsLen then

275 -- more bytes in this chunk, push again

281 -- more bytes in this chunk, push again

276 let bs'' = SU.unsafeDrop start bs

282 let bs'' = SU.unsafeDrop start bs

277− in push maxTotalHeaderLength src status bs''

283+ in push src status bs''

278 else do

284 else do

279 -- no more bytes in this chunk, ask for more

285 -- no more bytes in this chunk, ask for more

280 bst <- readSource' src

286 bst <- readSource' src

281 when (S.null bs) $ throwIO IncompleteHeaders

287 when (S.null bs) $ throwIO IncompleteHeaders

282− push maxTotalHeaderLength src status bst

288+ push src status bst

283 where

289 where

284 start = end + 1 -- start of next chunk

290 start = end + 1 -- start of next chunk

285 line = SU.unsafeTake (checkCR bs end) bs

291 line = SU.unsafeTake (checkCR bs end) bs

@@ -297,7 +303,3 @@ pauseTimeoutKey = unsafePerformIO Vault.newKey

297getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

303getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

298getFileInfoKey = unsafePerformIO Vault.newKey

304getFileInfoKey = unsafePerformIO Vault.newKey

299{-# NOINLINE getFileInfoKey #-}

305{-# NOINLINE getFileInfoKey #-}

300−

301−getClientCertificateKey :: Vault.Key (Maybe CertificateChain)

302−getClientCertificateKey = unsafePerformIO Vault.newKey

303−{-# NOINLINE getClientCertificateKey #-}

warp/Network/Wai/Handler/Warp/RequestHeader.hs+6−5

@@ -1,3 +1,4 @@

1+{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2

3

3module Network.Wai.Handler.Warp.RequestHeader (

4module Network.Wai.Handler.Warp.RequestHeader (

@@ -5,16 +6,16 @@ module Network.Wai.Handler.Warp.RequestHeader (

5 ) where

6 ) where

6

7

7import Control.Exception (throwIO)

8import Control.Exception (throwIO)

9+import Control.Monad (when)

8import qualified Data.ByteString as S

10import qualified Data.ByteString as S

9−import qualified Data.ByteString.Char8 as C8 (unpack)

11+import qualified Data.ByteString.Char8 as B (unpack)

10−import Data.ByteString.Internal (memchr)

12+import Data.ByteString.Internal (ByteString(..), memchr)

11import qualified Data.CaseInsensitive as CI

13import qualified Data.CaseInsensitive as CI

14+import Data.Word (Word8)

12import Foreign.ForeignPtr (withForeignPtr)

15import Foreign.ForeignPtr (withForeignPtr)

13import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

16import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

14import Foreign.Storable (peek)

17import Foreign.Storable (peek)

15import qualified Network.HTTP.Types as H

18import qualified Network.HTTP.Types as H

16−

17−import Network.Wai.Handler.Warp.Imports

18import Network.Wai.Handler.Warp.Types

19import Network.Wai.Handler.Warp.Types

19

20

20-- $setup

21-- $setup

@@ -88,7 +89,7 @@ parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> d

88

89

89 return (method,path,query,hv)

90 return (method,path,query,hv)

90 where

91 where

91− baderr = BadFirstLine $ C8.unpack requestLine

92+ baderr = BadFirstLine $ B.unpack requestLine

92 check :: Ptr Word8 -> Int -> Word8 -> IO ()

93 check :: Ptr Word8 -> Int -> Word8 -> IO ()

93 check p n w = do

94 check p n w = do

94 w0 <- peek $ p `plusPtr` n

95 w0 <- peek $ p `plusPtr` n

warp/Network/Wai/Handler/Warp/Response.hs+34−33

@@ -1,5 +1,6 @@

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE TupleSections #-}

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

5{-# LANGUAGE BangPatterns #-}

6{-# LANGUAGE BangPatterns #-}

@@ -13,34 +14,37 @@ module Network.Wai.Handler.Warp.Response (

13 , addServer -- testing

14 , addServer -- testing

14 ) where

15 ) where

15

16

16−import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)

17+import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)

17import qualified Control.Exception as E

18import qualified Control.Exception as E

19+import Control.Monad (unless, when)

18import Data.Array ((!))

20import Data.Array ((!))

21+import Data.ByteString (ByteString)

19import qualified Data.ByteString as S

22import qualified Data.ByteString as S

23+import qualified Data.ByteString.Char8 as S8

20import Data.ByteString.Builder (byteString, Builder)

24import Data.ByteString.Builder (byteString, Builder)

21import Data.ByteString.Builder.Extra (flush)

25import Data.ByteString.Builder.Extra (flush)

22−import qualified Data.ByteString.Char8 as C8

23import qualified Data.CaseInsensitive as CI

26import qualified Data.CaseInsensitive as CI

24import Data.Function (on)

27import Data.Function (on)

28+import Data.List (deleteBy)

29+import Data.Maybe

30+import Data.Monoid ((<>))

25−import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)

31+import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)

26import Data.Version (showVersion)

32import Data.Version (showVersion)

27import Data.Word8 (_cr, _lf)

33import Data.Word8 (_cr, _lf)

28import qualified Network.HTTP.Types as H

34import qualified Network.HTTP.Types as H

29import qualified Network.HTTP.Types.Header as H

35import qualified Network.HTTP.Types.Header as H

30import Network.Wai

36import Network.Wai

31−import Network.Wai.Internal

32−import qualified Paths_warp

33−import qualified System.TimeManager as T

34−

35import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

37import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

36import qualified Network.Wai.Handler.Warp.Date as D

38import qualified Network.Wai.Handler.Warp.Date as D

37import Network.Wai.Handler.Warp.File

39import Network.Wai.Handler.Warp.File

38import Network.Wai.Handler.Warp.Header

40import Network.Wai.Handler.Warp.Header

39import Network.Wai.Handler.Warp.IO (toBufIOWith)

41import Network.Wai.Handler.Warp.IO (toBufIOWith)

40−import Network.Wai.Handler.Warp.Imports

41import Network.Wai.Handler.Warp.ResponseHeader

42import Network.Wai.Handler.Warp.ResponseHeader

42import Network.Wai.Handler.Warp.Settings

43import Network.Wai.Handler.Warp.Settings

44+import qualified Network.Wai.Handler.Warp.Timeout as T

43import Network.Wai.Handler.Warp.Types

45import Network.Wai.Handler.Warp.Types

46+import Network.Wai.Internal

47+import qualified Paths_warp

44

48

45-- $setup

49-- $setup

46-- >>> :set -XOverloadedStrings

50-- >>> :set -XOverloadedStrings

@@ -101,13 +105,12 @@ import Network.Wai.Handler.Warp.Types

101sendResponse :: Settings

105sendResponse :: Settings

102 -> Connection

106 -> Connection

103 -> InternalInfo

107 -> InternalInfo

104− -> T.Handle

105 -> Request -- ^ HTTP request.

108 -> Request -- ^ HTTP request.

106 -> IndexedHeader -- ^ Indexed header of HTTP request.

109 -> IndexedHeader -- ^ Indexed header of HTTP request.

107 -> IO ByteString -- ^ source from client, for raw response

110 -> IO ByteString -- ^ source from client, for raw response

108 -> Response -- ^ HTTP response including status code and response header.

111 -> Response -- ^ HTTP response including status code and response header.

109 -> IO Bool -- ^ Returing True if the connection is persistent.

112 -> IO Bool -- ^ Returing True if the connection is persistent.

110−sendResponse settings conn ii th req reqidxhdr src response = do

113+sendResponse settings conn ii req reqidxhdr src response = do

111 hs <- addServerAndDate hs0

114 hs <- addServerAndDate hs0

112 if hasBody s then do

115 if hasBody s then do

113 -- The response to HEAD does not have body.

116 -- The response to HEAD does not have body.

@@ -116,14 +119,14 @@ sendResponse settings conn ii th req reqidxhdr src response = do

116 -- and status, the response to HEAD is processed here.

119 -- and status, the response to HEAD is processed here.

117 --

120 --

118 -- See definition of rsp below for proper body stripping.

121 -- See definition of rsp below for proper body stripping.

119− (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp

122+ (ms, mlen) <- sendRsp conn ii ver s hs rsp

120 case ms of

123 case ms of

121 Nothing -> return ()

124 Nothing -> return ()

122 Just realStatus -> logger req realStatus mlen

125 Just realStatus -> logger req realStatus mlen

123 T.tickle th

126 T.tickle th

124 return ret

127 return ret

125 else do

128 else do

126− _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody

129+ _ <- sendRsp conn ii ver s hs RspNoBody

127 logger req s Nothing

130 logger req s Nothing

128 T.tickle th

131 T.tickle th

129 return isPersist

132 return isPersist

@@ -134,6 +137,7 @@ sendResponse settings conn ii th req reqidxhdr src response = do

134 s = responseStatus response

137 s = responseStatus response

135 hs0 = sanitizeHeaders $ responseHeaders response

138 hs0 = sanitizeHeaders $ responseHeaders response

136 rspidxhdr = indexResponseHeader hs0

139 rspidxhdr = indexResponseHeader hs0

140+ th = threadHandle ii

137 getdate = getDate ii

141 getdate = getDate ii

138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

142 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

143 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

@@ -171,11 +175,11 @@ containsNewlines = S.any (\w -> w == _cr || w == _lf)

171

175

172{-# INLINE sanitizeHeaderValue #-}

176{-# INLINE sanitizeHeaderValue #-}

173sanitizeHeaderValue :: ByteString -> ByteString

177sanitizeHeaderValue :: ByteString -> ByteString

174−sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of

178+sanitizeHeaderValue v = case S8.lines $ S.filter (/= _cr) v of

175 [] -> ""

179 [] -> ""

176− x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)

180+ x : xs -> S8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)

177 where

181 where

178− addSpaceIfMissing line = case C8.uncons line of

182+ addSpaceIfMissing line = case S8.uncons line of

179 Nothing -> Nothing

183 Nothing -> Nothing

180 Just (first, _)

184 Just (first, _)

181 | first == ' ' || first == '\t' -> Just line

185 | first == ' ' || first == '\t' -> Just line

@@ -196,13 +200,12 @@ sendRsp :: Connection

196 -> H.HttpVersion

200 -> H.HttpVersion

197 -> H.Status

201 -> H.Status

198 -> H.ResponseHeaders

202 -> H.ResponseHeaders

199− -> IndexedHeader -- Response

200 -> Rsp

203 -> Rsp

201 -> IO (Maybe H.Status, Maybe Integer)

204 -> IO (Maybe H.Status, Maybe Integer)

202

205

203----------------------------------------------------------------

206----------------------------------------------------------------

204

207

205−sendRsp conn _ ver s hs _ RspNoBody = do

208+sendRsp conn _ ver s hs RspNoBody = do

206 -- Not adding Content-Length.

209 -- Not adding Content-Length.

207 -- User agents treats it as Content-Length: 0.

210 -- User agents treats it as Content-Length: 0.

208 composeHeader ver s hs >>= connSendAll conn

211 composeHeader ver s hs >>= connSendAll conn

@@ -210,7 +213,7 @@ sendRsp conn _ ver s hs _ RspNoBody = do

210

213

211----------------------------------------------------------------

214----------------------------------------------------------------

212

215

213−sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

216+sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

214 header <- composeHeaderBuilder ver s hs needsChunked

217 header <- composeHeaderBuilder ver s hs needsChunked

215 let hdrBdy

218 let hdrBdy

216 | needsChunked = header <> chunkedTransferEncoding body

219 | needsChunked = header <> chunkedTransferEncoding body

@@ -223,9 +226,9 @@ sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

223

226

224----------------------------------------------------------------

227----------------------------------------------------------------

225

228

226−sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

229+sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

227 header <- composeHeaderBuilder ver s hs needsChunked

230 header <- composeHeaderBuilder ver s hs needsChunked

228− (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

231+ (recv, finish) <- newBlazeRecv $ reuseBufferStrategy

229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

232 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

230 let send builder = do

233 let send builder = do

231 popper <- recv builder

234 popper <- recv builder

@@ -247,7 +250,7 @@ sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

247

250

248----------------------------------------------------------------

251----------------------------------------------------------------

249

252

250−sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

253+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

251 withApp recv send

254 withApp recv send

252 return (Nothing, Nothing)

255 return (Nothing, Nothing)

253 where

256 where

@@ -261,8 +264,8 @@ sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

261

264

262-- Sophisticated WAI applications.

265-- Sophisticated WAI applications.

263-- We respect s0. s0 MUST be a proper value.

266-- We respect s0. s0 MUST be a proper value.

264−sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

267+sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =

265− sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook

268+ sendRspFile2XX conn ii ver s0 hs path beg len isHead hook

266 where

269 where

267 beg = filePartOffset part

270 beg = filePartOffset part

268 len = filePartByteCount part

271 len = filePartByteCount part

@@ -272,17 +275,17 @@ sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

272

275

273-- Simple WAI applications.

276-- Simple WAI applications.

274-- Status is ignored

277-- Status is ignored

275−sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do

278+sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do

276 efinfo <- E.try $ getFileInfo ii path

279 efinfo <- E.try $ getFileInfo ii path

277 case efinfo of

280 case efinfo of

278 Left (_ex :: E.IOException) ->

281 Left (_ex :: E.IOException) ->

279#ifdef WARP_DEBUG

282#ifdef WARP_DEBUG

280 print _ex >>

283 print _ex >>

281#endif

284#endif

282− sendRspFile404 conn ii ver hs0 rspidxhdr

285+ sendRspFile404 conn ii ver hs0

283− Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of

286+ Right finfo -> case conditionalRequest finfo hs0 idxhdr of

284− WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody

287+ WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody

285− WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

288+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook

286

289

287----------------------------------------------------------------

290----------------------------------------------------------------

288

291

@@ -291,15 +294,14 @@ sendRspFile2XX :: Connection

291 -> H.HttpVersion

294 -> H.HttpVersion

292 -> H.Status

295 -> H.Status

293 -> H.ResponseHeaders

296 -> H.ResponseHeaders

294− -> IndexedHeader

295 -> FilePath

297 -> FilePath

296 -> Integer

298 -> Integer

297 -> Integer

299 -> Integer

298 -> Bool

300 -> Bool

299 -> IO ()

301 -> IO ()

300 -> IO (Maybe H.Status, Maybe Integer)

302 -> IO (Maybe H.Status, Maybe Integer)

301−sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

303+sendRspFile2XX conn ii ver s hs path beg len isHead hook

302− | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody

304+ | isHead = sendRsp conn ii ver s hs RspNoBody

303 | otherwise = do

305 | otherwise = do

304 lheader <- composeHeader ver s hs

306 lheader <- composeHeader ver s hs

305 (mfd, fresher) <- getFd ii path

307 (mfd, fresher) <- getFd ii path

@@ -312,9 +314,8 @@ sendRspFile404 :: Connection

312 -> InternalInfo

314 -> InternalInfo

313 -> H.HttpVersion

315 -> H.HttpVersion

314 -> H.ResponseHeaders

316 -> H.ResponseHeaders

315− -> IndexedHeader

316 -> IO (Maybe H.Status, Maybe Integer)

317 -> IO (Maybe H.Status, Maybe Integer)

317−sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)

318+sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)

318 where

319 where

319 s = H.notFound404

320 s = H.notFound404

320 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

321 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

warp/Network/Wai/Handler/Warp/ResponseHeader.hs+5−3

@@ -3,15 +3,17 @@

3

4module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where

5

6+import Control.Monad

7+import Data.ByteString (ByteString)

6import qualified Data.ByteString as S

8import qualified Data.ByteString as S

7import Data.ByteString.Internal (create)

9import Data.ByteString.Internal (create)

8import qualified Data.CaseInsensitive as CI

10import qualified Data.CaseInsensitive as CI

11+import Data.List (foldl')

12+import Data.Word (Word8)

9import Foreign.Ptr

13import Foreign.Ptr

10import GHC.Storable

14import GHC.Storable

11import qualified Network.HTTP.Types as H

15import qualified Network.HTTP.Types as H

12−

13import Network.Wai.Handler.Warp.Buffer (copy)

16import Network.Wai.Handler.Warp.Buffer (copy)

14−import Network.Wai.Handler.Warp.Imports

15

17

16----------------------------------------------------------------

18----------------------------------------------------------------

17

19

@@ -22,7 +24,7 @@ composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do

22 void $ copyCRLF ptr2

24 void $ copyCRLF ptr2

23 where

25 where

24 !len = 17 + slen + foldl' fieldLength 0 responseHeaders

26 !len = 17 + slen + foldl' fieldLength 0 responseHeaders

25− fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4

27+ fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4

26 !slen = S.length $ H.statusMessage status

28 !slen = S.length $ H.statusMessage status

27

29

28httpVer11 :: ByteString

30httpVer11 :: ByteString

warp/Network/Wai/Handler/Warp/Run.hs+73−137

@@ -3,53 +3,46 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PackageImports #-}

5{-# LANGUAGE PatternGuards #-}

6−{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE TupleSections #-}

9−{-# LANGUAGE ViewPatterns #-}

10{-# OPTIONS_GHC -fno-warn-deprecations #-}

8{-# OPTIONS_GHC -fno-warn-deprecations #-}

11

9

12module Network.Wai.Handler.Warp.Run where

10module Network.Wai.Handler.Warp.Run where

13

11

14−import "iproute" Data.IP (toHostAddress, toHostAddress6)

15import Control.Arrow (first)

12import Control.Arrow (first)

16import qualified Control.Concurrent as Conc (yield)

13import qualified Control.Concurrent as Conc (yield)

17import Control.Exception as E

14import Control.Exception as E

15+import Control.Monad (when, unless, void)

16+import Data.ByteString (ByteString)

18import qualified Data.ByteString as S

17import qualified Data.ByteString as S

19import Data.Char (chr)

18import Data.Char (chr)

19+import "iproute" Data.IP (toHostAddress, toHostAddress6)

20−import Data.IORef (IORef, newIORef, readIORef, writeIORef)

20+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')

21import Data.Streaming.Network (bindPortTCP)

22import Foreign.C.Error (Errno(..), eCONNABORTED)

23import GHC.IO.Exception (IOException(..))

24−import qualified Network.HTTP2 as H2

24+import Network (Socket)

25−import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

25+import Network.Socket (close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

26−#if MIN_VERSION_network(3,1,1)

27−import Network.Socket (gracefulClose)

28−#endif

29import qualified Network.Socket.ByteString as Sock

26import qualified Network.Socket.ByteString as Sock

30import Network.Wai

27import Network.Wai

31−import Network.Wai.Internal (ResponseReceived (ResponseReceived))

32−import System.Environment (lookupEnv)

33−import qualified System.TimeManager as T

34−import System.Timeout (timeout)

35−

36import Network.Wai.Handler.Warp.Buffer

28import Network.Wai.Handler.Warp.Buffer

37import Network.Wai.Handler.Warp.Counter

29import Network.Wai.Handler.Warp.Counter

38import qualified Network.Wai.Handler.Warp.Date as D

30import qualified Network.Wai.Handler.Warp.Date as D

39import qualified Network.Wai.Handler.Warp.FdCache as F

31import qualified Network.Wai.Handler.Warp.FdCache as F

40import qualified Network.Wai.Handler.Warp.FileInfoCache as I

32import qualified Network.Wai.Handler.Warp.FileInfoCache as I

41−import Network.Wai.Handler.Warp.HTTP2 (http2)

33+import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)

42−import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)

43import Network.Wai.Handler.Warp.Header

34import Network.Wai.Handler.Warp.Header

44−import Network.Wai.Handler.Warp.Imports hiding (readInt)

45import Network.Wai.Handler.Warp.ReadInt

35import Network.Wai.Handler.Warp.ReadInt

46import Network.Wai.Handler.Warp.Recv

36import Network.Wai.Handler.Warp.Recv

47import Network.Wai.Handler.Warp.Request

37import Network.Wai.Handler.Warp.Request

48import Network.Wai.Handler.Warp.Response

38import Network.Wai.Handler.Warp.Response

49import Network.Wai.Handler.Warp.SendFile

39import Network.Wai.Handler.Warp.SendFile

50import Network.Wai.Handler.Warp.Settings

40import Network.Wai.Handler.Warp.Settings

41+import qualified Network.Wai.Handler.Warp.Timeout as T

51import Network.Wai.Handler.Warp.Types

42import Network.Wai.Handler.Warp.Types

52−

43+import Network.Wai.Internal (ResponseReceived (ResponseReceived))

44+import System.Environment (getEnvironment)

45+import System.Timeout (timeout)

53

46

54#if WINDOWS

47#if WINDOWS

55import Network.Wai.Handler.Warp.Windows

48import Network.Wai.Handler.Warp.Windows

@@ -58,38 +51,21 @@ import Network.Socket (fdSocket)

58#endif

51#endif

59

52

60-- | Creating 'Connection' for plain HTTP based on a given socket.

53-- | Creating 'Connection' for plain HTTP based on a given socket.

61−socketConnection :: Settings -> Socket -> IO Connection

54+socketConnection :: Socket -> IO Connection

62−#if MIN_VERSION_network(3,1,1)

63−socketConnection set s = do

64−#else

65−socketConnection _ s = do

55+socketConnection s = do

66−#endif

67 bufferPool <- newBufferPool

56 bufferPool <- newBufferPool

68 writeBuf <- allocateBuffer bufferSize

57 writeBuf <- allocateBuffer bufferSize

69 let sendall = Sock.sendAll s

58 let sendall = Sock.sendAll s

70− isH2 <- newIORef False -- HTTP/1.x

71 return Connection {

59 return Connection {

72 connSendMany = Sock.sendMany s

60 connSendMany = Sock.sendMany s

73 , connSendAll = sendall

61 , connSendAll = sendall

74 , connSendFile = sendFile s writeBuf bufferSize sendall

62 , connSendFile = sendFile s writeBuf bufferSize sendall

75−#if MIN_VERSION_network(3,1,1)

76− , connClose = do

77− h2 <- readIORef isH2

78− let tm = if h2 then settingsGracefulCloseTimeout2 set

79− else settingsGracefulCloseTimeout1 set

80− if tm == 0 then

81− close s

82− else

83− gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()

84−#else

85 , connClose = close s

63 , connClose = close s

86−#endif

87 , connFree = freeBuffer writeBuf

64 , connFree = freeBuffer writeBuf

88 , connRecv = receive s bufferPool

65 , connRecv = receive s bufferPool

89 , connRecvBuf = receiveBuf s

66 , connRecvBuf = receiveBuf s

90 , connWriteBuffer = writeBuf

67 , connWriteBuffer = writeBuf

91 , connBufferSize = bufferSize

68 , connBufferSize = bufferSize

92− , connHTTP2 = isH2

93 }

69 }

94

70

95-- | Run an 'Application' on the given port.

71-- | Run an 'Application' on the given port.

@@ -104,7 +80,7 @@ run p = runSettings defaultSettings { settingsPort = p }

104-- Since 3.0.9

80-- Since 3.0.9

105runEnv :: Port -> Application -> IO ()

81runEnv :: Port -> Application -> IO ()

106runEnv p app = do

82runEnv p app = do

107− mp <- lookupEnv "PORT"

83+ mp <- lookup "PORT" <$> getEnvironment

108

84

109 maybe (run p app) runReadPort mp

85 maybe (run p app) runReadPort mp

110

86

@@ -151,7 +127,7 @@ runSettingsSocket set socket app = do

151 setSocketCloseOnExec s

127 setSocketCloseOnExec s

152 -- NoDelay causes an error for AF_UNIX.

128 -- NoDelay causes an error for AF_UNIX.

153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

129 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

154− conn <- socketConnection set s

130+ conn <- socketConnection s

155 return (conn, sa)

131 return (conn, sa)

156

132

157 closeListenSocket = close socket

133 closeListenSocket = close socket

@@ -192,15 +168,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),

192runSettingsConnectionMakerSecure set getConnMaker app = do

168runSettingsConnectionMakerSecure set getConnMaker app = do

193 settingsBeforeMainLoop set

169 settingsBeforeMainLoop set

194 counter <- newCounter

170 counter <- newCounter

195− withII $ acceptConnection set getConnMaker app counter

171+ withII0 $ acceptConnection set getConnMaker app counter

196 where

172 where

197− withII action =

173+ withII0 action =

198 withTimeoutManager $ \tm ->

174 withTimeoutManager $ \tm ->

199 D.withDateCache $ \dc ->

175 D.withDateCache $ \dc ->

200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

176 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

177 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

202− let ii = InternalInfo tm dc fdc fic

178+ let ii0 = InternalInfo0 tm dc fdc fic

203− action ii

179+ action ii0

204

180

205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

181 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

182 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

@@ -229,18 +205,13 @@ acceptConnection :: Settings

229 -> IO (IO (Connection, Transport), SockAddr)

205 -> IO (IO (Connection, Transport), SockAddr)

230 -> Application

206 -> Application

231 -> Counter

207 -> Counter

232− -> InternalInfo

208+ -> InternalInfo0

233 -> IO ()

209 -> IO ()

234−acceptConnection set getConnMaker app counter ii = do

210+acceptConnection set getConnMaker app counter ii0 = do

235 -- First mask all exceptions in acceptLoop. This is necessary to

211 -- First mask all exceptions in acceptLoop. This is necessary to

236 -- ensure that no async exception is throw between the call to

212 -- ensure that no async exception is throw between the call to

237 -- acceptNewConnection and the registering of connClose.

213 -- acceptNewConnection and the registering of connClose.

238− --

239− -- acceptLoop can be broken by closing the listing socket.

240 void $ mask_ acceptLoop

214 void $ mask_ acceptLoop

241− -- In some cases, we want to stop Warp here without graceful shutdown.

242− -- So, async exceptions are allowed here.

243− -- That's why `finally` is not used.

244 gracefulShutdown set counter

215 gracefulShutdown set counter

245 where

216 where

246 acceptLoop = do

217 acceptLoop = do

@@ -258,7 +229,7 @@ acceptConnection set getConnMaker app counter ii = do

258 case mx of

229 case mx of

259 Nothing -> return ()

230 Nothing -> return ()

260 Just (mkConn, addr) -> do

231 Just (mkConn, addr) -> do

261− fork set mkConn addr app counter ii

232+ fork set mkConn addr app counter ii0

262 acceptLoop

233 acceptLoop

263

234

264 acceptNewConnection = do

235 acceptNewConnection = do

@@ -281,12 +252,15 @@ fork :: Settings

281 -> SockAddr

252 -> SockAddr

282 -> Application

253 -> Application

283 -> Counter

254 -> Counter

284− -> InternalInfo

255+ -> InternalInfo0

285 -> IO ()

256 -> IO ()

286−fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

257+fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

287 -- Call the user-supplied on exception code if any

258 -- Call the user-supplied on exception code if any

288 -- exceptions are thrown.

259 -- exceptions are thrown.

289− handle (settingsOnException set Nothing) $

260+ handle (settingsOnException set Nothing) .

261+ -- Allocate a new IORef indicating whether the connection has been

262+ -- closed, to avoid double-freeing a connection

263+ withClosedRef $ \ref ->

290 -- Run the connection maker to get a new connection, and ensure

264 -- Run the connection maker to get a new connection, and ensure

291 -- that the connection is closed. If the mkConn call throws an

265 -- that the connection is closed. If the mkConn call throws an

292 -- exception, we will leak the connection. If the mkConn call is

266 -- exception, we will leak the connection. If the mkConn call is

@@ -297,15 +271,24 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

297 -- We grab the connection before registering timeouts since the

271 -- We grab the connection before registering timeouts since the

298 -- timeouts will be useless during connection creation, due to the

272 -- timeouts will be useless during connection creation, due to the

299 -- fact that async exceptions are still masked.

273 -- fact that async exceptions are still masked.

300− bracket mkConn cleanUp (serve unmask)

274+ bracket mkConn (cleanUp ref) (serve unmask ref)

301 where

275 where

276+ withClosedRef inner = newIORef False >>= inner

277+

278+ closeConn ref conn = do

279+ isClosed <- atomicModifyIORef' ref $ \x -> (True, x)

280+ unless isClosed $ connClose conn

281+

302− cleanUp (conn, _) = connClose conn `finally` connFree conn

282+ cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn

303

283

304 -- We need to register a timeout handler for this thread, and

284 -- We need to register a timeout handler for this thread, and

305− -- cancel that handler as soon as we exit.

285+ -- cancel that handler as soon as we exit. We additionally close

286+ -- the connection immediately in case the child thread catches the

287+ -- async exception or performs some long-running cleanup action.

306− serve unmask (conn, transport) = bracket register cancel $ \th -> do

288+ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do

289+ let ii1 = toInternalInfo1 ii0 th

307 -- We now have fully registered a connection close handler in

290 -- We now have fully registered a connection close handler in

308− -- the case of all exceptions, so it is safe to once again

291+ -- the case of all exceptions, so it is safe to one again

309 -- allow async exceptions.

292 -- allow async exceptions.

310 unmask .

293 unmask .

311 -- Call the user-supplied code for connection open and

294 -- Call the user-supplied code for connection open and

@@ -313,23 +296,23 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

313 bracket (onOpen addr) (onClose addr) $ \goingon ->

296 bracket (onOpen addr) (onClose addr) $ \goingon ->

314 -- Actually serve this connection. bracket with closeConn

297 -- Actually serve this connection. bracket with closeConn

315 -- above ensures the connection is closed.

298 -- above ensures the connection is closed.

316− when goingon $ serveConnection conn ii th addr transport set app

299+ when goingon $ serveConnection conn ii1 addr transport set app

317 where

300 where

318− register = T.registerKillThread (timeoutManager ii) (connClose conn)

301+ register = T.registerKillThread (timeoutManager0 ii0)

302+ (closeConn ref conn)

319 cancel = T.cancel

303 cancel = T.cancel

320

304

321 onOpen adr = increase counter >> settingsOnOpen set adr

305 onOpen adr = increase counter >> settingsOnOpen set adr

322 onClose adr _ = decrease counter >> settingsOnClose set adr

306 onClose adr _ = decrease counter >> settingsOnClose set adr

323

307

324serveConnection :: Connection

308serveConnection :: Connection

325− -> InternalInfo

309+ -> InternalInfo1

326− -> T.Handle

327 -> SockAddr

310 -> SockAddr

328 -> Transport

311 -> Transport

329 -> Settings

312 -> Settings

330 -> Application

313 -> Application

331 -> IO ()

314 -> IO ()

332−serveConnection conn ii th origAddr transport settings app = do

315+serveConnection conn ii1 origAddr transport settings app = do

333 -- fixme: Upgrading to HTTP/2 should be supported.

316 -- fixme: Upgrading to HTTP/2 should be supported.

334 (h2,bs) <- if isHTTP2 transport then

317 (h2,bs) <- if isHTTP2 transport then

335 return (True, "")

318 return (True, "")

@@ -342,36 +325,17 @@ serveConnection conn ii th origAddr transport settings app = do

342 istatus <- newIORef False

325 istatus <- newIORef False

343 if settingsHTTP2Enabled settings && h2 then do

326 if settingsHTTP2Enabled settings && h2 then do

344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

327 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

345− -- This thread becomes the sender in http2 library.

346− -- In the case of event source, one request comes and one

347− -- worker gets busy. But it is likely that the receiver does

348− -- not receive any data at all while the sender is sending

349− -- output data from the worker. It's not good enough to tickle

350− -- the time handler in the receiver only. So, we should tickle

351− -- the time handler in both the receiver and the sender.

352 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

328 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

353− sendBS x = connSendAll conn x >> T.tickle th

354 -- fixme: origAddr

329 -- fixme: origAddr

355− checkTLS

356− setConnHTTP2 conn True

357− http2 conn transport ii origAddr settings recvN sendBS app

330+ http2 conn ii1 origAddr transport settings recvN app

358 else do

331 else do

359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

332 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

360 writeIORef istatus True

333 writeIORef istatus True

361 leftoverSource src bs

334 leftoverSource src bs

362 addr <- getProxyProtocolAddr src

335 addr <- getProxyProtocolAddr src

363− http1 True addr istatus src `E.catch` \e ->

336+ http1 True addr istatus src `E.catch` \e -> do

364− case () of

365− ()

366− -- See comment below referencing

367− -- https://github.com/yesodweb/wai/issues/618

368− | Just NoKeepAliveRequest <- fromException e -> return ()

369− -- No valid request

370− | Just (BadFirstLine _) <- fromException e -> return ()

371− | otherwise -> do

372− _ <- sendErrorResponse (dummyreq addr) istatus e

337+ sendErrorResponse addr istatus e

373− throwIO e

338+ throwIO (e :: SomeException)

374−

375 where

339 where

376 getProxyProtocolAddr src =

340 getProxyProtocolAddr src =

377 case settingsProxyProtocol settings of

341 case settingsProxyProtocol settings of

@@ -413,25 +377,30 @@ serveConnection conn ii th origAddr transport settings app = do

413

377

414 decodeAscii = map (chr . fromEnum) . S.unpack

378 decodeAscii = map (chr . fromEnum) . S.unpack

415

379

380+ th = threadHandle1 ii1

381+

416 shouldSendErrorResponse se

382 shouldSendErrorResponse se

417 | Just ConnectionClosedByPeer <- fromException se = False

383 | Just ConnectionClosedByPeer <- fromException se = False

418 | otherwise = True

384 | otherwise = True

419

385

420− sendErrorResponse req istatus e = do

386+ sendErrorResponse addr istatus e = do

421 status <- readIORef istatus

387 status <- readIORef istatus

422− if shouldSendErrorResponse e && status

388+ when (shouldSendErrorResponse e && status) $ do

423− then do

389+ let ii = toInternalInfo ii1 0 -- dummy

390+ dreq = dummyreq addr

424− sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

391+ void $ sendResponse settings conn ii dreq defaultIndexRequestHeader (return S.empty) (errorResponse e)

425− else return False

426

392

427 dummyreq addr = defaultRequest { remoteHost = addr }

393 dummyreq addr = defaultRequest { remoteHost = addr }

428

394

429 errorResponse e = settingsOnExceptionResponse settings e

395 errorResponse e = settingsOnExceptionResponse settings e

430

396

431 http1 firstRequest addr istatus src = do

397 http1 firstRequest addr istatus src = do

432− (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport

398+ (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src

399+ let req = req' { isSecure = isTransportSecure transport }

433− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

400+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii

434 `E.catch` \e -> do

401 `E.catch` \e -> do

402+ -- Call the user-supplied exception handlers, passing the request.

403+ sendErrorResponse addr istatus e

435 settingsOnException settings (Just req) e

404 settingsOnException settings (Just req) e

436 -- Don't throw the error again to prevent calling settingsOnException twice.

405 -- Don't throw the error again to prevent calling settingsOnException twice.

437 return False

406 return False

@@ -444,9 +413,9 @@ serveConnection conn ii th origAddr transport settings app = do

444 -- request headers, no data is available, recvRequest will

413 -- request headers, no data is available, recvRequest will

445 -- throw a NoKeepAliveRequest exception, which we catch here

414 -- throw a NoKeepAliveRequest exception, which we catch here

446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

415 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

447− when keepAlive $ http1 False addr istatus src

416+ when keepAlive $ http1 False addr istatus src `E.catch` \NoKeepAliveRequest -> return ()

448

417

449− processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

418+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do

450 -- Let the application run for as long as it wants

419 -- Let the application run for as long as it wants

451 T.pause th

420 T.pause th

452

421

@@ -454,38 +423,30 @@ serveConnection conn ii th origAddr transport settings app = do

454 -- creating the request, we need to make sure that we don't get

423 -- creating the request, we need to make sure that we don't get

455 -- an async exception before calling the ResponseSource.

424 -- an async exception before calling the ResponseSource.

456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

425 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

457− r <- E.try $ app req $ \res -> do

426+ _ <- app req $ \res -> do

458 T.resume th

427 T.resume th

459 -- FIXME consider forcing evaluation of the res here to

428 -- FIXME consider forcing evaluation of the res here to

460 -- send more meaningful error messages to the user.

429 -- send more meaningful error messages to the user.

461 -- However, it may affect performance.

430 -- However, it may affect performance.

462 writeIORef istatus False

431 writeIORef istatus False

463− keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

432+ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

464 writeIORef keepAliveRef keepAlive

433 writeIORef keepAliveRef keepAlive

465 return ResponseReceived

434 return ResponseReceived

466− case r of

467− Right ResponseReceived -> return ()

468− Left e@(SomeException _)

469− | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'

470− | otherwise -> do

471− keepAlive <- sendErrorResponse req istatus e

472− settingsOnException settings (Just req) e

473− writeIORef keepAliveRef keepAlive

474−

475 keepAlive <- readIORef keepAliveRef

435 keepAlive <- readIORef keepAliveRef

476

436

477 -- We just send a Response and it takes a time to

437 -- We just send a Response and it takes a time to

478 -- receive a Request again. If we immediately call recv,

438 -- receive a Request again. If we immediately call recv,

479− -- it is likely to fail and cause the IO manager to do some work.

439+ -- it is likely to fail and the IO manager works.

480− -- It is very costly, so we yield to another Haskell

440+ -- It is very costly. So, we yield to another Haskell

481 -- thread hoping that the next Request will arrive

441 -- thread hoping that the next Request will arrive

482 -- when this Haskell thread will be re-scheduled.

442 -- when this Haskell thread will be re-scheduled.

483 -- This improves performance at least when

443 -- This improves performance at least when

484 -- the number of cores is small.

444 -- the number of cores is small.

485 Conc.yield

445 Conc.yield

486

446

487− if keepAlive

447+ if not keepAlive then

488− then

448+ return False

449+ else

489 -- If there is an unknown or large amount of data to still be read

450 -- If there is an unknown or large amount of data to still be read

490 -- from the request body, simple drop this connection instead of

451 -- from the request body, simple drop this connection instead of

491 -- reading it all in to satisfy a keep-alive request.

452 -- reading it all in to satisfy a keep-alive request.

@@ -511,21 +472,6 @@ serveConnection conn ii th origAddr transport settings app = do

511 else

472 else

512 return False

473 return False

513 Nothing -> tryKeepAlive

474 Nothing -> tryKeepAlive

514− else

515− return False

516−

517− checkTLS = case transport of

518− TCP -> return () -- direct

519− tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"

520− tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

521−

522−-- connClose must not be called here since Run:fork calls it

523−goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()

524−goaway Connection{..} etype debugmsg = connSendAll bytestream

525− where

526− einfo = H2.encodeInfo id 0

527− frame = H2.GoAwayFrame 0 etype debugmsg

528− bytestream = H2.encodeFrame einfo frame

529

475

530flushEntireBody :: IO ByteString -> IO ()

476flushEntireBody :: IO ByteString -> IO ()

531flushEntireBody src =

477flushEntireBody src =

@@ -571,22 +517,12 @@ wrappedRecvN th istatus slowlorisSize readN bufsize = do

571 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th

517 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th

572 return bs

518 return bs

573

519

574−-- | Set flag FileCloseOnExec flag on a socket (on Unix)

575−--

576-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

520-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

577−--

578−-- @since 3.2.17

579setSocketCloseOnExec :: Socket -> IO ()

521setSocketCloseOnExec :: Socket -> IO ()

580#if WINDOWS

522#if WINDOWS

581setSocketCloseOnExec _ = return ()

523setSocketCloseOnExec _ = return ()

582#else

524#else

583−setSocketCloseOnExec socket = do

584−#if MIN_VERSION_network(3,0,0)

585− fd <- fdSocket socket

586−#else

587− let fd = fdSocket socket

588−#endif

589− F.setFileCloseOnExec $ fromIntegral fd

525+setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket

590#endif

526#endif

591

527

592gracefulShutdown :: Settings -> Counter -> IO ()

528gracefulShutdown :: Settings -> Counter -> IO ()

warp/Network/Wai/Handler/Warp/SendFile.hs+8−4

@@ -9,14 +9,22 @@ module Network.Wai.Handler.Warp.SendFile (

9#endif

10 ) where

11

12+import Control.Monad (void, when)

13+import Data.ByteString (ByteString)

12import qualified Data.ByteString as BS

14import qualified Data.ByteString as BS

13import Network.Socket (Socket)

15import Network.Socket (Socket)

16+import Network.Wai.Handler.Warp.Buffer

17+import Network.Wai.Handler.Warp.Types

14

18

15#ifdef WINDOWS

19#ifdef WINDOWS

20+import Data.ByteString.Internal (ByteString(..))

16import Foreign.ForeignPtr (newForeignPtr_)

21import Foreign.ForeignPtr (newForeignPtr_)

17import Foreign.Ptr (plusPtr)

22import Foreign.Ptr (plusPtr)

18import qualified System.IO as IO

23import qualified System.IO as IO

19#else

24#else

25+# if __GLASGOW_HASKELL__ < 709

26+import Control.Applicative ((<$>))

27+# endif

20import Control.Exception

28import Control.Exception

21import Foreign.C.Error (throwErrno)

29import Foreign.C.Error (throwErrno)

22import Foreign.C.Types

30import Foreign.C.Types

@@ -26,10 +34,6 @@ import Network.Wai.Handler.Warp.FdCache (openFile, closeFile)

26import System.Posix.Types

34import System.Posix.Types

27#endif

35#endif

28

36

29−import Network.Wai.Handler.Warp.Buffer

30−import Network.Wai.Handler.Warp.Imports

31−import Network.Wai.Handler.Warp.Types

32−

33----------------------------------------------------------------

37----------------------------------------------------------------

34

38

35-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.

39-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.

warp/Network/Wai/Handler/Warp/Settings.hs+16−60

@@ -6,25 +6,23 @@ module Network.Wai.Handler.Warp.Settings where

6

7import Control.Concurrent (forkIOWithUnmask)

8import Control.Exception

9+import Control.Monad (when, void)

10+import Data.ByteString (ByteString)

11+import qualified Data.ByteString.Char8 as S8

9import Data.ByteString.Builder (byteString)

12import Data.ByteString.Builder (byteString)

10−import qualified Data.ByteString.Char8 as C8

11−import Data.ByteString.Lazy (fromStrict)

12import Data.Streaming.Network (HostPreference)

13import Data.Streaming.Network (HostPreference)

13import qualified Data.Text as T

14import qualified Data.Text as T

14import qualified Data.Text.IO as TIO

15import qualified Data.Text.IO as TIO

15import Data.Version (showVersion)

16import Data.Version (showVersion)

16import GHC.IO.Exception (IOErrorType(..))

17import GHC.IO.Exception (IOErrorType(..))

17import qualified Network.HTTP.Types as H

18import qualified Network.HTTP.Types as H

18−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

19import Network.Socket (SockAddr)

20import Network.Wai

21+import Network.Wai.Handler.Warp.Timeout

22+import Network.Wai.Handler.Warp.Types

21import qualified Paths_warp

23import qualified Paths_warp

22import System.IO (stderr)

24import System.IO (stderr)

23import System.IO.Error (ioeGetErrorType)

25import System.IO.Error (ioeGetErrorType)

24−import System.TimeManager

25−

26−import Network.Wai.Handler.Warp.Imports

27−import Network.Wai.Handler.Warp.Types

28

26

29-- | Various Warp server settings. This is purposely kept as an abstract data

27-- | Various Warp server settings. This is purposely kept as an abstract data

30-- type so that new settings can be added without breaking backwards

28-- type so that new settings can be added without breaking backwards

@@ -76,13 +74,6 @@ data Settings = Settings

76 --

74 --

77 -- Since 2.0.3

75 -- Since 2.0.3

78 , settingsInstallShutdownHandler :: IO () -> IO ()

76 , settingsInstallShutdownHandler :: IO () -> IO ()

79− -- ^ An action to install a handler (e.g. Unix signal handler)

80− -- to close a listen socket.

81− -- The first argument is an action to close the listen socket.

82− --

83− -- Default: no action

84− --

85− -- Since 3.0.1

86 , settingsServerName :: ByteString

77 , settingsServerName :: ByteString

87 -- ^ Default server name if application does not set one.

78 -- ^ Default server name if application does not set one.

88 --

79 --

@@ -94,44 +85,28 @@ data Settings = Settings

94 , settingsProxyProtocol :: ProxyProtocol

85 , settingsProxyProtocol :: ProxyProtocol

95 -- ^ Specify usage of the PROXY protocol.

86 -- ^ Specify usage of the PROXY protocol.

96 --

87 --

97− -- Since 3.0.5

88+ -- Since 3.0.5.

98 , settingsSlowlorisSize :: Int

89 , settingsSlowlorisSize :: Int

99 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

90 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

100 --

91 --

101− -- Since 3.1.2

92+ -- Since 3.1.2.

102 , settingsHTTP2Enabled :: Bool

93 , settingsHTTP2Enabled :: Bool

103 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

94 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

104 --

95 --

105− -- Since 3.1.7

96+ -- Since 3.1.7.

106 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

97 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

107 -- ^ A log function. Default: no action.

98 -- ^ A log function. Default: no action.

108 --

99 --

109− -- Since 3.1.10

100+ -- Since 3.X.X.

110 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

101 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

111 -- ^ A HTTP/2 server push log function. Default: no action.

102 -- ^ A HTTP/2 server push log function. Default: no action.

112 --

103 --

113− -- Since 3.2.7

104+ -- Since 3.X.X.

114 , settingsGracefulShutdownTimeout :: Maybe Int

105 , settingsGracefulShutdownTimeout :: Maybe Int

115 -- ^ An optional timeout to limit the time (in seconds) waiting for

106 -- ^ An optional timeout to limit the time (in seconds) waiting for

116 -- a graceful shutdown of the web server.

107 -- a graceful shutdown of the web server.

117 --

108 --

118 -- Since 3.2.8

109 -- Since 3.2.8

119− , settingsGracefulCloseTimeout1 :: Int

120− -- ^ A timeout to limit the time (in milliseconds) waiting for

121− -- FIN for HTTP/1.x. 0 means uses immediate close.

122− -- Default: 0.

123− --

124− -- Since 3.3.5

125− , settingsGracefulCloseTimeout2 :: Int

126− -- ^ A timeout to limit the time (in milliseconds) waiting for

127− -- FIN for HTTP/2. 0 means uses immediate close.

128− -- Default: 2000.

129− --

130− -- Since 3.3.5

131− , settingsMaxTotalHeaderLength :: Int

132− -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.

133− --

134− -- Since 3.3.8

135 }

110 }

136

111

137-- | Specify usage of the PROXY protocol.

112-- | Specify usage of the PROXY protocol.

@@ -160,7 +135,7 @@ defaultSettings = Settings

160 , settingsFork = void . forkIOWithUnmask

135 , settingsFork = void . forkIOWithUnmask

161 , settingsNoParsePath = False

136 , settingsNoParsePath = False

162 , settingsInstallShutdownHandler = const $ return ()

137 , settingsInstallShutdownHandler = const $ return ()

163− , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version

138+ , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version

164 , settingsMaximumBodyFlush = Just 8192

139 , settingsMaximumBodyFlush = Just 8192

165 , settingsProxyProtocol = ProxyProtocolNone

140 , settingsProxyProtocol = ProxyProtocolNone

166 , settingsSlowlorisSize = 2048

141 , settingsSlowlorisSize = 2048

@@ -168,9 +143,6 @@ defaultSettings = Settings

168 , settingsLogger = \_ _ _ -> return ()

143 , settingsLogger = \_ _ _ -> return ()

169 , settingsServerPushLogger = \_ _ _ -> return ()

144 , settingsServerPushLogger = \_ _ _ -> return ()

170 , settingsGracefulShutdownTimeout = Nothing

145 , settingsGracefulShutdownTimeout = Nothing

171− , settingsGracefulCloseTimeout1 = 0

172− , settingsGracefulCloseTimeout2 = 2000

173− , settingsMaxTotalHeaderLength = 50 * 1024

174 }

146 }

175

147

176-- | Apply the logic provided by 'defaultOnException' to determine if an

148-- | Apply the logic provided by 'defaultOnException' to determine if an

@@ -196,29 +168,13 @@ defaultOnException _ e =

196 when (defaultShouldDisplayException e)

168 when (defaultShouldDisplayException e)

197 $ TIO.hPutStrLn stderr $ T.pack $ show e

169 $ TIO.hPutStrLn stderr $ T.pack $ show e

198

170

199−-- | Sending 400 for bad requests.

200−-- Sending 500 for internal server errors.

171+-- | Sending 400 for bad requests. Sending 500 for internal server errors.

172+--

201-- Since: 3.1.0

173-- Since: 3.1.0

202−-- Sending 413 for too large payload.

203−-- Sending 431 for too large headers.

204−-- Since 3.2.27

205defaultOnExceptionResponse :: SomeException -> Response

174defaultOnExceptionResponse :: SomeException -> Response

206defaultOnExceptionResponse e

175defaultOnExceptionResponse e

207− | Just (_ :: InvalidRequest) <-

208− fromException e = responseLBS H.badRequest400

176+ | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request"

209− [(H.hContentType, "text/plain; charset=utf-8")]

210− "Bad Request"

211− | Just (ConnectionError (UnknownErrorCode 413) t) <-

212− fromException e = responseLBS H.status413

213− [(H.hContentType, "text/plain; charset=utf-8")]

214− (fromStrict t)

215− | Just (ConnectionError (UnknownErrorCode 431) t) <-

216− fromException e = responseLBS H.status431

217− [(H.hContentType, "text/plain; charset=utf-8")]

218− (fromStrict t)

219− | otherwise = responseLBS H.internalServerError500

177+ | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"

220− [(H.hContentType, "text/plain; charset=utf-8")]

221− "Something went wrong"

222

178

223-- | Exception handler for the debugging purpose.

179-- | Exception handler for the debugging purpose.

224-- 500, text/plain, a showed exception.

180-- 500, text/plain, a showed exception.

@@ -228,4 +184,4 @@ exceptionResponseForDebug :: SomeException -> Response

228exceptionResponseForDebug e =

184exceptionResponseForDebug e =

229 responseBuilder H.internalServerError500

185 responseBuilder H.internalServerError500

230 [(H.hContentType, "text/plain; charset=utf-8")]

186 [(H.hContentType, "text/plain; charset=utf-8")]

231− $ byteString . C8.pack $ "Exception: " ++ show e

187+ $ byteString . S8.pack $ "Exception: " ++ show e

warp/Network/Wai/Handler/Warp/Some.hsnew file+73

@@ -0,0 +1,73 @@

1+{-# LANGUAGE BangPatterns #-}

2+

3+module Network.Wai.Handler.Warp.Some (

4+ Some

5+ , singleton

6+ , top

7+ , lookupWith

8+ , union

9+ , toList

10+ , prune

11+ ) where

12+

13+----------------------------------------------------------------

14+

15+-- | One ore more list to implement multimap.

16+data Some a = One !a

17+ | Tom !a !(Some a) -- Two or more

18+ deriving (Eq,Show)

19+

20+{-# INLINE singleton #-}

21+singleton :: a -> Some a

22+singleton x = One x

23+

24+{-# INLINE top #-}

25+top :: Some a -> a

26+top (One x) = x

27+top (Tom x _) = x

28+

29+{-# INLINE lookupWith #-}

30+lookupWith :: (a -> Bool) -> Some a -> Maybe a

31+lookupWith f s = go s

32+ where

33+ go (One x)

34+ | f x = Just x

35+ | otherwise = Nothing

36+ go (Tom x xs)

37+ | f x = Just x

38+ | otherwise = go xs

39+

40+{-# INLINE union #-}

41+union :: Some a -> Some a -> Some a

42+union s t = go s t

43+ where

44+ go (One x) u = Tom x u

45+ go (Tom x xs) u = go xs (Tom x u)

46+

47+{-# INLINE toList #-}

48+toList :: Some a -> [a]

49+toList s = go s []

50+ where

51+ go (One x) !acc = x : acc

52+ go (Tom x xs) !acc = go xs (x : acc)

53+

54+{-# INLINE prune #-}

55+prune :: (a -> IO Bool) -> Some a -> IO (Maybe (Some a))

56+prune act s = go s

57+ where

58+ go (One x) = do

59+ keep <- act x

60+ return $ if keep then

61+ Just (One x)

62+ else

63+ Nothing

64+ go (Tom x xs) = do

65+ keep <- act x

66+ mys <- go xs

67+ return $ if keep then

68+ case mys of

69+ Nothing -> Just (One x)

70+ Just ys -> Just (Tom x ys)

71+ else

72+ mys

73+

time-manager/System/TimeManager.hs → warp/Network/Wai/Handler/Warp/Timeout.hsrenamed+3−2

@@ -1,6 +1,7 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

2

3

3−module System.TimeManager (

4+module Network.Wai.Handler.Warp.Timeout (

4 -- ** Types

5 -- ** Types

5 Manager

6 Manager

6 , TimeoutAction

7 , TimeoutAction

@@ -114,7 +115,7 @@ instance E.Exception TimeoutThread where

114 toException = E.asyncExceptionToException

115 toException = E.asyncExceptionToException

115 fromException = E.asyncExceptionFromException

116 fromException = E.asyncExceptionFromException

116instance Show TimeoutThread where

117instance Show TimeoutThread where

117− show TimeoutThread = "Thread killed by timeout manager"

118+ show TimeoutThread = "Thread killed by Warp's timeout reaper"

118

119

119----------------------------------------------------------------

120----------------------------------------------------------------

120

121

warp/Network/Wai/Handler/Warp/Types.hs+33−28

@@ -5,18 +5,17 @@

5module Network.Wai.Handler.Warp.Types where

6

7import Control.Exception

8+import Data.ByteString (ByteString)

8import qualified Data.ByteString as S

9import qualified Data.ByteString as S

9import Data.IORef (IORef, readIORef, writeIORef, newIORef)

10import Data.IORef (IORef, readIORef, writeIORef, newIORef)

10import Data.Typeable (Typeable)

11import Data.Typeable (Typeable)

11−import Data.X509

12+import Data.Word (Word16, Word8)

12import Foreign.Ptr (Ptr)

13import Foreign.Ptr (Ptr)

13−import System.Posix.Types (Fd)

14−import qualified System.TimeManager as T

15−

16import qualified Network.Wai.Handler.Warp.Date as D

14import qualified Network.Wai.Handler.Warp.Date as D

17import qualified Network.Wai.Handler.Warp.FdCache as F

15import qualified Network.Wai.Handler.Warp.FdCache as F

18import qualified Network.Wai.Handler.Warp.FileInfoCache as I

16import qualified Network.Wai.Handler.Warp.FileInfoCache as I

19−import Network.Wai.Handler.Warp.Imports

17+import qualified Network.Wai.Handler.Warp.Timeout as T

18+import System.Posix.Types (Fd)

20

19

21----------------------------------------------------------------

20----------------------------------------------------------------

22

21

@@ -53,20 +52,6 @@ instance Exception InvalidRequest

53

52

54----------------------------------------------------------------

53----------------------------------------------------------------

55

54

56−-- | Exception thrown if something goes wrong while in the midst of

57−-- sending a response, since the status code can't be altered at that

58−-- point.

59−--

60−-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe

61−-- or irrecoverable.

62−

63−newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException

64− deriving (Show, Typeable)

65−

66−instance Exception ExceptionInsideResponseBody

67−

68−----------------------------------------------------------------

69−

70-- | Data type to abstract file identifiers.

55-- | Data type to abstract file identifiers.

71-- On Unix, a file descriptor would be specified to make use of

56-- On Unix, a file descriptor would be specified to make use of

72-- the file descriptor cache.

57-- the file descriptor cache.

@@ -123,25 +108,46 @@ data Connection = Connection {

123 , connWriteBuffer :: Buffer

108 , connWriteBuffer :: Buffer

124 -- | The size of the write buffer.

109 -- | The size of the write buffer.

125 , connBufferSize :: BufSize

110 , connBufferSize :: BufSize

126− -- | Is this connection HTTP/2?

127− , connHTTP2 :: IORef Bool

128 }

111 }

129

112

130−getConnHTTP2 :: Connection -> IO Bool

113+----------------------------------------------------------------

131−getConnHTTP2 conn = readIORef (connHTTP2 conn)

132

114

133−setConnHTTP2 :: Connection -> Bool -> IO ()

115+type Hash = Int

134−setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b

135

116

136−----------------------------------------------------------------

117+

118+data InternalInfo0 =

119+ InternalInfo0 T.Manager

120+ (IO D.GMTDate)

121+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

122+ (Hash -> FilePath -> IO I.FileInfo)

123+

124+timeoutManager0 :: InternalInfo0 -> T.Manager

125+timeoutManager0 (InternalInfo0 tm _ _ _) = tm

126+

127+data InternalInfo1 =

128+ InternalInfo1 T.Handle

129+ T.Manager

130+ (IO D.GMTDate)

131+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

132+ (Hash -> FilePath -> IO I.FileInfo)

133+

134+toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1

135+toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e

136+

137+threadHandle1 :: InternalInfo1 -> T.Handle

138+threadHandle1 (InternalInfo1 th _ _ _ _) = th

137

139

138data InternalInfo = InternalInfo {

140data InternalInfo = InternalInfo {

141+ threadHandle :: T.Handle

139− timeoutManager :: T.Manager

142+ , timeoutManager :: T.Manager

140 , getDate :: IO D.GMTDate

143 , getDate :: IO D.GMTDate

141 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

144 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

142 , getFileInfo :: FilePath -> IO I.FileInfo

145 , getFileInfo :: FilePath -> IO I.FileInfo

143 }

146 }

144

147

148+toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo

149+toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h)

150+

145----------------------------------------------------------------

151----------------------------------------------------------------

146

152

147-- | Type for input streaming.

153-- | Type for input streaming.

@@ -180,7 +186,6 @@ data Transport = TCP -- ^ Plain channel: TCP

180 , tlsMinorVersion :: Int

186 , tlsMinorVersion :: Int

181 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

187 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

182 , tlsChiperID :: Word16

188 , tlsChiperID :: Word16

183− , tlsClientCertificate :: Maybe CertificateChain

184 } -- ^ Encrypted channel: TLS or SSL

189 } -- ^ Encrypted channel: TLS or SSL

185

190

186isTransportSecure :: Transport -> Bool

191isTransportSecure :: Transport -> Bool

warp/Network/Wai/Handler/Warp/Windows.hs+1−5

@@ -7,12 +7,8 @@ module Network.Wai.Handler.Warp.Windows

7import Control.Exception

8import Control.Concurrent.MVar

9import Control.Concurrent

10+import Control.Monad

10

11

11−import Network.Wai.Handler.Warp.Imports

12−

13−-- | Allow main socket listening thread to be interrupted on Windows platform

14−--

15−-- @since 3.2.17

16windowsThreadBlockHack :: IO a -> IO a

12windowsThreadBlockHack :: IO a -> IO a

17windowsThreadBlockHack act = do

13windowsThreadBlockHack act = do

18 var <- newEmptyMVar :: IO (MVar (Either SomeException a))

14 var <- newEmptyMVar :: IO (MVar (Either SomeException a))

warp/Network/Wai/Handler/Warp/WithApplication.hs+12−10

@@ -1,4 +1,4 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+

2module Network.Wai.Handler.Warp.WithApplication (

3 withApplication,

4 withApplicationSettings,

@@ -11,8 +11,6 @@ module Network.Wai.Handler.Warp.WithApplication (

11import Control.Concurrent

12import Control.Concurrent.Async

13import Control.Exception

14−import Control.Monad (when)

15−import Data.Streaming.Network (bindRandomPortTCP)

16import Network.Socket

14import Network.Socket

17import Network.Wai

15import Network.Wai

18import Network.Wai.Handler.Warp.Run

16import Network.Wai.Handler.Warp.Run

@@ -68,16 +66,14 @@ testWithApplication = testWithApplicationSettings defaultSettings

68--

66--

69-- @since 3.2.7

67-- @since 3.2.7

70testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

68testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

71−testWithApplicationSettings settings mkApp action = do

69+testWithApplicationSettings _settings mkApp action = do

72 callingThread <- myThreadId

70 callingThread <- myThreadId

73 app <- mkApp

71 app <- mkApp

74 let wrappedApp request respond =

72 let wrappedApp request respond =

75 app request respond `catch` \ e -> do

73 app request respond `catch` \ e -> do

76− when

77− (defaultShouldDisplayException e)

78− (throwTo callingThread e)

74+ throwTo callingThread (e :: SomeException)

79 throwIO e

75 throwIO e

80− withApplicationSettings settings (return wrappedApp) action

76+ withApplication (return wrappedApp) action

81

77

82data Waiter a

78data Waiter a

83 = Waiter {

79 = Waiter {

@@ -88,7 +84,7 @@ data Waiter a

88mkWaiter :: IO (Waiter a)

84mkWaiter :: IO (Waiter a)

89mkWaiter = do

85mkWaiter = do

90 mvar <- newEmptyMVar

86 mvar <- newEmptyMVar

91− return Waiter {

87+ return $ Waiter {

92 notify = putMVar mvar,

88 notify = putMVar mvar,

93 waitFor = readMVar mvar

89 waitFor = readMVar mvar

94 }

90 }

@@ -97,7 +93,13 @@ mkWaiter = do

97--

93--

98-- @since 3.2.4

94-- @since 3.2.4

99openFreePort :: IO (Port, Socket)

95openFreePort :: IO (Port, Socket)

100−openFreePort = bindRandomPortTCP "127.0.0.1"

96+openFreePort = do

97+ s <- socket AF_INET Stream defaultProtocol

98+ localhost <- inet_addr "127.0.0.1"

99+ bind s (SockAddrInet aNY_PORT localhost)

100+ listen s 1

101+ port <- socketPort s

102+ return (fromIntegral port, s)

101

103

102-- | Like 'openFreePort' but closes the socket before exiting.

104-- | Like 'openFreePort' but closes the socket before exiting.

103withFreePort :: ((Port, Socket) -> IO a) -> IO a

105withFreePort :: ((Port, Socket) -> IO a) -> IO a

warp/bench/Parser.hs+10−15

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

4

3

@@ -19,11 +18,7 @@ import Foreign.ForeignPtr

19import Foreign.Ptr

18import Foreign.Ptr

20import Foreign.Storable

19import Foreign.Storable

21

20

22−#if MIN_VERSION_gauge(0, 2, 0)

23−import Gauge

21+import Criterion.Main

24−#else

25−import Gauge.Main

26−#endif

27

22

28-- $setup

23-- $setup

29-- >>> :set -XOverloadedStrings

24-- >>> :set -XOverloadedStrings

@@ -68,15 +63,15 @@ parseRequestLine3 :: ByteString

68 ,H.HttpVersion)

63 ,H.HttpVersion)

69parseRequestLine3 requestLine = ret

64parseRequestLine3 requestLine = ret

70 where

65 where

71− (!method,!rest) = S.break (== 32) requestLine -- ' '

66+ (!method,!rest) = S.breakByte 32 requestLine -- ' '

72 (!pathQuery,!httpVer')

67 (!pathQuery,!httpVer')

73 | rest == "" = throw badmsg

68 | rest == "" = throw badmsg

74− | otherwise = S.break (== 32) (S.drop 1 rest) -- ' '

69+ | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' '

75− (!path,!query) = S.break (== 63) pathQuery -- '?'

70+ (!path,!query) = S.breakByte 63 pathQuery -- '?'

76 !httpVer = S.drop 1 httpVer'

71 !httpVer = S.drop 1 httpVer'

77 (!http,!ver)

72 (!http,!ver)

78 | httpVer == "" = throw badmsg

73 | httpVer == "" = throw badmsg

79− | otherwise = S.break (== 47) httpVer -- '/'

74+ | otherwise = S.breakByte 47 httpVer -- '/'

80 !hv | http /= "HTTP" = throw NonHttp

75 !hv | http /= "HTTP" = throw NonHttp

81 | ver == "/1.1" = H.http11

76 | ver == "/1.1" = H.http11

82 | otherwise = H.http10

77 | otherwise = H.http10

@@ -174,13 +169,13 @@ parseRequestLine1 :: ByteString

174 ,ByteString -- Query

169 ,ByteString -- Query

175 ,H.HttpVersion)

170 ,H.HttpVersion)

176parseRequestLine1 requestLine = do

171parseRequestLine1 requestLine = do

177− let (!method,!rest) = S.break (== 32) requestLine -- ' '

172+ let (!method,!rest) = S.breakByte 32 requestLine -- ' '

178− (!pathQuery,!httpVer') = S.break (== 32) (S.drop 1 rest) -- ' '

173+ (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' '

179 !httpVer = S.drop 1 httpVer'

174 !httpVer = S.drop 1 httpVer'

180 when (rest == "" || httpVer == "") $

175 when (rest == "" || httpVer == "") $

181 throwIO $ BadFirstLine $ B.unpack requestLine

176 throwIO $ BadFirstLine $ B.unpack requestLine

182− let (!path,!query) = S.break (== 63) pathQuery -- '?'

177+ let (!path,!query) = S.breakByte 63 pathQuery -- '?'

183− (!http,!ver) = S.break (== 47) httpVer -- '/'

178+ (!http,!ver) = S.breakByte 47 httpVer -- '/'

184 when (http /= "HTTP") $ throwIO NonHttp

179 when (http /= "HTTP") $ throwIO NonHttp

185 let !hv | ver == "/1.1" = H.http11

180 let !hv | ver == "/1.1" = H.http11

186 | otherwise = H.http10

181 | otherwise = H.http10

@@ -210,7 +205,7 @@ parseRequestLine0 s =

210 !http' = S.concat http''

205 !http' = S.concat http''

211 (!hfirst, !hsecond) = S.splitAt 5 http'

206 (!hfirst, !hsecond) = S.splitAt 5 http'

212 if hfirst == "HTTP/"

207 if hfirst == "HTTP/"

213− then let (!rpath, !qstring) = S.break (== 63) query -- '?'

208+ then let (!rpath, !qstring) = S.breakByte 63 query -- '?'

214 !hv =

209 !hv =

215 case hsecond of

210 case hsecond of

216 "1.1" -> H.http11

211 "1.1" -> H.http11

warp/test/ExceptionSpec.hs+11−11

@@ -7,7 +7,7 @@ import Control.Applicative

7#endif

8import Control.Monad

9import Network.HTTP.Types hiding (Header)

10−import Network.Wai hiding (Response, responseStatus)

10+import Network.Wai hiding (Response)

11import Network.Wai.Internal (Request(..))

12import Network.Wai.Handler.Warp

13import Test.Hspec

@@ -49,18 +49,18 @@ spec :: Spec

49spec = describe "responds even if there is an exception" $ do

50 {- Disabling these tests. We can consider forcing evaluation in Warp.

51 it "statusError" $ do

52− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"

52+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError"

53− sc `shouldBe` internalServerError500

53+ sc `shouldBe` (5,0,0)

54 it "headersError" $ do

55− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"

55+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError"

56− sc `shouldBe` internalServerError500

56+ sc `shouldBe` (5,0,0)

57 it "headerError" $ do

58− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"

58+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError"

59− sc `shouldBe` internalServerError500

59+ sc `shouldBe` (5,0,0)

60 it "bodyError" $ do

61− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"

61+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError"

62− sc `shouldBe` internalServerError500

62+ sc `shouldBe` (5,0,0)

63 -}

64 it "ioException" $ withTestServer $ \prt -> do

65− sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

65+ sc <- rspCode <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

66− sc `shouldBe` internalServerError500

66+ sc `shouldBe` (5,0,0)

warp/test/FdCacheSpec.hs+1−1

@@ -17,7 +17,7 @@ spec = describe "withFdCache" $ do

17 it "clean up Fd" $ do

18 ref <- newIORef (Fd (-1))

19 withFdCache 30000000 $ \getFd -> do

20− (Just fd,_) <- getFd "warp.cabal"

20+ (Just fd,_) <- getFd 0 "warp.cabal"

21 writeIORef ref fd

22 nfd <- readIORef ref

23 fdRead nfd 1 `shouldThrow` anyIOException

warp/test/FileSpec.hs+1−1

@@ -21,7 +21,7 @@ testFileRange desc reqhs file ans = it desc $ do

21 let WithBody s hs off len = ans

22 hs' = ("Last-Modified",fileInfoDate finfo) : hs

23 ans' = WithBody s hs' off len

24− conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans'

24+ conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'

25

26spec :: Spec

27spec = do

warp/test/HTTP.hs+28−26

@@ -1,41 +1,43 @@

1+{-# LANGUAGE StandaloneDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

1module HTTP (

3module HTTP (

2 sendGET

4 sendGET

3 , sendGETwH

5 , sendGETwH

4 , sendHEAD

6 , sendHEAD

5 , sendHEADwH

7 , sendHEADwH

6− , responseBody

8+ , rspBody

7− , responseStatus

9+ , rspCode

8− , responseHeaders

10+ , rspHeaders

9 , getHeaderValue

11 , getHeaderValue

10− , HeaderName

12+ , HeaderName(..)

13+ , mkHeader

11 ) where

14 ) where

12

15

13−import Network.HTTP.Client

16+import Network.HTTP

14−import Network.HTTP.Types

17+import Network.Stream

15−import Data.ByteString

16−import qualified Data.ByteString.Lazy as BL

17

18

18−sendGET :: String -> IO (Response BL.ByteString)

19+sendGET :: String -> IO (Response String)

19sendGET url = sendGETwH url []

20sendGET url = sendGETwH url []

20

21

21−sendGETwH :: String -> [Header] -> IO (Response BL.ByteString)

22+sendGETwH :: String -> [Header] -> IO (Response String)

22−sendGETwH url hdr = do

23+sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }

23− manager <- newManager defaultManagerSettings

24− request <- parseRequest url

25− let request' = request { requestHeaders = hdr }

26− response <- httpLbs request' manager

27− return response

28

24

29−sendHEAD :: String -> IO (Response BL.ByteString)

25+sendHEAD :: String -> IO (Response String)

30sendHEAD url = sendHEADwH url []

26sendHEAD url = sendHEADwH url []

31

27

32−sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString)

28+sendHEADwH :: String -> [Header] -> IO (Response String)

33−sendHEADwH url hdr = do

29+sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr }

34− manager <- newManager defaultManagerSettings

35− request <- parseRequest url

36− let request' = request { requestHeaders = hdr, method = methodHead }

37− response <- httpLbs request' manager

38− return response

39

30

31+unResult :: IO (Result (Response String)) -> IO (Response String)

32+unResult action = do

33+ res <- action

34+ case res of

35+ Right rsp -> return rsp

36+ Left _ -> error "Connection error"

37+

40−getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString

38+getHeaderValue :: HasHeaders a => HeaderName -> a -> Maybe String

41−getHeaderValue = lookup

39+getHeaderValue key r = case retrieveHeaders key r of

40+ [] -> Nothing

41+ x:_ -> Just $ hdrValue x

42+

43+deriving instance Eq Header

warp/test/RequestSpec.hs+7−11

@@ -7,7 +7,6 @@ module RequestSpec (main, spec) where

7import Network.Wai.Handler.Warp.File (parseByteRanges)

8import Network.Wai.Handler.Warp.Request

9import Network.Wai.Handler.Warp.Types

10−import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings)

11import Test.Hspec

10import Test.Hspec

12import Test.Hspec.QuickCheck

11import Test.Hspec.QuickCheck

13import qualified Data.ByteString as S

12import qualified Data.ByteString as S

@@ -18,9 +17,6 @@ import Data.IORef

18main :: IO ()

17main :: IO ()

19main = hspec spec

18main = hspec spec

20

19

21−defaultMaxTotalHeaderLength :: Int

22−defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23−

24spec :: Spec

20spec :: Spec

25spec = do

21spec = do

26 describe "headerLines" $ do

22 describe "headerLines" $ do

@@ -67,29 +63,29 @@ spec = do

67 describe "headerLines" $ do

63 describe "headerLines" $ do

68 it "can handle a nomarl case" $ do

64 it "can handle a nomarl case" $ do

69 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

65 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

70− x <- headerLines defaultMaxTotalHeaderLength True src

66+ x <- headerLines True src

71 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

67 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

72

68

73 it "can handle a nasty case (1)" $ do

69 it "can handle a nasty case (1)" $ do

74 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

70 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

75− x <- headerLines defaultMaxTotalHeaderLength True src

71+ x <- headerLines True src

76 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

72 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

77

73

78 it "can handle a nasty case (1)" $ do

74 it "can handle a nasty case (1)" $ do

79 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

75 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

80− x <- headerLines defaultMaxTotalHeaderLength True src

76+ x <- headerLines True src

81 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

77 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

82

78

83 it "can handle a nasty case (1)" $ do

79 it "can handle a nasty case (1)" $ do

84 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

80 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

85− x <- headerLines defaultMaxTotalHeaderLength True src

81+ x <- headerLines True src

86 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

82 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

87

83

88 it "can handle an illegal case (1)" $ do

84 it "can handle an illegal case (1)" $ do

89 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

85 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

90− x <- headerLines defaultMaxTotalHeaderLength True src

86+ x <- headerLines True src

91 x `shouldBe` []

87 x `shouldBe` []

92− y <- headerLines defaultMaxTotalHeaderLength True src

88+ y <- headerLines True src

93 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

89 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

94

90

95 where

91 where

@@ -115,7 +111,7 @@ headerLinesList' orig = do

115 writeIORef ref z

111 writeIORef ref z

116 return y

112 return y

117 src' <- mkSource src

113 src' <- mkSource src

118− res <- headerLines defaultMaxTotalHeaderLength True src'

114+ res <- headerLines True src'

119 return (res, src')

115 return (res, src')

120

116

121consumeLen :: Int -> Source -> IO S8.ByteString

117consumeLen :: Int -> Source -> IO S8.ByteString

warp/test/ResponseHeaderSpec.hs+30−2

@@ -7,6 +7,9 @@ import qualified Network.HTTP.Types as H

7import Network.Wai.Handler.Warp.ResponseHeader

8import Network.Wai.Handler.Warp.Response

9import Network.Wai.Handler.Warp.Header

10+import Network.Wai.Handler.Warp.HTTP2.HPACK

11+import Network.HPACK

12+import Network.HPACK.Token

10import Test.Hspec

13import Test.Hspec

11

14

12main :: IO ()

15main :: IO ()

@@ -34,15 +37,40 @@ spec = do

34 let hdrs = [("Server","MyServer")]

37 let hdrs = [("Server","MyServer")]

35 rspidxhdr = indexResponseHeader hdrs

38 rspidxhdr = indexResponseHeader hdrs

36 addServer "" rspidxhdr hdrs `shouldBe` []

39 addServer "" rspidxhdr hdrs `shouldBe` []

40+ describe "addHeader" $ do

41+ it "adds Server if not exist" $ do

42+ let v = "MyServer"

43+ hdrs = []

44+ hdrs1 = [("Server",v)]

45+ (thl, vt) <- toHeaderTable hdrs

46+ (thl1, _) <- toHeaderTable hdrs1

47+ addHeader tokenServer v vt thl `shouldBe` thl1

48+ it "does not add Server if exists" $ do

49+ let v = "MyServer2"

50+ hdrs = [("Server","MyServer")]

51+ (thl, vt) <- toHeaderTable hdrs

52+ addHeader tokenServer v vt thl `shouldBe` thl

53+ it "does not add Server if empty" $ do

54+ let v = ""

55+ hdrs = []

56+ (thl, vt) <- toHeaderTable hdrs

57+ addHeader tokenServer v vt thl `shouldBe` thl

58+ it "deletes Server " $ do

59+ let v = ""

60+ hdrs = [("Server","MyServer")]

61+ hdrs1 = []

62+ (thl, vt) <- toHeaderTable hdrs

63+ (thl1, _) <- toHeaderTable hdrs1

64+ addHeader tokenServer v vt thl `shouldBe` thl1

37

65

38headers :: H.ResponseHeaders

66headers :: H.ResponseHeaders

39headers = [

67headers = [

40 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

68 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

41− , ("Content-Length", "151")

69+ , ("Content-Lenght", "151")

42 , ("Server", "Mighttpd/2.5.8")

70 , ("Server", "Mighttpd/2.5.8")

43 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

71 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

44 , ("Content-Type", "text/html")

72 , ("Content-Type", "text/html")

45 ]

73 ]

46

74

47composedHeader :: ByteString

75composedHeader :: ByteString

48−composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

76+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

warp/test/ResponseSpec.hs+23−15

@@ -6,13 +6,17 @@ import Control.Concurrent (threadDelay)

6import qualified Data.ByteString as S

7import qualified Data.ByteString.Char8 as S8

8import Data.Maybe (mapMaybe)

9+import Network (connectTo, PortID (PortNumber))

9import Network.HTTP.Types

10import Network.HTTP.Types

10−import Network.Wai hiding (responseHeaders)

11+import Network.Wai

11import Network.Wai.Handler.Warp

12import Network.Wai.Handler.Warp

12import Network.Wai.Handler.Warp.Response

13import Network.Wai.Handler.Warp.Response

13−import RunSpec (withApp, msWrite, msRead, withMySocket)

14+import RunSpec (withApp)

15+import System.IO (hClose, hFlush)

14import Test.Hspec

16import Test.Hspec

15

17

18+import HTTP

19+

16main :: IO ()

20main :: IO ()

17main = hspec spec

21main = hspec spec

18

22

@@ -20,13 +24,16 @@ testRange :: S.ByteString -- ^ range value

20 -> String -- ^ expected output

24 -> String -- ^ expected output

21 -> Maybe String -- ^ expected content-range value

25 -> Maybe String -- ^ expected content-range value

22 -> Spec

26 -> Spec

23−testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

27+testRange range out crange = it title $ withApp defaultSettings app $ \port -> do

28+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

24− msWrite ms "GET / HTTP/1.0\r\n"

29+ S.hPutStr handle "GET / HTTP/1.0\r\n"

25− msWrite ms "Range: bytes="

30+ S.hPutStr handle "Range: bytes="

26− msWrite ms range

31+ S.hPutStr handle range

27− msWrite ms "\r\n\r\n"

32+ S.hPutStr handle "\r\n\r\n"

33+ hFlush handle

28 threadDelay 10000

34 threadDelay 10000

29− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

35+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

36+ hClose handle

30 last bss `shouldBe` out

37 last bss `shouldBe` out

31 let hs = mapMaybe toHeader bss

38 let hs = mapMaybe toHeader bss

32 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

39 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

@@ -44,10 +51,13 @@ testPartial :: Integer -- ^ file size

44 -> Integer -- ^ byte count

51 -> Integer -- ^ byte count

45 -> String -- ^ expected output

52 -> String -- ^ expected output

46 -> Spec

53 -> Spec

47−testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

54+testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do

55+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

48− msWrite ms "GET / HTTP/1.0\r\n\r\n"

56+ S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"

57+ hFlush handle

49 threadDelay 10000

58 threadDelay 10000

50− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

59+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

60+ hClose handle

51 out `shouldBe` last bss

61 out `shouldBe` last bss

52 let hs = mapMaybe toHeader bss

62 let hs = mapMaybe toHeader bss

53 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

63 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

@@ -63,15 +73,13 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ wit

63

73

64spec :: Spec

74spec :: Spec

65spec = do

75spec = do

66−{- http-client does not support this.

67 describe "preventing response splitting attack" $ do

76 describe "preventing response splitting attack" $ do

68 it "sanitizes header values" $ do

77 it "sanitizes header values" $ do

69 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

78 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

70 withApp defaultSettings app $ \port -> do

79 withApp defaultSettings app $ \port -> do

71 res <- sendGET $ "http://127.0.0.1:" ++ show port

80 res <- sendGET $ "http://127.0.0.1:" ++ show port

72− getHeaderValue "foo" (responseHeaders res) `shouldBe`

81+ getHeaderValue (HdrCustom "foo") res `shouldBe`

73 Just "foo bar" -- HTTP inserts two spaces for \r\n.

82 Just "foo bar" -- HTTP inserts two spaces for \r\n.

74−-}

75

83

76 describe "sanitizeHeaderValue" $ do

84 describe "sanitizeHeaderValue" $ do

77 it "doesn't alter valid multiline header values" $ do

85 it "doesn't alter valid multiline header values" $ do

@@ -83,7 +91,7 @@ spec = do

83 it "discards empty lines" $ do

91 it "discards empty lines" $ do

84 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

92 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

85

93

86− context "when sanitizing single occurrences of \n" $ do

94+ context "when sanitizing single occurences of \n" $ do

87 it "replaces \n with \r\n" $ do

95 it "replaces \n with \r\n" $ do

88 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

96 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

89

97

warp/test/RunSpec.hs+86−136

@@ -1,28 +1,29 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3

4

4−module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where

5+module RunSpec (main, spec, withApp) where

5

6

6import Control.Concurrent (forkIO, killThread, threadDelay)

7import Control.Concurrent (forkIO, killThread, threadDelay)

7import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

8import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

8−import Control.Concurrent.STM

9import qualified Control.Exception as E

10import Control.Exception.Lifted (bracket, try, IOException, onException)

11import Control.Monad (forM_, replicateM_, unless)

12import Control.Monad.IO.Class (MonadIO, liftIO)

13−import Data.ByteString (ByteString)

13+import Data.ByteString (ByteString, hPutStr, hGetSome)

14import qualified Data.ByteString as S

15import Data.ByteString.Builder (byteString)

16import qualified Data.ByteString.Char8 as S8

17import qualified Data.ByteString.Lazy as L

18import qualified Data.IORef as I

19import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

20+import Network (connectTo, PortID (PortNumber))

20import Network.HTTP.Types

21import Network.HTTP.Types

21−import Network.Socket

22+import Network.Socket (close)

22import Network.Socket.ByteString (sendAll)

23import Network.Socket.ByteString (sendAll)

23−import Network.Wai hiding (responseHeaders)

24+import Network.Wai

24−import Network.Wai.Internal (getRequestBodyChunk)

25import Network.Wai.Handler.Warp

26+import System.IO (hFlush, hClose)

26import System.IO.Unsafe (unsafePerformIO)

27import System.IO.Unsafe (unsafePerformIO)

27import System.Timeout (timeout)

28import System.Timeout (timeout)

28import Test.Hspec

29import Test.Hspec

@@ -35,52 +36,6 @@ main = hspec spec

35type Counter = I.IORef (Either String Int)

36type Counter = I.IORef (Either String Int)

36type CounterApplication = Counter -> Application

37type CounterApplication = Counter -> Application

37

38

38−data MySocket = MySocket

39− { msSocket :: !Socket

40− , msBuffer :: !(I.IORef ByteString)

41− }

42−

43−msWrite :: MySocket -> ByteString -> IO ()

44−msWrite ms bs = sendAll (msSocket ms) bs

45−

46−msRead :: MySocket -> Int -> IO ByteString

47−msRead (MySocket s ref) expected = do

48− bs <- I.readIORef ref

49− inner (bs:) (S.length bs)

50− where

51− inner front total =

52− case compare total expected of

53− EQ -> do

54− I.writeIORef ref mempty

55− pure $ S.concat $ front []

56− GT -> do

57− let bs = S.concat $ front []

58− (x, y) = S.splitAt expected bs

59− I.writeIORef ref y

60− pure x

61− LT -> do

62− bs <- safeRecv s 4096

63− if S.null bs

64− then do

65− I.writeIORef ref mempty

66− pure $ S.concat $ front []

67− else inner (front . (bs:)) (total + S.length bs)

68−

69−msClose :: MySocket -> IO ()

70−msClose = Network.Socket.close . msSocket

71−

72−connectTo :: Int -> IO MySocket

73−connectTo port = do

74− s <- fst <$> getSocketTCP "127.0.0.1" port

75− ref <- I.newIORef mempty

76− return MySocket {

77− msSocket = s

78− , msBuffer = ref

79− }

80−

81−withMySocket :: (MySocket -> IO a) -> Int -> IO a

82−withMySocket body port = bracket (connectTo port) msClose body

83−

84incr :: MonadIO m => Counter -> m ()

39incr :: MonadIO m => Counter -> m ()

85incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

40incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

86 ((case ecount of

41 ((case ecount of

@@ -92,7 +47,7 @@ err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

92

47

93readBody :: CounterApplication

48readBody :: CounterApplication

94readBody icount req f = do

49readBody icount req f = do

95− body <- consumeBody $ getRequestBodyChunk req

50+ body <- consumeBody $ requestBody req

96 case () of

51 case () of

97 ()

52 ()

98 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

53 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

@@ -113,8 +68,8 @@ ignoreBody icount req f = do

113

68

114doubleConnect :: CounterApplication

69doubleConnect :: CounterApplication

115doubleConnect icount req f = do

70doubleConnect icount req f = do

116− _ <- consumeBody $ getRequestBodyChunk req

71+ _ <- consumeBody $ requestBody req

117− _ <- consumeBody $ getRequestBodyChunk req

72+ _ <- consumeBody $ requestBody req

118 incr icount

73 incr icount

119 f $ responseLBS status200 [] "double connect"

74 f $ responseLBS status200 [] "double connect"

120

75

@@ -128,8 +83,8 @@ getPort = do

128 esocket <- try $ bindPortTCP port "127.0.0.1"

83 esocket <- try $ bindPortTCP port "127.0.0.1"

129 case esocket of

84 case esocket of

130 Left (_ :: IOException) -> RunSpec.getPort

85 Left (_ :: IOException) -> RunSpec.getPort

131− Right sock -> do

86+ Right socket -> do

132− close sock

87+ close socket

133 return port

88 return port

134

89

135withApp :: Settings -> Application -> (Int -> IO a) -> IO a

90withApp :: Settings -> Application -> (Int -> IO a) -> IO a

@@ -143,13 +98,7 @@ withApp settings app f = do

143 bracket

98 bracket

144 (forkIO $ runSettings settings' app `onException` putMVar baton ())

99 (forkIO $ runSettings settings' app `onException` putMVar baton ())

145 killThread

100 killThread

146− (const $ do

147− takeMVar baton

101+ (const $ takeMVar baton >> f port)

148− -- use timeout to make sure we don't take too long

149− mres <- timeout (60 * 1000 * 1000) (f port)

150− case mres of

151− Nothing -> error "Timeout triggered, too slow!"

152− Just a -> pure a)

153

102

154runTest :: Int -- ^ expected number of requests

103runTest :: Int -- ^ expected number of requests

155 -> CounterApplication

104 -> CounterApplication

@@ -157,9 +106,10 @@ runTest :: Int -- ^ expected number of requests

157 -> IO ()

106 -> IO ()

158runTest expected app chunks = do

107runTest expected app chunks = do

159 ref <- I.newIORef (Right 0)

108 ref <- I.newIORef (Right 0)

160− withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

109+ withApp defaultSettings (app ref) $ \port -> do

110+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

161− forM_ chunks $ \chunk -> msWrite ms chunk

111+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle

162− _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

112+ _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096

163 res <- I.readIORef ref

113 res <- I.readIORef ref

164 case res of

114 case res of

165 Left s -> error s

115 Left s -> error s

@@ -174,9 +124,11 @@ runTerminateTest :: InvalidRequest

174runTerminateTest expected input = do

124runTerminateTest expected input = do

175 ref <- I.newIORef Nothing

125 ref <- I.newIORef Nothing

176 let onExc _ = I.writeIORef ref . Just

126 let onExc _ = I.writeIORef ref . Just

177− withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

127+ withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

178− msWrite ms input

128+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

179− msClose ms -- explicitly

129+ hPutStr handle input

130+ hFlush handle

131+ hClose handle

180 threadDelay 1000

132 threadDelay 1000

181 res <- I.readIORef ref

133 res <- I.readIORef ref

182 show res `shouldBe` show (Just expected)

134 show res `shouldBe` show (Just expected)

@@ -247,11 +199,14 @@ spec = do

247 let app req f = do

199 let app req f = do

248 liftIO $ I.writeIORef iheaders $ requestHeaders req

200 liftIO $ I.writeIORef iheaders $ requestHeaders req

249 f $ responseLBS status200 [] ""

201 f $ responseLBS status200 [] ""

250− withApp defaultSettings app $ withMySocket $ \ms -> do

202+ withApp defaultSettings app $ \port -> do

203+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

251 let input = S.concat

204 let input = S.concat

252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

205 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

253 ]

206 ]

254− msWrite ms input

207+ hPutStr handle input

208+ hFlush handle

209+ hClose handle

255 threadDelay 1000

210 threadDelay 1000

256 headers <- I.readIORef iheaders

211 headers <- I.readIORef iheaders

257 headers `shouldBe`

212 headers `shouldBe`

@@ -262,11 +217,14 @@ spec = do

262 let app req f = do

217 let app req f = do

263 liftIO $ I.writeIORef iheaders $ requestHeaders req

218 liftIO $ I.writeIORef iheaders $ requestHeaders req

264 f $ responseLBS status200 [] ""

219 f $ responseLBS status200 [] ""

265− withApp defaultSettings app $ withMySocket $ \ms -> do

220+ withApp defaultSettings app $ \port -> do

221+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

266 let input = S.concat

222 let input = S.concat

267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

223 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

268 ]

224 ]

269− msWrite ms input

225+ hPutStr handle input

226+ hFlush handle

227+ hClose handle

270 threadDelay 1000

228 threadDelay 1000

271 headers <- I.readIORef iheaders

229 headers <- I.readIORef iheaders

272 headers `shouldBe`

230 headers `shouldBe`

@@ -275,24 +233,23 @@ spec = do

275

233

276 describe "chunked bodies" $ do

234 describe "chunked bodies" $ do

277 it "works" $ do

235 it "works" $ do

278− countVar <- newTVarIO (0 :: Int)

279 ifront <- I.newIORef id

236 ifront <- I.newIORef id

280 let app req f = do

237 let app req f = do

281− bss <- consumeBody $ getRequestBodyChunk req

238+ bss <- consumeBody $ requestBody req

282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

239 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

283− atomically $ modifyTVar countVar (+ 1)

284 f $ responseLBS status200 [] ""

240 f $ responseLBS status200 [] ""

285− withApp defaultSettings app $ withMySocket $ \ms -> do

241+ withApp defaultSettings app $ \port -> do

242+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

286 let input = S.concat

243 let input = S.concat

287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

244 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

288 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

245 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

289 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

246 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

290 , "b\r\nHello World\r\n0\r\n\r\n"

247 , "b\r\nHello World\r\n0\r\n\r\n"

291 ]

248 ]

292− msWrite ms input

249+ hPutStr handle input

293− atomically $ do

250+ hFlush handle

294− count <- readTVar countVar

251+ hClose handle

295− check $ count == 2

252+ threadDelay 1000

296 front <- I.readIORef ifront

253 front <- I.readIORef ifront

297 front [] `shouldBe`

254 front [] `shouldBe`

298 [ "Hello World\nBye"

255 [ "Hello World\nBye"

@@ -300,44 +257,38 @@ spec = do

300 ]

257 ]

301 it "lots of chunks" $ do

258 it "lots of chunks" $ do

302 ifront <- I.newIORef id

259 ifront <- I.newIORef id

303− countVar <- newTVarIO (0 :: Int)

304 let app req f = do

260 let app req f = do

305− bss <- consumeBody $ getRequestBodyChunk req

261+ bss <- consumeBody $ requestBody req

306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

262 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307− atomically $ modifyTVar countVar (+ 1)

308 f $ responseLBS status200 [] ""

263 f $ responseLBS status200 [] ""

309− withApp defaultSettings app $ withMySocket $ \ms -> do

264+ withApp defaultSettings app $ \port -> do

265+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

310 let input = concat $ replicate 2 $

266 let input = concat $ replicate 2 $

311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

267 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

312 (replicate 50 "5\r\n12345\r\n") ++

268 (replicate 50 "5\r\n12345\r\n") ++

313 ["0\r\n\r\n"]

269 ["0\r\n\r\n"]

314− mapM_ (msWrite ms) input

270+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input

315− atomically $ do

271+ hClose handle

316− count <- readTVar countVar

272+ threadDelay 100000 -- FIXME why does this delay need to be so high?

317− check $ count == 2

318 front <- I.readIORef ifront

273 front <- I.readIORef ifront

319 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

274 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

320−-- For some reason, the following test on Windows causes the socket

321−-- to be killed prematurely. Worth investigating in the future if possible.

322 it "in chunks" $ do

275 it "in chunks" $ do

323 ifront <- I.newIORef id

276 ifront <- I.newIORef id

324− countVar <- newTVarIO (0 :: Int)

325 let app req f = do

277 let app req f = do

326− bss <- consumeBody $ getRequestBodyChunk req

278+ bss <- consumeBody $ requestBody req

327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

279 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

328− atomically $ modifyTVar countVar (+ 1)

329 f $ responseLBS status200 [] ""

280 f $ responseLBS status200 [] ""

330− withApp defaultSettings app $ withMySocket $ \ms -> do

281+ withApp defaultSettings app $ \port -> do

282+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

331 let input = S.concat

283 let input = S.concat

332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

284 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

333 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

285 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

334 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

286 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

335 , "b\r\nHello World\r\n0\r\n\r\n"

287 , "b\r\nHello World\r\n0\r\n\r\n"

336 ]

288 ]

337− mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

289+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input

338− atomically $ do

290+ hClose handle

339− count <- readTVar countVar

291+ threadDelay 1000

340− check $ count == 2

341 front <- I.readIORef ifront

292 front <- I.readIORef ifront

342 front [] `shouldBe`

293 front [] `shouldBe`

343 [ "Hello World\nBye"

294 [ "Hello World\nBye"

@@ -346,7 +297,7 @@ spec = do

346 it "timeout in request body" $ do

297 it "timeout in request body" $ do

347 ifront <- I.newIORef id

298 ifront <- I.newIORef id

348 let app req f = do

299 let app req f = do

349− bss <- (consumeBody $ getRequestBodyChunk req) `onException`

300+ bss <- (consumeBody $ requestBody req) `onException`

350 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

301 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

351 liftIO $ threadDelay 4000000 `E.catch` \e -> do

302 liftIO $ threadDelay 4000000 `E.catch` \e -> do

352 I.atomicModifyIORef ifront (\front ->

303 I.atomicModifyIORef ifront (\front ->

@@ -355,18 +306,20 @@ spec = do

355 E.throwIO (e :: E.SomeException)

306 E.throwIO (e :: E.SomeException)

356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

357 f $ responseLBS status200 [] ""

308 f $ responseLBS status200 [] ""

358− withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

309+ withApp (setTimeout 1 defaultSettings) app $ \port -> do

359 let bs1 = S.replicate 2048 88

310 let bs1 = S.replicate 2048 88

360 bs2 = "This is short"

311 bs2 = "This is short"

361 bs = S.append bs1 bs2

312 bs = S.append bs1 bs2

313+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

362− msWrite ms "POST / HTTP/1.1\r\n"

314+ hPutStr handle "POST / HTTP/1.1\r\n"

363− msWrite ms "content-length: "

315+ hPutStr handle "content-length: "

364− msWrite ms $ S8.pack $ show $ S.length bs

316+ hPutStr handle $ S8.pack $ show $ S.length bs

365− msWrite ms "\r\n\r\n"

317+ hPutStr handle "\r\n\r\n"

366 threadDelay 100000

318 threadDelay 100000

367− msWrite ms bs1

319+ hPutStr handle bs1

368 threadDelay 100000

320 threadDelay 100000

369− msWrite ms bs2

321+ hPutStr handle bs2

322+ hClose handle

370 threadDelay 5000000

323 threadDelay 5000000

371 front <- I.readIORef ifront

324 front <- I.readIORef ifront

372 S.concat (front []) `shouldBe` bs

325 S.concat (front []) `shouldBe` bs

@@ -382,42 +335,39 @@ spec = do

382 loop

335 loop

383 loop

336 loop

384 doubleBS = S.concatMap $ \w -> S.pack [w, w]

337 doubleBS = S.concatMap $ \w -> S.pack [w, w]

385− withApp defaultSettings app $ withMySocket $ \ms -> do

338+ withApp defaultSettings app $ \port -> do

339+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

386− msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

340+ hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"

341+ hFlush handle

387− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

342+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")

388− msWrite ms "67890"

343+ hPutStr handle "67890"

344+ hFlush handle

389− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")

345+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")

346+

390 it "only one date and server header" $ do

347 it "only one date and server header" $ do

391 let app _ f = f $ responseLBS status200

348 let app _ f = f $ responseLBS status200

392 [ ("server", "server")

349 [ ("server", "server")

393 , ("date", "date")

350 , ("date", "date")

394 ] ""

351 ] ""

395− getValues key = map snd

396− . filter (\(key', _) -> key == key')

397− . responseHeaders

398 withApp defaultSettings app $ \port -> do

352 withApp defaultSettings app $ \port -> do

399 res <- sendGET $ "http://127.0.0.1:" ++ show port

353 res <- sendGET $ "http://127.0.0.1:" ++ show port

400− getValues hServer res `shouldBe` ["server"]

354+ getHeaderValue HdrServer res `shouldBe` Just "server"

401− getValues hDate res `shouldBe` ["date"]

355+ getHeaderValue HdrDate res `shouldBe` Just "date"

402

356

403 it "streaming echo #249" $ do

357 it "streaming echo #249" $ do

404− countVar <- newTVarIO (0 :: Int)

405 let app req f = f $ responseStream status200 [] $ \write _ -> do

358 let app req f = f $ responseStream status200 [] $ \write _ -> do

406− let loop = do

359+ let loop = do

407− bs <- getRequestBodyChunk req

360+ bs <- requestBody req

408 unless (S.null bs) $ do

361 unless (S.null bs) $ do

409 write $ byteString bs

362 write $ byteString bs

410− atomically $ modifyTVar countVar (+ 1)

411 loop

363 loop

412− loop

364+ loop

413− withApp defaultSettings app $ withMySocket $ \ms -> do

365+ withApp defaultSettings app $ \port -> do

366+ (socket, _addr) <- getSocketTCP "127.0.0.1" port

414− msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

367+ sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

415 threadDelay 10000

368 threadDelay 10000

416− msWrite ms "5\r\nhello\r\n0\r\n\r\n"

369+ sendAll socket "5\r\nhello\r\n0\r\n\r\n"

417− atomically $ do

418− count <- readTVar countVar

419− check $ count >= 1

420− bs <- safeRecv (msSocket ms) 4096 -- must not use msRead

370+ bs <- safeRecv socket 4096

421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

371 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

422

372

423 it "streaming response with length" $ do

373 it "streaming response with length" $ do

@@ -425,7 +375,7 @@ spec = do

425 replicateM_ 4 $ write $ byteString "Hello"

375 replicateM_ 4 $ write $ byteString "Hello"

426 withApp defaultSettings app $ \port -> do

376 withApp defaultSettings app $ \port -> do

427 res <- sendGET $ "http://127.0.0.1:" ++ show port

377 res <- sendGET $ "http://127.0.0.1:" ++ show port

428− responseBody res `shouldBe` "HelloHelloHelloHello"

378+ rspBody res `shouldBe` "HelloHelloHelloHello"

429

379

430 describe "head requests" $ do

380 describe "head requests" $ do

431 let fp = "test/head-response"

381 let fp = "test/head-response"

@@ -438,19 +388,19 @@ spec = do

438 _ -> error "invalid path"

388 _ -> error "invalid path"

439 it "builder" $ withApp defaultSettings app $ \port -> do

389 it "builder" $ withApp defaultSettings app $ \port -> do

440 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

390 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

441− responseBody res `shouldBe` ""

391+ rspBody res `shouldBe` ""

442 it "streaming" $ withApp defaultSettings app $ \port -> do

392 it "streaming" $ withApp defaultSettings app $ \port -> do

443 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

393 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

444− responseBody res `shouldBe` ""

394+ rspBody res `shouldBe` ""

445 it "file, no range" $ withApp defaultSettings app $ \port -> do

395 it "file, no range" $ withApp defaultSettings app $ \port -> do

446 bs <- S.readFile fp

396 bs <- S.readFile fp

447 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

397 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

448− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs)

398+ getHeaderValue HdrContentLength res `shouldBe` Just (show $ S.length bs)

449 it "file, with range" $ withApp defaultSettings app $ \port -> do

399 it "file, with range" $ withApp defaultSettings app $ \port -> do

450 res <- sendHEADwH

400 res <- sendHEADwH

451 (concat ["http://127.0.0.1:", show port, "/file"])

401 (concat ["http://127.0.0.1:", show port, "/file"])

452− [(hRange, "bytes=0-1")]

402+ [mkHeader HdrRange "bytes=0-1"]

453− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2"

403+ getHeaderValue HdrContentLength res `shouldBe` Just "2"

454

404

455consumeBody :: IO ByteString -> IO [ByteString]

405consumeBody :: IO ByteString -> IO [ByteString]

456consumeBody body =

406consumeBody body =

warp/test/WithApplicationSpec.hs+16−16

@@ -2,10 +2,13 @@

2

3module WithApplicationSpec where

4

5+import Control.Concurrent

5import Control.Exception

6import Control.Exception

6import Network.HTTP.Types

7import Network.HTTP.Types

8+import Network.Socket

7import Network.Wai

9import Network.Wai

8−import System.Environment

10+import System.IO

11+import System.IO.Silently

9import System.Process

12import System.Process

10import Test.Hspec

13import Test.Hspec

11

14

@@ -13,9 +16,6 @@ import Network.Wai.Handler.Warp.WithApplication

13

16

14spec :: Spec

17spec :: Spec

15spec = do

18spec = do

16− runIO $ do

17− unsetEnv "http_proxy"

18− unsetEnv "https_proxy"

19 describe "withApplication" $ do

20 it "runs a wai Application while executing the given action" $ do

21 let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"

@@ -23,23 +23,23 @@ spec = do

23 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

24 output `shouldBe` "foo"

25

26− it "does not propagate exceptions from the server to the executing thread" $ do

26+ it "does not propagate exceptions from the server to the executing thread" $

27+ hSilence [stderr] $ do

27− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

28+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

28− withApplication mkApp $ \ port -> do

29+ withApplication mkApp $ \ port -> do

29− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

30+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

30− output `shouldContain` "Something went wron"

31+ output `shouldContain` "Something went wron"

31

32

32 describe "testWithApplication" $ do

33 describe "testWithApplication" $ do

33− it "propagates exceptions from the server to the executing thread" $ do

34+ it "propagates exceptions from the server to the executing thread" $

35+ hSilence [stderr] $ do

34− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

36+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

35− (testWithApplication mkApp $ \ port -> do

37+ (testWithApplication mkApp $ \ port -> do

36− readProcess "curl" ["-s", "localhost:" ++ show port] "")

38+ readProcess "curl" ["-s", "localhost:" ++ show port] "")

37− `shouldThrow` (errorCall "foo")

39+ `shouldThrow` (errorCall "foo")

38

40

39−{- The future netwrok library will not export MkSocket.

40 describe "withFreePort" $ do

41 describe "withFreePort" $ do

41 it "closes the socket before exiting" $ do

42 it "closes the socket before exiting" $ do

42 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

43 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

43 return sock

44 return sock

44 readMVar statusMVar `shouldReturn` Closed

45 readMVar statusMVar `shouldReturn` Closed

45−-}

warp/warp.cabal+44−109

@@ -1,5 +1,5 @@

1Name: warp

2−Version: 3.3.9

2+Version: 3.2.13

3Synopsis: A fast, light-weight web server for WAI applications.

4License: MIT

5License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

8Homepage: http://github.com/yesodweb/wai

9Category: Web, Yesod

10Build-Type: Simple

11−Cabal-Version: >= 1.10

11+Cabal-Version: >=1.8

12Stability: Stable

13description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.

14 For HTTP\/2, Warp supports direct and ALPN (in TLS)

@@ -37,28 +37,24 @@ Library

37 , array

38 , async

39 , auto-update >= 0.1.3 && < 0.2

40− , bsb-http-chunked < 0.1

40+ , blaze-builder >= 0.4

41 , bytestring >= 0.9.1.4

42 , case-insensitive >= 0.2

43 , containers

44 , ghc-prim

45− , hashable

46− , http-date

47− , http-types >= 0.12

45+ , http-types >= 0.9.1

48− , http2 >= 2.0 && < 2.1

49 , iproute >= 1.3.1

46 , iproute >= 1.3.1

47+ , http2 >= 1.6 && < 1.7

50 , simple-sendfile >= 0.2.7 && < 0.3

48 , simple-sendfile >= 0.2.7 && < 0.3

51− , stm >= 2.3

52− , streaming-commons >= 0.1.10

53− , text

54− , time-manager

55 , unix-compat >= 0.2

49 , unix-compat >= 0.2

56− , vault >= 0.3

57 , wai >= 3.2 && < 3.3

50 , wai >= 3.2 && < 3.3

51+ , text

52+ , streaming-commons >= 0.1.10

53+ , vault >= 0.3

54+ , stm >= 2.3

58 , word8

55 , word8

59− , x509

56+ , hashable

60− if impl(ghc < 8)

57+ , http-date

61− Build-Depends: semigroups

62 if flag(network-bytestring)

58 if flag(network-bytestring)

63 Build-Depends: network >= 2.2.1.5 && < 2.2.3

59 Build-Depends: network >= 2.2.1.5 && < 2.2.3

64 , network-bytestring >= 0.1.3 && < 0.1.4

60 , network-bytestring >= 0.1.3 && < 0.1.4

@@ -75,14 +71,17 @@ Library

75 Network.Wai.Handler.Warp.FileInfoCache

71 Network.Wai.Handler.Warp.FileInfoCache

76 Network.Wai.Handler.Warp.HashMap

72 Network.Wai.Handler.Warp.HashMap

77 Network.Wai.Handler.Warp.HTTP2

73 Network.Wai.Handler.Warp.HTTP2

74+ Network.Wai.Handler.Warp.HTTP2.EncodeFrame

78 Network.Wai.Handler.Warp.HTTP2.File

75 Network.Wai.Handler.Warp.HTTP2.File

79− Network.Wai.Handler.Warp.HTTP2.PushPromise

76+ Network.Wai.Handler.Warp.HTTP2.HPACK

77+ Network.Wai.Handler.Warp.HTTP2.Manager

78+ Network.Wai.Handler.Warp.HTTP2.Receiver

80 Network.Wai.Handler.Warp.HTTP2.Request

79 Network.Wai.Handler.Warp.HTTP2.Request

81− Network.Wai.Handler.Warp.HTTP2.Response

80+ Network.Wai.Handler.Warp.HTTP2.Sender

82 Network.Wai.Handler.Warp.HTTP2.Types

81 Network.Wai.Handler.Warp.HTTP2.Types

82+ Network.Wai.Handler.Warp.HTTP2.Worker

83 Network.Wai.Handler.Warp.Header

84 Network.Wai.Handler.Warp.IO

85− Network.Wai.Handler.Warp.Imports

86 Network.Wai.Handler.Warp.PackInt

85 Network.Wai.Handler.Warp.PackInt

87 Network.Wai.Handler.Warp.ReadInt

86 Network.Wai.Handler.Warp.ReadInt

88 Network.Wai.Handler.Warp.Recv

87 Network.Wai.Handler.Warp.Recv

@@ -93,6 +92,8 @@ Library

93 Network.Wai.Handler.Warp.Run

92 Network.Wai.Handler.Warp.Run

94 Network.Wai.Handler.Warp.SendFile

93 Network.Wai.Handler.Warp.SendFile

95 Network.Wai.Handler.Warp.Settings

94 Network.Wai.Handler.Warp.Settings

95+ Network.Wai.Handler.Warp.Some

96+ Network.Wai.Handler.Warp.Timeout

96 Network.Wai.Handler.Warp.Types

97 Network.Wai.Handler.Warp.Types

97 Network.Wai.Handler.Warp.Windows

98 Network.Wai.Handler.Warp.Windows

98 Network.Wai.Handler.Warp.WithApplication

99 Network.Wai.Handler.Warp.WithApplication

@@ -109,23 +110,14 @@ Library

109 else

110 else

110 Build-Depends: unix

111 Build-Depends: unix

111 Other-modules: Network.Wai.Handler.Warp.MultiMap

112 Other-modules: Network.Wai.Handler.Warp.MultiMap

112− if impl(ghc >= 8)

113− Default-Extensions: Strict StrictData

114− Default-Language: Haskell2010

115

113

116Test-Suite doctest

114Test-Suite doctest

117− buildable: False

118 Type: exitcode-stdio-1.0

115 Type: exitcode-stdio-1.0

119 HS-Source-Dirs: test

116 HS-Source-Dirs: test

120 Ghc-Options: -threaded -Wall

117 Ghc-Options: -threaded -Wall

121 Main-Is: doctests.hs

118 Main-Is: doctests.hs

122 Build-Depends: base >= 4.8 && < 5

119 Build-Depends: base >= 4.8 && < 5

123 , doctest >= 0.10.1

120 , doctest >= 0.10.1

124− if os(windows)

125− Buildable: False

126− if impl(ghc >= 8)

127− Default-Extensions: Strict StrictData

128− Default-Language: Haskell2010

129

121

130Test-Suite spec

122Test-Suite spec

131 Main-Is: Spec.hs

123 Main-Is: Spec.hs

@@ -142,128 +134,71 @@ Test-Suite spec

142 SendFileSpec

134 SendFileSpec

143 WithApplicationSpec

135 WithApplicationSpec

144 HTTP

136 HTTP

145− Network.Wai.Handler.Warp

146− Network.Wai.Handler.Warp.Buffer

147− Network.Wai.Handler.Warp.Conduit

148− Network.Wai.Handler.Warp.Counter

149− Network.Wai.Handler.Warp.Date

150− Network.Wai.Handler.Warp.FdCache

151− Network.Wai.Handler.Warp.File

152− Network.Wai.Handler.Warp.FileInfoCache

153− Network.Wai.Handler.Warp.HTTP2

154− Network.Wai.Handler.Warp.HTTP2.File

155− Network.Wai.Handler.Warp.HTTP2.PushPromise

156− Network.Wai.Handler.Warp.HTTP2.Request

157− Network.Wai.Handler.Warp.HTTP2.Response

158− Network.Wai.Handler.Warp.HTTP2.Types

159− Network.Wai.Handler.Warp.HashMap

160− Network.Wai.Handler.Warp.Header

161− Network.Wai.Handler.Warp.IO

162− Network.Wai.Handler.Warp.Imports

163− Network.Wai.Handler.Warp.MultiMap

164− Network.Wai.Handler.Warp.PackInt

165− Network.Wai.Handler.Warp.ReadInt

166− Network.Wai.Handler.Warp.Recv

167− Network.Wai.Handler.Warp.Request

168− Network.Wai.Handler.Warp.RequestHeader

169− Network.Wai.Handler.Warp.Response

170− Network.Wai.Handler.Warp.ResponseHeader

171− Network.Wai.Handler.Warp.Run

172− Network.Wai.Handler.Warp.SendFile

173− Network.Wai.Handler.Warp.Settings

174− Network.Wai.Handler.Warp.Types

175− Network.Wai.Handler.Warp.Windows

176− Network.Wai.Handler.Warp.WithApplication

177− Paths_warp

178−

179 Hs-Source-Dirs: test, .

137 Hs-Source-Dirs: test, .

180 Type: exitcode-stdio-1.0

138 Type: exitcode-stdio-1.0

181

139

182− Ghc-Options: -Wall -threaded

140+ Ghc-Options: -Wall

183 Build-Depends: base >= 4.8 && < 5

141 Build-Depends: base >= 4.8 && < 5

184− , HUnit

185− , QuickCheck

186 , array

142 , array

187− , async

188 , auto-update

143 , auto-update

189− , bsb-http-chunked < 0.1

144+ , blaze-builder >= 0.4

190 , bytestring >= 0.9.1.4

145 , bytestring >= 0.9.1.4

191 , case-insensitive >= 0.2

146 , case-insensitive >= 0.2

192− , containers

193− , directory

194 , ghc-prim

147 , ghc-prim

195− , hashable

148+ , HTTP

196− , hspec >= 1.3

197− , http-client

198− , http-date

199− , http-types >= 0.12

149+ , http-types >= 0.8.5

200− , http2 >= 2.0 && < 2.1

201 , iproute >= 1.3.1

150 , iproute >= 1.3.1

202 , lifted-base >= 0.1

151 , lifted-base >= 0.1

203− , network

204− , process

205 , simple-sendfile >= 0.2.4 && < 0.3

152 , simple-sendfile >= 0.2.4 && < 0.3

206− , stm >= 2.3

153+ , transformers >= 0.2.2

207− , streaming-commons >= 0.1.10

208− , text

209− , time

210− , time-manager

211 , unix-compat >= 0.2

154 , unix-compat >= 0.2

212− , vault

213 , wai >= 3.2 && < 3.3

155 , wai >= 3.2 && < 3.3

156+ , network

157+ , HUnit

158+ , QuickCheck

159+ , hspec >= 1.3

160+ , time

161+ , text

162+ , streaming-commons >= 0.1.10

163+ , silently

164+ , async

165+ , vault

166+ , stm >= 2.3

167+ , directory

168+ , process

169+ , containers

170+ , http2 >= 1.6 && < 1.7

214 , word8

171 , word8

215− , x509

172+ , hashable

216− -- Build-Tool-Depends: hspec-discover:hspec-discover

173+ , http-date

217− if impl(ghc < 8)

218− Build-Depends: semigroups

219− , transformers

220

174

221 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

175 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

222 Cpp-Options: -DSENDFILEFD

176 Cpp-Options: -DSENDFILEFD

223 Build-Depends: unix

177 Build-Depends: unix

224 if os(windows)

178 if os(windows)

225− Cpp-Options: -DWINDOWS

179+ Cpp-Options: -DWINDOWS

226− Build-Depends: time

227− if impl(ghc >= 8)

228− Default-Extensions: Strict StrictData

229− Default-Language: Haskell2010

230

180

231Benchmark parser

181Benchmark parser

232 Type: exitcode-stdio-1.0

182 Type: exitcode-stdio-1.0

233 Main-Is: Parser.hs

183 Main-Is: Parser.hs

234− other-modules: Network.Wai.Handler.Warp.Date

235− Network.Wai.Handler.Warp.FdCache

236− Network.Wai.Handler.Warp.FileInfoCache

237− Network.Wai.Handler.Warp.HashMap

238− Network.Wai.Handler.Warp.Imports

239− Network.Wai.Handler.Warp.MultiMap

240− Network.Wai.Handler.Warp.Types

241 HS-Source-Dirs: bench .

184 HS-Source-Dirs: bench .

242 Build-Depends: base >= 4.8 && < 5

185 Build-Depends: base >= 4.8 && < 5

243 , auto-update

186 , auto-update

244 , bytestring

187 , bytestring

245 , containers

188 , containers

246− , gauge

189+ , criterion >= 1

247 , hashable

190 , hashable

248 , http-date

191 , http-date

249 , http-types

192 , http-types

250 , network

193 , network

251 , network

194 , network

252− , time-manager

253 , unix-compat

195 , unix-compat

254− , x509

255− if impl(ghc < 8)

256− Build-Depends: semigroups

257

196

258 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

197 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

259 Cpp-Options: -DSENDFILEFD

198 Cpp-Options: -DSENDFILEFD

260 Build-Depends: unix

199 Build-Depends: unix

261 if os(windows)

200 if os(windows)

262− Cpp-Options: -DWINDOWS

201+ Cpp-Options: -DWINDOWS

263− Build-Depends: time

264− if impl(ghc >= 8)

265− Default-Extensions: Strict StrictData

266− Default-Language: Haskell2010

267

202

268Source-Repository head

203Source-Repository head

269 Type: git

204 Type: git