on dd79377 help sign in
.azure/azure-linux-template.ymldeleted−93
since splitsnapshots
unifiedsplit
@@ -1,93 +0,0 @@
1−jobs:
2−- job: ${{ parameters.name }}
3− timeoutInMinutes: 180
4− pool:
5− vmImage: ${{ parameters.vmImage }}
6− strategy:
7− matrix:
8− stack-lts-11:
9− BUILD: stack
10− STACK_YAML: stack-lts-11.yaml
11− ARGS: "--resolver lts-11"
12− stack-lts-12:
13− BUILD: stack
14− STACK_YAML: stack-lts-12.yaml
15− ARGS: "--resolver lts-12"
16− stack-lts-14:
17− BUILD: stack
18− ARGS: "--resolver lts-14"
19− stack-nightly:
20− BUILD: stack
21− STACK_YAML: stack-nightly.yaml
22− ARGS: "--resolver nightly"
23− cabal-8.2.2:
24− BUILD: cabal
25− GHCVER: 8.4.4
26− CABALVER: 2.0
27− cabal-8.4.4:
28− BUILD: cabal
29− GHCVER: 8.4.4
30− CABALVER: 2.2
31− cabal-8.6.5:
32− BUILD: cabal
33− GHCVER: 8.6.5
34− CABALVER: 2.4
35− maxParallel: 6
36− steps:
37− - script: |
38− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
39− mkdir -p ~/.local/bin
40− curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
41− case "$BUILD" in
42− cabal)
43− sudo add-apt-repository -y ppa:hvr/ghc
44− sudo apt-get update
45− sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
46− # See note here: https://github.com/haskell-CI/haskell-ci#alex--happy-with-ghc--78
47− if [ "$GHCVER" = "head" ] || [ "${GHCVER%.*}" = "7.8" ] || [ "${GHCVER%.*}" = "7.10" ]; then
48− sudo apt-get install happy-1.19.4 alex-3.1.3
49− export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH
50− else
51− sudo apt-get install happy alex
52− fi
53− export PATH=$HOME/.local/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
54− cabal --version
55− cabal update
56− PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
57− cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
58− ;;
59− *)
60− export PATH=$HOME/.local/bin:$PATH
61− stack --install-ghc $ARGS test --bench --only-dependencies
62− ;;
63− esac
64− set -ex
65− case "$BUILD" in
66− cabal)
67− cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
68−
69− ORIGDIR=$(pwd)
70− for dir in $PACKAGES
71− do
72− cd $dir
73− cabal check || [ "$CABALVER" == "1.22" ] # https://github.com/yesodweb/wai/pull/754#issuecomment-504866279
74− cabal sdist
75− PKGVER=$(cabal info . | awk '{print $2;exit}')
76− SRC_TGZ=$PKGVER.tar.gz
77− cd dist
78− tar zxfv "$SRC_TGZ"
79− cd "$PKGVER"
80− cabal configure --enable-tests --ghc-options -O0
81− cabal build
82− cabal test --show-details=streaming
83− cd $ORIGDIR
84− done
85− ;;
86− *)
87− stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
88− ;;
89− esac
90− set +ex
91− env:
92− OS_NAME: ${{ parameters.os }}
93− displayName: 'Installation ${{parameters.os}} & Test'
.azure/azure-osx-template.ymldeleted−30
@@ -1,30 +0,0 @@
1−jobs:
2−- job: ${{ parameters.name }}
3− timeoutInMinutes: 180
4− pool:
5− vmImage: ${{ parameters.vmImage }}
6− strategy:
7− matrix:
8− stack-lts-11:
9− BUILD: stack
10− STACK_YAML: stack-lts-11.yaml
11− ARGS: "--resolver lts-11"
12− stack-lts-12:
13− BUILD: stack
14− STACK_YAML: stack-lts-12.yaml
15− ARGS: "--resolver lts-12"
16− stack-lts-14:
17− BUILD: stack
18− ARGS: "--resolver lts-14"
19− maxParallel: 3
20− steps:
21− - script: |
22− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
23− mkdir -p ~/.local/bin
24− curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
25− export PATH=$HOME/.local/bin:$PATH
26− stack --install-ghc $ARGS test --bench --only-dependencies
27− stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
28− env:
29− OS_NAME: ${{ parameters.os }}
30− displayName: 'Installation ${{parameters.os}} & Test'
.azure/azure-pipelines.ymldeleted−30
@@ -1,30 +0,0 @@
1−# This is the complex Azure configuration, which is intended for use
2−# on open source libraries which need compatibility across multiple GHC
3−# versions, must work with cabal-install, and should be
4−# cross-platform. For more information and other options, see:
5−#
6−# https://docs.haskellstack.org/en/stable/azure_ci/
7−#
8−# Copy these contents into the root directory of your Github project in a file
9−# named azure-pipelines.yml
10−#
11−# For better organization, you split various jobs into seprate parts
12−# and each of them are controlled via individual file.
13−jobs:
14−- template: azure-linux-template.yml
15− parameters:
16− name: Linux
17− vmImage: ubuntu-16.04
18− os: linux
19−
20−- template: azure-osx-template.yml
21− parameters:
22− name: macOS
23− vmImage: macOS-10.13
24− os: osx
25−
26−- template: azure-windows-template.yml
27− parameters:
28− name: Windows
29− vmImage: vs2017-win2016
30− os: windows
.azure/azure-windows-template.ymldeleted−23
@@ -1,23 +0,0 @@
1−jobs:
2−- job: ${{ parameters.name }}
3− timeoutInMinutes: 180
4− pool:
5− vmImage: ${{ parameters.vmImage }}
6− strategy:
7− matrix:
8− stack-lts-14:
9− BUILD: stack
10− ARGS: "--resolver lts-14"
11− maxParallel: 3
12− steps:
13− - bash: |
14− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
15− curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
16− unzip -o /usr/bin/stack.zip -d /usr/bin/
17− stack setup $ARGS > /dev/null
18− stack --install-ghc $ARGS test --bench --only-dependencies
19− stack $ARGS test --bench --no-run-benchmarks --no-run-tests
20− stack $ARGS test --bench --no-run-benchmarks --jobs 1 # non-parallel test execution
21− env:
22− OS_NAME: ${{ parameters.os }}
23− displayName: 'Installation ${{parameters.os}} & Test'
.gitignore−2
@@ -8,5 +8,3 @@ tarballs/
8.cabal-sandbox/
8.cabal-sandbox/
9cabal.sandbox.config
9cabal.sandbox.config
10.stack-work/
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
README.md+1−1
@@ -10,4 +10,4 @@ Code can be written that works with any web framework targeting WAI.
10
10
11[Haddock Documentation](http://hackage.haskell.org/package/wai)
11[Haddock Documentation](http://hackage.haskell.org/package/wai)
12
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'
11-- printString <- 'mkDebounce' 'defaultDebounceSettings'
12-- { 'debounceAction' = putStrLn "Running action"
12-- { 'debounceAction' = putStrLn "Running action"
13-- , 'debounceFreq' = 5000000 -- 5 seconds
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
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,
50 -- \"workload modifying\" function. In the common case of using lists,
51 -- the result should be a difference list that prepends the remaining
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
1name: auto-update
2−version: 0.1.6
2+version: 0.1.4
3synopsis: Efficiently run periodic, on-demand actions
3synopsis: Efficiently run periodic, on-demand actions
4description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.
4description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.
5homepage: https://github.com/yesodweb/wai
5homepage: https://github.com/yesodweb/wai
@@ -17,22 +17,18 @@ library
17 ghc-options: -Wall
17 ghc-options: -Wall
18 exposed-modules: Control.AutoUpdate
18 exposed-modules: Control.AutoUpdate
19 Control.Debounce
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
1module Control.AutoUpdateSpec (spec) where
2
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
9
10spec :: Spec
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
1module Control.ReaperSpec (spec) where
2
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
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")
531 , ("mime", "message/rfc822")
532 , ("mj2", "video/mj2")
532 , ("mj2", "video/mj2")
533 , ("mjp2", "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
1name: mime-types
2−version: 0.1.0.9
2+version: 0.1.0.7
3synopsis: Basic mime-type handling types and functions
3synopsis: Basic mime-type handling types and functions
4description: API docs and the README are available at <http://www.stackage.org/package/mime-types>.
4description: API docs and the README are available at <http://www.stackage.org/package/mime-types>.
5homepage: https://github.com/yesodweb/wai
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:
2packages:
3- ./auto-update
3- ./auto-update
4- ./mime-types
4- ./mime-types
@@ -7,19 +7,33 @@ packages:
7- ./warp
7- ./warp
8- ./warp-tls
8- ./warp-tls
9- ./wai-app-static
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 @@
1+Copyright (c) 2017, IIJ Innovation Institute Inc.
2+All rights reserved.
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 ()
34import Data.ByteString.Lazy.Char8 ()
35import Control.Monad.IO.Class (liftIO)
35import Control.Monad.IO.Class (liftIO)
36
36
37−import Data.ByteString.Builder (toLazyByteString)
37+import Blaze.ByteString.Builder (toByteString)
38
38
39import Data.FileEmbed (embedFile)
39import Data.FileEmbed (embedFile)
40
40
@@ -164,13 +164,11 @@ serveFile StaticSettings {..} req file
164 -- Didn't match, but we have a hash value. Send the file contents
164 -- Didn't match, but we have a hash value. Send the file contents
165 -- with an ETag header.
165 -- with an ETag header.
166 --
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 }
39 }
40
40
41#if MIN_VERSION_optparse_applicative(0, 10, 0)
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
64
65 -- Add a link to the root of the tree
65 -- Add a link to the root of the tree
66 showFolder' :: Bool -> Pieces -> H.Html
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
68
69 showFolder :: Bool -> Pieces -> H.Html
69 showFolder :: Bool -> Pieces -> H.Html
70 showFolder _ [] = "/" -- won't happen
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)
8import Data.ByteString (ByteString)
9import Control.Arrow ((&&&), second)
9import Control.Arrow ((&&&), second)
10import Data.List
10import Data.List
11−import Data.ByteString.Builder (byteString)
11+import Blaze.ByteString.Builder (fromByteString)
12import qualified Network.Wai as W
12import qualified Network.Wai as W
13import qualified Data.Map as Map
13import qualified Data.Map as Map
14import Data.Function (on)
14import Data.Function (on)
@@ -50,7 +50,7 @@ toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File
50toEntry (name, EEFolder{}) = Left name
50toEntry (name, EEFolder{}) = Left name
51toEntry (name, EEFile bs) = Right File
51toEntry (name, EEFile bs) = Right File
52 { fileGetSize = fromIntegral $ S.length bs
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
54 , fileName = name
55 , fileGetHash = return $ Just $ runHash bs
55 , fileGetHash = return $ Just $ runHash bs
56 , fileGetModified = Nothing
56 , fileGetModified = Nothing
@@ -87,7 +87,7 @@ toEmbedded fps =
87bsToFile :: Piece -> ByteString -> File
87bsToFile :: Piece -> ByteString -> File
88bsToFile name bs = File
88bsToFile name bs = File
89 { fileGetSize = fromIntegral $ S.length bs
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
91 , fileName = name
92 , fileGetHash = return $ Just $ runHash bs
92 , fileGetHash = return $ Just $ runHash bs
93 , fileGetModified = Nothing
93 , fileGetModified = Nothing
wai-app-static/WaiAppStatic/Storage/Embedded/TH.hs+3−2
@@ -5,8 +5,9 @@ module WaiAppStatic.Storage.Embedded.TH(
5 , mkSettings
5 , mkSettings
6) where
6) where
7
7
8−import Data.ByteString.Builder.Extra (byteStringInsert)
8+import Blaze.ByteString.Builder.ByteString (insertByteString)
9import Codec.Compression.GZip (compress)
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 =<<
57 assertStatus 200 =<<
58 request (setRawPathInfo defRequest path)
58 request (setRawPathInfo defRequest path)
59
59
60− it "404 for non-existent files" $ webApp $
60+ it "404 for non-existant files" $ webApp $
61 assertStatus 404 =<<
61 assertStatus 404 =<<
62 request (setRawPathInfo defRequest "doesNotExist")
62 request (setRawPathInfo defRequest "doesNotExist")
63
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")
65 req <- request (setRawPathInfo defRequest "a//b/c")
66− assertStatus 302 req
66+ assertStatus 301 req
67 assertHeader "Location" "../../a/b/c" req
67 assertHeader "Location" "../../a/b/c" req
68
68
69 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {
69 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {
70 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
70 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
71 }
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
73 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
74 req <- request (setRawPathInfo defRequest path)
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
76 assertHeader "Location" "http://www.example.com/a/b/c" req
77
77
78 describe "webApp when requesting a static asset" $ do
78 describe "webApp when requesting a static asset" $ do
@@ -131,10 +131,10 @@ spec = do
131 assertStatus 304 req
131 assertStatus 304 req
132 assertNoHeader "Cache-Control" req
132 assertNoHeader "Cache-Control" req
133
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
135 it "works at the root" $ fileServerApp $ do
136 req <- request (setRawPathInfo defRequest "/a")
136 req <- request (setRawPathInfo defRequest "/a")
137− assertStatus 302 req
137+ assertStatus 301 req
138 assertHeader "Location" "/a/" req
138 assertHeader "Location" "/a/" req
139
139
140 it "works when an index.html is delivered" $ do
140 it "works when an index.html is delivered" $ do
@@ -144,7 +144,7 @@ spec = do
144 inTempDirectory $ fileServerAppWithSettings settings $ do
144 inTempDirectory $ fileServerAppWithSettings settings $ do
145 liftIO $ touch "foo/index.html"
145 liftIO $ touch "foo/index.html"
146 req <- request (setRawPathInfo defRequest "/foo")
146 req <- request (setRawPathInfo defRequest "/foo")
147− assertStatus 302 req
147+ assertStatus 301 req
148 assertHeader "Location" "/foo/" req
148 assertHeader "Location" "/foo/" req
149
149
150 let urlMapApp = flip runSession $ \req send ->
150 let urlMapApp = flip runSession $ \req send ->
@@ -158,7 +158,7 @@ spec = do
158 "urlMapApp: only works at subPath"
158 "urlMapApp: only works at subPath"
159 it "works with subpath at the root of the file server" $ urlMapApp $ do
159 it "works with subpath at the root of the file server" $ urlMapApp $ do
160 req <- request (setRawPathInfo defRequest "/subPath")
160 req <- request (setRawPathInfo defRequest "/subPath")
161− assertStatus 302 req
161+ assertStatus 301 req
162 assertHeader "Location" "/subPath/" req
162 assertHeader "Location" "/subPath/" req
163
163
164 context "with defaultWebAppSettings" $ do
164 context "with defaultWebAppSettings" $ do
wai-app-static/wai-app-static.cabal+6−5
@@ -1,5 +1,5 @@
1name: wai-app-static
1name: wai-app-static
2−version: 3.1.7.1
2+version: 3.1.6.1
3license: MIT
3license: MIT
4license-file: LICENSE
4license-file: LICENSE
5author: Michael Snoyman <michael@snoyman.com>
5author: Michael Snoyman <michael@snoyman.com>
@@ -27,7 +27,7 @@ Flag print
27library
27library
28 build-depends: base >= 4 && < 5
28 build-depends: base >= 4 && < 5
29 , wai >= 3.0 && < 3.3
29 , wai >= 3.0 && < 3.3
30− , bytestring >= 0.10.4
30+ , bytestring >= 0.9.1.4
31 , http-types >= 0.7
31 , http-types >= 0.7
32 , transformers >= 0.2.2
32 , transformers >= 0.2.2
33 , unix-compat >= 0.2
33 , unix-compat >= 0.2
@@ -37,6 +37,7 @@ library
37 , old-locale >= 1.0.0.2
37 , old-locale >= 1.0.0.2
38 , file-embed >= 0.0.3.1
38 , file-embed >= 0.0.3.1
39 , text >= 0.7
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
16import qualified Data.ByteString as S
17import Control.Monad (unless)
17import Control.Monad (unless)
18import Network.HTTP.Types
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
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
1name: wai-conduit
2−version: 3.0.0.4
2+version: 3.0.0.3
3synopsis: conduit wrappers for WAI
3synopsis: conduit wrappers for WAI
4description: API docs and the README are available at <http://www.stackage.org/package/wai-conduit>.
4description: API docs and the README are available at <http://www.stackage.org/package/wai-conduit>.
5homepage: https://github.com/yesodweb/wai
5homepage: https://github.com/yesodweb/wai
@@ -18,6 +18,7 @@ library
18 , wai >= 3.0 && < 3.3
18 , wai >= 3.0 && < 3.3
19 , conduit
19 , conduit
20 , transformers
20 , transformers
21− , bytestring >= 0.10.4
21+ , bytestring
22 , http-types
22 , http-types
23+ , blaze-builder
23 default-language: Haskell2010
24 default-language: Haskell2010
wai-extra/ChangeLog.md−68
@@ -1,71 +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
1## 3.0.20.2
70
2
71* Revert previous change to `srequest`, which caused breakage
3* Revert previous change to `srequest`, which caused breakage
wai-extra/Network/Wai/EventSource.hs+1−19
@@ -5,14 +5,11 @@
5 headers:
5 headers:
6
6
7 > [ ("X-Accel-Buffering", "no"), ("Cache-Control", "no-cache")]
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 #-}
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
3
4{-|
4{-|
5 Internal module, usually you don't need to use it.
5 Internal module, usually you don't need to use it.
@@ -9,7 +9,8 @@ module Network.Wai.EventSource.EventStream (
9 eventToBuilder
9 eventToBuilder
10 ) where
10 ) where
11
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
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
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)
19import Data.Char (toLower)
20import qualified System.IO
20import qualified System.IO
21import qualified Data.String as String
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)
24import Data.ByteString.Lazy.Internal (defaultChunkSize)
25import System.IO (Handle)
25import System.IO (Handle)
26import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)
26import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)
@@ -29,8 +29,7 @@ import qualified Data.CaseInsensitive as CI
29#if __GLASGOW_HASKELL__ < 710
29#if __GLASGOW_HASKELL__ < 710
30import Data.Monoid (mconcat, mempty, mappend)
30import Data.Monoid (mconcat, mempty, mappend)
31#endif
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
14readInt :: S8.ByteString -> Maybe Integer
15readInt bs =
15readInt bs =
16 case S8.readInteger bs of
16 case S8.readInteger bs of
17− Just (i, rest) | S8.null rest -> Just i
17+ Just (i, "") -> Just i
18 _ -> Nothing
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
30import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent
31 , hContentType, hContentLength)
31 , hContentType, hContentLength)
32import System.Directory (doesFileExist, createDirectoryIfMissing)
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)
41import Control.Monad (unless)
42import Data.Function (fix)
42import Data.Function (fix)
43import Control.Exception (throwIO)
43import Control.Exception (throwIO)
@@ -69,7 +69,7 @@ instance Default GzipSettings where
69 def = GzipSettings GzipIgnore defaultCheckMime
69 def = GzipSettings GzipIgnore defaultCheckMime
70
70
71-- | MIME types that will be compressed by default:
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@.
73-- @application/ecmascript@, @image/x-icon@.
74defaultCheckMime :: S.ByteString -> Bool
74defaultCheckMime :: S.ByteString -> Bool
75defaultCheckMime bs =
75defaultCheckMime bs =
@@ -89,9 +89,6 @@ defaultCheckMime bs =
89-- if gzip is supported.
89-- if gzip is supported.
90--
90--
91-- File responses will be compressed according to the 'GzipFiles' setting.
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
18import Network.Wai.Internal
19import Data.ByteString (ByteString)
19import Data.ByteString (ByteString)
20import qualified Data.ByteString.Char8 as B8
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
23#if __GLASGOW_HASKELL__ < 710
24import Data.Monoid (mappend)
24import Data.Monoid (mappend)
25#endif
25#endif
@@ -60,10 +60,10 @@ jsonp app env sendResponse = do
60 sendResponse $ case checkJSON hs of
60 sendResponse $ case checkJSON hs of
61 Nothing -> r
61 Nothing -> r
62 Just hs' -> responseBuilder s hs' $
62 Just hs' -> responseBuilder s hs' $
63− byteStringCopy c
63+ copyByteString c
64− `mappend` char7 '('
64+ `mappend` fromChar '('
65 `mappend` b
65 `mappend` b
66− `mappend` char7 ')'
66+ `mappend` fromChar ')'
67 go c r =
67 go c r =
68 case checkJSON hs of
68 case checkJSON hs of
69 Just hs' -> addCallback c s hs' wb
69 Just hs' -> addCallback c s hs' wb
@@ -81,9 +81,9 @@ jsonp app env sendResponse = do
81
81
82 addCallback cb s hs wb =
82 addCallback cb s hs wb =
83 wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do
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
85 _ <- body sendChunk flush
86− sendChunk $ char7 ')'
86+ sendChunk $ fromChar ')'
87
87
88changeVal :: Eq a
88changeVal :: Eq a
89 => a
89 => a
wai-extra/Network/Wai/Middleware/RequestLogger.hs+14−64
@@ -14,16 +14,15 @@ module Network.Wai.Middleware.RequestLogger
14 , OutputFormat (..)
14 , OutputFormat (..)
15 , OutputFormatter
15 , OutputFormatter
16 , OutputFormatterWithDetails
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 #-}
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
27 -- ** Recommended functions
28 , rewriteWithQueries
28 , rewriteWithQueries
29 , rewritePureWithQueries
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
22 , parseContentType
23 , ParseRequestBodyOptions
23 , ParseRequestBodyOptions
24 , defaultParseRequestBodyOptions
24 , defaultParseRequestBodyOptions
25− , noLimitParseRequestBodyOptions
26 , parseRequestBodyEx
25 , parseRequestBodyEx
27 , setMaxRequestKeyLength
26 , setMaxRequestKeyLength
28 , clearMaxRequestKeyLength
27 , clearMaxRequestKeyLength
@@ -48,7 +47,7 @@ module Network.Wai.Parse
48#endif
47#endif
49 ) where
48 ) where
50
49
51−import qualified Control.Exception as E
50+import qualified Data.ByteString.Search as Search
52import qualified Data.ByteString as S
51import qualified Data.ByteString as S
53import qualified Data.ByteString.Lazy as L
52import qualified Data.ByteString.Lazy as L
54import qualified Data.ByteString.Char8 as S8
53import qualified Data.ByteString.Char8 as S8
@@ -59,16 +58,13 @@ import Data.List (sortBy)
59import Data.Function (on, fix)
58import Data.Function (on, fix)
60import System.Directory (removeFile, getTemporaryDirectory)
59import System.Directory (removeFile, getTemporaryDirectory)
61import System.IO (hClose, openBinaryTempFile)
60import System.IO (hClose, openBinaryTempFile)
62−import System.IO.Error (isDoesNotExistError)
63import Network.Wai
61import Network.Wai
64import qualified Network.HTTP.Types as H
62import qualified Network.HTTP.Types as H
65import Control.Applicative ((<$>))
63import Control.Applicative ((<$>))
66−import Control.Exception (catchJust)
67−import Control.Monad (when, unless, guard)
64+import Control.Monad (when, unless)
68import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
65import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
69import Data.IORef
66import Data.IORef
70import Network.HTTP.Types (hContentType)
67import Network.HTTP.Types (hContentType)
71−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
72import Data.CaseInsensitive (mk)
68import Data.CaseInsensitive (mk)
73
69
74import Prelude hiding (lines)
70import Prelude hiding (lines)
@@ -131,7 +127,7 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
131 -> IO FilePath
127 -> IO FilePath
132tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
128tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
133 (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
129 (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
134− _ <- runInternalState (register $ removeFileQuiet fp) internalState
130+ _ <- runInternalState (register $ removeFile fp) internalState
135 fix $ \loop -> do
131 fix $ \loop -> do
136 bs <- popper
132 bs <- popper
137 unless (S.null bs) $ do
133 unless (S.null bs) $ do
@@ -143,9 +139,6 @@ tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
143 it = do
139 it = do
144 tempDir <- getTmpDir
140 tempDir <- getTmpDir
145 openBinaryTempFile tempDir pattrn
141 openBinaryTempFile tempDir pattrn
146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)
147− (removeFile fp)
148− (const $ return ())
149
142
150-- | A data structure that describes the behavior of
143-- | A data structure that describes the behavior of
151-- the parseRequestBodyEx function.
144-- the parseRequestBodyEx function.
@@ -273,7 +266,7 @@ defaultParseRequestBodyOptions = ParseRequestBodyOptions
273
266
274-- | Do not impose any memory limits.
267-- | Do not impose any memory limits.
275--
268--
276−-- @since 3.0.21.0
269+-- @since 3.0.16.0
277noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
270noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
278noLimitParseRequestBodyOptions = ParseRequestBodyOptions
271noLimitParseRequestBodyOptions = ParseRequestBodyOptions
279 { prboKeyLength=Nothing
272 { prboKeyLength=Nothing
@@ -337,9 +330,6 @@ parseContentType a = do
337 semicolon = 59
330 semicolon = 59
338 equals = 61
331 equals = 61
339 space = 32
332 space = 32
340− dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote
341− then S.tail $ S.init s
342− else s
343 goAttrs front bs
333 goAttrs front bs
344 | S.null bs = front []
334 | S.null bs = front []
345 | otherwise =
335 | otherwise =
@@ -348,7 +338,7 @@ parseContentType a = do
348 goAttr bs =
338 goAttr bs =
349 let (k, v') = S.break (== equals) bs
339 let (k, v') = S.break (== equals) bs
350 v = S.drop 1 v'
340 v = S.drop 1 v'
351− in (strip k, dq $ strip v)
341+ in (strip k, strip v)
352 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
342 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
353
343
354-- | Parse the body of an HTTP request.
344-- | Parse the body of an HTTP request.
@@ -428,8 +418,6 @@ conduitRequestBodyEx o backend (Multipart bound) rbody add =
428
418
429
419
430-- | Take one header or subheader line.
420-- | Take one header or subheader line.
431−-- Since: 3.0.26
432−-- Throw 431 if headers too large.
433takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
421takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
434takeLine maxlen src =
422takeLine maxlen src =
435 go ""
423 go ""
@@ -438,8 +426,7 @@ takeLine maxlen src =
438 bs <- readSource src
426 bs <- readSource src
439 case maxlen of
427 case maxlen of
440 Just maxlen' -> when (S.length front > maxlen') $
428 Just maxlen' -> when (S.length front > maxlen') $
441− E.throwIO $ ConnectionError (UnknownErrorCode 431)
429+ error "Header line length exceeds allowed maximum."
442− "Request Header Fields Too Large"
443 Nothing -> return ()
430 Nothing -> return ()
444 if S.null bs
431 if S.null bs
445 then close front
432 then close front
@@ -455,8 +442,7 @@ takeLine maxlen src =
455 let res = front `S.append` x
442 let res = front `S.append` x
456 case maxlen of
443 case maxlen of
457 Just maxlen' -> when (S.length res > maxlen') $
444 Just maxlen' -> when (S.length res > maxlen') $
458− E.throwIO $ ConnectionError (UnknownErrorCode 431)
445+ error "Header line length exceeds allowed maximum."
459− "Request Header Fields Too Large"
460 Nothing -> return ()
446 Nothing -> return ()
461 return $ Just $ killCR $ res
447 return $ Just $ killCR $ res
462
448
@@ -582,7 +568,7 @@ data Bound = FoundBound S.ByteString S.ByteString
582 deriving (Eq, Show)
568 deriving (Eq, Show)
583
569
584findBound :: S.ByteString -> S.ByteString -> Bound
570findBound :: S.ByteString -> S.ByteString -> Bound
585−findBound b bs = handleBreak $ S.breakSubstring b bs
571+findBound b bs = handleBreak $ Search.breakOn b bs
586 where
572 where
587 handleBreak (h, t)
573 handleBreak (h, t)
588 | S.null t = go [lowBound..S.length bs - 1]
574 | S.null t = go [lowBound..S.length bs - 1]
@@ -645,9 +631,8 @@ wrapTillBound bound src max' = do
645 cur <- atomicModifyIORef' sref $ \ cur ->
631 cur <- atomicModifyIORef' sref $ \ cur ->
646 let new = cur + fromIntegral (S.length bs) in (new, new)
632 let new = cur + fromIntegral (S.length bs) in (new, new)
647 case max' of
633 case max' of
648− Just max'' | cur > max'' ->
634+ Just max'' | cur > max'' -> error "Maximum size exceeded"
649− E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"
650− _ -> return ()
635+ _ -> return ()
651 if S.null bs
636 if S.null bs
652 then do
637 then do
653 writeIORef ref $ WTBDone False
638 writeIORef ref $ WTBDone False
wai-extra/Network/Wai/Test.hs+18−25
@@ -52,7 +52,8 @@ import qualified Data.Map as Map
52import qualified Web.Cookie as Cookie
52import qualified Web.Cookie as Cookie
53import Data.ByteString (ByteString)
53import Data.ByteString (ByteString)
54import qualified Data.ByteString.Char8 as S8
54import qualified Data.ByteString.Char8 as S8
55−import Data.ByteString.Builder (toLazyByteString)
55+import Blaze.ByteString.Builder (toLazyByteString, toByteString)
56+import qualified Blaze.ByteString.Builder as B
56import qualified Data.ByteString.Lazy as L
57import qualified Data.ByteString.Lazy as L
57import qualified Data.ByteString.Lazy.Char8 as L8
58import qualified Data.ByteString.Lazy.Char8 as L8
58import qualified Network.HTTP.Types as H
59import qualified Network.HTTP.Types as H
@@ -99,10 +100,6 @@ runSession session app = ST.evalStateT (runReaderT session app) initState
99data SRequest = SRequest
100data SRequest = SRequest
100 { simpleRequest :: Request
101 { simpleRequest :: Request
101 , simpleRequestBody :: L.ByteString
102 , simpleRequestBody :: L.ByteString
102− -- ^ Request body that will override the one set in 'simpleRequest'.
103− --
104− -- This is usually simpler than setting the body as a stateful IO-action
105− -- in 'simpleRequest'.
106 }
103 }
107data SResponse = SResponse
104data SResponse = SResponse
108 { simpleStatus :: H.Status
105 { simpleStatus :: H.Status
@@ -110,22 +107,14 @@ data SResponse = SResponse
110 , simpleBody :: L.ByteString
107 , simpleBody :: L.ByteString
111 }
108 }
112 deriving (Show, Eq)
109 deriving (Show, Eq)
113−
114request :: Request -> Session SResponse
110request :: Request -> Session SResponse
115−request req = do
111+request = srequest . flip SRequest L.empty
116− app <- ask
117− req' <- addCookiesToRequest req
118− response <- liftIO $ do
119− ref <- newIORef $ error "runResponse gave no result"
120− ResponseReceived <- app req' (runResponse ref)
121− readIORef ref
122− extractSetCookieFromSResponse response
123
112
124-- | Set whole path (request path + query string).
113-- | Set whole path (request path + query string).
125setPath :: Request -> S8.ByteString -> Request
114setPath :: Request -> S8.ByteString -> Request
126setPath req path = req {
115setPath req path = req {
127 pathInfo = segments
116 pathInfo = segments
128− , rawPathInfo = (L8.toStrict . toLazyByteString) (H.encodePathSegments segments)
117+ , rawPathInfo = B.toByteString (H.encodePathSegments segments)
129 , queryString = query
118 , queryString = query
130 , rawQueryString = (H.renderQuery True query)
119 , rawQueryString = (H.renderQuery True query)
131 }
120 }
@@ -154,7 +143,7 @@ addCookiesToRequest req = do
154 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
143 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
155 | c <- map snd $ Map.toList cookiesForRequest
144 | c <- map snd $ Map.toList cookiesForRequest
156 ]
145 ]
157− let cookieValue = L8.toStrict . toLazyByteString $ Cookie.renderCookies cookiePairs
146+ let cookieValue = toByteString $ Cookie.renderCookies cookiePairs
158 addCookieHeader rest
147 addCookieHeader rest
159 | null cookiePairs = rest
148 | null cookiePairs = rest
160 | otherwise = ("Cookie", cookieValue) : rest
149 | otherwise = ("Cookie", cookieValue) : rest
@@ -178,18 +167,22 @@ extractSetCookieFromSResponse response = do
178 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))
167 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))
179 return response
168 return response
180
169
181−-- | Similar to 'request', but allows setting the request body as a plain
182−-- 'L.ByteString'.
183srequest :: SRequest -> Session SResponse
170srequest :: SRequest -> Session SResponse
184srequest (SRequest req bod) = do
171srequest (SRequest req bod) = do
172+ app <- ask
185 refChunks <- liftIO $ newIORef $ L.toChunks bod
173 refChunks <- liftIO $ newIORef $ L.toChunks bod
186− request $
187− req
174+ let req' = req
188− { requestBody = atomicModifyIORef refChunks $ \bss ->
175+ { requestBody = atomicModifyIORef refChunks $ \bss ->
189− case bss of
176+ case bss of
190− [] -> ([], S.empty)
177+ [] -> ([], S.empty)
191− x:y -> (y, x)
178+ x:y -> (y, x)
192− }
179+ }
180+ req'' <- addCookiesToRequest req'
181+ response <- liftIO $ do
182+ ref <- newIORef $ error "runResponse gave no result"
183+ ResponseReceived <- app req'' (runResponse ref)
184+ readIORef ref
185+ extractSetCookieFromSResponse response
193
186
194runResponse :: IORef SResponse -> Response -> IO ResponseReceived
187runResponse :: IORef SResponse -> Response -> IO ResponseReceived
195runResponse ref res = do
188runResponse ref res = do
wai-extra/example/Main.hs+4−15
@@ -1,7 +1,7 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Main where
2module Main where
3
3
4−import Data.ByteString.Builder (string8)
4+import Blaze.ByteString.Builder.Char.Utf8 (fromString)
5import Control.Concurrent (forkIO, threadDelay)
5import Control.Concurrent (forkIO, threadDelay)
6import Control.Concurrent.Chan
6import Control.Concurrent.Chan
7import Control.Monad
7import Control.Monad
@@ -27,26 +27,15 @@ eventChan :: Chan ServerEvent -> IO ()
27eventChan chan = forever $ do
27eventChan chan = forever $ do
28 threadDelay 1000000
28 threadDelay 1000000
29 time <- getPOSIXTime
29 time <- getPOSIXTime
30− writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time])
30+ writeChan chan (ServerEvent Nothing Nothing [fromString . show $ time])
31
31
32eventIO :: IO ServerEvent
32eventIO :: IO ServerEvent
33eventIO = do
33eventIO = do
34 threadDelay 1000000
34 threadDelay 1000000
35 time <- getPOSIXTime
35 time <- getPOSIXTime
36− return $ ServerEvent (Just $ string8 "io")
36+ return $ ServerEvent (Just $ fromString "io")
37 Nothing
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
13import qualified Data.Text as TS
14import qualified Data.Text.Encoding as TE
14import qualified Data.Text.Encoding as TE
15import Control.Monad.Trans.Resource (withInternalState, runResourceT)
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
3
4import Control.Monad (void)
4import Control.Monad (void)
5
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
1Name: wai-extra
2−Version: 3.0.29.1
2+Version: 3.0.20.2
3Synopsis: Provides some basic WAI handlers and middleware.
3Synopsis: Provides some basic WAI handlers and middleware.
4description:
4description:
5 Provides basic WAI handler and middleware functionality:
5 Provides basic WAI handler and middleware functionality:
@@ -87,35 +87,37 @@ flag build-example
87 default: False
87 default: False
88
88
89Library
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
92 , wai >= 3.0.3.0 && < 3.3
93 , old-locale >= 1.0.0.2 && < 1.1
93 , old-locale >= 1.0.0.2 && < 1.1
94 , time >= 1.1.4
94 , time >= 1.1.4
95 , network >= 2.6.1.0
95 , network >= 2.6.1.0
96 , directory >= 1.0.1
96 , directory >= 1.0.1
97 , transformers >= 0.2.2
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
190 WaiExtraSpec
191 build-depends: base >= 4 && < 5
191 build-depends: base >= 4 && < 5
192 , wai-extra
192 , wai-extra
@@ -200,10 +200,10 @@ test-suite spec
200 , resourcet
200 , resourcet
201 , bytestring
201 , bytestring
202 , HUnit
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
207 ghc-options: -Wall
208 default-language: Haskell2010
208 default-language: Haskell2010
209
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 @@
1+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
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 @@
1+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
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
120 when (isNothing mauth
121 || requestHeaderHost req == mauth) $ do
121 || requestHeaderHost req == mauth) $ do
122 when (path /= refPath) $ do -- just in case
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
1Name: wai-http2-extra
2−Version: 0.1.2
2+Version: 0.1.0
3Synopsis: WAI utilities for HTTP/2
3Synopsis: WAI utilities for HTTP/2
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE
@@ -8,7 +8,7 @@ Maintainer: kazu@iij.ad.jp
8Homepage: http://github.com/yesodweb/wai
8Homepage: http://github.com/yesodweb/wai
9Category: Web
9Category: Web
10Build-Type: Simple
10Build-Type: Simple
11−Cabal-Version: >=1.10
11+Cabal-Version: >=1.8
12Stability: Stable
12Stability: Stable
13Description: WAI utilities for HTTP/2
13Description: WAI utilities for HTTP/2
14
14
@@ -24,9 +24,6 @@ Library
24 Exposed-modules: Network.Wai.Middleware.Push.Referer
24 Exposed-modules: Network.Wai.Middleware.Push.Referer
25 Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap
25 Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap
26 Ghc-Options: -Wall
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.
8nearby to check out the functions we use.
9
9
10> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
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
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.
3Synopsis: Provide a bridge between WAI and the websockets package.
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE
@@ -21,6 +21,7 @@ Library
21 Build-Depends: base >= 3 && < 5
21 Build-Depends: base >= 3 && < 5
22 , bytestring >= 0.9.1.4
22 , bytestring >= 0.9.1.4
23 , wai >= 3.0 && < 3.3
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.
4protocol between web servers and web applications.
5
5
6The overriding design principles here are performance and generality. To
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.
5-- given for stability of these interfaces.
6module Network.Wai.Internal where
6module Network.Wai.Internal where
7
7
8−import Data.ByteString.Builder (Builder)
8+import Blaze.ByteString.Builder (Builder)
9import qualified Data.ByteString as B hiding (pack)
9import qualified Data.ByteString as B hiding (pack)
10import Data.Text (Text)
10import Data.Text (Text)
11import Data.Typeable (Typeable)
11import Data.Typeable (Typeable)
@@ -17,7 +17,6 @@ import Data.List (intercalate)
17
17
18-- | Information on the request sent by the client. This abstracts away the
18-- | Information on the request sent by the client. This abstracts away the
19-- details of the underlying implementation.
19-- details of the underlying implementation.
20−{-# DEPRECATED requestBody "requestBody's name is misleading because it only gets a partial chunk of the body. Use getRequestBodyChunk instead." #-}
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+5−4
@@ -4,9 +4,10 @@ import Test.Hspec
4import Test.Hspec.QuickCheck (prop)
4import Test.Hspec.QuickCheck (prop)
5import Network.Wai
5import Network.Wai
6import Data.IORef
6import Data.IORef
7+import Data.Monoid
7import qualified Data.ByteString as S
8import qualified Data.ByteString as S
8import qualified Data.ByteString.Lazy as L
9import qualified Data.ByteString.Lazy as L
9−import Data.ByteString.Builder (Builder, toLazyByteString, word8)
10+import Blaze.ByteString.Builder (toByteString, Builder, fromWord8)
10import Control.Monad (forM_)
11import Control.Monad (forM_)
11
12
12spec :: Spec
13spec :: Spec
@@ -22,17 +23,17 @@ spec = do
22 flush :: IO ()
23 flush :: IO ()
23 flush = return ()
24 flush = return ()
24 streamingBody add flush
25 streamingBody add flush
25− fmap (L.toStrict . toLazyByteString) $ readIORef builderRef
26+ fmap toByteString $ readIORef builderRef
26 prop "responseLBS" $ \bytes -> do
27 prop "responseLBS" $ \bytes -> do
27 body <- getBody $ responseLBS undefined undefined $ L.pack bytes
28 body <- getBody $ responseLBS undefined undefined $ L.pack bytes
28 body `shouldBe` S.pack bytes
29 body `shouldBe` S.pack bytes
29 prop "responseBuilder" $ \bytes -> do
30 prop "responseBuilder" $ \bytes -> do
30 body <- getBody $ responseBuilder undefined undefined
31 body <- getBody $ responseBuilder undefined undefined
31− $ mconcat $ map word8 bytes
32+ $ mconcat $ map fromWord8 bytes
32 body `shouldBe` S.pack bytes
33 body `shouldBe` S.pack bytes
33 prop "responseStream" $ \chunks -> do
34 prop "responseStream" $ \chunks -> do
34 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->
35 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->
35− forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk
36+ forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk
36 body `shouldBe` S.concat (map S.pack chunks)
37 body `shouldBe` S.concat (map S.pack chunks)
37 it "responseFile total" $ do
38 it "responseFile total" $ do
38 let fp = "wai.cabal"
39 let fp = "wai.cabal"
wai/wai.cabal+6−5
@@ -1,9 +1,8 @@
1Name: wai
1Name: wai
2−Version: 3.2.2.1
2+Version: 3.2.1.1
3Synopsis: Web Application Interface.
3Synopsis: Web Application Interface.
4Description: Provides a common protocol for communication between web applications and web servers.
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
25 , network >= 2.2.1.5
26 , http-types >= 0.7
26 , http-types >= 0.7
27 , text >= 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
@@ -39,9 +40,9 @@ test-suite test
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)
5import Data.ByteString (ByteString)
6import qualified Data.ByteString.Lazy as L
6import qualified Data.ByteString.Lazy as L
7import Data.Enumerator (consume, Iteratee)
7import Data.Enumerator (consume, Iteratee)
8−import Data.ByteString.Builder (lazyByteString)
8+import Blaze.ByteString.Builder (fromLazyByteString)
9
9
10main :: IO ()
10main :: IO ()
11main = putStrLn "http://localhost:3000/" >> run "Webkit Sample" app
11main = putStrLn "http://localhost:3000/" >> run "Webkit Sample" app
@@ -27,4 +27,4 @@ postResponse :: L.ByteString -> Iteratee ByteString IO Response
27postResponse lbs = return $ ResponseBuilder
27postResponse lbs = return $ ResponseBuilder
28 status200
28 status200
29 [("Content-Type", "text/plain")]
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)
53import Data.Streaming.Network (bindPortTCP, safeRecv)
54import Data.Typeable (Typeable)
54import Data.Typeable (Typeable)
55import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)
55import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)
56−#if MIN_VERSION_network(3,1,1)
57−import Network.Socket (gracefulClose)
58−#endif
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
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
3Synopsis: HTTP over TLS support for Warp via the TLS package
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE
@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com
8Homepage: http://github.com/yesodweb/wai
8Homepage: http://github.com/yesodweb/wai
9Category: Web, Yesod
9Category: Web, Yesod
10Build-Type: Simple
10Build-Type: Simple
11−Cabal-Version: >= 1.10
11+Cabal-Version: >=1.6
12Stability: Stable
12Stability: Stable
13description: SSLv1 and SSLv2 are obsoleted by IETF.
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).
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
18extra-source-files: ChangeLog.md README.md
19
19
20Library
20Library
21− Build-Depends: base >= 4.10 && < 5
21+ Build-Depends: base >= 4.8 && < 5
22 , bytestring >= 0.9
22 , bytestring >= 0.9
23 , wai >= 3.2 && < 3.3
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
25 , data-default-class >= 0.0.1
26− , tls >= 1.5.3
26+ , tls >= 1.3.10
27 , cryptonite >= 0.12
27 , cryptonite >= 0.12
28 , network >= 2.2.1
28 , network >= 2.2.1
29 , streaming-commons
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
31 Exposed-modules: Network.Wai.Handler.WarpTLS
32 ghc-options: -Wall
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+2−68
@@ -72,9 +72,6 @@ module Network.Wai.Handler.Warp (
72 , setLogger
72 , setLogger
73 , setServerPushLogger
73 , setServerPushLogger
74 , setGracefulShutdownTimeout
74 , setGracefulShutdownTimeout
75− , setGracefulCloseTimeout1
76− , setGracefulCloseTimeout2
77− , setMaxTotalHeaderLength
78 -- ** Getters
75 -- ** Getters
79 , getPort
76 , getPort
80 , getHost
77 , getHost
@@ -82,8 +79,6 @@ module Network.Wai.Handler.Warp (
82 , getOnClose
79 , getOnClose
83 , getOnException
80 , getOnException
84 , getGracefulShutdownTimeout
81 , getGracefulShutdownTimeout
85− , getGracefulCloseTimeout1
86− , getGracefulCloseTimeout2
87 -- ** Exception handler
82 -- ** Exception handler
88 , defaultOnException
83 , defaultOnException
89 , defaultShouldDisplayException
84 , defaultShouldDisplayException
@@ -98,7 +93,6 @@ module Network.Wai.Handler.Warp (
98 , pauseTimeout
93 , pauseTimeout
99 , FileInfo(..)
94 , FileInfo(..)
100 , getFileInfo
95 , getFileInfo
101− , clientCertificate
102 , withApplication
96 , withApplication
103 , withApplicationSettings
97 , withApplicationSettings
104 , testWithApplication
98 , testWithApplication
@@ -127,11 +121,9 @@ module Network.Wai.Handler.Warp (
127import Control.Exception (SomeException, throwIO)
121import Control.Exception (SomeException, throwIO)
128import Data.Streaming.Network (HostPreference)
122import Data.Streaming.Network (HostPreference)
129import qualified Data.Vault.Lazy as Vault
123import qualified Data.Vault.Lazy as Vault
130−import Data.X509
131import qualified Network.HTTP.Types as H
124import qualified Network.HTTP.Types as H
132import Network.Socket (SockAddr)
125import Network.Socket (SockAddr)
133import Network.Wai (Request, Response, vault)
126import Network.Wai (Request, Response, vault)
134−import System.TimeManager
135
127
136import Network.Wai.Handler.Warp.FileInfoCache
128import Network.Wai.Handler.Warp.FileInfoCache
137import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)
129import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)
@@ -141,6 +133,7 @@ import Network.Wai.Handler.Warp.Request
141import Network.Wai.Handler.Warp.Response (warpVersion)
133import Network.Wai.Handler.Warp.Response (warpVersion)
142import Network.Wai.Handler.Warp.Run
134import Network.Wai.Handler.Warp.Run
143import Network.Wai.Handler.Warp.Settings
135import Network.Wai.Handler.Warp.Settings
136+import Network.Wai.Handler.Warp.Timeout
144import Network.Wai.Handler.Warp.Types hiding (getFileInfo)
137import Network.Wai.Handler.Warp.Types hiding (getFileInfo)
145import Network.Wai.Handler.Warp.WithApplication
138import Network.Wai.Handler.Warp.WithApplication
146
139
@@ -303,18 +296,6 @@ getGracefulShutdownTimeout = settingsGracefulShutdownTimeout
303-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'
296-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'
304-- @
297-- @
305--
298--
306−-- Note that by default, the graceful shutdown mode lasts indefinitely
307−-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,
308−-- upon receiving that signal, the custon shutdown action will run /and/ all
309−-- outstanding requests will be handled.
310−--
311−-- You may instead prefer to do one or both of the following:
312−--
313−-- * Only wait a finite amount of time for outstanding requests to complete,
314−-- using 'setGracefulShutdownTimeout'.
315−-- * Only catch one signal, so the second hard-kills the Warp server, using
316−-- 'System.Posix.Signals.CatchOnce'.
317−--
318-- Default: does not install any code.
299-- Default: does not install any code.
319--
300--
320-- Since 3.0.1
301-- Since 3.0.1
@@ -385,7 +366,7 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }
385--
366--
386-- WARNING: This is contrary to the PROXY protocol specification and
367-- WARNING: This is contrary to the PROXY protocol specification and
387-- using it can indicate a security problem with your
368-- using it can indicate a security problem with your
388−-- architecture if the web server is directly accessible
369+-- architecture if the web server is directly accessable
389-- to the public, since it would allow easy IP address
370-- to the public, since it would allow easy IP address
390-- spoofing. However, it can be useful in some cases,
371-- spoofing. However, it can be useful in some cases,
391-- such as if a load balancer health check uses regular
372-- such as if a load balancer health check uses regular
@@ -428,22 +409,11 @@ setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }
428-- wait indefinitely, and a number, if provided, will be treated as seconds
409-- wait indefinitely, and a number, if provided, will be treated as seconds
429-- to wait for requests to finish, before shutting down the server entirely.
410-- to wait for requests to finish, before shutting down the server entirely.
430--
411--
431−-- Graceful shutdown mode is entered when the server socket is closed; see
432−-- 'setInstallShutdownHandler' for an example of how this could be done in
433−-- response to a UNIX signal.
434−--
435-- Since 3.2.8
412-- Since 3.2.8
436setGracefulShutdownTimeout :: Maybe Int
413setGracefulShutdownTimeout :: Maybe Int
437 -> Settings -> Settings
414 -> Settings -> Settings
438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }
415setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }
439
416
440−-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.
441−--
442−-- Since 3.3.8
443−setMaxTotalHeaderLength :: Int -> Settings -> Settings
444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings
445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }
446−
447-- | Explicitly pause the slowloris timeout.
417-- | Explicitly pause the slowloris timeout.
448--
418--
449-- This is useful for cases where you partially consume a request body. For
419-- This is useful for cases where you partially consume a request body. For
@@ -471,39 +441,3 @@ pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault
471-- Since 3.1.10
441-- Since 3.1.10
472getFileInfo :: Request -> FilePath -> IO FileInfo
442getFileInfo :: Request -> FilePath -> IO FileInfo
473getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault
443getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault
474−
475−-- | A timeout to limit the time (in milliseconds) waiting for
476−-- FIN for HTTP/1.x. 0 means uses immediate close.
477−-- Default: 0.
478−--
479−-- Since 3.3.5
480−setGracefulCloseTimeout1 :: Int -> Settings -> Settings
481−setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }
482−
483−-- | A timeout to limit the time (in milliseconds) waiting for
484−-- FIN for HTTP/1.x. 0 means uses immediate close.
485−--
486−-- Since 3.3.5
487−getGracefulCloseTimeout1 :: Settings -> Int
488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1
489−
490−-- | A timeout to limit the time (in milliseconds) waiting for
491−-- FIN for HTTP/2. 0 means uses immediate close.
492−-- Default: 2000.
493−--
494−-- Since 3.3.5
495−setGracefulCloseTimeout2 :: Int -> Settings -> Settings
496−setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }
497−
498−-- | A timeout to limit the time (in milliseconds) waiting for
499−-- FIN for HTTP/2. 0 means uses immediate close.
500−--
501−-- Since 3.3.5
502−getGracefulCloseTimeout2 :: Settings -> Int
503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2
504−
505−-- | Getting information of client certificate.
506−--
507−-- Since 3.3.5
508−clientCertificate :: Request -> Maybe CertificateChain
509−clientCertificate = join . Vault.lookup getClientCertificateKey . vault
warp/Network/Wai/Handler/Warp/FdCache.hs+22−18
@@ -17,24 +17,26 @@ module Network.Wai.Handler.Warp.FdCache (
17import Control.Exception (bracket)
17import Control.Exception (bracket)
18import Control.Reaper
18import Control.Reaper
19import Data.IORef
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)
21import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)
22#endif
22#endif
23import System.Posix.Types (Fd)
23import System.Posix.Types (Fd)
24
24
25----------------------------------------------------------------
25----------------------------------------------------------------
26
26
27+type Hash = Int
28+
27-- | An action to activate a Fd cache entry.
29-- | An action to activate a Fd cache entry.
28type Refresh = IO ()
30type Refresh = IO ()
29
31
30−getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)
32+getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)
31−getFdNothing _ = return (Nothing, return ())
33+getFdNothing _ _ = return (Nothing, return ())
32
34
33----------------------------------------------------------------
35----------------------------------------------------------------
34
36
35-- | Creating 'MutableFdCache' and executing the action in the second
37-- | Creating 'MutableFdCache' and executing the action in the second
36-- argument. The first argument is a cache duration in second.
38-- argument. The first argument is a cache duration in second.
37−withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a
39+withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a
38#ifdef WINDOWS
40#ifdef WINDOWS
39withFdCache _ action = action getFdNothing
41withFdCache _ action = action getFdNothing
40#else
42#else
@@ -63,7 +65,7 @@ inactive (MutableStatus ref) = writeIORef ref Inactive
63
65
64----------------------------------------------------------------
66----------------------------------------------------------------
65
67
66−data FdEntry = FdEntry !Fd !MutableStatus
68+data FdEntry = FdEntry !FilePath !Fd !MutableStatus
67
69
68openFile :: FilePath -> IO Fd
70openFile :: FilePath -> IO Fd
69openFile path = do
71openFile path = do
@@ -75,23 +77,25 @@ closeFile :: Fd -> IO ()
75closeFile = closeFd
77closeFile = closeFd
76
78
77newFdEntry :: FilePath -> IO FdEntry
79newFdEntry :: FilePath -> IO FdEntry
78−newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus
80+newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus
79
81
80setFileCloseOnExec :: Fd -> IO ()
82setFileCloseOnExec :: Fd -> IO ()
81setFileCloseOnExec fd = setFdOption fd CloseOnExec True
83setFileCloseOnExec fd = setFdOption fd CloseOnExec True
82
84
83----------------------------------------------------------------
85----------------------------------------------------------------
84
86
85−type FdCache = MultiMap FdEntry
87+type FdCache = MMap FdEntry
86
88
87-- | Mutable Fd cacher.
89-- | Mutable Fd cacher.
88−newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))
90+newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))
89
91
90fdCache :: MutableFdCache -> IO FdCache
92fdCache :: MutableFdCache -> IO FdCache
91fdCache (MutableFdCache reaper) = reaperRead reaper
93fdCache (MutableFdCache reaper) = reaperRead reaper
92
94
93−look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)
95+look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
94−look mfc path = MM.lookup path <$> fdCache mfc
96+look mfc path key = searchWith key check <$> fdCache mfc
97+ where
98+ check (FdEntry path' _ _) = path == path'
95
99
96----------------------------------------------------------------
100----------------------------------------------------------------
97
101
@@ -112,7 +116,7 @@ clean old = do
112 new <- pruneWith old prune
116 new <- pruneWith old prune
113 return $ merge new
117 return $ merge new
114 where
118 where
115− prune (_,FdEntry fd mst) = status mst >>= act
119+ prune (FdEntry _ fd mst) = status mst >>= act
116 where
120 where
117 act Active = inactive mst >> return True
121 act Active = inactive mst >> return True
118 act Inactive = closeFd fd >> return False
122 act Inactive = closeFd fd >> return False
@@ -122,21 +126,21 @@ clean old = do
122terminate :: MutableFdCache -> IO ()
126terminate :: MutableFdCache -> IO ()
123terminate (MutableFdCache reaper) = do
127terminate (MutableFdCache reaper) = do
124 !t <- reaperStop reaper
128 !t <- reaperStop reaper
125− mapM_ (closeIt . snd) $ toList t
129+ mapM_ closeIt $ toList t
126 where
130 where
127− closeIt (FdEntry fd _) = closeFd fd
131+ closeIt (FdEntry _ fd _) = closeFd fd
128
132
129----------------------------------------------------------------
133----------------------------------------------------------------
130
134
131-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
135-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
132−getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)
136+getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)
133−getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get
137+getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get
134 where
138 where
135 get Nothing = do
139 get Nothing = do
136− ent@(FdEntry fd mst) <- newFdEntry path
140+ ent@(FdEntry _ fd mst) <- newFdEntry path
137− reaperAdd reaper (path,ent)
141+ reaperAdd reaper (h, ent)
138 return (Just fd, refresh mst)
142 return (Just fd, refresh mst)
139− get (Just (FdEntry fd mst)) = do
143+ get (Just (FdEntry _ fd mst)) = do
140 refresh mst
144 refresh mst
141 return (Just fd, refresh mst)
145 return (Just fd, refresh mst)
142#endif
146#endif
warp/Network/Wai/Handler/Warp/File.hs+4−7
@@ -34,15 +34,12 @@ data RspFileInfo = WithoutBody H.Status
34----------------------------------------------------------------
34----------------------------------------------------------------
35
35
36conditionalRequest :: I.FileInfo
36conditionalRequest :: I.FileInfo
37− -> H.ResponseHeaders
37+ -> H.ResponseHeaders -> IndexedHeader
38− -> IndexedHeader -- ^ Response
39− -> IndexedHeader -- ^ Request
40 -> RspFileInfo
38 -> RspFileInfo
41−conditionalRequest finfo hs0 rspidx reqidx = case condition of
39+conditionalRequest finfo hs0 reqidx = case condition of
42 nobody@(WithoutBody _) -> nobody
40 nobody@(WithoutBody _) -> nobody
43− WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size
44− !hasLM = isJust $ rspidx ! fromEnum ResLastModified
45− !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1
41+ WithBody s _ off len -> let !hs = (H.hLastModified,date) :
42+ addContentHeaders hs0 off len size
46 in WithBody s hs off len
43 in WithBody s hs off len
47 where
44 where
48 !mtime = I.fileInfoTime finfo
45 !mtime = I.fileInfoTime finfo
warp/Network/Wai/Handler/Warp/FileInfoCache.hs+22−19
@@ -2,6 +2,7 @@
2
2
3module Network.Wai.Handler.Warp.FileInfoCache (
3module Network.Wai.Handler.Warp.FileInfoCache (
4 FileInfo(..)
4 FileInfo(..)
5+ , Hash
5 , withFileInfoCache
6 , withFileInfoCache
6 , getInfo -- test purpose only
7 , getInfo -- test purpose only
7 ) where
8 ) where
@@ -17,6 +18,8 @@ import Network.Wai.Handler.Warp.Imports
17
18
18----------------------------------------------------------------
19----------------------------------------------------------------
19
20
21+type Hash = Int
22+
20-- | File information.
23-- | File information.
21data FileInfo = FileInfo {
24data FileInfo = FileInfo {
22 fileInfoName :: !FilePath
25 fileInfoName :: !FilePath
@@ -26,8 +29,8 @@ data FileInfo = FileInfo {
26 } deriving (Eq, Show)
29 } deriving (Eq, Show)
27
30
28data Entry = Negative | Positive FileInfo
31data Entry = Negative | Positive FileInfo
29−type Cache = HashMap Entry
32+type Cache = HashMap FilePath Entry
30−type FileInfoCache = Reaper Cache (FilePath,Entry)
33+type FileInfoCache = Reaper Cache (Int,FilePath,Entry)
31
34
32----------------------------------------------------------------
35----------------------------------------------------------------
33
36
@@ -51,29 +54,29 @@ getInfo path = do
51 else
54 else
52 throwIO (userError "FileInfoCache:getInfo")
55 throwIO (userError "FileInfoCache:getInfo")
53
56
54−getInfoNaive :: FilePath -> IO FileInfo
57+getInfoNaive :: Hash -> FilePath -> IO FileInfo
55−getInfoNaive = getInfo
58+getInfoNaive _ = getInfo
56
59
57----------------------------------------------------------------
60----------------------------------------------------------------
58
61
59−getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo
62+getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo
60−getAndRegisterInfo reaper@Reaper{..} path = do
63+getAndRegisterInfo reaper@Reaper{..} h path = do
61 cache <- reaperRead
64 cache <- reaperRead
62− case M.lookup path cache of
65+ case M.lookup h path cache of
63 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")
66 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")
64 Just (Positive x) -> return x
67 Just (Positive x) -> return x
65− Nothing -> positive reaper path
68+ Nothing -> positive reaper h path
66− `E.onException` negative reaper path
69+ `E.onException` negative reaper h path
67
70
68−positive :: FileInfoCache -> FilePath -> IO FileInfo
71+positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo
69−positive Reaper{..} path = do
72+positive Reaper{..} h path = do
70 info <- getInfo path
73 info <- getInfo path
71− reaperAdd (path, Positive info)
74+ reaperAdd (h, path, Positive info)
72 return info
75 return info
73
76
74−negative :: FileInfoCache -> FilePath -> IO FileInfo
77+negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo
75−negative Reaper{..} path = do
78+negative Reaper{..} h path = do
76− reaperAdd (path, Negative)
79+ reaperAdd (h, path,Negative)
77 throwIO (userError "FileInfoCache:negative")
80 throwIO (userError "FileInfoCache:negative")
78
81
79----------------------------------------------------------------
82----------------------------------------------------------------
@@ -82,7 +85,7 @@ negative Reaper{..} path = do
82-- and executing the action in the second argument.
85-- and executing the action in the second argument.
83-- The first argument is a cache duration in second.
86-- The first argument is a cache duration in second.
84withFileInfoCache :: Int
87withFileInfoCache :: Int
85− -> ((FilePath -> IO FileInfo) -> IO a)
88+ -> ((Hash -> FilePath -> IO FileInfo) -> IO a)
86 -> IO a
89 -> IO a
87withFileInfoCache 0 action = action getInfoNaive
90withFileInfoCache 0 action = action getInfoNaive
88withFileInfoCache duration action =
91withFileInfoCache duration action =
@@ -90,14 +93,14 @@ withFileInfoCache duration action =
90 terminate
93 terminate
91 (action . getAndRegisterInfo)
94 (action . getAndRegisterInfo)
92
95
93−initialize :: Int -> IO FileInfoCache
96+initialize :: Hash -> IO FileInfoCache
94initialize duration = mkReaper settings
97initialize duration = mkReaper settings
95 where
98 where
96 settings = defaultReaperSettings {
99 settings = defaultReaperSettings {
97 reaperAction = override
100 reaperAction = override
98 , reaperDelay = duration
101 , reaperDelay = duration
99− , reaperCons = \(path,v) -> M.insert path v
102+ , reaperCons = \(h,k,v) -> M.insert h k v
100− , reaperNull = M.isEmpty
103+ , reaperNull = M.null
101 , reaperEmpty = M.empty
104 , reaperEmpty = M.empty
102 }
105 }
103
106
warp/Network/Wai/Handler/Warp/HTTP2.hs+54−70
@@ -1,85 +1,69 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE PatternGuards #-}
2+{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6
3
7−module Network.Wai.Handler.Warp.HTTP2 (http2) where
4+module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where
8
5
9−import qualified Data.IORef as I
6+import Control.Concurrent (forkIO, killThread)
10import qualified Control.Exception as E
7import qualified Control.Exception as E
11−import qualified Network.HTTP2.Server as H2
8+import Network.HTTP2
12import Network.Socket (SockAddr)
9import Network.Socket (SockAddr)
13import Network.Wai
10import Network.Wai
14−import Network.Wai.Internal (ResponseReceived(..))
15−import qualified System.TimeManager as T
16
11
17−import Network.Wai.Handler.Warp.HTTP2.File
12+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
13+import Network.Wai.Handler.Warp.HTTP2.Manager
18−import Network.Wai.Handler.Warp.HTTP2.PushPromise
14+import Network.Wai.Handler.Warp.HTTP2.Receiver
19import Network.Wai.Handler.Warp.HTTP2.Request
15import Network.Wai.Handler.Warp.HTTP2.Request
20−import Network.Wai.Handler.Warp.HTTP2.Response
16+import Network.Wai.Handler.Warp.HTTP2.Sender
17+import Network.Wai.Handler.Warp.HTTP2.Types
18+import Network.Wai.Handler.Warp.HTTP2.Worker
21import Network.Wai.Handler.Warp.Imports
19import Network.Wai.Handler.Warp.Imports
22−import qualified Network.Wai.Handler.Warp.Settings as S
20+import qualified Network.Wai.Handler.Warp.Settings as S (Settings)
23import Network.Wai.Handler.Warp.Types
21import Network.Wai.Handler.Warp.Types
24
22
25----------------------------------------------------------------
23----------------------------------------------------------------
26
24
27−http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> (ByteString -> IO ()) -> Application -> IO ()
25+http2 :: Connection -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()
28−http2 conn transport ii addr settings readN send app =
26+http2 conn ii1 addr transport settings readN app = do
29− H2.run conf http2server
27+ checkTLS
28+ ok <- checkPreface
29+ when ok $ do
30+ ctx <- newContext
31+ -- Workers, worker manager and timer manager
32+ mgr <- start settings
33+ let responder = response settings ctx mgr
34+ action = worker ctx settings app responder
35+ setAction mgr action
36+ -- The number of workers is 3.
37+ -- This was carefully chosen based on a lot of benchmarks.
38+ -- If it is 1, we cannot avoid head-of-line blocking.
39+ -- If it is large, huge memory is consumed and many
40+ -- context switches happen.
41+ replicateM_ 3 $ spawnAction mgr
42+ -- Receiver
43+ let mkreq = mkRequest ii1 settings addr
44+ tid <- forkIO $ frameReceiver ctx mkreq readN
45+ -- Sender
46+ -- frameSender is the main thread because it ensures to send
47+ -- a goway frame.
48+ frameSender ctx conn settings mgr `E.finally` do
49+ clearContext ctx
50+ stop mgr
51+ killThread tid
30 where
52 where
31− conf = H2.Config {
53+ checkTLS = case transport of
32− confWriteBuffer = connWriteBuffer conn
54+ TCP -> return () -- direct
33− , confBufferSize = connBufferSize conn
55+ tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"
34− , confSendAll = send
56+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3
35− , confReadN = readN
57+ checkPreface = do
36− , confPositionReadMaker = pReadMaker ii
58+ preface <- readN connectionPrefaceLength
37− }
59+ if connectionPreface /= preface then do
38−
60+ goaway conn ProtocolError "Preface mismatch"
39− http2server h2req aux response = do
61+ return False
40− req <- toWAIRequest h2req aux
62+ else
41− ref <- I.newIORef Nothing
42− eResponseReceived <- E.try $ app req $ \rsp -> do
43− h2rsp <- fromResponse settings ii req rsp
44− pps <- fromPushPromises ii req
45− I.writeIORef ref $ Just (h2rsp, pps)
46− _ <- response h2rsp pps
47− return ResponseReceived
48− case eResponseReceived of
49− Right ResponseReceived -> do
50− Just (h2rsp, pps) <- I.readIORef ref
51− logResponse h2rsp req
52− mapM_ (logPushPromise req) pps
53− Left e@(E.SomeException _)
54− -- killed by the local worker manager
55− | Just E.ThreadKilled <- E.fromException e -> return ()
56− -- killed by the local timeout manager
57− | Just T.TimeoutThread <- E.fromException e -> return ()
58− | otherwise -> do
59− S.settingsOnException settings (Just req) e
60− let ersp = S.settingsOnExceptionResponse settings e
61− h2rsp' <- fromResponse settings ii req ersp
62− _ <- response h2rsp' []
63− logResponse h2rsp' req
64− return ()
63+ return True
65
64
66− toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport
65+-- connClose must not be called here since Run:fork calls it
67− where
66+goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
68− !hdr = H2.requestHeaders h2req
67+goaway Connection{..} etype debugmsg = connSendAll bytestream
69− !bdy = H2.getRequestBodyChunk h2req
68+ where
70− !bdylen = H2.requestBodySize h2req
69+ bytestream = goawayFrame 0 etype debugmsg
71− !th = H2.auxTimeHandle aux
72−
73− logResponse h2rsp req = logger req st msiz
74− where
75− !logger = S.settingsLogger settings
76− !st = H2.responseStatus h2rsp
77− !msiz = fromIntegral <$> H2.responseBodySize h2rsp
78−
79− logPushPromise req pp = logger req path siz
80− where
81− !logger = S.settingsServerPushLogger settings
82− !path = H2.promiseRequestPath pp
83− !siz = case H2.responseBodySize $ H2.promiseResponse pp of
84− Nothing -> 0
85− Just s -> fromIntegral s
warp/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hsnew file+34
@@ -0,0 +1,34 @@
1+module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where
2+
3+import Network.HTTP2
4+
5+import Network.Wai.Handler.Warp.Imports
6+
7+----------------------------------------------------------------
8+
9+goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString
10+goawayFrame sid etype debugmsg = encodeFrame einfo frame
11+ where
12+ einfo = encodeInfo id 0
13+ frame = GoAwayFrame sid etype debugmsg
14+
15+resetFrame :: ErrorCodeId -> StreamId -> ByteString
16+resetFrame etype sid = encodeFrame einfo frame
17+ where
18+ einfo = encodeInfo id sid
19+ frame = RSTStreamFrame etype
20+
21+settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
22+settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist
23+ where
24+ einfo = encodeInfo func 0
25+
26+pingFrame :: ByteString -> ByteString
27+pingFrame bs = encodeFrame einfo $ PingFrame bs
28+ where
29+ einfo = encodeInfo setAck 0
30+
31+windowUpdateFrame :: StreamId -> WindowSize -> ByteString
32+windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz
33+ where
34+ einfo = encodeInfo id sid
warp/Network/Wai/Handler/Warp/HTTP2/File.hs+150−23
@@ -1,30 +1,157 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE BangPatterns #-}
2
4
3−module Network.Wai.Handler.Warp.HTTP2.File where
5+module Network.Wai.Handler.Warp.HTTP2.File (
6+ RspFileInfo(..)
7+ , conditionalRequest
8+ , addContentHeadersForFilePart
9+ , H.parseByteRanges
10+ ) where
4
11
5−import Network.HTTP2.Server
12+import qualified Data.ByteString.Char8 as C8 (pack)
13+import Network.HPACK
14+import Network.HPACK.Token
15+import Network.HTTP.Date
16+import qualified Network.HTTP.Types as H
17+import Network.Wai
6
18
19+import qualified Network.Wai.Handler.Warp.FileInfoCache as I
20+import Network.Wai.Handler.Warp.Imports
7−import Network.Wai.Handler.Warp.Types
21+import Network.Wai.Handler.Warp.PackInt
8
22
9−#ifdef WINDOWS
23+-- $setup
10−pReadMaker :: InternalInfo -> PositionReadMaker
24+-- >>> import Test.QuickCheck
11−pReadMaker _ = defaultPositionReadMaker
12−#else
13−import Network.Wai.Handler.Warp.FdCache
14−import Network.Wai.Handler.Warp.SendFile (positionRead)
15
25
16−pReadMaker :: InternalInfo -> PositionReadMaker
26+----------------------------------------------------------------
17−pReadMaker ii path = do
27+
18− (mfd, refresh) <- getFd ii path
28+data RspFileInfo = WithoutBody !H.Status
19− case mfd of
29+ | WithBody !H.Status !TokenHeaderList !Integer !Integer
20− Just fd -> return (pread fd, Refresher refresh)
30+ deriving (Eq,Show)
21− Nothing -> do
31+
22− fd <- openFile path
32+----------------------------------------------------------------
23− return (pread fd, Closer $ closeFile fd)
33+
34+conditionalRequest :: I.FileInfo
35+ -> TokenHeaderList -- Response
36+ -> ValueTable -- Request
37+ -> RspFileInfo
38+conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of
39+ nobody@(WithoutBody _) -> nobody
40+ WithBody s _ off len -> let !hs = (tokenLastModified,date) :
41+ addContentHeaders ths0 off len size
42+ in WithBody s hs off len
43+ where
44+ !mcondition = ifmodified reqtbl size mtime
45+ <|> ifunmodified reqtbl size mtime
46+ <|> ifrange reqtbl size mtime
47+ !condition = fromMaybe (unconditional reqtbl size) mcondition
48+
49+----------------------------------------------------------------
50+
51+{-# INLINE ifModifiedSince #-}
52+ifModifiedSince :: ValueTable -> Maybe HTTPDate
53+ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate
54+
55+{-# INLINE ifUnmodifiedSince #-}
56+ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate
57+ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate
58+
59+{-# INLINE ifRange #-}
60+ifRange :: ValueTable -> Maybe HTTPDate
61+ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate
62+
63+----------------------------------------------------------------
64+
65+{-# INLINE ifmodified #-}
66+ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
67+ifmodified reqtbl size mtime = do
68+ date <- ifModifiedSince reqtbl
69+ return $ if date /= mtime
70+ then unconditional reqtbl size
71+ else WithoutBody H.notModified304
72+
73+{-# INLINE ifunmodified #-}
74+ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
75+ifunmodified reqtbl size mtime = do
76+ date <- ifUnmodifiedSince reqtbl
77+ return $ if date == mtime
78+ then unconditional reqtbl size
79+ else WithoutBody H.preconditionFailed412
80+
81+{-# INLINE ifrange #-}
82+ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
83+ifrange reqtbl size mtime = do
84+ date <- ifRange reqtbl
85+ rng <- getHeaderValue tokenRange reqtbl
86+ return $ if date == mtime
87+ then parseRange rng size
88+ else WithBody H.ok200 [] 0 size
89+
90+{-# INLINE unconditional #-}
91+unconditional :: ValueTable -> Integer -> RspFileInfo
92+unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of
93+ Nothing -> WithBody H.ok200 [] 0 size
94+ Just rng -> parseRange rng size
95+
96+----------------------------------------------------------------
97+
98+{-# INLINE parseRange #-}
99+parseRange :: ByteString -> Integer -> RspFileInfo
100+parseRange rng size = case H.parseByteRanges rng of
101+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416
102+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416
103+ Just (r:_) -> let (!beg, !end) = checkRange r size
104+ !len = end - beg + 1
105+ s = if beg == 0 && end == size - 1 then
106+ H.ok200
107+ else
108+ H.partialContent206
109+ in WithBody s [] beg len
110+
111+{-# INLINE checkRange #-}
112+checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
113+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
114+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
115+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
116+
117+----------------------------------------------------------------
118+
119+{-# INLINE contentRangeHeader #-}
120+-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
121+-- for the range specified.
122+contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader
123+contentRangeHeader beg end total = (tokenContentRange, range)
124+ where
125+ range = C8.pack
126+ -- building with ShowS
127+ $ 'b' : 'y': 't' : 'e' : 's' : ' '
128+ : (if beg > end then ('*':) else
129+ showInt beg
130+ . ('-' :)
131+ . showInt end)
132+ ( '/'
133+ : showInt total "")
134+
135+{-# INLINE addContentHeaders #-}
136+addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList
137+addContentHeaders ths off len size
138+ | len == size = ths'
139+ | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size
140+ in ctrng:ths'
141+ where
142+ !lengthBS = packIntegral len
143+ !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths
144+
145+{-# INLINE addContentHeadersForFilePart #-}
146+-- |
147+--
148+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
149+-- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]
150+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
151+-- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]
152+addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList
153+addContentHeadersForFilePart hs part = addContentHeaders hs off len size
24 where
154 where
25− pread :: Fd -> PositionRead
155+ off = filePartOffset part
26− pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'
156+ len = filePartByteCount part
27− where
157+ size = filePartFileSize part
28− bytes' = fromIntegral bytes
29− off' = fromIntegral off
30−#endif
warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hsnew file+112
@@ -0,0 +1,112 @@
1+{-# LANGUAGE OverloadedStrings, BangPatterns #-}
2+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
3+
4+module Network.Wai.Handler.Warp.HTTP2.HPACK (
5+ hpackEncodeHeader
6+ , hpackEncodeHeaderLoop
7+ , hpackDecodeHeader
8+ , just
9+ , addNecessaryHeaders
10+ , addHeader -- testing
11+ ) where
12+
13+import qualified Control.Exception as E
14+import Network.HPACK hiding (Buffer)
15+import Network.HPACK.Token
16+import Network.HTTP2
17+
18+import Network.Wai.Handler.Warp.HTTP2.Types
19+import Network.Wai.Handler.Warp.Imports
20+import Network.Wai.Handler.Warp.PackInt
21+import qualified Network.Wai.Handler.Warp.Settings as S
22+import Network.Wai.Handler.Warp.Types
23+
24+-- $setup
25+-- >>> :set -XOverloadedStrings
26+
27+----------------------------------------------------------------
28+
29+{-# INLINE addHeader #-}
30+addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList
31+addHeader t "" tbl ths = case getHeaderValue t tbl of
32+ Nothing -> ths
33+ _ -> filter ((/= tokenServer) . fst) ths
34+addHeader t v tbl ths = case getHeaderValue t tbl of
35+ Nothing -> (t,v) : ths
36+ _ -> ths
37+
38+addNecessaryHeaders :: Context
39+ -> Rspn
40+ -> InternalInfo
41+ -> S.Settings
42+ -> IO TokenHeaderList
43+addNecessaryHeaders Context{..} rspn ii settings = do
44+ date <- getDate ii
45+ let !s = rspnStatus rspn
46+ !status = packStatus s
47+ !defServer = S.settingsServerName settings
48+ (!ths0,tbl) = rspnHeaders rspn
49+ !ths1 = addHeader tokenServer defServer tbl ths0
50+ !ths2 = addHeader tokenDate date tbl ths1
51+ !ths3 = (tokenStatus, status) : ths2
52+ return ths3
53+
54+----------------------------------------------------------------
55+
56+strategy :: EncodeStrategy
57+strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }
58+
59+-- Set-Cookie: contains only one cookie value.
60+-- So, we don't need to split it.
61+hpackEncodeHeader :: Context -> Buffer -> BufSize
62+ -> TokenHeaderList
63+ -> IO (TokenHeaderList, Int)
64+hpackEncodeHeader Context{..} buf siz ths =
65+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths
66+
67+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize
68+ -> TokenHeaderList
69+ -> IO (TokenHeaderList, Int)
70+hpackEncodeHeaderLoop Context{..} buf siz hs =
71+ encodeTokenHeader buf siz strategy False encodeDynamicTable hs
72+
73+----------------------------------------------------------------
74+
75+hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)
76+hpackDecodeHeader hdrblk Context{..} = do
77+ tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl
78+ unless (checkRequestHeader vt) $
79+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
80+ return tbl
81+ where
82+ handl IllegalHeaderName =
83+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
84+ handl _ =
85+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
86+
87+{-# INLINE checkRequestHeader #-}
88+checkRequestHeader :: ValueTable -> Bool
89+checkRequestHeader reqvt
90+ | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme
91+ | isJust mStatus = False
92+ | isNothing mMethod = False
93+ | isNothing mScheme = False
94+ | isNothing mPath = False
95+ | mPath == Just "" = False
96+ | isJust mConnection = False
97+ | just mTE (/= "trailers") = False
98+ | otherwise = True
99+ where
100+ mStatus = getHeaderValue tokenStatus reqvt
101+ mScheme = getHeaderValue tokenScheme reqvt
102+ mPath = getHeaderValue tokenPath reqvt
103+ mMethod = getHeaderValue tokenMethod reqvt
104+ mConnection = getHeaderValue tokenConnection reqvt
105+ mTE = getHeaderValue tokenTE reqvt
106+
107+{-# INLINE just #-}
108+just :: Maybe a -> (a -> Bool) -> Bool
109+just Nothing _ = False
110+just (Just x) p
111+ | p x = True
112+ | otherwise = False
warp/Network/Wai/Handler/Warp/HTTP2/Manager.hsnew file+95
@@ -0,0 +1,95 @@
1+{-# LANGUAGE CPP, BangPatterns #-}
2+
3+-- | A thread pool manager.
4+-- The manager has responsibility to spawn and kill
5+-- worker threads.
6+module Network.Wai.Handler.Warp.HTTP2.Manager (
7+ Manager
8+ , start
9+ , setAction
10+ , stop
11+ , spawnAction
12+ , addMyId
13+ , deleteMyId
14+ ) where
15+
16+import Control.Concurrent
17+import Control.Concurrent.STM
18+import Data.Foldable
19+import Data.IORef
20+import Data.Set (Set)
21+import qualified Data.Set as Set
22+
23+import Network.Wai.Handler.Warp.Imports
24+import Network.Wai.Handler.Warp.Settings
25+import qualified Network.Wai.Handler.Warp.Timeout as T
26+
27+----------------------------------------------------------------
28+
29+type Action = T.Manager -> IO ()
30+
31+data Command = Stop | Spawn | Add ThreadId | Delete ThreadId
32+
33+data Manager = Manager (TQueue Command) (IORef Action)
34+
35+-- | Starting a thread pool manager.
36+-- Its action is initially set to 'return ()' and should be set
37+-- by 'setAction'. This allows that the action can include
38+-- the manager itself.
39+start :: Settings -> IO Manager
40+start set = do
41+ q <- newTQueueIO
42+ ref <- newIORef (\_ -> return ())
43+ timmgr <- T.initialize $ settingsTimeout set * 1000000
44+ void $ forkIO $ go q Set.empty ref timmgr
45+ return $ Manager q ref
46+ where
47+ go q !tset0 ref timmgr = do
48+ x <- atomically $ readTQueue q
49+ case x of
50+ Stop -> kill tset0 >> T.killManager timmgr
51+ Spawn -> next tset0
52+ Add newtid -> let !tset = add newtid tset0
53+ in go q tset ref timmgr
54+ Delete oldtid -> let !tset = del oldtid tset0
55+ in go q tset ref timmgr
56+ where
57+ next tset = do
58+ action <- readIORef ref
59+ newtid <- forkIO (action timmgr)
60+ let !tset' = add newtid tset
61+ go q tset' ref timmgr
62+
63+setAction :: Manager -> Action -> IO ()
64+setAction (Manager _ ref) action = writeIORef ref action
65+
66+stop :: Manager -> IO ()
67+stop (Manager q _) = atomically $ writeTQueue q Stop
68+
69+spawnAction :: Manager -> IO ()
70+spawnAction (Manager q _) = atomically $ writeTQueue q Spawn
71+
72+addMyId :: Manager -> IO ()
73+addMyId (Manager q _) = do
74+ tid <- myThreadId
75+ atomically $ writeTQueue q $ Add tid
76+
77+deleteMyId :: Manager -> IO ()
78+deleteMyId (Manager q _) = do
79+ tid <- myThreadId
80+ atomically $ writeTQueue q $ Delete tid
81+
82+----------------------------------------------------------------
83+
84+add :: ThreadId -> Set ThreadId -> Set ThreadId
85+add tid set = set'
86+ where
87+ !set' = Set.insert tid set
88+
89+del :: ThreadId -> Set ThreadId -> Set ThreadId
90+del tid set = set'
91+ where
92+ !set' = Set.delete tid set
93+
94+kill :: Set ThreadId -> IO ()
95+kill set = traverse_ killThread set
warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hsdeleted−36
@@ -1,36 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE RecordWildCards #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Network.Wai.Handler.Warp.HTTP2.PushPromise where
6−
7−import qualified Control.Exception as E
8−import qualified Network.HTTP.Types as H
9−import qualified Network.HTTP2.Server as H2
10−
11−import Network.Wai
12−import Network.Wai.Handler.Warp.FileInfoCache
13−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)
14−import Network.Wai.Handler.Warp.HTTP2.Types
15−import Network.Wai.Handler.Warp.Imports
16−import Network.Wai.Handler.Warp.Types
17−
18−fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]
19−fromPushPromises ii req = do
20− mh2data <- getHTTP2Data req
21− let pp = case mh2data of
22− Nothing -> []
23− Just h2data -> http2dataPushPromise h2data
24− catMaybes <$> mapM (fromPushPromise ii) pp
25−
26−fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)
27−fromPushPromise ii (PushPromise path file rsphdr w) = do
28− efinfo <- E.try $ getFileInfo ii file
29− case efinfo of
30− Left (_ex :: E.IOException) -> return Nothing
31− Right finfo -> do
32− let !siz = fromIntegral $ fileInfoSize finfo
33− !fileSpec = H2.FileSpec file 0 siz
34− !rsp = H2.responseFile H.ok200 rsphdr fileSpec
35− !pp = H2.pushPromise path rsp w
36− return $ Just pp
warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hsnew file+397
@@ -0,0 +1,397 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE NamedFieldPuns #-}
3+{-# LANGUAGE BangPatterns #-}
4+{-# LANGUAGE CPP #-}
5+{-# LANGUAGE PatternGuards #-}
6+
7+module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where
8+
9+import Control.Concurrent
10+import Control.Concurrent.STM
11+import qualified Control.Exception as E
12+import qualified Data.ByteString as BS
13+import Data.IORef
14+import Network.HPACK
15+import Network.HPACK.Token
16+import Network.HTTP2
17+import Network.HTTP2.Priority (toPrecedence, delete, prepare)
18+
19+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
20+import Network.Wai.Handler.Warp.HTTP2.HPACK
21+import Network.Wai.Handler.Warp.HTTP2.Request
22+import Network.Wai.Handler.Warp.HTTP2.Types
23+import Network.Wai.Handler.Warp.Imports hiding (delete, insert, readInt)
24+import Network.Wai.Handler.Warp.ReadInt
25+import Network.Wai.Handler.Warp.Types
26+
27+----------------------------------------------------------------
28+
29+frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()
30+frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway
31+ where
32+ Context{ http2settings
33+ , streamTable
34+ , concurrency
35+ , continued
36+ , clientStreamId
37+ , inputQ
38+ , controlQ
39+ } = ctx
40+ sendGoaway e
41+ | Just (ConnectionError err msg) <- E.fromException e = do
42+ csid <- readIORef clientStreamId
43+ let !frame = goawayFrame csid err msg
44+ enqueueControl controlQ $ CGoaway frame
45+ | otherwise = return ()
46+
47+ sendReset err sid = do
48+ let !frame = resetFrame err sid
49+ enqueueControl controlQ $ CFrame frame
50+
51+ loop :: Int -> IO ()
52+ loop !n
53+ | n == 6 = do
54+ yield
55+ loop 0
56+ | otherwise = do
57+ hd <- recvN frameHeaderLength
58+ if BS.null hd then
59+ enqueueControl controlQ CFinish
60+ else do
61+ cont <- processStreamGuardingError $ decodeFrameHeader hd
62+ when cont $ loop (n + 1)
63+
64+ processStreamGuardingError (fid, FrameHeader{streamId})
65+ | isResponse streamId &&
66+ (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =
67+ E.throwIO $ ConnectionError ProtocolError "stream id should be odd"
68+ processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do
69+ mx <- readIORef continued
70+ case mx of
71+ Nothing -> do
72+ -- ignoring unknown frame
73+ consume payloadLength
74+ return True
75+ Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"
76+ processStreamGuardingError (FramePushPromise, _) =
77+ E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"
78+ processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do
79+ settings <- readIORef http2settings
80+ case checkFrameHeader settings typhdr of
81+ Left h2err -> case h2err of
82+ StreamError err sid -> do
83+ sendReset err sid
84+ consume payloadLength
85+ return True
86+ connErr -> E.throwIO connErr
87+ Right _ -> do
88+ ex <- E.try $ controlOrStream ftyp header
89+ case ex of
90+ Left (StreamError err sid) -> do
91+ sendReset err sid
92+ return True
93+ Left connErr -> E.throw connErr
94+ Right cont -> return cont
95+
96+ controlOrStream ftyp header@FrameHeader{streamId, payloadLength}
97+ | isControl streamId = do
98+ pl <- recvN payloadLength
99+ control ftyp header pl ctx
100+ | otherwise = do
101+ checkContinued
102+ !mstrm <- getStream
103+ pl <- recvN payloadLength
104+ case mstrm of
105+ Nothing -> do
106+ -- for h2spec only
107+ when (ftyp == FramePriority) $ do
108+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl
109+ checkPriority newpri streamId
110+ return True -- just ignore this frame
111+ Just strm@Stream{streamState,streamPrecedence} -> do
112+ state <- readIORef streamState
113+ state' <- stream ftyp header pl ctx state strm
114+ case state' of
115+ Open (NoBody tbl@(_,reqvt) pri) -> do
116+ resetContinued
117+ let mcl = readInt <$> getHeaderValue tokenContentLength reqvt
118+ when (just mcl (== (0 :: Int))) $
119+ E.throwIO $ StreamError ProtocolError streamId
120+ writeIORef streamPrecedence $ toPrecedence pri
121+ writeIORef streamState HalfClosed
122+ (!req, !ii) <- mkreq tbl (Just 0, return "")
123+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii
124+ Open (HasBody tbl@(_,reqvt) pri) -> do
125+ resetContinued
126+ q <- newTQueueIO
127+ let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt
128+ writeIORef streamPrecedence $ toPrecedence pri
129+ bodyLength <- newIORef 0
130+ writeIORef streamState $ Open (Body q mcl bodyLength)
131+ readQ <- newReadBody q
132+ bodySource <- mkSource readQ
133+ (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)
134+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii
135+ s@(Open Continued{}) -> do
136+ setContinued
137+ writeIORef streamState s
138+ s -> do -- Idle, Open Body, HalfClosed, Closed
139+ resetContinued
140+ writeIORef streamState s
141+ return True
142+ where
143+ setContinued = writeIORef continued (Just streamId)
144+ resetContinued = writeIORef continued Nothing
145+ checkContinued = do
146+ mx <- readIORef continued
147+ case mx of
148+ Nothing -> return ()
149+ Just sid
150+ | sid == streamId && ftyp == FrameContinuation -> return ()
151+ | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"
152+ getStream = do
153+ mstrm0 <- search streamTable streamId
154+ case mstrm0 of
155+ js@(Just strm0) -> do
156+ when (ftyp == FrameHeaders) $ do
157+ st <- readIORef $ streamState strm0
158+ when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed"
159+ -- Priority made an idele stream
160+ when (isIdle st) $ opened ctx strm0
161+ return js
162+ Nothing
163+ | isResponse streamId -> return Nothing
164+ | otherwise -> do
165+ when (ftyp `notElem` [FrameHeaders,FramePriority]) $
166+ E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream"
167+ csid <- readIORef clientStreamId
168+ if streamId <= csid then
169+ if ftyp == FramePriority then
170+ return Nothing -- will be ignored
171+ else
172+ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"
173+ else do
174+ when (ftyp == FrameHeaders) $ do
175+ writeIORef clientStreamId streamId
176+ cnt <- readIORef concurrency
177+ -- Checking the limitation of concurrency
178+ when (cnt >= maxConcurrency) $
179+ E.throwIO $ StreamError RefusedStream streamId
180+ ws <- initialWindowSize <$> readIORef http2settings
181+ newstrm <- newStream streamId (fromIntegral ws)
182+ when (ftyp == FrameHeaders) $ opened ctx newstrm
183+ insert streamTable streamId newstrm
184+ return $ Just newstrm
185+
186+ consume = void . recvN
187+
188+maxConcurrency :: Int
189+maxConcurrency = recommendedConcurrency
190+
191+initialFrame :: ByteString
192+initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]
193+
194+----------------------------------------------------------------
195+
196+control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
197+control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do
198+ SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs
199+ case checkSettingsList alist of
200+ Just x -> E.throwIO x
201+ Nothing -> return ()
202+ -- HTTP/2 Setting from a browser
203+ unless (testAck flags) $ do
204+ oldws <- initialWindowSize <$> readIORef http2settings
205+ modifyIORef' http2settings $ \old -> updateSettings old alist
206+ newws <- initialWindowSize <$> readIORef http2settings
207+ let diff = newws - oldws
208+ when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable
209+ let !frame = settingsFrame setAck []
210+ sent <- readIORef firstSettings
211+ let !setframe
212+ | sent = CSettings frame alist
213+ | otherwise = CSettings0 initialFrame frame alist
214+ unless sent $ writeIORef firstSettings True
215+ enqueueControl controlQ setframe
216+ return True
217+
218+control FramePing FrameHeader{flags} bs Context{controlQ} =
219+ if testAck flags then
220+ return True -- just ignore
221+ else do
222+ let !frame = pingFrame bs
223+ enqueueControl controlQ $ CFrame frame
224+ return True
225+
226+control FrameGoAway _ _ Context{controlQ} = do
227+ enqueueControl controlQ CFinish
228+ return False
229+
230+control FrameWindowUpdate header bs Context{connectionWindow} = do
231+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs
232+ !w <- atomically $ do
233+ w0 <- readTVar connectionWindow
234+ let !w1 = w0 + n
235+ writeTVar connectionWindow w1
236+ return w1
237+ when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"
238+ return True
239+
240+control _ _ _ _ =
241+ -- must not reach here
242+ return False
243+
244+----------------------------------------------------------------
245+
246+{-# INLINE guardIt #-}
247+guardIt :: Either HTTP2Error a -> IO a
248+guardIt x = case x of
249+ Left err -> E.throwIO err
250+ Right frame -> return frame
251+
252+
253+{-# INLINE checkPriority #-}
254+checkPriority :: Priority -> StreamId -> IO ()
255+checkPriority p me
256+ | dep == me = E.throwIO $ StreamError ProtocolError me
257+ | otherwise = return ()
258+ where
259+ dep = streamDependency p
260+
261+stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState
262+stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do
263+ HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs
264+ pri <- case mp of
265+ Nothing -> return defaultPriority
266+ Just p -> do
267+ checkPriority p streamNumber
268+ return p
269+ let !endOfStream = testEndStream flags
270+ !endOfHeader = testEndHeader flags
271+ if endOfHeader then do
272+ tbl <- hpackDecodeHeader frag ctx -- fixme
273+ return $ if endOfStream then
274+ Open (NoBody tbl pri)
275+ else
276+ Open (HasBody tbl pri)
277+ else do
278+ let !siz = BS.length frag
279+ return $ Open $ Continued [frag] siz 1 endOfStream pri
280+
281+stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do
282+ -- trailer is not supported.
283+ -- let's read and ignore it.
284+ HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs
285+ let !endOfStream = testEndStream flags
286+ if endOfStream then do
287+ atomically $ writeTQueue q ""
288+ return HalfClosed
289+ else
290+ -- we don't support continuation here.
291+ E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"
292+
293+stream FrameData
294+ header@FrameHeader{flags,payloadLength,streamId}
295+ bs
296+ Context{controlQ} s@(Open (Body q mcl bodyLength))
297+ Stream{streamNumber} = do
298+ DataFrame body <- guardIt $ decodeDataFrame header bs
299+ let !endOfStream = testEndStream flags
300+ len0 <- readIORef bodyLength
301+ let !len = len0 + payloadLength
302+ writeIORef bodyLength len
303+ when (payloadLength /= 0) $ do
304+ let !frame1 = windowUpdateFrame 0 payloadLength
305+ !frame2 = windowUpdateFrame streamNumber payloadLength
306+ !frame = frame1 `BS.append` frame2
307+ enqueueControl controlQ $ CFrame frame
308+ atomically $ writeTQueue q body
309+ if endOfStream then do
310+ case mcl of
311+ Nothing -> return ()
312+ Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId
313+ atomically $ writeTQueue q ""
314+ return HalfClosed
315+ else
316+ return s
317+
318+stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do
319+ let !endOfHeader = testEndHeader flags
320+ !rfrags' = frag : rfrags
321+ !siz' = siz + BS.length frag
322+ !n' = n + 1
323+ when (siz' > 51200) $ -- fixme: hard coding: 50K
324+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"
325+ when (n' > 10) $ -- fixme: hard coding
326+ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"
327+ if endOfHeader then do
328+ let !hdrblk = BS.concat $ reverse rfrags'
329+ tbl <- hpackDecodeHeader hdrblk ctx
330+ return $ if endOfStream then
331+ Open (NoBody tbl pri)
332+ else
333+ Open (HasBody tbl pri)
334+ else
335+ return $ Open $ Continued rfrags' siz' n' endOfStream pri
336+
337+stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do
338+ WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs
339+ !w <- atomically $ do
340+ w0 <- readTVar streamWindow
341+ let !w1 = w0 + n
342+ writeTVar streamWindow w1
343+ return w1
344+ when (isWindowOverflow w) $
345+ E.throwIO $ StreamError FlowControlError streamId
346+ return s
347+
348+stream FrameRSTStream header bs ctx _ strm = do
349+ RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs
350+ let !cc = Reset e
351+ closed ctx strm cc
352+ return $ Closed cc -- will be written to streamState again
353+
354+stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do
355+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs
356+ checkPriority newpri streamNumber
357+ oldpre <- readIORef streamPrecedence
358+ let !newpre = toPrecedence newpri
359+ writeIORef streamPrecedence newpre
360+ if isIdle s then do
361+ n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))
362+ -- fixme hard coding
363+ when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"
364+ prepare outputQ streamNumber newpri
365+ else do
366+ mx <- delete outputQ streamNumber oldpre
367+ case mx of
368+ Nothing -> return ()
369+ Just out -> enqueueOutput outputQ out
370+ return s
371+
372+-- this ordering is important
373+stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"
374+stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"
375+-- Ignore frames to streams we have just reset, per section 5.1.
376+stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st
377+stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId
378+stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId
379+
380+----------------------------------------------------------------
381+
382+{-# INLINE newReadBody #-}
383+newReadBody :: TQueue ByteString -> IO (IO ByteString)
384+newReadBody q = do
385+ ref <- newIORef False
386+ return $ readBody q ref
387+
388+{-# INLINE readBody #-}
389+readBody :: TQueue ByteString -> IORef Bool -> IO ByteString
390+readBody q ref = do
391+ eof <- readIORef ref
392+ if eof then
393+ return ""
394+ else do
395+ bs <- atomically $ readTQueue q
396+ when (bs == "") $ writeIORef ref True
397+ return bs
warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+20−18
@@ -1,7 +1,9 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
2
3
3module Network.Wai.Handler.Warp.HTTP2.Request (
4module Network.Wai.Handler.Warp.HTTP2.Request (
4− toRequest
5+ mkRequest
6+ , MkReq
5 , getHTTP2Data
7 , getHTTP2Data
6 , setHTTP2Data
8 , setHTTP2Data
7 , modifyHTTP2Data
9 , modifyHTTP2Data
@@ -18,37 +20,36 @@ import Network.Socket (SockAddr)
18import Network.Wai
20import Network.Wai
19import Network.Wai.Internal (Request(..))
21import Network.Wai.Internal (Request(..))
20import System.IO.Unsafe (unsafePerformIO)
22import System.IO.Unsafe (unsafePerformIO)
21−import qualified System.TimeManager as T
22
23
23import Network.Wai.Handler.Warp.HTTP2.Types
24import Network.Wai.Handler.Warp.HTTP2.Types
25+import Network.Wai.Handler.Warp.HashMap (hashByteString)
24import Network.Wai.Handler.Warp.Imports
26import Network.Wai.Handler.Warp.Imports
25−import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey, getClientCertificateKey)
27+import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)
26import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
28import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
29+import qualified Network.Wai.Handler.Warp.Timeout as Timeout
27import Network.Wai.Handler.Warp.Types
30import Network.Wai.Handler.Warp.Types
28
31
29−type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request
32+type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)
30
33
31−----------------------------------------------------------------
34+mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq
32−
33−toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq
34−toRequest ii settings addr ht bodylen body th transport = do
35+mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do
35 ref <- newIORef Nothing
36 ref <- newIORef Nothing
36− toRequest' ii settings addr ref ht bodylen body th transport
37+ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)
37
38
38−toRequest' :: InternalInfo -> S.Settings -> SockAddr
39+mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr
39 -> IORef (Maybe HTTP2Data)
40 -> IORef (Maybe HTTP2Data)
40− -> ToReq
41+ -> MkReq
41−toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req
42+mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)
42 where
43 where
43 !req = Request {
44 !req = Request {
44 requestMethod = colonMethod
45 requestMethod = colonMethod
45− , httpVersion = H.http20
46+ , httpVersion = http2ver
46 , rawPathInfo = rawPath
47 , rawPathInfo = rawPath
47 , pathInfo = H.decodePathSegments path
48 , pathInfo = H.decodePathSegments path
48 , rawQueryString = query
49 , rawQueryString = query
49 , queryString = H.parseQuery query
50 , queryString = H.parseQuery query
50 , requestHeaders = headers
51 , requestHeaders = headers
51− , isSecure = isTransportSecure transport
52+ , isSecure = True
52 , remoteHost = addr
53 , remoteHost = addr
53 , requestBody = body
54 , requestBody = body
54 , vault = vaultValue
55 , vault = vaultValue
@@ -77,13 +78,14 @@ toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = retur
77 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)
78 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)
78 !path = H.extractPath unparsedPath
79 !path = H.extractPath unparsedPath
79 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
80 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
80− -- fixme: pauseTimeout. th is not available here.
81+ !h = hashByteString rawPath
82+ !ii = toInternalInfo ii1 h
83+ !th = threadHandle ii
84+ !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
81− !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)
85+ $ Vault.insert getFileInfoKey (getFileInfo ii)
82 $ Vault.insert getHTTP2DataKey (readIORef ref)
86 $ Vault.insert getHTTP2DataKey (readIORef ref)
83 $ Vault.insert setHTTP2DataKey (writeIORef ref)
87 $ Vault.insert setHTTP2DataKey (writeIORef ref)
84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)
88 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)
85− $ Vault.insert pauseTimeoutKey (T.pause th)
86− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)
87 Vault.empty
89 Vault.empty
88
90
89getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))
91getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))
warp/Network/Wai/Handler/Warp/HTTP2/Response.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RecordWildCards #-}
3−{-# LANGUAGE BangPatterns #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−
6−module Network.Wai.Handler.Warp.HTTP2.Response (
7− fromResponse
8− ) where
9−
10−import qualified Control.Exception as E
11−import qualified Data.ByteString.Builder as BB
12−import qualified Network.HTTP.Types as H
13−import qualified Network.HTTP2.Server as H2
14−import Network.Wai hiding (responseFile, responseBuilder, responseStream)
15−import Network.Wai.Internal (Response(..))
16−
17−import Network.Wai.Handler.Warp.File
18−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)
19−import Network.Wai.Handler.Warp.HTTP2.Types
20−import Network.Wai.Handler.Warp.Header
21−import qualified Network.Wai.Handler.Warp.Response as R
22−import qualified Network.Wai.Handler.Warp.Settings as S
23−import Network.Wai.Handler.Warp.Types
24−
25−----------------------------------------------------------------
26−
27−fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response
28−fromResponse settings ii req rsp = do
29− date <- getDate ii
30− h2rsp <- case rsp of
31− ResponseFile st rsphdr path mpart -> do
32− let rsphdr' = add date svr rsphdr
33− responseFile st rsphdr' isHead path mpart ii reqhdr
34− ResponseBuilder st rsphdr builder -> do
35− let rsphdr' = add date svr rsphdr
36− return $ responseBuilder st rsphdr' isHead builder
37− ResponseStream st rsphdr strmbdy -> do
38− let rsphdr' = add date svr rsphdr
39− return $ responseStream st rsphdr' isHead strmbdy
40− _ -> error "ResponseRaw is not supported in HTTP/2"
41− mh2data <- getHTTP2Data req
42− case mh2data of
43− Nothing -> return h2rsp
44− Just h2data -> do
45− let !trailers = http2dataTrailers h2data
46− return $ H2.setResponseTrailersMaker h2rsp trailers
47− where
48− !isHead = requestMethod req == H.methodHead
49− !reqhdr = requestHeaders req
50− !svr = S.settingsServerName settings
51− add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr
52− -- fixme: not adding svr if already exists
53−
54−----------------------------------------------------------------
55−
56−responseFile :: H.Status -> H.ResponseHeaders -> Bool
57− -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders
58− -> IO H2.Response
59−responseFile st rsphdr _ _ _ _ _
60− | noBody st = return $ responseNoBody st rsphdr
61−
62−responseFile st rsphdr isHead path (Just fp) _ _ =
63− return $ responseFile2XX st rsphdr isHead fileSpec
64− where
65− !off' = fromIntegral $ filePartOffset fp
66− !bytes' = fromIntegral $ filePartByteCount fp
67− !fileSpec = H2.FileSpec path off' bytes'
68−
69−responseFile _ rsphdr isHead path Nothing ii reqhdr = do
70− efinfo <- E.try $ getFileInfo ii path
71− case efinfo of
72− Left (_ex :: E.IOException) -> return $ response404 rsphdr
73− Right finfo -> do
74− let reqidx = indexRequestHeader reqhdr
75− rspidx = indexResponseHeader rsphdr
76− case conditionalRequest finfo rsphdr rspidx reqidx of
77− WithoutBody s -> return $ responseNoBody s rsphdr
78− WithBody s rsphdr' off bytes -> do
79− let !off' = fromIntegral off
80− !bytes' = fromIntegral bytes
81− !fileSpec = H2.FileSpec path off' bytes'
82− return $ responseFile2XX s rsphdr' isHead fileSpec
83−
84−----------------------------------------------------------------
85−
86−responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response
87−responseFile2XX st rsphdr isHead fileSpec
88− | isHead = responseNoBody st rsphdr
89− | otherwise = H2.responseFile st rsphdr fileSpec
90−
91−----------------------------------------------------------------
92−
93−responseBuilder :: H.Status -> H.ResponseHeaders -> Bool
94− -> BB.Builder
95− -> H2.Response
96−responseBuilder st rsphdr isHead builder
97− | noBody st = responseNoBody st rsphdr
98− | isHead = responseNoBody st rsphdr
99− | otherwise = H2.responseBuilder st rsphdr builder
100−
101−----------------------------------------------------------------
102−
103−responseStream :: H.Status -> H.ResponseHeaders -> Bool
104− -> StreamingBody
105− -> H2.Response
106−responseStream st rsphdr isHead strmbdy
107− | noBody st = responseNoBody st rsphdr
108− | isHead = responseNoBody st rsphdr
109− | otherwise = H2.responseStreaming st rsphdr strmbdy
110−
111−----------------------------------------------------------------
112−
113−responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response
114−responseNoBody st rsphdr = H2.responseNoBody st rsphdr
115−
116−----------------------------------------------------------------
117−
118−response404 :: H.ResponseHeaders -> H2.Response
119−response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body
120− where
121− !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr
122− !body = BB.byteString "File not found"
123−
124−----------------------------------------------------------------
125−
126−noBody :: H.Status -> Bool
127−noBody = not . R.hasBody
warp/Network/Wai/Handler/Warp/HTTP2/Sender.hsnew file+536
@@ -0,0 +1,536 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, CPP #-}
3+{-# LANGUAGE NamedFieldPuns #-}
4+
5+module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where
6+
7+import Control.Concurrent.STM
8+import qualified Control.Exception as E
9+import qualified Data.ByteString as BS
10+import Data.ByteString.Builder (Builder)
11+import qualified Data.ByteString.Builder.Extra as B
12+import Data.IORef
13+import Foreign.Ptr (Ptr, plusPtr)
14+import Foreign.Storable (poke)
15+import Network.HPACK (setLimitForEncoding, toHeaderTable)
16+import Network.HTTP2
17+import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)
18+import Network.Wai
19+
20+#ifdef WINDOWS
21+import qualified System.IO as IO
22+#else
23+import Network.Wai.Handler.Warp.FdCache
24+import Network.Wai.Handler.Warp.SendFile (positionRead)
25+import qualified Network.Wai.Handler.Warp.Timeout as T
26+#endif
27+
28+import Network.Wai.Handler.Warp.Buffer
29+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
30+import Network.Wai.Handler.Warp.HTTP2.HPACK
31+import Network.Wai.Handler.Warp.HTTP2.Manager (Manager)
32+import Network.Wai.Handler.Warp.HTTP2.Types
33+import Network.Wai.Handler.Warp.Imports hiding (readInt)
34+import qualified Network.Wai.Handler.Warp.Settings as S
35+import Network.Wai.Handler.Warp.Types
36+
37+----------------------------------------------------------------
38+
39+data Leftover = LZero
40+ | LOne B.BufferWriter
41+ | LTwo ByteString B.BufferWriter
42+
43+----------------------------------------------------------------
44+
45+{-# INLINE getStreamWindowSize #-}
46+getStreamWindowSize :: Stream -> IO WindowSize
47+getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow
48+
49+{-# INLINE waitStreamWindowSize #-}
50+waitStreamWindowSize :: Stream -> IO ()
51+waitStreamWindowSize Stream{streamWindow} = atomically $ do
52+ w <- readTVar streamWindow
53+ check (w > 0)
54+
55+{-# INLINE waitStreaming #-}
56+waitStreaming :: TBQueue a -> IO ()
57+waitStreaming tbq = atomically $ do
58+ isEmpty <- isEmptyTBQueue tbq
59+ check (not isEmpty)
60+
61+data Switch = C Control
62+ | O (StreamId,Precedence,Output)
63+ | Flush
64+
65+frameSender :: Context -> Connection -> S.Settings -> Manager -> IO ()
66+frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
67+ conn@Connection{connWriteBuffer,connBufferSize,connSendAll}
68+ settings mgr = loop 0 `E.catch` ignore
69+ where
70+ dequeue off = do
71+ isEmpty <- isEmptyTQueue controlQ
72+ if isEmpty then do
73+ w <- readTVar connectionWindow
74+ check (w > 0)
75+ emp <- isEmptySTM outputQ
76+ if emp then
77+ if off /= 0 then return Flush else retry
78+ else
79+ O <$> dequeueSTM outputQ
80+ else
81+ C <$> readTQueue controlQ
82+
83+ loop off = do
84+ x <- atomically $ dequeue off
85+ case x of
86+ C ctl -> do
87+ when (off /= 0) $ flushN off
88+ off' <- control ctl off
89+ when (off' >= 0) $ loop off'
90+ O (_,pre,out) -> do
91+ let strm = outputStream out
92+ writeIORef (streamPrecedence strm) pre
93+ off' <- outputOrEnqueueAgain out off
94+ case off' of
95+ 0 -> loop 0
96+ _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding
97+ | otherwise -> loop off'
98+ Flush -> flushN off >> loop 0
99+
100+ control CFinish _ = return (-1)
101+ control (CGoaway frame) _ = connSendAll frame >> return (-1)
102+ control (CFrame frame) _ = connSendAll frame >> return 0
103+ control (CSettings frame alist) _ = do
104+ connSendAll frame
105+ setLimit alist
106+ return 0
107+ control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case
108+ let !buf = connWriteBuffer `plusPtr` off
109+ !off' = off + BS.length frame1 + BS.length frame2
110+ buf' <- copy buf frame1
111+ void $ copy buf' frame2
112+ setLimit alist
113+ return off'
114+
115+ {-# INLINE setLimit #-}
116+ setLimit alist = case lookup SettingsHeaderTableSize alist of
117+ Nothing -> return ()
118+ Just siz -> setLimitForEncoding siz encodeDynamicTable
119+
120+ output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do
121+ -- Data frame payload
122+ let !buf = connWriteBuffer `plusPtr` off0
123+ !siz = connBufferSize - off0
124+ Next datPayloadLen mnext <- curr buf siz lim
125+ off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D
126+ maybeEnqueueNext out mnext
127+ return off
128+
129+ output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do
130+ -- Header frame and Continuation frame
131+ let !sid = streamNumber strm
132+ !endOfStream = case rspn of
133+ RspnNobody _ _ -> True
134+ _ -> False
135+ ths <- addNecessaryHeaders ctx rspn ii settings
136+ kvlen <- headerContinue sid ths endOfStream off0
137+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen
138+ case rspn of
139+ RspnNobody _ _ -> do
140+ closed ctx strm Finished
141+ return off
142+ RspnFile _ _ path mpart -> do
143+ -- Data frame payload
144+ let payloadOff = off + frameHeaderLength
145+ Next datPayloadLen mnext <-
146+ fillFileBodyGetNext conn ii payloadOff lim path mpart
147+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
148+ maybeEnqueueNext out mnext
149+ return off'
150+ RspnBuilder _ _ builder -> do
151+ -- Data frame payload
152+ let payloadOff = off + frameHeaderLength
153+ Next datPayloadLen mnext <-
154+ fillBuilderBodyGetNext conn ii payloadOff lim builder
155+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
156+ maybeEnqueueNext out mnext
157+ return off'
158+ RspnStreaming _ _ tbq -> do
159+ let payloadOff = off + frameHeaderLength
160+ Next datPayloadLen mnext <-
161+ fillStreamBodyGetNext conn payloadOff lim tbq strm
162+ off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
163+ maybeEnqueueNext out mnext
164+ return off'
165+
166+ output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do
167+ -- Creating a push promise header
168+ -- Frame id should be associated stream id from the client.
169+ let !sid = streamNumber strm
170+ len <- pushPromise pid sid ths off0
171+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len
172+ output out{ outputType = ORspn } off lim
173+
174+ output _ _ _ = undefined -- never reach
175+
176+ outputOrEnqueueAgain out off = E.handle resetStream $ do
177+ state <- readIORef $ streamState strm
178+ if isClosed state then
179+ return off
180+ else case out of
181+ Output _ _ _ wait _ OWait -> do
182+ -- Checking if all push are done.
183+ let out' = out {
184+ outputHook = return ()
185+ , outputType = ORspn
186+ }
187+ forkAndEnqueueWhenReady wait outputQ out' mgr
188+ return off
189+ _ -> case mtbq of
190+ Just tbq -> checkStreaming tbq
191+ _ -> checkStreamWindowSize
192+ where
193+ strm = outputStream out
194+ mtbq = outputMaybeTBQueue out
195+ checkStreaming tbq = do
196+ isEmpty <- atomically $ isEmptyTBQueue tbq
197+ if isEmpty then do
198+ forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr
199+ return off
200+ else
201+ checkStreamWindowSize
202+ checkStreamWindowSize = do
203+ sws <- getStreamWindowSize strm
204+ if sws == 0 then do
205+ forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr
206+ return off
207+ else do
208+ cws <- atomically $ readTVar connectionWindow -- not 0
209+ let !lim = min cws sws
210+ output out off lim
211+ resetStream e = do
212+ closed ctx strm (ResetByMe e)
213+ let !rst = resetFrame InternalError $ streamNumber strm
214+ enqueueControl controlQ $ CFrame rst
215+ return off
216+
217+ {-# INLINE flushN #-}
218+ -- Flush the connection buffer to the socket, where the first 'n' bytes of
219+ -- the buffer are filled.
220+ flushN :: Int -> IO ()
221+ flushN n = bufferIO connWriteBuffer n connSendAll
222+
223+ headerContinue sid ths endOfStream off = do
224+ let !offkv = off + frameHeaderLength
225+ let !bufkv = connWriteBuffer `plusPtr` offkv
226+ !limkv = connBufferSize - offkv
227+ (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths
228+ let flag0 = case hs of
229+ [] -> setEndHeader defaultFlags
230+ _ -> defaultFlags
231+ flag = if endOfStream then setEndStream flag0 else flag0
232+ let buf = connWriteBuffer `plusPtr` off
233+ fillFrameHeader FrameHeaders kvlen sid flag buf
234+ continue sid kvlen hs
235+
236+ !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
237+ !headerPayloadLim = connBufferSize - frameHeaderLength
238+
239+ continue _ kvlen [] = return kvlen
240+ continue sid kvlen ths = do
241+ flushN $ kvlen + frameHeaderLength
242+ -- Now off is 0
243+ (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths
244+ when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"
245+ let flag = case ths' of
246+ [] -> setEndHeader defaultFlags
247+ _ -> defaultFlags
248+ fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
249+ continue sid kvlen' ths'
250+
251+ {-# INLINE maybeEnqueueNext #-}
252+ -- Re-enqueue the stream in the output queue.
253+ maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()
254+ maybeEnqueueNext _ Nothing = return ()
255+ maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'
256+ where
257+ !out' = out { outputType = ONext next }
258+
259+ {-# INLINE sendHeadersIfNecessary #-}
260+ -- Send headers if there is not room for a 1-byte data frame, and return
261+ -- the offset of the next frame's first header byte.
262+ sendHeadersIfNecessary off
263+ -- True if the connection buffer has room for a 1-byte data frame.
264+ | off + frameHeaderLength < connBufferSize = return off
265+ | otherwise = do
266+ flushN off
267+ return 0
268+
269+ fillDataHeader strm@Stream{streamWindow,streamNumber}
270+ off datPayloadLen mnext tell getH2D = do
271+ -- Data frame header
272+ mh2d <- getH2D
273+ let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of
274+ Nothing -> ([], True)
275+ Just ts -> (ts, null ts)
276+ !buf = connWriteBuffer `plusPtr` off
277+ !off' = off + frameHeaderLength + datPayloadLen
278+ !noMoreBody = isNothing mnext
279+ flag | noMoreBody && noTrailers = setEndStream defaultFlags
280+ | otherwise = defaultFlags
281+ fillFrameHeader FrameData datPayloadLen streamNumber flag buf
282+ off'' <- handleEndOfBody noMoreBody off' noTrailers trailers
283+ atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)
284+ atomically $ modifyTVar' streamWindow (subtract datPayloadLen)
285+ return off''
286+ where
287+ handleTrailers True off0 _ = return off0
288+ handleTrailers _ off0 trailers = do
289+ (ths,_) <- toHeaderTable trailers
290+ kvlen <- headerContinue streamNumber ths True off0
291+ sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen
292+ handleEndOfBody True off0 noTrailers trailers = do
293+ off1 <- handleTrailers noTrailers off0 trailers
294+ void tell
295+ closed ctx strm Finished
296+ return off1
297+ handleEndOfBody False off0 _ _ = return off0
298+
299+
300+ pushPromise pid sid ths off = do
301+ let !offsid = off + frameHeaderLength
302+ !bufsid = connWriteBuffer `plusPtr` offsid
303+ poke32 bufsid $ fromIntegral sid
304+ let !offkv = offsid + 4
305+ !bufkv = connWriteBuffer `plusPtr` offkv
306+ !limkv = connBufferSize - offkv
307+ (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths
308+ let !flag = setEndHeader defaultFlags -- No EndStream flag
309+ !buf = connWriteBuffer `plusPtr` off
310+ !len = kvlen + 4
311+ fillFrameHeader FramePushPromise len pid flag buf
312+ return len
313+
314+ {-# INLINE fillFrameHeader #-}
315+ fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf
316+ where
317+ hinfo = FrameHeader len flag sid
318+
319+ {-# INLINE ignore #-}
320+ ignore :: E.SomeException -> IO ()
321+ ignore _ = return ()
322+
323+----------------------------------------------------------------
324+
325+{-
326+ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)
327+ResponseBuilder Status ResponseHeaders Builder
328+ResponseStream Status ResponseHeaders StreamingBody
329+ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response
330+-}
331+
332+fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next
333+fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}
334+ _ off lim bb = do
335+ let datBuf = connWriteBuffer `plusPtr` off
336+ room = min (connBufferSize - off) lim
337+ (len, signal) <- B.runBuilder bb datBuf room
338+ return $ nextForBuilder len signal
339+
340+fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next
341+#ifdef WINDOWS
342+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}
343+ _ off lim path mpart = do
344+ let datBuf = connWriteBuffer `plusPtr` off
345+ room = min (connBufferSize - off) lim
346+ (start, bytes) <- fileStartEnd path mpart
347+ -- fixme: how to close Handle? GC does it at this moment.
348+ hdl <- IO.openBinaryFile path IO.ReadMode
349+ IO.hSeek hdl IO.AbsoluteSeek start
350+ len <- IO.hGetBufSome hdl datBuf (mini room bytes)
351+ let bytes' = bytes - fromIntegral len
352+ -- fixme: connWriteBuffer connBufferSize
353+ return $ nextForFile len hdl bytes' (return ())
354+#else
355+fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}
356+ ii off lim path mpart = do
357+ (mfd, refresh') <- getFd ii path
358+ (fd, refresh) <- case mfd of
359+ Nothing -> do
360+ fd' <- openFile path
361+ th <- T.register (timeoutManager ii) (closeFile fd')
362+ return (fd', T.tickle th)
363+ Just fd -> return (fd, refresh')
364+ let datBuf = connWriteBuffer `plusPtr` off
365+ room = min (connBufferSize - off) lim
366+ (start, bytes) <- fileStartEnd path mpart
367+ len <- positionRead fd datBuf (mini room bytes) start
368+ refresh
369+ let len' = fromIntegral len
370+ return $ nextForFile len fd (start + len') (bytes - len') refresh
371+#endif
372+
373+fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)
374+fileStartEnd _ (Just part) =
375+ return (filePartOffset part, filePartByteCount part)
376+fileStartEnd _ _ = error "fileStartEnd"
377+
378+----------------------------------------------------------------
379+
380+fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next
381+fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}
382+ off lim sq strm = do
383+ let datBuf = connWriteBuffer `plusPtr` off
384+ room = min (connBufferSize - off) lim
385+ (leftover, cont, len) <- runStreamBuilder datBuf room sq
386+ return $ nextForStream sq strm leftover cont len
387+
388+----------------------------------------------------------------
389+
390+fillBufBuilder :: Leftover -> DynaNext
391+fillBufBuilder leftover buf0 siz0 lim = do
392+ let payloadBuf = buf0 `plusPtr` frameHeaderLength
393+ room = min (siz0 - frameHeaderLength) lim
394+ case leftover of
395+ LZero -> error "fillBufBuilder: LZero"
396+ LOne writer -> do
397+ (len, signal) <- writer payloadBuf room
398+ getNext len signal
399+ LTwo bs writer
400+ | BS.length bs <= room -> do
401+ buf1 <- copy payloadBuf bs
402+ let len1 = BS.length bs
403+ (len2, signal) <- writer buf1 (room - len1)
404+ getNext (len1 + len2) signal
405+ | otherwise -> do
406+ let (bs1,bs2) = BS.splitAt room bs
407+ void $ copy payloadBuf bs1
408+ getNext room (B.Chunk bs2 writer)
409+ where
410+ getNext l s = return $ nextForBuilder l s
411+
412+nextForBuilder :: BytesFilled -> B.Next -> Next
413+nextForBuilder len B.Done
414+ = Next len Nothing
415+nextForBuilder len (B.More _ writer)
416+ = Next len $ Just (fillBufBuilder (LOne writer))
417+nextForBuilder len (B.Chunk bs writer)
418+ = Next len $ Just (fillBufBuilder (LTwo bs writer))
419+
420+----------------------------------------------------------------
421+
422+runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence
423+ -> IO (Leftover, Bool, BytesFilled)
424+runStreamBuilder buf0 room0 sq = loop buf0 room0 0
425+ where
426+ loop !buf !room !total = do
427+ mbuilder <- atomically $ tryReadTBQueue sq
428+ case mbuilder of
429+ Nothing -> return (LZero, True, total)
430+ Just (SBuilder builder) -> do
431+ (len, signal) <- B.runBuilder builder buf room
432+ let !total' = total + len
433+ case signal of
434+ B.Done -> loop (buf `plusPtr` len) (room - len) total'
435+ B.More _ writer -> return (LOne writer, True, total')
436+ B.Chunk bs writer -> return (LTwo bs writer, True, total')
437+ Just SFlush -> return (LZero, True, total)
438+ Just SFinish -> return (LZero, False, total)
439+
440+fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext
441+fillBufStream leftover0 sq strm buf0 siz0 lim0 = do
442+ let payloadBuf = buf0 `plusPtr` frameHeaderLength
443+ room0 = min (siz0 - frameHeaderLength) lim0
444+ case leftover0 of
445+ LZero -> do
446+ (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq
447+ getNext leftover cont len
448+ LOne writer -> write writer payloadBuf room0 0
449+ LTwo bs writer
450+ | BS.length bs <= room0 -> do
451+ buf1 <- copy payloadBuf bs
452+ let len = BS.length bs
453+ write writer buf1 (room0 - len) len
454+ | otherwise -> do
455+ let (bs1,bs2) = BS.splitAt room0 bs
456+ void $ copy payloadBuf bs1
457+ getNext (LTwo bs2 writer) True room0
458+ where
459+ getNext l b r = return $ nextForStream sq strm l b r
460+ write writer1 buf room sofar = do
461+ (len, signal) <- writer1 buf room
462+ case signal of
463+ B.Done -> do
464+ (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq
465+ let !total = sofar + len + extra
466+ getNext leftover cont total
467+ B.More _ writer -> do
468+ let !total = sofar + len
469+ getNext (LOne writer) True total
470+ B.Chunk bs writer -> do
471+ let !total = sofar + len
472+ getNext (LTwo bs writer) True total
473+
474+nextForStream :: TBQueue Sequence -> Stream
475+ -> Leftover -> Bool -> BytesFilled
476+ -> Next
477+nextForStream _ _ _ False len = Next len Nothing
478+nextForStream sq strm leftOrZero True len =
479+ Next len $ Just (fillBufStream leftOrZero sq strm)
480+
481+----------------------------------------------------------------
482+
483+#ifdef WINDOWS
484+fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext
485+fillBufFile h bytes refresh buf siz lim = do
486+ let payloadBuf = buf `plusPtr` frameHeaderLength
487+ room = min (siz - frameHeaderLength) lim
488+ len <- IO.hGetBufSome h payloadBuf room
489+ refresh
490+ let bytes' = bytes - fromIntegral len
491+ return $ nextForFile len h bytes' refresh
492+
493+nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next
494+nextForFile 0 _ _ _ = Next 0 Nothing
495+nextForFile len _ 0 _ = Next len Nothing
496+nextForFile len h bytes refresh =
497+ Next len $ Just (fillBufFile h bytes refresh)
498+#else
499+fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext
500+fillBufFile fd start bytes refresh buf siz lim = do
501+ let payloadBuf = buf `plusPtr` frameHeaderLength
502+ room = min (siz - frameHeaderLength) lim
503+ len <- positionRead fd payloadBuf (mini room bytes) start
504+ let len' = fromIntegral len
505+ refresh
506+ return $ nextForFile len fd (start + len') (bytes - len') refresh
507+
508+nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next
509+nextForFile 0 _ _ _ _ = Next 0 Nothing
510+nextForFile len _ _ 0 _ = Next len Nothing
511+nextForFile len fd start bytes refresh =
512+ Next len $ Just (fillBufFile fd start bytes refresh)
513+#endif
514+
515+{-# INLINE mini #-}
516+mini :: Int -> Integer -> Int
517+mini i n
518+ | fromIntegral i < n = i
519+ | otherwise = fromIntegral n
520+
521+
522+----------------------------------------------------------------
523+
524+poke32 :: Ptr Word8 -> Word32 -> IO ()
525+poke32 ptr i = do
526+ poke ptr w0
527+ poke8 ptr 1 w1
528+ poke8 ptr 2 w2
529+ poke8 ptr 3 w3
530+ where
531+ w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)
532+ w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)
533+ w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)
534+ w3 = fromIntegral (i .&. 0xff)
535+ poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()
536+ poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w
warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+265−13
@@ -1,26 +1,282 @@
1−{-# LANGUAGE NamedFieldPuns #-}
1+{-# LANGUAGE OverloadedStrings, CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
3+{-# LANGUAGE BangPatterns #-}
4
4
5module Network.Wai.Handler.Warp.HTTP2.Types where
5module Network.Wai.Handler.Warp.HTTP2.Types where
6
6
7+import Control.Concurrent (forkIO)
8+import Control.Concurrent.STM
9+import Control.Exception (SomeException, bracket)
7import qualified Data.ByteString as BS
10import qualified Data.ByteString as BS
11+import Data.ByteString.Builder (Builder)
12+import Data.IORef
13+import Data.IntMap.Strict (IntMap, IntMap)
14+import qualified Data.IntMap.Strict as M
15+import Network.HPACK hiding (Buffer)
8import qualified Network.HTTP.Types as H
16import qualified Network.HTTP.Types as H
9import Network.HTTP2
17import Network.HTTP2
10−import qualified Network.HTTP2.Server as H2
18+import Network.HTTP2.Priority
19+import Network.Wai (Request, FilePart)
11
20
21+import Network.Wai.Handler.Warp.HTTP2.Manager
12import Network.Wai.Handler.Warp.Imports
22import Network.Wai.Handler.Warp.Imports
13import Network.Wai.Handler.Warp.Types
23import Network.Wai.Handler.Warp.Types
14
24
15----------------------------------------------------------------
25----------------------------------------------------------------
16
26
27+http2ver :: H.HttpVersion
28+http2ver = H.HttpVersion 2 0
29+
17isHTTP2 :: Transport -> Bool
30isHTTP2 :: Transport -> Bool
18isHTTP2 TCP = False
31isHTTP2 TCP = False
19isHTTP2 tls = useHTTP2
32isHTTP2 tls = useHTTP2
20 where
33 where
21 useHTTP2 = case tlsNegotiatedProtocol tls of
34 useHTTP2 = case tlsNegotiatedProtocol tls of
22 Nothing -> False
35 Nothing -> False
23− Just proto -> "h2" `BS.isPrefixOf` proto
36+ Just proto -> "h2-" `BS.isPrefixOf` proto
37+
38+----------------------------------------------------------------
39+
40+data Input = Input Stream Request ValueTable InternalInfo
41+
42+----------------------------------------------------------------
43+
44+type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next
45+
46+type BytesFilled = Int
47+
48+data Next = Next !BytesFilled (Maybe DynaNext)
49+
50+data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)
51+ | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)
52+ | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder
53+ | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)
54+
55+rspnStatus :: Rspn -> H.Status
56+rspnStatus (RspnNobody s _) = s
57+rspnStatus (RspnStreaming s _ _) = s
58+rspnStatus (RspnBuilder s _ _) = s
59+rspnStatus (RspnFile s _ _ _ ) = s
60+
61+rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)
62+rspnHeaders (RspnNobody _ t) = t
63+rspnHeaders (RspnStreaming _ t _) = t
64+rspnHeaders (RspnBuilder _ t _) = t
65+rspnHeaders (RspnFile _ t _ _ ) = t
66+
67+data Output = Output {
68+ outputStream :: !Stream
69+ , outputRspn :: !Rspn
70+ , outputII :: !InternalInfo
71+ , outputHook :: IO () -- OPush: wait for done, O*: telling done
72+ , outputH2Data :: IO (Maybe HTTP2Data)
73+ , outputType :: !OutputType
74+ }
75+
76+data OutputType = ORspn
77+ | OWait
78+ | OPush !TokenHeaderList !StreamId -- associated stream id from client
79+ | ONext !DynaNext
80+
81+outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)
82+outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq
83+outputMaybeTBQueue _ = Nothing
84+
85+data Control = CFinish
86+ | CGoaway !ByteString
87+ | CFrame !ByteString
88+ | CSettings !ByteString !SettingsList
89+ | CSettings0 !ByteString !ByteString !SettingsList
90+
91+----------------------------------------------------------------
92+
93+data Sequence = SFinish
94+ | SFlush
95+ | SBuilder Builder
96+
97+----------------------------------------------------------------
98+
99+-- | The context for HTTP/2 connection.
100+data Context = Context {
101+ -- HTTP/2 settings received from a browser
102+ http2settings :: !(IORef Settings)
103+ , firstSettings :: !(IORef Bool)
104+ , streamTable :: !StreamTable
105+ , concurrency :: !(IORef Int)
106+ , priorityTreeSize :: !(IORef Int)
107+ -- | RFC 7540 says "Other frames (from any stream) MUST NOT
108+ -- occur between the HEADERS frame and any CONTINUATION
109+ -- frames that might follow". This field is used to implement
110+ -- this requirement.
111+ , continued :: !(IORef (Maybe StreamId))
112+ , clientStreamId :: !(IORef StreamId)
113+ , serverStreamId :: !(IORef StreamId)
114+ , inputQ :: !(TQueue Input)
115+ , outputQ :: !(PriorityTree Output)
116+ , controlQ :: !(TQueue Control)
117+ , encodeDynamicTable :: !DynamicTable
118+ , decodeDynamicTable :: !DynamicTable
119+ -- the connection window for data from a server to a browser.
120+ , connectionWindow :: !(TVar WindowSize)
121+ }
122+
123+----------------------------------------------------------------
124+
125+newContext :: IO Context
126+newContext = Context <$> newIORef defaultSettings
127+ <*> newIORef False
128+ <*> newStreamTable
129+ <*> newIORef 0
130+ <*> newIORef 0
131+ <*> newIORef Nothing
132+ <*> newIORef 0
133+ <*> newIORef 0
134+ <*> newTQueueIO
135+ <*> newPriorityTree
136+ <*> newTQueueIO
137+ <*> newDynamicTableForEncoding defaultDynamicTableSize
138+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096
139+ <*> newTVarIO defaultInitialWindowSize
140+
141+clearContext :: Context -> IO ()
142+clearContext _ctx = return ()
143+
144+----------------------------------------------------------------
145+
146+data OpenState =
147+ JustOpened
148+ | Continued [HeaderBlockFragment]
149+ !Int -- Total size
150+ !Int -- The number of continuation frames
151+ !Bool -- End of stream
152+ !Priority
153+ | NoBody (TokenHeaderList,ValueTable) !Priority
154+ | HasBody (TokenHeaderList,ValueTable) !Priority
155+ | Body !(TQueue ByteString)
156+ !(Maybe Int) -- received Content-Length
157+ -- compared the body length for error checking
158+ !(IORef Int) -- actual body length
159+
160+data ClosedCode = Finished
161+ | Killed
162+ | Reset !ErrorCodeId
163+ | ResetByMe SomeException
164+ deriving Show
165+
166+data StreamState =
167+ Idle
168+ | Open !OpenState
169+ | HalfClosed
170+ | Closed !ClosedCode
171+ | Reserved
172+
173+isIdle :: StreamState -> Bool
174+isIdle Idle = True
175+isIdle _ = False
176+
177+isOpen :: StreamState -> Bool
178+isOpen Open{} = True
179+isOpen _ = False
180+
181+isHalfClosed :: StreamState -> Bool
182+isHalfClosed HalfClosed = True
183+isHalfClosed _ = False
184+
185+isClosed :: StreamState -> Bool
186+isClosed Closed{} = True
187+isClosed _ = False
188+
189+instance Show StreamState where
190+ show Idle = "Idle"
191+ show Open{} = "Open"
192+ show HalfClosed = "HalfClosed"
193+ show (Closed e) = "Closed: " ++ show e
194+ show Reserved = "Reserved"
195+
196+----------------------------------------------------------------
197+
198+data Stream = Stream {
199+ streamNumber :: !StreamId
200+ , streamState :: !(IORef StreamState)
201+ , streamWindow :: !(TVar WindowSize)
202+ , streamPrecedence :: !(IORef Precedence)
203+ }
204+
205+instance Show Stream where
206+ show s = show (streamNumber s)
207+
208+newStream :: StreamId -> WindowSize -> IO Stream
209+newStream sid win = Stream sid <$> newIORef Idle
210+ <*> newTVarIO win
211+ <*> newIORef defaultPrecedence
212+
213+newPushStream :: Context -> WindowSize -> Precedence -> IO Stream
214+newPushStream Context{serverStreamId} win pre = do
215+ sid <- atomicModifyIORef' serverStreamId inc2
216+ Stream sid <$> newIORef Reserved
217+ <*> newTVarIO win
218+ <*> newIORef pre
219+ where
220+ inc2 x = let !x' = x + 2 in (x', x')
221+
222+----------------------------------------------------------------
223+
224+opened :: Context -> Stream -> IO ()
225+opened Context{concurrency} Stream{streamState} = do
226+ atomicModifyIORef' concurrency (\x -> (x+1,()))
227+ writeIORef streamState (Open JustOpened)
228+
229+closed :: Context -> Stream -> ClosedCode -> IO ()
230+closed Context{concurrency,streamTable} Stream{streamState,streamNumber} cc = do
231+ remove streamTable streamNumber
232+ atomicModifyIORef' concurrency (\x -> (x-1,()))
233+ writeIORef streamState (Closed cc) -- anyway
234+
235+----------------------------------------------------------------
236+
237+newtype StreamTable = StreamTable (IORef (IntMap Stream))
238+
239+newStreamTable :: IO StreamTable
240+newStreamTable = StreamTable <$> newIORef M.empty
241+
242+insert :: StreamTable -> M.Key -> Stream -> IO ()
243+insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->
244+ let !m' = M.insert k v m
245+ in (m', ())
246+
247+remove :: StreamTable -> M.Key -> IO ()
248+remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->
249+ let !m' = M.delete k m
250+ in (m', ())
251+
252+search :: StreamTable -> M.Key -> IO (Maybe Stream)
253+search (StreamTable ref) k = M.lookup k <$> readIORef ref
254+
255+updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()
256+updateAllStreamWindow adst (StreamTable ref) = do
257+ strms <- M.elems <$> readIORef ref
258+ forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst
259+
260+{-# INLINE forkAndEnqueueWhenReady #-}
261+forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()
262+forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->
263+ void . forkIO $ do
264+ wait
265+ enqueueOutput outQ out
266+ where
267+ setup = addMyId mgr
268+ teardown _ = deleteMyId mgr
269+
270+{-# INLINE enqueueOutput #-}
271+enqueueOutput :: PriorityTree Output -> Output -> IO ()
272+enqueueOutput outQ out = do
273+ let Stream{..} = outputStream out
274+ pre <- readIORef streamPrecedence
275+ enqueue outQ streamNumber pre out
276+
277+{-# INLINE enqueueControl #-}
278+enqueueControl :: TQueue Control -> Control -> IO ()
279+enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl
24
280
25----------------------------------------------------------------
281----------------------------------------------------------------
26
282
@@ -32,21 +288,17 @@ data HTTP2Data = HTTP2Data {
32 --
288 --
33 -- Since: 3.2.7
289 -- Since: 3.2.7
34 http2dataPushPromise :: [PushPromise]
290 http2dataPushPromise :: [PushPromise]
35− -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.
36− --
37− -- Since: 3.2.8 but the type changed in 3.3.0
291+ -- Since: 3.2.8
38− , http2dataTrailers :: H2.TrailersMaker
292+ , http2dataTrailers :: H.ResponseHeaders
39− }
293+ } deriving (Eq,Show)
40
294
41-- | Default HTTP/2 specific data.
295-- | Default HTTP/2 specific data.
42--
296--
43-- Since: 3.2.7
297-- Since: 3.2.7
44defaultHTTP2Data :: HTTP2Data
298defaultHTTP2Data :: HTTP2Data
45−defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker
299+defaultHTTP2Data = HTTP2Data [] []
46
300
47-- | HTTP/2 push promise or sever push.
301-- | HTTP/2 push promise or sever push.
48−-- This allows files only for backward-compatibility
49−-- while the HTTP/2 library supports other types.
50--
302--
51-- Since: 3.2.7
303-- Since: 3.2.7
52data PushPromise = PushPromise {
304data PushPromise = PushPromise {
warp/Network/Wai/Handler/Warp/HTTP2/Worker.hsnew file+315
@@ -0,0 +1,315 @@
1+{-# LANGUAGE NamedFieldPuns #-}
2+{-# LANGUAGE PatternGuards #-}
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE BangPatterns #-}
7+
8+module Network.Wai.Handler.Warp.HTTP2.Worker (
9+ Responder
10+ , response
11+ , worker
12+ ) where
13+
14+import Control.Concurrent.STM
15+import Control.Exception (SomeException(..), AsyncException(..))
16+import qualified Control.Exception as E
17+import Data.ByteString.Builder (byteString)
18+import Data.IORef
19+import Network.HPACK
20+import Network.HPACK.Token
21+import qualified Network.HTTP.Types as H
22+import Network.HTTP2
23+import Network.HTTP2.Priority
24+import Network.Wai
25+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))
26+
27+import Network.Wai.Handler.Warp.FileInfoCache
28+import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
29+import Network.Wai.Handler.Warp.HTTP2.File
30+import Network.Wai.Handler.Warp.HTTP2.Manager
31+import Network.Wai.Handler.Warp.HTTP2.Request
32+import Network.Wai.Handler.Warp.HTTP2.Types
33+import Network.Wai.Handler.Warp.Imports hiding (insert)
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+
39+----------------------------------------------------------------
40+
41+-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.
42+-- This type implements the second argument (Response -> IO ResponseReceived)
43+-- with extra arguments.
44+type Responder = InternalInfo
45+ -> ValueTable -- for Request
46+ -> ThreadContinue
47+ -> Stream
48+ -> Request
49+ -> Response
50+ -> IO ResponseReceived
51+
52+pushStream :: Context -> S.Settings
53+ -> StreamId -> ValueTable -> Request -> InternalInfo
54+ -> Maybe HTTP2Data
55+ -> IO (OutputType, IO ())
56+pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())
57+pushStream ctx@Context{http2settings,outputQ,streamTable}
58+ settings pid reqvt req ii (Just h2d)
59+ | len == 0 = return (ORspn, return ())
60+ | otherwise = do
61+ pushable <- enablePush <$> readIORef http2settings
62+ if pushable then do
63+ tvar <- newTVarIO 0
64+ lim <- push tvar pps0 0
65+ if lim == 0 then
66+ return (ORspn, return ())
67+ else
68+ return (OWait, waiter lim tvar)
69+ else
70+ return (ORspn, return ())
71+ where
72+ !pps0 = http2dataPushPromise h2d
73+ !len = length pps0
74+ !pushLogger = S.settingsServerPushLogger settings
75+ increment tvar = atomically $ modifyTVar' tvar (+1)
76+ waiter lim tvar = atomically $ do
77+ n <- readTVar tvar
78+ check (n >= lim)
79+ !h2data = getHTTP2Data req
80+ push _ [] !n = return (n :: Int)
81+ push tvar (pp:pps) !n = do
82+ let !file = promisedFile pp
83+ efinfo <- E.try $ getFileInfo ii file
84+ case efinfo of
85+ Left (_ex :: E.IOException) -> push tvar pps n
86+ Right (FileInfo _ size _ date) -> do
87+ ws <- initialWindowSize <$> readIORef http2settings
88+ let !w = promisedWeight pp
89+ !pri = defaultPriority { weight = w }
90+ !pre = toPrecedence pri
91+ strm <- newPushStream ctx ws pre
92+ let !sid = streamNumber strm
93+ insert streamTable sid strm
94+ (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)
95+ let !scheme = fromJust $ getHeaderValue tokenScheme reqvt
96+ -- fixme: this value can be Nothing
97+ !auth = fromJust (getHeaderValue tokenHost reqvt
98+ <|> getHeaderValue tokenAuthority reqvt)
99+ !path = promisedPath pp
100+ !promisedRequest = [(tokenMethod, H.methodGet)
101+ ,(tokenScheme, scheme)
102+ ,(tokenAuthority, auth)
103+ ,(tokenPath, path)]
104+ !part = FilePart 0 size size
105+ !rsp = RspnFile H.ok200 (ths,vt) file (Just part)
106+ !ths = (tokenLastModified,date) :
107+ addContentHeadersForFilePart ths0 part
108+ pushLogger req path size
109+ let !ot = OPush promisedRequest pid
110+ !out = Output strm rsp ii (increment tvar) h2data ot
111+ enqueueOutput outputQ out
112+ push tvar pps (n + 1)
113+
114+
115+-- | This function is passed to workers.
116+-- They also pass 'Response's from 'Application's to this function.
117+-- This function enqueues commands for the HTTP/2 sender.
118+response :: S.Settings -> Context -> Manager -> Responder
119+response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of
120+ ResponseStream s0 hs0 strmbdy
121+ | noBody s0 -> responseNoBody s0 hs0
122+ | isHead -> responseNoBody s0 hs0
123+ | otherwise -> getHTTP2Data req
124+ >>= pushStream ctx settings sid reqvt req ii
125+ >>= responseStreaming s0 hs0 strmbdy
126+ ResponseBuilder s0 hs0 b
127+ | noBody s0 -> responseNoBody s0 hs0
128+ | isHead -> responseNoBody s0 hs0
129+ | otherwise -> getHTTP2Data req
130+ >>= pushStream ctx settings sid reqvt req ii
131+ >>= responseBuilderBody s0 hs0 b
132+ ResponseFile s0 hs0 p mp
133+ | noBody s0 -> responseNoBody s0 hs0
134+ | otherwise -> getHTTP2Data req
135+ >>= pushStream ctx settings sid reqvt req ii
136+ >>= responseFileXXX s0 hs0 p mp
137+ ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"
138+ where
139+ noBody = not . R.hasBody
140+ !isHead = requestMethod req == H.methodHead
141+ !logger = S.settingsLogger settings
142+ !th = threadHandle ii
143+ sid = streamNumber strm
144+ !h2data = getHTTP2Data req
145+
146+ -- Ideally, log messages should be written when responses are
147+ -- actually sent. But there is no way to keep good memory usage
148+ -- (resist to Request leak) and throughput. By compromise,
149+ -- log message are written here even the window size of streams
150+ -- is 0.
151+
152+ responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s
153+
154+ responseNoBody' s tbl = do
155+ logger req s Nothing
156+ setThreadContinue tconf True
157+ let !rspn = RspnNobody s tbl
158+ !out = Output strm rspn ii (return ()) h2data ORspn
159+ enqueueOutput outputQ out
160+ return ResponseReceived
161+
162+ responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do
163+ logger req s Nothing
164+ setThreadContinue tconf True
165+ tbl <- toHeaderTable hs0
166+ let !rspn = RspnBuilder s tbl bdy
167+ !out = Output strm rspn ii tell h2data rspnOrWait
168+ enqueueOutput outputQ out
169+ return ResponseReceived
170+
171+ responseFileXXX _ hs0 path Nothing aux = do
172+ efinfo <- E.try $ getFileInfo ii path
173+ case efinfo of
174+ Left (_ex :: E.IOException) -> response404 hs0
175+ Right finfo -> do
176+ (rspths0,vt) <- toHeaderTable hs0
177+ case conditionalRequest finfo rspths0 reqvt of
178+ WithoutBody s -> responseNoBody s hs0
179+ WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux
180+
181+ responseFileXXX s0 hs0 path mpart aux = do
182+ tbl <- toHeaderTable hs0
183+ responseFile2XX s0 tbl path mpart aux
184+
185+ responseFile2XX s tbl path mpart (rspnOrWait,tell)
186+ | isHead = do
187+ logger req s Nothing
188+ responseNoBody' s tbl
189+ | otherwise = do
190+ logger req s (filePartByteCount <$> mpart)
191+ setThreadContinue tconf True
192+ let !rspn = RspnFile s tbl path mpart
193+ !out = Output strm rspn ii tell h2data rspnOrWait
194+ enqueueOutput outputQ out
195+ return ResponseReceived
196+
197+ response404 hs0 = responseBuilderBody s hs body (ORspn, return ())
198+ where
199+ s = H.notFound404
200+ hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
201+ body = byteString "File not found"
202+
203+ responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do
204+ logger req s0 Nothing
205+ -- We must not exit this WAI application.
206+ -- If the application exits, streaming would be also closed.
207+ -- So, this work occupies this thread.
208+ --
209+ -- We need to increase the number of workers.
210+ spawnAction mgr
211+ -- After this work, this thread stops to decease
212+ -- the number of workers.
213+ setThreadContinue tconf False
214+ -- Since 'StreamingBody' is loop, we cannot control it.
215+ -- So, let's serialize 'Builder' with a designated queue.
216+ tbq <- newTBQueueIO 10 -- fixme: hard coding: 10
217+ tbl <- toHeaderTable hs0
218+ let !rspn = RspnStreaming s0 tbl tbq
219+ !out = Output strm rspn ii tell h2data rspnOrWait
220+ enqueueOutput outputQ out
221+ let push b = do
222+ atomically $ writeTBQueue tbq (SBuilder b)
223+ T.tickle th
224+ flush = atomically $ writeTBQueue tbq SFlush
225+ _ <- strmbdy push flush
226+ atomically $ writeTBQueue tbq SFinish
227+ deleteMyId mgr
228+ return ResponseReceived
229+
230+worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO ()
231+worker ctx@Context{inputQ,controlQ} set app responder tm = do
232+ sinfo <- newStreamInfo
233+ tcont <- newThreadContinue
234+ let timeoutAction = return () -- cannot close the shared connection
235+ E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont
236+ where
237+ go sinfo tcont th = do
238+ setThreadContinue tcont True
239+ ex <- E.try $ do
240+ T.pause th
241+ inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ
242+ setStreamInfo sinfo inp
243+ T.resume th
244+ T.tickle th
245+ app req $ responder ii reqvt tcont strm req
246+ cont1 <- case ex of
247+ Right ResponseReceived -> return True
248+ Left e@(SomeException _)
249+ -- killed by the local worker manager
250+ | Just ThreadKilled <- E.fromException e -> return False
251+ -- killed by the local timeout manager
252+ | Just T.TimeoutThread <- E.fromException e -> do
253+ cleanup sinfo Nothing
254+ return True
255+ | otherwise -> do
256+ cleanup sinfo $ Just e
257+ return True
258+ cont2 <- getThreadContinue tcont
259+ clearStreamInfo sinfo
260+ when (cont1 && cont2) $ go sinfo tcont th
261+ cleanup sinfo me = do
262+ minp <- getStreamInfo sinfo
263+ case minp of
264+ Nothing -> return ()
265+ Just (Input strm req _reqvt _ii) -> do
266+ closed ctx strm Killed
267+ let !frame = resetFrame InternalError (streamNumber strm)
268+ enqueueControl controlQ $ CFrame frame
269+ case me of
270+ Nothing -> return ()
271+ Just e -> S.settingsOnException set (Just req) e
272+
273+----------------------------------------------------------------
274+
275+-- | It would nice if responders could return values to workers.
276+-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.
277+-- It is not wise to change this type.
278+-- So, a reference is shared by a responder and its worker.
279+-- The reference refers a value of this type as a return value.
280+-- If 'True', the worker continue to serve requests.
281+-- Otherwise, the worker get finished.
282+newtype ThreadContinue = ThreadContinue (IORef Bool)
283+
284+{-# INLINE newThreadContinue #-}
285+newThreadContinue :: IO ThreadContinue
286+newThreadContinue = ThreadContinue <$> newIORef True
287+
288+{-# INLINE setThreadContinue #-}
289+setThreadContinue :: ThreadContinue -> Bool -> IO ()
290+setThreadContinue (ThreadContinue ref) x = writeIORef ref x
291+
292+{-# INLINE getThreadContinue #-}
293+getThreadContinue :: ThreadContinue -> IO Bool
294+getThreadContinue (ThreadContinue ref) = readIORef ref
295+
296+----------------------------------------------------------------
297+
298+-- | The type to store enough information for 'settingsOnException'.
299+newtype StreamInfo = StreamInfo (IORef (Maybe Input))
300+
301+{-# INLINE newStreamInfo #-}
302+newStreamInfo :: IO StreamInfo
303+newStreamInfo = StreamInfo <$> newIORef Nothing
304+
305+{-# INLINE clearStreamInfo #-}
306+clearStreamInfo :: StreamInfo -> IO ()
307+clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing
308+
309+{-# INLINE setStreamInfo #-}
310+setStreamInfo :: StreamInfo -> Input -> IO ()
311+setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp
312+
313+{-# INLINE getStreamInfo #-}
314+getStreamInfo :: StreamInfo -> IO (Maybe Input)
315+getStreamInfo (StreamInfo ref) = readIORef ref
warp/Network/Wai/Handler/Warp/HashMap.hs+15−24
@@ -1,5 +1,3 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3module Network.Wai.Handler.Warp.HashMap where
1module Network.Wai.Handler.Warp.HashMap where
4
2
5import Data.Hashable (hash)
3import Data.Hashable (hash)
@@ -9,34 +7,27 @@ import Data.Map.Strict (Map)
9import qualified Data.Map.Strict as M
7import qualified Data.Map.Strict as M
10import Prelude hiding (lookup)
8import Prelude hiding (lookup)
11
9
12−----------------------------------------------------------------
10+import Network.Wai.Handler.Warp.Imports hiding (insert, lookup)
13
11
14−-- | 'HashMap' is used for cache of file information.
12+type Hash = Int
15−-- Hash values of file pathes are used as outer keys.
16−-- Because negative entries are also contained,
17−-- a bad guy can intentionally cause the hash collison.
18−-- So, 'Map' is used internally to prevent
19−-- the hash collision attack.
20−newtype HashMap v = HashMap (IntMap (Map FilePath v))
13+newtype HashMap k v = HashMap (IntMap (Map k v))
21
14
22−----------------------------------------------------------------
15+hashByteString :: ByteString -> Hash
16+hashByteString = hash
23
17
24−empty :: HashMap v
18+empty :: HashMap k v
25empty = HashMap I.empty
19empty = HashMap I.empty
26
20
27−isEmpty :: HashMap v -> Bool
21+null :: HashMap k v -> Bool
28−isEmpty (HashMap hm) = I.null hm
22+null (HashMap hm) = I.null hm
29−
30−----------------------------------------------------------------
31
23
32−insert :: FilePath -> v -> HashMap v -> HashMap v
24+insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v
33−insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm
25+insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm
34 where
26 where
35− !h = hash path
36− !m = M.singleton path v
27+ m = M.singleton k v
37 f = M.union -- fimxe
28 f = M.union -- fimxe
29+{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}
38
30
39−lookup :: FilePath -> HashMap v -> Maybe v
31+lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v
40−lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path
32+lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k
41− where
33+{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}
42− !h = hash path
warp/Network/Wai/Handler/Warp/Header.hs−2
@@ -69,7 +69,6 @@ indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex
69data ResponseHeaderIndex = ResContentLength
69data ResponseHeaderIndex = ResContentLength
70 | ResServer
70 | ResServer
71 | ResDate
71 | ResDate
72− | ResLastModified
73 deriving (Enum,Bounded)
72 deriving (Enum,Bounded)
74
73
75-- | The size for 'IndexedHeader' for HTTP Response.
74-- | The size for 'IndexedHeader' for HTTP Response.
@@ -80,7 +79,6 @@ responseKeyIndex :: HeaderName -> Int
80responseKeyIndex hn = case BS.length bs of
79responseKeyIndex hn = case BS.length bs of
81 4 -> if bs == "date" then fromEnum ResDate else -1
80 4 -> if bs == "date" then fromEnum ResDate else -1
82 6 -> if bs == "server" then fromEnum ResServer else -1
81 6 -> if bs == "server" then fromEnum ResServer else -1
83− 13 -> if bs == "last-modified" then fromEnum ResLastModified else -1
84 14 -> if bs == "content-length" then fromEnum ResContentLength else -1
82 14 -> if bs == "content-length" then fromEnum ResContentLength else -1
85 _ -> -1
83 _ -> -1
86 where
84 where
warp/Network/Wai/Handler/Warp/Internal.hs+2−7
@@ -53,7 +53,7 @@ module Network.Wai.Handler.Warp.Internal (
53 -- resumed as soon as we return from user code.
53 -- resumed as soon as we return from user code.
54 --
54 --
55 -- * Every time data is successfully sent to the client, the timeout is tickled.
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
57 -- * File descriptor cache
58 , module Network.Wai.Handler.Warp.FdCache
58 , module Network.Wai.Handler.Warp.FdCache
59 -- * File information cache
59 -- * File information cache
@@ -64,13 +64,8 @@ module Network.Wai.Handler.Warp.Internal (
64 , Source
64 , Source
65 , recvRequest
65 , recvRequest
66 , sendResponse
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 #-}
2
2
3module Network.Wai.Handler.Warp.MultiMap (
3module Network.Wai.Handler.Warp.MultiMap (
4− MultiMap
4+ MMap
5 , isEmpty
5 , isEmpty
6 , empty
6 , empty
7 , singleton
7 , singleton
8 , insert
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)
16import Data.IntMap.Strict (IntMap)
17import qualified Data.IntMap.Strict as I
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/Recv.hs+10−40
@@ -17,14 +17,7 @@ import Foreign.C.Types
17import Foreign.ForeignPtr (withForeignPtr)
17import Foreign.ForeignPtr (withForeignPtr)
18import Foreign.Ptr (Ptr, castPtr, plusPtr)
18import Foreign.Ptr (Ptr, castPtr, plusPtr)
19import GHC.Conc (threadWaitRead)
19import GHC.Conc (threadWaitRead)
20−import qualified GHC.IO.Exception as E
21−import Network.Socket (Socket)
20+import Network.Socket (Socket, fdSocket)
22−import qualified System.IO.Error as E
23−#if MIN_VERSION_network(3,1,0)
24−import Network.Socket (withFdSocket)
25−#else
26−import Network.Socket (fdSocket)
27−#endif
28import System.Posix.Types (Fd(..))
21import System.Posix.Types (Fd(..))
29
22
30import Network.Wai.Handler.Warp.Buffer
23import Network.Wai.Handler.Warp.Buffer
@@ -96,45 +89,24 @@ spell init0 siz0 recv recvBuf
96 siz' = siz - len
89 siz' = siz - len
97 loop bss' siz'
90 loop bss' siz'
98
91
99−-- The timeout manager may close the socket.
100−-- In that case, an error of "Bad file descriptor" occurs.
101−-- We ignores it because we expect TimeoutThread.
102receive :: Socket -> BufferPool -> Recv
92receive :: Socket -> BufferPool -> Recv
103−receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do
93+receive sock pool = withBufferPool pool $ \ (ptr, size) -> do
104−#if MIN_VERSION_network(3,1,0)
105− withFdSocket sock $ \fd -> do
106−#elif MIN_VERSION_network(3,0,0)
107− fd <- fdSocket sock
108−#else
109− let fd = fdSocket sock
94+ let sock' = fdSocket sock
110−#endif
111− let size' = fromIntegral size
95+ size' = fromIntegral size
112− fromIntegral <$> receiveloop fd ptr size'
96+ fromIntegral <$> receiveloop sock' ptr size'
113− where
114− handler :: E.IOException -> IO ByteString
115− handler e
116− | E.ioeGetErrorType e == E.InvalidArgument = return ""
117− | otherwise = E.throwIO e
118
97
119receiveBuf :: Socket -> RecvBuf
98receiveBuf :: Socket -> RecvBuf
120−receiveBuf sock buf0 siz0 = do
99+receiveBuf sock buf0 siz0 = loop buf0 siz0
121−#if MIN_VERSION_network(3,1,0)
122− withFdSocket sock $ \fd -> do
123−#elif MIN_VERSION_network(3,0,0)
124− fd <- fdSocket sock
125−#else
126− let fd = fdSocket sock
127−#endif
128− loop fd buf0 siz0
129 where
100 where
130− loop _ _ 0 = return True
101+ loop _ 0 = return True
131− loop fd buf siz = do
102+ loop buf siz = do
132 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)
103 n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)
133 -- fixme: what should we do in the case of n == 0
104 -- fixme: what should we do in the case of n == 0
134 if n == 0 then
105 if n == 0 then
135 return False
106 return False
136 else
107 else
137− loop fd (buf `plusPtr` n) (siz - n)
108+ loop (buf `plusPtr` n) (siz - n)
109+ fd = fdSocket sock
138
110
139receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt
111receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt
140receiveloop sock ptr size = do
112receiveloop sock ptr size = do
@@ -153,8 +125,6 @@ receiveloop sock ptr size = do
153 else
125 else
154 return bytes
126 return bytes
155
127
156−#ifndef mingw32_HOST_OS
157-- fixme: the type of the return value
128-- fixme: the type of the return value
158foreign import ccall unsafe "recv"
129foreign import ccall unsafe "recv"
159 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
130 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
160−#endif
warp/Network/Wai/Handler/Warp/Request.hs+28−26
@@ -9,7 +9,6 @@ module Network.Wai.Handler.Warp.Request (
9 , headerLines
9 , headerLines
10 , pauseTimeoutKey
10 , pauseTimeoutKey
11 , getFileInfoKey
11 , getFileInfoKey
12− , getClientCertificateKey
13 , NoKeepAliveRequest (..)
12 , NoKeepAliveRequest (..)
14 ) where
13 ) where
15
14
@@ -22,23 +21,29 @@ import qualified Data.CaseInsensitive as CI
22import qualified Data.IORef as I
21import qualified Data.IORef as I
23import Data.Typeable (Typeable)
22import Data.Typeable (Typeable)
24import qualified Data.Vault.Lazy as Vault
23import qualified Data.Vault.Lazy as Vault
25−import Data.X509
26import qualified Network.HTTP.Types as H
24import qualified Network.HTTP.Types as H
27import Network.Socket (SockAddr)
25import Network.Socket (SockAddr)
28import Network.Wai
26import Network.Wai
27+import qualified Network.Wai.Handler.Warp.Timeout as Timeout
29import Network.Wai.Handler.Warp.Types
28import Network.Wai.Handler.Warp.Types
30import Network.Wai.Internal
29import Network.Wai.Internal
31import Prelude hiding (lines)
30import Prelude hiding (lines)
32import System.IO.Unsafe (unsafePerformIO)
31import System.IO.Unsafe (unsafePerformIO)
33−import qualified System.TimeManager as Timeout
34
32
35import Network.Wai.Handler.Warp.Conduit
33import Network.Wai.Handler.Warp.Conduit
36import Network.Wai.Handler.Warp.FileInfoCache
34import Network.Wai.Handler.Warp.FileInfoCache
35+import Network.Wai.Handler.Warp.HashMap (hashByteString)
37import Network.Wai.Handler.Warp.Header
36import Network.Wai.Handler.Warp.Header
38import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)
37import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)
39import Network.Wai.Handler.Warp.ReadInt
38import Network.Wai.Handler.Warp.ReadInt
40import Network.Wai.Handler.Warp.RequestHeader
39import Network.Wai.Handler.Warp.RequestHeader
41−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)
40+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)
41+
42+----------------------------------------------------------------
43+
44+-- FIXME come up with good values here
45+maxTotalHeaderLength :: Int
46+maxTotalHeaderLength = 50 * 1024
42
47
43----------------------------------------------------------------
48----------------------------------------------------------------
44
49
@@ -47,22 +52,21 @@ import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, setting
47recvRequest :: Bool -- ^ first request on this connection?
52recvRequest :: Bool -- ^ first request on this connection?
48 -> Settings
53 -> Settings
49 -> Connection
54 -> Connection
50− -> InternalInfo
55+ -> InternalInfo1
51− -> Timeout.Handle
52 -> SockAddr -- ^ Peer's address.
56 -> SockAddr -- ^ Peer's address.
53 -> Source -- ^ Where HTTP request comes from.
57 -> Source -- ^ Where HTTP request comes from.
54− -> Transport
55 -> IO (Request
58 -> IO (Request
56 ,Maybe (I.IORef Int)
59 ,Maybe (I.IORef Int)
57 ,IndexedHeader
60 ,IndexedHeader
58− ,IO ByteString) -- ^
61+ ,IO ByteString
62+ ,InternalInfo) -- ^
59 -- 'Request' passed to 'Application',
63 -- 'Request' passed to 'Application',
60 -- how many bytes remain to be consumed, if known
64 -- how many bytes remain to be consumed, if known
61 -- 'IndexedHeader' of HTTP request for internal use,
65 -- 'IndexedHeader' of HTTP request for internal use,
62 -- Body producing action used for flushing the request body
66 -- Body producing action used for flushing the request body
63
67
64−recvRequest firstRequest settings conn ii th addr src transport = do
68+recvRequest firstRequest settings conn ii1 addr src = do
65− hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src
69+ hdrlines <- headerLines firstRequest src
66 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
70 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
67 let idxhdr = indexRequestHeader hdr
71 let idxhdr = indexRequestHeader hdr
68 expect = idxhdr ! fromEnum ReqExpect
72 expect = idxhdr ! fromEnum ReqExpect
@@ -70,9 +74,11 @@ recvRequest firstRequest settings conn ii th addr src transport = do
70 te = idxhdr ! fromEnum ReqTransferEncoding
74 te = idxhdr ! fromEnum ReqTransferEncoding
71 handle100Continue = handleExpect conn httpversion expect
75 handle100Continue = handleExpect conn httpversion expect
72 rawPath = if settingsNoParsePath settings then unparsedPath else path
76 rawPath = if settingsNoParsePath settings then unparsedPath else path
77+ h = hashByteString rawPath
78+ ii = toInternalInfo ii1 h
79+ th = threadHandle ii
73 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
80 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
74 $ Vault.insert getFileInfoKey (getFileInfo ii)
81 $ Vault.insert getFileInfoKey (getFileInfo ii)
75− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)
76 Vault.empty
82 Vault.empty
77 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te
83 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te
78 -- body producing function which will produce '100-continue', if needed
84 -- body producing function which will produce '100-continue', if needed
@@ -87,7 +93,7 @@ recvRequest firstRequest settings conn ii th addr src transport = do
87 , rawQueryString = query
93 , rawQueryString = query
88 , queryString = H.parseQuery query
94 , queryString = H.parseQuery query
89 , requestHeaders = hdr
95 , requestHeaders = hdr
90− , isSecure = isTransportSecure transport
96+ , isSecure = False
91 , remoteHost = addr
97 , remoteHost = addr
92 , requestBody = rbody'
98 , requestBody = rbody'
93 , vault = vaultValue
99 , vault = vaultValue
@@ -97,12 +103,12 @@ recvRequest firstRequest settings conn ii th addr src transport = do
97 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer
103 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer
98 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent
104 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent
99 }
105 }
100− return (req, remainingRef, idxhdr, rbodyFlush)
106+ return (req, remainingRef, idxhdr, rbodyFlush, ii)
101
107
102----------------------------------------------------------------
108----------------------------------------------------------------
103
109
104−headerLines :: Int -> Bool -> Source -> IO [ByteString]
110+headerLines :: Bool -> Source -> IO [ByteString]
105−headerLines maxTotalHeaderLength firstRequest src = do
111+headerLines firstRequest src = do
106 bs <- readSource src
112 bs <- readSource src
107 if S.null bs
113 if S.null bs
108 -- When we're working on a keep-alive connection and trying to
114 -- When we're working on a keep-alive connection and trying to
@@ -110,7 +116,7 @@ headerLines maxTotalHeaderLength firstRequest src = do
110 -- lack of data as a real exception. See the http1 function in
116 -- lack of data as a real exception. See the http1 function in
111 -- the Run module for more details.
117 -- the Run module for more details.
112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest
118 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest
113− else push maxTotalHeaderLength src (THStatus 0 id id) bs
119+ else push src (THStatus 0 id id) bs
114
120
115data NoKeepAliveRequest = NoKeepAliveRequest
121data NoKeepAliveRequest = NoKeepAliveRequest
116 deriving (Show, Typeable)
122 deriving (Show, Typeable)
@@ -220,8 +226,8 @@ close :: Sink ByteString IO a
220close = throwIO IncompleteHeaders
226close = throwIO IncompleteHeaders
221-}
227-}
222
228
223−push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
229+push :: Source -> THStatus -> ByteString -> IO [ByteString]
224−push maxTotalHeaderLength src (THStatus len lines prepend) bs'
230+push src (THStatus len lines prepend) bs'
225 -- Too many bytes
231 -- Too many bytes
226 | len > maxTotalHeaderLength = throwIO OverLargeHeader
232 | len > maxTotalHeaderLength = throwIO OverLargeHeader
227 | otherwise = push' mnl
233 | otherwise = push' mnl
@@ -249,13 +255,13 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'
249 push' Nothing = do
255 push' Nothing = do
250 bst <- readSource' src
256 bst <- readSource' src
251 when (S.null bst) $ throwIO IncompleteHeaders
257 when (S.null bst) $ throwIO IncompleteHeaders
252− push maxTotalHeaderLength src status bst
258+ push src status bst
253 where
259 where
254 len' = len + bsLen
260 len' = len + bsLen
255 prepend' = S.append bs
261 prepend' = S.append bs
256 status = THStatus len' lines prepend'
262 status = THStatus len' lines prepend'
257 -- Found a newline, but next line continues as a multiline header
263 -- Found a newline, but next line continues as a multiline header
258− push' (Just (end, True)) = push maxTotalHeaderLength src status rest
264+ push' (Just (end, True)) = push src status rest
259 where
265 where
260 rest = S.drop (end + 1) bs
266 rest = S.drop (end + 1) bs
261 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)
267 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)
@@ -274,12 +280,12 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'
274 in if start < bsLen then
280 in if start < bsLen then
275 -- more bytes in this chunk, push again
281 -- more bytes in this chunk, push again
276 let bs'' = SU.unsafeDrop start bs
282 let bs'' = SU.unsafeDrop start bs
277− in push maxTotalHeaderLength src status bs''
283+ in push src status bs''
278 else do
284 else do
279 -- no more bytes in this chunk, ask for more
285 -- no more bytes in this chunk, ask for more
280 bst <- readSource' src
286 bst <- readSource' src
281 when (S.null bs) $ throwIO IncompleteHeaders
287 when (S.null bs) $ throwIO IncompleteHeaders
282− push maxTotalHeaderLength src status bst
288+ push src status bst
283 where
289 where
284 start = end + 1 -- start of next chunk
290 start = end + 1 -- start of next chunk
285 line = SU.unsafeTake (checkCR bs end) bs
291 line = SU.unsafeTake (checkCR bs end) bs
@@ -297,7 +303,3 @@ pauseTimeoutKey = unsafePerformIO Vault.newKey
297getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)
303getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)
298getFileInfoKey = unsafePerformIO Vault.newKey
304getFileInfoKey = unsafePerformIO Vault.newKey
299{-# NOINLINE getFileInfoKey #-}
305{-# NOINLINE getFileInfoKey #-}
300−
301−getClientCertificateKey :: Vault.Key (Maybe CertificateChain)
302−getClientCertificateKey = unsafePerformIO Vault.newKey
303−{-# NOINLINE getClientCertificateKey #-}
warp/Network/Wai/Handler/Warp/Response.hs+22−25
@@ -13,7 +13,7 @@ module Network.Wai.Handler.Warp.Response (
13 , addServer -- testing
13 , addServer -- testing
14 ) where
14 ) where
15
15
16−import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)
16+import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
17import qualified Control.Exception as E
17import qualified Control.Exception as E
18import Data.Array ((!))
18import Data.Array ((!))
19import qualified Data.ByteString as S
19import qualified Data.ByteString as S
@@ -22,7 +22,7 @@ import Data.ByteString.Builder.Extra (flush)
22import qualified Data.ByteString.Char8 as C8
22import qualified Data.ByteString.Char8 as C8
23import qualified Data.CaseInsensitive as CI
23import qualified Data.CaseInsensitive as CI
24import Data.Function (on)
24import Data.Function (on)
25−import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)
25+import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)
26import Data.Version (showVersion)
26import Data.Version (showVersion)
27import Data.Word8 (_cr, _lf)
27import Data.Word8 (_cr, _lf)
28import qualified Network.HTTP.Types as H
28import qualified Network.HTTP.Types as H
@@ -30,7 +30,6 @@ import qualified Network.HTTP.Types.Header as H
30import Network.Wai
30import Network.Wai
31import Network.Wai.Internal
31import Network.Wai.Internal
32import qualified Paths_warp
32import qualified Paths_warp
33−import qualified System.TimeManager as T
34
33
35import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
34import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
36import qualified Network.Wai.Handler.Warp.Date as D
35import qualified Network.Wai.Handler.Warp.Date as D
@@ -40,6 +39,7 @@ import Network.Wai.Handler.Warp.IO (toBufIOWith)
40import Network.Wai.Handler.Warp.Imports
39import Network.Wai.Handler.Warp.Imports
41import Network.Wai.Handler.Warp.ResponseHeader
40import Network.Wai.Handler.Warp.ResponseHeader
42import Network.Wai.Handler.Warp.Settings
41import Network.Wai.Handler.Warp.Settings
42+import qualified Network.Wai.Handler.Warp.Timeout as T
43import Network.Wai.Handler.Warp.Types
43import Network.Wai.Handler.Warp.Types
44
44
45-- $setup
45-- $setup
@@ -101,13 +101,12 @@ import Network.Wai.Handler.Warp.Types
101sendResponse :: Settings
101sendResponse :: Settings
102 -> Connection
102 -> Connection
103 -> InternalInfo
103 -> InternalInfo
104− -> T.Handle
105 -> Request -- ^ HTTP request.
104 -> Request -- ^ HTTP request.
106 -> IndexedHeader -- ^ Indexed header of HTTP request.
105 -> IndexedHeader -- ^ Indexed header of HTTP request.
107 -> IO ByteString -- ^ source from client, for raw response
106 -> IO ByteString -- ^ source from client, for raw response
108 -> Response -- ^ HTTP response including status code and response header.
107 -> Response -- ^ HTTP response including status code and response header.
109 -> IO Bool -- ^ Returing True if the connection is persistent.
108 -> IO Bool -- ^ Returing True if the connection is persistent.
110−sendResponse settings conn ii th req reqidxhdr src response = do
109+sendResponse settings conn ii req reqidxhdr src response = do
111 hs <- addServerAndDate hs0
110 hs <- addServerAndDate hs0
112 if hasBody s then do
111 if hasBody s then do
113 -- The response to HEAD does not have body.
112 -- The response to HEAD does not have body.
@@ -116,14 +115,14 @@ sendResponse settings conn ii th req reqidxhdr src response = do
116 -- and status, the response to HEAD is processed here.
115 -- and status, the response to HEAD is processed here.
117 --
116 --
118 -- See definition of rsp below for proper body stripping.
117 -- See definition of rsp below for proper body stripping.
119− (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp
118+ (ms, mlen) <- sendRsp conn ii ver s hs rsp
120 case ms of
119 case ms of
121 Nothing -> return ()
120 Nothing -> return ()
122 Just realStatus -> logger req realStatus mlen
121 Just realStatus -> logger req realStatus mlen
123 T.tickle th
122 T.tickle th
124 return ret
123 return ret
125 else do
124 else do
126− _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody
125+ _ <- sendRsp conn ii ver s hs RspNoBody
127 logger req s Nothing
126 logger req s Nothing
128 T.tickle th
127 T.tickle th
129 return isPersist
128 return isPersist
@@ -134,6 +133,7 @@ sendResponse settings conn ii th req reqidxhdr src response = do
134 s = responseStatus response
133 s = responseStatus response
135 hs0 = sanitizeHeaders $ responseHeaders response
134 hs0 = sanitizeHeaders $ responseHeaders response
136 rspidxhdr = indexResponseHeader hs0
135 rspidxhdr = indexResponseHeader hs0
136+ th = threadHandle ii
137 getdate = getDate ii
137 getdate = getDate ii
138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr
138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr
139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr
139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr
@@ -196,13 +196,12 @@ sendRsp :: Connection
196 -> H.HttpVersion
196 -> H.HttpVersion
197 -> H.Status
197 -> H.Status
198 -> H.ResponseHeaders
198 -> H.ResponseHeaders
199− -> IndexedHeader -- Response
200 -> Rsp
199 -> Rsp
201 -> IO (Maybe H.Status, Maybe Integer)
200 -> IO (Maybe H.Status, Maybe Integer)
202
201
203----------------------------------------------------------------
202----------------------------------------------------------------
204
203
205−sendRsp conn _ ver s hs _ RspNoBody = do
204+sendRsp conn _ ver s hs RspNoBody = do
206 -- Not adding Content-Length.
205 -- Not adding Content-Length.
207 -- User agents treats it as Content-Length: 0.
206 -- User agents treats it as Content-Length: 0.
208 composeHeader ver s hs >>= connSendAll conn
207 composeHeader ver s hs >>= connSendAll conn
@@ -210,7 +209,7 @@ sendRsp conn _ ver s hs _ RspNoBody = do
210
209
211----------------------------------------------------------------
210----------------------------------------------------------------
212
211
213−sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do
212+sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do
214 header <- composeHeaderBuilder ver s hs needsChunked
213 header <- composeHeaderBuilder ver s hs needsChunked
215 let hdrBdy
214 let hdrBdy
216 | needsChunked = header <> chunkedTransferEncoding body
215 | needsChunked = header <> chunkedTransferEncoding body
@@ -223,9 +222,9 @@ sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do
223
222
224----------------------------------------------------------------
223----------------------------------------------------------------
225
224
226−sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do
225+sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do
227 header <- composeHeaderBuilder ver s hs needsChunked
226 header <- composeHeaderBuilder ver s hs needsChunked
228− (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy
227+ (recv, finish) <- newBlazeRecv $ reuseBufferStrategy
229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)
228 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)
230 let send builder = do
229 let send builder = do
231 popper <- recv builder
230 popper <- recv builder
@@ -247,7 +246,7 @@ sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do
247
246
248----------------------------------------------------------------
247----------------------------------------------------------------
249
248
250−sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do
249+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do
251 withApp recv send
250 withApp recv send
252 return (Nothing, Nothing)
251 return (Nothing, Nothing)
253 where
252 where
@@ -261,8 +260,8 @@ sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do
261
260
262-- Sophisticated WAI applications.
261-- Sophisticated WAI applications.
263-- We respect s0. s0 MUST be a proper value.
262-- We respect s0. s0 MUST be a proper value.
264−sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =
263+sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =
265− sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook
264+ sendRspFile2XX conn ii ver s0 hs path beg len isHead hook
266 where
265 where
267 beg = filePartOffset part
266 beg = filePartOffset part
268 len = filePartByteCount part
267 len = filePartByteCount part
@@ -272,17 +271,17 @@ sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =
272
271
273-- Simple WAI applications.
272-- Simple WAI applications.
274-- Status is ignored
273-- Status is ignored
275−sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do
274+sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do
276 efinfo <- E.try $ getFileInfo ii path
275 efinfo <- E.try $ getFileInfo ii path
277 case efinfo of
276 case efinfo of
278 Left (_ex :: E.IOException) ->
277 Left (_ex :: E.IOException) ->
279#ifdef WARP_DEBUG
278#ifdef WARP_DEBUG
280 print _ex >>
279 print _ex >>
281#endif
280#endif
282− sendRspFile404 conn ii ver hs0 rspidxhdr
281+ sendRspFile404 conn ii ver hs0
283− Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of
282+ Right finfo -> case conditionalRequest finfo hs0 idxhdr of
284− WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody
283+ WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody
285− WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook
284+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook
286
285
287----------------------------------------------------------------
286----------------------------------------------------------------
288
287
@@ -291,15 +290,14 @@ sendRspFile2XX :: Connection
291 -> H.HttpVersion
290 -> H.HttpVersion
292 -> H.Status
291 -> H.Status
293 -> H.ResponseHeaders
292 -> H.ResponseHeaders
294− -> IndexedHeader
295 -> FilePath
293 -> FilePath
296 -> Integer
294 -> Integer
297 -> Integer
295 -> Integer
298 -> Bool
296 -> Bool
299 -> IO ()
297 -> IO ()
300 -> IO (Maybe H.Status, Maybe Integer)
298 -> IO (Maybe H.Status, Maybe Integer)
301−sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook
299+sendRspFile2XX conn ii ver s hs path beg len isHead hook
302− | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody
300+ | isHead = sendRsp conn ii ver s hs RspNoBody
303 | otherwise = do
301 | otherwise = do
304 lheader <- composeHeader ver s hs
302 lheader <- composeHeader ver s hs
305 (mfd, fresher) <- getFd ii path
303 (mfd, fresher) <- getFd ii path
@@ -312,9 +310,8 @@ sendRspFile404 :: Connection
312 -> InternalInfo
310 -> InternalInfo
313 -> H.HttpVersion
311 -> H.HttpVersion
314 -> H.ResponseHeaders
312 -> H.ResponseHeaders
315− -> IndexedHeader
316 -> IO (Maybe H.Status, Maybe Integer)
313 -> IO (Maybe H.Status, Maybe Integer)
317−sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)
314+sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)
318 where
315 where
319 s = H.notFound404
316 s = H.notFound404
320 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
317 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
warp/Network/Wai/Handler/Warp/Run.hs+68−131
@@ -3,10 +3,8 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PackageImports #-}
4{-# LANGUAGE PackageImports #-}
5{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE PatternGuards #-}
6−{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE ViewPatterns #-}
10{-# OPTIONS_GHC -fno-warn-deprecations #-}
8{-# OPTIONS_GHC -fno-warn-deprecations #-}
11
9
12module Network.Wai.Handler.Warp.Run where
10module Network.Wai.Handler.Warp.Run where
@@ -17,20 +15,16 @@ import qualified Control.Concurrent as Conc (yield)
17import Control.Exception as E
15import Control.Exception as E
18import qualified Data.ByteString as S
16import qualified Data.ByteString as S
19import Data.Char (chr)
17import Data.Char (chr)
20−import Data.IORef (IORef, newIORef, readIORef, writeIORef)
18+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')
21import Data.Streaming.Network (bindPortTCP)
19import Data.Streaming.Network (bindPortTCP)
22import Foreign.C.Error (Errno(..), eCONNABORTED)
20import Foreign.C.Error (Errno(..), eCONNABORTED)
23import GHC.IO.Exception (IOException(..))
21import GHC.IO.Exception (IOException(..))
24−import qualified Network.HTTP2 as H2
22+import Network (Socket)
25−import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
23+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
24import qualified Network.Socket.ByteString as Sock
30import Network.Wai
25import Network.Wai
31import Network.Wai.Internal (ResponseReceived (ResponseReceived))
26import Network.Wai.Internal (ResponseReceived (ResponseReceived))
32−import System.Environment (lookupEnv)
27+import System.Environment (getEnvironment)
33−import qualified System.TimeManager as T
34import System.Timeout (timeout)
28import System.Timeout (timeout)
35
29
36import Network.Wai.Handler.Warp.Buffer
30import Network.Wai.Handler.Warp.Buffer
@@ -38,8 +32,7 @@ import Network.Wai.Handler.Warp.Counter
38import qualified Network.Wai.Handler.Warp.Date as D
32import qualified Network.Wai.Handler.Warp.Date as D
39import qualified Network.Wai.Handler.Warp.FdCache as F
33import qualified Network.Wai.Handler.Warp.FdCache as F
40import qualified Network.Wai.Handler.Warp.FileInfoCache as I
34import qualified Network.Wai.Handler.Warp.FileInfoCache as I
41−import Network.Wai.Handler.Warp.HTTP2 (http2)
35+import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)
42−import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
43import Network.Wai.Handler.Warp.Header
36import Network.Wai.Handler.Warp.Header
44import Network.Wai.Handler.Warp.Imports hiding (readInt)
37import Network.Wai.Handler.Warp.Imports hiding (readInt)
45import Network.Wai.Handler.Warp.ReadInt
38import Network.Wai.Handler.Warp.ReadInt
@@ -48,6 +41,7 @@ import Network.Wai.Handler.Warp.Request
48import Network.Wai.Handler.Warp.Response
41import Network.Wai.Handler.Warp.Response
49import Network.Wai.Handler.Warp.SendFile
42import Network.Wai.Handler.Warp.SendFile
50import Network.Wai.Handler.Warp.Settings
43import Network.Wai.Handler.Warp.Settings
44+import qualified Network.Wai.Handler.Warp.Timeout as T
51import Network.Wai.Handler.Warp.Types
45import Network.Wai.Handler.Warp.Types
52
46
53
47
@@ -58,38 +52,21 @@ import Network.Socket (fdSocket)
58#endif
52#endif
59
53
60-- | Creating 'Connection' for plain HTTP based on a given socket.
54-- | Creating 'Connection' for plain HTTP based on a given socket.
61−socketConnection :: Settings -> Socket -> IO Connection
55+socketConnection :: Socket -> IO Connection
62−#if MIN_VERSION_network(3,1,1)
63−socketConnection set s = do
64−#else
65−socketConnection _ s = do
56+socketConnection s = do
66−#endif
67 bufferPool <- newBufferPool
57 bufferPool <- newBufferPool
68 writeBuf <- allocateBuffer bufferSize
58 writeBuf <- allocateBuffer bufferSize
69 let sendall = Sock.sendAll s
59 let sendall = Sock.sendAll s
70− isH2 <- newIORef False -- HTTP/1.x
71 return Connection {
60 return Connection {
72 connSendMany = Sock.sendMany s
61 connSendMany = Sock.sendMany s
73 , connSendAll = sendall
62 , connSendAll = sendall
74 , connSendFile = sendFile s writeBuf bufferSize sendall
63 , 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
64 , connClose = close s
86−#endif
87 , connFree = freeBuffer writeBuf
65 , connFree = freeBuffer writeBuf
88 , connRecv = receive s bufferPool
66 , connRecv = receive s bufferPool
89 , connRecvBuf = receiveBuf s
67 , connRecvBuf = receiveBuf s
90 , connWriteBuffer = writeBuf
68 , connWriteBuffer = writeBuf
91 , connBufferSize = bufferSize
69 , connBufferSize = bufferSize
92− , connHTTP2 = isH2
93 }
70 }
94
71
95-- | Run an 'Application' on the given port.
72-- | Run an 'Application' on the given port.
@@ -104,7 +81,7 @@ run p = runSettings defaultSettings { settingsPort = p }
104-- Since 3.0.9
81-- Since 3.0.9
105runEnv :: Port -> Application -> IO ()
82runEnv :: Port -> Application -> IO ()
106runEnv p app = do
83runEnv p app = do
107− mp <- lookupEnv "PORT"
84+ mp <- lookup "PORT" <$> getEnvironment
108
85
109 maybe (run p app) runReadPort mp
86 maybe (run p app) runReadPort mp
110
87
@@ -151,7 +128,7 @@ runSettingsSocket set socket app = do
151 setSocketCloseOnExec s
128 setSocketCloseOnExec s
152 -- NoDelay causes an error for AF_UNIX.
129 -- NoDelay causes an error for AF_UNIX.
153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
130 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
154− conn <- socketConnection set s
131+ conn <- socketConnection s
155 return (conn, sa)
132 return (conn, sa)
156
133
157 closeListenSocket = close socket
134 closeListenSocket = close socket
@@ -192,15 +169,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),
192runSettingsConnectionMakerSecure set getConnMaker app = do
169runSettingsConnectionMakerSecure set getConnMaker app = do
193 settingsBeforeMainLoop set
170 settingsBeforeMainLoop set
194 counter <- newCounter
171 counter <- newCounter
195− withII $ acceptConnection set getConnMaker app counter
172+ withII0 $ acceptConnection set getConnMaker app counter
196 where
173 where
197− withII action =
174+ withII0 action =
198 withTimeoutManager $ \tm ->
175 withTimeoutManager $ \tm ->
199 D.withDateCache $ \dc ->
176 D.withDateCache $ \dc ->
200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->
177 F.withFdCache fdCacheDurationInSeconds $ \fdc ->
201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
178 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
202− let ii = InternalInfo tm dc fdc fic
179+ let ii0 = InternalInfo0 tm dc fdc fic
203− action ii
180+ action ii0
204
181
205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
182 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
183 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
@@ -229,18 +206,13 @@ acceptConnection :: Settings
229 -> IO (IO (Connection, Transport), SockAddr)
206 -> IO (IO (Connection, Transport), SockAddr)
230 -> Application
207 -> Application
231 -> Counter
208 -> Counter
232− -> InternalInfo
209+ -> InternalInfo0
233 -> IO ()
210 -> IO ()
234−acceptConnection set getConnMaker app counter ii = do
211+acceptConnection set getConnMaker app counter ii0 = do
235 -- First mask all exceptions in acceptLoop. This is necessary to
212 -- First mask all exceptions in acceptLoop. This is necessary to
236 -- ensure that no async exception is throw between the call to
213 -- ensure that no async exception is throw between the call to
237 -- acceptNewConnection and the registering of connClose.
214 -- acceptNewConnection and the registering of connClose.
238− --
239− -- acceptLoop can be broken by closing the listing socket.
240 void $ mask_ acceptLoop
215 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
216 gracefulShutdown set counter
245 where
217 where
246 acceptLoop = do
218 acceptLoop = do
@@ -258,7 +230,7 @@ acceptConnection set getConnMaker app counter ii = do
258 case mx of
230 case mx of
259 Nothing -> return ()
231 Nothing -> return ()
260 Just (mkConn, addr) -> do
232 Just (mkConn, addr) -> do
261− fork set mkConn addr app counter ii
233+ fork set mkConn addr app counter ii0
262 acceptLoop
234 acceptLoop
263
235
264 acceptNewConnection = do
236 acceptNewConnection = do
@@ -281,12 +253,15 @@ fork :: Settings
281 -> SockAddr
253 -> SockAddr
282 -> Application
254 -> Application
283 -> Counter
255 -> Counter
284− -> InternalInfo
256+ -> InternalInfo0
285 -> IO ()
257 -> IO ()
286−fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
258+fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
287 -- Call the user-supplied on exception code if any
259 -- Call the user-supplied on exception code if any
288 -- exceptions are thrown.
260 -- exceptions are thrown.
289− handle (settingsOnException set Nothing) $
261+ handle (settingsOnException set Nothing) .
262+ -- Allocate a new IORef indicating whether the connection has been
263+ -- closed, to avoid double-freeing a connection
264+ withClosedRef $ \ref ->
290 -- Run the connection maker to get a new connection, and ensure
265 -- Run the connection maker to get a new connection, and ensure
291 -- that the connection is closed. If the mkConn call throws an
266 -- that the connection is closed. If the mkConn call throws an
292 -- exception, we will leak the connection. If the mkConn call is
267 -- exception, we will leak the connection. If the mkConn call is
@@ -297,15 +272,24 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
297 -- We grab the connection before registering timeouts since the
272 -- We grab the connection before registering timeouts since the
298 -- timeouts will be useless during connection creation, due to the
273 -- timeouts will be useless during connection creation, due to the
299 -- fact that async exceptions are still masked.
274 -- fact that async exceptions are still masked.
300− bracket mkConn cleanUp (serve unmask)
275+ bracket mkConn (cleanUp ref) (serve unmask ref)
301 where
276 where
277+ withClosedRef inner = newIORef False >>= inner
278+
279+ closeConn ref conn = do
280+ isClosed <- atomicModifyIORef' ref $ \x -> (True, x)
281+ unless isClosed $ connClose conn
282+
302− cleanUp (conn, _) = connClose conn `finally` connFree conn
283+ cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn
303
284
304 -- We need to register a timeout handler for this thread, and
285 -- We need to register a timeout handler for this thread, and
305− -- cancel that handler as soon as we exit.
286+ -- cancel that handler as soon as we exit. We additionally close
287+ -- the connection immediately in case the child thread catches the
288+ -- async exception or performs some long-running cleanup action.
306− serve unmask (conn, transport) = bracket register cancel $ \th -> do
289+ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do
290+ let ii1 = toInternalInfo1 ii0 th
307 -- We now have fully registered a connection close handler in
291 -- We now have fully registered a connection close handler in
308− -- the case of all exceptions, so it is safe to once again
292+ -- the case of all exceptions, so it is safe to one again
309 -- allow async exceptions.
293 -- allow async exceptions.
310 unmask .
294 unmask .
311 -- Call the user-supplied code for connection open and
295 -- Call the user-supplied code for connection open and
@@ -313,23 +297,23 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
313 bracket (onOpen addr) (onClose addr) $ \goingon ->
297 bracket (onOpen addr) (onClose addr) $ \goingon ->
314 -- Actually serve this connection. bracket with closeConn
298 -- Actually serve this connection. bracket with closeConn
315 -- above ensures the connection is closed.
299 -- above ensures the connection is closed.
316− when goingon $ serveConnection conn ii th addr transport set app
300+ when goingon $ serveConnection conn ii1 addr transport set app
317 where
301 where
318− register = T.registerKillThread (timeoutManager ii) (connClose conn)
302+ register = T.registerKillThread (timeoutManager0 ii0)
303+ (closeConn ref conn)
319 cancel = T.cancel
304 cancel = T.cancel
320
305
321 onOpen adr = increase counter >> settingsOnOpen set adr
306 onOpen adr = increase counter >> settingsOnOpen set adr
322 onClose adr _ = decrease counter >> settingsOnClose set adr
307 onClose adr _ = decrease counter >> settingsOnClose set adr
323
308
324serveConnection :: Connection
309serveConnection :: Connection
325− -> InternalInfo
310+ -> InternalInfo1
326− -> T.Handle
327 -> SockAddr
311 -> SockAddr
328 -> Transport
312 -> Transport
329 -> Settings
313 -> Settings
330 -> Application
314 -> Application
331 -> IO ()
315 -> IO ()
332−serveConnection conn ii th origAddr transport settings app = do
316+serveConnection conn ii1 origAddr transport settings app = do
333 -- fixme: Upgrading to HTTP/2 should be supported.
317 -- fixme: Upgrading to HTTP/2 should be supported.
334 (h2,bs) <- if isHTTP2 transport then
318 (h2,bs) <- if isHTTP2 transport then
335 return (True, "")
319 return (True, "")
@@ -342,36 +326,17 @@ serveConnection conn ii th origAddr transport settings app = do
342 istatus <- newIORef False
326 istatus <- newIORef False
343 if settingsHTTP2Enabled settings && h2 then do
327 if settingsHTTP2Enabled settings && h2 then do
344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
328 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
329 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
353− sendBS x = connSendAll conn x >> T.tickle th
354 -- fixme: origAddr
330 -- fixme: origAddr
355− checkTLS
356− setConnHTTP2 conn True
357− http2 conn transport ii origAddr settings recvN sendBS app
331+ http2 conn ii1 origAddr transport settings recvN app
358 else do
332 else do
359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
333 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
360 writeIORef istatus True
334 writeIORef istatus True
361 leftoverSource src bs
335 leftoverSource src bs
362 addr <- getProxyProtocolAddr src
336 addr <- getProxyProtocolAddr src
363− http1 True addr istatus src `E.catch` \e ->
337+ 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
338+ sendErrorResponse addr istatus e
373− throwIO e
339+ throwIO (e :: SomeException)
374−
375 where
340 where
376 getProxyProtocolAddr src =
341 getProxyProtocolAddr src =
377 case settingsProxyProtocol settings of
342 case settingsProxyProtocol settings of
@@ -413,25 +378,30 @@ serveConnection conn ii th origAddr transport settings app = do
413
378
414 decodeAscii = map (chr . fromEnum) . S.unpack
379 decodeAscii = map (chr . fromEnum) . S.unpack
415
380
381+ th = threadHandle1 ii1
382+
416 shouldSendErrorResponse se
383 shouldSendErrorResponse se
417 | Just ConnectionClosedByPeer <- fromException se = False
384 | Just ConnectionClosedByPeer <- fromException se = False
418 | otherwise = True
385 | otherwise = True
419
386
420− sendErrorResponse req istatus e = do
387+ sendErrorResponse addr istatus e = do
421 status <- readIORef istatus
388 status <- readIORef istatus
422− if shouldSendErrorResponse e && status
389+ when (shouldSendErrorResponse e && status) $ do
423− then do
390+ let ii = toInternalInfo ii1 0 -- dummy
391+ dreq = dummyreq addr
424− sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)
392+ void $ sendResponse settings conn ii dreq defaultIndexRequestHeader (return S.empty) (errorResponse e)
425− else return False
426
393
427 dummyreq addr = defaultRequest { remoteHost = addr }
394 dummyreq addr = defaultRequest { remoteHost = addr }
428
395
429 errorResponse e = settingsOnExceptionResponse settings e
396 errorResponse e = settingsOnExceptionResponse settings e
430
397
431 http1 firstRequest addr istatus src = do
398 http1 firstRequest addr istatus src = do
432− (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport
399+ (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src
400+ let req = req' { isSecure = isTransportSecure transport }
433− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
401+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii
434 `E.catch` \e -> do
402 `E.catch` \e -> do
403+ -- Call the user-supplied exception handlers, passing the request.
404+ sendErrorResponse addr istatus e
435 settingsOnException settings (Just req) e
405 settingsOnException settings (Just req) e
436 -- Don't throw the error again to prevent calling settingsOnException twice.
406 -- Don't throw the error again to prevent calling settingsOnException twice.
437 return False
407 return False
@@ -444,9 +414,9 @@ serveConnection conn ii th origAddr transport settings app = do
444 -- request headers, no data is available, recvRequest will
414 -- request headers, no data is available, recvRequest will
445 -- throw a NoKeepAliveRequest exception, which we catch here
415 -- throw a NoKeepAliveRequest exception, which we catch here
446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618
416 -- and ignore. See: https://github.com/yesodweb/wai/issues/618
447− when keepAlive $ http1 False addr istatus src
417+ when keepAlive $ http1 False addr istatus src `E.catch` \NoKeepAliveRequest -> return ()
448
418
449− processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do
419+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do
450 -- Let the application run for as long as it wants
420 -- Let the application run for as long as it wants
451 T.pause th
421 T.pause th
452
422
@@ -454,38 +424,30 @@ serveConnection conn ii th origAddr transport settings app = do
454 -- creating the request, we need to make sure that we don't get
424 -- creating the request, we need to make sure that we don't get
455 -- an async exception before calling the ResponseSource.
425 -- an async exception before calling the ResponseSource.
456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
426 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
457− r <- E.try $ app req $ \res -> do
427+ _ <- app req $ \res -> do
458 T.resume th
428 T.resume th
459 -- FIXME consider forcing evaluation of the res here to
429 -- FIXME consider forcing evaluation of the res here to
460 -- send more meaningful error messages to the user.
430 -- send more meaningful error messages to the user.
461 -- However, it may affect performance.
431 -- However, it may affect performance.
462 writeIORef istatus False
432 writeIORef istatus False
463− keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res
433+ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res
464 writeIORef keepAliveRef keepAlive
434 writeIORef keepAliveRef keepAlive
465 return ResponseReceived
435 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
436 keepAlive <- readIORef keepAliveRef
476
437
477 -- We just send a Response and it takes a time to
438 -- We just send a Response and it takes a time to
478 -- receive a Request again. If we immediately call recv,
439 -- receive a Request again. If we immediately call recv,
479− -- it is likely to fail and cause the IO manager to do some work.
440+ -- it is likely to fail and the IO manager works.
480− -- It is very costly, so we yield to another Haskell
441+ -- It is very costly. So, we yield to another Haskell
481 -- thread hoping that the next Request will arrive
442 -- thread hoping that the next Request will arrive
482 -- when this Haskell thread will be re-scheduled.
443 -- when this Haskell thread will be re-scheduled.
483 -- This improves performance at least when
444 -- This improves performance at least when
484 -- the number of cores is small.
445 -- the number of cores is small.
485 Conc.yield
446 Conc.yield
486
447
487− if keepAlive
448+ if not keepAlive then
488− then
449+ return False
450+ else
489 -- If there is an unknown or large amount of data to still be read
451 -- 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
452 -- from the request body, simple drop this connection instead of
491 -- reading it all in to satisfy a keep-alive request.
453 -- reading it all in to satisfy a keep-alive request.
@@ -511,21 +473,6 @@ serveConnection conn ii th origAddr transport settings app = do
511 else
473 else
512 return False
474 return False
513 Nothing -> tryKeepAlive
475 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
476
530flushEntireBody :: IO ByteString -> IO ()
477flushEntireBody :: IO ByteString -> IO ()
531flushEntireBody src =
478flushEntireBody src =
@@ -571,22 +518,12 @@ wrappedRecvN th istatus slowlorisSize readN bufsize = do
571 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th
518 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th
572 return bs
519 return bs
573
520
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
521-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs
577−--
578−-- @since 3.2.17
579setSocketCloseOnExec :: Socket -> IO ()
522setSocketCloseOnExec :: Socket -> IO ()
580#if WINDOWS
523#if WINDOWS
581setSocketCloseOnExec _ = return ()
524setSocketCloseOnExec _ = return ()
582#else
525#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
526+setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket
590#endif
527#endif
591
528
592gracefulShutdown :: Settings -> Counter -> IO ()
529gracefulShutdown :: Settings -> Counter -> IO ()
warp/Network/Wai/Handler/Warp/Settings.hs+10−54
@@ -8,22 +8,20 @@ import Control.Concurrent (forkIOWithUnmask)
8import Control.Exception
8import Control.Exception
9import Data.ByteString.Builder (byteString)
9import Data.ByteString.Builder (byteString)
10import qualified Data.ByteString.Char8 as C8
10import qualified Data.ByteString.Char8 as C8
11−import Data.ByteString.Lazy (fromStrict)
12import Data.Streaming.Network (HostPreference)
11import Data.Streaming.Network (HostPreference)
13import qualified Data.Text as T
12import qualified Data.Text as T
14import qualified Data.Text.IO as TIO
13import qualified Data.Text.IO as TIO
15import Data.Version (showVersion)
14import Data.Version (showVersion)
16import GHC.IO.Exception (IOErrorType(..))
15import GHC.IO.Exception (IOErrorType(..))
17import qualified Network.HTTP.Types as H
16import qualified Network.HTTP.Types as H
18−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
19import Network.Socket (SockAddr)
17import Network.Socket (SockAddr)
20import Network.Wai
18import Network.Wai
21import qualified Paths_warp
19import qualified Paths_warp
22import System.IO (stderr)
20import System.IO (stderr)
23import System.IO.Error (ioeGetErrorType)
21import System.IO.Error (ioeGetErrorType)
24−import System.TimeManager
25
22
26import Network.Wai.Handler.Warp.Imports
23import Network.Wai.Handler.Warp.Imports
24+import Network.Wai.Handler.Warp.Timeout
27import Network.Wai.Handler.Warp.Types
25import Network.Wai.Handler.Warp.Types
28
26
29-- | Various Warp server settings. This is purposely kept as an abstract data
27-- | Various Warp server settings. This is purposely kept as an abstract data
@@ -76,13 +74,6 @@ data Settings = Settings
76 --
74 --
77 -- Since 2.0.3
75 -- Since 2.0.3
78 , settingsInstallShutdownHandler :: IO () -> IO ()
76 , settingsInstallShutdownHandler :: IO () -> IO ()
79− -- ^ An action to install a handler (e.g. Unix signal handler)
80− -- to close a listen socket.
81− -- The first argument is an action to close the listen socket.
82− --
83− -- Default: no action
84− --
85− -- Since 3.0.1
86 , settingsServerName :: ByteString
77 , settingsServerName :: ByteString
87 -- ^ Default server name if application does not set one.
78 -- ^ Default server name if application does not set one.
88 --
79 --
@@ -94,44 +85,28 @@ data Settings = Settings
94 , settingsProxyProtocol :: ProxyProtocol
85 , settingsProxyProtocol :: ProxyProtocol
95 -- ^ Specify usage of the PROXY protocol.
86 -- ^ Specify usage of the PROXY protocol.
96 --
87 --
97− -- Since 3.0.5
88+ -- Since 3.0.5.
98 , settingsSlowlorisSize :: Int
89 , settingsSlowlorisSize :: Int
99 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048
90 -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048
100 --
91 --
101− -- Since 3.1.2
92+ -- Since 3.1.2.
102 , settingsHTTP2Enabled :: Bool
93 , settingsHTTP2Enabled :: Bool
103 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True
94 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True
104 --
95 --
105− -- Since 3.1.7
96+ -- Since 3.1.7.
106 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()
97 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()
107 -- ^ A log function. Default: no action.
98 -- ^ A log function. Default: no action.
108 --
99 --
109− -- Since 3.1.10
100+ -- Since 3.X.X.
110 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
101 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
111 -- ^ A HTTP/2 server push log function. Default: no action.
102 -- ^ A HTTP/2 server push log function. Default: no action.
112 --
103 --
113− -- Since 3.2.7
104+ -- Since 3.X.X.
114 , settingsGracefulShutdownTimeout :: Maybe Int
105 , settingsGracefulShutdownTimeout :: Maybe Int
115 -- ^ An optional timeout to limit the time (in seconds) waiting for
106 -- ^ An optional timeout to limit the time (in seconds) waiting for
116 -- a graceful shutdown of the web server.
107 -- a graceful shutdown of the web server.
117 --
108 --
118 -- Since 3.2.8
109 -- Since 3.2.8
119− , settingsGracefulCloseTimeout1 :: Int
120− -- ^ A timeout to limit the time (in milliseconds) waiting for
121− -- FIN for HTTP/1.x. 0 means uses immediate close.
122− -- Default: 0.
123− --
124− -- Since 3.3.5
125− , settingsGracefulCloseTimeout2 :: Int
126− -- ^ A timeout to limit the time (in milliseconds) waiting for
127− -- FIN for HTTP/2. 0 means uses immediate close.
128− -- Default: 2000.
129− --
130− -- Since 3.3.5
131− , settingsMaxTotalHeaderLength :: Int
132− -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.
133− --
134− -- Since 3.3.8
135 }
110 }
136
111
137-- | Specify usage of the PROXY protocol.
112-- | Specify usage of the PROXY protocol.
@@ -168,9 +143,6 @@ defaultSettings = Settings
168 , settingsLogger = \_ _ _ -> return ()
143 , settingsLogger = \_ _ _ -> return ()
169 , settingsServerPushLogger = \_ _ _ -> return ()
144 , settingsServerPushLogger = \_ _ _ -> return ()
170 , settingsGracefulShutdownTimeout = Nothing
145 , settingsGracefulShutdownTimeout = Nothing
171− , settingsGracefulCloseTimeout1 = 0
172− , settingsGracefulCloseTimeout2 = 2000
173− , settingsMaxTotalHeaderLength = 50 * 1024
174 }
146 }
175
147
176-- | Apply the logic provided by 'defaultOnException' to determine if an
148-- | Apply the logic provided by 'defaultOnException' to determine if an
@@ -196,29 +168,13 @@ defaultOnException _ e =
196 when (defaultShouldDisplayException e)
168 when (defaultShouldDisplayException e)
197 $ TIO.hPutStrLn stderr $ T.pack $ show e
169 $ TIO.hPutStrLn stderr $ T.pack $ show e
198
170
199−-- | Sending 400 for bad requests.
200−-- Sending 500 for internal server errors.
171+-- | Sending 400 for bad requests. Sending 500 for internal server errors.
172+--
201-- Since: 3.1.0
173-- Since: 3.1.0
202−-- Sending 413 for too large payload.
203−-- Sending 431 for too large headers.
204−-- Since 3.2.27
205defaultOnExceptionResponse :: SomeException -> Response
174defaultOnExceptionResponse :: SomeException -> Response
206defaultOnExceptionResponse e
175defaultOnExceptionResponse e
207− | Just (_ :: InvalidRequest) <-
208− fromException e = responseLBS H.badRequest400
176+ | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request"
209− [(H.hContentType, "text/plain; charset=utf-8")]
210− "Bad Request"
211− | Just (ConnectionError (UnknownErrorCode 413) t) <-
212− fromException e = responseLBS H.status413
213− [(H.hContentType, "text/plain; charset=utf-8")]
214− (fromStrict t)
215− | Just (ConnectionError (UnknownErrorCode 431) t) <-
216− fromException e = responseLBS H.status431
217− [(H.hContentType, "text/plain; charset=utf-8")]
218− (fromStrict t)
219− | otherwise = responseLBS H.internalServerError500
177+ | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"
220− [(H.hContentType, "text/plain; charset=utf-8")]
221− "Something went wrong"
222
178
223-- | Exception handler for the debugging purpose.
179-- | Exception handler for the debugging purpose.
224-- 500, text/plain, a showed exception.
180-- 500, text/plain, a showed exception.
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+30−25
@@ -8,15 +8,14 @@ import Control.Exception
8import qualified Data.ByteString as S
8import qualified Data.ByteString as S
9import Data.IORef (IORef, readIORef, writeIORef, newIORef)
9import Data.IORef (IORef, readIORef, writeIORef, newIORef)
10import Data.Typeable (Typeable)
10import Data.Typeable (Typeable)
11−import Data.X509
12import Foreign.Ptr (Ptr)
11import Foreign.Ptr (Ptr)
13import System.Posix.Types (Fd)
12import System.Posix.Types (Fd)
14−import qualified System.TimeManager as T
15
13
16import qualified Network.Wai.Handler.Warp.Date as D
14import qualified Network.Wai.Handler.Warp.Date as D
17import qualified Network.Wai.Handler.Warp.FdCache as F
15import qualified Network.Wai.Handler.Warp.FdCache as F
18import qualified Network.Wai.Handler.Warp.FileInfoCache as I
16import qualified Network.Wai.Handler.Warp.FileInfoCache as I
19import Network.Wai.Handler.Warp.Imports
17import Network.Wai.Handler.Warp.Imports
18+import qualified Network.Wai.Handler.Warp.Timeout as T
20
19
21----------------------------------------------------------------
20----------------------------------------------------------------
22
21
@@ -53,20 +52,6 @@ instance Exception InvalidRequest
53
52
54----------------------------------------------------------------
53----------------------------------------------------------------
55
54
56−-- | Exception thrown if something goes wrong while in the midst of
57−-- sending a response, since the status code can't be altered at that
58−-- point.
59−--
60−-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe
61−-- or irrecoverable.
62−
63−newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException
64− deriving (Show, Typeable)
65−
66−instance Exception ExceptionInsideResponseBody
67−
68−----------------------------------------------------------------
69−
70-- | Data type to abstract file identifiers.
55-- | Data type to abstract file identifiers.
71-- On Unix, a file descriptor would be specified to make use of
56-- On Unix, a file descriptor would be specified to make use of
72-- the file descriptor cache.
57-- the file descriptor cache.
@@ -123,25 +108,46 @@ data Connection = Connection {
123 , connWriteBuffer :: Buffer
108 , connWriteBuffer :: Buffer
124 -- | The size of the write buffer.
109 -- | The size of the write buffer.
125 , connBufferSize :: BufSize
110 , connBufferSize :: BufSize
126− -- | Is this connection HTTP/2?
127− , connHTTP2 :: IORef Bool
128 }
111 }
129
112
130−getConnHTTP2 :: Connection -> IO Bool
113+----------------------------------------------------------------
131−getConnHTTP2 conn = readIORef (connHTTP2 conn)
114+
115+type Hash = Int
132
116
133−setConnHTTP2 :: Connection -> Bool -> IO ()
134−setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b
135
117
136−----------------------------------------------------------------
118+data InternalInfo0 =
119+ InternalInfo0 T.Manager
120+ (IO D.GMTDate)
121+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))
122+ (Hash -> FilePath -> IO I.FileInfo)
123+
124+timeoutManager0 :: InternalInfo0 -> T.Manager
125+timeoutManager0 (InternalInfo0 tm _ _ _) = tm
126+
127+data InternalInfo1 =
128+ InternalInfo1 T.Handle
129+ T.Manager
130+ (IO D.GMTDate)
131+ (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))
132+ (Hash -> FilePath -> IO I.FileInfo)
133+
134+toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1
135+toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e
136+
137+threadHandle1 :: InternalInfo1 -> T.Handle
138+threadHandle1 (InternalInfo1 th _ _ _ _) = th
137
139
138data InternalInfo = InternalInfo {
140data InternalInfo = InternalInfo {
141+ threadHandle :: T.Handle
139− timeoutManager :: T.Manager
142+ , timeoutManager :: T.Manager
140 , getDate :: IO D.GMTDate
143 , getDate :: IO D.GMTDate
141 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)
144 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)
142 , getFileInfo :: FilePath -> IO I.FileInfo
145 , getFileInfo :: FilePath -> IO I.FileInfo
143 }
146 }
144
147
148+toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo
149+toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h)
150+
145----------------------------------------------------------------
151----------------------------------------------------------------
146
152
147-- | Type for input streaming.
153-- | Type for input streaming.
@@ -180,7 +186,6 @@ data Transport = TCP -- ^ Plain channel: TCP
180 , tlsMinorVersion :: Int
186 , tlsMinorVersion :: Int
181 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301
187 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301
182 , tlsChiperID :: Word16
188 , tlsChiperID :: Word16
183− , tlsClientCertificate :: Maybe CertificateChain
184 } -- ^ Encrypted channel: TLS or SSL
189 } -- ^ Encrypted channel: TLS or SSL
185
190
186isTransportSecure :: Transport -> Bool
191isTransportSecure :: Transport -> Bool
warp/Network/Wai/Handler/Warp/Windows.hs−3
@@ -10,9 +10,6 @@ import Control.Concurrent
10
10
11import Network.Wai.Handler.Warp.Imports
11import Network.Wai.Handler.Warp.Imports
12
12
13−-- | Allow main socket listening thread to be interrupted on Windows platform
14−--
15−-- @since 3.2.17
16windowsThreadBlockHack :: IO a -> IO a
13windowsThreadBlockHack :: IO a -> IO a
17windowsThreadBlockHack act = do
14windowsThreadBlockHack act = do
18 var <- newEmptyMVar :: IO (MVar (Either SomeException a))
15 var <- newEmptyMVar :: IO (MVar (Either SomeException a))
warp/Network/Wai/Handler/Warp/WithApplication.hs+11−9
@@ -1,4 +1,4 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+
2module Network.Wai.Handler.Warp.WithApplication (
2module Network.Wai.Handler.Warp.WithApplication (
3 withApplication,
3 withApplication,
4 withApplicationSettings,
4 withApplicationSettings,
@@ -11,8 +11,6 @@ module Network.Wai.Handler.Warp.WithApplication (
11import Control.Concurrent
11import Control.Concurrent
12import Control.Concurrent.Async
12import Control.Concurrent.Async
13import Control.Exception
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 {
@@ -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
7#endif
8import Control.Monad
8import Control.Monad
9import Network.HTTP.Types hiding (Header)
9import Network.HTTP.Types hiding (Header)
10−import Network.Wai hiding (Response, responseStatus)
10+import Network.Wai hiding (Response)
11import Network.Wai.Internal (Request(..))
11import Network.Wai.Internal (Request(..))
12import Network.Wai.Handler.Warp
12import Network.Wai.Handler.Warp
13import Test.Hspec
13import Test.Hspec
@@ -49,18 +49,18 @@ spec :: Spec
49spec = describe "responds even if there is an exception" $ do
49spec = describe "responds even if there is an exception" $ do
50 {- Disabling these tests. We can consider forcing evaluation in Warp.
50 {- Disabling these tests. We can consider forcing evaluation in Warp.
51 it "statusError" $ do
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
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
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
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 -}
63 -}
64 it "ioException" $ withTestServer $ \prt -> do
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
17 it "clean up Fd" $ do
18 ref <- newIORef (Fd (-1))
18 ref <- newIORef (Fd (-1))
19 withFdCache 30000000 $ \getFd -> do
19 withFdCache 30000000 $ \getFd -> do
20− (Just fd,_) <- getFd "warp.cabal"
20+ (Just fd,_) <- getFd 0 "warp.cabal"
21 writeIORef ref fd
21 writeIORef ref fd
22 nfd <- readIORef ref
22 nfd <- readIORef ref
23 fdRead nfd 1 `shouldThrow` anyIOException
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
21 let WithBody s hs off len = ans
22 hs' = ("Last-Modified",fileInfoDate finfo) : hs
22 hs' = ("Last-Modified",fileInfoDate finfo) : hs
23 ans' = WithBody s hs' off len
23 ans' = WithBody s hs' off len
24− conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans'
24+ conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'
25
25
26spec :: Spec
26spec :: Spec
27spec = do
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)
7import Network.Wai.Handler.Warp.File (parseByteRanges)
8import Network.Wai.Handler.Warp.Request
8import Network.Wai.Handler.Warp.Request
9import Network.Wai.Handler.Warp.Types
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
7import Network.Wai.Handler.Warp.ResponseHeader
8import Network.Wai.Handler.Warp.Response
8import Network.Wai.Handler.Warp.Response
9import Network.Wai.Handler.Warp.Header
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
6import qualified Data.ByteString as S
7import qualified Data.ByteString.Char8 as S8
7import qualified Data.ByteString.Char8 as S8
8import Data.Maybe (mapMaybe)
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
9import qualified Control.Exception as E
10import Control.Exception.Lifted (bracket, try, IOException, onException)
10import Control.Exception.Lifted (bracket, try, IOException, onException)
11import Control.Monad (forM_, replicateM_, unless)
11import Control.Monad (forM_, replicateM_, unless)
12import Control.Monad.IO.Class (MonadIO, liftIO)
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
14import qualified Data.ByteString as S
15import Data.ByteString.Builder (byteString)
15import Data.ByteString.Builder (byteString)
16import qualified Data.ByteString.Char8 as S8
16import qualified Data.ByteString.Char8 as S8
17import qualified Data.ByteString.Lazy as L
17import qualified Data.ByteString.Lazy as L
18import qualified Data.IORef as I
18import qualified Data.IORef as I
19import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)
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
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−12
@@ -2,10 +2,14 @@
2
2
3module WithApplicationSpec where
3module WithApplicationSpec where
4
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
8import System.Environment
10import System.Environment
11+import System.IO
12+import System.IO.Silently
9import System.Process
13import System.Process
10import Test.Hspec
14import Test.Hspec
11
15
@@ -23,23 +27,23 @@ spec = do
23 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
27 output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
24 output `shouldBe` "foo"
28 output `shouldBe` "foo"
25
29
26− it "does not propagate exceptions from the server to the executing thread" $ do
30+ it "does not propagate exceptions from the server to the executing thread" $
31+ hSilence [stderr] $ do
27− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
32+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
28− withApplication mkApp $ \ port -> do
33+ withApplication mkApp $ \ port -> do
29− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
34+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
30− output `shouldContain` "Something went wron"
35+ output `shouldContain` "Something went wron"
31
36
32 describe "testWithApplication" $ do
37 describe "testWithApplication" $ do
33− it "propagates exceptions from the server to the executing thread" $ do
38+ it "propagates exceptions from the server to the executing thread" $
39+ hSilence [stderr] $ do
34− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
40+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
35− (testWithApplication mkApp $ \ port -> do
41+ (testWithApplication mkApp $ \ port -> do
36− readProcess "curl" ["-s", "localhost:" ++ show port] "")
42+ readProcess "curl" ["-s", "localhost:" ++ show port] "")
37− `shouldThrow` (errorCall "foo")
43+ `shouldThrow` (errorCall "foo")
38
44
39−{- The future netwrok library will not export MkSocket.
40 describe "withFreePort" $ do
45 describe "withFreePort" $ do
41 it "closes the socket before exiting" $ do
46 it "closes the socket before exiting" $ do
42 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do
47 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do
43 return sock
48 return sock
44 readMVar statusMVar `shouldReturn` Closed
49 readMVar statusMVar `shouldReturn` Closed
45−-}
warp/warp.cabal+44−109
@@ -1,5 +1,5 @@
1Name: warp
1Name: warp
2−Version: 3.3.9
2+Version: 3.2.13
3Synopsis: A fast, light-weight web server for WAI applications.
3Synopsis: A fast, light-weight web server for WAI applications.
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE
@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com
8Homepage: http://github.com/yesodweb/wai
8Homepage: http://github.com/yesodweb/wai
9Category: Web, Yesod
9Category: Web, Yesod
10Build-Type: Simple
10Build-Type: Simple
11−Cabal-Version: >= 1.10
11+Cabal-Version: >=1.8
12Stability: Stable
12Stability: Stable
13description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.
13description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.
14 For HTTP\/2, Warp supports direct and ALPN (in TLS)
14 For HTTP\/2, Warp supports direct and ALPN (in TLS)
@@ -37,28 +37,24 @@ Library
37 , array
37 , array
38 , async
38 , async
39 , auto-update >= 0.1.3 && < 0.2
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
41 , bytestring >= 0.9.1.4
42 , case-insensitive >= 0.2
42 , case-insensitive >= 0.2
43 , containers
43 , containers
44 , ghc-prim
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
83 Network.Wai.Handler.Warp.Header
84 Network.Wai.Handler.Warp.IO
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