git.iko.soy/typeable/wai
on 56bd8e2 help sign in
e083f6e
swap
0 ahead, 1239 behind
.azure/azure-linux-template.ymldeleted−93
since splitsnapshots
unifiedsplit
@@ -1,93 +0,0 @@
1−jobs:
2−- job: ${{ parameters.name }}
3− timeoutInMinutes: 180
4− pool:
5− vmImage: ${{ parameters.vmImage }}
6− strategy:
7− matrix:
8− stack-lts-11:
9− BUILD: stack
10− STACK_YAML: stack-lts-11.yaml
11− ARGS: "--resolver lts-11"
12− stack-lts-12:
13− BUILD: stack
14− STACK_YAML: stack-lts-12.yaml
15− ARGS: "--resolver lts-12"
16− stack-lts-14:
17− BUILD: stack
18− ARGS: "--resolver lts-14"
19− stack-nightly:
20− BUILD: stack
21− STACK_YAML: stack-nightly.yaml
22− ARGS: "--resolver nightly"
23− cabal-8.2.2:
24− BUILD: cabal
25− GHCVER: 8.4.4
26− CABALVER: 2.0
27− cabal-8.4.4:
28− BUILD: cabal
29− GHCVER: 8.4.4
30− CABALVER: 2.2
31− cabal-8.6.5:
32− BUILD: cabal
33− GHCVER: 8.6.5
34− CABALVER: 2.4
35− maxParallel: 6
36− steps:
37− - script: |
38− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
39− mkdir -p ~/.local/bin
40− curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
41− case "$BUILD" in
42− cabal)
43− sudo add-apt-repository -y ppa:hvr/ghc
44− sudo apt-get update
45− sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
46− # See note here: https://github.com/haskell-CI/haskell-ci#alex--happy-with-ghc--78
47− if [ "$GHCVER" = "head" ] || [ "${GHCVER%.*}" = "7.8" ] || [ "${GHCVER%.*}" = "7.10" ]; then
48− sudo apt-get install happy-1.19.4 alex-3.1.3
49− export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH
50− else
51− sudo apt-get install happy alex
52− fi
53− export PATH=$HOME/.local/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
54− cabal --version
55− cabal update
56− PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
57− cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
58− ;;
59− *)
60− export PATH=$HOME/.local/bin:$PATH
61− stack --install-ghc $ARGS test --bench --only-dependencies
62− ;;
63− esac
64− set -ex
65− case "$BUILD" in
66− cabal)
67− cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
68−
69− ORIGDIR=$(pwd)
70− for dir in $PACKAGES
71− do
72− cd $dir
73− cabal check || [ "$CABALVER" == "1.22" ] # https://github.com/yesodweb/wai/pull/754#issuecomment-504866279
74− cabal sdist
75− PKGVER=$(cabal info . | awk '{print $2;exit}')
76− SRC_TGZ=$PKGVER.tar.gz
77− cd dist
78− tar zxfv "$SRC_TGZ"
79− cd "$PKGVER"
80− cabal configure --enable-tests --ghc-options -O0
81− cabal build
82− cabal test --show-details=streaming
83− cd $ORIGDIR
84− done
85− ;;
86− *)
87− stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
88− ;;
89− esac
90− set +ex
91− env:
92− OS_NAME: ${{ parameters.os }}
93− displayName: 'Installation ${{parameters.os}} & Test'
.azure/azure-osx-template.ymldeleted−30
@@ -1,30 +0,0 @@
1−jobs:
2−- job: ${{ parameters.name }}
3− timeoutInMinutes: 180
4− pool:
5− vmImage: ${{ parameters.vmImage }}
6− strategy:
7− matrix:
8− stack-lts-11:
9− BUILD: stack
10− STACK_YAML: stack-lts-11.yaml
11− ARGS: "--resolver lts-11"
12− stack-lts-12:
13− BUILD: stack
14− STACK_YAML: stack-lts-12.yaml
15− ARGS: "--resolver lts-12"
16− stack-lts-14:
17− BUILD: stack
18− ARGS: "--resolver lts-14"
19− maxParallel: 3
20− steps:
21− - script: |
22− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
23− mkdir -p ~/.local/bin
24− curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
25− export PATH=$HOME/.local/bin:$PATH
26− stack --install-ghc $ARGS test --bench --only-dependencies
27− stack $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
28− env:
29− OS_NAME: ${{ parameters.os }}
30− displayName: 'Installation ${{parameters.os}} & Test'
.azure/azure-pipelines.ymldeleted−30
@@ -1,30 +0,0 @@
1−# This is the complex Azure configuration, which is intended for use
2−# on open source libraries which need compatibility across multiple GHC
3−# versions, must work with cabal-install, and should be
4−# cross-platform. For more information and other options, see:
5−#
6−# https://docs.haskellstack.org/en/stable/azure_ci/
7−#
8−# Copy these contents into the root directory of your Github project in a file
9−# named azure-pipelines.yml
10−#
11−# For better organization, you split various jobs into seprate parts
12−# and each of them are controlled via individual file.
13−jobs:
14−- template: azure-linux-template.yml
15− parameters:
16− name: Linux
17− vmImage: ubuntu-16.04
18− os: linux
19−
20−- template: azure-osx-template.yml
21− parameters:
22− name: macOS
23− vmImage: macOS-10.13
24− os: osx
25−
26−- template: azure-windows-template.yml
27− parameters:
28− name: Windows
29− vmImage: vs2017-win2016
30− os: windows
.azure/azure-windows-template.ymldeleted−23
@@ -1,23 +0,0 @@
1−jobs:
2−- job: ${{ parameters.name }}
3− timeoutInMinutes: 180
4− pool:
5− vmImage: ${{ parameters.vmImage }}
6− strategy:
7− matrix:
8− stack-lts-14:
9− BUILD: stack
10− ARGS: "--resolver lts-14"
11− maxParallel: 3
12− steps:
13− - bash: |
14− export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root;
15− curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
16− unzip -o /usr/bin/stack.zip -d /usr/bin/
17− stack setup $ARGS > /dev/null
18− stack --install-ghc $ARGS test --bench --only-dependencies
19− stack $ARGS test --bench --no-run-benchmarks --no-run-tests
20− stack $ARGS test --bench --no-run-benchmarks --jobs 1 # non-parallel test execution
21− env:
22− OS_NAME: ${{ parameters.os }}
23− displayName: 'Installation ${{parameters.os}} & Test'
.github/ISSUE_TEMPLATE.mddeleted−28
@@ -1,28 +0,0 @@
1−<!---
2−
3−### Bug Reports
4−
5−Reporting a bug? If relevant, we recommend including:
6−
7−* Your OS name and version
8−* The versions of tools you're using (e.g. `stack`, `ghc`).
9−* The versions of dependencies you're using
10−
11−For your convenience, we recommend pasting this script into bash and uploading the output [as a gist](https://gist.github.com/).
12−
13−```
14−command -v sw_vers && sw_vers # OS X only
15−command -v uname && uname -a # Kernel version
16−command -v stack && stack --version
17−command -v stack && stack ghc -- --version
18−command -v stack && stack list-dependencies
19−```
20−
21−* Also, is there anything custom or unusual about your setup? i.e. new or prerelease versions of GHC, Stack, etc.
22−
23−* Finally, if possible, please reproduce the error in a small script, or if necessary create a new Github repo with the smallest possible reproducing case. [Stack's scripting support](https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter) might be useful for creating your reproduction example.
24−
25−### Support
26−
27−Please direct support questions to [Stack Overflow](https://stackoverflow.com/questions/tagged/yesod+haskell) or the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb). If you don't get a response there, or you suspect there may be a bug in Wai causing your problem, you're welcome to ask here.
28−-->
.github/PULL_REQUEST_TEMPLATE.mddeleted−14
@@ -1,14 +0,0 @@
1−Before submitting your PR, check that you've:
2−
3−- [ ] Bumped the version number
4−- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html)
5−- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock
6−
7−After submitting your PR:
8−
9−- [ ] Update the Changelog.md file with a link to your PR
10−- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts)
11−
12−<!---Thanks so much for contributing! :)
13−
14−_If these checkboxes don't apply to your PR, you can delete them_-->
.gitignore−3
@@ -7,6 +7,3 @@ tarballs/
7/.shelly
7/.shelly
8.cabal-sandbox/
8.cabal-sandbox/
9cabal.sandbox.config
9cabal.sandbox.config
10−.stack-work/
11−*~
12−stack*.yaml.lock
.travis.ymlnew file+16
@@ -0,0 +1,16 @@
1+language: haskell
2+
3+ghc:
4+ - 7.6
5+ - 7.8
6+
7+install:
8+ - ghc --version
9+ - cabal --version
10+ - sudo apt-get install libfcgi-dev
11+ - cabal unpack wai-logger
12+ - mv wai-logger-* wai-logger
13+ - cabal install hspec doctest HTTP cabal-meta cabal-src
14+ - cabal-meta install --force-reinstalls
15+
16+script: mega-sdist --test
CONTRIBUTING.mddeleted−94
@@ -1,94 +0,0 @@
1−# Contributing
2−
3−Thanks for your interest in contributing to Wai! This file has some tips for developing Wai and getting a pull request accepted.
4−
5−## Development
6−
7−Wai is a mega-repo that contains many Haskell packages, each in a different directory. All the subprojects can be developed with Stack, using `stack <command> <subproject>`, e.g.
8−
9−* `stack build mime-types`
10−* `stack test auto-update`
11−* `stack haddock warp`
12−
13−If you'd like to test your changes in a full-fledged Wai app, you can use Stack to build against it, e.g.:
14−
15−```
16−packages:
17−- '/path/to/this/repo/wai'
18−```
19−
20−## Coding Guidelines
21−
22−### Safety
23−
24−Avoid partial functions. Even if you know the partial function is safe in your instance, partial functions require more reasoning from the programmer and are not resilient to refactoring. For the rare cases where a partial function is appropriate, a custom `error` should be used.
25−
26−### Style
27−
28−Keep coding style consistent with the rest of the file, but don't worry about style too much otherwise. PRs changing code style are viewed skeptically.
29−
30−### Dependencies
31−
32−Avoid adding unnecessary dependencies. If a dependency provides only a minor convenience for your implementation, it's probably better to skip it.
33−
34−If you do add a new dependency, try to support a wide range of versions of it.
35−
36−### Backwards Compatibility
37−
38−Backwards incompatible changes are viewed skeptically—best to ask in an issue to see if a particular backwards incompatible change would be approved. If possible keep backwards compatibility by adding new APIs and deprecating old ones.
39−
40−Keep backwards compatibility with old versions of dependencies when possible.
41−
42−## PR Guidelines
43−
44−### PR Scope
45−
46−As much as possible, keep separate changes in separate PRs.
47−
48−### Testing
49−
50−Tests are recommended, but not required.
51−
52−### Documentation
53−
54−All public APIs must be documented. Documenting private functions is optional, but may be nice depending on their complexity. Example documentation:
55−
56−```
57−-- | Generate an action which will either read from an automatically
58−-- updated value, or run the update action in the current thread.
59−--
60−-- ==== __Examples__
61−--
62−-- > getTime <- mkAutoUpdate defaultUpdateSettings
63−--
64−-- @since 0.1.0
65−mkAutoUpdate :: UpdateSettings a -> IO (IO a)
66−```
67−
68−Examples are recommended, but not required, in documentation. Marking new APIs with `@since <version number>` is required.
69−
70−### Versioning
71−
72−Wai packages roughly follow the Haskell Package Versioning Policy style of A.B.C.[D] (MAJOR.MAJOR.MINOR.[PATCH])
73−
74−* A - Used for massive changes in the library. (Example: 1.2.3.4 becomes 2.0.0)
75−* B - Used for smaller breaking changes, like removing, renaming, or changing behavior of existing public API. (Example: 1.2.3.4 becomes 1.3.0)
76−* C - Used for new public APIs (Example: 1.2.3.4 becomes 1.2.4)
77−* D - Used for bug fixes (Example: 1.2.3.4 becomes 1.2.3.5).
78− * D is optional in the version number, so 2.0.0 is a valid version.
79−
80−Documentation changes don't require a new version.
81−
82−If you feel there is ambiguity to a change (e.g. fixing a bug in a function, when people may be relying on the old broken behavior), you can ask in an issue or pull request.
83−
84−Unlike in the Package Versioning Policy, deprecations are not counted as MAJOR changes.
85−
86−In some cases, dropping compatibility with a major version of a dependency (e.g. changing from transformers >= 0.3 to transformers >= 0.4), is considered a breaking change.
87−
88−### Changelog
89−
90−After you submit a PR, update the subproject's Changelog.md file with the new version number and a link to your PR. If your PR does not need to bump the version number, include the change in an "Unreleased" section at the top.
91−
92−### Releases
93−
94−Releases should be done as soon as possible after a pull request is merged—don't be shy about reminding us to make a release if we forget.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/
1+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
2
2
3Permission is hereby granted, free of charge, to any person obtaining
3Permission is hereby granted, free of charge, to any person obtaining
4a copy of this software and associated documentation files (the
4a copy of this software and associated documentation files (the
README.md−2
@@ -9,5 +9,3 @@ Code can be written that works with any web framework targeting WAI.
9[Documentation](http://www.yesodweb.com/book/web-application-interface)
9[Documentation](http://www.yesodweb.com/book/web-application-interface)
10
10
11[Haddock Documentation](http://hackage.haskell.org/package/wai)
11[Haddock Documentation](http://hackage.haskell.org/package/wai)
12−
13−[![Build Status](https://dev.azure.com/yesodweb/wai/_apis/build/status/yesodweb.wai?branchName=master)](https://dev.azure.com/yesodweb/wai/_build/latest?definitionId=1&branchName=master)
auto-update/ChangeLog.md+1−34
@@ -1,34 +1 @@
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
21−
22−* Provide updateActionModify API in AutoUpdate [#547](https://github.com/yesodweb/wai/pull/547)
23−
24−## 0.1.3.1
25−
26−* Doc improvements
27−
28−## 0.1.3
29−
30−* Adding a new AIP - reaperKill
31−
32−## 0.1.2
33−
34−* Added Control.Debounce
1+__0.1.2__ Added Control.Debounce
auto-update/Control/AutoUpdate.hs+28−64
@@ -1,60 +1,35 @@
1−{-# LANGUAGE CPP #-}
1+-- | A common problem is the desire to have an action run at a scheduled
2−-- | In a multithreaded environment, running actions on a regularly scheduled
2+-- interval, but only if it is needed. For example, instead of having
3−-- background thread can dramatically improve performance.
3+-- every web request result in a new @getCurrentTime@ call, we'd like to
4−-- For example, web servers need to return the current time with each HTTP response.
4+-- have a single worker thread run every second, updating an @IORef@.
5−-- For a high-volume server, it's much faster for a dedicated thread to run every
5+-- However, if the request frequency is less than once per second, this is
6−-- second, and write the current time to a shared 'IORef', than it is for each
6+-- a pessimization, and worse, kills idle GC.
7−-- request to make its own call to 'getCurrentTime'.
8--
7--
9−-- But for a low-volume server, whose request frequency is less than once per
10−-- second, that approach will result in /more/ calls to 'getCurrentTime' than
11−-- necessary, and worse, kills idle GC.
12−--
13−-- This library solves that problem by allowing you to define actions which will
8+-- This library allows you to define actions which will either be
14−-- either be performed by a dedicated thread, or, in times of low volume, will
9+-- performed by a dedicated thread or, in times of low volume, will be
15−-- be executed by the calling thread.
10+-- executed by the calling thread.
16−--
17−-- Example usage:
18−--
19−-- @
20−-- import "Data.Time"
21−-- import "Control.AutoUpdate"
22−--
23−-- getTime <- 'mkAutoUpdate' 'defaultUpdateSettings'
24−-- { 'updateAction' = 'Data.Time.Clock.getCurrentTime'
25−-- , 'updateFreq' = 1000000 -- The default frequency, once per second
26−-- }
27−-- currentTime <- getTime
28−-- @
29−--
30−-- For more examples, <http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post introducing this library>.
31module Control.AutoUpdate (
11module Control.AutoUpdate (
32 -- * Type
12 -- * Type
33 UpdateSettings
13 UpdateSettings
34 , defaultUpdateSettings
14 , defaultUpdateSettings
35 -- * Accessors
15 -- * Accessors
36− , updateAction
37 , updateFreq
16 , updateFreq
38 , updateSpawnThreshold
17 , updateSpawnThreshold
18+ , updateAction
39 -- * Creation
19 -- * Creation
40 , mkAutoUpdate
20 , mkAutoUpdate
41− , mkAutoUpdateWithModify
42 ) where
21 ) where
43
22
44−#if __GLASGOW_HASKELL__ < 709
45−import Control.Applicative ((<*>))
46−#endif
47import Control.Concurrent (forkIO, threadDelay)
23import Control.Concurrent (forkIO, threadDelay)
48import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
24import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
49 takeMVar, tryPutMVar)
25 takeMVar, tryPutMVar)
50−import Control.Exception (SomeException, catch, mask_, throw,
26+import Control.Exception (SomeException, catch, throw, mask_, try)
51− try)
52import Control.Monad (void)
27import Control.Monad (void)
53import Data.IORef (newIORef, readIORef, writeIORef)
28import Data.IORef (newIORef, readIORef, writeIORef)
54
29
55−-- | Default value for creating an 'UpdateSettings'.
30+-- | Default value for creating an @UpdateSettings@.
56--
31--
57−-- @since 0.1.0
32+-- Since 0.1.0
58defaultUpdateSettings :: UpdateSettings ()
33defaultUpdateSettings :: UpdateSettings ()
59defaultUpdateSettings = UpdateSettings
34defaultUpdateSettings = UpdateSettings
60 { updateFreq = 1000000
35 { updateFreq = 1000000
@@ -64,57 +39,46 @@ defaultUpdateSettings = UpdateSettings
64
39
65-- | Settings to control how values are updated.
40-- | Settings to control how values are updated.
66--
41--
67−-- This should be constructed using 'defaultUpdateSettings' and record
42+-- This should be constructed using @defaultUpdateSettings@ and record
68-- update syntax, e.g.:
43-- update syntax, e.g.:
69--
44--
70-- @
45-- @
71−-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }
46+-- let set = defaultUpdateSettings { updateAction = getCurrentTime }
72-- @
47-- @
73--
48--
74−-- @since 0.1.0
49+-- Since 0.1.0
75data UpdateSettings a = UpdateSettings
50data UpdateSettings a = UpdateSettings
76 { updateFreq :: Int
51 { updateFreq :: Int
77 -- ^ Microseconds between update calls. Same considerations as
52 -- ^ Microseconds between update calls. Same considerations as
78− -- 'threadDelay' apply.
53+ -- @threadDelay@ apply.
79 --
54 --
80 -- Default: 1 second (1000000)
55 -- Default: 1 second (1000000)
81 --
56 --
82− -- @since 0.1.0
57+ -- Since 0.1.0
83 , updateSpawnThreshold :: Int
58 , updateSpawnThreshold :: Int
84 -- ^ NOTE: This value no longer has any effect, since worker threads are
59 -- ^ NOTE: This value no longer has any effect, since worker threads are
85 -- dedicated instead of spawned on demand.
60 -- dedicated instead of spawned on demand.
86 --
61 --
87− -- Previously, this determined how many times the data must be requested
62+ -- Previously, this determined: How many times the data must be requested
88 -- before we decide to spawn a dedicated thread.
63 -- before we decide to spawn a dedicated thread.
89 --
64 --
90 -- Default: 3
65 -- Default: 3
91 --
66 --
92− -- @since 0.1.0
67+ -- Since 0.1.0
93 , updateAction :: IO a
68 , updateAction :: IO a
94 -- ^ Action to be performed to get the current value.
69 -- ^ Action to be performed to get the current value.
95 --
70 --
96 -- Default: does nothing.
71 -- Default: does nothing.
97 --
72 --
98− -- @since 0.1.0
73+ -- Since 0.1.0
99 }
74 }
100
75
101-- | Generate an action which will either read from an automatically
76-- | Generate an action which will either read from an automatically
102-- updated value, or run the update action in the current thread.
77-- updated value, or run the update action in the current thread.
103--
78--
104−-- @since 0.1.0
79+-- Since 0.1.0
105mkAutoUpdate :: UpdateSettings a -> IO (IO a)
80mkAutoUpdate :: UpdateSettings a -> IO (IO a)
106−mkAutoUpdate us = mkAutoUpdateHelper us Nothing
81+mkAutoUpdate us = do
107−
108−-- | Generate an action which will either read from an automatically
109−-- updated value, or run the update action in the current thread if
110−-- the first time or the provided modify action after that.
111−--
112−-- @since 0.1.4
113−mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)
114−mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f)
115−
116−mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)
117−mkAutoUpdateHelper us updateActionModify = do
118 -- A baton to tell the worker thread to generate a new value.
82 -- A baton to tell the worker thread to generate a new value.
119 needsRunning <- newEmptyMVar
83 needsRunning <- newEmptyMVar
120
84
@@ -157,12 +121,12 @@ mkAutoUpdateHelper us updateActionModify = do
157 -- This infinite loop makes up out worker thread. It takes an a
121 -- This infinite loop makes up out worker thread. It takes an a
158 -- responseVar value where the next value should be putMVar'ed to for
122 -- responseVar value where the next value should be putMVar'ed to for
159 -- the benefit of any requesters currently blocked on it.
123 -- the benefit of any requesters currently blocked on it.
160− let loop responseVar maybea = do
124+ let loop responseVar = do
161 -- block until a value is actually needed
125 -- block until a value is actually needed
162 takeMVar needsRunning
126 takeMVar needsRunning
163
127
164 -- new value requested, so run the updateAction
128 -- new value requested, so run the updateAction
165− a <- catchSome $ maybe (updateAction us) id (updateActionModify <*> maybea)
129+ a <- catchSome $ updateAction us
166
130
167 -- we got a new value, update currRef and lastValue
131 -- we got a new value, update currRef and lastValue
168 writeIORef currRef $ Right a
132 writeIORef currRef $ Right a
@@ -177,10 +141,10 @@ mkAutoUpdateHelper us updateActionModify = do
177 -- variable.
141 -- variable.
178 responseVar' <- newEmptyMVar
142 responseVar' <- newEmptyMVar
179 writeIORef currRef $ Left responseVar'
143 writeIORef currRef $ Left responseVar'
180− loop responseVar' (Just a)
144+ loop responseVar'
181
145
182 -- Kick off the loop, with the initial responseVar0 variable.
146 -- Kick off the loop, with the initial responseVar0 variable.
183− loop responseVar0 Nothing
147+ loop responseVar0
184
148
185 return $ do
149 return $ do
186 mval <- readIORef currRef
150 mval <- readIORef currRef
@@ -194,7 +158,7 @@ mkAutoUpdateHelper us updateActionModify = do
194 -- we have a current value, use it
158 -- we have a current value, use it
195 Right val -> return val
159 Right val -> return val
196
160
197−-- | Turn a runtime exception into an impure exception, so that all 'IO'
161+-- | Turn a runtime exception into an impure exception, so that all @IO@
198-- actions will complete successfully. This simply defers the exception until
162-- actions will complete successfully. This simply defers the exception until
199-- the value is forced.
163-- the value is forced.
200catchSome :: IO a -> IO a
164catchSome :: IO a -> IO a
auto-update/Control/Debounce.hs+59−41
@@ -3,58 +3,76 @@
3-- period of time.
3-- period of time.
4--
4--
5-- This is useful as an optimization, for example to ensure that logs are only
5-- This is useful as an optimization, for example to ensure that logs are only
6−-- flushed to disk at most once per second.
6+-- flushed to disk at most once per second. See the fast-logger package for an
7+-- example usage.
7--
8--
8−-- Example usage:
9+-- Since 0.1.2
9−--
10−-- @
11−-- printString <- 'mkDebounce' 'defaultDebounceSettings'
12−-- { 'debounceAction' = putStrLn "Running action"
13−-- , 'debounceFreq' = 5000000 -- 5 seconds
14−-- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge
15−-- }
16−-- @
17−--
18−-- >>> printString
19−-- Running action
20−-- >>> printString
21−-- <Wait five seconds>
22−-- Running action
23−--
24−-- See the fast-logger package ("System.Log.FastLogger") for real-world usage.
25−--
26−-- @since 0.1.2
27module Control.Debounce
10module Control.Debounce
28 ( -- * Type
11 ( -- * Type
29− DI.DebounceSettings
12+ DebounceSettings
30 , defaultDebounceSettings
13 , defaultDebounceSettings
31 -- * Accessors
14 -- * Accessors
32− , DI.debounceFreq
15+ , debounceFreq
33− , DI.debounceAction
16+ , debounceAction
34− , DI.debounceEdge
35− , DI.leadingEdge
36− , DI.trailingEdge
37 -- * Creation
17 -- * Creation
38 , mkDebounce
18 , mkDebounce
39 ) where
19 ) where
40
20
41−import Control.Concurrent (newEmptyMVar, threadDelay)
21+import Control.Concurrent (forkIO, threadDelay)
42−import qualified Control.Debounce.Internal as DI
22+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)
23+import Control.Exception (SomeException, handle, mask_)
24+import Control.Monad (forever, void)
25+
26+-- | Settings to control how debouncing should work.
27+--
28+-- This should be constructed using @defaultDebounceSettings@ and record
29+-- update syntax, e.g.:
30+--
31+-- @
32+-- let set = defaultDebounceSettings { debounceAction = flushLog }
33+-- @
34+--
35+-- Since 0.1.2
36+data DebounceSettings = DebounceSettings
37+ { debounceFreq :: Int
38+ -- ^ Microseconds lag required between subsequence calls to the debounced
39+ -- action.
40+ --
41+ -- Default: 1 second (1000000)
42+ --
43+ -- Since 0.1.2
44+ , debounceAction :: IO ()
45+ -- ^ Action to be performed.
46+ --
47+ -- Note: all exceptions thrown by this action will be silently discarded.
48+ --
49+ -- Default: does nothing.
50+ --
51+ -- Since 0.1.2
52+ }
43
53
44−-- | Default value for creating a 'DebounceSettings'.
54+-- | Default value for creating a @DebounceSettings@.
45--
55--
46−-- @since 0.1.2
56+-- Since 0.1.2
47−defaultDebounceSettings :: DI.DebounceSettings
57+defaultDebounceSettings :: DebounceSettings
48−defaultDebounceSettings = DI.DebounceSettings
58+defaultDebounceSettings = DebounceSettings
49− { DI.debounceFreq = 1000000
59+ { debounceFreq = 1000000
50− , DI.debounceAction = return ()
60+ , debounceAction = return ()
51− , DI.debounceEdge = DI.leadingEdge
52 }
61 }
53
62
54−-- | Generate an action which will trigger the debounced action to be performed.
63+-- | Generate an action which will trigger the debounced action to be
64+-- performed. The action will either be performed immediately, or after the
65+-- current cooldown period has expired.
55--
66--
56−-- @since 0.1.2
67+-- Since 0.1.2
57−mkDebounce :: DI.DebounceSettings -> IO (IO ())
68+mkDebounce :: DebounceSettings -> IO (IO ())
58−mkDebounce settings = do
69+mkDebounce (DebounceSettings freq action) = do
59− baton <- newEmptyMVar
70+ baton <- newEmptyMVar
60− DI.mkDebounceInternal baton threadDelay settings
71+ mask_ $ void $ forkIO $ forever $ do
72+ takeMVar baton
73+ ignoreExc action
74+ threadDelay freq
75+ return $ void $ tryPutMVar baton ()
76+
77+ignoreExc :: IO () -> IO ()
78+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+36−131
@@ -1,20 +1,9 @@
1{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE BangPatterns #-}
3
2
4-- | This module provides the ability to create reapers: dedicated cleanup
3-- | This module provides the ability to create reapers: dedicated cleanup
5-- threads. These threads will automatically spawn and die based on the
4-- threads. These threads will automatically spawn and die based on the
6−-- presence of a workload to process on. Example uses include:
5+-- presence of a workload to process on.
7−--
8−-- * Killing long-running jobs
9−-- * Closing unused connections in a connection pool
10−-- * Pruning a cache of old items (see example below)
11−--
12−-- For real-world usage, search the <https://github.com/yesodweb/wai WAI family of packages>
13−-- for imports of "Control.Reaper".
14module Control.Reaper (
6module Control.Reaper (
15− -- * Example: Regularly cleaning a cache
16− -- $example1
17−
18 -- * Settings
7 -- * Settings
19 ReaperSettings
8 ReaperSettings
20 , defaultReaperSettings
9 , defaultReaperSettings
@@ -33,9 +22,10 @@ module Control.Reaper (
33 ) where
22 ) where
34
23
35import Control.AutoUpdate.Util (atomicModifyIORef')
24import Control.AutoUpdate.Util (atomicModifyIORef')
36−import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
25+import Control.Concurrent (forkIO, threadDelay)
37import Control.Exception (mask_)
26import Control.Exception (mask_)
27+import Control.Monad (join, void)
38−import Data.IORef (IORef, newIORef, readIORef, writeIORef)
28+import Data.IORef (IORef, newIORef, readIORef)
39
29
40-- | Settings for creating a reaper. This type has two parameters:
30-- | Settings for creating a reaper. This type has two parameters:
41-- @workload@ gives the entire workload, whereas @item@ gives an
31-- @workload@ gives the entire workload, whereas @item@ gives an
@@ -43,52 +33,51 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef)
43-- be a list of @item@s. This is encouraged by 'defaultReaperSettings' and
33-- be a list of @item@s. This is encouraged by 'defaultReaperSettings' and
44-- 'mkListAction'.
34-- 'mkListAction'.
45--
35--
46−-- @since 0.1.1
36+-- Since 0.1.1
47data ReaperSettings workload item = ReaperSettings
37data ReaperSettings workload item = ReaperSettings
48 { reaperAction :: workload -> IO (workload -> workload)
38 { reaperAction :: workload -> IO (workload -> workload)
49 -- ^ The action to perform on a workload. The result of this is a
39 -- ^ The action to perform on a workload. The result of this is a
50 -- \"workload modifying\" function. In the common case of using lists,
40 -- \"workload modifying\" function. In the common case of using lists,
51 -- the result should be a difference list that prepends the remaining
41 -- the result should be a difference list that prepends the remaining
52− -- workload to the temporary workload. The temporary workload here
42+ -- 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'.
43+ -- an action, see 'mkListAction'.
55 --
44 --
56 -- Default: do nothing with the workload, and then prepend it to the
45 -- Default: do nothing with the workload, and then prepend it to the
57 -- temporary workload. This is incredibly useless; you should
46 -- temporary workload. This is incredibly useless; you should
58 -- definitely override this default.
47 -- definitely override this default.
59 --
48 --
60− -- @since 0.1.1
49+ -- Since 0.1.1
61 , reaperDelay :: {-# UNPACK #-} !Int
50 , reaperDelay :: {-# UNPACK #-} !Int
62 -- ^ Number of microseconds to delay between calls of 'reaperAction'.
51 -- ^ Number of microseconds to delay between calls of 'reaperAction'.
63 --
52 --
64 -- Default: 30 seconds.
53 -- Default: 30 seconds.
65 --
54 --
66− -- @since 0.1.1
55+ -- Since 0.1.1
67 , reaperCons :: item -> workload -> workload
56 , reaperCons :: item -> workload -> workload
68 -- ^ Add an item onto a workload.
57 -- ^ Add an item onto a workload.
69 --
58 --
70 -- Default: list consing.
59 -- Default: list consing.
71 --
60 --
72− -- @since 0.1.1
61+ -- Since 0.1.1
73 , reaperNull :: workload -> Bool
62 , reaperNull :: workload -> Bool
74 -- ^ Check if a workload is empty, in which case the worker thread
63 -- ^ Check if a workload is empty, in which case the worker thread
75 -- will shut down.
64 -- will shut down.
76 --
65 --
77 -- Default: 'null'.
66 -- Default: 'null'.
78 --
67 --
79− -- @since 0.1.1
68+ -- Since 0.1.1
80 , reaperEmpty :: workload
69 , reaperEmpty :: workload
81 -- ^ An empty workload.
70 -- ^ An empty workload.
82 --
71 --
83 -- Default: empty list.
72 -- Default: empty list.
84 --
73 --
85− -- @since 0.1.1
74+ -- Since 0.1.1
86 }
75 }
87
76
88-- | Default @ReaperSettings@ value, biased towards having a list of work
77-- | Default @ReaperSettings@ value, biased towards having a list of work
89-- items.
78-- items.
90--
79--
91−-- @since 0.1.1
80+-- Since 0.1.1
92defaultReaperSettings :: ReaperSettings [item] item
81defaultReaperSettings :: ReaperSettings [item] item
93defaultReaperSettings = ReaperSettings
82defaultReaperSettings = ReaperSettings
94 { reaperAction = \wl -> return (wl ++)
83 { reaperAction = \wl -> return (wl ++)
@@ -107,28 +96,24 @@ data Reaper workload item = Reaper {
107 -- | Stopping the reaper thread if exists.
96 -- | Stopping the reaper thread if exists.
108 -- The current workload is returned.
97 -- The current workload is returned.
109 , reaperStop :: IO workload
98 , reaperStop :: IO workload
110− -- | Killing the reaper thread immediately if exists.
111− , reaperKill :: IO ()
112 }
99 }
113
100
114-- | State of reaper.
101-- | State of reaper.
115data State workload = NoReaper -- ^ No reaper thread
102data State workload = NoReaper -- ^ No reaper thread
116− | Workload !workload -- ^ The current jobs
103+ | Workload workload -- ^ The current jobs
117
104
118−-- | Create a reaper addition function. This function can be used to add
105+-- | Create a reaper addition function. This funciton can be used to add
119-- new items to the workload. Spawning of reaper threads will be handled
106-- new items to the workload. Spawning of reaper threads will be handled
120-- for you automatically.
107-- for you automatically.
121--
108--
122−-- @since 0.1.1
109+-- Since 0.1.1
123mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)
110mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)
124mkReaper settings@ReaperSettings{..} = do
111mkReaper settings@ReaperSettings{..} = do
125 stateRef <- newIORef NoReaper
112 stateRef <- newIORef NoReaper
126− tidRef <- newIORef Nothing
127 return Reaper {
113 return Reaper {
128− reaperAdd = add settings stateRef tidRef
114+ reaperAdd = update settings stateRef
129 , reaperRead = readRef stateRef
115 , reaperRead = readRef stateRef
130 , reaperStop = stop stateRef
116 , reaperStop = stop stateRef
131− , reaperKill = kill tidRef
132 }
117 }
133 where
118 where
134 readRef stateRef = do
119 readRef stateRef = do
@@ -140,46 +125,31 @@ mkReaper settings@ReaperSettings{..} = do
140 case mx of
125 case mx of
141 NoReaper -> (NoReaper, reaperEmpty)
126 NoReaper -> (NoReaper, reaperEmpty)
142 Workload x -> (Workload reaperEmpty, x)
127 Workload x -> (Workload reaperEmpty, x)
143− kill tidRef = do
144− mtid <- readIORef tidRef
145− case mtid of
146− Nothing -> return ()
147− Just tid -> killThread tid
148
128
149−add :: ReaperSettings workload item
129+update :: ReaperSettings workload item -> IORef (State workload) -> item
150− -> IORef (State workload) -> IORef (Maybe ThreadId)
151− -> item -> IO ()
130+ -> IO ()
152−add settings@ReaperSettings{..} stateRef tidRef item =
131+update settings@ReaperSettings{..} stateRef item =
153− mask_ $ do
154− next <- atomicModifyIORef' stateRef cons
132+ mask_ $ join $ atomicModifyIORef' stateRef cons
155− next
156 where
133 where
157− cons NoReaper = let wl = reaperCons item reaperEmpty
134+ cons NoReaper = (Workload $ reaperCons item reaperEmpty
158− in (Workload wl, spawn settings stateRef tidRef)
135+ ,spawn settings stateRef)
159− cons (Workload wl) = let wl' = reaperCons item wl
136+ cons (Workload wl) = (Workload $ reaperCons item wl
160− in (Workload wl', return ())
137+ ,return ())
161
138
162−spawn :: ReaperSettings workload item
139+spawn :: ReaperSettings workload item -> IORef (State workload) -> IO ()
163− -> IORef (State workload) -> IORef (Maybe ThreadId)
164− -> IO ()
165−spawn settings stateRef tidRef = do
166− tid <- forkIO $ reaper settings stateRef tidRef
140+spawn settings stateRef = void . forkIO $ reaper settings stateRef
167− writeIORef tidRef $ Just tid
168
141
169−reaper :: ReaperSettings workload item
142+reaper :: ReaperSettings workload item -> IORef (State workload) -> IO ()
170− -> IORef (State workload) -> IORef (Maybe ThreadId)
171− -> IO ()
172−reaper settings@ReaperSettings{..} stateRef tidRef = do
143+reaper settings@ReaperSettings{..} stateRef = do
173 threadDelay reaperDelay
144 threadDelay reaperDelay
174 -- Getting the current jobs. Push an empty job to the reference.
145 -- Getting the current jobs. Push an empty job to the reference.
175 wl <- atomicModifyIORef' stateRef swapWithEmpty
146 wl <- atomicModifyIORef' stateRef swapWithEmpty
176 -- Do the jobs. A function to merge the left jobs and
147 -- Do the jobs. A function to merge the left jobs and
177 -- new jobs is returned.
148 -- new jobs is returned.
178− !merge <- reaperAction wl
149+ merge <- reaperAction wl
179 -- Merging the left jobs and new jobs.
150 -- Merging the left jobs and new jobs.
180 -- If there is no jobs, this thread finishes.
151 -- If there is no jobs, this thread finishes.
181− next <- atomicModifyIORef' stateRef (check merge)
152+ join $ atomicModifyIORef' stateRef (check merge)
182− next
183 where
153 where
184 swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)"
154 swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)"
185 swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl)
155 swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl)
@@ -187,9 +157,9 @@ reaper settings@ReaperSettings{..} stateRef tidRef = do
187 check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"
157 check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"
188 check merge (Workload wl)
158 check merge (Workload wl)
189 -- If there is no job, reaper is terminated.
159 -- If there is no job, reaper is terminated.
190− | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing)
160+ | reaperNull wl' = (NoReaper, return ())
191 -- If there are jobs, carry them out.
161 -- If there are jobs, carry them out.
192− | otherwise = (Workload wl', reaper settings stateRef tidRef)
162+ | otherwise = (Workload wl', reaper settings stateRef)
193 where
163 where
194 wl' = merge wl
164 wl' = merge wl
195
165
@@ -198,83 +168,18 @@ reaper settings@ReaperSettings{..} stateRef tidRef = do
198-- return either a new work item, or @Nothing@ if the work item is
168-- return either a new work item, or @Nothing@ if the work item is
199-- expired.
169-- expired.
200--
170--
201−-- @since 0.1.1
171+-- Since 0.1.1
202mkListAction :: (item -> IO (Maybe item'))
172mkListAction :: (item -> IO (Maybe item'))
203 -> [item]
173 -> [item]
204 -> IO ([item'] -> [item'])
174 -> IO ([item'] -> [item'])
205mkListAction f =
175mkListAction f =
206 go id
176 go id
207 where
177 where
208− go !front [] = return front
178+ go front [] = return front
209− go !front (x:xs) = do
179+ go front (x:xs) = do
210 my <- f x
180 my <- f x
211 let front' =
181 let front' =
212 case my of
182 case my of
213 Nothing -> front
183 Nothing -> front
214 Just y -> front . (y:)
184 Just y -> front . (y:)
215 go front' xs
185 go front' xs
216−
217−-- $example1
218−-- In this example code, we use a 'Data.Map.Strict.Map' to cache fibonacci numbers, and a 'Reaper' to prune the cache.
219−--
220−-- The @main@ function first creates a 'Reaper', with fields to initialize the
221−-- cache ('reaperEmpty'), add items to it ('reaperCons'), and prune it ('reaperAction').
222−-- The reaper will run every two seconds ('reaperDelay'), but will stop running while
223−-- 'reaperNull' is true.
224−--
225−-- @main@ then loops infinitely ('Control.Monad.forever'). Each second it calculates the fibonacci number
226−-- for a value between 30 and 34, first trying the cache ('reaperRead' and 'Data.Map.Strict.lookup'),
227−-- then falling back to manually calculating it (@fib@)
228−-- and updating the cache with the result ('reaperAdd')
229−--
230−-- @clean@ simply removes items cached for more than 10 seconds.
231−-- This function is where you would perform IO-related cleanup,
232−-- like killing threads or closing connections, if that was the purpose of your reaper.
233−--
234−-- @
235−-- module Main where
236−--
237−-- import "Data.Time" (UTCTime, getCurrentTime, diffUTCTime)
238−-- import "Control.Reaper"
239−-- import "Control.Concurrent" (threadDelay)
240−-- import "Data.Map.Strict" (Map)
241−-- import qualified "Data.Map.Strict" as Map
242−-- import "Control.Monad" (forever)
243−-- import "System.Random" (getStdRandom, randomR)
244−--
245−-- fib :: 'Int' -> 'Int'
246−-- fib 0 = 0
247−-- fib 1 = 1
248−-- fib n = fib (n-1) + fib (n-2)
249−--
250−-- type Cache = 'Data.Map.Strict.Map' 'Int' ('Int', 'Data.Time.Clock.UTCTime')
251−--
252−-- main :: IO ()
253−-- main = do
254−-- reaper <- 'mkReaper' 'defaultReaperSettings'
255−-- { 'reaperEmpty' = Map.'Data.Map.Strict.empty'
256−-- , 'reaperCons' = \\(k, v, time) workload -> Map.'Data.Map.Strict.insert' k (v, time) workload
257−-- , 'reaperAction' = clean
258−-- , 'reaperDelay' = 1000000 * 2 -- Clean every 2 seconds
259−-- , 'reaperNull' = Map.'Data.Map.Strict.null'
260−-- }
261−-- forever $ do
262−-- fibArg <- 'System.Random.getStdRandom' ('System.Random.randomR' (30,34))
263−-- cache <- 'reaperRead' reaper
264−-- let cachedResult = Map.'Data.Map.Strict.lookup' fibArg cache
265−-- case cachedResult of
266−-- 'Just' (fibResult, _createdAt) -> 'putStrLn' $ "Found in cache: `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult
267−-- 'Nothing' -> do
268−-- let fibResult = fib fibArg
269−-- 'putStrLn' $ "Calculating `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult
270−-- time <- 'Data.Time.Clock.getCurrentTime'
271−-- ('reaperAdd' reaper) (fibArg, fibResult, time)
272−-- 'threadDelay' 1000000 -- 1 second
273−--
274−-- -- Remove items > 10 seconds old
275−-- clean :: Cache -> IO (Cache -> Cache)
276−-- clean oldMap = do
277−-- currentTime <- 'Data.Time.Clock.getCurrentTime'
278−-- let pruned = Map.'Data.Map.Strict.filter' (\\(_, createdAt) -> currentTime \`diffUTCTime\` createdAt < 10.0) oldMap
279−-- return (\\newData -> Map.'Data.Map.Strict.union' pruned newData)
280−-- @
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.2.1
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
mime-types/ChangeLog.md−12
@@ -1,15 +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
10−
11−* Add support for .less files [#534](https://github.com/yesodweb/wai/pull/534)
12−
13## 0.1.0.6
1## 0.1.0.6
14
2
15* Add woff2 mime type [#350](https://github.com/yesodweb/wai/pull/350)
3* Add woff2 mime type [#350](https://github.com/yesodweb/wai/pull/350)
mime-types/Network/Mime.hs−7
@@ -468,11 +468,6 @@ defaultMimeMap = Map.fromAscList [
468 , ("lbd", "application/vnd.llamagraphics.life-balance.desktop")
468 , ("lbd", "application/vnd.llamagraphics.life-balance.desktop")
469 , ("lbe", "application/vnd.llamagraphics.life-balance.exchange+xml")
469 , ("lbe", "application/vnd.llamagraphics.life-balance.exchange+xml")
470 , ("les", "application/vnd.hhe.lesson-player")
470 , ("les", "application/vnd.hhe.lesson-player")
471−
472− -- Added after deliberation in PR (https://github.com/yesodweb/wai/pull/534)
473− -- Accepted mainly because of StackOverflow (http://stackoverflow.com/questions/7319555/how-to-add-less-to-iis-7-0)
474− , ("less", "text/css")
475−
476 , ("lha", "application/x-lzh-compressed")
471 , ("lha", "application/x-lzh-compressed")
477 , ("link66", "application/vnd.route66.link66+xml")
472 , ("link66", "application/vnd.route66.link66+xml")
478 , ("list", "text/plain")
473 , ("list", "text/plain")
@@ -531,7 +526,6 @@ defaultMimeMap = Map.fromAscList [
531 , ("mime", "message/rfc822")
526 , ("mime", "message/rfc822")
532 , ("mj2", "video/mj2")
527 , ("mj2", "video/mj2")
533 , ("mjp2", "video/mj2")
528 , ("mjp2", "video/mj2")
534− , ("mjs", "application/javascript")
535 , ("mk3d", "video/x-matroska")
529 , ("mk3d", "video/x-matroska")
536 , ("mka", "audio/x-matroska")
530 , ("mka", "audio/x-matroska")
537 , ("mks", "video/x-matroska")
531 , ("mks", "video/x-matroska")
@@ -980,7 +974,6 @@ defaultMimeMap = Map.fromAscList [
980 , ("w3d", "application/x-director")
974 , ("w3d", "application/x-director")
981 , ("wad", "application/x-doom")
975 , ("wad", "application/x-doom")
982 , ("war", "application/java-archive")
976 , ("war", "application/java-archive")
983− , ("wasm", "application/wasm")
984 , ("wav", "audio/x-wav")
977 , ("wav", "audio/x-wav")
985 , ("wax", "audio/x-ms-wax")
978 , ("wax", "audio/x-ms-wax")
986 , ("wbmp", "image/vnd.wap.wbmp")
979 , ("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.6
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+7−16
@@ -1,25 +1,16 @@
1−resolver: lts-14.22
1+resolver: lts-2.9
2packages:
2packages:
3−- ./auto-update
4−- ./mime-types
5- ./wai
3- ./wai
6- ./wai-extra
4- ./wai-extra
7- ./warp
5- ./warp
8- ./warp-tls
6- ./warp-tls
9- ./wai-app-static
7- ./wai-app-static
8+- ./wai-handler-fastcgi
9+- ./wai-handler-launch
10- ./wai-websockets
10- ./wai-websockets
11- ./wai-conduit
11- ./wai-conduit
12−- ./time-manager
12+- ./mime-types
13−flags:
13+- ./auto-update
14− wai-extra:
15− build-example: true
16−nix:
17− enable: false
18− packages:
19− - fcgi
20− - zlib
21extra-deps:
14extra-deps:
22−- http2-2.0.0
15+- fast-logger-2.3.1
23−- network-byte-order-0.1.1.0
16+- wai-logger-2.2.4
24−- tls-1.5.3
25−- tls-session-manager-0.0.4
time-manager/time-manager.cabaldeleted−19
@@ -1,19 +0,0 @@
1−Name: time-manager
2−Version: 0.0.0
3−Synopsis: Scalable timer
4−License: MIT
5−License-file: LICENSE
6−Author: Michael Snoyman and Kazu Yamamoto
7−Maintainer: kazu@iij.ad.jp
8−Homepage: http://github.com/yesodweb/wai
9−Category: System
10−Build-Type: Simple
11−Cabal-Version: >=1.8
12−Stability: Stable
13−Description: Scalable timer functions provided by a timer manager.
14−
15−Library
16− Build-Depends: base >= 4.8 && < 5
17− , auto-update
18− Exposed-modules: System.TimeManager
19− Ghc-Options: -Wall
wai-app-static/ChangeLog.md−53
@@ -1,56 +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
22−
23−* Add `<>` import
24−
25−## 3.1.6
26−
27−* Make ssAddTrailingSlash work in combination with ssIndices [#569](https://github.com/yesodweb/wai/pull/569)
28−* Make ssIndices work with ssLookupFile and trailing slashes [#570](https://github.com/yesodweb/wai/pull/570)
29−
30−## 3.1.5
31−
32−* Switch to cryponite
33−
34−## 3.1.4.1
35−
36−* Support wai/warp 3.2
37−
38−## 3.1.4
39−
40−* Reinstate redirectToIndex
41−
42−## 3.1.3
43−
44−* Add 404 handler [#467](https://github.com/yesodweb/wai/pull/467)
45−
46−## 3.1.2
47−
48−* Honor ssIndices when used with defaultWebAppSettings [#460](https://github.com/yesodweb/wai/pull/460)
49−
50−## 3.1.1
51−
52−* Make adding a trailing slash optional [#327](https://github.com/yesodweb/wai/issues/327) [yesod#988](https://github.com/yesodweb/yesod/issues/988)
53−
54## 3.1.0
1## 3.1.0
55
2
56* Drop system-filepath
3* Drop system-filepath
wai-app-static/Network/Wai/Application/Static.hs+65−82
@@ -21,8 +21,6 @@ module Network.Wai.Application.Static
21 , ssIndices
21 , ssIndices
22 , ssMaxAge
22 , ssMaxAge
23 , ssRedirectToIndex
23 , ssRedirectToIndex
24− , ssAddTrailingSlash
25− , ss404Handler
26 ) where
24 ) where
27
25
28import Prelude hiding (FilePath)
26import Prelude hiding (FilePath)
@@ -34,15 +32,16 @@ import qualified Data.ByteString.Lazy as L
34import Data.ByteString.Lazy.Char8 ()
32import Data.ByteString.Lazy.Char8 ()
35import Control.Monad.IO.Class (liftIO)
33import Control.Monad.IO.Class (liftIO)
36
34
37−import Data.ByteString.Builder (toLazyByteString)
35+import Blaze.ByteString.Builder (toByteString)
38
36
39import Data.FileEmbed (embedFile)
37import Data.FileEmbed (embedFile)
40
38
41import Data.Text (Text)
39import Data.Text (Text)
42import qualified Data.Text as T
40import qualified Data.Text as T
43−import qualified Data.Text.Encoding as TE
44
41
42+import Data.Either (rights)
45import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
43import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
44+import Data.Monoid (First (First, getFirst), mconcat)
46
45
47import WaiAppStatic.Types
46import WaiAppStatic.Types
48import Util
47import Util
@@ -74,27 +73,55 @@ filterButLast f (x:xs)
74
73
75-- | Serve an appropriate response for a folder request.
74-- | Serve an appropriate response for a folder request.
76serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse
75serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse
77−serveFolder StaticSettings {..} pieces req folder@Folder {..} =
76+serveFolder ss@StaticSettings {..} pieces req folder@Folder {..} =
77+ -- first check if there is an index file in this folder
78+ case getFirst $ mconcat $ map (findIndex $ rights folderContents) ssIndices of
79+ Just index ->
80+ let pieces' = setLast pieces index in
81+ case () of
82+ () | ssRedirectToIndex -> return $ Redirect pieces' Nothing
83+ | Just path <- addTrailingSlash req ->
84+ return $ RawRedirect path
85+ | otherwise ->
86+ -- start the checking process over, with a new set
87+ checkPieces ss pieces' req
88+ Nothing ->
78− case ssListing of
89+ case ssListing of
79− Just _ | Just path <- addTrailingSlash req, ssAddTrailingSlash ->
90+ Just _ | Just path <- addTrailingSlash req ->
80− return $ RawRedirect path
91+ return $ RawRedirect path
81− Just listing -> do
92+ Just listing -> do
82− -- directory listings turned on, display it
93+ -- directory listings turned on, display it
83− builder <- listing pieces folder
94+ builder <- listing pieces folder
84− return $ WaiResponse $ W.responseBuilder H.status200
95+ return $ WaiResponse $ W.responseBuilder H.status200
85− [ ("Content-Type", "text/html; charset=utf-8")
96+ [ ("Content-Type", "text/html; charset=utf-8")
86− ] builder
97+ ] builder
87− Nothing -> return $ WaiResponse $ W.responseLBS H.status403
98+ Nothing -> return $ WaiResponse $ W.responseLBS H.status403
88− [ ("Content-Type", "text/plain")
99+ [ ("Content-Type", "text/plain")
89− ] "Directory listings disabled"
100+ ] "Directory listings disabled"
90−
91−addTrailingSlash :: W.Request -> Maybe ByteString
92−addTrailingSlash req
93− | S8.null rp = Just "/"
94− | S8.last rp == '/' = Nothing
95− | otherwise = Just $ S8.snoc rp '/'
96 where
101 where
102+ setLast :: Pieces -> Piece -> Pieces
103+ setLast [] x = [x]
104+ setLast [t] x
105+ | fromPiece t == "" = [x]
106+ setLast (a:b) x = a : setLast b x
107+
108+ addTrailingSlash :: W.Request -> Maybe ByteString
109+ addTrailingSlash req
110+ | S8.null rp = Just "/"
111+ | S8.last rp == '/' = Nothing
112+ | otherwise = Just $ S8.snoc rp '/'
113+ where
97− rp = W.rawPathInfo req
114+ rp = W.rawPathInfo req
115+
116+ noTrailingSlash :: Pieces -> Bool
117+ noTrailingSlash [] = False
118+ noTrailingSlash [x] = fromPiece x /= ""
119+ noTrailingSlash (_:xs) = noTrailingSlash xs
120+
121+ findIndex :: [File] -> Piece -> First Piece
122+ findIndex files index
123+ | index `elem` map fileName files = First $ Just index
124+ | otherwise = First Nothing
98
125
99checkPieces :: StaticSettings
126checkPieces :: StaticSettings
100 -> Pieces -- ^ parsed request
127 -> Pieces -- ^ parsed request
@@ -106,51 +133,11 @@ checkPieces _ pieces _ | any (T.null . fromPiece) $ safeInit pieces =
106 return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing
133 return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing
107
134
108checkPieces ss@StaticSettings {..} pieces req = do
135checkPieces ss@StaticSettings {..} pieces req = do
109− res <- lookupResult
136+ res <- ssLookupFile pieces
110 case res of
137 case res of
111− Left location -> return $ RawRedirect location
112− Right LRNotFound -> return NotFound
138+ LRNotFound -> return NotFound
113− Right (LRFile file) -> serveFile ss req file
139+ LRFile file -> serveFile ss req file
114− Right (LRFolder folder) -> serveFolder ss pieces req folder
140+ LRFolder folder -> serveFolder ss pieces req folder
115− where
116− lookupResult :: IO (Either ByteString LookupResult)
117− lookupResult = do
118− nonIndexResult <- ssLookupFile pieces
119− case nonIndexResult of
120− LRFile{} -> return $ Right nonIndexResult
121− _ -> do
122− eIndexResult <- lookupIndices (map (\ index -> dropLastIfNull pieces ++ [index]) ssIndices)
123− return $ case eIndexResult of
124− Left redirect -> Left redirect
125− Right indexResult -> case indexResult of
126− LRNotFound -> Right nonIndexResult
127− LRFile file | ssRedirectToIndex ->
128− let relPath =
129− case reverse pieces of
130− -- Served at root
131− [] -> fromPiece $ fileName file
132− lastSegment:_ ->
133− case fromPiece lastSegment of
134− -- Ends with a trailing slash
135− "" -> fromPiece $ fileName file
136− -- Lacks a trailing slash
137− lastSegment' -> T.concat
138− [ lastSegment'
139− , "/"
140− , fromPiece $ fileName file
141− ]
142− in Left $ TE.encodeUtf8 relPath
143− _ -> Right indexResult
144−
145− lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult)
146− lookupIndices (x : xs) = do
147− res <- ssLookupFile x
148− case res of
149− LRNotFound -> lookupIndices xs
150− _ -> return $ case (ssAddTrailingSlash, addTrailingSlash req) of
151− (True, Just redirect) -> Left redirect
152− _ -> Right res
153− lookupIndices [] = return $ Right LRNotFound
154
141
155serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse
142serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse
156serveFile StaticSettings {..} req file
143serveFile StaticSettings {..} req file
@@ -164,13 +151,11 @@ serveFile StaticSettings {..} req file
164 -- Didn't match, but we have a hash value. Send the file contents
151 -- Didn't match, but we have a hash value. Send the file contents
165 -- with an ETag header.
152 -- with an ETag header.
166 --
153 --
167− -- RFC7232 (HTTP 1.1):
154+ -- Note: It would be arguably better to next check
168− -- > A recipient MUST ignore If-Modified-Since if the request contains an
155+ -- 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
156+ -- well. However, the circumstances under which such a situation
170− -- > considered to be a more accurate replacement for the condition in
157+ -- 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
158+ -- new file being sent anyway.
172− -- > interoperating with older intermediaries that might not implement
173− -- > If-None-Match.
174 (Just hash, _) -> respond [("ETag", hash)]
159 (Just hash, _) -> respond [("ETag", hash)]
175
160
176 -- No hash value available, fall back to last modified support.
161 -- No hash value available, fall back to last modified support.
@@ -245,7 +230,7 @@ staticAppPieces ss rawPieces req sendResponse = liftIO $ do
245 response :: StaticResponse -> IO W.ResponseReceived
230 response :: StaticResponse -> IO W.ResponseReceived
246 response (FileResponse file ch) = do
231 response (FileResponse file ch) = do
247 mimetype <- ssGetMimeType ss file
232 mimetype <- ssGetMimeType ss file
248− -- let filesize = fileGetSize file
233+ let filesize = fileGetSize file
249 let headers = ("Content-Type", mimetype)
234 let headers = ("Content-Type", mimetype)
250 -- Let Warp provide the content-length, since it takes
235 -- Let Warp provide the content-length, since it takes
251 -- range requests into account
236 -- range requests into account
@@ -264,25 +249,23 @@ staticAppPieces ss rawPieces req sendResponse = liftIO $ do
264 ] lbs
249 ] lbs
265
250
266 response (Redirect pieces' mHash) = do
251 response (Redirect pieces' mHash) = do
267− let loc = ssMkRedirect ss pieces' $ L.toStrict $ toLazyByteString (H.encodePathSegments $ map fromPiece pieces')
252+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map fromPiece pieces')
268 let qString = case mHash of
253 let qString = case mHash of
269 Just hash -> replace "etag" (Just hash) (W.queryString req)
254 Just hash -> replace "etag" (Just hash) (W.queryString req)
270 Nothing -> remove "etag" (W.queryString req)
255 Nothing -> remove "etag" (W.queryString req)
271
256
272− sendResponse $ W.responseLBS H.status302
257+ sendResponse $ W.responseLBS H.status301
273 [ ("Content-Type", "text/plain")
258 [ ("Content-Type", "text/plain")
274 , ("Location", S8.append loc $ H.renderQuery True qString)
259 , ("Location", S8.append loc $ H.renderQuery True qString)
275 ] "Redirect"
260 ] "Redirect"
276
261
277 response (RawRedirect path) =
262 response (RawRedirect path) =
278− sendResponse $ W.responseLBS H.status302
263+ sendResponse $ W.responseLBS H.status301
279 [ ("Content-Type", "text/plain")
264 [ ("Content-Type", "text/plain")
280 , ("Location", path)
265 , ("Location", path)
281 ] "Redirect"
266 ] "Redirect"
282
267
283− response NotFound = case (ss404Handler ss) of
284− Just app -> app req sendResponse
285− Nothing -> sendResponse $ W.responseLBS H.status404
268+ response NotFound = sendResponse $ W.responseLBS H.status404
286 [ ("Content-Type", "text/plain")
269 [ ("Content-Type", "text/plain")
287 ] "File not found"
270 ] "File not found"
288
271
wai-app-static/Util.hs+1−8
@@ -1,10 +1,9 @@
1−{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
1+{-# LANGUAGE OverloadedStrings #-}
2module Util
2module Util
3 ( relativeDirFromPieces
3 ( relativeDirFromPieces
4 , defaultMkRedirect
4 , defaultMkRedirect
5 , replace
5 , replace
6 , remove
6 , remove
7− , dropLastIfNull
8 ) where
7 ) where
9
8
10import WaiAppStatic.Types
9import WaiAppStatic.Types
@@ -37,9 +36,3 @@ defaultMkRedirect pieces newPath
37 | otherwise = relDir `S8.append` S8.tail newPath
36 | otherwise = relDir `S8.append` S8.tail newPath
38 where
37 where
39 relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
38 relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
40−
41−dropLastIfNull :: [Piece] -> [Piece]
42−dropLastIfNull pieces = case pieces of
43− [fromPiece -> ""] -> []
44− (a : r) -> a : dropLastIfNull r
45− [] -> []
wai-app-static/WaiAppStatic/CmdLine.hs+6−15
@@ -8,7 +8,7 @@ module WaiAppStatic.CmdLine
8import Network.Wai (Middleware)
8import Network.Wai (Middleware)
9import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
9import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
10import Network.Wai.Handler.Warp
10import Network.Wai.Handler.Warp
11− ( runSettings, defaultSettings, setHost, setPort
11+ ( runSettings, defaultSettings, settingsHost, settingsPort
12 )
12 )
13import Options.Applicative
13import Options.Applicative
14import Text.Printf (printf)
14import Text.Printf (printf)
@@ -25,7 +25,6 @@ import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType)
25import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)
25import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)
26import Data.Maybe (mapMaybe)
26import Data.Maybe (mapMaybe)
27import Control.Arrow (second)
27import Control.Arrow (second)
28−import Data.Monoid ((<>))
29
28
30data Args = Args
29data Args = Args
31 { docroot :: FilePath
30 { docroot :: FilePath
@@ -39,7 +38,6 @@ data Args = Args
39 }
38 }
40
39
41#if MIN_VERSION_optparse_applicative(0, 10, 0)
40#if MIN_VERSION_optparse_applicative(0, 10, 0)
42−option' :: Mod OptionFields Int -> Parser Int
43option' = option auto
41option' = option auto
44#else
42#else
45option' = option
43option' = option
@@ -94,7 +92,7 @@ args = Args
94-- Since 2.0.1
92-- Since 2.0.1
95runCommandLine :: (Args -> Middleware) -> IO ()
93runCommandLine :: (Args -> Middleware) -> IO ()
96runCommandLine middleware = do
94runCommandLine middleware = do
97− args@Args {..} <- execParser $ info (helperOption <*> args) fullDesc
95+ args@Args {..} <- execParser $ info (helper <*> args) fullDesc
98 let mime' = map (pack *** S8.pack) mime
96 let mime' = map (pack *** S8.pack) mime
99 let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap
97 let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap
100 docroot' <- canonicalizePath docroot
98 docroot' <- canonicalizePath docroot
@@ -102,17 +100,10 @@ runCommandLine middleware = do
102 let middle = gzip def { gzipFiles = GzipCompress }
100 let middle = gzip def { gzipFiles = GzipCompress }
103 . (if verbose then logStdout else id)
101 . (if verbose then logStdout else id)
104 . (middleware args)
102 . (middleware args)
105− runSettings
103+ runSettings defaultSettings
106− ( setPort port
104+ { settingsPort = port
107− $ setHost (fromString host)
105+ , settingsHost = fromString host
108− defaultSettings
109− )
110− $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)
106+ } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)
111 { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
107 { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
112 , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
108 , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
113 }
109 }
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+14−28
@@ -22,7 +22,7 @@ import qualified Text.Blaze.Html.Renderer.Utf8 as HU
22
22
23-- | Provides a default directory listing, suitable for most apps.
23-- | Provides a default directory listing, suitable for most apps.
24--
24--
25−-- Code below taken from Happstack: <https://github.com/Happstack/happstack-server/blob/87e6c01a65c687d06c61345430a112fc9a444a95/src/Happstack/Server/FileServe/BuildingBlocks.hs>
25+-- Code below taken from Happstack: <http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs>
26defaultListing :: Listing
26defaultListing :: Listing
27defaultListing pieces (Folder contents) = do
27defaultListing pieces (Folder contents) = do
28 let isTop = null pieces || map Just pieces == [toPiece ""]
28 let isTop = null pieces || map Just pieces == [toPiece ""]
@@ -49,12 +49,8 @@ defaultListing pieces (Folder contents) = do
49 , "a { text-decoration: none }"
49 , "a { text-decoration: none }"
50 ]
50 ]
51 H.body $ do
51 H.body $ do
52− let hasTrailingSlash =
53− case map fromPiece $ reverse $ pieces of
54− "":_ -> True
55− _ -> False
56− H.h1 $ showFolder' hasTrailingSlash $ filter (not . T.null . fromPiece) pieces
52+ H.h1 $ showFolder' $ filter (not . T.null . fromPiece) pieces
57− renderDirectoryContentsTable (map fromPiece pieces) haskellSrc folderSrc fps''
53+ renderDirectoryContentsTable haskellSrc folderSrc fps''
58 where
54 where
59 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
55 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
60 folderSrc = image "folder"
56 folderSrc = image "folder"
@@ -63,20 +59,17 @@ defaultListing pieces (Folder contents) = do
63 showName x = x
59 showName x = x
64
60
65 -- Add a link to the root of the tree
61 -- Add a link to the root of the tree
66− showFolder' :: Bool -> Pieces -> H.Html
62+ showFolder' :: Pieces -> H.Html
67− showFolder' hasTrailingSlash pieces' = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces')
63+ showFolder' pieces = showFolder (unsafeToPiece "root" : pieces)
68
64
69− showFolder :: Bool -> Pieces -> H.Html
65+ showFolder :: Pieces -> H.Html
70− showFolder _ [] = "/" -- won't happen
66+ showFolder [] = "/" -- won't happen
71− showFolder _ [x] = H.toHtml $ showName $ fromPiece x
67+ showFolder [x] = H.toHtml $ showName $ fromPiece x
72− showFolder hasTrailingSlash (x:xs) = do
68+ showFolder (x:xs) = do
73− let len = length xs - (if hasTrailingSlash then 0 else 1)
74− href
75− | len == 0 = "."
76− | otherwise = concat $ replicate len "../" :: String
69+ let href = concat $ replicate (length xs) "../" :: String
77 H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x
70 H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x
78 " / " :: H.Html
71 " / " :: H.Html
79− showFolder hasTrailingSlash xs
72+ showFolder xs
80
73
81-- | a function to generate an HTML table showing the contents of a directory on the disk
74-- | a function to generate an HTML table showing the contents of a directory on the disk
82--
75--
@@ -86,12 +79,11 @@ defaultListing pieces (Folder contents) = do
86-- a new page template to wrap around this HTML.
79-- a new page template to wrap around this HTML.
87--
80--
88-- see also: 'getMetaData', 'renderDirectoryContents'
81-- see also: 'getMetaData', 'renderDirectoryContents'
89−renderDirectoryContentsTable :: [T.Text] -- ^ requested path info
82+renderDirectoryContentsTable :: String
90− -> String
91 -> String
83 -> String
92 -> [Either FolderName File]
84 -> [Either FolderName File]
93 -> H.Html
85 -> H.Html
94−renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps =
86+renderDirectoryContentsTable haskellSrc folderSrc fps =
95 H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
87 H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
96 H.th "Name"
88 H.th "Name"
97 H.th "Modified"
89 H.th "Modified"
@@ -118,13 +110,7 @@ renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps =
118 (fromPiece -> "") -> unsafeToPiece ".."
110 (fromPiece -> "") -> unsafeToPiece ".."
119 x -> x
111 x -> x
120 let isFile = either (const False) (const True) md
112 let isFile = either (const False) (const True) md
121− href = addCurrentDir $ fromPiece name
122− addCurrentDir x =
123− case reverse pathInfo' of
124− "":_ -> x -- has a trailing slash
125− [] -> x -- at the root
126− currentDir:_ -> T.concat [currentDir, "/", x]
127− H.td (H.a ! A.href (H.toValue href) $ H.toHtml $ fromPiece name)
113+ H.td (H.a ! A.href (H.toValue $ fromPiece name `T.append` if isFile then "" else "/") $ H.toHtml $ fromPiece name)
128 H.td ! A.class_ "date" $ H.toHtml $
114 H.td ! A.class_ "date" $ H.toHtml $
129 case md of
115 case md of
130 Right File { fileGetModified = Just t } ->
116 Right File { fileGetModified = Just t } ->
wai-app-static/WaiAppStatic/Storage/Embedded/Runtime.hs+8−7
@@ -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)
@@ -16,7 +16,8 @@ import qualified Data.Text as T
16import Data.Ord
16import Data.Ord
17import qualified Data.ByteString as S
17import qualified Data.ByteString as S
18import Crypto.Hash (hash, MD5, Digest)
18import Crypto.Hash (hash, MD5, Digest)
19−import Data.ByteArray.Encoding
19+import Data.Byteable (toBytes)
20+import qualified Data.ByteString.Base64 as B64
20import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)
21import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)
21import System.FilePath (isPathSeparator)
22import System.FilePath (isPathSeparator)
22
23
@@ -49,8 +50,8 @@ embeddedLookup root pieces =
49toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File
50toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File
50toEntry (name, EEFolder{}) = Left name
51toEntry (name, EEFolder{}) = Left name
51toEntry (name, EEFile bs) = Right File
52toEntry (name, EEFile bs) = Right File
52− { fileGetSize = fromIntegral $ S.length bs
53+ { fileGetSize = S.length bs
53− , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs
54+ , fileToResponse = \s h -> W.responseBuilder s h $ fromByteString bs
54 , fileName = name
55 , fileName = name
55 , fileGetHash = return $ Just $ runHash bs
56 , fileGetHash = return $ Just $ runHash bs
56 , fileGetModified = Nothing
57 , fileGetModified = Nothing
@@ -86,12 +87,12 @@ toEmbedded fps =
86
87
87bsToFile :: Piece -> ByteString -> File
88bsToFile :: Piece -> ByteString -> File
88bsToFile name bs = File
89bsToFile name bs = File
89− { fileGetSize = fromIntegral $ S.length bs
90+ { fileGetSize = S.length bs
90− , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs
91+ , fileToResponse = \s h -> W.responseBuilder s h $ fromByteString bs
91 , fileName = name
92 , fileName = name
92 , fileGetHash = return $ Just $ runHash bs
93 , fileGetHash = return $ Just $ runHash bs
93 , fileGetModified = Nothing
94 , fileGetModified = Nothing
94 }
95 }
95
96
96runHash :: ByteString -> ByteString
97runHash :: ByteString -> ByteString
97−runHash = convertToBase Base64 . (hash :: S.ByteString -> Digest MD5)
98+runHash = B64.encode . toBytes . (hash :: S.ByteString -> Digest MD5)
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/Storage/Filesystem.hs+7−13
@@ -1,6 +1,5 @@
1{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE BangPatterns #-}
4-- | Access files on the filesystem.
3-- | Access files on the filesystem.
5module WaiAppStatic.Storage.Filesystem
4module WaiAppStatic.Storage.Filesystem
6 ( -- * Types
5 ( -- * Types
@@ -13,7 +12,6 @@ module WaiAppStatic.Storage.Filesystem
13
12
14import WaiAppStatic.Types
13import WaiAppStatic.Types
15import System.FilePath ((</>))
14import System.FilePath ((</>))
16−import System.IO (withBinaryFile, IOMode(..))
17import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
15import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
18import Data.List (foldl')
16import Data.List (foldl')
19import Control.Monad (forM)
17import Control.Monad (forM)
@@ -25,9 +23,10 @@ import WaiAppStatic.Listing
25import Network.Mime
23import Network.Mime
26import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRegularFile)
24import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRegularFile)
27import Data.Maybe (catMaybes)
25import Data.Maybe (catMaybes)
28−import Data.ByteArray.Encoding
26+import qualified Crypto.Hash.Conduit (hashFile)
27+import Data.Byteable (toBytes)
29−import Crypto.Hash (hashlazy, MD5, Digest)
28+import Crypto.Hash (MD5, Digest)
30−import qualified Data.ByteString.Lazy as BL (hGetContents)
29+import qualified Data.ByteString.Base64 as B64
31import qualified Data.Text as T
30import qualified Data.Text as T
32
31
33-- | Construct a new path from a root and some @Pieces@.
32-- | Construct a new path from a root and some @Pieces@.
@@ -47,8 +46,6 @@ defaultWebAppSettings root = StaticSettings
47 , ssIndices = []
46 , ssIndices = []
48 , ssRedirectToIndex = False
47 , ssRedirectToIndex = False
49 , ssUseHash = True
48 , ssUseHash = True
50− , ssAddTrailingSlash = False
51− , ss404Handler = Nothing
52 }
49 }
53
50
54-- | Settings optimized for a file server. More conservative caching will be
51-- | Settings optimized for a file server. More conservative caching will be
@@ -64,8 +61,6 @@ defaultFileServerSettings root = StaticSettings
64 , ssIndices = map unsafeToPiece ["index.html", "index.htm"]
61 , ssIndices = map unsafeToPiece ["index.html", "index.htm"]
65 , ssRedirectToIndex = False
62 , ssRedirectToIndex = False
66 , ssUseHash = False
63 , ssUseHash = False
67− , ssAddTrailingSlash = False
68− , ss404Handler = Nothing
69 }
64 }
70
65
71-- | Same as @defaultWebAppSettings@, but additionally uses a specialized
66-- | Same as @defaultWebAppSettings@, but additionally uses a specialized
@@ -120,10 +115,9 @@ webAppLookup hashFunc prefix pieces =
120-- | MD5 hash and base64-encode the file contents. Does not check if the file
115-- | MD5 hash and base64-encode the file contents. Does not check if the file
121-- exists.
116-- exists.
122hashFile :: FilePath -> IO ByteString
117hashFile :: FilePath -> IO ByteString
123−hashFile fp = withBinaryFile fp ReadMode $ \h -> do
118+hashFile fp = do
124− f <- BL.hGetContents h
119+ h <- Crypto.Hash.Conduit.hashFile fp
125− let !hash = hashlazy f :: Digest MD5
120+ return $ B64.encode $ toBytes (h :: Digest MD5)
126− return $ convertToBase Base64 hash
127
121
128hashFileIfExists :: ETagLookup
122hashFileIfExists :: ETagLookup
129hashFileIfExists fp = do
123hashFileIfExists fp = do
wai-app-static/WaiAppStatic/Types.hs+3−12
@@ -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.
@@ -80,7 +79,7 @@ data Folder = Folder
80-- | Information on an individual file.
79-- | Information on an individual file.
81data File = File
80data File = File
82 { -- | Size of file in bytes
81 { -- | Size of file in bytes
83− fileGetSize :: Integer
82+ fileGetSize :: Int
84 -- | How to construct a WAI response for this file. Some files are stored
83 -- | How to construct a WAI response for this file. Some files are stored
85 -- on the filesystem and can use @ResponseFile@, while others are stored
84 -- on the filesystem and can use @ResponseFile@, while others are stored
86 -- in memory and should use @ResponseBuilder@.
85 -- in memory and should use @ResponseBuilder@.
@@ -142,12 +141,4 @@ data StaticSettings = StaticSettings
142
141
143 -- | Prefer usage of etag caching to last-modified caching.
142 -- | Prefer usage of etag caching to last-modified caching.
144 , ssUseHash :: Bool
143 , ssUseHash :: Bool
145−
146− -- | Force a trailing slash at the end of directories
147− , ssAddTrailingSlash :: Bool
148−
149− -- | Optional `W.Application` to be used in case of 404 errors
150− --
151− -- Since 3.1.3
152− , ss404Handler :: Maybe W.Application
153 }
144 }
wai-app-static/test/EmbeddedTestEntries.hs−10
@@ -42,14 +42,4 @@ mkEntries = return
42 , EmbeddableEntry "e6.txt"
42 , EmbeddableEntry "e6.txt"
43 "text/plain"
43 "text/plain"
44 (Right [| return ("" :: T.Text, body 1000 'W') |] )
44 (Right [| return ("" :: T.Text, body 1000 'W') |] )
45−
46− -- An index file
47− , EmbeddableEntry "index.html"
48− "text/html"
49− (Right [| return ("" :: T.Text, "index file") |] )
50−
51− -- An index file in a subdir
52− , EmbeddableEntry "foo/index.html"
53− "text/html"
54− (Right [| return ("" :: T.Text, "index file in subdir") |] )
55 ]
45 ]
wai-app-static/test/WaiAppEmbeddedTest.hs+5−21
@@ -8,15 +8,16 @@ import Network.Wai.Application.Static (staticApp)
8import Network.Wai.Test
8import Network.Wai.Test
9import Test.Hspec
9import Test.Hspec
10import WaiAppStatic.Storage.Embedded
10import WaiAppStatic.Storage.Embedded
11−import WaiAppStatic.Types
11+
12+embApp :: Application
13+embApp = staticApp $(mkSettings mkEntries)
12
14
13defRequest :: Request
15defRequest :: Request
14defRequest = defaultRequest
16defRequest = defaultRequest
15
17
16embSpec :: Spec
18embSpec :: Spec
17embSpec = do
19embSpec = do
18− let embedSettings settings = flip runSession (staticApp settings)
20+ let embed = flip runSession embApp
19− let embed = embedSettings $(mkSettings mkEntries)
20 describe "embedded, compressed entry" $ do
21 describe "embedded, compressed entry" $ do
21 it "served correctly" $ embed $ do
22 it "served correctly" $ embed $ do
22 req <- request (setRawPathInfo defRequest "e1.txt")
23 req <- request (setRawPathInfo defRequest "e1.txt")
@@ -32,24 +33,6 @@ embSpec = do
32 { requestHeaders = [("If-None-Match", "Etag 1")] }
33 { requestHeaders = [("If-None-Match", "Etag 1")] }
33 assertStatus 304 req
34 assertStatus 304 req
34
35
35− it "ssIndices works" $ do
36− let testSettings = $(mkSettings mkEntries){
37− ssIndices = [unsafeToPiece "index.html"]
38− }
39− embedSettings testSettings $ do
40− req <- request defRequest
41− assertStatus 200 req
42− assertBody "index file" req
43−
44− it "ssIndices works with trailing slashes" $ do
45− let testSettings = $(mkSettings mkEntries){
46− ssIndices = [unsafeToPiece "index.html"]
47− }
48− embedSettings testSettings $ do
49− req <- request (setRawPathInfo defRequest "/foo/")
50− assertStatus 200 req
51− assertBody "index file in subdir" req
52−
53 describe "embedded, uncompressed entry" $ do
36 describe "embedded, uncompressed entry" $ do
54 it "too short" $ embed $ do
37 it "too short" $ embed $ do
55 req <- request (setRawPathInfo defRequest "e2.txt")
38 req <- request (setRawPathInfo defRequest "e2.txt")
@@ -92,3 +75,4 @@ embSpec = do
92 assertNoHeader "Content-Encoding" req
75 assertNoHeader "Content-Encoding" req
93 assertNoHeader "ETag" req
76 assertNoHeader "ETag" req
94 assertBody (body 1000 'W') req
77 assertBody (body 1000 'W') req
78+
wai-app-static/test/WaiAppStaticTest.hs+10−51
@@ -2,15 +2,11 @@
2module WaiAppStaticTest (spec) where
2module WaiAppStaticTest (spec) where
3
3
4import Network.Wai.Application.Static
4import Network.Wai.Application.Static
5−import WaiAppStatic.Types
6
5
7import Test.Hspec
6import Test.Hspec
8−import Test.Mockery.Directory
9import qualified Data.ByteString.Char8 as S8
7import qualified Data.ByteString.Char8 as S8
10-- import qualified Data.ByteString.Lazy.Char8 as L8
8-- import qualified Data.ByteString.Lazy.Char8 as L8
11import System.PosixCompat.Files (getFileStatus, modificationTime)
9import System.PosixCompat.Files (getFileStatus, modificationTime)
12−import System.FilePath
13−import System.IO.Temp
14
10
15import Network.HTTP.Date
11import Network.HTTP.Date
16import Network.HTTP.Types (status500)
12import Network.HTTP.Types (status500)
@@ -29,10 +25,7 @@ defRequest = defaultRequest
29spec :: Spec
25spec :: Spec
30spec = do
26spec = do
31 let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"
27 let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"
32− let fileServerAppWithSettings settings = flip runSession $ staticApp settings
33− let fileServerApp = fileServerAppWithSettings (defaultFileServerSettings "test")
28+ let fileServerApp = flip runSession $ staticApp $ defaultFileServerSettings "test"
34− { ssAddTrailingSlash = True
35− }
36
29
37 let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
30 let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
38 let file = "a/b"
31 let file = "a/b"
@@ -57,22 +50,22 @@ spec = do
57 assertStatus 200 =<<
50 assertStatus 200 =<<
58 request (setRawPathInfo defRequest path)
51 request (setRawPathInfo defRequest path)
59
52
60− it "404 for non-existent files" $ webApp $
53+ it "404 for non-existant files" $ webApp $
61 assertStatus 404 =<<
54 assertStatus 404 =<<
62 request (setRawPathInfo defRequest "doesNotExist")
55 request (setRawPathInfo defRequest "doesNotExist")
63
56
64− it "302 redirect when multiple slashes" $ webApp $ do
57+ it "301 redirect when multiple slashes" $ webApp $ do
65 req <- request (setRawPathInfo defRequest "a//b/c")
58 req <- request (setRawPathInfo defRequest "a//b/c")
66− assertStatus 302 req
59+ assertStatus 301 req
67 assertHeader "Location" "../../a/b/c" req
60 assertHeader "Location" "../../a/b/c" req
68
61
69 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {
62 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {
70 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
63 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
71 }
64 }
72− it "302 redirect when multiple slashes" $ absoluteApp $
65+ it "301 redirect when multiple slashes" $ absoluteApp $
73 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
66 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
74 req <- request (setRawPathInfo defRequest path)
67 req <- request (setRawPathInfo defRequest path)
75− assertStatus 302 req
68+ assertStatus 301 req
76 assertHeader "Location" "http://www.example.com/a/b/c" req
69 assertHeader "Location" "http://www.example.com/a/b/c" req
77
70
78 describe "webApp when requesting a static asset" $ do
71 describe "webApp when requesting a static asset" $ do
@@ -131,54 +124,20 @@ spec = do
131 assertStatus 304 req
124 assertStatus 304 req
132 assertNoHeader "Cache-Control" req
125 assertNoHeader "Cache-Control" req
133
126
134− context "302 redirect to add a trailing slash on directories if missing" $ do
127+ context "301 redirect to add a trailing slash on directories if missing" $ do
135 it "works at the root" $ fileServerApp $ do
128 it "works at the root" $ fileServerApp $ do
136 req <- request (setRawPathInfo defRequest "/a")
129 req <- request (setRawPathInfo defRequest "/a")
137− assertStatus 302 req
130+ assertStatus 301 req
138 assertHeader "Location" "/a/" req
131 assertHeader "Location" "/a/" req
139
132
140− it "works when an index.html is delivered" $ do
141− let settings = (defaultFileServerSettings "."){
142− ssAddTrailingSlash = True
143− }
144− inTempDirectory $ fileServerAppWithSettings settings $ do
145− liftIO $ touch "foo/index.html"
146− req <- request (setRawPathInfo defRequest "/foo")
147− assertStatus 302 req
148− assertHeader "Location" "/foo/" req
149−
150 let urlMapApp = flip runSession $ \req send ->
133 let urlMapApp = flip runSession $ \req send ->
151 case pathInfo req of
134 case pathInfo req of
152 "subPath":rest ->
135 "subPath":rest ->
153 let req' = req { pathInfo = rest }
136 let req' = req { pathInfo = rest }
154− in (staticApp (defaultFileServerSettings "test")
137+ in (staticApp $ defaultFileServerSettings "test") req' send
155− { ssAddTrailingSlash = True
156− }) req' send
157 _ -> send $ responseLBS status500 []
138 _ -> send $ responseLBS status500 []
158 "urlMapApp: only works at subPath"
139 "urlMapApp: only works at subPath"
159 it "works with subpath at the root of the file server" $ urlMapApp $ do
140 it "works with subpath at the root of the file server" $ urlMapApp $ do
160 req <- request (setRawPathInfo defRequest "/subPath")
141 req <- request (setRawPathInfo defRequest "/subPath")
161− assertStatus 302 req
142+ assertStatus 301 req
162 assertHeader "Location" "/subPath/" req
143 assertHeader "Location" "/subPath/" req
163−
164− context "with defaultWebAppSettings" $ do
165− it "ssIndices works" $ do
166− withSystemTempDirectory "wai-app-static-test" $ \ dir -> do
167− writeFile (dir </> "index.html") "foo"
168− let testSettings = (defaultWebAppSettings dir) {
169− ssIndices = [unsafeToPiece "index.html"]
170− }
171− fileServerAppWithSettings testSettings $ do
172− resp <- request (setRawPathInfo defRequest "/")
173− assertStatus 200 resp
174− assertBody "foo" resp
175−
176− context "with defaultFileServerSettings" $ do
177− it "prefers ssIndices over ssListing" $ do
178− withSystemTempDirectory "wai-app-static-test" $ \ dir -> do
179− writeFile (dir </> "index.html") "foo"
180− let testSettings = defaultFileServerSettings dir
181− fileServerAppWithSettings testSettings $ do
182− resp <- request (setRawPathInfo defRequest "/")
183− assertStatus 200 resp
184− assertBody "foo" resp
wai-app-static/wai-app-static.cabal+12−11
@@ -1,5 +1,5 @@
1name: wai-app-static
1name: wai-app-static
2−version: 3.1.7.1
2+version: 3.1.0
3license: MIT
3license: MIT
4license-file: LICENSE
4license-file: LICENSE
5author: Michael Snoyman <michael@snoyman.com>
5author: Michael Snoyman <michael@snoyman.com>
@@ -26,8 +26,8 @@ Flag print
26
26
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.1
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,8 +37,10 @@ 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− , cryptonite >= 0.6
40+ , blaze-builder >= 0.2.1.4
41− , memory >= 0.7
41+ , base64-bytestring >= 0.1
42+ , byteable
43+ , cryptohash >= 0.11
42 , http-date
44 , http-date
43 , blaze-html >= 0.5
45 , blaze-html >= 0.5
44 , blaze-markup >= 0.5.1
46 , blaze-markup >= 0.5.1
@@ -49,7 +51,9 @@ library
49 , filepath
51 , filepath
50 , wai-extra >= 3.0 && < 3.1
52 , wai-extra >= 3.0 && < 3.1
51 , optparse-applicative >= 0.7
53 , optparse-applicative >= 0.7
52− , warp >= 3.0.11 && < 3.4
54+ , warp >= 3.0.11 && < 3.1
55+ -- Used exclusively for hashFile function
56+ , cryptohash-conduit
53
57
54 exposed-modules: Network.Wai.Application.Static
58 exposed-modules: Network.Wai.Application.Static
55 WaiAppStatic.Storage.Filesystem
59 WaiAppStatic.Storage.Filesystem
@@ -73,7 +77,7 @@ Executable warp
73 , wai-app-static
77 , wai-app-static
74 , directory >= 1.0
78 , directory >= 1.0
75 , containers >= 0.2
79 , containers >= 0.2
76− , bytestring >= 0.10.4
80+ , bytestring >= 0.9.1.4
77 , text >= 0.7
81 , text >= 0.7
78 , mime-types >= 0.1 && < 0.2
82 , mime-types >= 0.1 && < 0.2
79
83
@@ -98,11 +102,8 @@ test-suite runtests
98 , transformers
102 , transformers
99 , mime-types
103 , mime-types
100 , zlib
104 , zlib
101− , filepath
102− , temporary
103− , 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+1−7
@@ -1,7 +1 @@
1−## 3.0.0.4
1+No changes logged yet.
2−
3−* Drop dependency on blaze-builder
4−
5−## 3.0.0.3
6−
7−* 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+4−3
@@ -1,5 +1,5 @@
1name: wai-conduit
1name: wai-conduit
2−version: 3.0.0.4
2+version: 3.0.0.2
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
@@ -15,9 +15,10 @@ extra-source-files: README.md ChangeLog.md
15library
15library
16 exposed-modules: Network.Wai.Conduit
16 exposed-modules: Network.Wai.Conduit
17 build-depends: base >= 4 && < 5
17 build-depends: base >= 4 && < 5
18− , wai >= 3.0 && < 3.3
18+ , wai >= 3.0 && < 3.1
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−162
@@ -1,165 +1,3 @@
1−# Changelog for wai-extra
2−
3−## 3.0.29.1
4−
5−* Fix `Network.Wai.Test.request` always sending an empty request body [#794](https://github.com/yesodweb/wai/pull/794)
6−
7−## 3.0.29
8−
9−* Export `Network.Wai.EventSource.eventStreamAppRaw` [#786](https://github.com/yesodweb/wai/pull/786)
10−
11−## 3.0.28
12−
13−* Add `Network.Wai.EventSource.eventStreamAppRaw` [#767](https://github.com/yesodweb/wai/pull/767)
14−
15−## 3.0.27
16−
17−* Add custom request log formatter which includes response headers [#762](https://github.com/yesodweb/wai/pull/762)
18−
19−## 3.0.26.1
20−
21−* When available, supply the response size to custom loggers
22− [#757](https://github.com/yesodweb/wai/pull/757)
23−
24−## 3.0.26
25−
26−* Throw 413 for too large payload
27−* Throw 431 for too large headers
28− [#741](https://github.com/yesodweb/wai/pull/741)
29−
30−## 3.0.25
31−
32−* Supporting `network` version 3.0.
33−
34−## 3.0.24.3
35−
36−* Drop unnecessary `lifted-base` dependency
37−* Drop unnecessary `stringsearch` dependency [#714](https://github.com/yesodweb/wai/pull/714)
38−
39−## 3.0.24.2
40−
41−* Consider quoted multipart form boundary markers [#700](https://github.com/yesodweb/wai/pull/700).
42−* Don't raise exceptions in `formatAsJSON` [#709](https://github.com/yesodweb/wai/pull/709)
43−
44−## 3.0.24.1
45−
46−* Fix a "file not found" exception in wai-extra [#705](https://github.com/yesodweb/wai/pull/706)
47−
48−## 3.0.24.0
49−
50−* Add timeout middleware [#702](https://github.com/yesodweb/wai/pull/702).
51−
52−## 3.0.23.0
53−
54−* Add rewriteRoot middleware [#697](https://github.com/yesodweb/wai/pull/697).
55−
56−## 3.0.22.1
57−
58−* Drop dependency on blaze-builder, requiring streaming-commons >= 0.2
59−
60−## 3.0.22.0
61−
62−* Support for streaming-commons 0.2
63−* Support for resourcet 1.2
64−
65−## 3.0.21.0
66−
67−* Export `Network.Wai.Parse.noLimitParseRequestBodyOptions` [#662](https://github.com/yesodweb/wai/pull/662).
68−
69−## 3.0.20.2
70−
71−* Revert previous change to `srequest`, which caused breakage
72−
73−## 3.0.20.1
74−
75−* Set `requestBodyLength` for `srequest` [#654](https://github.com/yesodweb/wai/pull/654)
76−
77−## 3.0.20.0
78−
79−* runSessionWith (runSession variant that gives access to ClientState) [#629](https://github.com/yesodweb/wai/pull/629)
80−
81−## 3.0.19.1
82−
83−* All loggers follow the autoFlush setting [#604](https://github.com/yesodweb/wai/pull/604)
84−
85−## 3.0.19
86−
87−* Add a new function basicAuth', which passes request to the CheckCreds argument.
88−
89−## 3.0.18
90−
91−* ForceSSL: preserve port number when redirecting to https. [#582](https://github.com/yesodweb/wai/pull/582)
92−
93−## 3.0.17
94−
95−* Gzip pre compressed [#580](https://github.com/yesodweb/wai/pull/580)
96−
97−## 3.0.16.1
98−
99−* Fix the way the header length is checked (for limiting the max header length)
100−
101−## 3.0.16.0
102−
103−* Add a new function "parseRequestBodyEx" that allows various size limits to be set.
104−
105−## 3.0.15.3
106−
107−* Allow wai-logger 2.3
108−
109−## 3.0.15.2
110−
111−* Doc improvements
112−
113−## 3.0.15.1
114−
115−* don't use deprecated CRT functions on Windows [#544](https://github.com/yesodweb/wai/pull/544)
116−
117−## 3.0.15
118−
119−* add requestSizeCheck [#525](https://github.com/yesodweb/wai/pull/525)
120−
121−## 3.0.14.3
122−
123−* Add missing `requestHeaderReferer` and `requestHeaderUserAgent` fields to CGI [yesod#1186](https://github.com/yesodweb/yesod/issues/1186)
124−
125−## 3.0.14.2
126−
127−* Case insensitive multipart request header lookup [#518](https://github.com/yesodweb/wai/pull/518)
128−
129−## 3.0.14.1
130−
131−* Doc update for logStdout and logStdoutDev [#515](https://github.com/yesodweb/wai/issues/515)
132−
133−## 3.0.14
134−
135−* Middleware to force domain names. [#506](https://github.com/yesodweb/wai/issues/506) [#507](https://github.com/yesodweb/wai/pull/507)
136−
137−## 3.0.13.1
138−
139−* Support wai 3.2
140−
141−## 3.0.13
142−
143−* Autoflush handle [#466](https://github.com/yesodweb/wai/pull/466)
144−
145−## 3.0.12
146−
147−* Add Network.Wai.Header.contentLength to read the Content-Length header of a response
148−* The gzip middleware no longer zips responses smaller than 860 bytes
149−
150−## 3.0.11
151−
152−* Add constructor for more detailed custom output formats for RequestLogger
153−* Add JSON output formatter for RequestLogger
154−
155−## 3.0.10
156−
157−* Adding Request Body to RequestLogger [#401](https://github.com/yesodweb/wai/pull/401)
158−
159−## 3.0.9
160−
161−* Network.Wai.Middleware.Routed module added
162−
163## 3.0.7
1## 3.0.7
164
2
165* Add appearsSecure: check if a request appears to be using SSL even in the
3* Add appearsSecure: check if a request appears to be using SSL even in the
wai-extra/Network/Wai/EventSource.hs+6−27
@@ -1,25 +1,19 @@
1+{-# LANGUAGE OverloadedStrings #-}
1{-|
2{-|
2 A WAI adapter to the HTML5 Server-Sent Events API.
3 A WAI adapter to the HTML5 Server-Sent Events API.
3−
4− If running through a proxy like Nginx you might need to add the
5− headers:
6−
7− > [ ("X-Accel-Buffering", "no"), ("Cache-Control", "no-cache")]
8−
9− There is a small example using these functions in the @example@ directory.
10-}
4-}
11module Network.Wai.EventSource (
5module Network.Wai.EventSource (
12 ServerEvent(..),
6 ServerEvent(..),
13 eventSourceAppChan,
7 eventSourceAppChan,
14− eventSourceAppIO,
8+ eventSourceAppIO
15− eventStreamAppRaw
16 ) where
9 ) where
17
10
11+import Blaze.ByteString.Builder (Builder)
18import Data.Function (fix)
12import Data.Function (fix)
19import Control.Concurrent.Chan (Chan, dupChan, readChan)
13import Control.Concurrent.Chan (Chan, dupChan, readChan)
20import Control.Monad.IO.Class (liftIO)
14import Control.Monad.IO.Class (liftIO)
21−import Network.HTTP.Types (status200, hContentType)
15+import Network.HTTP.Types (status200)
22−import Network.Wai (Application, responseStream)
16+import Network.Wai (Application, Response, responseStream)
23
17
24import Network.Wai.EventSource.EventStream
18import Network.Wai.EventSource.EventStream
25
19
@@ -36,24 +30,9 @@ eventSourceAppIO :: IO ServerEvent -> Application
36eventSourceAppIO src _ sendResponse =
30eventSourceAppIO src _ sendResponse =
37 sendResponse $ responseStream
31 sendResponse $ responseStream
38 status200
32 status200
39− [(hContentType, "text/event-stream")]
33+ [("Content-Type", "text/event-stream")]
40 $ \sendChunk flush -> fix $ \loop -> do
34 $ \sendChunk flush -> fix $ \loop -> do
41 se <- src
35 se <- src
42 case eventToBuilder se of
36 case eventToBuilder se of
43 Nothing -> return ()
37 Nothing -> return ()
44 Just b -> sendChunk b >> flush >> loop
38 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+11−12
@@ -1,5 +1,5 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE OverloadedStrings #-}
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,10 +9,9 @@ module Network.Wai.EventSource.EventStream (
9 eventToBuilder
9 eventToBuilder
10 ) where
10 ) where
11
11
12−import Data.ByteString.Builder
12+import Blaze.ByteString.Builder
13−#if __GLASGOW_HASKELL__ < 710
13+import Blaze.ByteString.Builder.Char8
14import Data.Monoid
14import Data.Monoid
15−#endif
16
15
17{-|
16{-|
18 Type representing a communication over an event stream. This can be an
17 Type representing a communication over an event stream. This can be an
@@ -38,18 +37,18 @@ data ServerEvent
38 Newline as a Builder.
37 Newline as a Builder.
39-}
38-}
40nl :: Builder
39nl :: Builder
41−nl = char7 '\n'
40+nl = fromChar '\n'
42
41
43
42
44{-|
43{-|
45 Field names as Builder
44 Field names as Builder
46-}
45-}
47nameField, idField, dataField, retryField, commentField :: Builder
46nameField, idField, dataField, retryField, commentField :: Builder
48−nameField = string7 "event:"
47+nameField = fromString "event:"
49−idField = string7 "id:"
48+idField = fromString "id:"
50−dataField = string7 "data:"
49+dataField = fromString "data:"
51−retryField = string7 "retry:"
50+retryField = fromString "retry:"
52−commentField = char7 ':'
51+commentField = fromChar ':'
53
52
54
53
55{-|
54{-|
@@ -65,7 +64,7 @@ field l b = l `mappend` b `mappend` nl
65-}
64-}
66eventToBuilder :: ServerEvent -> Maybe Builder
65eventToBuilder :: ServerEvent -> Maybe Builder
67eventToBuilder (CommentEvent txt) = Just $ field commentField txt
66eventToBuilder (CommentEvent txt) = Just $ field commentField txt
68−eventToBuilder (RetryEvent n) = Just $ field retryField (string8 . show $ n)
67+eventToBuilder (RetryEvent n) = Just $ field retryField (fromShow n)
69eventToBuilder (CloseEvent) = Nothing
68eventToBuilder (CloseEvent) = Nothing
70eventToBuilder (ServerEvent n i d)= Just $
69eventToBuilder (ServerEvent n i d)= Just $
71 (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
70 (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
wai-extra/Network/Wai/Handler/CGI.hs+27−31
@@ -1,4 +1,6 @@
1+{-# LANGUAGE OverloadedStrings #-}
1−{-# LANGUAGE RankNTypes, CPP #-}
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE CPP #-}
2-- | Backend for Common Gateway Interface. Almost all users should use the
4-- | Backend for Common Gateway Interface. Almost all users should use the
3-- 'run' function.
5-- 'run' function.
4module Network.Wai.Handler.CGI
6module Network.Wai.Handler.CGI
@@ -19,18 +21,16 @@ import Control.Arrow ((***))
19import Data.Char (toLower)
21import Data.Char (toLower)
20import qualified System.IO
22import qualified System.IO
21import qualified Data.String as String
23import qualified Data.String as String
24+import Data.Monoid (mconcat, mempty)
22−import Data.ByteString.Builder (byteString, toLazyByteString, char7, string8)
25+import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush)
23−import Data.ByteString.Builder.Extra (flush)
26+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
24import Data.ByteString.Lazy.Internal (defaultChunkSize)
27import Data.ByteString.Lazy.Internal (defaultChunkSize)
25import System.IO (Handle)
28import System.IO (Handle)
26−import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)
29+import Network.HTTP.Types (Status (..))
27import qualified Network.HTTP.Types as H
30import qualified Network.HTTP.Types as H
28import qualified Data.CaseInsensitive as CI
31import qualified Data.CaseInsensitive as CI
29−#if __GLASGOW_HASKELL__ < 710
30−import Data.Monoid (mconcat, mempty, mappend)
32+import Data.Monoid (mappend)
31−#endif
32−
33−import qualified Data.Streaming.ByteString.Builder as Builder
33+import qualified Data.Streaming.Blaze as Blaze
34import Data.Function (fix)
34import Data.Function (fix)
35import Control.Monad (unless, void)
35import Control.Monad (unless, void)
36
36
@@ -118,11 +118,7 @@ runGeneric vars inputH outputH xsendfile app = do
118 , vault = mempty
118 , vault = mempty
119 , requestBodyLength = KnownLength $ fromIntegral contentLength
119 , requestBodyLength = KnownLength $ fromIntegral contentLength
120 , requestHeaderHost = lookup "host" reqHeaders
120 , requestHeaderHost = lookup "host" reqHeaders
121− , requestHeaderRange = lookup hRange reqHeaders
121+ , requestHeaderRange = lookup "range" reqHeaders
122−#if MIN_VERSION_wai(3,2,0)
123− , requestHeaderReferer = lookup "referer" reqHeaders
124− , requestHeaderUserAgent = lookup "user-agent" reqHeaders
125−#endif
126 }
122 }
127 void $ app env $ \res ->
123 void $ app env $ \res ->
128 case (xsendfile, res) of
124 case (xsendfile, res) of
@@ -131,7 +127,7 @@ runGeneric vars inputH outputH xsendfile app = do
131 return ResponseReceived
127 return ResponseReceived
132 _ -> do
128 _ -> do
133 let (s, hs, wb) = responseToStream res
129 let (s, hs, wb) = responseToStream res
134− (blazeRecv, blazeFinish) <- Builder.newBuilderRecv Builder.defaultStrategy
130+ (blazeRecv, blazeFinish) <- Blaze.newBlazeRecv Blaze.defaultStrategy
135 wb $ \b -> do
131 wb $ \b -> do
136 let sendBuilder builder = do
132 let sendBuilder builder = do
137 popper <- blazeRecv builder
133 popper <- blazeRecv builder
@@ -140,39 +136,39 @@ runGeneric vars inputH outputH xsendfile app = do
140 unless (B.null bs) $ do
136 unless (B.null bs) $ do
141 outputH bs
137 outputH bs
142 loop
138 loop
143− sendBuilder $ headers s hs `mappend` char7 '\n'
139+ sendBuilder $ headers s hs `mappend` fromChar '\n'
144 b sendBuilder (sendBuilder flush)
140 b sendBuilder (sendBuilder flush)
145 blazeFinish >>= maybe (return ()) outputH
141 blazeFinish >>= maybe (return ()) outputH
146 return ResponseReceived
142 return ResponseReceived
147 where
143 where
148 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
144 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
149− status (Status i m) = (byteString "Status", mconcat
145+ status (Status i m) = (fromByteString "Status", mconcat
150− [ string8 $ show i
146+ [ fromString $ show i
151− , char7 ' '
147+ , fromChar ' '
152− , byteString m
148+ , fromByteString m
153 ])
149 ])
154− header' (x, y) = (byteString $ CI.original x, byteString y)
150+ header' (x, y) = (fromByteString $ CI.original x, fromByteString y)
155 header (x, y) = mconcat
151 header (x, y) = mconcat
156 [ x
152 [ x
157− , byteString ": "
153+ , fromByteString ": "
158 , y
154 , y
159− , char7 '\n'
155+ , fromChar '\n'
160 ]
156 ]
161 sfBuilder s hs sf fp = mconcat
157 sfBuilder s hs sf fp = mconcat
162 [ headers s hs
158 [ headers s hs
163− , header $ (byteString sf, string8 fp)
159+ , header $ (fromByteString sf, fromString fp)
164− , char7 '\n'
160+ , fromChar '\n'
165− , byteString sf
161+ , fromByteString sf
166− , byteString " not supported"
162+ , fromByteString " not supported"
167 ]
163 ]
168 fixHeaders h =
164 fixHeaders h =
169− case lookup hContentType h of
165+ case lookup "content-type" h of
170− Nothing -> (hContentType, "text/html; charset=utf-8") : h
166+ Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
171 Just _ -> h
167 Just _ -> h
172
168
173cleanupVarName :: String -> CI.CI B.ByteString
169cleanupVarName :: String -> CI.CI B.ByteString
174−cleanupVarName "CONTENT_TYPE" = hContentType
170+cleanupVarName "CONTENT_TYPE" = "Content-Type"
175−cleanupVarName "CONTENT_LENGTH" = hContentLength
171+cleanupVarName "CONTENT_LENGTH" = "Content-Length"
176cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
172cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
177cleanupVarName s =
173cleanupVarName s =
178 case s of
174 case s of
wai-extra/Network/Wai/Handler/SCGI.hs+1−12
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, ForeignFunctionInterface #-}
1+{-# LANGUAGE ForeignFunctionInterface #-}
2module Network.Wai.Handler.SCGI
2module Network.Wai.Handler.SCGI
3 ( run
3 ( run
4 , runSendfile
4 , runSendfile
@@ -86,16 +86,6 @@ readByteString socket len = do
86foreign import ccall unsafe "accept"
86foreign import ccall unsafe "accept"
87 c'accept :: CInt -> Ptr a -> Ptr a -> IO CInt
87 c'accept :: CInt -> Ptr a -> Ptr a -> IO CInt
88
88
89−#if WINDOWS
90−foreign import ccall unsafe "_close"
91− c'close :: CInt -> IO CInt
92−
93−foreign import ccall unsafe "_write"
94− c'write :: CInt -> Ptr CChar -> CInt -> IO CInt
95−
96−foreign import ccall unsafe "_read"
97− c'read :: CInt -> Ptr CChar -> CInt -> IO CInt
98−#else
99foreign import ccall unsafe "close"
89foreign import ccall unsafe "close"
100 c'close :: CInt -> IO CInt
90 c'close :: CInt -> IO CInt
101
91
@@ -104,4 +94,3 @@ foreign import ccall unsafe "write"
104
94
105foreign import ccall unsafe "read"
95foreign import ccall unsafe "read"
106 c'read :: CInt -> Ptr CChar -> CInt -> IO CInt
96 c'read :: CInt -> Ptr CChar -> CInt -> IO CInt
107−#endif
wai-extra/Network/Wai/Header.hsdeleted−18
@@ -1,18 +0,0 @@
1−-- | Some helpers for dealing with WAI 'Header's.
2−
3−module Network.Wai.Header
4− ( contentLength
5− ) where
6−
7−import qualified Data.ByteString.Char8 as S8
8−import Network.HTTP.Types as H
9−
10−-- | More useful for a response. A Wai Request already has a requestBodyLength
11−contentLength :: [(HeaderName, S8.ByteString)] -> Maybe Integer
12−contentLength hdrs = lookup H.hContentLength hdrs >>= readInt
13−
14−readInt :: S8.ByteString -> Maybe Integer
15−readInt bs =
16− case S8.readInteger bs of
17− Just (i, rest) | S8.null rest -> Just i
18− _ -> Nothing
wai-extra/Network/Wai/Middleware/AcceptOverride.hs+2
@@ -1,3 +1,5 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
1module Network.Wai.Middleware.AcceptOverride
3module Network.Wai.Middleware.AcceptOverride
2 ( acceptOverride
4 ( acceptOverride
3 ) where
5 ) where
wai-extra/Network/Wai/Middleware/AddHeaders.hs+10−4
@@ -5,8 +5,8 @@ module Network.Wai.Middleware.AddHeaders
5 ( addHeaders
5 ( addHeaders
6 ) where
6 ) where
7
7
8−import Network.HTTP.Types (Header)
8+import Network.HTTP.Types (ResponseHeaders, Header)
9−import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)
9+import Network.Wai (Middleware)
10import Network.Wai.Internal (Response(..))
10import Network.Wai.Internal (Response(..))
11import Data.ByteString (ByteString)
11import Data.ByteString (ByteString)
12
12
@@ -18,7 +18,13 @@ addHeaders :: [(ByteString, ByteString)] -> Middleware
18--
18--
19-- Since 3.0.3
19-- Since 3.0.3
20
20
21−addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h)
21+addHeaders h app req respond = app req $ respond . addHeaders' (map (first CI.mk) h)
22+
23+mapHeader :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response
24+mapHeader f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2
25+mapHeader f (ResponseBuilder s h b) = ResponseBuilder s (f h) b
26+mapHeader f (ResponseStream s h b) = ResponseStream s (f h) b
27+mapHeader _ r@(ResponseRaw _ _) = r
22
28
23addHeaders' :: [Header] -> Response -> Response
29addHeaders' :: [Header] -> Response -> Response
24−addHeaders' h = mapResponseHeaders (\hs -> h ++ hs)
30+addHeaders' h = mapHeader (\hs -> h ++ hs)
wai-extra/Network/Wai/Middleware/Approot.hs+4−2
@@ -1,4 +1,5 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE OverloadedStrings #-}
2-- | Middleware for establishing the root of the application.
3-- | Middleware for establishing the root of the application.
3--
4--
4-- Many application need the ability to create URLs referring back to the
5-- Many application need the ability to create URLs referring back to the
@@ -28,12 +29,13 @@ module Network.Wai.Middleware.Approot
28
29
29import Control.Exception (Exception, throw)
30import Control.Exception (Exception, throw)
30import Data.ByteString (ByteString)
31import Data.ByteString (ByteString)
32+import qualified Data.ByteString as S
31import qualified Data.ByteString.Char8 as S8
33import qualified Data.ByteString.Char8 as S8
32import Data.Maybe (fromMaybe)
34import Data.Maybe (fromMaybe)
33import Data.Typeable (Typeable)
35import Data.Typeable (Typeable)
34import qualified Data.Vault.Lazy as V
36import qualified Data.Vault.Lazy as V
35−import Network.Wai (Request, vault, Middleware)
37+import Network.Wai (Request, vault, Middleware, requestHeaderHost)
36−import Network.Wai.Request (guessApproot)
38+import Network.Wai.Request (appearsSecure, guessApproot)
37import System.Environment (getEnvironment)
39import System.Environment (getEnvironment)
38import System.IO.Unsafe (unsafePerformIO)
40import System.IO.Unsafe (unsafePerformIO)
39
41
wai-extra/Network/Wai/Middleware/Autohead.hs+1−3
@@ -1,12 +1,10 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE OverloadedStrings #-}
2-- | Automatically produce responses to HEAD requests based on the underlying
2-- | Automatically produce responses to HEAD requests based on the underlying
3-- applications GET response.
3-- applications GET response.
4module Network.Wai.Middleware.Autohead (autohead) where
4module Network.Wai.Middleware.Autohead (autohead) where
5
5
6import Network.Wai
6import Network.Wai
7−#if __GLASGOW_HASKELL__ < 710
8import Data.Monoid (mempty)
7import Data.Monoid (mempty)
9−#endif
10
8
11autohead :: Middleware
9autohead :: Middleware
12autohead app req sendResponse
10autohead app req sendResponse
wai-extra/Network/Wai/Middleware/CleanPath.hs+3−5
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE OverloadedStrings #-}
2module Network.Wai.Middleware.CleanPath
2module Network.Wai.Middleware.CleanPath
3 ( cleanPath
3 ( cleanPath
4 ) where
4 ) where
@@ -6,11 +6,9 @@ module Network.Wai.Middleware.CleanPath
6import Network.Wai
6import Network.Wai
7import qualified Data.ByteString.Char8 as B
7import qualified Data.ByteString.Char8 as B
8import qualified Data.ByteString.Lazy as L
8import qualified Data.ByteString.Lazy as L
9−import Network.HTTP.Types (status301, hLocation)
9+import Network.HTTP.Types (status301)
10import Data.Text (Text)
10import Data.Text (Text)
11−#if __GLASGOW_HASKELL__ < 710
12import Data.Monoid (mconcat)
11import Data.Monoid (mconcat)
13−#endif
14
12
15cleanPath :: ([Text] -> Either B.ByteString [Text])
13cleanPath :: ([Text] -> Either B.ByteString [Text])
16 -> B.ByteString
14 -> B.ByteString
@@ -21,7 +19,7 @@ cleanPath splitter prefix app env sendResponse =
21 Right pieces -> app pieces env sendResponse
19 Right pieces -> app pieces env sendResponse
22 Left p -> sendResponse
20 Left p -> sendResponse
23 $ responseLBS status301
21 $ responseLBS status301
24− [(hLocation, mconcat [prefix, p, suffix])]
22+ [("Location", mconcat [prefix, p, suffix])]
25 $ L.empty
23 $ L.empty
26 where
24 where
27 -- include the query string if present
25 -- include the query string if present
wai-extra/Network/Wai/Middleware/ForceDomain.hsdeleted−38
@@ -1,38 +0,0 @@
1−-- |
2−--
3−-- @since 3.0.14
4−module Network.Wai.Middleware.ForceDomain where
5−
6−import Data.ByteString (ByteString)
7−import Data.Monoid ((<>), mempty)
8−import Network.HTTP.Types (hLocation, methodGet, status301, status307)
9−import Prelude
10−
11−import Network.Wai
12−import Network.Wai.Request
13−
14−-- | Force a domain by redirecting.
15−-- The `checkDomain` function takes the current domain and checks whether it is correct.
16−-- It should return `Nothing` if the domain is correct, or `Just "domain.com"` if it is incorrect.
17−--
18−-- @since 3.0.14
19−forceDomain :: (ByteString -> Maybe ByteString) -> Middleware
20−forceDomain checkDomain app req sendResponse =
21− case requestHeaderHost req >>= checkDomain of
22− Nothing ->
23− app req sendResponse
24− Just domain ->
25− sendResponse $ redirectResponse domain
26−
27− where
28− -- From: Network.Wai.Middleware.ForceSSL
29− redirectResponse domain =
30− responseBuilder status [(hLocation, location domain)] mempty
31−
32− location h =
33− let p = if appearsSecure req then "https://" else "http://" in
34− p <> h <> rawPathInfo req <> rawQueryString req
35−
36− status
37− | requestMethod req == methodGet = status301
38− | otherwise = status307
wai-extra/Network/Wai/Middleware/ForceSSL.hs+9−2
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
2-- | Redirect non-SSL requests to https
3-- | Redirect non-SSL requests to https
3--
4--
4-- Since 3.0.7
5-- Since 3.0.7
@@ -17,6 +18,9 @@ import Data.Monoid (mempty)
17import Data.Monoid ((<>))
18import Data.Monoid ((<>))
18import Network.HTTP.Types (hLocation, methodGet, status301, status307)
19import Network.HTTP.Types (hLocation, methodGet, status301, status307)
19
20
21+import qualified Data.ByteString as S
22+import Data.Word8 (_colon)
23+
20-- | For requests that don't appear secure, redirect to https
24-- | For requests that don't appear secure, redirect to https
21--
25--
22-- Since 3.0.7
26-- Since 3.0.7
@@ -28,10 +32,13 @@ forceSSL app req sendResponse =
28
32
29redirectResponse :: Request -> Maybe Response
33redirectResponse :: Request -> Maybe Response
30redirectResponse req = do
34redirectResponse req = do
31− host <- requestHeaderHost req
35+ (host, _) <- S.break (== _colon) <$> requestHeaderHost req
36+
32− return $ responseBuilder status [(hLocation, location host)] mempty
37+ return $ responseBuilder status [(hLocation, location host)] mempty
38+
33 where
39 where
34 location h = "https://" <> h <> rawPathInfo req <> rawQueryString req
40 location h = "https://" <> h <> rawPathInfo req <> rawQueryString req
41+
35 status
42 status
36 | requestMethod req == methodGet = status301
43 | requestMethod req == methodGet = status301
37 | otherwise = status307
44 | otherwise = status307
wai-extra/Network/Wai/Middleware/Gzip.hs+31−67
@@ -1,4 +1,6 @@
1−{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}
1+{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE OverloadedStrings #-}
2---------------------------------------------------------
4---------------------------------------------------------
3-- |
5-- |
4-- Module : Network.Wai.Middleware.Gzip
6-- Module : Network.Wai.Middleware.Gzip
@@ -27,60 +29,43 @@ import Data.Maybe (fromMaybe, isJust)
27import qualified Data.ByteString.Char8 as S8
29import qualified Data.ByteString.Char8 as S8
28import qualified Data.ByteString as S
30import qualified Data.ByteString as S
29import Data.Default.Class
31import Data.Default.Class
30−import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent
32+import Network.HTTP.Types (Status, Header)
31− , hContentType, hContentLength)
33+import Control.Monad.IO.Class (liftIO)
34+import Control.Monad.Trans.Resource (runResourceT)
32import System.Directory (doesFileExist, createDirectoryIfMissing)
35import System.Directory (doesFileExist, createDirectoryIfMissing)
33−import Data.ByteString.Builder (byteString)
36+import Blaze.ByteString.Builder (fromByteString)
34−import qualified Data.ByteString.Builder.Extra as Blaze (flush)
35import Control.Exception (try, SomeException)
37import Control.Exception (try, SomeException)
36import qualified Data.Set as Set
38import qualified Data.Set as Set
37−import Network.Wai.Header
38import Network.Wai.Internal
39import Network.Wai.Internal
39−import qualified Data.Streaming.ByteString.Builder as B
40+import qualified Data.Streaming.Blaze as B
40import qualified Data.Streaming.Zlib as Z
41import qualified Data.Streaming.Zlib as Z
42+import qualified Blaze.ByteString.Builder as Blaze
41import Control.Monad (unless)
43import Control.Monad (unless)
42import Data.Function (fix)
44import Data.Function (fix)
43import Control.Exception (throwIO)
45import Control.Exception (throwIO)
44import qualified System.IO as IO
46import qualified System.IO as IO
45import Data.ByteString.Lazy.Internal (defaultChunkSize)
47import Data.ByteString.Lazy.Internal (defaultChunkSize)
46−import Data.Word8 (_semicolon)
47
48
48data GzipSettings = GzipSettings
49data GzipSettings = GzipSettings
49 { gzipFiles :: GzipFiles
50 { gzipFiles :: GzipFiles
50 , gzipCheckMime :: S.ByteString -> Bool
51 , gzipCheckMime :: S.ByteString -> Bool
51 }
52 }
52
53
53−-- | Gzip behavior for files.
54−data GzipFiles
55− = GzipIgnore -- ^ Do not compress file responses.
56− | GzipCompress -- ^ Compress files. Note that this may counteract
57− -- zero-copy response optimizations on some
58− -- platforms.
59− | GzipCacheFolder FilePath -- ^ Compress files, caching them in
54+data GzipFiles = GzipIgnore | GzipCompress | GzipCacheFolder FilePath
60− -- some directory.
61− | GzipPreCompressed GzipFiles -- ^ If we use compression then try to use the filename with ".gz"
62− -- appended to it, if the file is missing then try next action
63− --
64− -- @since 3.0.17
65 deriving (Show, Eq, Read)
55 deriving (Show, Eq, Read)
66
56
67−-- | Use default MIME settings; /do not/ compress files.
68instance Default GzipSettings where
57instance Default GzipSettings where
69 def = GzipSettings GzipIgnore defaultCheckMime
58 def = GzipSettings GzipIgnore defaultCheckMime
70
59
71−-- | MIME types that will be compressed by default:
72−-- @text/@ @*@, @application/json@, @application/javascript@,
73−-- @application/ecmascript@, @image/x-icon@.
74defaultCheckMime :: S.ByteString -> Bool
60defaultCheckMime :: S.ByteString -> Bool
75defaultCheckMime bs =
61defaultCheckMime bs =
76 S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress
62 S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress
77 where
63 where
78− bs' = fst $ S.break (== _semicolon) bs
64+ bs' = fst $ S.breakByte 59 bs -- semicolon
79 toCompress = Set.fromList
65 toCompress = Set.fromList
80 [ "application/json"
66 [ "application/json"
81 , "application/javascript"
67 , "application/javascript"
82 , "application/ecmascript"
68 , "application/ecmascript"
83− , "image/x-icon"
84 ]
69 ]
85
70
86-- | Use gzip to compress the body of the response.
71-- | Use gzip to compress the body of the response.
@@ -88,51 +73,30 @@ defaultCheckMime bs =
88-- Analyzes the \"Accept-Encoding\" header from the client to determine
73-- Analyzes the \"Accept-Encoding\" header from the client to determine
89-- if gzip is supported.
74-- if gzip is supported.
90--
75--
91−-- File responses will be compressed according to the 'GzipFiles' setting.
76+-- Possible future enhancements:
92--
77--
93−-- Will only be applied based on the 'gzipCheckMime' setting. For default
78+-- * Only compress if the response is above a certain size.
94−-- behavior, see 'defaultCheckMime'.
95gzip :: GzipSettings -> Middleware
79gzip :: GzipSettings -> Middleware
96gzip set app env sendResponse = app env $ \res ->
80gzip set app env sendResponse = app env $ \res ->
97 case res of
81 case res of
98 ResponseRaw{} -> sendResponse res
82 ResponseRaw{} -> sendResponse res
99 ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res
83 ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res
100− _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res)
84+ _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)
101 then
85 then
102− let runAction x = case x of
86+ case (res, gzipFiles set) of
103− (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) ->
104− let
105− compressedVersion = file ++ ".gz"
106− in
107− doesFileExist compressedVersion >>= \y ->
108− if y
109− then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing)
110− else (runAction (ResponseFile s hs file Nothing, nextAction))
111− (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
87+ (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
112− case lookup hContentType hs of
88+ case lookup "content-type" hs of
113− Just m
89+ Just m
114− | gzipCheckMime set m -> compressFile s hs file cache sendResponse
90+ | gzipCheckMime set m -> compressFile s hs file cache sendResponse
115− _ -> sendResponse res
91+ _ -> sendResponse res
116− (ResponseFile {}, GzipIgnore) -> sendResponse res
117− _ -> compressE set res sendResponse
92+ _ -> compressE set res sendResponse
118− in runAction (res, gzipFiles set)
119 else sendResponse res
93 else sendResponse res
120 where
94 where
121 enc = fromMaybe [] $ (splitCommas . S8.unpack)
95 enc = fromMaybe [] $ (splitCommas . S8.unpack)
122 `fmap` lookup "Accept-Encoding" (requestHeaders env)
96 `fmap` lookup "Accept-Encoding" (requestHeaders env)
123− ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env
97+ ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env
124 isMSIE6 = "MSIE 6" `S.isInfixOf` ua
98 isMSIE6 = "MSIE 6" `S.isInfixOf` ua
125− isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res
99+ isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res
126−
127− bigEnough rsp = case contentLength (responseHeaders rsp) of
128− Nothing -> True -- This could be a streaming case
129− Just len -> len >= minimumLength
130−
131− -- For a small enough response, gzipping will actually increase the size
132− -- Potentially for anything less than 860 bytes gzipping could be a net loss
133− -- The actual number is application specific though and may need to be adjusted
134− -- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits
135− minimumLength = 860
136
100
137compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a
101compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a
138compressFile s hs file cache sendResponse = do
102compressFile s hs file cache sendResponse = do
@@ -154,7 +118,7 @@ compressFile s hs file cache sendResponse = do
154 Z.PRNext bs -> do
118 Z.PRNext bs -> do
155 S.hPut outH bs
119 S.hPut outH bs
156 loop
120 loop
157− Z.PRError ex -> throwIO ex
121+ Z.PRError e -> throwIO e
158 fix $ \loop -> do
122 fix $ \loop -> do
159 bs <- S.hGetSome inH defaultChunkSize
123 bs <- S.hGetSome inH defaultChunkSize
160 unless (S.null bs) $ do
124 unless (S.null bs) $ do
@@ -181,11 +145,11 @@ compressE :: GzipSettings
181 -> (Response -> IO a)
145 -> (Response -> IO a)
182 -> IO a
146 -> IO a
183compressE set res sendResponse =
147compressE set res sendResponse =
184− case lookup hContentType hs of
148+ case lookup "content-type" hs of
185 Just m | gzipCheckMime set m ->
149 Just m | gzipCheckMime set m ->
186 let hs' = fixHeaders hs
150 let hs' = fixHeaders hs
187 in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do
151 in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do
188− (blazeRecv, _) <- B.newBuilderRecv B.defaultStrategy
152+ (blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy
189 deflate <- Z.initDeflate 1 (Z.WindowBits 31)
153 deflate <- Z.initDeflate 1 (Z.WindowBits 31)
190 let sendBuilder builder = do
154 let sendBuilder builder = do
191 popper <- blazeRecv builder
155 popper <- blazeRecv builder
@@ -200,11 +164,11 @@ compressE set res sendResponse =
200 deflatePopper $ Z.flushDeflate deflate
164 deflatePopper $ Z.flushDeflate deflate
201 flush
165 flush
202 deflatePopper popper = fix $ \loop -> do
166 deflatePopper popper = fix $ \loop -> do
203− result <- popper
167+ res <- popper
204− case result of
168+ case res of
205 Z.PRDone -> return ()
169 Z.PRDone -> return ()
206 Z.PRNext bs' -> do
170 Z.PRNext bs' -> do
207− sendChunk $ byteString bs'
171+ sendChunk $ fromByteString bs'
208 loop
172 loop
209 Z.PRError e -> throwIO e
173 Z.PRError e -> throwIO e
210
174
@@ -219,9 +183,9 @@ compressE set res sendResponse =
219-- different length after gzip compression.
183-- different length after gzip compression.
220fixHeaders :: [Header] -> [Header]
184fixHeaders :: [Header] -> [Header]
221fixHeaders =
185fixHeaders =
222− ((hContentEncoding, "gzip") :) . filter notLength
186+ (("Content-Encoding", "gzip") :) . filter notLength
223 where
187 where
224− notLength (x, _) = x /= hContentLength
188+ notLength (x, _) = x /= "content-length"
225
189
226splitCommas :: String -> [String]
190splitCommas :: String -> [String]
227splitCommas [] = []
191splitCommas [] = []
wai-extra/Network/Wai/Middleware/HttpAuth.hs+16−25
@@ -1,11 +1,10 @@
1−{-# LANGUAGE RecordWildCards, TupleSections, CPP #-}
1+{-# LANGUAGE RecordWildCards, OverloadedStrings, TupleSections #-}
2-- | Implements HTTP Basic Authentication.
2-- | Implements HTTP Basic Authentication.
3--
3--
4-- This module may add digest authentication in the future.
4-- This module may add digest authentication in the future.
5module Network.Wai.Middleware.HttpAuth
5module Network.Wai.Middleware.HttpAuth
6 ( -- * Middleware
6 ( -- * Middleware
7 basicAuth
7 basicAuth
8− , basicAuth'
9 , CheckCreds
8 , CheckCreds
10 , AuthSettings
9 , AuthSettings
11 , authRealm
10 , authRealm
@@ -15,14 +14,13 @@ module Network.Wai.Middleware.HttpAuth
15 , extractBasicAuth
14 , extractBasicAuth
16 , extractBearerAuth
15 , extractBearerAuth
17 ) where
16 ) where
18−#if __GLASGOW_HASKELL__ < 710
17+
19import Control.Applicative
18import Control.Applicative
20−#endif
21import Data.ByteString (ByteString)
19import Data.ByteString (ByteString)
22import Data.ByteString.Base64 (decodeLenient)
20import Data.ByteString.Base64 (decodeLenient)
23import Data.String (IsString (..))
21import Data.String (IsString (..))
24import Data.Word8 (isSpace, _colon, toLower)
22import Data.Word8 (isSpace, _colon, toLower)
25−import Network.HTTP.Types (status401, hContentType, hAuthorization)
23+import Network.HTTP.Types (status401)
26import Network.Wai
24import Network.Wai
27
25
28import qualified Data.ByteString as S
26import qualified Data.ByteString as S
@@ -37,19 +35,11 @@ type CheckCreds = ByteString
37--
35--
38-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
36-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
39--
37--
40−-- @since 1.3.4
38+-- Since 1.3.4
41basicAuth :: CheckCreds
39basicAuth :: CheckCreds
42 -> AuthSettings
40 -> AuthSettings
43 -> Middleware
41 -> Middleware
44−basicAuth checkCreds = basicAuth' (\_ -> checkCreds)
45−
46−-- | Like 'basicAuth', but also passes a request to the authentication function.
47−--
48−-- @since 3.0.19
49−basicAuth' :: (Request -> CheckCreds)
50− -> AuthSettings
51− -> Middleware
52−basicAuth' checkCreds AuthSettings {..} app req sendResponse = do
42+basicAuth checkCreds AuthSettings {..} app req sendResponse = do
53 isProtected <- authIsProtected req
43 isProtected <- authIsProtected req
54 allowed <- if isProtected then check else return True
44 allowed <- if isProtected then check else return True
55 if allowed
45 if allowed
@@ -57,10 +47,11 @@ basicAuth' checkCreds AuthSettings {..} app req sendResponse = do
57 else authOnNoAuth authRealm req sendResponse
47 else authOnNoAuth authRealm req sendResponse
58 where
48 where
59 check =
49 check =
60− case (lookup hAuthorization $ requestHeaders req)
50+ case (lookup "Authorization" $ requestHeaders req)
61 >>= extractBasicAuth of
51 >>= extractBasicAuth of
62 Nothing -> return False
52 Nothing -> return False
63− Just (username, password) -> checkCreds req username password
53+ Just (username, password) -> checkCreds username password
54+
64
55
65-- | Basic authentication settings. This value is an instance of
56-- | Basic authentication settings. This value is an instance of
66-- @IsString@, so the recommended approach to create a value is to
57-- @IsString@, so the recommended approach to create a value is to
@@ -69,23 +60,23 @@ basicAuth' checkCreds AuthSettings {..} app req sendResponse = do
69--
60--
70-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
61-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
71--
62--
72−-- @since 1.3.4
63+-- Since 1.3.4
73data AuthSettings = AuthSettings
64data AuthSettings = AuthSettings
74 { authRealm :: !ByteString
65 { authRealm :: !ByteString
75 -- ^
66 -- ^
76 --
67 --
77− -- @since 1.3.4
68+ -- Since 1.3.4
78 , authOnNoAuth :: !(ByteString -> Application)
69 , authOnNoAuth :: !(ByteString -> Application)
79 -- ^ Takes the realm and returns an appropriate 401 response when
70 -- ^ Takes the realm and returns an appropriate 401 response when
80 -- authentication is not provided.
71 -- authentication is not provided.
81 --
72 --
82− -- @since 1.3.4
73+ -- Since 1.3.4
83 , authIsProtected :: !(Request -> IO Bool)
74 , authIsProtected :: !(Request -> IO Bool)
84 -- ^ Determine if access to the requested resource is restricted.
75 -- ^ Determine if access to the requested resource is restricted.
85 --
76 --
86 -- Default: always returns @True@.
77 -- Default: always returns @True@.
87 --
78 --
88− -- @since 1.3.4
79+ -- Since 1.3.4
89 }
80 }
90
81
91instance IsString AuthSettings where
82instance IsString AuthSettings where
@@ -93,7 +84,7 @@ instance IsString AuthSettings where
93 { authRealm = fromString s
84 { authRealm = fromString s
94 , authOnNoAuth = \realm _req f -> f $ responseLBS
85 , authOnNoAuth = \realm _req f -> f $ responseLBS
95 status401
86 status401
96− [ (hContentType, "text/plain")
87+ [ ("Content-Type", "text/plain")
97 , ("WWW-Authenticate", S.concat
88 , ("WWW-Authenticate", S.concat
98 [ "Basic realm=\""
89 [ "Basic realm=\""
99 , realm
90 , realm
@@ -107,7 +98,7 @@ instance IsString AuthSettings where
107-- | Extract basic authentication data from usually __Authorization__
98-- | Extract basic authentication data from usually __Authorization__
108-- header value. Returns username and password
99-- header value. Returns username and password
109--
100--
110−-- @since 3.0.5
101+-- Since 3.0.5
111extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)
102extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)
112extractBasicAuth bs =
103extractBasicAuth bs =
113 let (x, y) = S.break isSpace bs
104 let (x, y) = S.break isSpace bs
@@ -117,13 +108,13 @@ extractBasicAuth bs =
117 where
108 where
118 extract encoded =
109 extract encoded =
119 let raw = decodeLenient encoded
110 let raw = decodeLenient encoded
120− (username, password') = S.break (== _colon) raw
111+ (username, password') = S.breakByte _colon raw
121 in ((username,) . snd) <$> S.uncons password'
112 in ((username,) . snd) <$> S.uncons password'
122
113
123-- | Extract bearer authentication data from __Authorization__ header
114-- | Extract bearer authentication data from __Authorization__ header
124-- value. Returns bearer token
115-- value. Returns bearer token
125--
116--
126−-- @since 3.0.5
117+-- Since 3.0.5
127extractBearerAuth :: ByteString -> Maybe ByteString
118extractBearerAuth :: ByteString -> Maybe ByteString
128extractBearerAuth bs =
119extractBearerAuth bs =
129 let (x, y) = S.break isSpace bs
120 let (x, y) = S.break isSpace bs
wai-extra/Network/Wai/Middleware/Jsonp.hs+16−16
@@ -1,4 +1,5 @@
1+{-# LANGUAGE OverloadedStrings #-}
1−{-# LANGUAGE RankNTypes, CPP #-}
2+{-# LANGUAGE RankNTypes #-}
2---------------------------------------------------------
3---------------------------------------------------------
3-- |
4-- |
4-- Module : Network.Wai.Middleware.Jsonp
5-- Module : Network.Wai.Middleware.Jsonp
@@ -18,15 +19,14 @@ import Network.Wai
18import Network.Wai.Internal
19import Network.Wai.Internal
19import Data.ByteString (ByteString)
20import Data.ByteString (ByteString)
20import qualified Data.ByteString.Char8 as B8
21import qualified Data.ByteString.Char8 as B8
21−import Data.ByteString.Builder.Extra (byteStringCopy)
22+import Blaze.ByteString.Builder (Builder, copyByteString)
22−import Data.ByteString.Builder (char7)
23+import Blaze.ByteString.Builder.Char8 (fromChar)
23−#if __GLASGOW_HASKELL__ < 710
24import Data.Monoid (mappend)
24import Data.Monoid (mappend)
25−#endif
26import Control.Monad (join)
25import Control.Monad (join)
27import Data.Maybe (fromMaybe)
26import Data.Maybe (fromMaybe)
28import qualified Data.ByteString as S
27import qualified Data.ByteString as S
28+import Data.CaseInsensitive (CI)
29−import Network.HTTP.Types (hAccept, hContentType)
29+import Network.HTTP.Types (Status)
30
30
31-- | Wrap json responses in a jsonp callback.
31-- | Wrap json responses in a jsonp callback.
32--
32--
@@ -37,7 +37,7 @@ import Network.HTTP.Types (hAccept, hContentType)
37-- callback function.
37-- callback function.
38jsonp :: Middleware
38jsonp :: Middleware
39jsonp app env sendResponse = do
39jsonp app env sendResponse = do
40− let accept = fromMaybe B8.empty $ lookup hAccept $ requestHeaders env
40+ let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env
41 let callback :: Maybe B8.ByteString
41 let callback :: Maybe B8.ByteString
42 callback =
42 callback =
43 if B8.pack "text/javascript" `B8.isInfixOf` accept
43 if B8.pack "text/javascript" `B8.isInfixOf` accept
@@ -47,7 +47,7 @@ jsonp app env sendResponse = do
47 case callback of
47 case callback of
48 Nothing -> env
48 Nothing -> env
49 Just _ -> env
49 Just _ -> env
50− { requestHeaders = changeVal hAccept
50+ { requestHeaders = changeVal "Accept"
51 "application/json"
51 "application/json"
52 $ requestHeaders env
52 $ requestHeaders env
53 }
53 }
@@ -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
@@ -72,18 +72,18 @@ jsonp app env sendResponse = do
72 (s, hs, wb) = responseToStream r
72 (s, hs, wb) = responseToStream r
73
73
74 checkJSON hs =
74 checkJSON hs =
75− case lookup hContentType hs of
75+ case lookup "Content-Type" hs of
76 Just x
76 Just x
77 | B8.pack "application/json" `S.isPrefixOf` x ->
77 | B8.pack "application/json" `S.isPrefixOf` x ->
78 Just $ fixHeaders hs
78 Just $ fixHeaders hs
79 _ -> Nothing
79 _ -> Nothing
80− fixHeaders = changeVal hContentType "text/javascript"
80+ fixHeaders = changeVal "Content-Type" "text/javascript"
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/Local.hs+1−1
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE OverloadedStrings, CPP #-}
2-- | Only allow local connections.
2-- | Only allow local connections.
3--
3--
4module Network.Wai.Middleware.Local
4module Network.Wai.Middleware.Local
wai-extra/Network/Wai/Middleware/MethodOverride.hs+6−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE OverloadedStrings #-}
1module Network.Wai.Middleware.MethodOverride
2module Network.Wai.Middleware.MethodOverride
2 ( methodOverride
3 ( methodOverride
3 ) where
4 ) where
@@ -5,11 +6,12 @@ module Network.Wai.Middleware.MethodOverride
5import Network.Wai
6import Network.Wai
6import Control.Monad (join)
7import Control.Monad (join)
7
8
8−-- | Overriding of HTTP request method via `_method` query string parameter.
9+-- | Allows overriding of the HTTP request method via the _method query string
10+-- parameter.
9--
11--
10−-- This middleware only applies when the initial request method is POST.
12+-- This middleware only applies when the initial request method is POST. This
11−-- Allows submitting of normal HTML forms, without worries of semantic
13+-- allow submitting of normal HTML forms, without worries of semantics
12−-- mismatches with the HTTP spec.
14+-- mismatches in the HTTP spec.
13methodOverride :: Middleware
15methodOverride :: Middleware
14methodOverride app req =
16methodOverride app req =
15 app req'
17 app req'
wai-extra/Network/Wai/Middleware/MethodOverridePost.hs+3−6
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE OverloadedStrings #-}
2-----------------------------------------------------------------
2-----------------------------------------------------------------
3-- | Module : Network.Wai.Middleware.MethodOverridePost
3-- | Module : Network.Wai.Middleware.MethodOverridePost
4--
4--
@@ -9,11 +9,8 @@ module Network.Wai.Middleware.MethodOverridePost
9 ) where
9 ) where
10
10
11import Network.Wai
11import Network.Wai
12−import Network.HTTP.Types (parseQuery, hContentType)
12+import Network.HTTP.Types (parseQuery)
13−
14−#if __GLASGOW_HASKELL__ < 710
15import Data.Monoid (mconcat, mempty)
13import Data.Monoid (mconcat, mempty)
16−#endif
17import Data.IORef
14import Data.IORef
18import Data.ByteString.Lazy (toChunks)
15import Data.ByteString.Lazy (toChunks)
19
16
@@ -30,7 +27,7 @@ import Data.ByteString.Lazy (toChunks)
30--
27--
31methodOverridePost :: Middleware
28methodOverridePost :: Middleware
32methodOverridePost app req send =
29methodOverridePost app req send =
33− case (requestMethod req, lookup hContentType (requestHeaders req)) of
30+ case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of
34 ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send
31 ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send
35 _ -> app req send
32 _ -> app req send
36
33
wai-extra/Network/Wai/Middleware/RequestLogger.hs+66−150
@@ -1,4 +1,6 @@
1+{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE RecordWildCards #-}
3+
2-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should
4-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should
3-- not use CPP.
5-- not use CPP.
4module Network.Wai.Middleware.RequestLogger
6module Network.Wai.Middleware.RequestLogger
@@ -13,80 +15,42 @@ module Network.Wai.Middleware.RequestLogger
13 , destination
15 , destination
14 , OutputFormat (..)
16 , OutputFormat (..)
15 , OutputFormatter
17 , OutputFormatter
16− , OutputFormatterWithDetails
17− , OutputFormatterWithDetailsAndHeaders
18 , Destination (..)
18 , Destination (..)
19 , Callback
19 , Callback
20 , IPAddrSource (..)
20 , IPAddrSource (..)
21 ) where
21 ) where
22
22
23−import System.IO (Handle, hFlush, stdout)
23+import System.IO (Handle, stdout)
24−import qualified Data.ByteString.Builder as B (Builder, byteString)
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)
27−import Control.Monad (when)
28import Control.Monad.IO.Class (liftIO)
26import Control.Monad.IO.Class (liftIO)
29−import Network.Wai
30− ( Request(..), requestBodyLength, RequestBodyLength(..)
31− , Middleware
32− , Response, responseStatus, responseHeaders
27+import Network.Wai (Request(..), Middleware, responseStatus, Response, responseHeaders)
33− )
34import System.Log.FastLogger
28import System.Log.FastLogger
35import Network.HTTP.Types as H
29import Network.HTTP.Types as H
36import Data.Maybe (fromMaybe)
30import Data.Maybe (fromMaybe)
37import Data.Monoid (mconcat, (<>))
31import Data.Monoid (mconcat, (<>))
38−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
32+import Data.Time (getCurrentTime, diffUTCTime)
33+
39−import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File
34+import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
40− , getRequestBodyType)
41import qualified Data.ByteString.Lazy as LBS
35import qualified Data.ByteString.Lazy as LBS
42import qualified Data.ByteString.Char8 as S8
36import qualified Data.ByteString.Char8 as S8
37+
43import System.Console.ANSI
38import System.Console.ANSI
44−import Data.IORef
39+import Data.IORef.Lifted
45import System.IO.Unsafe
40import System.IO.Unsafe
41+import Control.Monad (unless)
46−import Network.Wai.Internal (Response (..))
42+import Network.Wai.Internal (Response (ResponseRaw))
43+
47import Data.Default.Class (Default (def))
44import Data.Default.Class (Default (def))
48import Network.Wai.Logger
45import Network.Wai.Logger
49import Network.Wai.Middleware.RequestLogger.Internal
46import Network.Wai.Middleware.RequestLogger.Internal
50−import Network.Wai.Header (contentLength)
51−import Data.Text.Encoding (decodeUtf8')
52
47
53−data OutputFormat
54− = Apache IPAddrSource
48+data OutputFormat = Apache IPAddrSource
55− | Detailed Bool -- ^ use colors?
49+ | Detailed Bool -- ^ use colors?
56− | CustomOutputFormat OutputFormatter
50+ | CustomOutputFormat OutputFormatter
57− | CustomOutputFormatWithDetails OutputFormatterWithDetails
58− | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders
59
51
60type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr
52type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr
61
53
62−type OutputFormatterWithDetails
63− = ZonedDate
64− -> Request
65− -> Status
66− -> Maybe Integer
67− -> NominalDiffTime
68− -> [S8.ByteString]
69− -> B.Builder
70− -> LogStr
71−
72−-- | Same as @OutputFormatterWithDetails@ but with response headers included
73−--
74−-- This is useful if you wish to include arbitrary application data in your
75−-- logs, e.g., an authenticated user ID, which you would set in a response
76−-- header in your application and retrieve in the log formatter.
77−--
78−-- @since 3.0.27
79−type OutputFormatterWithDetailsAndHeaders
80− = ZonedDate -- ^ When the log message was generated
81− -> Request -- ^ The WAI request
82− -> Status -- ^ HTTP status code
83− -> Maybe Integer -- ^ Response size
84− -> NominalDiffTime -- ^ Duration of the request
85− -> [S8.ByteString] -- ^ The request body
86− -> B.Builder -- ^ Raw response
87− -> [Header] -- ^ The response headers
88− -> LogStr
89−
90data Destination = Handle Handle
54data Destination = Handle Handle
91 | Logger LoggerSet
55 | Logger LoggerSet
92 | Callback Callback
56 | Callback Callback
@@ -121,85 +85,48 @@ mkRequestLogger :: RequestLoggerSettings -> IO Middleware
121mkRequestLogger RequestLoggerSettings{..} = do
85mkRequestLogger RequestLoggerSettings{..} = do
122 let (callback, flusher) =
86 let (callback, flusher) =
123 case destination of
87 case destination of
124− Handle h -> (BS.hPutStr h . logToByteString, when autoFlush (hFlush h))
88+ Handle h -> (BS.hPutStr h . logToByteString, return ())
125− Logger l -> (pushLogStr l, when autoFlush (flushLogStr l))
89+ Logger l -> (pushLogStr l, flushLogStr l)
126 Callback c -> (c, return ())
90 Callback c -> (c, return ())
127− callbackAndFlush str = callback str >> flusher
128 case outputFormat of
91 case outputFormat of
129 Apache ipsrc -> do
92 Apache ipsrc -> do
130 getdate <- getDateGetter flusher
93 getdate <- getDateGetter flusher
131− apache <- initLogger ipsrc (LogCallback callback flusher) getdate
94+ apache <- initLogger ipsrc (LogCallback callback (return ())) getdate
132 return $ apacheMiddleware apache
95 return $ apacheMiddleware apache
133− Detailed useColors -> detailedMiddleware callbackAndFlush useColors
96+ Detailed useColors -> detailedMiddleware
97+ (\str -> callback str >> flusher)
98+ useColors
134 CustomOutputFormat formatter -> do
99 CustomOutputFormat formatter -> do
135− getDate <- getDateGetter flusher
136− return $ customMiddleware callbackAndFlush getDate formatter
137− CustomOutputFormatWithDetails formatter -> do
138− getdate <- getDateGetter flusher
139− return $ customMiddlewareWithDetails callbackAndFlush getdate formatter
140− CustomOutputFormatWithDetailsAndHeaders formatter -> do
141 getdate <- getDateGetter flusher
100 getdate <- getDateGetter flusher
142− return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter
101+ return $ customMiddleware callback getdate formatter
143
102
144apacheMiddleware :: ApacheLoggerActions -> Middleware
103apacheMiddleware :: ApacheLoggerActions -> Middleware
145apacheMiddleware ala app req sendResponse = app req $ \res -> do
104apacheMiddleware ala app req sendResponse = app req $ \res -> do
146− let msize = contentLength (responseHeaders res)
105+ let msize = lookup "content-length" (responseHeaders res) >>= readInt'
106+ readInt' bs =
107+ case S8.readInteger bs of
108+ Just (i, "") -> Just i
109+ _ -> Nothing
147 apacheLogger ala req (responseStatus res) msize
110 apacheLogger ala req (responseStatus res) msize
148 sendResponse res
111 sendResponse res
149
112
150customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
113customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
151customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do
114customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do
152 date <- liftIO getdate
115 date <- liftIO getdate
153− let msize = contentLength (responseHeaders res)
116+ -- We use Nothing for the response size since we generally don't know it
154− liftIO $ cb $ formatter date req (responseStatus res) msize
117+ liftIO $ cb $ formatter date req (responseStatus res) Nothing
155 sendResponse res
118 sendResponse res
156
119
157−customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware
158−customMiddlewareWithDetails cb getdate formatter app req sendResponse = do
159− (req', reqBody) <- getRequestBody req
160− t0 <- getCurrentTime
161− app req' $ \res -> do
162− t1 <- getCurrentTime
163− date <- liftIO getdate
164− let msize = contentLength (responseHeaders res)
165− builderIO <- newIORef $ B.byteString ""
166− res' <- recordChunks builderIO res
167− rspRcv <- sendResponse res'
168− _ <- liftIO . cb .
169− formatter date req' (responseStatus res') msize (t1 `diffUTCTime` t0) reqBody =<<
170− readIORef builderIO
171− return rspRcv
172−
173−customMiddlewareWithDetailsAndHeaders :: Callback -> IO ZonedDate -> OutputFormatterWithDetailsAndHeaders -> Middleware
174−customMiddlewareWithDetailsAndHeaders cb getdate formatter app req sendResponse = do
175− (req', reqBody) <- getRequestBody req
176− t0 <- getCurrentTime
177− app req' $ \res -> do
178− t1 <- getCurrentTime
179− date <- liftIO getdate
180− let msize = contentLength (responseHeaders res)
181− builderIO <- newIORef $ B.byteString ""
182− res' <- recordChunks builderIO res
183− rspRcv <- sendResponse res'
184− _ <- do
185− rawResponse <- readIORef builderIO
186− let status = responseStatus res'
187− duration = t1 `diffUTCTime` t0
188− resHeaders = responseHeaders res'
189− liftIO . cb $ formatter date req' status msize duration reqBody rawResponse resHeaders
190− return rspRcv
191-- | Production request logger middleware.
120-- | Production request logger middleware.
192−--
121+-- Implemented on top of "logCallback", but prints to 'stdout'
193−-- This uses the 'Apache' logging format, and takes IP addresses for clients from
194−-- the socket (see 'IPAddrSource' for more information). It logs to 'stdout'.
195−{-# NOINLINE logStdout #-}
196logStdout :: Middleware
122logStdout :: Middleware
197logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }
123logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }
198
124
199-- | Development request logger middleware.
125-- | Development request logger middleware.
126+-- Implemented on top of "logCallbackDev", but prints to 'stdout'
200--
127--
201−-- This uses the 'Detailed' 'True' logging format and logs to 'stdout'.
128+-- Flushes 'stdout' on each request, which would be inefficient in production use.
202−{-# NOINLINE logStdoutDev #-}
129+-- Use "logStdout" in production.
203logStdoutDev :: Middleware
130logStdoutDev :: Middleware
204logStdoutDev = unsafePerformIO $ mkRequestLogger def
131logStdoutDev = unsafePerformIO $ mkRequestLogger def
205
132
@@ -259,63 +186,49 @@ ansiStatusCode' c t = case S8.take 1 c of
259 "5" -> ansiColor' Magenta t
186 "5" -> ansiColor' Magenta t
260 _ -> ansiColor' Blue t
187 _ -> ansiColor' Blue t
261
188
262−recordChunks :: IORef B.Builder -> Response -> IO Response
263−recordChunks i (ResponseStream s h sb) =
264− return . ResponseStream s h $ (\send flush -> sb (\b -> modifyIORef i (<> b) >> send b) flush)
265−recordChunks i (ResponseBuilder s h b) =
266− modifyIORef i (<> b) >> (return $ ResponseBuilder s h b)
267−recordChunks _ r =
268− return r
269−
270−getRequestBody :: Request -> IO (Request, [S8.ByteString])
271−getRequestBody req = do
272− let loop front = do
273− bs <- requestBody req
274− if S8.null bs
275− then return $ front []
276− else loop $ front . (bs:)
277− body <- loop id
278− -- logging the body here consumes it, so fill it back up
279− -- obviously not efficient, but this is the development logger
280− --
281− -- Note: previously, we simply used CL.sourceList. However,
282− -- that meant that you could read the request body in twice.
283− -- While that in itself is not a problem, the issue is that,
284− -- in production, you wouldn't be able to do this, and
285− -- therefore some bugs wouldn't show up during testing. This
286− -- implementation ensures that each chunk is only returned
287− -- once.
288− ichunks <- newIORef body
289− let rbody = atomicModifyIORef ichunks $ \chunks ->
290− case chunks of
291− [] -> ([], S8.empty)
292− x:y -> (y, x)
293− let req' = req { requestBody = rbody }
294− return (req', body)
295−
296detailedMiddleware' :: Callback
189detailedMiddleware' :: Callback
297 -> (Color -> BS.ByteString -> [BS.ByteString])
190 -> (Color -> BS.ByteString -> [BS.ByteString])
298 -> (BS.ByteString -> [BS.ByteString])
191 -> (BS.ByteString -> [BS.ByteString])
299 -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
192 -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
300 -> Middleware
193 -> Middleware
301detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do
194detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do
195+ let mlen = lookup "content-length" (requestHeaders req) >>= readInt
302 (req', body) <-
196 (req', body) <-
303− -- second tuple item should not be necessary, but a test runner might mess it up
197+ case mlen of
304− case (requestBodyLength req, contentLength (requestHeaders req)) of
305 -- log the request body if it is small
198 -- log the request body if it is small
306− (KnownLength len, _) | len <= 2048 -> getRequestBody req
307− (_, Just len) | len <= 2048 -> getRequestBody req
199+ Just len | len <= 2048 -> do
200+ let loop front = do
201+ bs <- requestBody req
202+ if S8.null bs
203+ then return $ front []
204+ else loop $ front . (bs:)
205+ body <- loop id
206+ -- logging the body here consumes it, so fill it back up
207+ -- obviously not efficient, but this is the development logger
208+ --
209+ -- Note: previously, we simply used CL.sourceList. However,
210+ -- that meant that you could read the request body in twice.
211+ -- While that in itself is not a problem, the issue is that,
212+ -- in production, you wouldn't be able to do this, and
213+ -- therefore some bugs wouldn't show up during testing. This
214+ -- implementation ensures that each chunk is only returned
215+ -- once.
216+ ichunks <- newIORef body
217+ let rbody = atomicModifyIORef ichunks $ \chunks ->
218+ case chunks of
219+ [] -> ([], S8.empty)
220+ x:y -> (y, x)
221+ let req' = req { requestBody = rbody }
222+ return (req', body)
308 _ -> return (req, [])
223 _ -> return (req, [])
309
224
310− let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"]
311− reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body
312 postParams <- if requestMethod req `elem` ["GET", "HEAD"]
225 postParams <- if requestMethod req `elem` ["GET", "HEAD"]
313 then return []
226 then return []
314 else do postParams <- liftIO $ allPostParams body
227 else do postParams <- liftIO $ allPostParams body
315 return $ collectPostParams postParams
228 return $ collectPostParams postParams
316
229
317 let getParams = map emptyGetParam $ queryString req
230 let getParams = map emptyGetParam $ queryString req
318− accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req
231+ accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
319 params = let par | not $ null postParams = [pack (show postParams)]
232 params = let par | not $ null postParams = [pack (show postParams)]
320 | not $ null getParams = [pack (show getParams)]
233 | not $ null getParams = [pack (show getParams)]
321 | otherwise = []
234 | otherwise = []
@@ -334,7 +247,7 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse
334 -- log the status of the response
247 -- log the status of the response
335 cb $ mconcat $ map toLogStr $
248 cb $ mconcat $ map toLogStr $
336 ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++
249 ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++
337− params ++ reqbody ++
250+ params ++
338 ansiColor White " Accept: " ++ [accept, "\n"] ++
251 ansiColor White " Accept: " ++ [accept, "\n"] ++
339 if isRaw then [] else
252 if isRaw then [] else
340 ansiColor White " Status: " ++
253 ansiColor White " Status: " ++
@@ -362,7 +275,10 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse
362 collectPostParams (postParams, files) = postParams ++
275 collectPostParams (postParams, files) = postParams ++
363 map (\(k,v) -> (k, "FILE: " <> fileName v)) files
276 map (\(k,v) -> (k, "FILE: " <> fileName v)) files
364
277
365−
278+ readInt bs =
279+ case reads $ unpack bs of
280+ (i, _):_ -> Just (i :: Int)
281+ [] -> Nothing
366
282
367statusBS :: Response -> BS.ByteString
283statusBS :: Response -> BS.ByteString
368statusBS = pack . show . statusCode . responseStatus
284statusBS = pack . show . statusCode . responseStatus
wai-extra/Network/Wai/Middleware/RequestLogger/Internal.hs+2−6
@@ -8,10 +8,9 @@ module Network.Wai.Middleware.RequestLogger.Internal
8
8
9import Data.ByteString (ByteString)
9import Data.ByteString (ByteString)
10import Network.Wai.Logger (clockDateCacher)
10import Network.Wai.Logger (clockDateCacher)
11−#if !MIN_VERSION_wai_logger(2, 2, 0)
12import Control.Concurrent (forkIO, threadDelay)
11import Control.Concurrent (forkIO, threadDelay)
13import Control.Monad (forever)
12import Control.Monad (forever)
14−#endif
13+
15import System.Log.FastLogger (LogStr, fromLogStr)
14import System.Log.FastLogger (LogStr, fromLogStr)
16
15
17logToByteString :: LogStr -> ByteString
16logToByteString :: LogStr -> ByteString
@@ -19,15 +18,12 @@ logToByteString = fromLogStr
19
18
20getDateGetter :: IO () -- ^ flusher
19getDateGetter :: IO () -- ^ flusher
21 -> IO (IO ByteString)
20 -> IO (IO ByteString)
22−#if !MIN_VERSION_wai_logger(2, 2, 0)
23getDateGetter flusher = do
21getDateGetter flusher = do
24 (getter, updater) <- clockDateCacher
22 (getter, updater) <- clockDateCacher
23+#if !MIN_VERSION_wai_logger(2, 2, 0)
25 _ <- forkIO $ forever $ do
24 _ <- forkIO $ forever $ do
26 threadDelay 1000000
25 threadDelay 1000000
27 updater
26 updater
28 flusher
27 flusher
29−#else
30−getDateGetter _ = do
31− (getter, _) <- clockDateCacher
32#endif
28#endif
33 return getter
29 return getter
wai-extra/Network/Wai/Middleware/RequestLogger/JSON.hsdeleted−137
@@ -1,137 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE CPP #-}
3−
4−module Network.Wai.Middleware.RequestLogger.JSON
5− ( formatAsJSON
6− , formatAsJSONWithHeaders
7− ) where
8−
9−import qualified Data.ByteString.Builder as BB (toLazyByteString)
10−import Data.ByteString.Lazy (toStrict)
11−import Data.Aeson
12−import Data.CaseInsensitive (original)
13−import Data.Monoid ((<>))
14−import qualified Data.ByteString.Char8 as S8
15−import Data.IP
16−import qualified Data.Text as T
17−import Data.Text (Text)
18−import Data.Text.Encoding (decodeUtf8With)
19−import Data.Text.Encoding.Error (lenientDecode)
20−import Data.Time (NominalDiffTime)
21−import Data.Word (Word32)
22−import Network.HTTP.Types as H
23−import Network.Socket (SockAddr (..), PortNumber)
24−import Network.Wai
25−import Network.Wai.Middleware.RequestLogger
26−import System.Log.FastLogger (toLogStr)
27−import Text.Printf (printf)
28−
29−formatAsJSON :: OutputFormatterWithDetails
30−formatAsJSON date req status responseSize duration reqBody response =
31− toLogStr (encode $
32− object
33− [ "request" .= requestToJSON duration req reqBody
34− , "response" .=
35− object
36− [ "status" .= statusCode status
37− , "size" .= responseSize
38− , "body" .=
39− if statusCode status >= 400
40− then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ response
41− else Nothing
42− ]
43− , "time" .= decodeUtf8With lenientDecode date
44− ]) <> "\n"
45−
46−-- | Same as @formatAsJSON@ but with response headers included
47−--
48−-- This is useful for passing arbitrary data from your application out to the
49−-- WAI layer for it to be logged, but you may need to be careful to
50−-- subsequently redact any headers which may contain sensitive data.
51−--
52−-- @since 3.0.27
53−formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders
54−formatAsJSONWithHeaders date req status resSize duration reqBody res resHeaders =
55− toLogStr (encode $
56− object
57− [ "request" .= requestToJSON duration req reqBody
58− , "response" .= object
59− [ "status" .= statusCode status
60− , "size" .= resSize
61− , "headers" .= responseHeadersToJSON resHeaders
62− , "body" .=
63− if statusCode status >= 400
64− then Just . decodeUtf8With lenientDecode . toStrict . BB.toLazyByteString $ res
65− else Nothing
66− ]
67− , "time" .= decodeUtf8With lenientDecode date
68− ]) <> "\n"
69−
70−word32ToHostAddress :: Word32 -> Text
71−word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress
72−
73−readAsDouble :: String -> Double
74−readAsDouble = read
75−
76−requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value
77−requestToJSON duration req reqBody =
78− object
79− [ "method" .= decodeUtf8With lenientDecode (requestMethod req)
80− , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)
81− , "queryString" .= map queryItemToJSON (queryString req)
82− , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)
83− , "size" .= requestBodyLengthToJSON (requestBodyLength req)
84− , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody)
85− , "remoteHost" .= sockToJSON (remoteHost req)
86− , "httpVersion" .= httpVersionToJSON (httpVersion req)
87− , "headers" .= requestHeadersToJSON (requestHeaders req)
88− ]
89− where
90− rationalToDouble :: Rational -> Double
91− rationalToDouble = fromRational
92−
93−sockToJSON :: SockAddr -> Value
94−sockToJSON (SockAddrInet pn ha) =
95− object
96− [ "port" .= portToJSON pn
97− , "hostAddress" .= word32ToHostAddress ha
98− ]
99−sockToJSON (SockAddrInet6 pn _ ha _) =
100− object
101− [ "port" .= portToJSON pn
102− , "hostAddress" .= ha
103− ]
104−sockToJSON (SockAddrUnix sock) =
105− object [ "unix" .= sock ]
106−#if !MIN_VERSION_network(3,0,0)
107−sockToJSON (SockAddrCan i) =
108− object [ "can" .= i ]
109−#endif
110−
111−queryItemToJSON :: QueryItem -> Value
112−queryItemToJSON (name, mValue) = toJSON (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue)
113−
114−requestHeadersToJSON :: RequestHeaders -> Value
115−requestHeadersToJSON = toJSON . map hToJ where
116− -- Redact cookies
117− hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)
118− hToJ hd = headerToJSON hd
119−
120−responseHeadersToJSON :: [Header] -> Value
121−responseHeadersToJSON = toJSON . map hToJ where
122− -- Redact cookies
123− hToJ ("Set-Cookie", _) = toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)
124− hToJ hd = headerToJSON hd
125−
126−headerToJSON :: Header -> Value
127−headerToJSON (headerName, header) = toJSON (decodeUtf8With lenientDecode . original $ headerName, decodeUtf8With lenientDecode header)
128−
129−portToJSON :: PortNumber -> Value
130−portToJSON = toJSON . toInteger
131−
132−httpVersionToJSON :: HttpVersion -> Value
133−httpVersionToJSON (HttpVersion major minor) = String $ T.pack (show major) <> "." <> T.pack (show minor)
134−
135−requestBodyLengthToJSON :: RequestBodyLength -> Value
136−requestBodyLengthToJSON ChunkedBody = String "Unknown"
137−requestBodyLengthToJSON (KnownLength l) = toJSON l
wai-extra/Network/Wai/Middleware/Rewrite.hs+15−321
@@ -1,339 +1,33 @@
1−{-# LANGUAGE TupleSections #-}
1+{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE CPP #-}
3−
4module Network.Wai.Middleware.Rewrite
2module Network.Wai.Middleware.Rewrite
5− ( -- * How to use this module
6− -- $howto
7−
8− -- ** A note on semantics
9−
10− -- $semantics
11−
12− -- ** Paths and Queries
13−
14− -- $pathsandqueries
15− PathsAndQueries
16−
17− -- ** An example rewriting paths with queries
18−
19− -- $takeover
20−
21− -- ** Upgrading from wai-extra ≤ 3.0.16.1
22−
23− -- $upgrading
24−
25− -- * 'Middleware'
26−
27− -- ** Recommended functions
28− , rewriteWithQueries
29− , rewritePureWithQueries
30− , rewriteRoot
31−
32− -- ** Deprecated
33− , rewrite
34− , rewritePure
3+ ( rewrite, rewritePure
35−
36− -- * Operating on 'Request's
37−
38− , rewriteRequest
39− , rewriteRequestPure
40 ) where
4 ) where
41
5
42import Network.Wai
6import Network.Wai
43import Control.Monad.IO.Class (liftIO)
7import Control.Monad.IO.Class (liftIO)
44import Data.Text (Text)
8import Data.Text (Text)
45−import Data.Functor.Identity (Identity(..))
46import qualified Data.Text.Encoding as TE
9import qualified Data.Text.Encoding as TE
47import qualified Data.Text as T
10import qualified Data.Text as T
48import Network.HTTP.Types as H
11import Network.HTTP.Types as H
49
12
50−-- GHC ≤ 7.10 does not export Applicative functions from the prelude.
51−#if __GLASGOW_HASKELL__ <= 710
52−import Control.Applicative
53−#endif
54−
55−-- $howto
56−-- This module provides 'Middleware' to rewrite URL paths. It also provides
57−-- functions that will convert a 'Request' to a modified 'Request'.
58−-- Both operations require a function that takes URL parameters and
59−-- headers, and returns new URL parameters. Parameters are pieces of URL
60−-- paths and query parameters.
61−--
62−-- If you are a new user of the library, use 'rewriteWithQueries' or
63−-- 'rewritePureWithQueries' for middleware. For modifying 'Request's
64−-- directly, use 'rewriteRequest' or 'rewriteRequestPure'.
65
13
66−-- $semantics
14+-- | rewrite based on your own conversion rules
67−--
15+rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware
68−-- Versions of this library in wai-extra ≤ 3.0.16.1 exported only
16+rewrite convert app req sendResponse = do
69−-- 'rewrite' and 'rewritePure' and both modified 'rawPathInfo' of the
17+ newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)
70−-- underlying requests. Such modification has been proscribed. The
18+ let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo
71−-- semantics of these functions have not changed; instead the recommended
19+ app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } sendResponse
72−-- approach is to use 'rewriteWithQueries' and 'rewritePureWithQueries'.
73−-- The new functions are slightly different, as described in the section
74−-- on upgrading; code for previous library versions can be upgraded with
75−-- a single change, and as the type of the new function is different the
76−-- compiler will indicate where this change must be made.
77−--
78−-- The 'rewriteRequest' and 'rewriteRequestPure' functions use the new
79−-- semantics, too.
80−
81−-- $pathsandqueries
82−--
83−-- This library defines the type synonym `PathsAndQueries` to make code
84−-- handling paths and queries easier to read.
85−--
86−-- /e.g./ /\/foo\/bar/ would look like
87−--
88−-- > ["foo", "bar"] :: Text
89−--
90−-- /?bar=baz/ would look like
91−--
92−-- > [("bar", Just "baz")] :: QueryText
93−--
94−-- Together,
95−--
96−-- /\/foo?bar=baz/ would look like
97−--
98−-- > (["foo"],[("bar", Just "baz")]) :: PathsAndQueries
99
20
100−-- $takeover
21+-- | rewrite based on your own conversion rules
101−-- Let’s say we want to replace a website written in PHP with one written
22+-- Example convert function:
102−-- using WAI. We’ll use the
103−-- <https://hackage.haskell.org/package/http-reverse-proxy http-reverse-proxy>
104−-- package to serve the old
105−-- site from the new site, but there’s a problem. The old site uses pages like
106−--
107−-- @
108−-- index.php?page=/page/
109−-- @
110−--
111−-- whereas the new site would look like
112−--
113−-- @
114−-- index\//page/
115−-- @
116−--
117−-- In doing this, we want to separate the migration code from our new
118−-- website. So we’d like to handle links internally using the path
119−-- formulation, but externally have the old links still work.
120−--
121−-- Therefore, we will use middleware ('rewritePureWithQueries') from this
122−-- module to rewrite incoming requests from the query formulation to the
123−-- paths formulation.
124−--
125−-- > {-# LANGUAGE ViewPatterns #-}
126−-- >
127−-- > rewritePathFromPhp :: Middleware
128−-- > rewritePathFromPhp = rewritePureWithQueries pathFromPhp
129−-- >
130−-- > pathFromPhp :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries
131−-- > pathFromPhp (pieces, queries) _ = piecesConvert pieces queries
132−-- > where
133−-- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries
134−-- > piecesConvert ["index.php"] qs@(join . lookup "page" -> Just page) =
135−-- > ( ["index", TE.decodeUtf8With TE.lenientDecode page]
136−-- > , delete ("page", pure page) qs
137−-- > )
138−-- > piecesConvert ps qs = (ps, qs)
139−--
140−-- On the other side, we will use 'rewriteRequestPure' to rewrite outgoing
141−-- requests to the original website from the reverse proxy code (using the
142−-- 'Network.HTTP.ReverseProxy.WPRModifiedRequest' or
143−-- 'Network.HTTP.ReverseProxy.WPRModifiedRequestSecure' constructors. Note,
144−-- these links will only work if the haddock documentation for
145−-- <https://hackage.haskell.org/package/http-reverse-proxy http-reverse-proxy>
146−-- is installed).
147−--
148−-- > rewritePhpFromPath :: Request -> Request
149−-- > rewritePhpFromPath = rewriteRequestPure phpFromPath
150−-- >
151−-- > phpFromPath :: PathsAndQueries -> H.RequestHeaders -> PathsAndQueries
152−-- > phpFromPath (pieces, queries) _ = piecesConvert pieces queries
153−-- > where
154−-- > piecesConvert :: [Text] -> H.Query -> PathsAndQueries
155−-- > piecesConvert ["index", page] qs = ( ["index.php"], ("page", pure . TE.encodeUtf8 $ page) : qs )
156−-- > piecesConvert ps qs = (ps, qs)
157−--
158−-- For the whole example, see
159−-- <https://gist.github.com/dbaynard/c844d0df124f68ec8b6da152c581ce6d>.
160
23
161−-- $upgrading
162−-- It is quite simple to upgrade from 'rewrite' and 'rewritePure', to
163−-- 'rewriteWithQueries' and 'rewritePureWithQueries'.
164−-- Insert 'Data.Bifunctor.first', which specialises to
165−--
166−-- @
167−-- 'Data.Bifunctor.first' :: (['Text'] -> ['Text']) -> 'PathsAndQueries' -> 'PathsAndQueries'
168−-- @
169−--
170−-- as the following example demonstrates.
171−--
172−-- Old versions of the library could only handle path pieces, not queries.
173−-- This could have been supplied to 'rewritePure'.
174−--
175−-- @
176−-- staticConvert' :: [Text] -> H.RequestHeaders -> [Text]
24+-- staticConvert :: [Text] -> H.RequestHeaders -> [Text]
177−-- staticConvert' pieces _ = piecesConvert pieces
25+-- staticConvert pieces _ = piecesConvert pieces
178−-- where
179−-- piecesConvert [] = ["static", "html", "pages.html"]
180−-- piecesConvert route@("pages":_) = "static":"html":route
181−-- @
182−--
183−-- Instead, use this function, supplied to 'rewritePureWithQueries'.
184−--
185−-- @
186−-- staticConvert :: 'PathsAndQueries' -> H.RequestHeaders -> 'PathsAndQueries'
187−-- staticConvert pathsAndQueries _ = 'Data.Bifunctor.first' piecesConvert pathsAndQueries
188-- where
26-- where
189-- piecesConvert [] = ["static", "html", "pages.html"]
27-- piecesConvert [] = ["static", "html", "pages.html"]
190-- piecesConvert route@("pages":_) = "static":"html":route
28-- piecesConvert route@("pages":_) = "static":"html":route
191−-- @
192−--
193−-- The former formulation is deprecated for two reasons:
194−--
195−-- 1. The original formulation of 'rewrite' modified 'rawPathInfo', which
196−-- is deprecated behaviour.
197−--
198−-- 2. The original formulation did not allow query parameters to
199−-- influence the path.
200−--
201−-- Concerning the first point, take care with semantics of your program when
202−-- upgrading as the upgraded functions no longer modify 'rawPathInfo'.
203−
204−--------------------------------------------------
205−-- * Types
206−--------------------------------------------------
207−
208−-- | A tuple of the path sections as ['Text'] and query parameters as
209−-- 'H.Query'. This makes writing type signatures for the conversion
210−-- function far more pleasant.
211−--
212−-- Note that this uses 'H.Query' not 'H.QueryText' to more accurately
213−-- reflect the paramaters that can be supplied in URLs. It may be safe to
214−-- treat parameters as text; use the 'H.queryToQueryText' and
215−-- 'H.queryTextToQuery' functions to interconvert.
216−type PathsAndQueries = ([Text], H.Query)
217−
218−--------------------------------------------------
219−-- * Rewriting 'Middleware'
220−--------------------------------------------------
221−
222−-- | Rewrite based on your own conversion function for paths only, to be
223−-- supplied by users of this library (with the conversion operating in 'IO').
224−--
225−-- For new code, use 'rewriteWithQueries' instead.
226−rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware
227−rewrite convert app req sendResponse = do
228− let convertIO = pathsOnly . curry $ liftIO . uncurry convert
229− newReq <- rewriteRequestRawM convertIO req
230− app newReq sendResponse
231−{-# WARNING rewrite [
232− "This modifies the 'rawPathInfo' field of a 'Request'."
233− , " This is not recommended behaviour; it is however how"
234− , " this function has worked in the past."
235− , " Use 'rewriteWithQueries' instead"] #-}
236−
237−-- | Rewrite based on pure conversion function for paths only, to be
238−-- supplied by users of this library.
239−--
240−-- For new code, use 'rewritePureWithQueries' instead.
241rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware
29rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware
242rewritePure convert app req =
30rewritePure convert app req =
243− let convertPure = pathsOnly . curry $ Identity . uncurry convert
244− newReq = runIdentity $ rewriteRequestRawM convertPure req
245− in app newReq
246−{-# WARNING rewritePure [
247− "This modifies the 'rawPathInfo' field of a 'Request'."
248− , " This is not recommended behaviour; it is however how"
249− , " this function has worked in the past."
250− , " Use 'rewritePureWithQueries' instead"] #-}
251−
252−-- | Rewrite based on your own conversion function for paths and queries.
253−-- This function is to be supplied by users of this library, and operates
254−-- in 'IO'.
255−rewriteWithQueries :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)
256− -> Middleware
257−rewriteWithQueries convert app req sendResponse = do
258− newReq <- rewriteRequestM convert req
259− app newReq sendResponse
260−
261−-- | Rewrite based on pure conversion function for paths and queries. This
262−-- function is to be supplied by users of this library.
263−rewritePureWithQueries :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)
264− -> Middleware
265−rewritePureWithQueries convert app req = app $ rewriteRequestPure convert req
266−
267−-- | Rewrite root requests (/) to a specified path
268−--
269−-- Note that /index.html/ in example below should already be a valid route.
270−--
271−-- @
272−-- rewriteRoot "index.html" :: Middleware
273−-- @
274−--
275−-- @since 3.0.23.0
276−rewriteRoot :: Text -> Middleware
277−rewriteRoot root = rewritePureWithQueries onlyRoot
278− where
279− onlyRoot ([], q) _ = ([root], q)
280− onlyRoot paths _ = paths
281−
282−--------------------------------------------------
283−-- * Modifying 'Request's directly
284−--------------------------------------------------
285−
286−-- | Modify a 'Request' using the supplied function in 'IO'. This is suitable for
287−-- the reverse proxy example.
288−rewriteRequest :: (PathsAndQueries -> H.RequestHeaders -> IO PathsAndQueries)
289− -> Request -> IO Request
290−rewriteRequest convert req =
291− let convertIO = curry $ liftIO . uncurry convert
292− in rewriteRequestRawM convertIO req
293−
294−-- | Modify a 'Request' using the pure supplied function. This is suitable for
295−-- the reverse proxy example.
296−rewriteRequestPure :: (PathsAndQueries -> H.RequestHeaders -> PathsAndQueries)
297− -> Request -> Request
298−rewriteRequestPure convert req =
299− let convertPure = curry $ Identity . uncurry convert
300− in runIdentity $ rewriteRequestRawM convertPure req
301−
302−--------------------------------------------------
303−-- * Helper functions
304−--------------------------------------------------
305−
306−-- | This helper function factors out the common behaviour of rewriting requests.
307−rewriteRequestM :: (Applicative m, Monad m)
308− => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)
309− -> Request -> m Request
310−rewriteRequestM convert req = do
311− (pInfo, qByteStrings) <- curry convert (pathInfo req) (queryString req) (requestHeaders req)
31+ let pInfo = convert (pathInfo req) (requestHeaders req)
312− pure req {pathInfo = pInfo, queryString = qByteStrings}
313−
314−-- | This helper function preserves the semantics of wai-extra ≤ 3.0, in
315−-- which the rewrite functions modify the 'rawPathInfo' parameter. Note
316−-- that this has not been extended to modify the 'rawQueryInfo' as
317−-- modifying either of these values has been deprecated.
318−rewriteRequestRawM :: (Applicative m, Monad m)
319− => (PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries)
320− -> Request -> m Request
321−rewriteRequestRawM convert req = do
322− newReq <- rewriteRequestM convert req
323− let rawPInfo = TE.encodeUtf8 . T.intercalate "/" . pathInfo $ newReq
32+ rawPInfo = TE.encodeUtf8 $ T.intercalate "/" pInfo
324− pure newReq { rawPathInfo = rawPInfo }
33+ in app req { pathInfo = pInfo, rawPathInfo = rawPInfo }
325−{-# WARNING rewriteRequestRawM [
326− "This modifies the 'rawPathInfo' field of a 'Request'."
327− , " This is not recommended behaviour; it is however how"
328− , " this function has worked in the past."
329− , " Use 'rewriteRequestM' instead"] #-}
330−
331−-- | Produce a function that works on 'PathsAndQueries' from one working
332−-- only on paths. This is not exported, as it is only needed to handle
333−-- code written for versions ≤ 3.0 of the library; see the
334−-- example above using 'Data.Bifunctor.first' to do something similar.
335−pathsOnly :: (Applicative m, Monad m)
336− => ([Text] -> H.RequestHeaders -> m [Text])
337− -> PathsAndQueries -> H.RequestHeaders -> m PathsAndQueries
338−pathsOnly convert psAndQs headers = (,[]) <$> convert (fst psAndQs) headers
339−{-# INLINE pathsOnly #-}
wai-extra/Network/Wai/Middleware/Routed.hsdeleted−39
@@ -1,39 +0,0 @@
1−-- |
2−--
3−-- Since 3.0.9
4−module Network.Wai.Middleware.Routed
5− ( routedMiddleware
6− , hostedMiddleware
7− ) where
8−
9−import Network.Wai
10−import Data.ByteString (ByteString)
11−import Data.Text (Text)
12−
13−-- | Apply a middleware based on a test of pathInfo
14−--
15−-- example:
16−--
17−-- > let corsify = routedMiddleWare ("static" `elem`) addCorsHeaders
18−--
19−-- Since 3.0.9
20−routedMiddleware :: ([Text] -> Bool) -- ^ Only use middleware if this pathInfo test returns True
21− -> Middleware -- ^ middleware to apply the path prefix guard to
22− -> Middleware -- ^ modified middleware
23−routedMiddleware pathCheck middle app req
24− | pathCheck (pathInfo req) = middle app req
25− | otherwise = app req
26−
27−-- | Only apply the middleware to certain hosts
28−--
29−-- Since 3.0.9
30−hostedMiddleware :: ByteString -- ^ Domain the middleware applies to
31− -> Middleware -- ^ middleware to apply the path prefix guard to
32− -> Middleware -- ^ modified middleware
33−hostedMiddleware domain middle app req
34− | hasDomain domain req = middle app req
35− | otherwise = app req
36−
37−hasDomain :: ByteString -> Request -> Bool
38−hasDomain domain req = maybe False (== domain) mHost
39− where mHost = requestHeaderHost req
wai-extra/Network/Wai/Middleware/StreamFile.hs+3−2
@@ -1,3 +1,5 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
1-- |
3-- |
2--
4--
3-- Since 3.0.4
5-- Since 3.0.4
@@ -9,7 +11,6 @@ import Network.Wai.Internal
9import Network.Wai (Middleware, responseToStream)
11import Network.Wai (Middleware, responseToStream)
10import qualified Data.ByteString.Char8 as S8
12import qualified Data.ByteString.Char8 as S8
11import System.PosixCompat (getFileStatus, fileSize, FileOffset)
13import System.PosixCompat (getFileStatus, fileSize, FileOffset)
12−import Network.HTTP.Types (hContentLength)
13
14
14-- |Convert ResponseFile type responses into ResponseStream type
15-- |Convert ResponseFile type responses into ResponseStream type
15--
16--
@@ -33,7 +34,7 @@ streamFile app env sendResponse = app env $ \res ->
33 sendBody :: StreamingBody -> IO ResponseReceived
34 sendBody :: StreamingBody -> IO ResponseReceived
34 sendBody body = do
35 sendBody body = do
35 len <- getFileSize fp
36 len <- getFileSize fp
36− let hs' = (hContentLength, (S8.pack (show len))) : hs
37+ let hs' = ("Content-Length", (S8.pack (show len))) : hs
37 sendResponse $ responseStream s hs' body
38 sendResponse $ responseStream s hs' body
38 _ -> sendResponse res
39 _ -> sendResponse res
39
40
wai-extra/Network/Wai/Middleware/StripHeaders.hsdeleted−45
@@ -1,45 +0,0 @@
1−-- This was written for one specific use case and then generalized.
2−
3−-- The specific use case was a JSON API with a consumer that would choke on the
4−-- "Set-Cookie" response header. The solution was to test for the API's
5−-- `pathInfo` in the Request and if it matched, filter the response headers.
6−
7−-- When using this, care should be taken not to strip out headers that are
8−-- required for correct operation of the client (eg Content-Type).
9−
10−module Network.Wai.Middleware.StripHeaders
11− ( stripHeader
12− , stripHeaders
13− , stripHeaderIf
14− , stripHeadersIf
15− ) where
16−
17−import Network.Wai (Middleware, Request, modifyResponse, mapResponseHeaders, ifRequest)
18−import Network.Wai.Internal (Response)
19−import Data.ByteString (ByteString)
20−
21−import qualified Data.CaseInsensitive as CI
22−
23−stripHeader :: ByteString -> (Response -> Response)
24−stripHeader h = mapResponseHeaders (filter (\ hdr -> fst hdr /= CI.mk h))
25−
26−stripHeaders :: [ByteString] -> (Response -> Response)
27−stripHeaders hs =
28− let hnames = map CI.mk hs
29− in mapResponseHeaders (filter (\ hdr -> fst hdr `notElem` hnames))
30−
31−-- | If the request satisifes the provided predicate, strip headers matching
32−-- the provided header name.
33−--
34−-- Since 3.0.8
35−stripHeaderIf :: ByteString -> (Request -> Bool) -> Middleware
36−stripHeaderIf h rpred =
37− ifRequest rpred (modifyResponse $ stripHeader h)
38−
39−-- | If the request satisifes the provided predicate, strip all headers whose
40−-- header name is in the list of provided header names.
41−--
42−-- Since 3.0.8
43−stripHeadersIf :: [ByteString] -> (Request -> Bool) -> Middleware
44−stripHeadersIf hs rpred
45− = ifRequest rpred (modifyResponse $ stripHeaders hs)
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/Middleware/Vhost.hs+3−5
@@ -1,5 +1,5 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE OverloadedStrings #-}
2− module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where
2+module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where
3
3
4import Network.Wai
4import Network.Wai
5
5
@@ -7,9 +7,7 @@ import Network.HTTP.Types as H
7import qualified Data.Text.Encoding as TE
7import qualified Data.Text.Encoding as TE
8import Data.Text (Text)
8import Data.Text (Text)
9import qualified Data.ByteString as BS
9import qualified Data.ByteString as BS
10−#if __GLASGOW_HASKELL__ < 710
11import Data.Monoid (mappend)
10import Data.Monoid (mappend)
12−#endif
13
11
14vhost :: [(Request -> Bool, Application)] -> Application -> Application
12vhost :: [(Request -> Bool, Application)] -> Application -> Application
15vhost vhosts def req =
13vhost vhosts def req =
@@ -29,7 +27,7 @@ redirectIf home cond app req sendResponse =
29
27
30redirectTo :: BS.ByteString -> Response
28redirectTo :: BS.ByteString -> Response
31redirectTo location = responseLBS H.status301
29redirectTo location = responseLBS H.status301
32− [ (H.hContentType, "text/plain") , (H.hLocation, location) ] "Redirect"
30+ [ ("Content-Type", "text/plain") , ("Location", location) ] "Redirect"
33
31
34redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response
32redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response
35redirectToLogged logger loc = do
33redirectToLogged logger loc = do
wai-extra/Network/Wai/Parse.hs+86−368
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE PatternGuards #-}
4{-# LANGUAGE PatternGuards #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
@@ -11,7 +12,6 @@ module Network.Wai.Parse
11 , RequestBodyType (..)
12 , RequestBodyType (..)
12 , getRequestBodyType
13 , getRequestBodyType
13 , sinkRequestBody
14 , sinkRequestBody
14− , sinkRequestBodyEx
15 , BackEnd
15 , BackEnd
16 , lbsBackEnd
16 , lbsBackEnd
17 , tempFileBackEnd
17 , tempFileBackEnd
@@ -20,24 +20,6 @@ module Network.Wai.Parse
20 , File
20 , File
21 , FileInfo (..)
21 , FileInfo (..)
22 , parseContentType
22 , parseContentType
23− , ParseRequestBodyOptions
24− , defaultParseRequestBodyOptions
25− , noLimitParseRequestBodyOptions
26− , parseRequestBodyEx
27− , setMaxRequestKeyLength
28− , clearMaxRequestKeyLength
29− , setMaxRequestNumFiles
30− , clearMaxRequestNumFiles
31− , setMaxRequestFileSize
32− , clearMaxRequestFileSize
33− , setMaxRequestFilesSize
34− , clearMaxRequestFilesSize
35− , setMaxRequestParmsSize
36− , clearMaxRequestParmsSize
37− , setMaxHeaderLines
38− , clearMaxHeaderLines
39− , setMaxHeaderLineLength
40− , clearMaxHeaderLineLength
41#if TEST
23#if TEST
42 , Bound (..)
24 , Bound (..)
43 , findBound
25 , findBound
@@ -48,30 +30,21 @@ module Network.Wai.Parse
48#endif
30#endif
49 ) where
31 ) where
50
32
51−import qualified Control.Exception as E
33+import qualified Data.ByteString.Search as Search
52import qualified Data.ByteString as S
34import qualified Data.ByteString as S
53import qualified Data.ByteString.Lazy as L
35import qualified Data.ByteString.Lazy as L
54import qualified Data.ByteString.Char8 as S8
36import qualified Data.ByteString.Char8 as S8
55import Data.Word (Word8)
37import Data.Word (Word8)
56−import Data.Int (Int64)
57−import Data.Maybe (catMaybes, fromMaybe)
38+import Data.Maybe (fromMaybe)
58import Data.List (sortBy)
39import Data.List (sortBy)
59import Data.Function (on, fix)
40import Data.Function (on, fix)
60import System.Directory (removeFile, getTemporaryDirectory)
41import System.Directory (removeFile, getTemporaryDirectory)
61import System.IO (hClose, openBinaryTempFile)
42import System.IO (hClose, openBinaryTempFile)
62−import System.IO.Error (isDoesNotExistError)
63import Network.Wai
43import Network.Wai
64import qualified Network.HTTP.Types as H
44import qualified Network.HTTP.Types as H
65−import Control.Applicative ((<$>))
45+import Control.Monad (when, unless)
66−import Control.Exception (catchJust)
67−import Control.Monad (when, unless, guard)
68import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
46import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
69import Data.IORef
47import Data.IORef
70−import Network.HTTP.Types (hContentType)
71−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
72−import Data.CaseInsensitive (mk)
73−
74−import Prelude hiding (lines)
75
48
76breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
49breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
77breakDiscard w s =
50breakDiscard w s =
@@ -121,7 +94,7 @@ lbsBackEnd _ _ popper =
121tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
94tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
122tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"
95tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"
123
96
124−-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.
97+-- | Same as 'tempFileSink', but use configurable temp folders and patterns.
125tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
98tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
126 -> String -- ^ filename pattern
99 -> String -- ^ filename pattern
127 -> InternalState
100 -> InternalState
@@ -129,9 +102,11 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
129 -> ignored2
102 -> ignored2
130 -> IO S.ByteString
103 -> IO S.ByteString
131 -> IO FilePath
104 -> IO FilePath
132−tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
105+tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do
133− (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
106+ (key, (fp, h)) <- flip runInternalState internalState $ allocate (do
107+ tempDir <- getTmpDir
108+ openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)
134− _ <- runInternalState (register $ removeFileQuiet fp) internalState
109+ _ <- runInternalState (register $ removeFile fp) internalState
135 fix $ \loop -> do
110 fix $ \loop -> do
136 bs <- popper
111 bs <- popper
137 unless (S.null bs) $ do
112 unless (S.null bs) $ do
@@ -139,150 +114,6 @@ tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
139 loop
114 loop
140 release key
115 release key
141 return fp
116 return fp
142− where
143− it = do
144− tempDir <- getTmpDir
145− openBinaryTempFile tempDir pattrn
146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)
147− (removeFile fp)
148− (const $ return ())
149−
150−-- | A data structure that describes the behavior of
151−-- the parseRequestBodyEx function.
152−--
153−-- @since 3.0.16.0
154−data ParseRequestBodyOptions = ParseRequestBodyOptions
155− { -- | The maximum length of a filename
156− prboKeyLength :: Maybe Int
157− , -- | The maximum number of files.
158− prboMaxNumFiles :: Maybe Int
159− , -- | The maximum filesize per file.
160− prboMaxFileSize :: Maybe Int64
161− , -- | The maximum total filesize.
162− prboMaxFilesSize :: Maybe Int64
163− , -- | The maximum size of the sum of all parameters
164− prboMaxParmsSize :: Maybe Int
165− , -- | The maximum header lines per mime/multipart entry
166− prboMaxHeaderLines :: Maybe Int
167− , -- | The maximum header line length per mime/multipart entry
168− prboMaxHeaderLineLength :: Maybe Int }
169−
170−-- | Set the maximum length of a filename.
171−--
172−-- @since 3.0.16.0
173−setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
174−setMaxRequestKeyLength l p = p { prboKeyLength=Just l }
175−
176−-- | Do not limit the length of filenames.
177−--
178−-- @since 3.0.16.0
179−clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
180−clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }
181−
182−-- | Set the maximum number of files per request.
183−--
184−-- @since 3.0.16.0
185−setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
186−setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }
187−
188−-- | Do not limit the maximum number of files per request.
189−--
190−-- @since 3.0.16.0
191−clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions
192−clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }
193−
194−-- | Set the maximum filesize per file (in bytes).
195−--
196−-- @since 3.0.16.0
197−setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
198−setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }
199−
200−-- | Do not limit the maximum filesize per file.
201−--
202−-- @since 3.0.16.0
203−clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
204−clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }
205−
206−-- | Set the maximum size of all files per request.
207−--
208−-- @since 3.0.16.0
209−setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions
210−setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }
211−
212−-- | Do not limit the maximum size of all files per request.
213−--
214−-- @since 3.0.16.0
215−clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
216−clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }
217−
218−-- | Set the maximum size of the sum of all parameters.
219−--
220−-- @since 3.0.16.0
221−setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
222−setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }
223−
224−-- | Do not limit the maximum size of the sum of all parameters.
225−--
226−-- @since 3.0.16.0
227−clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions
228−clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }
229−
230−-- | Set the maximum header lines per mime/multipart entry.
231−--
232−-- @since 3.0.16.0
233−setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
234−setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }
235−
236−-- | Do not limit the maximum header lines per mime/multipart entry.
237−--
238−-- @since 3.0.16.0
239−clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions
240−clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }
241−
242−-- | Set the maximum header line length per mime/multipart entry.
243−--
244−-- @since 3.0.16.0
245−setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions
246−setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }
247−
248−-- | Do not limit the maximum header lines per mime/multipart entry.
249−--
250−-- @since 3.0.16.0
251−clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
252−clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }
253−
254−-- | A reasonable default set of parsing options.
255−-- Maximum key/filename length: 32 bytes;
256−-- maximum files: 10; filesize unlimited; maximum
257−-- size for parameters: 64kbytes; maximum number of header
258−-- lines: 32 bytes (applies only to headers of a mime/multipart message);
259−-- maximum header line length: Apache's default for that is 8190 bytes
260−-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline)
261−-- so we're using that here as well.
262−--
263−-- @since 3.0.16.0
264−defaultParseRequestBodyOptions :: ParseRequestBodyOptions
265−defaultParseRequestBodyOptions = ParseRequestBodyOptions
266− { prboKeyLength=Just 32
267− , prboMaxNumFiles=Just 10
268− , prboMaxFileSize=Nothing
269− , prboMaxFilesSize=Nothing
270− , prboMaxParmsSize=Just 65336
271− , prboMaxHeaderLines=Just 32
272− , prboMaxHeaderLineLength=Just 8190 }
273−
274−-- | Do not impose any memory limits.
275−--
276−-- @since 3.0.21.0
277−noLimitParseRequestBodyOptions :: ParseRequestBodyOptions
278−noLimitParseRequestBodyOptions = ParseRequestBodyOptions
279− { prboKeyLength=Nothing
280− , prboMaxNumFiles=Nothing
281− , prboMaxFileSize=Nothing
282− , prboMaxFilesSize=Nothing
283− , prboMaxParmsSize=Nothing
284− , prboMaxHeaderLines=Nothing
285− , prboMaxHeaderLineLength=Nothing }
286
117
287-- | Information on an uploaded file.
118-- | Information on an uploaded file.
288data FileInfo c = FileInfo
119data FileInfo c = FileInfo
@@ -305,19 +136,11 @@ type BackEnd a = S.ByteString -- ^ parameter name
305 -> IO S.ByteString
136 -> IO S.ByteString
306 -> IO a
137 -> IO a
307
138
308−-- | The mimetype of the http body.
309−-- Depending on whether just parameters or parameters and files
310−-- are passed, one or the other mimetype should be used.
311−data RequestBodyType
312− = -- | application/x-www-form-urlencoded (parameters only)
313− UrlEncoded
314− | -- | multipart/form-data (parameters and files)
315− Multipart S.ByteString
139+data RequestBodyType = UrlEncoded | Multipart S.ByteString
316
140
317−-- | Get the mimetype of the body of an http request.
318getRequestBodyType :: Request -> Maybe RequestBodyType
141getRequestBodyType :: Request -> Maybe RequestBodyType
319getRequestBodyType req = do
142getRequestBodyType req = do
320− ctype' <- lookup hContentType $ requestHeaders req
143+ ctype' <- lookup "Content-Type" $ requestHeaders req
321 let (ctype, attrs) = parseContentType ctype'
144 let (ctype, attrs) = parseContentType ctype'
322 case ctype of
145 case ctype of
323 "application/x-www-form-urlencoded" -> return UrlEncoded
146 "application/x-www-form-urlencoded" -> return UrlEncoded
@@ -327,7 +150,7 @@ getRequestBodyType req = do
327-- | Parse a content type value, turning a single @ByteString@ into the actual
150-- | Parse a content type value, turning a single @ByteString@ into the actual
328-- content type and a list of pairs of attributes.
151-- content type and a list of pairs of attributes.
329--
152--
330−-- @since 1.3.2
153+-- Since 1.3.2
331parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
154parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
332parseContentType a = do
155parseContentType a = do
333 let (ctype, b) = S.break (== semicolon) a
156 let (ctype, b) = S.break (== semicolon) a
@@ -337,9 +160,6 @@ parseContentType a = do
337 semicolon = 59
160 semicolon = 59
338 equals = 61
161 equals = 61
339 space = 32
162 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
163 goAttrs front bs
344 | S.null bs = front []
164 | S.null bs = front []
345 | otherwise =
165 | otherwise =
@@ -348,140 +168,79 @@ parseContentType a = do
348 goAttr bs =
168 goAttr bs =
349 let (k, v') = S.break (== equals) bs
169 let (k, v') = S.break (== equals) bs
350 v = S.drop 1 v'
170 v = S.drop 1 v'
351− in (strip k, dq $ strip v)
171+ in (strip k, strip v)
352 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
172 strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
353
173
354−-- | Parse the body of an HTTP request.
355−-- See parseRequestBodyEx for details.
356−-- Note: This function does not limit the memory it allocates.
357−-- When dealing with untrusted data (as is usually the case when
358−-- receiving input from the internet), it is recommended to
359−-- use the 'parseRequestBodyEx' function instead.
360parseRequestBody :: BackEnd y
174parseRequestBody :: BackEnd y
361 -> Request
175 -> Request
362 -> IO ([Param], [File y])
176 -> IO ([Param], [File y])
363−parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
177+parseRequestBody s r =
364−
365−-- | Parse the body of an HTTP request, limit resource usage.
366−-- The HTTP body can contain both parameters and files.
367−-- This function will return a list of key,value pairs
368−-- for all parameters, and a list of key,a pairs
369−-- for filenames. The a depends on the used backend that
370−-- is responsible for storing the received files.
371−parseRequestBodyEx :: ParseRequestBodyOptions
372− -> BackEnd y
373− -> Request
374− -> IO ([Param], [File y])
375−parseRequestBodyEx o s r =
376 case getRequestBodyType r of
178 case getRequestBodyType r of
377 Nothing -> return ([], [])
179 Nothing -> return ([], [])
378− Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
180+ Just rbt -> sinkRequestBody s rbt (requestBody r)
379
181
380sinkRequestBody :: BackEnd y
182sinkRequestBody :: BackEnd y
381 -> RequestBodyType
183 -> RequestBodyType
382 -> IO S.ByteString
184 -> IO S.ByteString
383 -> IO ([Param], [File y])
185 -> IO ([Param], [File y])
384−sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
186+sinkRequestBody s r body = do
385−
386−-- |
387−--
388−-- @since 3.0.16.0
389−sinkRequestBodyEx :: ParseRequestBodyOptions
390− -> BackEnd y
391− -> RequestBodyType
392− -> IO S.ByteString
393− -> IO ([Param], [File y])
394−sinkRequestBodyEx o s r body = do
395− ref <- newIORef ([], [])
187+ ref <- newIORef (id, id)
396 let add x = atomicModifyIORef ref $ \(y, z) ->
188 let add x = atomicModifyIORef ref $ \(y, z) ->
397 case x of
189 case x of
398− Left y' -> ((y':y, z), ())
190+ Left y' -> ((y . (y':), z), ())
399− Right z' -> ((y, z':z), ())
191+ Right z' -> ((y, z . (z':)), ())
400− conduitRequestBodyEx o s r body add
192+ conduitRequestBody s r body add
401− (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
193+ (x, y) <- readIORef ref
402−
194+ return (x [], y [])
403−conduitRequestBodyEx :: ParseRequestBodyOptions
195+
404− -> BackEnd y
196+conduitRequestBody :: BackEnd y
405− -> RequestBodyType
197+ -> RequestBodyType
406− -> IO S.ByteString
198+ -> IO S.ByteString
407− -> (Either Param (File y) -> IO ())
199+ -> (Either Param (File y) -> IO ())
408− -> IO ()
200+ -> IO ()
409−conduitRequestBodyEx o _ UrlEncoded rbody add = do
201+conduitRequestBody _ UrlEncoded rbody add = do
410 -- NOTE: in general, url-encoded data will be in a single chunk.
202 -- NOTE: in general, url-encoded data will be in a single chunk.
411 -- Therefore, I'm optimizing for the usual case by sticking with
203 -- Therefore, I'm optimizing for the usual case by sticking with
412 -- strict byte strings here.
204 -- strict byte strings here.
413− let loop size front = do
205+ let loop front = do
414 bs <- rbody
206 bs <- rbody
415 if S.null bs
207 if S.null bs
416 then return $ S.concat $ front []
208 then return $ S.concat $ front []
417− else do
418− let newsize = size + S.length bs
419− case prboMaxParmsSize o of
420− Just maxSize -> when (newsize > maxSize) $
421− error "Maximum size of parameters exceeded"
422− Nothing -> return ()
423− loop newsize $ front . (bs:)
209+ else loop $ front . (bs:)
424− bs <- loop 0 id
210+ bs <- loop id
425 mapM_ (add . Left) $ H.parseSimpleQuery bs
211 mapM_ (add . Left) $ H.parseSimpleQuery bs
426−conduitRequestBodyEx o backend (Multipart bound) rbody add =
212+conduitRequestBody backend (Multipart bound) rbody add =
427− parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add
213+ parsePieces backend (S8.pack "--" `S.append` bound) rbody add
428−
429
214
430−-- | Take one header or subheader line.
431−-- Since: 3.0.26
432−-- Throw 431 if headers too large.
433−takeLine :: Maybe Int -> Source -> IO (Maybe S.ByteString)
215+takeLine :: Source -> IO (Maybe S.ByteString)
434−takeLine maxlen src =
216+takeLine src =
435− go ""
217+ go id
436 where
218 where
437 go front = do
219 go front = do
438 bs <- readSource src
220 bs <- readSource src
439− case maxlen of
440− Just maxlen' -> when (S.length front > maxlen') $
441− E.throwIO $ ConnectionError (UnknownErrorCode 431)
442− "Request Header Fields Too Large"
443− Nothing -> return ()
444 if S.null bs
221 if S.null bs
445 then close front
222 then close front
446 else push front bs
223 else push front bs
447
224
448− close front = leftover src front >> return Nothing
225+ close front = leftover src (front S.empty) >> return Nothing
449 push front bs = do
226 push front bs = do
450− let (x, y) = S.break (== 10) bs -- LF
227+ let (x, y) = S.break (== 10) $ front bs -- LF
451 in if S.null y
228 in if S.null y
452− then go $ front `S.append` x
229+ then go $ S.append x
453 else do
230 else do
454 when (S.length y > 1) $ leftover src $ S.drop 1 y
231 when (S.length y > 1) $ leftover src $ S.drop 1 y
455− let res = front `S.append` x
232+ return $ Just $ killCR x
456− case maxlen of
233+
457− Just maxlen' -> when (S.length res > maxlen') $
458− E.throwIO $ ConnectionError (UnknownErrorCode 431)
459− "Request Header Fields Too Large"
460− Nothing -> return ()
461− return $ Just $ killCR $ res
462−
463−takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
234+takeLines :: Source -> IO [S.ByteString]
464−takeLines' lineLength maxLines source =
235+takeLines src = do
465− reverse <$> takeLines'' [] lineLength maxLines source
466−
467−takeLines''
468− :: [S.ByteString]
469− -> Maybe Int
470− -> Maybe Int
471− -> Source
472− -> IO [S.ByteString]
473−takeLines'' lines lineLength maxLines src = do
474− case maxLines of
475− Just maxLines' ->
476− when (length lines > maxLines') $
477− error "Too many lines in mime/multipart header"
478− Nothing -> return ()
479− res <- takeLine lineLength src
236+ res <- takeLine src
480 case res of
237 case res of
481− Nothing -> return lines
238+ Nothing -> return []
482 Just l
239 Just l
483− | S.null l -> return lines
240+ | S.null l -> return []
484− | otherwise -> takeLines'' (l:lines) lineLength maxLines src
241+ | otherwise -> do
242+ ls <- takeLines src
243+ return $ l : ls
485
244
486data Source = Source (IO S.ByteString) (IORef S.ByteString)
245data Source = Source (IO S.ByteString) (IORef S.ByteString)
487
246
@@ -500,20 +259,17 @@ readSource (Source f ref) = do
500leftover :: Source -> S.ByteString -> IO ()
259leftover :: Source -> S.ByteString -> IO ()
501leftover (Source _ ref) bs = writeIORef ref bs
260leftover (Source _ ref) bs = writeIORef ref bs
502
261
503−parsePiecesEx :: ParseRequestBodyOptions
504− -> BackEnd y
262+parsePieces :: BackEnd y
505− -> S.ByteString
263+ -> S.ByteString
506− -> IO S.ByteString
264+ -> IO S.ByteString
507− -> (Either Param (File y) -> IO ())
265+ -> (Either Param (File y) -> IO ())
508− -> IO ()
266+ -> IO ()
509−parsePiecesEx o sink bound rbody add =
267+parsePieces sink bound rbody add =
510− mkSource rbody >>= loop 0 0 0 0
268+ mkSource rbody >>= loop
511 where
269 where
512− loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
270+ loop src = do
513− loop numParms numFiles parmSize filesSize src = do
514− _boundLine <- takeLine (prboMaxHeaderLineLength o) src
271+ _boundLine <- takeLine src
515− res' <- takeLines' (prboMaxHeaderLineLength o)
272+ res' <- takeLines src
516− (prboMaxHeaderLines o) src
517 unless (null res') $ do
273 unless (null res') $ do
518 let ls' = map parsePair res'
274 let ls' = map parsePair res'
519 let x = do
275 let x = do
@@ -524,57 +280,31 @@ parsePiecesEx o sink bound rbody add =
524 return (ct, name, lookup "filename" attrs)
280 return (ct, name, lookup "filename" attrs)
525 case x of
281 case x of
526 Just (mct, name, Just filename) -> do
282 Just (mct, name, Just filename) -> do
527− case prboKeyLength o of
528− Just maxKeyLength ->
529− when (S.length name > maxKeyLength) $
530− error "Filename is too long"
531− Nothing -> return ()
532− case prboMaxNumFiles o of
533− Just maxFiles -> when (numFiles >= maxFiles) $
534− error "Maximum number of files exceeded"
535− Nothing -> return ()
536 let ct = fromMaybe "application/octet-stream" mct
283 let ct = fromMaybe "application/octet-stream" mct
537 fi0 = FileInfo filename ct ()
284 fi0 = FileInfo filename ct ()
538− fs = catMaybes [ prboMaxFileSize o
539− , subtract filesSize <$> prboMaxFilesSize o ]
540− mfs = if fs == [] then Nothing else Just $ minimum fs
541− ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
285+ (wasFound, y) <- sinkTillBound' bound name fi0 sink src
542− let newFilesSize = filesSize + fileSize
543 add $ Right (name, fi0 { fileContent = y })
286 add $ Right (name, fi0 { fileContent = y })
544− when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
287+ when wasFound (loop src)
545 Just (_ct, name, Nothing) -> do
288 Just (_ct, name, Nothing) -> do
546− case prboKeyLength o of
547− Just maxKeyLength ->
548− when (S.length name > maxKeyLength) $
549− error "Parameter name is too long"
550− Nothing -> return ()
551 let seed = id
289 let seed = id
552 let iter front bs = return $ front . (:) bs
290 let iter front bs = return $ front . (:) bs
553− ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
291+ (wasFound, front) <- sinkTillBound bound iter seed src
554− (fromIntegral <$> prboMaxParmsSize o)
555 let bs = S.concat $ front []
292 let bs = S.concat $ front []
556 let x' = (name, bs)
293 let x' = (name, bs)
557− let newParmSize = parmSize + S.length name + S.length bs
558− case prboMaxParmsSize o of
559− Just maxParmSize -> when (newParmSize > maxParmSize) $
560− error "Maximum size of parameters exceeded"
561− Nothing -> return ()
562 add $ Left x'
294 add $ Left x'
563− when wasFound $ loop (numParms + 1) numFiles
295+ when wasFound (loop src)
564− newParmSize filesSize src
565 _ -> do
296 _ -> do
566 -- ignore this part
297 -- ignore this part
567 let seed = ()
298 let seed = ()
568 iter () _ = return ()
299 iter () _ = return ()
569− ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
300+ (wasFound, ()) <- sinkTillBound bound iter seed src
570− when wasFound $ loop numParms numFiles parmSize filesSize src
301+ when wasFound (loop src)
571 where
302 where
572− contDisp = mk $ S8.pack "Content-Disposition"
303+ contDisp = S8.pack "Content-Disposition"
573− contType = mk $ S8.pack "Content-Type"
304+ contType = S8.pack "Content-Type"
574 parsePair s =
305 parsePair s =
575 let (x, y) = breakDiscard 58 s -- colon
306 let (x, y) = breakDiscard 58 s -- colon
576− in (mk $ x, S.dropWhile (== 32) y) -- space
307+ in (x, S.dropWhile (== 32) y) -- space
577−
578
308
579data Bound = FoundBound S.ByteString S.ByteString
309data Bound = FoundBound S.ByteString S.ByteString
580 | NoBound
310 | NoBound
@@ -582,7 +312,7 @@ data Bound = FoundBound S.ByteString S.ByteString
582 deriving (Eq, Show)
312 deriving (Eq, Show)
583
313
584findBound :: S.ByteString -> S.ByteString -> Bound
314findBound :: S.ByteString -> S.ByteString -> Bound
585−findBound b bs = handleBreak $ S.breakSubstring b bs
315+findBound b bs = handleBreak $ Search.breakOn b bs
586 where
316 where
587 handleBreak (h, t)
317 handleBreak (h, t)
588 | S.null t = go [lowBound..S.length bs - 1]
318 | S.null t = go [lowBound..S.length bs - 1]
@@ -609,10 +339,9 @@ sinkTillBound' :: S.ByteString
609 -> FileInfo ()
339 -> FileInfo ()
610 -> BackEnd y
340 -> BackEnd y
611 -> Source
341 -> Source
612− -> Maybe Int64
613− -> IO ((Bool, Int64), y)
342+ -> IO (Bool, y)
614−sinkTillBound' bound name fi sink src max' = do
343+sinkTillBound' bound name fi sink src = do
615− (next, final) <- wrapTillBound bound src max'
344+ (next, final) <- wrapTillBound bound src
616 y <- sink name fi next
345 y <- sink name fi next
617 b <- final
346 b <- final
618 return (b, y)
347 return (b, y)
@@ -621,40 +350,30 @@ data WTB = WTBWorking (S.ByteString -> S.ByteString)
621 | WTBDone Bool
350 | WTBDone Bool
622wrapTillBound :: S.ByteString -- ^ bound
351wrapTillBound :: S.ByteString -- ^ bound
623 -> Source
352 -> Source
624− -> Maybe Int64
625− -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found
353+ -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found
626−wrapTillBound bound src max' = do
354+wrapTillBound bound src = do
627 ref <- newIORef $ WTBWorking id
355 ref <- newIORef $ WTBWorking id
628− sref <- newIORef (0 :: Int64)
629− return (go ref sref, final ref sref)
356+ return (go ref, final ref)
630 where
357 where
631− final ref sref = do
358+ final ref = do
632 x <- readIORef ref
359 x <- readIORef ref
633 case x of
360 case x of
634 WTBWorking _ -> error "wrapTillBound did not finish"
361 WTBWorking _ -> error "wrapTillBound did not finish"
635− WTBDone y -> do
362+ WTBDone y -> return y
636− siz <- readIORef sref
637− return (y, siz)
638
363
639− go ref sref = do
364+ go ref = do
640 state <- readIORef ref
365 state <- readIORef ref
641 case state of
366 case state of
642 WTBDone _ -> return S.empty
367 WTBDone _ -> return S.empty
643 WTBWorking front -> do
368 WTBWorking front -> do
644 bs <- readSource src
369 bs <- readSource src
645− cur <- atomicModifyIORef' sref $ \ cur ->
646− let new = cur + fromIntegral (S.length bs) in (new, new)
647− case max' of
648− Just max'' | cur > max'' ->
649− E.throwIO $ ConnectionError (UnknownErrorCode 413) "Payload Too Large"
650− _ -> return ()
651 if S.null bs
370 if S.null bs
652 then do
371 then do
653 writeIORef ref $ WTBDone False
372 writeIORef ref $ WTBDone False
654 return $ front bs
373 return $ front bs
655 else push $ front bs
374 else push $ front bs
656 where
375 where
657− push bs = do
376+ push bs =
658 case findBound bound bs of
377 case findBound bound bs of
659 FoundBound before after -> do
378 FoundBound before after -> do
660 let before' = killCRLF before
379 let before' = killCRLF before
@@ -670,20 +389,19 @@ wrapTillBound bound src max' = do
670 else (bs, id)
389 else (bs, id)
671 writeIORef ref $ WTBWorking front'
390 writeIORef ref $ WTBWorking front'
672 if S.null toEmit
391 if S.null toEmit
673− then go ref sref
392+ then go ref
674 else return toEmit
393 else return toEmit
675 PartialBound -> do
394 PartialBound -> do
676 writeIORef ref $ WTBWorking $ S.append bs
395 writeIORef ref $ WTBWorking $ S.append bs
677− go ref sref
396+ go ref
678
397
679sinkTillBound :: S.ByteString
398sinkTillBound :: S.ByteString
680 -> (x -> S.ByteString -> IO x)
399 -> (x -> S.ByteString -> IO x)
681 -> x
400 -> x
682 -> Source
401 -> Source
683− -> Maybe Int64
684− -> IO ((Bool, Int64), x)
402+ -> IO (Bool, x)
685−sinkTillBound bound iter seed0 src max' = do
403+sinkTillBound bound iter seed0 src = do
686− (next, final) <- wrapTillBound bound src max'
404+ (next, final) <- wrapTillBound bound src
687 let loop seed = do
405 let loop seed = do
688 bs <- next
406 bs <- next
689 if S.null bs
407 if S.null bs
wai-extra/Network/Wai/Request.hs+4−54
@@ -1,25 +1,18 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE OverloadedStrings #-}
2-- | Some helpers for interrogating a WAI 'Request'.
2-- | Some helpers for interrogating a WAI 'Request'.
3
3
4module Network.Wai.Request
4module Network.Wai.Request
5 ( appearsSecure
5 ( appearsSecure
6 , guessApproot
6 , guessApproot
7− , RequestSizeException(..)
8− , requestSizeCheck
9 ) where
7 ) where
10
8
11import Data.ByteString (ByteString)
9import Data.ByteString (ByteString)
12import Data.Maybe (fromMaybe)
10import Data.Maybe (fromMaybe)
13import Network.HTTP.Types (HeaderName)
11import Network.HTTP.Types (HeaderName)
14−import Network.Wai
12+import Network.Wai (Request, isSecure, requestHeaders, requestHeaderHost)
15
13
16import qualified Data.ByteString as S
14import qualified Data.ByteString as S
17import qualified Data.ByteString.Char8 as C
15import qualified Data.ByteString.Char8 as C
18−import Control.Exception (Exception, throwIO)
19−import Data.Typeable (Typeable)
20−import Data.Word (Word64)
21−import Data.IORef (atomicModifyIORef', newIORef)
22−
23
16
24-- | Does this request appear to have been made over an SSL connection?
17-- | Does this request appear to have been made over an SSL connection?
25--
18--
@@ -32,14 +25,13 @@ import Data.IORef (atomicModifyIORef', newIORef)
32-- force a non-SSL request to SSL by redirect. One can safely choose not to
25-- force a non-SSL request to SSL by redirect. One can safely choose not to
33-- redirect when the request /appears/ secure, even if it's actually not.
26-- redirect when the request /appears/ secure, even if it's actually not.
34--
27--
35−-- @since 3.0.7
28+-- Since 3.0.7
36appearsSecure :: Request -> Bool
29appearsSecure :: Request -> Bool
37appearsSecure request = isSecure request || any (uncurry matchHeader)
30appearsSecure request = isSecure request || any (uncurry matchHeader)
38 [ ("HTTPS" , (== "on"))
31 [ ("HTTPS" , (== "on"))
39 , ("HTTP_X_FORWARDED_SSL" , (== "on"))
32 , ("HTTP_X_FORWARDED_SSL" , (== "on"))
40 , ("HTTP_X_FORWARDED_SCHEME", (== "https"))
33 , ("HTTP_X_FORWARDED_SCHEME", (== "https"))
41 , ("HTTP_X_FORWARDED_PROTO" , ((== ["https"]) . take 1 . C.split ','))
34 , ("HTTP_X_FORWARDED_PROTO" , ((== ["https"]) . take 1 . C.split ','))
42− , ("X-Forwarded-Proto" , (== "https")) -- Used by Nginx and AWS ELB.
43 ]
35 ]
44
36
45 where
37 where
@@ -52,50 +44,8 @@ appearsSecure request = isSecure request || any (uncurry matchHeader)
52-- application. For more information and relevant caveats, please see
44-- application. For more information and relevant caveats, please see
53-- "Network.Wai.Middleware.Approot".
45-- "Network.Wai.Middleware.Approot".
54--
46--
55−-- @since 3.0.7
47+-- Since 3.0.7
56guessApproot :: Request -> ByteString
48guessApproot :: Request -> ByteString
57guessApproot req =
49guessApproot req =
58 (if appearsSecure req then "https://" else "http://") `S.append`
50 (if appearsSecure req then "https://" else "http://") `S.append`
59 (fromMaybe "localhost" $ requestHeaderHost req)
51 (fromMaybe "localhost" $ requestHeaderHost req)
60−
61−-- | see 'requestSizeCheck'
62−--
63−-- @since 3.0.15
64−data RequestSizeException
65− = RequestSizeException Word64
66− deriving (Eq, Ord, Typeable)
67−
68−instance Exception RequestSizeException
69−
70−instance Show RequestSizeException where
71− showsPrec p (RequestSizeException limit) =
72− showString ("Request Body is larger than ") . showsPrec p limit . showString " bytes."
73−
74−-- | Check request body size to avoid server crash when request is too large.
75−--
76−-- This function first checks @'requestBodyLength'@, if content-length is known
77−-- but larger than limit, or it's unknown but we have received too many chunks,
78−-- a 'RequestSizeException' are thrown when user use @'requestBody'@ to extract
79−-- request body inside IO.
80−--
81−-- @since 3.0.15
82−requestSizeCheck :: Word64 -> Request -> IO Request
83−requestSizeCheck maxSize req =
84− case requestBodyLength req of
85− KnownLength len ->
86− if len > maxSize
87− then return $ req { requestBody = throwIO (RequestSizeException maxSize) }
88− else return req
89− ChunkedBody -> do
90− currentSize <- newIORef 0
91− return $ req
92− { requestBody = do
93− bs <- requestBody req
94− total <-
95− atomicModifyIORef' currentSize $ \sz ->
96− let nextSize = sz + fromIntegral (S.length bs)
97− in (nextSize, nextSize)
98− if total > maxSize
99− then throwIO (RequestSizeException maxSize)
100− else return bs
101− }
wai-extra/Network/Wai/Test.hs+35−28
@@ -39,20 +39,21 @@ import Data.Monoid (mempty, mappend)
39
39
40import Network.Wai
40import Network.Wai
41import Network.Wai.Internal (ResponseReceived (ResponseReceived))
41import Network.Wai.Internal (ResponseReceived (ResponseReceived))
42−import Network.Wai.Test.Internal
43import Control.Monad.IO.Class (liftIO)
42import Control.Monad.IO.Class (liftIO)
44import Control.Monad.Trans.Class (lift)
43import Control.Monad.Trans.Class (lift)
45import qualified Control.Monad.Trans.State as ST
44import qualified Control.Monad.Trans.State as ST
46−import Control.Monad.Trans.Reader (runReaderT, ask)
45+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
47import Control.Monad (unless)
46import Control.Monad (unless)
48import Control.DeepSeq (deepseq)
47import Control.DeepSeq (deepseq)
49import Control.Exception (throwIO, Exception)
48import Control.Exception (throwIO, Exception)
50import Data.Typeable (Typeable)
49import Data.Typeable (Typeable)
50+import Data.Map (Map)
51import qualified Data.Map as Map
51import 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
@@ -63,6 +64,17 @@ import qualified Data.Text.Encoding as TE
63import Data.IORef
64import Data.IORef
64import Data.Time.Clock (getCurrentTime)
65import Data.Time.Clock (getCurrentTime)
65
66
67+type Session = ReaderT Application (ST.StateT ClientState IO)
68+
69+-- |
70+--
71+-- Since 3.0.6
72+type ClientCookies = Map ByteString Cookie.SetCookie
73+
74+data ClientState = ClientState
75+ { clientCookies :: ClientCookies
76+ }
77+
66-- |
78-- |
67--
79--
68-- Since 3.0.6
80-- Since 3.0.6
@@ -92,17 +104,15 @@ deleteClientCookie cookieName =
92 modifyClientCookies
104 modifyClientCookies
93 (Map.delete cookieName)
105 (Map.delete cookieName)
94
106
95−-- | See also: 'runSessionWith'.
107+initState :: ClientState
108+initState = ClientState Map.empty
109+
96runSession :: Session a -> Application -> IO a
110runSession :: Session a -> Application -> IO a
97runSession session app = ST.evalStateT (runReaderT session app) initState
111runSession session app = ST.evalStateT (runReaderT session app) initState
98
112
99data SRequest = SRequest
113data SRequest = SRequest
100 { simpleRequest :: Request
114 { simpleRequest :: Request
101 , simpleRequestBody :: L.ByteString
115 , 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 }
116 }
107data SResponse = SResponse
117data SResponse = SResponse
108 { simpleStatus :: H.Status
118 { simpleStatus :: H.Status
@@ -110,22 +120,14 @@ data SResponse = SResponse
110 , simpleBody :: L.ByteString
120 , simpleBody :: L.ByteString
111 }
121 }
112 deriving (Show, Eq)
122 deriving (Show, Eq)
113−
114request :: Request -> Session SResponse
123request :: Request -> Session SResponse
115−request req = do
124+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
125
124-- | Set whole path (request path + query string).
126-- | Set whole path (request path + query string).
125setPath :: Request -> S8.ByteString -> Request
127setPath :: Request -> S8.ByteString -> Request
126setPath req path = req {
128setPath req path = req {
127 pathInfo = segments
129 pathInfo = segments
128− , rawPathInfo = (L8.toStrict . toLazyByteString) (H.encodePathSegments segments)
130+ , rawPathInfo = B.toByteString (H.encodePathSegments segments)
129 , queryString = query
131 , queryString = query
130 , rawQueryString = (H.renderQuery True query)
132 , rawQueryString = (H.renderQuery True query)
131 }
133 }
@@ -154,7 +156,7 @@ addCookiesToRequest req = do
154 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
156 let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
155 | c <- map snd $ Map.toList cookiesForRequest
157 | c <- map snd $ Map.toList cookiesForRequest
156 ]
158 ]
157− let cookieValue = L8.toStrict . toLazyByteString $ Cookie.renderCookies cookiePairs
159+ let cookieValue = toByteString $ Cookie.renderCookies cookiePairs
158 addCookieHeader rest
160 addCookieHeader rest
159 | null cookiePairs = rest
161 | null cookiePairs = rest
160 | otherwise = ("Cookie", cookieValue) : rest
162 | otherwise = ("Cookie", cookieValue) : rest
@@ -178,18 +180,22 @@ extractSetCookieFromSResponse response = do
178 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))
180 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))
179 return response
181 return response
180
182
181−-- | Similar to 'request', but allows setting the request body as a plain
182−-- 'L.ByteString'.
183srequest :: SRequest -> Session SResponse
183srequest :: SRequest -> Session SResponse
184srequest (SRequest req bod) = do
184srequest (SRequest req bod) = do
185+ app <- ask
185 refChunks <- liftIO $ newIORef $ L.toChunks bod
186 refChunks <- liftIO $ newIORef $ L.toChunks bod
186− request $
187− req
187+ let req' = req
188− { requestBody = atomicModifyIORef refChunks $ \bss ->
188+ { requestBody = atomicModifyIORef refChunks $ \bss ->
189− case bss of
189+ case bss of
190− [] -> ([], S.empty)
190+ [] -> ([], S.empty)
191− x:y -> (y, x)
191+ x:y -> (y, x)
192− }
192+ }
193+ req'' <- addCookiesToRequest req'
194+ response <- liftIO $ do
195+ ref <- newIORef $ error "runResponse gave no result"
196+ ResponseReceived <- app req'' (runResponse ref)
197+ readIORef ref
198+ extractSetCookieFromSResponse response
193
199
194runResponse :: IORef SResponse -> Response -> IO ResponseReceived
200runResponse :: IORef SResponse -> Response -> IO ResponseReceived
195runResponse ref res = do
201runResponse ref res = do
@@ -331,3 +337,4 @@ assertClientCookieValue s cookieName cookieValue = do
331 ]
337 ]
332 )
338 )
333 (Cookie.setCookieValue c == cookieValue)
339 (Cookie.setCookieValue c == cookieValue)
340+
wai-extra/Network/Wai/Test/Internal.hsdeleted−35
@@ -1,35 +0,0 @@
1−module Network.Wai.Test.Internal where
2−
3−import Network.Wai
4−import qualified Control.Monad.Trans.State as ST
5−import Control.Monad.Trans.Reader (ReaderT, runReaderT)
6−import Data.Map (Map)
7−import qualified Data.Map as Map
8−import qualified Web.Cookie as Cookie
9−import Data.ByteString (ByteString)
10−
11−type Session = ReaderT Application (ST.StateT ClientState IO)
12−
13−-- |
14−--
15−-- Since 3.0.6
16−type ClientCookies = Map ByteString Cookie.SetCookie
17−
18−data ClientState = ClientState
19− { clientCookies :: ClientCookies
20− }
21−
22−-- |
23−--
24−-- Since 3.0.20.0
25−initState :: ClientState
26−initState = ClientState Map.empty
27−
28−-- | Like 'runSession', but if allows you to hand in cookies and get
29−-- the updated cookies back. One use case for this is writing tests
30−-- that address the application under test alternatingly through rest
31−-- api and through db handle.
32−--
33−-- Since 3.0.20.0
34−runSessionWith :: ClientState -> Session a -> Application -> IO (a, ClientState)
35−runSessionWith st session app = ST.runStateT (runReaderT session app) st
wai-extra/Network/Wai/UrlMap.hs+2−2
@@ -1,4 +1,4 @@
1−{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
1+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
2{-# LANGUAGE ExistentialQuantification #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{- | This module gives you a way to mount applications under sub-URIs.
3{- | This module gives you a way to mount applications under sub-URIs.
4For example:
4For example:
@@ -93,7 +93,7 @@ instance ToApplication UrlMap where
93 Nothing ->
93 Nothing ->
94 sendResponse $ responseLBS
94 sendResponse $ responseLBS
95 status404
95 status404
96− [(hContentType, "text/plain")]
96+ [("content-type", "text/plain")]
97 "Not found\n"
97 "Not found\n"
98
98
99 where
99 where
wai-extra/README.md+1−14
@@ -1,16 +1,3 @@
1−# wai-extra
1+## wai-extra
2
2
3The goal here is to provide common features without many dependencies.
3The goal here is to provide common features without many dependencies.
4−
5−
6−## Example using Server-Sent Events ##
7−
8−There is a small example using Server-Sent Events (SSE) in the
9−`./example` directory.
10−
11−Run the commands below to start the server on http://localhost:8080
12−
13−```
14−$ stack build .
15−$ stack exec example
16−```
wai-extra/app/Main.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main where
3+
4+import Control.Monad
5+import Control.Concurrent (forkIO, threadDelay)
6+import Control.Monad.Trans (liftIO)
7+import Control.Concurrent.Chan
8+import Network.Wai.Handler.Warp (run)
9+import Network.Wai.Middleware.Gzip (gzip, def)
10+import Network.Wai
11+import Network.HTTP.Types (status200)
12+import Data.Time.Clock.POSIX
13+import Blaze.ByteString.Builder.Char.Utf8 (fromString)
14+import qualified Data.Conduit as C
15+
16+import Network.Wai.EventSource
17+
18+app :: Chan ServerEvent -> Application
19+app chan req =
20+ case pathInfo req of
21+ [] -> return $ ResponseFile status200 [("Content-Type", "text/html")] "static/index.html" Nothing
22+ ["esold"] -> eventSourceAppChan chan req
23+ ["eschan"] -> eventSourceAppChan chan req
24+ ["esio"] -> eventSourceAppIO eventIO req
25+ ["essrc"] -> eventSourceAppSource eventSource req
26+ _ -> error "unexpected pathInfo"
27+
28+eventChan :: Chan ServerEvent -> IO ()
29+eventChan chan = forever $ do
30+ threadDelay 1000000
31+ time <- getPOSIXTime
32+ writeChan chan (ServerEvent Nothing Nothing [fromString . show $ time])
33+
34+eventIO :: IO ServerEvent
35+eventIO = do
36+ threadDelay 1000000
37+ time <- getPOSIXTime
38+ return $ ServerEvent (Just $ fromString "io")
39+ Nothing
40+ [fromString . show $ time]
41+
42+eventSource :: C.Source (C.ResourceT IO) ServerEvent
43+eventSource = forever $ do
44+ time <- liftIO $ do
45+ threadDelay 1000000
46+ getPOSIXTime
47+ C.yield $ ServerEvent (Just $ fromString "source")
48+ Nothing
49+ [fromString . show $ time]
50+
51+main = do
52+ chan <- newChan
53+ _ <- forkIO . eventChan $ chan
54+ run 8080 (gzip def $ app chan)
55+
wai-extra/example/index.html → wai-extra/app/index.htmlrenamed+2−3
@@ -1,9 +1,8 @@
1<!doctype html>
1<!doctype html>
2<head>
2<head>
3− <title>Example</title>
3+ <title>Hello</title>
4− <link rel="icon" href="data:;base64,=">
5</head>
4</head>
6−<h1>Testing Server-Sent Events</h1>
5+<h1>Testing</h1>
7
6
8<div id="output"></div>
7<div id="output"></div>
9
8
wai-extra/example/Main.hsdeleted−62
@@ -1,62 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Main where
3−
4−import Data.ByteString.Builder (string8)
5−import Control.Concurrent (forkIO, threadDelay)
6−import Control.Concurrent.Chan
7−import Control.Monad
8−import Data.Time.Clock.POSIX (getPOSIXTime)
9−import Network.HTTP.Types (status200)
10−import Network.Wai (Application, Middleware, pathInfo, responseFile)
11−import Network.Wai.EventSource (ServerEvent(..), eventSourceAppChan, eventSourceAppIO)
12−import Network.Wai.Handler.Warp (run)
13−import Network.Wai.Middleware.AddHeaders (addHeaders)
14−import Network.Wai.Middleware.Gzip (gzip, def)
15−
16−
17−app :: Chan ServerEvent -> Application
18−app chan req respond =
19− case pathInfo req of
20− [] -> respond $ responseFile status200 [("Content-Type", "text/html")] "example/index.html" Nothing
21− ["esold"] -> eventSourceAppChan chan req respond
22− ["eschan"] -> eventSourceAppChan chan req respond
23− ["esio"] -> eventSourceAppIO eventIO req respond
24− _ -> error "unexpected pathInfo"
25−
26−eventChan :: Chan ServerEvent -> IO ()
27−eventChan chan = forever $ do
28− threadDelay 1000000
29− time <- getPOSIXTime
30− writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time])
31−
32−eventIO :: IO ServerEvent
33−eventIO = do
34− threadDelay 1000000
35− time <- getPOSIXTime
36− return $ ServerEvent (Just $ string8 "io")
37− Nothing
38− [string8 . show $ time]
39−
40−eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO ()
41−eventRaw = handle 0
42− where
43− handle counter emit flush = do
44− threadDelay 1000000
45− _ <- emit $ ServerEvent (Just $ string8 "raw")
46− Nothing
47− [string8 . show $ counter]
48− _ <- flush
49− handle (counter + 1) emit flush
50−
51−main :: IO ()
52−main = do
53− chan <- newChan
54− _ <- forkIO . eventChan $ chan
55− run 8080 (gzip def $ headers $ app chan)
56− where
57− -- headers required for SSE to work through nginx
58− -- not required if using warp directly
59− headers :: Middleware
60− headers = addHeaders [ ("X-Accel-Buffering", "no")
61− , ("Cache-Control", "no-cache")
62− ]
wai-extra/test/Network/Wai/Middleware/ForceSSLSpec.hs+5−9
@@ -8,7 +8,6 @@ import Test.Hspec
8
8
9import Network.Wai.Middleware.ForceSSL
9import Network.Wai.Middleware.ForceSSL
10
10
11−import Control.Monad
12import Data.ByteString (ByteString)
11import Data.ByteString (ByteString)
13import Data.Monoid ((<>))
12import Data.Monoid ((<>))
14import Network.HTTP.Types (methodPost, status200, status301, status307)
13import Network.HTTP.Types (methodPost, status200, status301, status307)
@@ -19,12 +18,8 @@ main :: IO ()
19main = hspec spec
18main = hspec spec
20
19
21spec :: Spec
20spec :: Spec
22−spec = describe "forceSSL" (forM_ hosts $ \host -> hostSpec host)
21+spec = describe "forceSSL" $ do
23− where
22+ let host = "example.com"
24− hosts = ["example.com", "example.com:80", "example.com:8080"]
25−
26−hostSpec :: ByteString -> Spec
27−hostSpec host = describe ("forceSSL on host " <> show host <> "") $ do
28
23
29 it "redirects non-https requests to https" $ do
24 it "redirects non-https requests to https" $ do
30 resp <- runApp host forceSSL defaultRequest
25 resp <- runApp host forceSSL defaultRequest
@@ -44,7 +39,7 @@ hostSpec host = describe ("forceSSL on host " <> show host <> "") $ do
44
39
45 simpleStatus resp `shouldBe` status200
40 simpleStatus resp `shouldBe` status200
46
41
47− it "preserves the original host, path, and query string" $ do
42+ it "preserves the original path and query string" $ do
48 resp <- runApp host forceSSL defaultRequest
43 resp <- runApp host forceSSL defaultRequest
49 { rawPathInfo = "/foo/bar"
44 { rawPathInfo = "/foo/bar"
50 , rawQueryString = "?baz=bat"
45 , rawQueryString = "?baz=bat"
@@ -55,6 +50,7 @@ hostSpec host = describe ("forceSSL on host " <> show host <> "") $ do
55
50
56runApp :: ByteString -> Middleware -> Request -> IO SResponse
51runApp :: ByteString -> Middleware -> Request -> IO SResponse
57runApp host mw req = runSession
52runApp host mw req = runSession
58− (request req { requestHeaderHost = Just host }) $ mw app
53+ (request req { requestHeaderHost = Just $ host <> ":80" }) $ mw app
54+
59 where
55 where
60 app _ respond = respond $ responseLBS status200 [] ""
56 app _ respond = respond $ responseLBS status200 [] ""
wai-extra/test/Network/Wai/Middleware/RoutedSpec.hsdeleted−53
@@ -1,53 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.Middleware.RoutedSpec
3− ( main
4− , spec
5− ) where
6−
7−import Test.Hspec
8−
9−import Network.Wai.Middleware.Routed
10−import Network.Wai.Middleware.ForceSSL (forceSSL)
11−
12−import Network.HTTP.Types (hContentType, status200)
13−import Network.Wai
14−import Network.Wai.Test
15−import Data.ByteString (ByteString)
16−import Data.String (IsString)
17−
18−main :: IO ()
19−main = hspec spec
20−
21−spec :: Spec
22−spec = describe "forceSSL" $ do
23− it "routed middleware" $ do
24− let destination = "https://example.com/d/"
25− let routedSslJsonApp prefix = routedMiddleware (checkPrefix prefix) forceSSL jsonApp
26− checkPrefix p (p1:_) = p == p1
27− checkPrefix _ _ = False
28−
29− flip runSession (routedSslJsonApp "r") $ do
30− res <- testDPath "http"
31− assertNoHeader location res
32− assertStatus 200 res
33− assertBody "{\"foo\":\"bar\"}" res
34−
35− flip runSession (routedSslJsonApp "d") $ do
36− res2 <- testDPath "http"
37− assertHeader location destination res2
38− assertStatus 301 res2
39−
40−jsonApp :: Application
41−jsonApp _req cps = cps $ responseLBS status200
42− [(hContentType, "application/json")]
43− "{\"foo\":\"bar\"}"
44−
45−testDPath :: ByteString -> Session SResponse
46−testDPath proto =
47− request $ flip setRawPathInfo "/d/" defaultRequest
48− { requestHeaders = [("X-Forwarded-Proto", proto)]
49− , requestHeaderHost = Just "example.com"
50− }
51−
52−location :: IsString ci => ci
53−location = "Location"
wai-extra/test/Network/Wai/Middleware/StripHeadersSpec.hsdeleted−58
@@ -1,58 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.Middleware.StripHeadersSpec
3− ( main
4− , spec
5− ) where
6−
7−import Test.Hspec
8−
9−import Network.Wai.Middleware.AddHeaders
10−import Network.Wai.Middleware.StripHeaders
11−
12−import Control.Arrow (first)
13−import Data.ByteString (ByteString)
14−import Data.Monoid ((<>))
15−import Network.HTTP.Types (status200)
16−import Network.Wai
17−import Network.Wai.Test
18−
19−import qualified Data.CaseInsensitive as CI
20−
21−
22−main :: IO ()
23−main = hspec spec
24−
25−
26−spec :: Spec
27−spec = describe "stripHeader" $ do
28− let host = "example.com"
29− let ciTestHeaders = map (first CI.mk) testHeaders
30−
31− it "strips a specific header" $ do
32− resp1 <- runApp host (addHeaders testHeaders) defaultRequest
33− resp2 <- runApp host (stripHeaderIf "Foo" (const False) . addHeaders testHeaders) defaultRequest
34− resp3 <- runApp host (stripHeaderIf "Foo" (const True) . addHeaders testHeaders) defaultRequest
35−
36− simpleHeaders resp1 `shouldBe` ciTestHeaders
37− simpleHeaders resp2 `shouldBe` ciTestHeaders
38− simpleHeaders resp3 `shouldBe` tail ciTestHeaders
39−
40− it "strips specific set of headers" $ do
41− resp1 <- runApp host (addHeaders testHeaders) defaultRequest
42− resp2 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const False) . addHeaders testHeaders) defaultRequest
43− resp3 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const True) . addHeaders testHeaders) defaultRequest
44−
45− simpleHeaders resp1 `shouldBe` ciTestHeaders
46− simpleHeaders resp2 `shouldBe` ciTestHeaders
47− simpleHeaders resp3 `shouldBe` [last ciTestHeaders]
48−
49−
50−testHeaders :: [(ByteString, ByteString)]
51−testHeaders = [("Foo", "fooey"), ("Bar", "barbican"), ("Baz", "bazooka")]
52−
53−
54−runApp :: ByteString -> Middleware -> Request -> IO SResponse
55−runApp host mw req = runSession
56− (request req { requestHeaderHost = Just $ host <> ":80" }) $ mw app
57− where
58− app _ respond = respond $ responseLBS status200 [] ""
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−94
@@ -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,11 +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−
102− let def = defaultParseRequestBodyOptions
103 it "parsing actual post multipart/form-data" $ do
96 it "parsing actual post multipart/form-data" $ do
104 result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
97 result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
105 result3 `shouldBe` expected3
98 result3 `shouldBe` expected3
@@ -107,61 +100,6 @@ caseParseRequestBody = do
107 it "parsing actual post multipart/form-data 2" $ do
100 it "parsing actual post multipart/form-data 2" $ do
108 result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
101 result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
109 result3' `shouldBe` expected3
102 result3' `shouldBe` expected3
110−
111− it "parsing with memory limit" $ do
112− SRequest req4 _bod4 <- toRequest'' ctype3 content3
113− result4' <- parseRequestBodyEx ( setMaxRequestNumFiles 1 $ setMaxRequestKeyLength 14 def ) lbsBackEnd req4
114− result4' `shouldBe` expected3
115−
116− it "exceeding number of files" $ do
117− SRequest req4 _bod4 <- toRequest'' ctype3 content3
118− (parseRequestBodyEx ( setMaxRequestNumFiles 0 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall
119−
120− it "exceeding parameter length" $ do
121− SRequest req4 _bod4 <- toRequest'' ctype3 content3
122− (parseRequestBodyEx ( setMaxRequestKeyLength 2 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall
123−
124− it "exceeding file size" $ do
125− SRequest req4 _bod4 <- toRequest'' ctype3 content3
126− (parseRequestBodyEx ( setMaxRequestFileSize 2 def ) lbsBackEnd req4)
127− `shouldThrow` unknownErrorException 413
128−
129− it "exceeding total file size" $ do
130− SRequest req4 _bod4 <- toRequest'' ctype3 content3
131− (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req4)
132− `shouldThrow` unknownErrorException 413
133− SRequest req5 _bod5 <- toRequest'' ctype3 content5
134− (parseRequestBodyEx ( setMaxRequestFilesSize 20 def ) lbsBackEnd req5)
135− `shouldThrow` unknownErrorException 413
136−
137− it "exceeding max parm value size" $ do
138− SRequest req4 _bod4 <- toRequest'' ctype2 content2
139− (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req4)
140− `shouldThrow` unknownErrorException 413
141−
142− it "exceeding max header lines" $ do
143− SRequest req4 _bod4 <- toRequest'' ctype2 content2
144− (parseRequestBodyEx ( setMaxHeaderLines 1 def ) lbsBackEnd req4) `shouldThrow` anyErrorCall
145−
146− it "exceeding header line size" $ do
147− SRequest req4 _bod4 <- toRequest'' ctype3 content4
148− (parseRequestBodyEx ( setMaxHeaderLineLength 8190 def ) lbsBackEnd req4)
149− `shouldThrow` unknownErrorException 431
150−
151− it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do
152− let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"
153− let ctype = "application/x-www-form-urlencoded"
154− SRequest req _bod <- toRequest'' ctype content
155− result <- parseRequestBodyEx def lbsBackEnd req
156− result `shouldBe` ([( "thisisalongparameterkey"
157− , "andthisbeanevenlongerparametervaluehelloworldhowareyou" )], [])
158−
159− it "exceeding max parm value size with x-www-form-urlencoded mimetype" $ do
160− let content = "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"
161− let ctype = "application/x-www-form-urlencoded"
162− SRequest req _bod <- toRequest'' ctype content
163− (parseRequestBodyEx ( setMaxRequestParmsSize 10 def ) lbsBackEnd req) `shouldThrow` anyErrorCall
164−
165 where
103 where
166 content2 =
104 content2 =
167 "--AaB03x\n"
105 "--AaB03x\n"
@@ -185,27 +123,6 @@ caseParseRequestBody = do
185 <> "Content-Type: application/octet-stream\r\n\r\n"
123 <> "Content-Type: application/octet-stream\r\n\r\n"
186 <> "Photo blog using Hack.\n\r\n"
124 <> "Photo blog using Hack.\n\r\n"
187 <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
125 <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
188− content4 =
189− "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
190− <> "Content-Disposition: form-data; name=\"alb\"; filename=\"README\"\r\n"
191− <> "Content-Type: application/octet-stream\r\n\r\n"
192− <> "Photo blog using Hack.\r\n\r\n"
193− <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
194− <> "Content-Disposition: form-data; name=\"bla\"; filename=\"riedmi"
195− <> S8.replicate 8190 'e' <> "\"\r\n"
196− <> "Content-Type: application/octet-stream\r\n\r\n"
197− <> "Photo blog using Hack.\r\n\r\n"
198− <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
199− content5 =
200− "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
201− <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"
202− <> "Content-Type: application/octet-stream\r\n\r\n"
203− <> "Photo blog using Hack.\n\r\n"
204− <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
205− <> "Content-Disposition: form-data; name=\"yaml2\"; filename=\"MEADRE\"\r\n"
206− <> "Content-Type: application/octet-stream\r\n\r\n"
207− <> "Photo blog using Hack.\n\r\n"
208− <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
209
126
210caseMultipartPlus :: Assertion
127caseMultipartPlus :: Assertion
211caseMultipartPlus = do
128caseMultipartPlus = do
@@ -281,14 +198,3 @@ toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
281toRequest' ctype content = SRequest defaultRequest
198toRequest' ctype content = SRequest defaultRequest
282 { requestHeaders = [("Content-Type", ctype)]
199 { requestHeaders = [("Content-Type", ctype)]
283 } (L.fromChunks $ map S.singleton $ S.unpack content)
200 } (L.fromChunks $ map S.singleton $ S.unpack content)
284−
285−toRequest'' :: S8.ByteString -> S8.ByteString -> IO SRequest
286−toRequest'' ctype content = mkRB content >>= \b -> return $ SRequest defaultRequest
287− { requestHeaders = [("Content-Type", ctype)], requestBody = b
288− } (L.fromChunks $ map S.singleton $ S.unpack content)
289−
290−mkRB :: S8.ByteString -> IO (IO S8.ByteString)
291−mkRB content = do
292− r <- I.newIORef content
293− return $
294− I.atomicModifyIORef r $ \a -> (S8.empty, a)
wai-extra/test/Network/Wai/RequestSpec.hs+39−69
@@ -8,82 +8,52 @@ import Test.Hspec
8
8
9import Data.ByteString (ByteString)
9import Data.ByteString (ByteString)
10import Network.HTTP.Types (HeaderName)
10import Network.HTTP.Types (HeaderName)
11−import Network.Wai (Request(..), defaultRequest, RequestBodyLength(..))
11+import Network.Wai (Request(..), defaultRequest)
12
12
13import Network.Wai.Request
13import Network.Wai.Request
14−import Control.Exception (try)
15−import Control.Monad (forever)
16
14
17main :: IO ()
15main :: IO ()
18main = hspec spec
16main = hspec spec
19
17
20spec :: Spec
18spec :: Spec
21−spec = do
19+spec = describe "appearsSecure" $ do
22− describe "requestSizeCheck" $ do
23− it "too large content length should throw RequestSizeException" $ do
24− let limit = 1024
25− largeRequest = defaultRequest
20+ let insecureRequest = defaultRequest
26− { isSecure = False
27− , requestBodyLength = KnownLength (limit + 1)
28− , requestBody = return "repeat this chunk"
29− }
30− checkedRequest <- requestSizeCheck limit largeRequest
31− body <- try (requestBody checkedRequest)
32− case body of
33− Left (RequestSizeException l) -> l `shouldBe` limit
34− Right _ -> expectationFailure "request size check failed"
35−
36− it "too many chunks should throw RequestSizeException" $ do
37− let limit = 1024
38− largeRequest = defaultRequest
39− { isSecure = False
21+ { isSecure = False
40− , requestBodyLength = ChunkedBody
41− , requestBody = return "repeat this chunk"
42− }
43− checkedRequest <- requestSizeCheck limit largeRequest
44− body <- try (forever $ requestBody checkedRequest)
45− case body of
46− Left (RequestSizeException l) -> l `shouldBe` limit
47− Right _ -> expectationFailure "request size check failed"
48−
49− describe "appearsSecure" $ do
50− let insecureRequest = defaultRequest
51− { isSecure = False
52− , requestHeaders =
22+ , requestHeaders =
53− [ ("HTTPS", "off")
23+ [ ("HTTPS", "off")
54− , ("HTTP_X_FORWARDED_SSL", "off")
24+ , ("HTTP_X_FORWARDED_SSL", "off")
55− , ("HTTP_X_FORWARDED_SCHEME", "http")
25+ , ("HTTP_X_FORWARDED_SCHEME", "http")
56− , ("HTTP_X_FORWARDED_PROTO", "http,xyz")
26+ , ("HTTP_X_FORWARDED_PROTO", "http,xyz")
57− ]
27+ ]
58− }
28+ }
59−
29+
60− it "returns False for an insecure request" $
30+ it "returns False for an insecure request" $
61− insecureRequest `shouldSatisfy` not . appearsSecure
31+ insecureRequest `shouldSatisfy` not . appearsSecure
62−
32+
63− it "checks if the Request is actually secure" $ do
33+ it "checks if the Request is actually secure" $ do
64− let req = insecureRequest { isSecure = True }
34+ let req = insecureRequest { isSecure = True }
65−
35+
66− req `shouldSatisfy` appearsSecure
36+ req `shouldSatisfy` appearsSecure
67−
37+
68− it "checks for HTTP: on" $ do
38+ it "checks for HTTP: on" $ do
69− let req = addHeader "HTTPS" "on" insecureRequest
39+ let req = addHeader "HTTPS" "on" insecureRequest
70−
40+
71− req `shouldSatisfy` appearsSecure
41+ req `shouldSatisfy` appearsSecure
72−
42+
73− it "checks for HTTP_X_FORWARDED_SSL: on" $ do
43+ it "checks for HTTP_X_FORWARDED_SSL: on" $ do
74− let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest
44+ let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest
75−
45+
76− req `shouldSatisfy` appearsSecure
46+ req `shouldSatisfy` appearsSecure
77−
47+
78− it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do
48+ it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do
79− let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest
49+ let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest
80−
50+
81− req `shouldSatisfy` appearsSecure
51+ req `shouldSatisfy` appearsSecure
82−
52+
83− it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do
53+ it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do
84− let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest
54+ let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest
85−
55+
86− req `shouldSatisfy` appearsSecure
56+ req `shouldSatisfy` appearsSecure
87
57
88addHeader :: HeaderName -> ByteString -> Request -> Request
58addHeader :: HeaderName -> ByteString -> Request -> Request
89addHeader name value req = req
59addHeader name value req = req
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/test/WaiExtraSpec.hs+3−1
@@ -341,8 +341,10 @@ caseDebugRequestBody = do
341 }
341 }
342 where
342 where
343 params = [("foo", "bar"), ("baz", "bin")]
343 params = [("foo", "bar"), ("baz", "bin")]
344+ -- FIXME change back once we include post parameter output in logging
345+ -- postOutput = T.pack $ "POST \nAccept: \n Params: " ++ (show params)
344 -- the time cannot be known, so match around it
346 -- the time cannot be known, so match around it
345− postOutput = (T.pack $ "POST /\n Params: " ++ (show params), "s\n")
347+ postOutput = ("POST /\n Accept: \n Status: 200 OK 0", "s\n")
346 getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n")
348 getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n")
347
349
348 debugApp (beginning, ending) req send = do
350 debugApp (beginning, ending) req send = do
wai-extra/wai-extra.cabal+15−52
@@ -1,5 +1,5 @@
1Name: wai-extra
1Name: wai-extra
2−Version: 3.0.29.1
2+Version: 3.0.7.1
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:
@@ -71,7 +71,7 @@ Maintainer: michael@snoyman.com
71Homepage: http://github.com/yesodweb/wai
71Homepage: http://github.com/yesodweb/wai
72Category: Web
72Category: Web
73Build-Type: Simple
73Build-Type: Simple
74−Cabal-Version: >=1.10
74+Cabal-Version: >=1.8
75Stability: Stable
75Stability: Stable
76extra-source-files:
76extra-source-files:
77 test/requests/dalvik-request
77 test/requests/dalvik-request
@@ -81,52 +81,43 @@ extra-source-files:
81 ChangeLog.md
81 ChangeLog.md
82 README.md
82 README.md
83
83
84−flag build-example
85− description: Build example executable.
86− manual: True
87− default: False
88−
89Library
84Library
90− Build-Depends: base >= 4.8 && < 5
85+ Build-Depends: base >= 4 && < 5
91− , bytestring >= 0.10.4
86+ , bytestring >= 0.9.1.4
92− , wai >= 3.0.3.0 && < 3.3
87+ , wai >= 3.0 && < 3.1
93 , old-locale >= 1.0.0.2 && < 1.1
88 , old-locale >= 1.0.0.2 && < 1.1
94 , time >= 1.1.4
89 , time >= 1.1.4
95− , network >= 2.6.1.0
90+ , network >= 2.2.1.5
96 , directory >= 1.0.1
91 , directory >= 1.0.1
97 , transformers >= 0.2.2
92 , transformers >= 0.2.2
93+ , blaze-builder >= 0.2.1.4 && < 0.5
98 , http-types >= 0.7
94 , http-types >= 0.7
99 , text >= 0.7
95 , text >= 0.7
100 , case-insensitive >= 0.2
96 , case-insensitive >= 0.2
101 , data-default-class
97 , data-default-class
102− , fast-logger >= 2.4.5
98+ , fast-logger >= 2.1 && < 2.4
103− , wai-logger >= 2.3.2
99+ , wai-logger >= 2.0 && < 2.3
104 , ansi-terminal
100 , ansi-terminal
105− , resourcet >= 0.4.6 && < 1.3
101+ , resourcet >= 0.4.6 && < 1.2
106 , void >= 0.5
102 , void >= 0.5
103+ , stringsearch >= 0.3 && < 0.4
107 , containers
104 , containers
108 , base64-bytestring
105 , base64-bytestring
109 , word8
106 , word8
107+ , lifted-base >= 0.1.2
110 , deepseq
108 , deepseq
111− , streaming-commons >= 0.2
109+ , streaming-commons
112 , unix-compat
110 , unix-compat
113 , cookie
111 , cookie
114 , vault
112 , vault
115− , zlib
116− , aeson
117− , iproute
118− , http2
119
113
120 if os(windows)
114 if os(windows)
121 cpp-options: -DWINDOWS
115 cpp-options: -DWINDOWS
122 else
116 else
123 build-depends: unix
117 build-depends: unix
124
118
125− default-extensions: OverloadedStrings
126−
127 Exposed-modules: Network.Wai.Handler.CGI
119 Exposed-modules: Network.Wai.Handler.CGI
128 Network.Wai.Handler.SCGI
120 Network.Wai.Handler.SCGI
129− Network.Wai.Header
130 Network.Wai.Middleware.AcceptOverride
121 Network.Wai.Middleware.AcceptOverride
131 Network.Wai.Middleware.AddHeaders
122 Network.Wai.Middleware.AddHeaders
132 Network.Wai.Middleware.Approot
123 Network.Wai.Middleware.Approot
@@ -134,47 +125,24 @@ Library
134 Network.Wai.Middleware.CleanPath
125 Network.Wai.Middleware.CleanPath
135 Network.Wai.Middleware.Local
126 Network.Wai.Middleware.Local
136 Network.Wai.Middleware.RequestLogger
127 Network.Wai.Middleware.RequestLogger
137− Network.Wai.Middleware.RequestLogger.JSON
138 Network.Wai.Middleware.Gzip
128 Network.Wai.Middleware.Gzip
139 Network.Wai.Middleware.Jsonp
129 Network.Wai.Middleware.Jsonp
140 Network.Wai.Middleware.MethodOverride
130 Network.Wai.Middleware.MethodOverride
141 Network.Wai.Middleware.MethodOverridePost
131 Network.Wai.Middleware.MethodOverridePost
142 Network.Wai.Middleware.Rewrite
132 Network.Wai.Middleware.Rewrite
143− Network.Wai.Middleware.StripHeaders
144 Network.Wai.Middleware.Vhost
133 Network.Wai.Middleware.Vhost
145 Network.Wai.Middleware.HttpAuth
134 Network.Wai.Middleware.HttpAuth
146 Network.Wai.Middleware.StreamFile
135 Network.Wai.Middleware.StreamFile
147− Network.Wai.Middleware.ForceDomain
148 Network.Wai.Middleware.ForceSSL
136 Network.Wai.Middleware.ForceSSL
149− Network.Wai.Middleware.Routed
150− Network.Wai.Middleware.Timeout
151 Network.Wai.Parse
137 Network.Wai.Parse
152 Network.Wai.Request
138 Network.Wai.Request
153 Network.Wai.UrlMap
139 Network.Wai.UrlMap
154 Network.Wai.Test
140 Network.Wai.Test
155− Network.Wai.Test.Internal
156 Network.Wai.EventSource
141 Network.Wai.EventSource
157 Network.Wai.EventSource.EventStream
142 Network.Wai.EventSource.EventStream
158 other-modules: Network.Wai.Middleware.RequestLogger.Internal
143 other-modules: Network.Wai.Middleware.RequestLogger.Internal
159− default-language: Haskell2010
160 ghc-options: -Wall
144 ghc-options: -Wall
161
145
162−executable example
163− hs-source-dirs: example
164− main-is: Main.hs
165− ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
166− if flag(build-example)
167− build-depends: base
168− , wai-extra
169− , warp
170− , wai
171− , time
172− , http-types
173− , bytestring
174− else
175− buildable: False
176− default-language: Haskell2010
177−
178test-suite spec
146test-suite spec
179 type: exitcode-stdio-1.0
147 type: exitcode-stdio-1.0
180 hs-source-dirs: test
148 hs-source-dirs: test
@@ -184,9 +152,6 @@ test-suite spec
184 Network.Wai.RequestSpec
152 Network.Wai.RequestSpec
185 Network.Wai.Middleware.ApprootSpec
153 Network.Wai.Middleware.ApprootSpec
186 Network.Wai.Middleware.ForceSSLSpec
154 Network.Wai.Middleware.ForceSSLSpec
187− Network.Wai.Middleware.RoutedSpec
188− Network.Wai.Middleware.StripHeadersSpec
189− Network.Wai.Middleware.TimeoutSpec
190 WaiExtraSpec
155 WaiExtraSpec
191 build-depends: base >= 4 && < 5
156 build-depends: base >= 4 && < 5
192 , wai-extra
157 , wai-extra
@@ -200,12 +165,10 @@ test-suite spec
200 , resourcet
165 , resourcet
201 , bytestring
166 , bytestring
202 , HUnit
167 , HUnit
168+ , blaze-builder
203 , cookie
169 , cookie
204 , time
170 , time
205− , case-insensitive
206− , http2
207− ghc-options: -Wall
171+ ghc-options: -Wall -Werror
208− default-language: Haskell2010
209
172
210source-repository head
173source-repository head
211 type: git
174 type: git
wai-frontend-monadcgi/ChangeLog.md+1−7
@@ -1,7 +1 @@
1−## 3.0.0.3
1+No changes logged yet.
2−
3−* wai-frontend-monadcgi does not drop '?' in query string [#590](https://github.com/yesodweb/wai/issues/590)
4−
5−## 3.0.0.2
6−
7−* Support for wai 3.2
wai-frontend-monadcgi/Network/Wai/Frontend/MonadCGI.hs+1−4
@@ -64,8 +64,5 @@ getCgiVars :: Request -> [(String, String)]
64getCgiVars e =
64getCgiVars e =
65 [ ("PATH_INFO", S8.unpack $ rawPathInfo e)
65 [ ("PATH_INFO", S8.unpack $ rawPathInfo e)
66 , ("REQUEST_METHOD", show $ requestMethod e)
66 , ("REQUEST_METHOD", show $ requestMethod e)
67− , ("QUERY_STRING",
68− case S8.unpack $ rawQueryString e of
67+ , ("QUERY_STRING", S8.unpack $ rawQueryString e)
69− '?':rest -> rest
70− x -> x)
71 ]
68 ]
wai-frontend-monadcgi/wai-frontend-monadcgi.cabal+2−2
@@ -1,5 +1,5 @@
1name: wai-frontend-monadcgi
1name: wai-frontend-monadcgi
2−version: 3.0.0.3
2+version: 3.0.0.1
3license: MIT
3license: MIT
4license-file: LICENSE
4license-file: LICENSE
5author: Michael Snoyman <michael@snoyman.com>
5author: Michael Snoyman <michael@snoyman.com>
@@ -20,7 +20,7 @@ library
20 , http-types
20 , http-types
21 , transformers
21 , transformers
22 , case-insensitive
22 , case-insensitive
23− , wai >= 3.0 && < 3.3
23+ , wai >= 3.0 && < 3.1
24 exposed-modules: Network.Wai.Frontend.MonadCGI
24 exposed-modules: Network.Wai.Frontend.MonadCGI
25 ghc-options: -Wall
25 ghc-options: -Wall
26
26
wai-handler-fastcgi/.gitignorenew file+4
@@ -0,0 +1,4 @@
1+/dist/
2+*.swp
3+*.hi
4+*.o
wai-handler-fastcgi/ChangeLog.mdnew file+1
@@ -0,0 +1 @@
1+No changes logged yet.
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.1
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.1
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+7
@@ -0,0 +1,7 @@
1+## 3.0.0.3
2+
3+Allow blaze-builder 0.4
4+
5+## 3.0.0.2
6+
7+* Support for Win64
wai-http2-extra/LICENSE → wai-handler-launch/LICENSErenamed+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2016 Kazu Yamamoto, http://www.yesodweb.com/
1+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
2
2
3Permission is hereby granted, free of charge, to any person obtaining
3Permission is hereby granted, free of charge, to any person obtaining
4a copy of this software and associated documentation files (the
4a copy of this software and associated documentation files (the
wai-handler-launch/Network/Wai/Handler/Launch.hsnew file+206
@@ -0,0 +1,206 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+{-# LANGUAGE CPP #-}
4+module Network.Wai.Handler.Launch
5+ ( run
6+ , runUrl
7+ , runUrlPort
8+ ) where
9+
10+import Network.Wai
11+import Network.Wai.Internal
12+import Network.HTTP.Types
13+import qualified Network.Wai.Handler.Warp as Warp
14+import Data.IORef
15+import Data.Monoid (mappend)
16+import Control.Concurrent (forkIO, threadDelay)
17+import Control.Monad.IO.Class (liftIO)
18+import Control.Monad (unless)
19+import Control.Exception (throwIO)
20+import Data.Function (fix)
21+import qualified Data.ByteString as S
22+import Blaze.ByteString.Builder (fromByteString, Builder, flush)
23+import qualified Blaze.ByteString.Builder as Blaze
24+#if WINDOWS
25+import Foreign
26+import Foreign.C.String
27+#else
28+import System.Process (rawSystem)
29+#endif
30+import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)
31+import qualified Data.Streaming.Zlib as Z
32+
33+ping :: IORef Bool -> Middleware
34+ping var app req sendResponse
35+ | pathInfo req == ["_ping"] = do
36+ liftIO $ writeIORef var True
37+ sendResponse $ responseLBS status200 [] ""
38+ | otherwise = app req $ \res -> do
39+ let isHtml hs =
40+ case lookup "content-type" hs of
41+ Just ct -> "text/html" `S.isPrefixOf` ct
42+ Nothing -> False
43+ if isHtml $ responseHeaders res
44+ then do
45+ let (s, hs, withBody) = responseToStream res
46+ (isEnc, headers') = fixHeaders id hs
47+ headers'' = filter (\(x, _) -> x /= "content-length") headers'
48+ withBody $ \body ->
49+ sendResponse $ responseStream s headers'' $ \sendChunk flush ->
50+ addInsideHead sendChunk flush $ \sendChunk' flush' ->
51+ if isEnc
52+ then decode sendChunk' flush' body
53+ else body sendChunk' flush'
54+ else sendResponse res
55+
56+decode :: (Builder -> IO ()) -> IO ()
57+ -> StreamingBody
58+ -> IO ()
59+decode sendInner flushInner streamingBody = do
60+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy
61+ inflate <- Z.initInflate $ Z.WindowBits 31
62+ let send builder = blazeRecv builder >>= goBuilderPopper
63+ goBuilderPopper popper = fix $ \loop -> do
64+ bs <- popper
65+ unless (S.null bs) $ do
66+ Z.feedInflate inflate bs >>= goZlibPopper
67+ loop
68+ goZlibPopper popper = fix $ \loop -> do
69+ res <- popper
70+ case res of
71+ Z.PRDone -> return ()
72+ Z.PRNext bs -> do
73+ sendInner $ fromByteString bs
74+ loop
75+ Z.PRError e -> throwIO e
76+ streamingBody send (send flush)
77+ mbs <- blazeFinish
78+ case mbs of
79+ Nothing -> return ()
80+ Just bs -> Z.feedInflate inflate bs >>= goZlibPopper
81+ Z.finishInflate inflate >>= sendInner . fromByteString
82+
83+toInsert :: S.ByteString
84+toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping\",false);x.send();},60000)</script>"
85+
86+addInsideHead :: (Builder -> IO ())
87+ -> IO ()
88+ -> StreamingBody
89+ -> IO ()
90+addInsideHead sendInner flushInner streamingBody = do
91+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy
92+ ref <- newIORef $ Just (S.empty, whole)
93+ streamingBody (inner blazeRecv ref) (flush blazeRecv ref)
94+ state <- readIORef ref
95+ mbs <- blazeFinish
96+ held <- case mbs of
97+ Nothing -> return state
98+ Just bs -> push state bs
99+ case state of
100+ Nothing -> return ()
101+ Just (held, _) -> sendInner $ fromByteString held `mappend` fromByteString toInsert
102+ where
103+ whole = "<head>"
104+
105+ flush blazeRecv ref = inner blazeRecv ref Blaze.flush
106+
107+ inner blazeRecv ref builder = do
108+ state0 <- readIORef ref
109+ popper <- blazeRecv builder
110+ let loop state = do
111+ bs <- popper
112+ if S.null bs
113+ then writeIORef ref state
114+ else push state bs >>= loop
115+ loop state0
116+
117+ push Nothing x = sendInner (fromByteString x) >> return Nothing
118+ push (Just (held, atFront)) x
119+ | atFront `S.isPrefixOf` x = do
120+ let y = S.drop (S.length atFront) x
121+ sendInner $ fromByteString held
122+ `mappend` fromByteString atFront
123+ `mappend` fromByteString toInsert
124+ `mappend` fromByteString y
125+ return Nothing
126+ | whole `S.isInfixOf` x = do
127+ let (before, rest) = S.breakSubstring whole x
128+ let after = S.drop (S.length whole) rest
129+ sendInner $ fromByteString held
130+ `mappend` fromByteString before
131+ `mappend` fromByteString whole
132+ `mappend` fromByteString toInsert
133+ `mappend` fromByteString after
134+ return Nothing
135+ | x `S.isPrefixOf` atFront = do
136+ let held' = held `S.append` x
137+ atFront' = S.drop (S.length x) atFront
138+ return $ Just (held', atFront')
139+ | otherwise = do
140+ let (held', atFront', x') = getOverlap whole x
141+ sendInner $ fromByteString held `mappend` fromByteString x'
142+ return $ Just (held', atFront')
143+
144+getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
145+getOverlap whole x =
146+ go whole
147+ where
148+ go piece
149+ | S.null piece = ("", whole, x)
150+ | piece `S.isSuffixOf` x =
151+ let x' = S.take (S.length x - S.length piece) x
152+ atFront = S.drop (S.length piece) whole
153+ in (piece, atFront, x')
154+ | otherwise = go $ S.init piece
155+
156+fixHeaders :: ([Header] -> [Header])
157+ -> [Header]
158+ -> (Bool, [Header])
159+fixHeaders front [] = (False, front [])
160+fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)
161+fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs
162+
163+#if WINDOWS
164+foreign import ccall "launch"
165+ launch' :: Int -> CString -> IO ()
166+#endif
167+
168+launch :: Int -> String -> IO ()
169+
170+#if WINDOWS
171+launch port s = withCString s $ launch' port
172+#else
173+launch port s = forkIO (rawSystem
174+#if MAC
175+ "open"
176+#else
177+ "xdg-open"
178+#endif
179+ ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return ()
180+#endif
181+
182+run :: Application -> IO ()
183+run = runUrl ""
184+
185+runUrl :: String -> Application -> IO ()
186+runUrl = runUrlPort 4587
187+
188+runUrlPort :: Int -> String -> Application -> IO ()
189+runUrlPort port url app = do
190+ x <- newIORef True
191+ _ <- forkIO $ Warp.runSettings
192+ ( Warp.setPort port
193+ $ Warp.setOnException (\_ _ -> return ())
194+ $ Warp.setHost "*4" Warp.defaultSettings)
195+ $ ping x app
196+ launch port url
197+ loop x
198+
199+loop :: IORef Bool -> IO ()
200+loop x = do
201+ let seconds = 120
202+ threadDelay $ 1000000 * seconds
203+ b <- readIORef x
204+ if b
205+ then writeIORef x False >> loop x
206+ 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+36
@@ -0,0 +1,36 @@
1+Name: wai-handler-launch
2+Version: 3.0.0.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.1
18+ , warp >= 3.0 && < 3.1
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+
25+ if os(windows)
26+ c-sources: windows.c
27+ cpp-options: -DWINDOWS
28+ extra-libraries: Shell32 msvcrt
29+ else
30+ build-depends: process >= 1.0 && < 1.3
31+ if os(darwin)
32+ cpp-options: -DMAC
33+
34+source-repository head
35+ type: git
36+ 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+1
@@ -0,0 +1 @@
1+No changes logged yet
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.1
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.1
19+ , warp >= 3.0 && < 3.1
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.hsdeleted−236
@@ -1,236 +0,0 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}
2−
3−-- | Middleware for server push learning dependency based on Referer:.
4−module Network.Wai.Middleware.Push.Referer (
5− -- * Middleware
6− pushOnReferer
7− -- * Making push promise
8− , URLPath
9− , MakePushPromise
10− , defaultMakePushPromise
11− -- * Settings
12− , Settings
13− , defaultSettings
14− , makePushPromise
15− , duration
16− , keyLimit
17− , valueLimit
18− ) where
19−
20−import Control.Monad (when, unless)
21−import Control.Reaper
22−import Data.ByteString (ByteString)
23−import qualified Data.ByteString as BS
24−import Data.ByteString.Internal (ByteString(..), memchr)
25−import Data.IORef
26−import Data.Maybe (isNothing)
27−import Data.Word (Word8)
28−import Data.Word8
29−import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
30−import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
31−import Foreign.Storable (peek)
32−import Network.HTTP.Types (Status(..))
33−import Network.Wai
34−import Network.Wai.Handler.Warp hiding (Settings, defaultSettings)
35−import Network.Wai.Internal (Response(..))
36−import System.IO.Unsafe (unsafePerformIO)
37−
38−import qualified Network.Wai.Middleware.Push.Referer.LimitMultiMap as M
39−
40−-- $setup
41−-- >>> :set -XOverloadedStrings
42−
43−-- | Making a push promise based on Referer:,
44−-- path to be pushed and file to be pushed.
45−-- If the middleware should push this file in the next time when
46−-- the page of Referer: is accessed,
47−-- this function should return 'Just'.
48−-- If 'Nothing' is returned,
49−-- the middleware learns nothing.
50−type MakePushPromise = URLPath -- ^ path in referer (key: /index.html)
51− -> URLPath -- ^ path to be pushed (value: /style.css)
52− -> FilePath -- ^ file to be pushed (file_path/style.css)
53− -> IO (Maybe PushPromise)
54−
55−-- | Type for URL path.
56−type URLPath = ByteString
57−
58−type Cache = M.LimitMultiMap URLPath PushPromise
59−
60−initialized :: IORef Bool
61−initialized = unsafePerformIO $ newIORef False
62−{-# NOINLINE initialized #-}
63−
64−cacheReaper :: IORef (Maybe (Reaper Cache (URLPath,PushPromise)))
65−cacheReaper = unsafePerformIO $ newIORef Nothing
66−{-# NOINLINE cacheReaper #-}
67−
68−-- | Settings for server push based on Referer:.
69−data Settings = Settings {
70− makePushPromise :: MakePushPromise -- ^ Default: 'defaultMakePushPromise'
71− , duration :: Int -- ^ Duration (in micro seconds) to keep the learning information. The information completely cleared every this duration. Default: 30000000
72− , keyLimit :: Int -- ^ Max number of keys (e.g. index.html) in the learning information. Default: 20
73− , valueLimit :: Int -- ^ Max number of values (e.g. style.css) in the learning information. Default: 20
74− }
75−
76−-- | Default settings.
77−defaultSettings :: Settings
78−defaultSettings = Settings {
79− makePushPromise = defaultMakePushPromise
80− , duration = 30000000
81− , keyLimit = 20
82− , valueLimit = 20
83− }
84−
85−tryInitialize :: Settings -> IO ()
86−tryInitialize Settings{..} = do
87− isInitialized <- atomicModifyIORef' initialized $ \x -> (True, x)
88− unless isInitialized $ do
89− reaper <- mkReaper settings
90− writeIORef cacheReaper (Just reaper)
91− where
92− emptyCache = M.empty keyLimit valueLimit
93− settings :: ReaperSettings Cache (URLPath,PushPromise)
94− settings = defaultReaperSettings {
95− reaperAction = \_ -> return (\_ -> emptyCache)
96− , reaperCons = M.insert
97− , reaperNull = M.isEmpty
98− , reaperEmpty = emptyCache
99− , reaperDelay = duration
100− }
101−
102−-- | The middleware to push files based on Referer:.
103−-- Learning strategy is implemented in the first argument.
104−pushOnReferer :: Settings -> Middleware
105−pushOnReferer settings@Settings{..} app req sendResponse = do
106− tryInitialize settings
107− mreaper <- readIORef cacheReaper
108− case mreaper of
109− Nothing -> app req sendResponse
110− Just reaper -> app req (push reaper)
111− where
112− push reaper res@(ResponseFile (Status 200 "OK") _ file Nothing) = do
113− let !path = rawPathInfo req
114− m <- reaperRead reaper
115− case M.lookup path m of
116− [] -> case requestHeaderReferer req of
117− Nothing -> return ()
118− Just referer -> do
119− (mauth,refPath) <- parseUrl referer
120− when (isNothing mauth
121− || requestHeaderHost req == mauth) $ do
122− when (path /= refPath) $ do -- just in case
123− let !path' = BS.copy path
124− !refPath' = BS.copy refPath
125− mpp <- makePushPromise refPath' path' file
126− case mpp of
127− Nothing -> return ()
128− Just pp -> reaperAdd reaper (refPath',pp)
129− ps -> do
130− let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
131− setHTTP2Data req (Just h2d)
132− sendResponse res
133− push _ res = sendResponse res
134−
135−
136−-- | Learn if the file to be pushed is CSS (.css) or JavaScript (.js) file
137−-- AND the Referer: ends with \"/\" or \".html\" or \".htm\".
138−defaultMakePushPromise :: MakePushPromise
139−defaultMakePushPromise refPath path file
140− | isHTML refPath = case getCT path of
141− Nothing -> return Nothing
142− Just ct -> do
143− let pp = defaultPushPromise {
144− promisedPath = path
145− , promisedFile = file
146− , promisedResponseHeaders = [("content-type", ct)
147− ,("x-http2-push", refPath)]
148− }
149− return $ Just pp
150− | otherwise = return Nothing
151−
152−getCT :: URLPath -> Maybe ByteString
153−getCT p
154− | ".js" `BS.isSuffixOf` p = Just "application/javascript"
155− | ".css" `BS.isSuffixOf` p = Just "text/css"
156− | otherwise = Nothing
157−
158−isHTML :: URLPath -> Bool
159−isHTML p = ("/" `BS.isSuffixOf` p)
160− || (".html" `BS.isSuffixOf` p)
161− || (".htm" `BS.isSuffixOf` p)
162−
163−-- |
164−--
165−-- >>> parseUrl ""
166−-- (Nothing,"")
167−-- >>> parseUrl "/"
168−-- (Nothing,"/")
169−-- >>> parseUrl "ht"
170−-- (Nothing,"")
171−-- >>> parseUrl "http://example.com/foo/bar/"
172−-- (Just "example.com","/foo/bar/")
173−-- >>> parseUrl "https://www.example.com/path/to/dir/"
174−-- (Just "www.example.com","/path/to/dir/")
175−-- >>> parseUrl "http://www.example.com:8080/path/to/dir/"
176−-- (Just "www.example.com:8080","/path/to/dir/")
177−-- >>> parseUrl "//www.example.com:8080/path/to/dir/"
178−-- (Just "www.example.com:8080","/path/to/dir/")
179−-- >>> parseUrl "/path/to/dir/"
180−-- (Nothing,"/path/to/dir/")
181−
182−parseUrl :: ByteString -> IO (Maybe ByteString, URLPath)
183−parseUrl bs@(PS fptr0 off len)
184− | len == 0 = return (Nothing, "")
185− | len == 1 = return (Nothing, bs)
186− | otherwise = withForeignPtr fptr0 $ \ptr0 -> do
187− let begptr = ptr0 `plusPtr` off
188− limptr = begptr `plusPtr` len
189− parseUrl' fptr0 ptr0 begptr limptr len
190−
191−parseUrl' :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int
192− -> IO (Maybe ByteString, URLPath)
193−parseUrl' fptr0 ptr0 begptr limptr len0 = do
194− w0 <- peek begptr
195− if w0 == _slash then do
196− w1 <- peek $ begptr `plusPtr` 1
197− if w1 == _slash then
198− doubleSlashed begptr len0
199− else
200− slashed begptr len0 Nothing
201− else do
202− colonptr <- memchr begptr _colon $ fromIntegral len0
203− if colonptr == nullPtr then
204− return (Nothing, "")
205− else do
206− let !authptr = colonptr `plusPtr` 1
207− doubleSlashed authptr (limptr `minusPtr` authptr)
208− where
209− -- // / ?
210− doubleSlashed :: Ptr Word8 -> Int -> IO (Maybe ByteString, URLPath)
211− doubleSlashed ptr len
212− | len < 2 = return (Nothing, "")
213− | otherwise = do
214− let ptr1 = ptr `plusPtr` 2
215− pathptr <- memchr ptr1 _slash $ fromIntegral len
216− if pathptr == nullPtr then
217− return (Nothing, "")
218− else do
219− let !auth = bs ptr0 ptr1 pathptr
220− slashed pathptr (limptr `minusPtr` pathptr) (Just auth)
221−
222− -- / ?
223− slashed :: Ptr Word8 -> Int -> Maybe ByteString -> IO (Maybe ByteString, URLPath)
224− slashed ptr len mauth = do
225− questionptr <- memchr ptr _question $ fromIntegral len
226− if questionptr == nullPtr then do
227− let !path = bs ptr0 ptr limptr
228− return (mauth, path)
229− else do
230− let !path = bs ptr0 ptr questionptr
231− return (mauth, path)
232− bs p0 p1 p2 = path
233− where
234− !off = p1 `minusPtr` p0
235− !siz = p2 `minusPtr` p1
236− !path = PS fptr0 off siz
wai-http2-extra/Network/Wai/Middleware/Push/Referer/LimitMultiMap.hsdeleted−40
@@ -1,40 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−module Network.Wai.Middleware.Push.Referer.LimitMultiMap where
4−
5−import Data.Map (Map)
6−import qualified Data.Map.Strict as M
7−import Data.Set (Set)
8−import qualified Data.Set as S
9−
10−data LimitMultiMap k v = LimitMultiMap {
11− limitKey :: !Int
12− , limitVal :: !Int
13− , multiMap :: !(Map k (Set v))
14− } deriving (Eq, Show)
15−
16−isEmpty :: LimitMultiMap k t -> Bool
17−isEmpty (LimitMultiMap _ _ m) = M.null m
18−
19−empty :: Int -> Int -> LimitMultiMap k v
20−empty lk lv = LimitMultiMap lk lv M.empty
21−
22−insert :: (Ord k, Ord v) => (k,v) -> LimitMultiMap k v -> LimitMultiMap k v
23−insert (k,v) (LimitMultiMap lk lv m)
24− | siz < lk = let !m' = M.alter alt k m in LimitMultiMap lk lv m'
25− | siz == lk = let !m' = M.adjust adj k m in LimitMultiMap lk lv m'
26− | otherwise = error "insert"
27− where
28− siz = M.size m
29− alt Nothing = Just $ S.singleton v
30− alt s@(Just set)
31− | S.size set == lv = s
32− | otherwise = Just $ S.insert v set
33− adj set
34− | S.size set == lv = set
35− | otherwise = S.insert v set
36−
37−lookup :: Ord k => k -> LimitMultiMap k v -> [v]
38−lookup k (LimitMultiMap _ _ m) = case M.lookup k m of
39− Nothing -> []
40− Just set -> S.toList set
wai-http2-extra/test/doctests.hsdeleted−4
@@ -1,4 +0,0 @@
1−import Test.DocTest
2−
3−main :: IO ()
4−main = doctest ["Network"]
wai-http2-extra/wai-http2-extra.cabaldeleted−44
@@ -1,44 +0,0 @@
1−Name: wai-http2-extra
2−Version: 0.1.2
3−Synopsis: WAI utilities for HTTP/2
4−License: MIT
5−License-file: LICENSE
6−Author: Kazu Yamamoto
7−Maintainer: kazu@iij.ad.jp
8−Homepage: http://github.com/yesodweb/wai
9−Category: Web
10−Build-Type: Simple
11−Cabal-Version: >=1.10
12−Stability: Stable
13−Description: WAI utilities for HTTP/2
14−
15−Library
16− Build-Depends: base >= 3 && < 5
17− , auto-update >= 0.1.3 && < 0.2
18− , bytestring
19− , containers
20− , http-types
21− , wai
22− , warp
23− , word8
24− Exposed-modules: Network.Wai.Middleware.Push.Referer
25− Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap
26− Ghc-Options: -Wall
27− if impl(ghc >= 8)
28− default-extensions: Strict StrictData
29− default-language: Haskell2010
30−
31−Test-Suite doctest
32− Type: exitcode-stdio-1.0
33− HS-Source-Dirs: test
34− Ghc-Options: -threaded -Wall
35− Main-Is: doctests.hs
36− Build-Depends: base
37− , doctest >= 0.10.1
38− if impl(ghc >= 8)
39− default-extensions: Strict StrictData
40− default-language: Haskell2010
41−
42−Source-Repository head
43− Type: git
44− Location: git://github.com/yesodweb/wai.git
wai-websockets/ChangeLog.md−24
@@ -1,27 +1,3 @@
1−## 3.0.1.2
2−
3−* Drop unused dependency on blaze-builder
4−
5−## 3.0.1.1
6−
7−* Doc improvement
8−
9−## 3.0.1
10−
11−* Improved connection close logic
12−
13−## 3.0.0.9
14−
15−* Clean up stream resources when websockets completes [#549](https://github.com/yesodweb/wai/pull/549)
16−
17−## 3.0.0.8
18−
19−* Support wai 3.2
20−
21−## 3.0.0.7
22−
23−* Improved documentation [#471](https://github.com/yesodweb/wai/pull/471)
24−
25## 3.0.0.5
1## 3.0.0.5
26
2
27Allow blaze-builder 0.4
3Allow blaze-builder 0.4
wai-websockets/Network/Wai/Handler/WebSockets.hs+19−56
@@ -1,13 +1,12 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Network.Wai.Handler.WebSockets
2module Network.Wai.Handler.WebSockets
3− ( websocketsOr
3+ ( websocketsApp
4− , websocketsApp
4+ , websocketsOr
5 , isWebSocketsReq
5 , isWebSocketsReq
6 , getRequestHead
6 , getRequestHead
7 , runWebSockets
7 , runWebSockets
8 ) where
8 ) where
9
9
10−import Control.Exception (bracket, tryJust)
11import Data.ByteString (ByteString)
10import Data.ByteString (ByteString)
12import qualified Data.ByteString.Char8 as BC
11import qualified Data.ByteString.Char8 as BC
13import qualified Data.ByteString.Lazy as BL
12import qualified Data.ByteString.Lazy as BL
@@ -19,38 +18,11 @@ import qualified Network.WebSockets.Connection as WS
19import qualified Network.WebSockets.Stream as WS
18import qualified Network.WebSockets.Stream as WS
20
19
21--------------------------------------------------------------------------------
20--------------------------------------------------------------------------------
22−-- | Returns whether or not the given 'Wai.Request' is a WebSocket request.
23isWebSocketsReq :: Wai.Request -> Bool
21isWebSocketsReq :: Wai.Request -> Bool
24isWebSocketsReq req =
22isWebSocketsReq req =
25 fmap CI.mk (lookup "upgrade" $ Wai.requestHeaders req) == Just "websocket"
23 fmap CI.mk (lookup "upgrade" $ Wai.requestHeaders req) == Just "websocket"
26
24
27--------------------------------------------------------------------------------
25--------------------------------------------------------------------------------
28−-- | Upgrade a @websockets@ 'WS.ServerApp' to a @wai@ 'Wai.Application'. Uses
29−-- the given backup 'Wai.Application' to handle 'Wai.Request's that are not
30−-- WebSocket requests.
31−--
32−-- @
33−-- websocketsOr opts ws_app backup_app = \\req respond ->
34−-- __case__ 'websocketsApp' opts ws_app req __of__
35−-- 'Nothing' -> backup_app req send_response
36−-- 'Just' res -> respond res
37−-- @
38−--
39−-- For example, below is an 'Wai.Application' that sends @"Hello, client!"@ to
40−-- each connected client.
41−--
42−-- @
43−-- app :: 'Wai.Application'
44−-- app = 'websocketsOr' 'WS.defaultConnectionOptions' wsApp backupApp
45−-- __where__
46−-- wsApp :: 'WS.ServerApp'
47−-- wsApp pending_conn = do
48−-- conn <- 'WS.acceptRequest' pending_conn
49−-- 'WS.sendTextData' conn ("Hello, client!" :: 'Data.Text.Text')
50−--
51−-- backupApp :: 'Wai.Application'
52−-- backupApp _ respond = respond $ 'Wai.responseLBS' 'Network.HTTP.Types.status400' [] "Not a WebSocket request"
53−-- @
54websocketsOr :: WS.ConnectionOptions
26websocketsOr :: WS.ConnectionOptions
55 -> WS.ServerApp
27 -> WS.ServerApp
56 -> Wai.Application
28 -> Wai.Application
@@ -61,11 +33,6 @@ websocketsOr opts app backup req sendResponse =
61 Just res -> sendResponse res
33 Just res -> sendResponse res
62
34
63--------------------------------------------------------------------------------
35--------------------------------------------------------------------------------
64−-- | Handle a single @wai@ 'Wai.Request' with the given @websockets@
65−-- 'WS.ServerApp'. Returns 'Nothing' if the 'Wai.Request' is not a WebSocket
66−-- request, 'Just' otherwise.
67−--
68−-- Usually, 'websocketsOr' is more convenient.
69websocketsApp :: WS.ConnectionOptions
36websocketsApp :: WS.ConnectionOptions
70 -> WS.ServerApp
37 -> WS.ServerApp
71 -> Wai.Request
38 -> Wai.Request
@@ -88,31 +55,27 @@ getRequestHead req = WS.RequestHead
88 (Wai.isSecure req)
55 (Wai.isSecure req)
89
56
90--------------------------------------------------------------------------------
57--------------------------------------------------------------------------------
91−-- | Internal function to run the WebSocket io-streams using the conduit library.
58+---- | Internal function to run the WebSocket io-streams using the conduit library
92runWebSockets :: WS.ConnectionOptions
59runWebSockets :: WS.ConnectionOptions
93 -> WS.RequestHead
60 -> WS.RequestHead
94 -> (WS.PendingConnection -> IO a)
61 -> (WS.PendingConnection -> IO a)
95 -> IO ByteString
62 -> IO ByteString
96 -> (ByteString -> IO ())
63 -> (ByteString -> IO ())
97 -> IO a
64 -> IO a
98−runWebSockets opts req app src sink = bracket mkStream ensureClose (app . pc)
65+runWebSockets opts req app src sink = do
99− where
100− ensureClose = tryJust onConnectionException . WS.close
101− onConnectionException :: WS.ConnectionException -> Maybe ()
102− onConnectionException WS.ConnectionClosed = Just ()
103− onConnectionException _ = Nothing
104− mkStream =
105− WS.makeStream
66+ stream <- WS.makeStream
106− (do
67+ (do
107− bs <- src
68+ bs <- src
108− return $ if BC.null bs then Nothing else Just bs)
69+ return $ if BC.null bs then Nothing else Just bs)
109− (\mbBl -> case mbBl of
70+ (\mbBl -> case mbBl of
110− Nothing -> return ()
71+ Nothing -> return ()
111− Just bl -> mapM_ sink (BL.toChunks bl))
72+ Just bl -> mapM_ sink (BL.toChunks bl))
73+
74+ let pc = WS.PendingConnection
75+ { WS.pendingOptions = opts
76+ , WS.pendingRequest = req
77+ , WS.pendingOnAccept = \_ -> return ()
78+ , WS.pendingStream = stream
79+ }
112
80
113− pc stream = WS.PendingConnection
81+ app pc
114− { WS.pendingOptions = opts
115− , WS.pendingRequest = req
116− , WS.pendingOnAccept = \_ -> return ()
117− , WS.pendingStream = stream
118− }
wai-websockets/server.lhs+6−12
@@ -8,14 +8,12 @@ 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)
16−> import Control.Exception (finally)
14+> import Control.Exception (finally)
17> import Control.Monad (forM_, forever)
15> import Control.Monad (forM_, forever)
18−> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, modifyMVar)
16+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO, modifyMVar)
19> import Control.Monad.IO.Class (liftIO)
17> import Control.Monad.IO.Class (liftIO)
20> import qualified Data.Text as T
18> import qualified Data.Text as T
21> import qualified Data.Text.IO as T
19> import qualified Data.Text.IO as T
@@ -78,9 +76,9 @@ actual server.
78> main = do
76> main = do
79> putStrLn "http://localhost:9160/client.html"
77> putStrLn "http://localhost:9160/client.html"
80> state <- newMVar newServerState
78> state <- newMVar newServerState
81−> Warp.runSettings
79+> Warp.runSettings Warp.defaultSettings
82−> (Warp.setPort 9160 Warp.defaultSettings)
80+> { Warp.settingsPort = 9160
83−> $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp
81+> } $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp
84
82
85> staticApp :: Network.Wai.Application
83> staticApp :: Network.Wai.Application
86> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
84> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
@@ -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+4−3
@@ -1,5 +1,5 @@
1Name: wai-websockets
1Name: wai-websockets
2−Version: 3.0.1.2
2+Version: 3.0.0.5
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
@@ -20,7 +20,8 @@ flag example
20Library
20Library
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.1
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+1−49
@@ -1,54 +1,6 @@
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
16−
17−* Relax upper bound on bytestring-builder
18−
19−## 3.2.1
20−
21−* add mapResponseStatus [#532](https://github.com/yesodweb/wai/pull/532)
22−
23−## 3.2.0.1
24−
25−* Add missing changelog entry
26−
27−## 3.2.0
28−
29−* Major version up due to breaking changes. We chose 3.2.0, not 3.1.0
30− for consistency with Warp 3.2.0.
31−* The Network.Wai.HTTP2 module was removed.
32−* tryGetFileSize, hContentRange, hAcceptRanges, contentRangeHeader and
33− chooseFilePart, adjustForFilePart and parseByteRanges were removed
34− from the Network.Wai.Internal module.
35−* New fields for Request: requestHeaderReferer and requestHeaderUserAgent.
36−
37−## 3.0.5.0
38−
39−* Avoid using the IsString Builder instance
40−
41−## 3.0.4.0
42−
43−* A new module Network.Wai.HTTP2 is exported.
44−
45−## 3.0.3.0
46−
47−* mapResponseHeaders, ifRequest and modifyResponse are exported.
48−
49## 3.0.2.3
1## 3.0.2.3
50
2
51−* Allow blaze-builder 0.4
3+Allow blaze-builder 0.4
52
4
53## 3.0.2.2
5## 3.0.2.2
54
6
wai/Network/Wai.hs+37−75
@@ -1,14 +1,15 @@
1+{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE CPP #-}
1{-|
3{-|
2
4
3This module defines a generic web application interface. It is a common
5This module defines a generic web application interface. It is a common
4protocol between web servers and web applications.
6protocol between web servers and web applications.
5
7
6The overriding design principles here are performance and generality. To
8The overriding design principles here are performance and generality. To
7−address performance, this library uses a streaming interface for request and
9+address performance, this library is built on top of the conduit and
8−response bodies, paired with bytestring's 'Builder' type. The advantages of a
10+blaze-builder packages. The advantages of conduits over lazy IO have been
9−streaming API over lazy IO have been debated elsewhere and so will not be
10−addressed here. However, helper functions like 'responseLBS' allow you to
11+debated elsewhere and so will not be addressed here. However, helper functions
11−continue using lazy IO if you so desire.
12+like 'responseLBS' allow you to continue using lazy IO if you so desire.
12
13
13Generality is achieved by removing many variables commonly found in similar
14Generality is achieved by removing many variables commonly found in similar
14projects that are not universal to all servers. The goal is that the 'Request'
15projects that are not universal to all servers. The goal is that the 'Request'
@@ -30,9 +31,9 @@ include:
30
31
31[wai-extra] <http://hackage.haskell.org/package/wai-extra>
32[wai-extra] <http://hackage.haskell.org/package/wai-extra>
32
33
34+[wai-test] <http://hackage.haskell.org/package/wai-test>
35+
33-}
36-}
34−-- Ignore deprecations, because this module needs to use the deprecated requestBody to construct a response.
35−{-# OPTIONS_GHC -fno-warn-deprecations #-}
36module Network.Wai
37module Network.Wai
37 (
38 (
38 -- * Types
39 -- * Types
@@ -53,14 +54,11 @@ module Network.Wai
53 , remoteHost
54 , remoteHost
54 , pathInfo
55 , pathInfo
55 , queryString
56 , queryString
56− , getRequestBodyChunk
57 , requestBody
57 , requestBody
58 , vault
58 , vault
59 , requestBodyLength
59 , requestBodyLength
60 , requestHeaderHost
60 , requestHeaderHost
61 , requestHeaderRange
61 , requestHeaderRange
62− , requestHeaderReferer
63− , requestHeaderUserAgent
64 , strictRequestBody
62 , strictRequestBody
65 , lazyRequestBody
63 , lazyRequestBody
66 -- * Response
64 -- * Response
@@ -73,20 +71,14 @@ module Network.Wai
73 , responseLBS
71 , responseLBS
74 , responseStream
72 , responseStream
75 , responseRaw
73 , responseRaw
76− -- ** Response accessors
74+ -- * Response accessors
77 , responseStatus
75 , responseStatus
78 , responseHeaders
76 , responseHeaders
79− -- ** Response modifiers
80 , responseToStream
77 , responseToStream
81− , mapResponseHeaders
82− , mapResponseStatus
83− -- * Middleware composition
84− , ifRequest
85− , modifyResponse
86 ) where
78 ) where
87
79
88−import Data.ByteString.Builder (Builder, lazyByteString)
80+import Blaze.ByteString.Builder (Builder, fromLazyByteString)
89−import Data.ByteString.Builder (byteString)
81+import Blaze.ByteString.Builder (fromByteString)
90import Control.Monad (unless)
82import Control.Monad (unless)
91import qualified Data.ByteString as B
83import qualified Data.ByteString as B
92import qualified Data.ByteString.Lazy as L
84import qualified Data.ByteString.Lazy as L
@@ -94,6 +86,7 @@ import qualified Data.ByteString.Lazy.Internal as LI
94import Data.ByteString.Lazy.Internal (defaultChunkSize)
86import Data.ByteString.Lazy.Internal (defaultChunkSize)
95import Data.ByteString.Lazy.Char8 ()
87import Data.ByteString.Lazy.Char8 ()
96import Data.Function (fix)
88import Data.Function (fix)
89+import Data.Monoid (mempty)
97import qualified Network.HTTP.Types as H
90import qualified Network.HTTP.Types as H
98import Network.Socket (SockAddr (SockAddrInet))
91import Network.Socket (SockAddr (SockAddrInet))
99import Network.Wai.Internal
92import Network.Wai.Internal
@@ -121,13 +114,13 @@ responseFile = ResponseFile
121--
114--
122-- A2. No. If the ByteStrings are small, then they will be copied into a larger
115-- 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
116-- buffer, which should be a performance gain overall (less system calls). If
124−-- they are already large, then an insert operation is used
117+-- they are already large, then blaze-builder uses an InsertByteString
125−-- to avoid copying.
118+-- instruction to avoid copying.
126--
119--
127-- Q3. Doesn't this prevent us from creating comet-style servers, since data
120-- Q3. Doesn't this prevent us from creating comet-style servers, since data
128-- will be cached?
121-- will be cached?
129--
122--
130−-- A3. You can force a Builder to output a ByteString before it is an
123+-- A3. You can force blaze-builder to output a ByteString before it is an
131-- optimal size by sending a flush command.
124-- optimal size by sending a flush command.
132responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response
125responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response
133responseBuilder = ResponseBuilder
126responseBuilder = ResponseBuilder
@@ -135,7 +128,7 @@ responseBuilder = ResponseBuilder
135-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for
128-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for
136-- 'responseBuilder'.
129-- 'responseBuilder'.
137responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response
130responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response
138−responseLBS s h = ResponseBuilder s h . lazyByteString
131+responseLBS s h = ResponseBuilder s h . fromLazyByteString
139
132
140-- | Creating 'Response' from a stream of values.
133-- | Creating 'Response' from a stream of values.
141--
134--
@@ -149,9 +142,9 @@ responseLBS s h = ResponseBuilder s h . lazyByteString
149-- (putStrLn \"Allocating scarce resource\")
142-- (putStrLn \"Allocating scarce resource\")
150-- (putStrLn \"Cleaning up\")
143-- (putStrLn \"Cleaning up\")
151-- $ respond $ responseStream status200 [] $ \\write flush -> do
144-- $ respond $ responseStream status200 [] $ \\write flush -> do
152−-- write $ byteString \"Hello\\n\"
145+-- write $ fromByteString \"Hello\\n\"
153-- flush
146-- flush
154−-- write $ byteString \"World\\n\"
147+-- write $ fromByteString \"World\\n\"
155-- @
148-- @
156--
149--
157-- Note that in some cases you can use @bracket@ from inside @responseStream@
150-- Note that in some cases you can use @bracket@ from inside @responseStream@
@@ -214,7 +207,7 @@ responseToStream (ResponseFile s h fp (Just part)) =
214 bs <- B.hGetSome handle defaultChunkSize
207 bs <- B.hGetSome handle defaultChunkSize
215 unless (B.null bs) $ do
208 unless (B.null bs) $ do
216 let x = B.take remaining bs
209 let x = B.take remaining bs
217− sendChunk $ byteString x
210+ sendChunk $ fromByteString x
218 loop $ remaining - B.length x
211 loop $ remaining - B.length x
219 loop $ fromIntegral $ filePartByteCount part
212 loop $ fromIntegral $ filePartByteCount part
220 )
213 )
@@ -225,27 +218,13 @@ responseToStream (ResponseFile s h fp Nothing) =
225 withBody $ \sendChunk _flush -> fix $ \loop -> do
218 withBody $ \sendChunk _flush -> fix $ \loop -> do
226 bs <- B.hGetSome handle defaultChunkSize
219 bs <- B.hGetSome handle defaultChunkSize
227 unless (B.null bs) $ do
220 unless (B.null bs) $ do
228− sendChunk $ byteString bs
221+ sendChunk $ fromByteString bs
229 loop
222 loop
230 )
223 )
231responseToStream (ResponseBuilder s h b) =
224responseToStream (ResponseBuilder s h b) =
232 (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b)
225 (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b)
233responseToStream (ResponseRaw _ res) = responseToStream res
226responseToStream (ResponseRaw _ res) = responseToStream res
234
227
235−-- | Apply the provided function to the response header list of the Response.
236−mapResponseHeaders :: (H.ResponseHeaders -> H.ResponseHeaders) -> Response -> Response
237−mapResponseHeaders f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2
238−mapResponseHeaders f (ResponseBuilder s h b) = ResponseBuilder s (f h) b
239−mapResponseHeaders f (ResponseStream s h b) = ResponseStream s (f h) b
240−mapResponseHeaders _ r@(ResponseRaw _ _) = r
241−
242−-- | Apply the provided function to the response status of the Response.
243−mapResponseStatus :: (H.Status -> H.Status) -> Response -> Response
244−mapResponseStatus f (ResponseFile s h b1 b2) = ResponseFile (f s) h b1 b2
245−mapResponseStatus f (ResponseBuilder s h b) = ResponseBuilder (f s) h b
246−mapResponseStatus f (ResponseStream s h b) = ResponseStream (f s) h b
247−mapResponseStatus _ r@(ResponseRaw _ _) = r
248−
249----------------------------------------------------------------
228----------------------------------------------------------------
250
229
251-- | The WAI application.
230-- | The WAI application.
@@ -263,6 +242,21 @@ mapResponseStatus _ r@(ResponseRaw _ _) = r
263-- @
242-- @
264type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
243type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
265
244
245+-- | Middleware is a component that sits between the server and application. It
246+-- can do such tasks as GZIP encoding or response caching. What follows is the
247+-- general definition of middleware, though a middleware author should feel
248+-- free to modify this.
249+--
250+-- As an example of an alternate type for middleware, suppose you write a
251+-- function to load up session information. The session information is simply a
252+-- string map \[(String, String)\]. A logical type signature for this middleware
253+-- might be:
254+--
255+-- @ loadSession :: ([(String, String)] -> Application) -> Application @
256+--
257+-- Here, instead of taking a standard 'Application' as its first argument, the
258+-- middleware takes a function which consumes the session information as well.
259+type Middleware = Application -> Application
266
260
267-- | A default, blank request.
261-- | A default, blank request.
268--
262--
@@ -283,40 +277,8 @@ defaultRequest = Request
283 , requestBodyLength = KnownLength 0
277 , requestBodyLength = KnownLength 0
284 , requestHeaderHost = Nothing
278 , requestHeaderHost = Nothing
285 , requestHeaderRange = Nothing
279 , requestHeaderRange = Nothing
286− , requestHeaderReferer = Nothing
287− , requestHeaderUserAgent = Nothing
288 }
280 }
289
281
290−
291−-- | Middleware is a component that sits between the server and application. It
292−-- can do such tasks as GZIP encoding or response caching. What follows is the
293−-- general definition of middleware, though a middleware author should feel
294−-- free to modify this.
295−--
296−-- As an example of an alternate type for middleware, suppose you write a
297−-- function to load up session information. The session information is simply a
298−-- string map \[(String, String)\]. A logical type signature for this middleware
299−-- might be:
300−--
301−-- @ loadSession :: ([(String, String)] -> Application) -> Application @
302−--
303−-- Here, instead of taking a standard 'Application' as its first argument, the
304−-- middleware takes a function which consumes the session information as well.
305−type Middleware = Application -> Application
306−
307−
308−-- | apply a function that modifies a response as a 'Middleware'
309−modifyResponse :: (Response -> Response) -> Middleware
310−modifyResponse f app req respond = app req $ respond . f
311−
312−
313−-- | conditionally apply a 'Middleware'
314−ifRequest :: (Request -> Bool) -> Middleware -> Middleware
315−ifRequest rpred middle app req | rpred req = middle app req
316− | otherwise = app req
317−
318−
319−
320-- | Get the request body as a lazy ByteString. However, do /not/ use any lazy
282-- | Get the request body as a lazy ByteString. However, do /not/ use any lazy
321-- I\/O, instead reading the entire body into memory strictly.
283-- I\/O, instead reading the entire body into memory strictly.
322--
284--
@@ -326,7 +288,7 @@ strictRequestBody req =
326 loop id
288 loop id
327 where
289 where
328 loop front = do
290 loop front = do
329− bs <- getRequestBodyChunk req
291+ bs <- requestBody req
330 if B.null bs
292 if B.null bs
331 then return $ front LI.Empty
293 then return $ front LI.Empty
332 else loop (front . LI.Chunk bs)
294 else loop (front . LI.Chunk bs)
@@ -340,7 +302,7 @@ lazyRequestBody req =
340 loop
302 loop
341 where
303 where
342 loop = unsafeInterleaveIO $ do
304 loop = unsafeInterleaveIO $ do
343− bs <- getRequestBodyChunk req
305+ bs <- requestBody req
344 if B.null bs
306 if B.null bs
345 then return LI.Empty
307 then return LI.Empty
346 else do
308 else do
wai/Network/Wai/Internal.hs+6−20
@@ -1,15 +1,17 @@
1{-# OPTIONS_HADDOCK not-home #-}
1{-# OPTIONS_HADDOCK not-home #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE CPP #-}
4+{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE RecordWildCards #-}
4-- | Internal constructors and helper functions. Note that no guarantees are
6-- | Internal constructors and helper functions. Note that no guarantees are
5-- given for stability of these interfaces.
7-- given for stability of these interfaces.
6module Network.Wai.Internal where
8module Network.Wai.Internal where
7
9
8−import Data.ByteString.Builder (Builder)
10+import Blaze.ByteString.Builder (Builder)
9−import qualified Data.ByteString as B hiding (pack)
11+import qualified Data.ByteString as B
10import Data.Text (Text)
12import Data.Text (Text)
11import Data.Typeable (Typeable)
13import Data.Typeable (Typeable)
12−import Data.Vault.Lazy (Vault)
14+import Data.Vault.Lazy (Vault)
13import Data.Word (Word64)
15import Data.Word (Word64)
14import qualified Network.HTTP.Types as H
16import qualified Network.HTTP.Types as H
15import Network.Socket (SockAddr)
17import Network.Socket (SockAddr)
@@ -17,7 +19,6 @@ import Data.List (intercalate)
17
19
18-- | Information on the request sent by the client. This abstracts away the
20-- | Information on the request sent by the client. This abstracts away the
19-- details of the underlying implementation.
21-- 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 {
22data Request = Request {
22 -- | Request method such as GET.
23 -- | Request method such as GET.
23 requestMethod :: H.Method
24 requestMethod :: H.Method
@@ -63,7 +64,7 @@ data Request = Request {
63 -- | Parsed query string information.
64 -- | Parsed query string information.
64 , queryString :: H.Query
65 , queryString :: H.Query
65 -- | Get the next chunk of the body. Returns 'B.empty' when the
66 -- | 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'.
67+ -- body is fully consumed.
67 , requestBody :: IO B.ByteString
68 , requestBody :: IO B.ByteString
68 -- | A location for arbitrary data to be shared by applications and middleware.
69 -- | A location for arbitrary data to be shared by applications and middleware.
69 , vault :: Vault
70 , vault :: Vault
@@ -80,24 +81,9 @@ data Request = Request {
80 --
81 --
81 -- Since 2.0.0
82 -- Since 2.0.0
82 , requestHeaderRange :: Maybe B.ByteString
83 , requestHeaderRange :: Maybe B.ByteString
83− -- | The value of the Referer header in a HTTP request.
84− --
85− -- Since 3.2.0
86− , requestHeaderReferer :: Maybe B.ByteString
87− -- | The value of the User-Agent header in a HTTP request.
88− --
89− -- Since 3.2.0
90− , requestHeaderUserAgent :: Maybe B.ByteString
91 }
84 }
92 deriving (Typeable)
85 deriving (Typeable)
93
86
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
87instance Show Request where
102 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"
88 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"
103 where
89 where
wai/README.md+1−1
@@ -67,7 +67,7 @@ Basic dispatching
67An `Application` maps `Request`s to `Response`s:
67An `Application` maps `Request`s to `Response`s:
68
68
69 ghci> :info Application
69 ghci> :info Application
70− type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
70+ type Application = Request -> IO Response
71
71
72Depending on the path info provided with each `Request` we can serve different `Response`s:
72Depending on the path info provided with each `Request` we can serve different `Response`s:
73
73
wai/test/Network/WaiSpec.hs+9−7
@@ -3,10 +3,12 @@ module Network.WaiSpec (spec) where
3import Test.Hspec
3import Test.Hspec
4import Test.Hspec.QuickCheck (prop)
4import Test.Hspec.QuickCheck (prop)
5import Network.Wai
5import Network.Wai
6+import Network.Wai.Internal (Request (Request))
6import Data.IORef
7import Data.IORef
8+import Data.Monoid
7import qualified Data.ByteString as S
9import qualified Data.ByteString as S
8import qualified Data.ByteString.Lazy as L
10import qualified Data.ByteString.Lazy as L
9−import Data.ByteString.Builder (Builder, toLazyByteString, word8)
11+import Blaze.ByteString.Builder (toByteString, Builder, fromWord8)
10import Control.Monad (forM_)
12import Control.Monad (forM_)
11
13
12spec :: Spec
14spec :: Spec
@@ -22,17 +24,17 @@ spec = do
22 flush :: IO ()
24 flush :: IO ()
23 flush = return ()
25 flush = return ()
24 streamingBody add flush
26 streamingBody add flush
25− fmap (L.toStrict . toLazyByteString) $ readIORef builderRef
27+ fmap toByteString $ readIORef builderRef
26 prop "responseLBS" $ \bytes -> do
28 prop "responseLBS" $ \bytes -> do
27 body <- getBody $ responseLBS undefined undefined $ L.pack bytes
29 body <- getBody $ responseLBS undefined undefined $ L.pack bytes
28 body `shouldBe` S.pack bytes
30 body `shouldBe` S.pack bytes
29 prop "responseBuilder" $ \bytes -> do
31 prop "responseBuilder" $ \bytes -> do
30 body <- getBody $ responseBuilder undefined undefined
32 body <- getBody $ responseBuilder undefined undefined
31− $ mconcat $ map word8 bytes
33+ $ mconcat $ map fromWord8 bytes
32 body `shouldBe` S.pack bytes
34 body `shouldBe` S.pack bytes
33 prop "responseStream" $ \chunks -> do
35 prop "responseStream" $ \chunks -> do
34 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->
36 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->
35− forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk
37+ forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk
36 body `shouldBe` S.concat (map S.pack chunks)
38 body `shouldBe` S.concat (map S.pack chunks)
37 it "responseFile total" $ do
39 it "responseFile total" $ do
38 let fp = "wai.cabal"
40 let fp = "wai.cabal"
@@ -55,7 +57,7 @@ spec = do
55 describe "lazyRequestBody" $ do
57 describe "lazyRequestBody" $ do
56 prop "works" $ \chunks -> do
58 prop "works" $ \chunks -> do
57 ref <- newIORef $ map S.pack $ filter (not . null) chunks
59 ref <- newIORef $ map S.pack $ filter (not . null) chunks
58− let req = defaultRequest
60+ let req = Request
59 { requestBody = atomicModifyIORef ref $ \bss ->
61 { requestBody = atomicModifyIORef ref $ \bss ->
60 case bss of
62 case bss of
61 [] -> ([], S.empty)
63 [] -> ([], S.empty)
@@ -64,7 +66,7 @@ spec = do
64 body <- lazyRequestBody req
66 body <- lazyRequestBody req
65 body `shouldBe` L.fromChunks (map S.pack chunks)
67 body `shouldBe` L.fromChunks (map S.pack chunks)
66 it "is lazy" $ do
68 it "is lazy" $ do
67− let req = defaultRequest
69+ let req = Request
68 { requestBody = error "requestBody"
70 { requestBody = error "requestBody"
69 }
71 }
70 _ <- lazyRequestBody req
72 _ <- lazyRequestBody req
@@ -72,7 +74,7 @@ spec = do
72 describe "strictRequestBody" $ do
74 describe "strictRequestBody" $ do
73 prop "works" $ \chunks -> do
75 prop "works" $ \chunks -> do
74 ref <- newIORef $ map S.pack $ filter (not . null) chunks
76 ref <- newIORef $ map S.pack $ filter (not . null) chunks
75− let req = defaultRequest
77+ let req = Request
76 { requestBody = atomicModifyIORef ref $ \bss ->
78 { requestBody = atomicModifyIORef ref $ \bss ->
77 case bss of
79 case bss of
78 [] -> ([], S.empty)
80 [] -> ([], S.empty)
wai/wai.cabal+8−8
@@ -1,9 +1,8 @@
1Name: wai
1Name: wai
2−Version: 3.2.2.1
2+Version: 3.0.2.3
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
@@ -20,8 +19,9 @@ Source-repository head
20 location: git://github.com/yesodweb/wai.git
19 location: git://github.com/yesodweb/wai.git
21
20
22Library
21Library
23− Build-Depends: base >= 4.8 && < 5
22+ Build-Depends: base >= 4 && < 5
24− , bytestring >= 0.10.4
23+ , bytestring >= 0.9.1.4
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
@@ -34,14 +34,14 @@ test-suite test
34 hs-source-dirs: test
34 hs-source-dirs: test
35 main-is: Spec.hs
35 main-is: Spec.hs
36 type: exitcode-stdio-1.0
36 type: exitcode-stdio-1.0
37− ghc-options: -threaded -Wall
37+ ghc-options: -threaded
38 cpp-options: -DTEST
38 cpp-options: -DTEST
39− build-depends: base >= 4.8 && < 5
39+ build-depends: base
40 , wai
40 , wai
41 , hspec
41 , hspec
42+ , blaze-builder
42 , bytestring
43 , bytestring
43 other-modules: Network.WaiSpec
44 other-modules: Network.WaiSpec
44− build-tool-depends: hspec-discover:hspec-discover
45
45
46source-repository head
46source-repository head
47 type: git
47 type: git
wai/webkit-sample/webkit-sample.hs+2−2
@@ -5,7 +5,7 @@ import Network.Wai.Handler.Webkit
5import Data.ByteString (ByteString)
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−86
@@ -1,89 +1,3 @@
1−## 3.2.11
2−
3−* Ignoring an exception from shutdown (gracefulClose).
4−
5−## 3.2.10
6−
7−* Passing client certificate, if any, to Warp
8− [#783](https://github.com/yesodweb/wai/pull/783)
9−
10−## 3.2.9
11−
12−* Cooperating setGracefulCloseTimeout1 and setGracefulCloseTimeout2 of Warp.
13− [#782](https://github.com/yesodweb/wai/pull/782)
14−
15−## 3.2.8
16−
17−* Using gracefullClose of network 3.1.1 or later if available.
18−
19−## 3.2.7
20−
21−* Relaxing version constraint.
22−
23−## 3.2.6
24−
25−* Using the Strict and StrictData language extensions for GHC >8.
26− [#752](https://github.com/yesodweb/wai/pull/752)
27−
28−## 3.2.5
29−
30−* When tls 1.5.0 is available, TLS 1.3 is automatically supported.
31−
32−## 3.2.4.3
33−
34−* Using warp >= 3.2.17.
35−
36−## 3.2.4.2
37−
38−* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640)
39−
40−## 3.2.4
41−
42−* Using tls-session-manager.
43−
44−## 3.2.3
45−
46−* Stop using obsoleted APIs of network.
47−
48−## 3.2.2
49−
50−* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)
51−* Preventing socket leakage [#559](https://github.com/yesodweb/wai/pull/559)
52−
53−## 3.2.1
54−
55−* Removing dependency to cprng-aes.
56−
57−## 3.2.0
58−
59−* Major version up due to breaking changes.
60−* runHTTP2TLS and runHTTP2TLSSocket were removed.
61−
62−## 3.1.4
63−
64−* Add an option to disable HTTP2 [#450](https://github.com/yesodweb/wai/pull/450)
65−
66−## 3.1.3
67−
68−* Removing SHA 512 and SHA 384 from supportedCiphers to rescue Safari and golang. [#429](https://github.com/yesodweb/wai/issues/429)
69−
70−## 3.1.2
71−
72−* [Getting Rating A from the SSL Server Test](http://www.yesodweb.com/blog/2015/08/ssl-server-test)
73−
74−## 3.1.1
75−
76−* Converting "send: resource vanished (Broken pipe)" to ConnectionClosedByPeer. [#421](https://github.com/yesodweb/wai/issues/421)
77−
78−## 3.1.0
79−
80−* Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399)
81−* Removing RC4 [#400](https://github.com/yesodweb/wai/issues/400)
82−
83−## 3.0.4.2
84−
85−* tls 1.3 support [#390](https://github.com/yesodweb/wai/issues/390)
86−
87## 3.0.4.1
1## 3.0.4.1
88
2
89* Fix for leaked FDs [#378](https://github.com/yesodweb/wai/issues/378)
3* Fix for leaked FDs [#378](https://github.com/yesodweb/wai/issues/378)
warp-tls/Network/Wai/Handler/WarpTLS.hs+116−258
@@ -1,74 +1,59 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
6{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE PatternGuards #-}
6+{-# LANGUAGE CPP #-}
7
7
8−-- | HTTP over TLS support for Warp via the TLS package.
8+-- | HTTP over SSL/TLS support for Warp via the TLS package.
9−--
10−-- If HTTP\/2 is negotiated by ALPN, HTTP\/2 over TLS is used.
11−-- Otherwise HTTP\/1.1 over TLS is used.
12−--
13−-- Support for SSL is now obsoleted.
14
9
15module Network.Wai.Handler.WarpTLS (
10module Network.Wai.Handler.WarpTLS (
16 -- * Settings
11 -- * Settings
17 TLSSettings
12 TLSSettings
18− , defaultTlsSettings
19− -- * Smart constructors
20− , tlsSettings
21− , tlsSettingsMemory
22− , tlsSettingsChain
23− , tlsSettingsChainMemory
24− -- * Accessors
25 , certFile
13 , certFile
26 , keyFile
14 , keyFile
15+ , onInsecure
27 , tlsLogging
16 , tlsLogging
28 , tlsAllowedVersions
17 , tlsAllowedVersions
29 , tlsCiphers
18 , tlsCiphers
30 , tlsWantClientCert
19 , tlsWantClientCert
31 , tlsServerHooks
20 , tlsServerHooks
32− , tlsServerDHEParams
21+ , defaultTlsSettings
33− , tlsSessionManagerConfig
22+ , tlsSettings
34− , onInsecure
23+ , tlsSettingsMemory
24+ , tlsSettingsChain
25+ , tlsSettingsChainMemory
35 , OnInsecure (..)
26 , OnInsecure (..)
36 -- * Runner
27 -- * Runner
37 , runTLS
28 , runTLS
38 , runTLSSocket
29 , runTLSSocket
39 -- * Exception
30 -- * Exception
40 , WarpTLSException (..)
31 , WarpTLSException (..)
41− , DH.Params
42− , DH.generateParams
43 ) where
32 ) where
44
33
34+#if __GLASGOW_HASKELL__ < 709
45−import Control.Applicative ((<|>))
35+import Control.Applicative ((<$>))
36+#endif
46−import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)
37+import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException)
47−import qualified Control.Exception as E
48−import Control.Monad (void, guard)
38+import Control.Monad (void)
39+import qualified Crypto.Random.AESCtr
40+import qualified Data.ByteString as B
49import qualified Data.ByteString as S
41import qualified Data.ByteString as S
50import qualified Data.ByteString.Lazy as L
42import qualified Data.ByteString.Lazy as L
51import Data.Default.Class (def)
43import Data.Default.Class (def)
52import qualified Data.IORef as I
44import qualified Data.IORef as I
53import Data.Streaming.Network (bindPortTCP, safeRecv)
45import Data.Streaming.Network (bindPortTCP, safeRecv)
54import Data.Typeable (Typeable)
46import Data.Typeable (Typeable)
55−import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)
47+import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept)
56−#if MIN_VERSION_network(3,1,1)
57−import Network.Socket (gracefulClose)
58−#endif
59import Network.Socket.ByteString (sendAll)
48import Network.Socket.ByteString (sendAll)
60import qualified Network.TLS as TLS
49import qualified Network.TLS as TLS
61−import qualified Crypto.PubKey.DH as DH
62import qualified Network.TLS.Extra as TLSExtra
50import qualified Network.TLS.Extra as TLSExtra
63−import qualified Network.TLS.SessionManager as SM
64import Network.Wai (Application)
51import Network.Wai (Application)
65import Network.Wai.Handler.Warp
52import Network.Wai.Handler.Warp
66−import Network.Wai.Handler.Warp.Internal
67import System.IO.Error (isEOFError)
53import System.IO.Error (isEOFError)
68
54
69----------------------------------------------------------------
55----------------------------------------------------------------
70
56
71−-- | Settings for WarpTLS.
72data TLSSettings = TLSSettings {
57data TLSSettings = TLSSettings {
73 certFile :: FilePath
58 certFile :: FilePath
74 -- ^ File containing the certificate.
59 -- ^ File containing the certificate.
@@ -80,10 +65,8 @@ data TLSSettings = TLSSettings {
80 , chainCertsMemory :: [S.ByteString]
65 , chainCertsMemory :: [S.ByteString]
81 , keyMemory :: Maybe S.ByteString
66 , keyMemory :: Maybe S.ByteString
82 , onInsecure :: OnInsecure
67 , onInsecure :: OnInsecure
83− -- ^ Do we allow insecure connections with this server as well?
68+ -- ^ Do we allow insecure connections with this server as well? Default
84− --
69+ -- is a simple text response stating that a secure connection is required.
85− -- >>> onInsecure defaultTlsSettings
86− -- DenyInsecure "This server only accepts secure HTTPS connections."
87 --
70 --
88 -- Since 1.4.0
71 -- Since 1.4.0
89 , tlsLogging :: TLS.Logging
72 , tlsLogging :: TLS.Logging
@@ -93,44 +76,23 @@ data TLSSettings = TLSSettings {
93 --
76 --
94 -- Since 1.4.0
77 -- Since 1.4.0
95 , tlsAllowedVersions :: [TLS.Version]
78 , 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.
79 -- ^ The TLS versions this server accepts.
105 --
80 --
106− -- >>> tlsAllowedVersions defaultTlsSettings
81+ -- Default: '[TLS.TLS10,TLS.TLS11,TLS.TLS12]'.
107− -- [TLS12,TLS11,TLS10]
108 --
82 --
109 -- Since 1.4.2
83 -- Since 1.4.2
110−#endif
111 , tlsCiphers :: [TLS.Cipher]
84 , 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.
85 -- ^ The TLS ciphers this server accepts.
121 --
86 --
122− -- >>> tlsCiphers defaultTlsSettings
87+ -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSEtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'
123− -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1]
124 --
88 --
125 -- Since 1.4.2
89 -- Since 1.4.2
126−#endif
127 , tlsWantClientCert :: Bool
90 , tlsWantClientCert :: Bool
128 -- ^ Whether or not to demand a certificate from the client. If this
91 -- ^ 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
92 -- is set to True, you must handle received certificates in a server hook
130 -- or all connections will fail.
93 -- or all connections will fail.
131 --
94 --
132− -- >>> tlsWantClientCert defaultTlsSettings
133− -- False
95+ -- Default: False
134 --
96 --
135 -- Since 3.0.2
97 -- Since 3.0.2
136 , tlsServerHooks :: TLS.ServerHooks
98 , tlsServerHooks :: TLS.ServerHooks
@@ -141,25 +103,9 @@ data TLSSettings = TLSSettings {
141 -- Default: def
103 -- Default: def
142 --
104 --
143 -- Since 3.0.2
105 -- Since 3.0.2
144− , tlsServerDHEParams :: Maybe DH.Params
145− -- ^ Configuration for ServerDHEParams
146− -- more function lives in `cryptonite` package
147− --
148− -- Default: Nothing
149− --
150− -- Since 3.2.2
151− , tlsSessionManagerConfig :: Maybe SM.Config
152− -- ^ Configuration for in-memory TLS session manager.
153− -- If Nothing, 'TLS.noSessionManager' is used.
154− -- Otherwise, an in-memory TLS session manager is created
155− -- according to 'Config'.
156− --
157− -- Default: Nothing
158− --
159− -- Since 3.2.4
160 }
106 }
161
107
162−-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors).
108+-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name.
163defaultTlsSettings :: TLSSettings
109defaultTlsSettings :: TLSSettings
164defaultTlsSettings = TLSSettings {
110defaultTlsSettings = TLSSettings {
165 certFile = "certificate.pem"
111 certFile = "certificate.pem"
@@ -170,32 +116,39 @@ defaultTlsSettings = TLSSettings {
170 , keyMemory = Nothing
116 , keyMemory = Nothing
171 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
117 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
172 , tlsLogging = def
118 , tlsLogging = def
173−#if MIN_VERSION_tls(1,5,0)
174− , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]
119+ , tlsAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12]
175−#else
176− , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]
177−#endif
178 , tlsCiphers = ciphers
120 , tlsCiphers = ciphers
179 , tlsWantClientCert = False
121 , tlsWantClientCert = False
180 , tlsServerHooks = def
122 , tlsServerHooks = def
181− , tlsServerDHEParams = Nothing
182− , tlsSessionManagerConfig = Nothing
183 }
123 }
184
124
185-- taken from stunnel example in tls-extra
125-- taken from stunnel example in tls-extra
186ciphers :: [TLS.Cipher]
126ciphers :: [TLS.Cipher]
187−ciphers = TLSExtra.ciphersuite_strong
127+ciphers =
128+ [ TLSExtra.cipher_ECDHE_RSA_AES128GCM_SHA256
129+ , TLSExtra.cipher_DHE_RSA_AES128GCM_SHA256
130+ , TLSExtra.cipher_DHE_RSA_AES256_SHA256
131+ , TLSExtra.cipher_DHE_RSA_AES128_SHA256
132+ , TLSExtra.cipher_DHE_RSA_AES256_SHA1
133+ , TLSExtra.cipher_DHE_RSA_AES128_SHA1
134+ , TLSExtra.cipher_DHE_DSS_AES128_SHA1
135+ , TLSExtra.cipher_DHE_DSS_AES256_SHA1
136+ , TLSExtra.cipher_DHE_DSS_RC4_SHA1
137+ , TLSExtra.cipher_AES128_SHA1
138+ , TLSExtra.cipher_AES256_SHA1
139+ , TLSExtra.cipher_RC4_128_MD5
140+ , TLSExtra.cipher_RC4_128_SHA1
141+ ]
188
142
189----------------------------------------------------------------
143----------------------------------------------------------------
190
144
191-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.
145-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.
192data OnInsecure = DenyInsecure L.ByteString
146data OnInsecure = DenyInsecure L.ByteString
193 | AllowInsecure
147 | AllowInsecure
194− deriving (Show)
195
148
196----------------------------------------------------------------
149----------------------------------------------------------------
197
150
198−-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.
151+-- | A smart constructor for 'TLSSettings'.
199tlsSettings :: FilePath -- ^ Certificate file
152tlsSettings :: FilePath -- ^ Certificate file
200 -> FilePath -- ^ Key file
153 -> FilePath -- ^ Key file
201 -> TLSSettings
154 -> TLSSettings
@@ -205,7 +158,7 @@ tlsSettings cert key = defaultTlsSettings {
205 }
158 }
206
159
207-- | A smart constructor for 'TLSSettings' that allows specifying
160-- | A smart constructor for 'TLSSettings' that allows specifying
208−-- chain certificates based on 'defaultTlsSettings'.
161+-- chain certificates.
209--
162--
210-- Since 3.0.3
163-- Since 3.0.3
211tlsSettingsChain
164tlsSettingsChain
@@ -220,7 +173,7 @@ tlsSettingsChain cert chainCerts key = defaultTlsSettings {
220 }
173 }
221
174
222-- | A smart constructor for 'TLSSettings', but uses in-memory representations
175-- | A smart constructor for 'TLSSettings', but uses in-memory representations
223−-- of the certificate and key based on 'defaultTlsSettings'.
176+-- of the certificate and key
224--
177--
225-- Since 3.0.1
178-- Since 3.0.1
226tlsSettingsMemory
179tlsSettingsMemory
@@ -233,7 +186,7 @@ tlsSettingsMemory cert key = defaultTlsSettings
233 }
186 }
234
187
235-- | A smart constructor for 'TLSSettings', but uses in-memory representations
188-- | A smart constructor for 'TLSSettings', but uses in-memory representations
236−-- of the certificate and key based on 'defaultTlsSettings'.
189+-- of the certificate and key
237--
190--
238-- Since 3.0.3
191-- Since 3.0.3
239tlsSettingsChainMemory
192tlsSettingsChainMemory
@@ -249,12 +202,13 @@ tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings
249
202
250----------------------------------------------------------------
203----------------------------------------------------------------
251
204
205+
252-- | Running 'Application' with 'TLSSettings' and 'Settings'.
206-- | Running 'Application' with 'TLSSettings' and 'Settings'.
253runTLS :: TLSSettings -> Settings -> Application -> IO ()
207runTLS :: TLSSettings -> Settings -> Application -> IO ()
254runTLS tset set app = withSocketsDo $
208runTLS tset set app = withSocketsDo $
255 bracket
209 bracket
256 (bindPortTCP (getPort set) (getHost set))
210 (bindPortTCP (getPort set) (getHost set))
257− close
211+ sClose
258 (\sock -> runTLSSocket tset set sock app)
212 (\sock -> runTLSSocket tset set sock app)
259
213
260----------------------------------------------------------------
214----------------------------------------------------------------
@@ -272,186 +226,89 @@ runTLSSocket tlsset@TLSSettings{..} set sock app = do
272 key <- maybe (S.readFile keyFile) return mkey
226 key <- maybe (S.readFile keyFile) return mkey
273 either error return $
227 either error return $
274 TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key
228 TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key
275− mgr <- case tlsSessionManagerConfig of
276− Nothing -> return TLS.noSessionManager
277− Just config -> SM.newSessionManager config
278− runTLSSocket' tlsset set credential mgr sock app
229+ runTLSSocket' tlsset set credential sock app
279
230
280−runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager -> Socket -> Application -> IO ()
231+runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO ()
281−runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =
232+runTLSSocket' tlsset@TLSSettings{..} set credential sock app =
282 runSettingsConnectionMakerSecure set get app
233 runSettingsConnectionMakerSecure set get app
283 where
234 where
284− get = getter tlsset set sock params
235+ get = getter tlsset sock params
285− params = def { -- TLS.ServerParams
236+ params = def {
286 TLS.serverWantClientCert = tlsWantClientCert
237 TLS.serverWantClientCert = tlsWantClientCert
287− , TLS.serverCACertificates = []
238+ , TLS.serverSupported = def {
288− , TLS.serverDHEParams = tlsServerDHEParams
239+ TLS.supportedVersions = tlsAllowedVersions
240+ , TLS.supportedCiphers = tlsCiphers
241+ }
242+ , TLS.serverShared = def {
243+ TLS.sharedCredentials = TLS.Credentials [credential]
244+ }
289− , TLS.serverHooks = hooks
245+ , TLS.serverHooks = tlsServerHooks
290− , TLS.serverShared = shared
291− , TLS.serverSupported = supported
292−#if MIN_VERSION_tls(1,5,0)
293− , TLS.serverEarlyDataSize = 2018
294−#endif
295− }
296− -- Adding alpn to user's tlsServerHooks.
297− hooks = tlsServerHooks {
298− TLS.onALPNClientSuggest = TLS.onALPNClientSuggest tlsServerHooks <|>
299− (if settingsHTTP2Enabled set then Just alpn else Nothing)
300 }
246 }
301− shared = def {
302− TLS.sharedCredentials = TLS.Credentials [credential]
303− , TLS.sharedSessionManager = mgr
304− }
305− supported = def { -- TLS.Supported
306− TLS.supportedVersions = tlsAllowedVersions
307− , TLS.supportedCiphers = tlsCiphers
308− , TLS.supportedCompressions = [TLS.nullCompression]
309− , TLS.supportedSecureRenegotiation = True
310− , TLS.supportedClientInitiatedRenegotiation = False
311− , TLS.supportedSession = True
312− , TLS.supportedFallbackScsv = True
313−#if MIN_VERSION_tls(1,5,0)
314− , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]
315−#endif
316− }
317−
318−alpn :: [S.ByteString] -> IO S.ByteString
319−alpn xs
320− | "h2" `elem` xs = return "h2"
321− | otherwise = return "http/1.1"
322
247
323----------------------------------------------------------------
248----------------------------------------------------------------
324
249
325−getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
250+getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
326−getter tlsset@TLSSettings{..} set sock params = do
251+getter tlsset@TLSSettings{..} sock params = do
327−#if WINDOWS
328− (s, sa) <- windowsThreadBlockHack $ accept sock
329−#else
330 (s, sa) <- accept sock
252 (s, sa) <- accept sock
331−#endif
332− setSocketCloseOnExec s
333− return (mkConn tlsset set s params, sa)
253+ return (mkConn tlsset s params, sa)
334
254
335−mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)
255+mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)
336−mkConn tlsset set s params = switch `onException` close s
256+mkConn tlsset s params = do
337− where
338− switch = do
339− firstBS <- safeRecv s 4096
257+ firstBS <- safeRecv s 4096
258+ cachedRef <- I.newIORef firstBS
340− if not (S.null firstBS) && S.head firstBS == 0x16 then
259+ (if not (B.null firstBS) && B.head firstBS == 0x16 then
341− httpOverTls tlsset set s firstBS params
260+ httpOverTls tlsset s cachedRef params
342− else
261+ else
343− plainHTTP tlsset set s firstBS
262+ plainHTTP tlsset s cachedRef) `onException` sClose s
344
263
345----------------------------------------------------------------
264----------------------------------------------------------------
346
265
347−httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)
266+httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport)
348−httpOverTls TLSSettings{..} _set s bs0 params = do
267+httpOverTls TLSSettings{..} s cachedRef params = do
349− recvN <- makePlainReceiveN s bs0
268+ gen <- Crypto.Random.AESCtr.makeSystem
350− ctx <- TLS.contextNew (backend recvN) params
269+ ctx <- TLS.contextNew backend params gen
351 TLS.contextHookSetLogging ctx tlsLogging
270 TLS.contextHookSetLogging ctx tlsLogging
352 TLS.handshake ctx
271 TLS.handshake ctx
353− h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx
354− isH2 <- I.newIORef h2
355 writeBuf <- allocateBuffer bufferSize
272 writeBuf <- allocateBuffer bufferSize
356− -- Creating a cache for leftover input data.
357− ref <- I.newIORef ""
358 tls <- getTLSinfo ctx
273 tls <- getTLSinfo ctx
359− return (conn ctx writeBuf ref isH2, tls)
274+ return (conn ctx writeBuf, tls)
360 where
275 where
361− backend recvN = TLS.Backend {
276+ backend = TLS.Backend {
362 TLS.backendFlush = return ()
277 TLS.backendFlush = return ()
363−#if MIN_VERSION_network(3,1,1)
278+ , TLS.backendClose = sClose s
364− , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()
365−#else
366− , TLS.backendClose = close s
367−#endif
368− , TLS.backendSend = sendAll' s
279+ , TLS.backendSend = sendAll s
369− , TLS.backendRecv = recvN
280+ , TLS.backendRecv = recvTLS cachedRef s
370 }
281 }
371− sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->
372− throwIO ConnectionClosedByPeer
373− conn ctx writeBuf ref isH2 = Connection {
282+ conn ctx writeBuf = Connection {
374 connSendMany = TLS.sendData ctx . L.fromChunks
283 connSendMany = TLS.sendData ctx . L.fromChunks
375 , connSendAll = sendall
284 , connSendAll = sendall
376 , connSendFile = sendfile
285 , connSendFile = sendfile
377− , connClose = close'
286+ , connClose = close
378− , connFree = freeBuffer writeBuf
379− , connRecv = recv ref
287+ , connRecv = recv
380− , connRecvBuf = recvBuf ref
381 , connWriteBuffer = writeBuf
288 , connWriteBuffer = writeBuf
382 , connBufferSize = bufferSize
289 , connBufferSize = bufferSize
383− , connHTTP2 = isH2
384 }
290 }
385 where
291 where
386 sendall = TLS.sendData ctx . L.fromChunks . return
292 sendall = TLS.sendData ctx . L.fromChunks . return
387 sendfile fid offset len hook headers =
293 sendfile fid offset len hook headers =
388 readSendFile writeBuf bufferSize sendall fid offset len hook headers
294 readSendFile writeBuf bufferSize sendall fid offset len hook headers
389
295
390− close' = void (tryIO sendBye) `finally`
296+ close = freeBuffer writeBuf `finally`
391− TLS.contextClose ctx
392−
393− sendBye =
394− -- It's fine if the connection was closed by the other side before
395− -- receiving close_notify, see RFC 5246 section 7.2.1.
396− handleJust
397− (\e -> guard (e == ConnectionClosedByPeer) >> return e)
398− (const (return ()))
399− (TLS.bye ctx)
297+ void (tryIO $ TLS.bye ctx) `finally`
400−
298+ TLS.contextClose ctx
401− -- TLS version of recv with a cache for leftover input data.
299+
402− -- The cache is shared with recvBuf.
403− recv cref = do
404− cached <- I.readIORef cref
405− if cached /= "" then do
406− I.writeIORef cref ""
407− return cached
408− else
409− recv'
410−
411− -- TLS version of recv (decrypting) without a cache.
412− recv' = handle onEOF go
300+ recv = handle onEOF go
413 where
301 where
414 onEOF e
302 onEOF e
415− | Just TLS.Error_EOF <- fromException e = return S.empty
303+ | Just TLS.Error_EOF <- fromException e = return B.empty
416− | Just ioe <- fromException e, isEOFError ioe = return S.empty | otherwise = throwIO e
304+ | Just ioe <- fromException e, isEOFError ioe = return B.empty | otherwise = throwIO e
417 go = do
305 go = do
418 x <- TLS.recvData ctx
306 x <- TLS.recvData ctx
419− if S.null x then
307+ if B.null x then
420 go
308 go
421 else
309 else
422 return x
310 return x
423
311
424− -- TLS version of recvBuf with a cache for leftover input data.
425− recvBuf cref buf siz = do
426− cached <- I.readIORef cref
427− (ret, leftover) <- fill cached buf siz recv'
428− I.writeIORef cref leftover
429− return ret
430−
431−fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString)
432−fill bs0 buf0 siz0 recv
433− | siz0 <= len0 = do
434− let (bs, leftover) = S.splitAt siz0 bs0
435− void $ copy buf0 bs
436− return (True, leftover)
437− | otherwise = do
438− buf <- copy buf0 bs0
439− loop buf (siz0 - len0)
440− where
441− len0 = S.length bs0
442− loop _ 0 = return (True, "")
443− loop buf siz = do
444− bs <- recv
445− let len = S.length bs
446− if len == 0 then return (False, "")
447− else if (len <= siz) then do
448− buf' <- copy buf bs
449− loop buf' (siz - len)
450− else do
451− let (bs1,bs2) = S.splitAt siz bs
452− void $ copy buf bs1
453− return (True, bs2)
454−
455getTLSinfo :: TLS.Context -> IO Transport
312getTLSinfo :: TLS.Context -> IO Transport
456getTLSinfo ctx = do
313getTLSinfo ctx = do
457 proto <- TLS.getNegotiatedProtocol ctx
314 proto <- TLS.getNegotiatedProtocol ctx
@@ -465,16 +322,11 @@ getTLSinfo ctx = do
465 TLS.TLS10 -> (3,1)
322 TLS.TLS10 -> (3,1)
466 TLS.TLS11 -> (3,2)
323 TLS.TLS11 -> (3,2)
467 TLS.TLS12 -> (3,3)
324 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 {
325 return TLS {
473 tlsMajorVersion = major
326 tlsMajorVersion = major
474 , tlsMinorVersion = minor
327 , tlsMinorVersion = minor
475 , tlsNegotiatedProtocol = proto
328 , tlsNegotiatedProtocol = proto
476 , tlsChiperID = TLS.cipherID infoCipher
329 , tlsChiperID = TLS.cipherID infoCipher
477− , tlsClientCertificate = clientCert
478 }
330 }
479
331
480tryIO :: IO a -> IO (Either IOException a)
332tryIO :: IO a -> IO (Either IOException a)
@@ -482,46 +334,52 @@ tryIO = try
482
334
483----------------------------------------------------------------
335----------------------------------------------------------------
484
336
485−plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)
337+plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport)
486−plainHTTP TLSSettings{..} set s bs0 = case onInsecure of
338+plainHTTP TLSSettings{..} s cachedRef = case onInsecure of
487 AllowInsecure -> do
339 AllowInsecure -> do
488− conn' <- socketConnection set s
340+ conn' <- socketConnection s
489− cachedRef <- I.newIORef bs0
490 let conn'' = conn'
341 let conn'' = conn'
491 { connRecv = recvPlain cachedRef (connRecv conn')
342 { connRecv = recvPlain cachedRef (connRecv conn')
492 }
343 }
493 return (conn'', TCP)
344 return (conn'', TCP)
494 DenyInsecure lbs -> do
345 DenyInsecure lbs -> do
495− -- Listening port 443 but TLS records do not arrive.
496− -- We want to let the browser know that TLS is required.
497− -- So, we use 426.
498− -- http://tools.ietf.org/html/rfc2817#section-4.2
499− -- https://tools.ietf.org/html/rfc7231#section-6.5.15
500− -- FIXME: should we distinguish HTTP/1.1 and HTTP/2?
501− -- In the case of HTTP/2, should we send
502− -- GOAWAY + INADEQUATE_SECURITY?
503− -- FIXME: Content-Length:
504− -- FIXME: TLS/<version>
505− sendAll s "HTTP/1.1 426 Upgrade Required\
506− \r\nUpgrade: TLS/1.0, HTTP/1.1\
507− \r\nConnection: Upgrade\
508− \r\nContent-Type: text/plain\r\n\r\n"
346+ sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"
509 mapM_ (sendAll s) $ L.toChunks lbs
347 mapM_ (sendAll s) $ L.toChunks lbs
510− close s
348+ sClose s
511 throwIO InsecureConnectionDenied
349 throwIO InsecureConnectionDenied
512
350
513----------------------------------------------------------------
351----------------------------------------------------------------
514
352
353+recvTLS :: I.IORef B.ByteString -> Socket -> Int -> IO B.ByteString
354+recvTLS cachedRef s size = do
355+ cached <- I.readIORef cachedRef
356+ loop cached
357+ where
358+ loop bs | B.length bs >= size = do
359+ let (x, y) = B.splitAt size bs
360+ I.writeIORef cachedRef y
361+ return x
362+ loop bs1 = do
363+ bs2 <- safeRecv s 4096
364+ if B.null bs2 then do
365+ -- FIXME does this deserve an exception being thrown?
366+ I.writeIORef cachedRef B.empty
367+ return bs1
368+ else
369+ loop $ B.append bs1 bs2
370+
371+----------------------------------------------------------------
372+
515-- | Modify the given receive function to first check the given @IORef@ for a
373-- | Modify the given receive function to first check the given @IORef@ for a
516-- chunk of data. If present, takes the chunk of data from the @IORef@ and
374-- chunk of data. If present, takes the chunk of data from the @IORef@ and
517-- empties out the @IORef@. Otherwise, calls the supplied receive function.
375-- empties out the @IORef@. Otherwise, calls the supplied receive function.
518−recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString
376+recvPlain :: I.IORef B.ByteString -> IO B.ByteString -> IO B.ByteString
519recvPlain ref fallback = do
377recvPlain ref fallback = do
520 bs <- I.readIORef ref
378 bs <- I.readIORef ref
521− if S.null bs
379+ if B.null bs
522 then fallback
380 then fallback
523 else do
381 else do
524− I.writeIORef ref S.empty
382+ I.writeIORef ref B.empty
525 return bs
383 return bs
526
384
527----------------------------------------------------------------
385----------------------------------------------------------------
warp-tls/warp-tls.cabal+9−20
@@ -1,6 +1,6 @@
1Name: warp-tls
1Name: warp-tls
2−Version: 3.2.11
2+Version: 3.0.4.1
3−Synopsis: HTTP over TLS support for Warp via the TLS package
3+Synopsis: HTTP over SSL/TLS support for Warp via the TLS package
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE
6Author: Michael Snoyman
6Author: Michael Snoyman
@@ -8,34 +8,23 @@ 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
13−description: SSLv1 and SSLv2 are obsoleted by IETF.
14− We should use TLS 1.2 (or TLS 1.1 or TLS 1.0 if necessary).
15− HTTP/2 can be negotiated by ALPN.
16− API docs and the README are available at
13+description: API docs and the README are available at <http://www.stackage.org/package/warp-tls>.
17− <http://www.stackage.org/package/warp-tls>.
18extra-source-files: ChangeLog.md README.md
14extra-source-files: ChangeLog.md README.md
19
15
20Library
16Library
21− Build-Depends: base >= 4.10 && < 5
17+ Build-Depends: base >= 4 && < 5
22 , bytestring >= 0.9
18 , bytestring >= 0.9
23− , wai >= 3.2 && < 3.3
19+ , wai >= 3.0 && < 3.1
24− , warp >= 3.3.6 && < 3.4
20+ , warp >= 3.0.8 && < 3.1
25 , data-default-class >= 0.0.1
21 , data-default-class >= 0.0.1
26− , tls >= 1.5.3
22+ , tls >= 1.2.16
27− , cryptonite >= 0.12
28 , network >= 2.2.1
23 , network >= 2.2.1
24+ , cprng-aes >= 0.5.0
29 , streaming-commons
25 , streaming-commons
30− , tls-session-manager >= 0.0.4
31 Exposed-modules: Network.Wai.Handler.WarpTLS
26 Exposed-modules: Network.Wai.Handler.WarpTLS
32 ghc-options: -Wall
27 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
28
40source-repository head
29source-repository head
41 type: git
30 type: git
warp/.ghci+1−1
@@ -1 +1 @@
1−:set -itest -idist/build/autogen -i.stack-work/dist/x86_64-linux/Cabal-1.22.5.0/build/autogen
1+:set -itest -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
warp/ChangeLog.md−298
@@ -1,301 +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
152−
153−* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)
154−* Guarantee atomicity of WINDOW_UPDATE increments [622](https://github.com/yesodweb/wai/pull/622)
155−* Relax HTTP2 headers check [621](https://github.com/yesodweb/wai/pull/621)
156−
157−## 3.2.12
158−
159−* If an empty string is set by setServerName, the Server header is not included in response headers [#619](https://github.com/yesodweb/wai/issues/619)
160−
161−## 3.2.11.2
162−
163−* Don't throw exceptions when closing a keep-alive connection
164− [#618](https://github.com/yesodweb/wai/issues/618)
165−
166−## 3.2.11.1
167−
168−* Move exception handling to top of thread (fixes
169− [#613](https://github.com/yesodweb/wai/issues/613))
170−
171−## 3.2.11
172−
173−* Fixing 10 HTTP2 bugs pointed out by h2spec v2.
174−
175−## 3.2.10
176−
177−* Add `connFree` to `Connection`. Close socket connections on timeout triggered. Timeout exceptions extend from `SomeAsyncException`. [#602](https://github.com/yesodweb/wai/pull/602) [#605](https://github.com/yesodweb/wai/pull/605)
178−
179−## 3.2.9
180−
181−* Fixing a space leak. [#586](https://github.com/yesodweb/wai/pull/586)
182−
183−## 3.2.8
184−
185−* Fixing HTTP2 requestBodyLength. [#573](https://github.com/yesodweb/wai/pull/573)
186−* Making HTTP/2 :path optional for the CONNECT method. [#572](https://github.com/yesodweb/wai/pull/572)
187−* Adding new APIs for HTTP/2 trailers: http2dataTrailers and modifyHTTP2Data [#566](https://github.com/yesodweb/wai/pull/566)
188−
189−## 3.2.7
190−
191−* Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data [#510](https://github.com/yesodweb/wai/pull/510)
192−* Better accept(2) error handling [#553](https://github.com/yesodweb/wai/pull/553)
193−* Adding getGracefulShutdownTimeout.
194−* Add {test,}withApplicationSettings [#531](https://github.com/yesodweb/wai/pull/531)
195−
196−## 3.2.6
197−
198−* Using token based APIs of http2 1.6.
199−
200−## 3.2.5
201−
202−* Ignoring errors from setSocketOption. [#526](https://github.com/yesodweb/wai/issues/526).
203−
204−## 3.2.4
205−
206−* Added `withApplication`, `testWithApplication`, and `openFreePort`
207−* Fixing reaper delay value of file info cache.
208−
209−## 3.2.3
210−
211−* Using http2 v1.5.x which much improves the performance of HTTP/2.
212−* To get rid of the bottleneck of ByteString's (==), a new logic to
213− compare header names is introduced.
214−
215−## 3.2.2
216−
217−* Throwing errno for pread [#499](https://github.com/yesodweb/wai/issues/499).
218−* Makeing compilable on Windows [#505](https://github.com/yesodweb/wai/issues/505).
219−
220−## 3.2.1
221−
222−* Add back `warpVersion`
223−
224−## 3.2.0
225−
226−* Major version up due to breaking changes. This is because the HTTP/2 code
227− was started over with Warp 3.1.3 due to performance issue [#470](https://github.com/yesodweb/wai/issues/470).
228−* runHTTP2, runHTTP2Env, runHTTP2Settings and runHTTP2SettingsSocket were removed from the Network.Wai.Handler.Warp module.
229−* The performance of HTTP/2 was drastically improved. Now the performance of HTTP/2 is almost the same as that of HTTP/1.1.
230−* The logic to handle files in HTTP/2 is now identical to that in HTTP/1.1.
231−* Internal stuff was removed from the Network.Wai.Handler.Warp module according to [the plan](http://www.yesodweb.com/blog/2015/06/cleaning-up-warp-apis).
232−
233−## 3.1.12
234−
235−* Setting lower bound for auto-update [#495](https://github.com/yesodweb/wai/issues/495)
236−
237−## 3.1.11
238−
239−* Providing a new API: killManager.
240−* Preventing space leaks due to Weak ThreadId [#488](https://github.com/yesodweb/wai/issues/488)
241−* Setting upper bound for http2.
242−
243−## 3.1.10
244−
245−* `setFileInfoCacheDuration`
246−* `setLogger`
247−* `FileInfo`/`getFileInfo`
248−* Fix: warp-tls strips out the Host request header [#478](https://github.com/yesodweb/wai/issues/478)
249−
250−## 3.1.9
251−
252−* Using the new priority queue based on PSQ provided by http2 lib again.
253−
254−## 3.1.8
255−
256−* Using the new priority queue based on PSQ provided by http2 lib.
257−
258−## 3.1.7
259−
260−* A concatenated Cookie header is prepended to the headers to ensure that it flows pseudo headers. [#454](https://github.com/yesodweb/wai/pull/454)
261−* Providing a new settings: `setHTTP2Disabled` [#450](https://github.com/yesodweb/wai/pull/450)
262−
263−## 3.1.6
264−
265−* Adding back http-types 0.8 support [#449](https://github.com/yesodweb/wai/pull/449)
266−
267−## 3.1.5
268−
269−* Using http-types v0.9.
270−* Fixing build on OpenBSD. [#428](https://github.com/yesodweb/wai/pull/428) [#440](https://github.com/yesodweb/wai/pull/440)
271−* Fixing build on Windows. [#438](https://github.com/yesodweb/wai/pull/438)
272−
273−## 3.1.4
274−
275−* Using newer http2 library to prevent change table size attacks.
276−* API for HTTP/2 server push and trailers. [#426](https://github.com/yesodweb/wai/pull/426)
277−* Preventing response splitting attacks. [#435](https://github.com/yesodweb/wai/pull/435)
278−* Concatenating multiple Cookie: headers in HTTP/2.
279−
280−## 3.1.3
281−
282−* Warp now supports blaze-builder v0.4 or later only.
283−* HTTP/2 code was improved: dynamic priority change, efficient queuing and sender loop continuation. [#423](https://github.com/yesodweb/wai/pull/423) [#424](https://github.com/yesodweb/wai/pull/424)
284−
285−## 3.1.2
286−
287−* Configurable Slowloris size [#418](https://github.com/yesodweb/wai/pull/418)
288−
289−## 3.1.1
290−
291−* Fixing a bug of HTTP/2 when no FD cache is used [#411](https://github.com/yesodweb/wai/pull/411)
292−* Fixing a buffer-pool bug [#406](https://github.com/yesodweb/wai/pull/406) [#407](https://github.com/yesodweb/wai/pull/407)
293−
294−## 3.1.0
295−
296−* Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399)
297−* Cleaning up APIs [#387](https://github.com/yesodweb/wai/issues/387)
298−
299## 3.0.13.1
1## 3.0.13.1
300
2
301* Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375)
3* Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375)
warp/Network/Wai/Handler/Warp.hs+55−234
@@ -19,9 +19,6 @@
19
19
20-- | A fast, light-weight HTTP server handler for WAI.
20-- | A fast, light-weight HTTP server handler for WAI.
21--
21--
22−-- HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2,
23−-- Warp supports direct and ALPN (in TLS) but not upgrade.
24−--
25-- Note on slowloris timeouts: to prevent slowloris attacks, timeouts are used
22-- Note on slowloris timeouts: to prevent slowloris attacks, timeouts are used
26-- at various points in request receiving and response sending. One interesting
23-- at various points in request receiving and response sending. One interesting
27-- corner case is partial request body consumption; in that case, Warp's
24-- corner case is partial request body consumption; in that case, Warp's
@@ -38,8 +35,6 @@
38--
35--
39module Network.Wai.Handler.Warp (
36module Network.Wai.Handler.Warp (
40 -- * Run a Warp server
37 -- * Run a Warp server
41− -- | All of these automatically serve the same 'Application' over HTTP\/1,
42− -- HTTP\/1.1, and HTTP\/2.
43 run
38 run
44 , runEnv
39 , runEnv
45 , runSettings
40 , runSettings
@@ -57,7 +52,6 @@ module Network.Wai.Handler.Warp (
57 , setTimeout
52 , setTimeout
58 , setManager
53 , setManager
59 , setFdCacheDuration
54 , setFdCacheDuration
60− , setFileInfoCacheDuration
61 , setBeforeMainLoop
55 , setBeforeMainLoop
62 , setNoParsePath
56 , setNoParsePath
63 , setInstallShutdownHandler
57 , setInstallShutdownHandler
@@ -67,23 +61,9 @@ module Network.Wai.Handler.Warp (
67 , setProxyProtocolNone
61 , setProxyProtocolNone
68 , setProxyProtocolRequired
62 , setProxyProtocolRequired
69 , setProxyProtocolOptional
63 , setProxyProtocolOptional
70− , setSlowlorisSize
71− , setHTTP2Disabled
72− , setLogger
73− , setServerPushLogger
74− , setGracefulShutdownTimeout
75− , setGracefulCloseTimeout1
76− , setGracefulCloseTimeout2
77− , setMaxTotalHeaderLength
78 -- ** Getters
64 -- ** Getters
79 , getPort
65 , getPort
80 , getHost
66 , getHost
81− , getOnOpen
82− , getOnClose
83− , getOnException
84− , getGracefulShutdownTimeout
85− , getGracefulCloseTimeout1
86− , getGracefulCloseTimeout2
87 -- ** Exception handler
67 -- ** Exception handler
88 , defaultOnException
68 , defaultOnException
89 , defaultShouldDisplayException
69 , defaultShouldDisplayException
@@ -91,58 +71,70 @@ module Network.Wai.Handler.Warp (
91 , defaultOnExceptionResponse
71 , defaultOnExceptionResponse
92 , exceptionResponseForDebug
72 , exceptionResponseForDebug
93 -- * Data types
73 -- * Data types
94− , HostPreference
74+ , HostPreference (..)
95 , Port
75 , Port
96 , InvalidRequest (..)
76 , InvalidRequest (..)
97 -- * Utilities
77 -- * Utilities
98 , pauseTimeout
78 , pauseTimeout
99− , FileInfo(..)
79+ -- * Internal
100− , getFileInfo
80+ -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal.
101− , clientCertificate
81+
102− , withApplication
82+ -- ** Low level run functions
103− , withApplicationSettings
83+ , runSettingsConnection
104− , testWithApplication
84+ , runSettingsConnectionMaker
105− , testWithApplicationSettings
85+ , runSettingsConnectionMakerSecure
106− , openFreePort
86+ , Transport (..)
87+ -- ** Connection
88+ , Connection (..)
89+ , socketConnection
90+ -- ** Buffer
91+ , Buffer
92+ , BufSize
93+ , bufferSize
94+ , allocateBuffer
95+ , freeBuffer
96+ -- ** Sendfile
97+ , FileId (..)
98+ , SendFile
99+ , sendFile
100+ , readSendFile
107− -- * Version
101+ -- ** Version
108 , warpVersion
102 , warpVersion
109− -- * HTTP/2
103+ -- ** Data types
110− -- ** HTTP2 data
104+ , InternalInfo (..)
111− , HTTP2Data
105+ , HeaderValue
112− , http2dataPushPromise
106+ , IndexedHeader
113− , http2dataTrailers
107+ , requestMaxIndex
114− , defaultHTTP2Data
108+ -- ** File descriptor cache
115− , getHTTP2Data
109+ , module Network.Wai.Handler.Warp.FdCache
116− , setHTTP2Data
110+ -- ** Date
117− , modifyHTTP2Data
111+ , module Network.Wai.Handler.Warp.Date
118− -- ** Push promise
112+ -- ** Request and response
119− , PushPromise
113+ , Source
120− , promisedPath
114+ , recvRequest
121− , promisedFile
115+ , sendResponse
122− , promisedResponseHeaders
116+ -- ** Time out manager
123− , promisedWeight
117+ , module Network.Wai.Handler.Warp.Timeout
124− , defaultPushPromise
125 ) where
118 ) where
126
119
127−import Control.Exception (SomeException, throwIO)
120+import Control.Exception (SomeException)
121+import Data.ByteString (ByteString)
122+import Data.Maybe (fromMaybe)
128import Data.Streaming.Network (HostPreference)
123import Data.Streaming.Network (HostPreference)
129import qualified Data.Vault.Lazy as Vault
124import qualified Data.Vault.Lazy as Vault
130−import Data.X509
131−import 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−
136−import Network.Wai.Handler.Warp.FileInfoCache
127+import Network.Wai.Handler.Warp.Buffer
137−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)
128+import Network.Wai.Handler.Warp.Date
138−import Network.Wai.Handler.Warp.HTTP2.Types
129+import Network.Wai.Handler.Warp.FdCache
139−import Network.Wai.Handler.Warp.Imports
130+import Network.Wai.Handler.Warp.Header
140import Network.Wai.Handler.Warp.Request
131import Network.Wai.Handler.Warp.Request
141−import Network.Wai.Handler.Warp.Response (warpVersion)
132+import Network.Wai.Handler.Warp.Response
142import Network.Wai.Handler.Warp.Run
133import Network.Wai.Handler.Warp.Run
134+import Network.Wai.Handler.Warp.SendFile
143import Network.Wai.Handler.Warp.Settings
135import Network.Wai.Handler.Warp.Settings
144−import Network.Wai.Handler.Warp.Types hiding (getFileInfo)
136+import Network.Wai.Handler.Warp.Timeout
145−import Network.Wai.Handler.Warp.WithApplication
137+import Network.Wai.Handler.Warp.Types
146
138
147-- | Port to listen on. Default value: 3000
139-- | Port to listen on. Default value: 3000
148--
140--
@@ -164,17 +156,8 @@ setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Setti
164setOnException x y = y { settingsOnException = x }
156setOnException x y = y { settingsOnException = x }
165
157
166-- | A function to create a `Response` when an exception occurs.
158-- | A function to create a `Response` when an exception occurs.
167−-- Default: 'defaultOnExceptionResponse'
168--
159--
169−-- Note that an application can handle its own exceptions without interfering with Warp:
160+-- Default: 'defaultOnExceptionResponse'
170−--
171−-- > myApp :: Application
172−-- > myApp request respond = innerApp `catch` onError
173−-- > where
174−-- > onError = respond . response500 request
175−-- >
176−-- > response500 :: Request -> SomeException -> Response
177−-- > response500 req someEx = responseLBS status500 -- ...
178--
161--
179-- Since 2.1.0
162-- Since 2.1.0
180setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings
163setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings
@@ -217,26 +200,10 @@ setManager x y = y { settingsManager = Just x }
217-- Enabling this cache results in drastic performance improvement for file
200-- Enabling this cache results in drastic performance improvement for file
218-- transfers.
201-- transfers.
219--
202--
220−-- Default value: 0, was previously 10
203+-- Default value: since 3.0.13, default value is 0, was previously 10
221−--
222−-- Since 3.0.13
223setFdCacheDuration :: Int -> Settings -> Settings
204setFdCacheDuration :: Int -> Settings -> Settings
224setFdCacheDuration x y = y { settingsFdCacheDuration = x }
205setFdCacheDuration x y = y { settingsFdCacheDuration = x }
225
206
226−-- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used.
227−--
228−-- The file information cache is an optimization that is useful for servers dealing with
229−-- static files. However, if files are being modified, it can cause incorrect
230−-- results in some cases. Therefore, we disable it by default. If you know that
231−-- your files will be static or you prefer performance to file consistency,
232−-- it's recommended to turn this on; a reasonable value for those cases is 10.
233−-- Enabling this cache results in drastic performance improvement for file
234−-- transfers.
235−--
236−-- Default value: 0
237−setFileInfoCacheDuration :: Int -> Settings -> Settings
238−setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }
239−
240-- | Code to run after the listening socket is ready but before entering
207-- | Code to run after the listening socket is ready but before entering
241-- the main event loop. Useful for signaling to tests that they can start
208-- the main event loop. Useful for signaling to tests that they can start
242-- running, or to drop permissions after binding to a restricted port.
209-- running, or to drop permissions after binding to a restricted port.
@@ -269,51 +236,11 @@ getPort = settingsPort
269getHost :: Settings -> HostPreference
236getHost :: Settings -> HostPreference
270getHost = settingsHost
237getHost = settingsHost
271
238
272−-- | Get the action on opening connection.
273−getOnOpen :: Settings -> SockAddr -> IO Bool
274−getOnOpen = settingsOnOpen
275−
276−-- | Get the action on closeing connection.
277−getOnClose :: Settings -> SockAddr -> IO ()
278−getOnClose = settingsOnClose
279−
280−-- | Get the exception handler.
281−getOnException :: Settings -> Maybe Request -> SomeException -> IO ()
282−getOnException = settingsOnException
283−
284−-- | Get the graceful shutdown timeout
285−--
286−-- Since 3.2.8
287−getGracefulShutdownTimeout :: Settings -> Maybe Int
288−getGracefulShutdownTimeout = settingsGracefulShutdownTimeout
289−
290-- | A code to install shutdown handler.
239-- | A code to install shutdown handler.
291--
240--
292-- For instance, this code should set up a UNIX signal
241-- For instance, this code should set up a UNIX signal
293-- handler. The handler should call the first argument,
242-- handler. The handler should call the first argument,
294−-- which closes the listen socket, at shutdown.
243+-- which close the listen socket, at shutdown.
295−--
296−-- Example usage:
297−--
298−-- @
299−-- settings :: IO () -> 'Settings'
300−-- settings shutdownAction = 'setInstallShutdownHandler' shutdownHandler 'defaultSettings'
301−-- __where__
302−-- shutdownHandler closeSocket =
303−-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'
304−-- @
305−--
306−-- Note that by default, the graceful shutdown mode lasts indefinitely
307−-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,
308−-- upon receiving that signal, the custon shutdown action will run /and/ all
309−-- outstanding requests will be handled.
310−--
311−-- You may instead prefer to do one or both of the following:
312−--
313−-- * Only wait a finite amount of time for outstanding requests to complete,
314−-- using 'setGracefulShutdownTimeout'.
315−-- * Only catch one signal, so the second hard-kills the Warp server, using
316−-- 'System.Posix.Signals.CatchOnce'.
317--
244--
318-- Default: does not install any code.
245-- Default: does not install any code.
319--
246--
@@ -321,10 +248,7 @@ getGracefulShutdownTimeout = settingsGracefulShutdownTimeout
321setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings
248setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings
322setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }
249setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }
323
250
324−-- | Default server name to be sent as the \"Server:\" header
325−-- if an application does not set one.
251+-- | Default server name if application does not set one.
326−-- If an empty string is set, the \"Server:\" header is not sent.
327−-- This is true even if an application set one.
328--
252--
329-- Since 3.0.2
253-- Since 3.0.2
330setServerName :: ByteString -> Settings -> Settings
254setServerName :: ByteString -> Settings -> Settings
@@ -385,7 +309,7 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }
385--
309--
386-- WARNING: This is contrary to the PROXY protocol specification and
310-- WARNING: This is contrary to the PROXY protocol specification and
387-- using it can indicate a security problem with your
311-- using it can indicate a security problem with your
388−-- architecture if the web server is directly accessible
312+-- architecture if the web server is directly accessable
389-- to the public, since it would allow easy IP address
313-- to the public, since it would allow easy IP address
390-- spoofing. However, it can be useful in some cases,
314-- spoofing. However, it can be useful in some cases,
391-- such as if a load balancer health check uses regular
315-- such as if a load balancer health check uses regular
@@ -396,54 +320,6 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }
396setProxyProtocolOptional :: Settings -> Settings
320setProxyProtocolOptional :: Settings -> Settings
397setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional }
321setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional }
398
322
399−-- | Size in bytes read to prevent Slowloris attacks. Default value: 2048
400−--
401−-- Since 3.1.2
402−setSlowlorisSize :: Int -> Settings -> Settings
403−setSlowlorisSize x y = y { settingsSlowlorisSize = x }
404−
405−-- | Disable HTTP2.
406−--
407−-- Since 3.1.7
408−setHTTP2Disabled :: Settings -> Settings
409−setHTTP2Disabled y = y { settingsHTTP2Enabled = False }
410−
411−-- | Setting a log function.
412−--
413−-- Since 3.X.X
414−setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -- ^ request, status, maybe file-size
415− -> Settings
416− -> Settings
417−setLogger lgr y = y { settingsLogger = lgr }
418−
419−-- | Setting a log function for HTTP/2 server push.
420−--
421−-- Since: 3.2.7
422−setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size
423− -> Settings
424− -> Settings
425−setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }
426−
427−-- | Set the graceful shutdown timeout. A timeout of `Nothing' will
428−-- 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.
430−--
431−-- Graceful shutdown mode is entered when the server socket is closed; see
432−-- 'setInstallShutdownHandler' for an example of how this could be done in
433−-- response to a UNIX signal.
434−--
435−-- Since 3.2.8
436−setGracefulShutdownTimeout :: Maybe Int
437− -> Settings -> Settings
438−setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }
439−
440−-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.
441−--
442−-- Since 3.3.8
443−setMaxTotalHeaderLength :: Int -> Settings -> Settings
444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings
445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }
446−
447-- | Explicitly pause the slowloris timeout.
323-- | Explicitly pause the slowloris timeout.
448--
324--
449-- This is useful for cases where you partially consume a request body. For
325-- This is useful for cases where you partially consume a request body. For
@@ -452,58 +328,3 @@ setMaxTotalHeaderLength maxTotalHeaderLength settings = settings
452-- Since 3.0.10
328-- Since 3.0.10
453pauseTimeout :: Request -> IO ()
329pauseTimeout :: Request -> IO ()
454pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault
330pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault
455−
456−-- | Getting file information of the target file.
457−--
458−-- This function first uses a stat(2) or similar system call
459−-- to obtain information of the target file, then registers
460−-- it into the internal cache.
461−-- From the next time, the information is obtained
462−-- from the cache. This reduces the overhead to call the system call.
463−-- The internal cache is refreshed every duration specified by
464−-- 'setFileInfoCacheDuration'.
465−--
466−-- This function throws an 'IO' exception if the information is not
467−-- available. For instance, the target file does not exist.
468−-- If this function is used an a Request generated by a WAI
469−-- backend besides Warp, it also throws an 'IO' exception.
470−--
471−-- Since 3.1.10
472−getFileInfo :: Request -> FilePath -> IO FileInfo
473−getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault
474−
475−-- | A timeout to limit the time (in milliseconds) waiting for
476−-- FIN for HTTP/1.x. 0 means uses immediate close.
477−-- Default: 0.
478−--
479−-- Since 3.3.5
480−setGracefulCloseTimeout1 :: Int -> Settings -> Settings
481−setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }
482−
483−-- | A timeout to limit the time (in milliseconds) waiting for
484−-- FIN for HTTP/1.x. 0 means uses immediate close.
485−--
486−-- Since 3.3.5
487−getGracefulCloseTimeout1 :: Settings -> Int
488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1
489−
490−-- | A timeout to limit the time (in milliseconds) waiting for
491−-- FIN for HTTP/2. 0 means uses immediate close.
492−-- Default: 2000.
493−--
494−-- Since 3.3.5
495−setGracefulCloseTimeout2 :: Int -> Settings -> Settings
496−setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }
497−
498−-- | A timeout to limit the time (in milliseconds) waiting for
499−-- FIN for HTTP/2. 0 means uses immediate close.
500−--
501−-- Since 3.3.5
502−getGracefulCloseTimeout2 :: Settings -> Int
503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2
504−
505−-- | Getting information of client certificate.
506−--
507−-- Since 3.3.5
508−clientCertificate :: Request -> Maybe CertificateChain
509−clientCertificate = join . Vault.lookup getClientCertificateKey . vault
warp/Network/Wai/Handler/Warp/Buffer.hs+28−22
@@ -4,24 +4,23 @@ module Network.Wai.Handler.Warp.Buffer (
4 bufferSize
4 bufferSize
5 , allocateBuffer
5 , allocateBuffer
6 , freeBuffer
6 , freeBuffer
7− , mallocBS
8 , newBufferPool
7 , newBufferPool
9 , withBufferPool
8 , withBufferPool
10− , toBuilderBuffer
9+ , toBlazeBuffer
11 , copy
10 , copy
12− , bufferIO
11+ , toBS
13 ) where
12 ) where
14
13
14+import Control.Monad (when)
15import qualified Data.ByteString as BS
15import qualified Data.ByteString as BS
16−import Data.ByteString.Internal (memcpy)
16+import Data.ByteString.Internal
17import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)
17import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)
18import Data.IORef (newIORef, readIORef, writeIORef)
18import Data.IORef (newIORef, readIORef, writeIORef)
19import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))
19import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))
20+import Data.Word (Word8)
20import Foreign.ForeignPtr
21import Foreign.ForeignPtr
21import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)
22import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)
22−import Foreign.Ptr (castPtr, plusPtr)
23+import Foreign.Ptr (Ptr, castPtr, plusPtr)
23−
24−import Network.Wai.Handler.Warp.Imports
25import Network.Wai.Handler.Warp.Types
24import Network.Wai.Handler.Warp.Types
26
25
27----------------------------------------------------------------
26----------------------------------------------------------------
@@ -52,12 +51,20 @@ minBufferSize = 2048
52newBufferPool :: IO BufferPool
51newBufferPool :: IO BufferPool
53newBufferPool = newIORef BS.empty
52newBufferPool = newIORef BS.empty
54
53
55−mallocBS :: Int -> IO ByteString
54+mallocBuffer :: Int -> IO ByteString
56−mallocBS size = do
55+mallocBuffer size = do
57− ptr <- allocateBuffer size
56+ ptr <- mallocBytes size
58 fptr <- newForeignPtr finalizerFree ptr
57 fptr <- newForeignPtr finalizerFree ptr
59 return $! PS fptr 0 size
58 return $! PS fptr 0 size
60−{-# INLINE mallocBS #-}
59+{-# INLINE mallocBuffer #-}
60+
61+{-
62+createBuffer :: Int -> IO ByteString
63+createBuffer size = do
64+ fptr <- mallocByteString size
65+ return $! PS fptr 0 size
66+{-# INLINE createBuffer #-}
67+-}
61
68
62usefulBuffer :: ByteString -> Bool
69usefulBuffer :: ByteString -> Bool
63usefulBuffer buffer = BS.length buffer >= minBufferSize
70usefulBuffer buffer = BS.length buffer >= minBufferSize
@@ -66,11 +73,11 @@ usefulBuffer buffer = BS.length buffer >= minBufferSize
66getBuffer :: BufferPool -> IO ByteString
73getBuffer :: BufferPool -> IO ByteString
67getBuffer pool = do
74getBuffer pool = do
68 buffer <- readIORef pool
75 buffer <- readIORef pool
69− if usefulBuffer buffer then return buffer else mallocBS largeBufferSize
76+ if usefulBuffer buffer then return buffer else mallocBuffer largeBufferSize
70{-# INLINE getBuffer #-}
77{-# INLINE getBuffer #-}
71
78
72putBuffer :: BufferPool -> ByteString -> IO ()
79putBuffer :: BufferPool -> ByteString -> IO ()
73−putBuffer pool buffer = writeIORef pool buffer
80+putBuffer pool buffer = when (usefulBuffer buffer) $ writeIORef pool buffer
74{-# INLINE putBuffer #-}
81{-# INLINE putBuffer #-}
75
82
76withForeignBuffer :: ByteString -> ((Buffer, BufSize) -> IO Int) -> IO Int
83withForeignBuffer :: ByteString -> ((Buffer, BufSize) -> IO Int) -> IO Int
@@ -90,20 +97,19 @@ withBufferPool pool f = do
90-- Utilities
97-- Utilities
91--
98--
92
99
93−toBuilderBuffer :: Buffer -> BufSize -> IO B.Buffer
100+toBlazeBuffer :: Buffer -> BufSize -> IO B.Buffer
94−toBuilderBuffer ptr size = do
101+toBlazeBuffer ptr size = do
95 fptr <- newForeignPtr_ ptr
102 fptr <- newForeignPtr_ ptr
96 return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)
103 return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)
97
104
98−-- | Copying the bytestring to the buffer.
105+{-# INLINE copy #-}
99−-- This function returns the point where the next copy should start.
100−copy :: Buffer -> ByteString -> IO Buffer
106+copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)
101copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do
107copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do
102 memcpy ptr (p `plusPtr` o) (fromIntegral l)
108 memcpy ptr (p `plusPtr` o) (fromIntegral l)
103 return $! ptr `plusPtr` l
109 return $! ptr `plusPtr` l
104−{-# INLINE copy #-}
105
110
111+{-# INLINE toBS #-}
106−bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO ()
112+toBS :: Buffer -> Int -> IO ByteString
107−bufferIO ptr siz io = do
113+toBS ptr siz = do
108 fptr <- newForeignPtr_ ptr
114 fptr <- newForeignPtr_ ptr
109− io $ PS fptr 0 siz
115+ return $ PS fptr 0 siz
warp/Network/Wai/Handler/Warp/Conduit.hs+16−2
@@ -3,10 +3,16 @@
3module Network.Wai.Handler.Warp.Conduit where
3module Network.Wai.Handler.Warp.Conduit where
4
4
5import Control.Exception
5import Control.Exception
6+import Control.Monad (when, unless)
7+import Data.ByteString (ByteString)
8+import Data.ByteString.Lazy.Char8 (pack)
6import qualified Data.ByteString as S
9import qualified Data.ByteString as S
10+import qualified Data.ByteString.Lazy as L
7import qualified Data.IORef as I
11import qualified Data.IORef as I
8−
12+#if __GLASGOW_HASKELL__ < 709
9−import Network.Wai.Handler.Warp.Imports
13+import Data.Word (Word)
14+#endif
15+import Data.Word (Word8)
10import Network.Wai.Handler.Warp.Types
16import Network.Wai.Handler.Warp.Types
11
17
12----------------------------------------------------------------
18----------------------------------------------------------------
@@ -60,6 +66,11 @@ readISource (ISource src ref) = do
60 assert (count' == 0) $ I.writeIORef ref count'
66 assert (count' == 0) $ I.writeIORef ref count'
61 return x
67 return x
62
68
69+-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not
70+-- perform any more isolation.
71+isourceDone :: ISource -> Source
72+isourceDone (ISource src _) = src
73+
63----------------------------------------------------------------
74----------------------------------------------------------------
64
75
65data CSource = CSource !Source !(I.IORef ChunkState)
76data CSource = CSource !Source !(I.IORef ChunkState)
@@ -70,6 +81,9 @@ data ChunkState = NeedLen
70 | DoneChunking
81 | DoneChunking
71 deriving Show
82 deriving Show
72
83
84+bsCRLF :: L.ByteString
85+bsCRLF = pack "\r\n"
86+
73mkCSource :: Source -> IO CSource
87mkCSource :: Source -> IO CSource
74mkCSource src = do
88mkCSource src = do
75 ref <- I.newIORef NeedLen
89 ref <- I.newIORef NeedLen
warp/Network/Wai/Handler/Warp/Counter.hs+4−3
@@ -8,10 +8,11 @@ module Network.Wai.Handler.Warp.Counter (
8 , decrease
8 , decrease
9 ) where
9 ) where
10
10
11+#if __GLASGOW_HASKELL__ < 709
12+import Control.Applicative ((<$>))
13+#endif
11import Control.Concurrent.STM
14import Control.Concurrent.STM
12−
15+import Control.Monad (unless)
13−import Network.Wai.Handler.Warp.Imports
14−
15
16
16newtype Counter = Counter (TVar Int)
17newtype Counter = Counter (TVar Int)
17
18
warp/Network/Wai/Handler/Warp/Date.hs+28−17
@@ -2,40 +2,51 @@
2
2
3module Network.Wai.Handler.Warp.Date (
3module Network.Wai.Handler.Warp.Date (
4 withDateCache
4 withDateCache
5+ , getDate
6+ , DateCache
5 , GMTDate
7 , GMTDate
6 ) where
8 ) where
7
9
10+#if __GLASGOW_HASKELL__ < 709
11+import Control.Applicative
12+#endif
8import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)
13import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)
9−import Data.ByteString
14+import Data.ByteString.Char8
10−import Network.HTTP.Date
11
15
12#if WINDOWS
16#if WINDOWS
13−import Data.Time (UTCTime, getCurrentTime)
17+import Data.Time (formatTime, getCurrentTime)
14−import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
18+# if MIN_VERSION_time(1,5,0)
15−import Foreign.C.Types (CTime(..))
19+import Data.Time (defaultTimeLocale)
20+# else
21+import System.Locale (defaultTimeLocale)
22+# endif
16#else
23#else
24+import Network.HTTP.Date
17import System.Posix (epochTime)
25import System.Posix (epochTime)
18#endif
26#endif
19
27
20-- | The type of the Date header value.
28-- | The type of the Date header value.
21type GMTDate = ByteString
29type GMTDate = ByteString
22
30
31+-- | The type of the cache of the Date header value.
32+type DateCache = IO GMTDate
33+
23-- | Creating 'DateCache' and executing the action.
34-- | Creating 'DateCache' and executing the action.
24−withDateCache :: (IO GMTDate -> IO a) -> IO a
35+withDateCache :: (DateCache -> IO a) -> IO a
25withDateCache action = initialize >>= action
36withDateCache action = initialize >>= action
26
37
27−initialize :: IO (IO GMTDate)
38+initialize :: IO DateCache
28−initialize = mkAutoUpdate defaultUpdateSettings {
39+initialize = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentGMTDate }
29− updateAction = formatHTTPDate <$> getCurrentHTTPDate
30− }
31
40
32−#ifdef WINDOWS
41+-- | Getting 'GMTDate' based on 'DateCache'.
33−uToH :: UTCTime -> HTTPDate
42+getDate :: DateCache -> IO GMTDate
34−uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds
43+getDate = id
35
44
36−getCurrentHTTPDate :: IO HTTPDate
45+getCurrentGMTDate :: IO GMTDate
37−getCurrentHTTPDate = uToH <$> getCurrentTime
46+#ifdef WINDOWS
47+getCurrentGMTDate = formatDate <$> getCurrentTime
48+ where
49+ formatDate = pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
38#else
50#else
39−getCurrentHTTPDate :: IO HTTPDate
40−getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime
51+getCurrentGMTDate = formatHTTPDate . epochTimeToHTTPDate <$> epochTime
41#endif
52#endif
warp/Network/Wai/Handler/Warp/FdCache.hs+90−78
@@ -2,46 +2,36 @@
2
2
3-- | File descriptor cache to avoid locks in kernel.
3-- | File descriptor cache to avoid locks in kernel.
4
4
5+#ifdef WINDOWS
5module Network.Wai.Handler.Warp.FdCache (
6module Network.Wai.Handler.Warp.FdCache (
6 withFdCache
7 withFdCache
7− , Fd
8+ , MutableFdCache
8 , Refresh
9 , Refresh
9−#ifndef WINDOWS
10− , openFile
11− , closeFile
12− , setFileCloseOnExec
13−#endif
14 ) where
10 ) where
15
11
16−#ifndef WINDOWS
17−import Control.Exception (bracket)
18−import Control.Reaper
19−import Data.IORef
20−import Network.Wai.Handler.Warp.MultiMap as MM
21−import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)
22−#endif
23−import System.Posix.Types (Fd)
24−
25−----------------------------------------------------------------
26−
27−-- | An action to activate a Fd cache entry.
28type Refresh = IO ()
12type Refresh = IO ()
13+data MutableFdCache = MutableFdCache
29
14
30−getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)
15+withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
31−getFdNothing _ = return (Nothing, return ())
32−
33−----------------------------------------------------------------
34−
35−-- | Creating 'MutableFdCache' and executing the action in the second
36−-- argument. The first argument is a cache duration in second.
37−withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a
38−#ifdef WINDOWS
39−withFdCache _ action = action getFdNothing
16+withFdCache _ f = f Nothing
40#else
17#else
41−withFdCache 0 action = action getFdNothing
18+module Network.Wai.Handler.Warp.FdCache (
42−withFdCache duration action = bracket (initialize duration)
19+ withFdCache
43− terminate
44− (action . getFd)
20+ , getFd
21+ , MutableFdCache
22+ , Refresh
23+ ) where
24+
25+#if __GLASGOW_HASKELL__ < 709
26+import Control.Applicative ((<$>), (<*>))
27+#endif
28+import Control.Exception (bracket)
29+import Data.Hashable (hash)
30+import Network.Wai.Handler.Warp.IORef
31+import Network.Wai.Handler.Warp.MultiMap
32+import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
33+import System.Posix.Types (Fd)
34+import Control.Reaper
45
35
46----------------------------------------------------------------
36----------------------------------------------------------------
47
37
@@ -49,6 +39,9 @@ data Status = Active | Inactive
49
39
50newtype MutableStatus = MutableStatus (IORef Status)
40newtype MutableStatus = MutableStatus (IORef Status)
51
41
42+-- | An action to activate a Fd cache entry.
43+type Refresh = IO ()
44+
52status :: MutableStatus -> IO Status
45status :: MutableStatus -> IO Status
53status (MutableStatus ref) = readIORef ref
46status (MutableStatus ref) = readIORef ref
54
47
@@ -63,80 +56,99 @@ inactive (MutableStatus ref) = writeIORef ref Inactive
63
56
64----------------------------------------------------------------
57----------------------------------------------------------------
65
58
66−data FdEntry = FdEntry !Fd !MutableStatus
59+data FdEntry = FdEntry !FilePath !Fd !MutableStatus
67−
68−openFile :: FilePath -> IO Fd
69−openFile path = do
70− fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=False}
71− setFileCloseOnExec fd
72− return fd
73−
74−closeFile :: Fd -> IO ()
75−closeFile = closeFd
76
60
77newFdEntry :: FilePath -> IO FdEntry
61newFdEntry :: FilePath -> IO FdEntry
78−newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus
62+newFdEntry path = FdEntry path
79−
63+ <$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
80−setFileCloseOnExec :: Fd -> IO ()
64+ <*> newActiveStatus
81−setFileCloseOnExec fd = setFdOption fd CloseOnExec True
82
65
83----------------------------------------------------------------
66----------------------------------------------------------------
84
67
68+type Hash = Int
85−type FdCache = MultiMap FdEntry
69+type FdCache = MMap Hash FdEntry
86
70
87-- | Mutable Fd cacher.
71-- | Mutable Fd cacher.
88−newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))
72+type MutableFdCache = Reaper FdCache (Hash, FdEntry)
89
73
90fdCache :: MutableFdCache -> IO FdCache
74fdCache :: MutableFdCache -> IO FdCache
91−fdCache (MutableFdCache reaper) = reaperRead reaper
75+fdCache mfc = reaperRead mfc
92
76
93−look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)
77+look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)
94−look mfc path = MM.lookup path <$> fdCache mfc
78+look mfc path key = searchWith key check <$> fdCache mfc
79+ where
80+ check (One ent@(FdEntry path' _ _))
81+ | path == path' = Just ent
82+ | otherwise = Nothing
83+ check (Tom ent@(FdEntry path' _ _) vs)
84+ | path == path' = Just ent
85+ | otherwise = check vs
86+
87+----------------------------------------------------------------
88+
89+-- | Creating 'MutableFdCache' and executing the action in the second
90+-- argument. The first argument is a cache duration in second.
91+withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a
92+withFdCache duration action = bracket (initialize duration)
93+ terminate
94+ action
95
95
96----------------------------------------------------------------
96----------------------------------------------------------------
97
97
98-- The first argument is a cache duration in second.
98-- The first argument is a cache duration in second.
99−initialize :: Int -> IO MutableFdCache
99+initialize :: Int -> IO (Maybe MutableFdCache)
100+initialize 0 = return Nothing
100−initialize duration = MutableFdCache <$> mkReaper settings
101+initialize duration = Just <$> mkReaper defaultReaperSettings
101− where
102− settings = defaultReaperSettings {
103− reaperAction = clean
102+ { reaperAction = clean
104− , reaperDelay = duration
103+ , reaperDelay = duration
105− , reaperCons = uncurry insert
104+ , reaperCons = uncurry insert
106− , reaperNull = isEmpty
105+ , reaperNull = isEmpty
107− , reaperEmpty = empty
106+ , reaperEmpty = empty
108− }
107+ }
109
108
110clean :: FdCache -> IO (FdCache -> FdCache)
109clean :: FdCache -> IO (FdCache -> FdCache)
111clean old = do
110clean old = do
112 new <- pruneWith old prune
111 new <- pruneWith old prune
113 return $ merge new
112 return $ merge new
113+
114+prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]
115+prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'
116+ where
117+ prune' Active = inactive mst >> return [(k,v)]
118+ prune' Inactive = closeFd fd >> return []
119+prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'
114 where
120 where
115− prune (_,FdEntry fd mst) = status mst >>= act
121+ prune' Active = do
116− where
117− act Active = inactive mst >> return True
122+ inactive mst
123+ zs <- prune k vs
124+ case zs of
125+ [] -> return [(k,One ent)]
126+ [(_,zvs)] -> return [(k,Tom ent zvs)]
127+ _ -> error "prune"
118− act Inactive = closeFd fd >> return False
128+ prune' Inactive = closeFd fd >> prune k vs
119
129
120----------------------------------------------------------------
130----------------------------------------------------------------
121
131
122−terminate :: MutableFdCache -> IO ()
132+terminate :: Maybe MutableFdCache -> IO ()
123−terminate (MutableFdCache reaper) = do
133+terminate Nothing = return ()
134+terminate (Just mfc) = do
124− !t <- reaperStop reaper
135+ !t <- reaperStop mfc
125− mapM_ (closeIt . snd) $ toList t
136+ mapM_ closeIt $ toList t
126 where
137 where
127− closeIt (FdEntry fd _) = closeFd fd
138+ closeIt (_, FdEntry _ fd _) = closeFd fd
128
139
129----------------------------------------------------------------
140----------------------------------------------------------------
130
141
131-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
142-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
132−getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)
143+getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)
133−getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get
144+getFd mfc path = look mfc path key >>= getFd'
134 where
145 where
146+ key = hash path
135− get Nothing = do
147+ getFd' Nothing = do
136− ent@(FdEntry fd mst) <- newFdEntry path
148+ ent@(FdEntry _ fd mst) <- newFdEntry path
137− reaperAdd reaper (path,ent)
149+ reaperAdd mfc (key, ent)
138− return (Just fd, refresh mst)
150+ return (fd, refresh mst)
139− get (Just (FdEntry fd mst)) = do
151+ getFd' (Just (FdEntry _ fd mst)) = do
140 refresh mst
152 refresh mst
141− return (Just fd, refresh mst)
153+ return (fd, refresh mst)
142#endif
154#endif
warp/Network/Wai/Handler/Warp/File.hsdeleted−152
@@ -1,152 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE BangPatterns #-}
4−
5−module Network.Wai.Handler.Warp.File (
6− RspFileInfo(..)
7− , conditionalRequest
8− , addContentHeadersForFilePart
9− , H.parseByteRanges
10− ) where
11−
12−import Data.Array ((!))
13−import qualified Data.ByteString.Char8 as C8 (pack)
14−import Network.HTTP.Date
15−import qualified Network.HTTP.Types as H
16−import qualified Network.HTTP.Types.Header as H
17−import Network.Wai
18−
19−import qualified Network.Wai.Handler.Warp.FileInfoCache as I
20−import Network.Wai.Handler.Warp.Header
21−import Network.Wai.Handler.Warp.Imports
22−import Network.Wai.Handler.Warp.PackInt
23−
24−
25−-- $setup
26−-- >>> import Test.QuickCheck
27−
28−----------------------------------------------------------------
29−
30−data RspFileInfo = WithoutBody H.Status
31− | WithBody H.Status H.ResponseHeaders Integer Integer
32− deriving (Eq,Show)
33−
34−----------------------------------------------------------------
35−
36−conditionalRequest :: I.FileInfo
37− -> H.ResponseHeaders
38− -> IndexedHeader -- ^ Response
39− -> IndexedHeader -- ^ Request
40− -> RspFileInfo
41−conditionalRequest finfo hs0 rspidx reqidx = case condition of
42− 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
46− in WithBody s hs off len
47− where
48− !mtime = I.fileInfoTime finfo
49− !size = I.fileInfoSize finfo
50− !date = I.fileInfoDate finfo
51− !mcondition = ifmodified reqidx size mtime
52− <|> ifunmodified reqidx size mtime
53− <|> ifrange reqidx size mtime
54− !condition = fromMaybe (unconditional reqidx size) mcondition
55−
56−----------------------------------------------------------------
57−
58−ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
59−ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate
60−
61−ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
62−ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate
63−
64−ifRange :: IndexedHeader -> Maybe HTTPDate
65−ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate
66−
67−----------------------------------------------------------------
68−
69−ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
70−ifmodified reqidx size mtime = do
71− date <- ifModifiedSince reqidx
72− return $ if date /= mtime
73− then unconditional reqidx size
74− else WithoutBody H.notModified304
75−
76−ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
77−ifunmodified reqidx size mtime = do
78− date <- ifUnmodifiedSince reqidx
79− return $ if date == mtime
80− then unconditional reqidx size
81− else WithoutBody H.preconditionFailed412
82−
83−ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
84−ifrange reqidx size mtime = do
85− date <- ifRange reqidx
86− rng <- reqidx ! fromEnum ReqRange
87− return $ if date == mtime
88− then parseRange rng size
89− else WithBody H.ok200 [] 0 size
90−
91−unconditional :: IndexedHeader -> Integer -> RspFileInfo
92−unconditional reqidx size = case reqidx ! fromEnum ReqRange of
93− Nothing -> WithBody H.ok200 [] 0 size
94− Just rng -> parseRange rng size
95−
96−----------------------------------------------------------------
97−
98−parseRange :: ByteString -> Integer -> RspFileInfo
99−parseRange rng size = case H.parseByteRanges rng of
100− Nothing -> WithoutBody H.requestedRangeNotSatisfiable416
101− Just [] -> WithoutBody H.requestedRangeNotSatisfiable416
102− Just (r:_) -> let (!beg, !end) = checkRange r size
103− !len = end - beg + 1
104− s = if beg == 0 && end == size - 1 then
105− H.ok200
106− else
107− H.partialContent206
108− in WithBody s [] beg len
109−
110−checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
111−checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
112−checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
113−checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
114−
115−----------------------------------------------------------------
116−
117−-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
118−-- for the range specified.
119−contentRangeHeader :: Integer -> Integer -> Integer -> H.Header
120−contentRangeHeader beg end total = (H.hContentRange, range)
121− where
122− range = C8.pack
123− -- building with ShowS
124− $ 'b' : 'y': 't' : 'e' : 's' : ' '
125− : (if beg > end then ('*':) else
126− showInt beg
127− . ('-' :)
128− . showInt end)
129− ( '/'
130− : showInt total "")
131−
132−addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders
133−addContentHeaders hs off len size
134− | len == size = hs'
135− | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size
136− in ctrng:hs'
137− where
138− !lengthBS = packIntegral len
139− !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges,"bytes") : hs
140−
141−-- |
142−--
143−-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
144−-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]
145−-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
146−-- [("Content-Length","16"),("Accept-Ranges","bytes")]
147−addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders
148−addContentHeadersForFilePart hs part = addContentHeaders hs off len size
149− where
150− off = filePartOffset part
151− len = filePartByteCount part
152− size = filePartFileSize part
warp/Network/Wai/Handler/Warp/FileInfoCache.hsdeleted−108
@@ -1,108 +0,0 @@
1−{-# LANGUAGE RecordWildCards, CPP #-}
2−
3−module Network.Wai.Handler.Warp.FileInfoCache (
4− FileInfo(..)
5− , withFileInfoCache
6− , getInfo -- test purpose only
7− ) where
8−
9−import Control.Exception as E
10−import Control.Reaper
11−import Network.HTTP.Date
12−import System.PosixCompat.Files
13−
14−import Network.Wai.Handler.Warp.HashMap (HashMap)
15−import qualified Network.Wai.Handler.Warp.HashMap as M
16−import Network.Wai.Handler.Warp.Imports
17−
18−----------------------------------------------------------------
19−
20−-- | File information.
21−data FileInfo = FileInfo {
22− fileInfoName :: !FilePath
23− , fileInfoSize :: !Integer
24− , fileInfoTime :: HTTPDate -- ^ Modification time
25− , fileInfoDate :: ByteString -- ^ Modification time in the GMT format
26− } deriving (Eq, Show)
27−
28−data Entry = Negative | Positive FileInfo
29−type Cache = HashMap Entry
30−type FileInfoCache = Reaper Cache (FilePath,Entry)
31−
32−----------------------------------------------------------------
33−
34−-- | Getting the file information corresponding to the file.
35−getInfo :: FilePath -> IO FileInfo
36−getInfo path = do
37− fs <- getFileStatus path -- file access
38− let regular = not (isDirectory fs)
39− readable = fileMode fs `intersectFileModes` ownerReadMode /= 0
40− if regular && readable then do
41− let time = epochTimeToHTTPDate $ modificationTime fs
42− date = formatHTTPDate time
43− size = fromIntegral $ fileSize fs
44− info = FileInfo {
45− fileInfoName = path
46− , fileInfoSize = size
47− , fileInfoTime = time
48− , fileInfoDate = date
49− }
50− return info
51− else
52− throwIO (userError "FileInfoCache:getInfo")
53−
54−getInfoNaive :: FilePath -> IO FileInfo
55−getInfoNaive = getInfo
56−
57−----------------------------------------------------------------
58−
59−getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo
60−getAndRegisterInfo reaper@Reaper{..} path = do
61− cache <- reaperRead
62− case M.lookup path cache of
63− Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")
64− Just (Positive x) -> return x
65− Nothing -> positive reaper path
66− `E.onException` negative reaper path
67−
68−positive :: FileInfoCache -> FilePath -> IO FileInfo
69−positive Reaper{..} path = do
70− info <- getInfo path
71− reaperAdd (path, Positive info)
72− return info
73−
74−negative :: FileInfoCache -> FilePath -> IO FileInfo
75−negative Reaper{..} path = do
76− reaperAdd (path, Negative)
77− throwIO (userError "FileInfoCache:negative")
78−
79−----------------------------------------------------------------
80−
81−-- | Creating a file information cache
82−-- and executing the action in the second argument.
83−-- The first argument is a cache duration in second.
84−withFileInfoCache :: Int
85− -> ((FilePath -> IO FileInfo) -> IO a)
86− -> IO a
87−withFileInfoCache 0 action = action getInfoNaive
88−withFileInfoCache duration action =
89− E.bracket (initialize duration)
90− terminate
91− (action . getAndRegisterInfo)
92−
93−initialize :: Int -> IO FileInfoCache
94−initialize duration = mkReaper settings
95− where
96− settings = defaultReaperSettings {
97− reaperAction = override
98− , reaperDelay = duration
99− , reaperCons = \(path,v) -> M.insert path v
100− , reaperNull = M.isEmpty
101− , reaperEmpty = M.empty
102− }
103−
104−override :: Cache -> IO (Cache -> Cache)
105−override _ = return $ const M.empty
106−
107−terminate :: FileInfoCache -> IO ()
108−terminate x = void $ reaperStop x
warp/Network/Wai/Handler/Warp/HTTP2.hsdeleted−85
@@ -1,85 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE PatternGuards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−
7−module Network.Wai.Handler.Warp.HTTP2 (http2) where
8−
9−import qualified Data.IORef as I
10−import qualified Control.Exception as E
11−import qualified Network.HTTP2.Server as H2
12−import Network.Socket (SockAddr)
13−import Network.Wai
14−import Network.Wai.Internal (ResponseReceived(..))
15−import qualified System.TimeManager as T
16−
17−import Network.Wai.Handler.Warp.HTTP2.File
18−import Network.Wai.Handler.Warp.HTTP2.PushPromise
19−import Network.Wai.Handler.Warp.HTTP2.Request
20−import Network.Wai.Handler.Warp.HTTP2.Response
21−import Network.Wai.Handler.Warp.Imports
22−import qualified Network.Wai.Handler.Warp.Settings as S
23−import Network.Wai.Handler.Warp.Types
24−
25−----------------------------------------------------------------
26−
27−http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> (ByteString -> IO ()) -> Application -> IO ()
28−http2 conn transport ii addr settings readN send app =
29− H2.run conf http2server
30− where
31− conf = H2.Config {
32− confWriteBuffer = connWriteBuffer conn
33− , confBufferSize = connBufferSize conn
34− , confSendAll = send
35− , confReadN = readN
36− , confPositionReadMaker = pReadMaker ii
37− }
38−
39− http2server h2req aux response = do
40− req <- toWAIRequest h2req aux
41− ref <- I.newIORef Nothing
42− eResponseReceived <- E.try $ app req $ \rsp -> do
43− h2rsp <- fromResponse settings ii req rsp
44− pps <- fromPushPromises ii req
45− I.writeIORef ref $ Just (h2rsp, pps)
46− _ <- response h2rsp pps
47− return ResponseReceived
48− case eResponseReceived of
49− Right ResponseReceived -> do
50− Just (h2rsp, pps) <- I.readIORef ref
51− logResponse h2rsp req
52− mapM_ (logPushPromise req) pps
53− Left e@(E.SomeException _)
54− -- killed by the local worker manager
55− | Just E.ThreadKilled <- E.fromException e -> return ()
56− -- killed by the local timeout manager
57− | Just T.TimeoutThread <- E.fromException e -> return ()
58− | otherwise -> do
59− S.settingsOnException settings (Just req) e
60− let ersp = S.settingsOnExceptionResponse settings e
61− h2rsp' <- fromResponse settings ii req ersp
62− _ <- response h2rsp' []
63− logResponse h2rsp' req
64− return ()
65−
66− toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport
67− where
68− !hdr = H2.requestHeaders h2req
69− !bdy = H2.getRequestBodyChunk h2req
70− !bdylen = H2.requestBodySize h2req
71− !th = H2.auxTimeHandle aux
72−
73− logResponse h2rsp req = logger req st msiz
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/File.hsdeleted−30
@@ -1,30 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Network.Wai.Handler.Warp.HTTP2.File where
4−
5−import Network.HTTP2.Server
6−
7−import Network.Wai.Handler.Warp.Types
8−
9−#ifdef WINDOWS
10−pReadMaker :: InternalInfo -> PositionReadMaker
11−pReadMaker _ = defaultPositionReadMaker
12−#else
13−import Network.Wai.Handler.Warp.FdCache
14−import Network.Wai.Handler.Warp.SendFile (positionRead)
15−
16−pReadMaker :: InternalInfo -> PositionReadMaker
17−pReadMaker ii path = do
18− (mfd, refresh) <- getFd ii path
19− case mfd of
20− Just fd -> return (pread fd, Refresher refresh)
21− Nothing -> do
22− fd <- openFile path
23− return (pread fd, Closer $ closeFile fd)
24− where
25− pread :: Fd -> PositionRead
26− pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'
27− where
28− bytes' = fromIntegral bytes
29− off' = fromIntegral off
30−#endif
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/Request.hsdeleted−126
@@ -1,126 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−module Network.Wai.Handler.Warp.HTTP2.Request (
4− toRequest
5− , getHTTP2Data
6− , setHTTP2Data
7− , modifyHTTP2Data
8− ) where
9−
10−import Control.Arrow (first)
11−import qualified Data.ByteString.Char8 as C8
12−import Data.IORef
13−import qualified Data.Vault.Lazy as Vault
14−import Network.HPACK
15−import Network.HPACK.Token
16−import qualified Network.HTTP.Types as H
17−import Network.Socket (SockAddr)
18−import Network.Wai
19−import Network.Wai.Internal (Request(..))
20−import System.IO.Unsafe (unsafePerformIO)
21−import qualified System.TimeManager as T
22−
23−import Network.Wai.Handler.Warp.HTTP2.Types
24−import Network.Wai.Handler.Warp.Imports
25−import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey, getClientCertificateKey)
26−import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
27−import Network.Wai.Handler.Warp.Types
28−
29−type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request
30−
31−----------------------------------------------------------------
32−
33−toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq
34−toRequest ii settings addr ht bodylen body th transport = do
35− ref <- newIORef Nothing
36− toRequest' ii settings addr ref ht bodylen body th transport
37−
38−toRequest' :: InternalInfo -> S.Settings -> SockAddr
39− -> IORef (Maybe HTTP2Data)
40− -> ToReq
41−toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req
42− where
43− !req = Request {
44− requestMethod = colonMethod
45− , httpVersion = H.http20
46− , rawPathInfo = rawPath
47− , pathInfo = H.decodePathSegments path
48− , rawQueryString = query
49− , queryString = H.parseQuery query
50− , requestHeaders = headers
51− , isSecure = isTransportSecure transport
52− , remoteHost = addr
53− , requestBody = body
54− , vault = vaultValue
55− , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen
56− , requestHeaderHost = mHost <|> mAuth
57− , requestHeaderRange = mRange
58− , requestHeaderReferer = mReferer
59− , requestHeaderUserAgent = mUserAgent
60− }
61− headers = map (first tokenKey) ths
62− where
63− ths = case mHost of
64− Just _ -> reqths
65− Nothing -> case mAuth of
66− Just auth -> (tokenHost, auth) : reqths
67− _ -> reqths
68− !mPath = getHeaderValue tokenPath reqvt -- SHOULD
69− !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST
70− !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD
71− !mHost = getHeaderValue tokenHost reqvt
72− !mRange = getHeaderValue tokenRange reqvt
73− !mReferer = getHeaderValue tokenReferer reqvt
74− !mUserAgent = getHeaderValue tokenUserAgent reqvt
75− -- CONNECT request will have ":path" omitted, use ":authority" as unparsed
76− -- path instead so that it will have consistent behavior compare to HTTP 1.0
77− (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)
78− !path = H.extractPath unparsedPath
79− !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
80− -- fixme: pauseTimeout. th is not available here.
81− !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)
82− $ Vault.insert getHTTP2DataKey (readIORef ref)
83− $ Vault.insert setHTTP2DataKey (writeIORef ref)
84− $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)
85− $ Vault.insert pauseTimeoutKey (T.pause th)
86− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)
87− Vault.empty
88−
89−getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))
90−getHTTP2DataKey = unsafePerformIO Vault.newKey
91−{-# NOINLINE getHTTP2DataKey #-}
92−
93−-- | Getting 'HTTP2Data' through vault of the request.
94−-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.
95−--
96−-- Since: 3.2.7
97−getHTTP2Data :: Request -> IO (Maybe HTTP2Data)
98−getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of
99− Nothing -> return Nothing
100− Just getter -> getter
101−
102−setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())
103−setHTTP2DataKey = unsafePerformIO Vault.newKey
104−{-# NOINLINE setHTTP2DataKey #-}
105−
106−-- | Setting 'HTTP2Data' through vault of the request.
107−-- 'Application' or 'Middleware' should use this.
108−--
109−-- Since: 3.2.7
110−setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()
111−setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of
112− Nothing -> return ()
113− Just setter -> setter mh2d
114−
115−modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())
116−modifyHTTP2DataKey = unsafePerformIO Vault.newKey
117−{-# NOINLINE modifyHTTP2DataKey #-}
118−
119−-- | Modifying 'HTTP2Data' through vault of the request.
120−-- 'Application' or 'Middleware' should use this.
121−--
122−-- Since: 3.2.8
123−modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()
124−modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of
125− Nothing -> return ()
126− Just modify -> modify func
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/Types.hsdeleted−81
@@ -1,81 +0,0 @@
1−{-# LANGUAGE NamedFieldPuns #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
4−
5−module Network.Wai.Handler.Warp.HTTP2.Types where
6−
7−import qualified Data.ByteString as BS
8−import qualified Network.HTTP.Types as H
9−import Network.HTTP2
10−import qualified Network.HTTP2.Server as H2
11−
12−import Network.Wai.Handler.Warp.Imports
13−import Network.Wai.Handler.Warp.Types
14−
15−----------------------------------------------------------------
16−
17−isHTTP2 :: Transport -> Bool
18−isHTTP2 TCP = False
19−isHTTP2 tls = useHTTP2
20− where
21− useHTTP2 = case tlsNegotiatedProtocol tls of
22− Nothing -> False
23− Just proto -> "h2" `BS.isPrefixOf` proto
24−
25−----------------------------------------------------------------
26−
27−-- | HTTP/2 specific data.
28−--
29−-- Since: 3.2.7
30−data HTTP2Data = HTTP2Data {
31− -- | Accessor for 'PushPromise' in 'HTTP2Data'.
32− --
33− -- Since: 3.2.7
34− http2dataPushPromise :: [PushPromise]
35− -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.
36− --
37− -- Since: 3.2.8 but the type changed in 3.3.0
38− , http2dataTrailers :: H2.TrailersMaker
39− }
40−
41−-- | Default HTTP/2 specific data.
42−--
43−-- Since: 3.2.7
44−defaultHTTP2Data :: HTTP2Data
45−defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker
46−
47−-- | HTTP/2 push promise or sever push.
48−-- This allows files only for backward-compatibility
49−-- while the HTTP/2 library supports other types.
50−--
51−-- Since: 3.2.7
52−data PushPromise = PushPromise {
53− -- | Accessor for a URL path in 'PushPromise'.
54− -- E.g. \"\/style\/default.css\".
55− --
56− -- Since: 3.2.7
57− promisedPath :: ByteString
58− -- | Accessor for 'FilePath' in 'PushPromise'.
59− -- E.g. \"FILE_PATH/default.css\".
60− --
61− -- Since: 3.2.7
62− , promisedFile :: FilePath
63− -- | Accessor for 'H.ResponseHeaders' in 'PushPromise'
64− -- \"content-type\" must be specified.
65− -- Default value: [].
66− --
67− --
68− -- Since: 3.2.7
69− , promisedResponseHeaders :: H.ResponseHeaders
70− -- | Accessor for 'Weight' in 'PushPromise'.
71− -- Default value: 16.
72− --
73− -- Since: 3.2.7
74− , promisedWeight :: Weight
75− } deriving (Eq,Ord,Show)
76−
77−-- | Default push promise.
78−--
79−-- Since: 3.2.7
80−defaultPushPromise :: PushPromise
81−defaultPushPromise = PushPromise "" "" [] 16
warp/Network/Wai/Handler/Warp/HashMap.hsdeleted−42
@@ -1,42 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−module Network.Wai.Handler.Warp.HashMap where
4−
5−import Data.Hashable (hash)
6−import Data.IntMap.Strict (IntMap)
7−import qualified Data.IntMap.Strict as I
8−import Data.Map.Strict (Map)
9−import qualified Data.Map.Strict as M
10−import Prelude hiding (lookup)
11−
12−----------------------------------------------------------------
13−
14−-- | 'HashMap' is used for cache of file information.
15−-- Hash values of file pathes are used as outer keys.
16−-- Because negative entries are also contained,
17−-- a bad guy can intentionally cause the hash collison.
18−-- So, 'Map' is used internally to prevent
19−-- the hash collision attack.
20−newtype HashMap v = HashMap (IntMap (Map FilePath v))
21−
22−----------------------------------------------------------------
23−
24−empty :: HashMap v
25−empty = HashMap I.empty
26−
27−isEmpty :: HashMap v -> Bool
28−isEmpty (HashMap hm) = I.null hm
29−
30−----------------------------------------------------------------
31−
32−insert :: FilePath -> v -> HashMap v -> HashMap v
33−insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm
34− where
35− !h = hash path
36− !m = M.singleton path v
37− f = M.union -- fimxe
38−
39−lookup :: FilePath -> HashMap v -> Maybe v
40−lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path
41− where
42− !h = hash path
warp/Network/Wai/Handler/Warp/Header.hs+26−48
@@ -4,10 +4,7 @@ module Network.Wai.Handler.Warp.Header where
4
4
5import Data.Array
5import Data.Array
6import Data.Array.ST
6import Data.Array.ST
7−import qualified Data.ByteString as BS
8−import Data.CaseInsensitive (foldedCase)
9import Network.HTTP.Types
7import Network.HTTP.Types
10−
11import Network.Wai.Handler.Warp.Types
8import Network.Wai.Handler.Warp.Types
12
9
13----------------------------------------------------------------
10----------------------------------------------------------------
@@ -20,43 +17,29 @@ type IndexedHeader = Array Int (Maybe HeaderValue)
20indexRequestHeader :: RequestHeaders -> IndexedHeader
17indexRequestHeader :: RequestHeaders -> IndexedHeader
21indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex
18indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex
22
19
23−data RequestHeaderIndex = ReqContentLength
20+idxContentLength,idxTransferEncoding,idxExpect :: Int
24− | ReqTransferEncoding
21+idxConnection,idxRange,idxHost :: Int
25− | ReqExpect
22+idxContentLength = 0
26− | ReqConnection
23+idxTransferEncoding = 1
27− | ReqRange
24+idxExpect = 2
28− | ReqHost
25+idxConnection = 3
29− | ReqIfModifiedSince
26+idxRange = 4
30− | ReqIfUnmodifiedSince
27+idxHost = 5
31− | ReqIfRange
32− | ReqReferer
33− | ReqUserAgent
34− deriving (Enum,Bounded)
35
28
36-- | The size for 'IndexedHeader' for HTTP Request.
29-- | The size for 'IndexedHeader' for HTTP Request.
37-- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",
30-- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",
38−-- \"Expect\", \"Connection\", \"Range\", \"Host\",
31+-- \"Expect\", \"Connection\", \"Range\", and \"Host\".
39−-- \"If-Modified-Since\", \"If-Unmodified-Since\" and \"If-Range\".
40requestMaxIndex :: Int
32requestMaxIndex :: Int
41−requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex)
33+requestMaxIndex = 5
42
34
43requestKeyIndex :: HeaderName -> Int
35requestKeyIndex :: HeaderName -> Int
44−requestKeyIndex hn = case BS.length bs of
36+requestKeyIndex "content-length" = idxContentLength
45− 4 -> if bs == "host" then fromEnum ReqHost else -1
37+requestKeyIndex "transfer-encoding" = idxTransferEncoding
46− 5 -> if bs == "range" then fromEnum ReqRange else -1
38+requestKeyIndex "expect" = idxExpect
47− 6 -> if bs == "expect" then fromEnum ReqExpect else -1
39+requestKeyIndex "connection" = idxConnection
48− 7 -> if bs == "referer" then fromEnum ReqReferer else -1
40+requestKeyIndex "range" = idxRange
49− 8 -> if bs == "if-range" then fromEnum ReqIfRange else -1
41+requestKeyIndex "host" = idxHost
50− 10 -> if bs == "user-agent" then fromEnum ReqUserAgent else
42+requestKeyIndex _ = -1
51− if bs == "connection" then fromEnum ReqConnection else -1
52− 14 -> if bs == "content-length" then fromEnum ReqContentLength else -1
53− 17 -> if bs == "transfer-encoding" then fromEnum ReqTransferEncoding else
54− if bs == "if-modified-since" then fromEnum ReqIfModifiedSince
55− else -1
56− 19 -> if bs == "if-unmodified-since" then fromEnum ReqIfUnmodifiedSince else -1
57− _ -> -1
58− where
59− bs = foldedCase hn
60
43
61defaultIndexRequestHeader :: IndexedHeader
44defaultIndexRequestHeader :: IndexedHeader
62defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]
45defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]
@@ -66,25 +49,20 @@ defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..reques
66indexResponseHeader :: ResponseHeaders -> IndexedHeader
49indexResponseHeader :: ResponseHeaders -> IndexedHeader
67indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex
50indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex
68
51
69−data ResponseHeaderIndex = ResContentLength
52+idxServer, idxDate :: Int
70− | ResServer
53+--idxContentLength = 0
71− | ResDate
54+idxServer = 1
72− | ResLastModified
55+idxDate = 2
73− deriving (Enum,Bounded)
74
56
75-- | The size for 'IndexedHeader' for HTTP Response.
57-- | The size for 'IndexedHeader' for HTTP Response.
76responseMaxIndex :: Int
58responseMaxIndex :: Int
77−responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex)
59+responseMaxIndex = 2
78
60
79responseKeyIndex :: HeaderName -> Int
61responseKeyIndex :: HeaderName -> Int
80−responseKeyIndex hn = case BS.length bs of
62+responseKeyIndex "content-length" = idxContentLength
81− 4 -> if bs == "date" then fromEnum ResDate else -1
63+responseKeyIndex "server" = idxServer
82− 6 -> if bs == "server" then fromEnum ResServer else -1
64+responseKeyIndex "date" = idxDate
83− 13 -> if bs == "last-modified" then fromEnum ResLastModified else -1
65+responseKeyIndex _ = -1
84− 14 -> if bs == "content-length" then fromEnum ResContentLength else -1
85− _ -> -1
86− where
87− bs = foldedCase hn
88
66
89----------------------------------------------------------------
67----------------------------------------------------------------
90
68
warp/Network/Wai/Handler/Warp/IO.hs+40−5
@@ -3,18 +3,25 @@
3
3
4module Network.Wai.Handler.Warp.IO where
4module Network.Wai.Handler.Warp.IO where
5
5
6−import Data.ByteString.Builder (Builder)
6+import Data.ByteString (ByteString)
7−import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))
8−
9import Network.Wai.Handler.Warp.Buffer
7import Network.Wai.Handler.Warp.Buffer
10−import Network.Wai.Handler.Warp.Imports
11import Network.Wai.Handler.Warp.Types
8import Network.Wai.Handler.Warp.Types
12
9
10+-- Support for doctest, where cabal macros are not available
11+#ifndef MIN_VERSION_blaze_builder
12+#define MIN_VERSION_blaze_builder(x, y, z) 1
13+#endif
14+
15+#if MIN_VERSION_blaze_builder(0,4,0)
16+
17+import Blaze.ByteString.Builder (Builder)
18+import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))
19+
13toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()
20toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()
14toBufIOWith buf !size io builder = loop firstWriter
21toBufIOWith buf !size io builder = loop firstWriter
15 where
22 where
16 firstWriter = runBuilder builder
23 firstWriter = runBuilder builder
17− runIO len = bufferIO buf len io
24+ runIO len = toBS buf len >>= io
18 loop writer = do
25 loop writer = do
19 (len, signal) <- writer buf size
26 (len, signal) <- writer buf size
20 case signal of
27 case signal of
@@ -28,3 +35,31 @@ toBufIOWith buf !size io builder = loop firstWriter
28 runIO len
35 runIO len
29 io bs
36 io bs
30 loop next
37 loop next
38+
39+#else /* !MIN_VERSION_blaze_builder(0,4,0) */
40+
41+import Blaze.ByteString.Builder.Internal.Types (Builder(..), BuildSignal(..), BufRange(..), runBuildStep, buildStep)
42+import Foreign.Ptr (plusPtr, minusPtr)
43+
44+toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()
45+toBufIOWith buf !size io (Builder build) = loop firstStep
46+ where
47+ firstStep = build (buildStep finalStep)
48+ finalStep (BufRange p _) = return $ Done p ()
49+ bufRange = BufRange buf (buf `plusPtr` size)
50+ runIO ptr = toBS buf (ptr `minusPtr` buf) >>= io
51+ loop step = do
52+ signal <- runBuildStep step bufRange
53+ case signal of
54+ Done ptr _ -> runIO ptr
55+ BufferFull minSize ptr next
56+ | size < minSize -> error "toBufIOWith: BufferFull: minSize"
57+ | otherwise -> do
58+ runIO ptr
59+ loop next
60+ InsertByteString ptr bs next -> do
61+ runIO ptr
62+ io bs
63+ loop next
64+
65+#endif /* !MIN_VERSION_blaze_builder(0,4,0) */
warp/Network/Wai/Handler/Warp/IORef.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# LANGUAGE CPP #-}
2+
3+#ifndef MIN_VERSION_base
4+#define MIN_VERSION_base(x,y,z) 1
5+#endif
6+
7+module Network.Wai.Handler.Warp.IORef (
8+ module Data.IORef
9+#if !MIN_VERSION_base(4,6,0)
10+ , atomicModifyIORef'
11+#endif
12+ ) where
13+
14+import Data.IORef
15+
16+#if !MIN_VERSION_base(4,6,0)
17+-- | Strict version of 'atomicModifyIORef'. This forces both the value stored
18+-- in the 'IORef' as well as the value returned.
19+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
20+atomicModifyIORef' ref f = do
21+ c <- atomicModifyIORef ref
22+ (\x -> let (a, b) = f x -- Lazy application of "f"
23+ in (a, a `seq` b)) -- Lazy application of "seq"
24+ -- The following forces "a `seq` b", so it also forces "f x".
25+ c `seq` return c
26+#endif
warp/Network/Wai/Handler/Warp/Imports.hsdeleted−27
@@ -1,27 +0,0 @@
1−module Network.Wai.Handler.Warp.Imports (
2− ByteString(..)
3− , NonEmpty(..)
4− , module Control.Applicative
5− , module Control.Monad
6− , module Data.Bits
7− , module Data.List
8− , module Data.Int
9− , module Data.Monoid
10− , module Data.Ord
11− , module Data.Word
12− , module Data.Maybe
13− , module Numeric
14− ) where
15−
16−import Control.Applicative
17−import Control.Monad
18−import Data.Bits
19−import Data.ByteString.Internal (ByteString(..))
20−import Data.Int
21−import Data.List
22−import Data.List.NonEmpty (NonEmpty(..))
23−import Data.Maybe
24−import Data.Monoid
25−import Data.Ord
26−import Data.Word
27−import Numeric
warp/Network/Wai/Handler/Warp/Internal.hs+20−19
@@ -3,7 +3,10 @@
3module Network.Wai.Handler.Warp.Internal (
3module Network.Wai.Handler.Warp.Internal (
4 -- * Settings
4 -- * Settings
5 Settings (..)
5 Settings (..)
6− , ProxyProtocol(..)
6+ -- ** Getters
7+ , getOnOpen
8+ , getOnClose
9+ , getOnException
7 -- * Low level run functions
10 -- * Low level run functions
8 , runSettingsConnection
11 , runSettingsConnection
9 , runSettingsConnectionMaker
12 , runSettingsConnectionMaker
@@ -12,17 +15,12 @@ module Network.Wai.Handler.Warp.Internal (
12 -- * Connection
15 -- * Connection
13 , Connection (..)
16 , Connection (..)
14 , socketConnection
17 , socketConnection
15− -- ** Receive
16− , Recv
17− , RecvBuf
18− , makePlainReceiveN
19 -- ** Buffer
18 -- ** Buffer
20 , Buffer
19 , Buffer
21 , BufSize
20 , BufSize
22 , bufferSize
21 , bufferSize
23 , allocateBuffer
22 , allocateBuffer
24 , freeBuffer
23 , freeBuffer
25− , copy
26 -- ** Sendfile
24 -- ** Sendfile
27 , FileId (..)
25 , FileId (..)
28 , SendFile
26 , SendFile
@@ -45,42 +43,45 @@ module Network.Wai.Handler.Warp.Internal (
45 --
43 --
46 -- * When all request headers are read, the timeout is tickled.
44 -- * When all request headers are read, the timeout is tickled.
47 --
45 --
48− -- * Every time at least the slowloris size settings number of bytes of the request
46+ -- * Every time at least 2048 bytes of the request body are read, the timeout
49− -- body are read, the timeout is tickled.
47+ -- is tickled.
50 --
48 --
51 -- * The timeout is paused while executing user code. This will apply to both
49 -- * The timeout is paused while executing user code. This will apply to both
52 -- the application itself, and a ResponseSource response. The timeout is
50 -- the application itself, and a ResponseSource response. The timeout is
53 -- resumed as soon as we return from user code.
51 -- resumed as soon as we return from user code.
54 --
52 --
55 -- * Every time data is successfully sent to the client, the timeout is tickled.
53 -- * Every time data is successfully sent to the client, the timeout is tickled.
56− , module System.TimeManager
54+ , module Network.Wai.Handler.Warp.Timeout
57 -- * File descriptor cache
55 -- * File descriptor cache
58 , module Network.Wai.Handler.Warp.FdCache
56 , module Network.Wai.Handler.Warp.FdCache
59− -- * File information cache
60− , module Network.Wai.Handler.Warp.FileInfoCache
61 -- * Date
57 -- * Date
62 , module Network.Wai.Handler.Warp.Date
58 , module Network.Wai.Handler.Warp.Date
63 -- * Request and response
59 -- * Request and response
64 , Source
60 , Source
65 , recvRequest
61 , recvRequest
66 , sendResponse
62 , sendResponse
67− -- * Platform dependent helper functions
68− , setSocketCloseOnExec
69− , windowsThreadBlockHack
70 ) where
63 ) where
71
64
72−import System.TimeManager
65+import Control.Exception (SomeException)
73−
66+import Network.Socket (SockAddr)
67+import Network.Wai (Request)
74import Network.Wai.Handler.Warp.Buffer
68import Network.Wai.Handler.Warp.Buffer
75import Network.Wai.Handler.Warp.Date
69import Network.Wai.Handler.Warp.Date
76import Network.Wai.Handler.Warp.FdCache
70import Network.Wai.Handler.Warp.FdCache
77−import Network.Wai.Handler.Warp.FileInfoCache
78import Network.Wai.Handler.Warp.Header
71import Network.Wai.Handler.Warp.Header
79−import Network.Wai.Handler.Warp.Recv
80import Network.Wai.Handler.Warp.Request
72import Network.Wai.Handler.Warp.Request
81import Network.Wai.Handler.Warp.Response
73import Network.Wai.Handler.Warp.Response
82import Network.Wai.Handler.Warp.Run
74import Network.Wai.Handler.Warp.Run
83import Network.Wai.Handler.Warp.SendFile
75import Network.Wai.Handler.Warp.SendFile
84import Network.Wai.Handler.Warp.Settings
76import Network.Wai.Handler.Warp.Settings
77+import Network.Wai.Handler.Warp.Timeout
85import Network.Wai.Handler.Warp.Types
78import Network.Wai.Handler.Warp.Types
86−import Network.Wai.Handler.Warp.Windows
79+
80+getOnOpen :: Settings -> SockAddr -> IO Bool
81+getOnOpen = settingsOnOpen
82+
83+getOnClose :: Settings -> SockAddr -> IO ()
84+getOnClose = settingsOnClose
85+
86+getOnException :: Settings -> Maybe Request -> SomeException -> IO ()
87+getOnException = settingsOnException
warp/Network/Wai/Handler/Warp/MultiMap.hs+194−65
@@ -1,111 +1,240 @@
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+ , Some(..)
6 , empty
6 , empty
7 , singleton
7 , singleton
8 , insert
8 , insert
9− , Network.Wai.Handler.Warp.MultiMap.lookup
9+ , search
10+ , searchWith
11+ , isEmpty
12+ , valid
10 , pruneWith
13 , pruneWith
14+ , fromList
11 , toList
15 , toList
16+ , fromSortedList
17+ , toSortedList
12 , merge
18 , merge
13 ) where
19 ) where
14
20
15−import Data.Hashable (hash)
21+#if __GLASGOW_HASKELL__ < 709
16−import Data.IntMap.Strict (IntMap)
22+import Control.Applicative ((<$>))
17−import qualified Data.IntMap.Strict as I
23+#endif
18−import Data.Semigroup
24+import Data.List (foldl')
19−import Prelude -- Silence redundant import warnings
20
25
21----------------------------------------------------------------
26----------------------------------------------------------------
22
27
23−-- | 'MultiMap' is used for cache of file descriptors.
28+-- | One ore more list to implement multimap.
24−-- Since multiple threads would open file descriptors for
29+data Some a = One !a
25−-- the same file simultaneously, multiple entries must
30+ | Tom !a !(Some a) -- Two or more
26−-- be contained for the file.
31+ deriving (Eq,Show)
27−-- Since hash values of file pathes are used as outer keys,
32+
28−-- collison would happen for multiple file pathes.
33+-- This is slow but assuming rarely used.
29−-- Becase only positive entries are contained,
34+snoc :: Some a -> a -> Some a
30−-- a bad guy cannot be cause the hash collision intentinally.
35+snoc (One x) y = Tom x (One y)
31−-- So, lists are good enough.
36+snoc (Tom x xs) y = Tom x (snoc xs y)
32−newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])
37+
38+top :: Some a -> a
39+top (One x) = x
40+top (Tom x _) = x
41+
42+----------------------------------------------------------------
43+
44+-- | Red black tree as multimap.
45+data MMap k v = Leaf -- color is Black
46+ | Node Color !(MMap k v) !k !(Some v) !(MMap k v)
47+ deriving (Show)
48+
49+data Color = B -- ^ Black
50+ | R -- ^ Red
51+ deriving (Eq, Show)
52+
53+----------------------------------------------------------------
54+
55+instance (Eq k, Eq v) => Eq (MMap k v) where
56+ t1 == t2 = toSortedList t1 == toSortedList t2
57+
58+----------------------------------------------------------------
59+
60+-- | O(log N)
61+search :: Ord k => k -> MMap k v -> Maybe v
62+search _ Leaf = Nothing
63+search xk (Node _ l k v r) = case compare xk k of
64+ LT -> search xk l
65+ GT -> search xk r
66+ EQ -> Just $ top v
67+
68+-- | O(log N)
69+searchWith :: Ord k => k -> (Some v -> Maybe v) -> MMap k v -> Maybe v
70+searchWith _ _ Leaf = Nothing
71+searchWith xk f (Node _ l k v r) = case compare xk k of
72+ LT -> searchWith xk f l
73+ GT -> searchWith xk f r
74+ EQ -> f v
33
75
34----------------------------------------------------------------
76----------------------------------------------------------------
35
77
36-- | O(1)
78-- | O(1)
37−empty :: MultiMap v
79+isEmpty :: MMap k v -> Bool
38−empty = MultiMap $ I.empty
80+isEmpty Leaf = True
81+isEmpty _ = False
39
82
40-- | O(1)
83-- | O(1)
41−isEmpty :: MultiMap v -> Bool
84+empty :: MMap k v
42−isEmpty (MultiMap mm) = I.null mm
85+empty = Leaf
43
86
44----------------------------------------------------------------
87----------------------------------------------------------------
45
88
46-- | O(1)
89-- | O(1)
47−singleton :: FilePath -> v -> MultiMap v
90+singleton :: Ord k => k -> v -> MMap k v
48−singleton path v = MultiMap mm
91+singleton k v = Node B Leaf k (One v) Leaf
49− where
92+
50− !h = hash path
93+----------------------------------------------------------------
51− !mm = I.singleton h [(path,v)]
94+
95+-- | O(log N)
96+insert :: Ord k => k -> v -> MMap k v -> MMap k v
97+insert kx kv t = turnB (insert' kx kv t)
98+
99+insert' :: Ord k => k -> v -> MMap k v -> MMap k v
100+insert' xk xv Leaf = Node R Leaf xk (One xv) Leaf
101+insert' xk xv (Node B l k v r) = case compare xk k of
102+ LT -> balanceL' (insert' xk xv l) k v r
103+ GT -> balanceR' l k v (insert' xk xv r)
104+ EQ -> Node B l k (snoc v xv) r
105+insert' xk xv (Node R l k v r) = case compare xk k of
106+ LT -> Node R (insert' xk xv l) k v r
107+ GT -> Node R l k v (insert' xk xv r)
108+ EQ -> Node R l k (snoc v xv) r
109+
110+balanceL' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v
111+balanceL' (Node R (Node R a xk xv b) yk yv c) zk zv d =
112+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)
113+balanceL' (Node R a xk xv (Node R b yk yv c)) zk zv d =
114+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)
115+balanceL' l k v r = Node B l k v r
116+
117+balanceR' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v
118+balanceR' a xk xv (Node R b yk yv (Node R c zk zv d)) =
119+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)
120+balanceR' a xk xv (Node R (Node R b yk yv c) zk zv d) =
121+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)
122+balanceR' l xk xv r = Node B l xk xv r
123+
124+turnB :: MMap k v -> MMap k v
125+turnB Leaf = error "turnB"
126+turnB (Node _ l k v r) = Node B l k v r
52
127
53----------------------------------------------------------------
128----------------------------------------------------------------
54
129
130+-- | O(N log N)
131+fromList :: Ord k => [(k,v)] -> MMap k v
132+fromList = foldl' (\t (k,v) -> insert k v t) empty
133+
55-- | O(N)
134-- | O(N)
56−lookup :: FilePath -> MultiMap v -> Maybe v
135+toList :: MMap k v -> [(k,v)]
57−lookup path (MultiMap mm) = case I.lookup h mm of
136+toList t = inorder t []
58− Nothing -> Nothing
59− Just s -> Prelude.lookup path s
60 where
137 where
61− !h = hash path
138+ inorder Leaf xs = xs
139+ inorder (Node _ l k v r) xs = inorder l (pairs k v ++ inorder r xs)
140+ pairs k (One v) = [(k,v)]
141+ pairs k (Tom v vs) = (k,v) : pairs k vs
62
142
63----------------------------------------------------------------
143----------------------------------------------------------------
64
144
65−-- | O(log n)
145+-- | O(N)
66−insert :: FilePath -> v -> MultiMap v -> MultiMap v
146+-- "Constructing Red-Black Trees" by Ralf Hinze
67−insert path v (MultiMap mm) = MultiMap mm'
147+fromSortedList :: Ord k => [(k,Some v)] -> MMap k v
68− where
148+fromSortedList = linkAll . foldr add []
69− !h = hash path
149+
70− !mm' = I.insertWith (<>) h [(path,v)] mm
150+data Digit k v = Uno k (Some v) (MMap k v)
151+ | Due k (Some v) (MMap k v) k (Some v) (MMap k v)
152+ deriving (Eq,Show)
153+
154+incr :: Digit k v -> [Digit k v] -> [Digit k v]
155+incr (Uno k v t) [] = [Uno k v t]
156+incr (Uno k1 v1 t1) (Uno k2 v2 t2 : ps) = Due k1 v1 t1 k2 v2 t2 : ps
157+incr (Uno k1 v1 t1) (Due k2 v2 t2 k3 v3 t3 : ps) = Uno k1 v1 t1 : incr (Uno k2 v2 (Node B t2 k3 v3 t3)) ps
158+incr _ _ = error "incr"
159+
160+add :: (k,Some v) -> [Digit k v] -> [Digit k v]
161+add (k,v) ps = incr (Uno k v Leaf) ps
162+
163+linkAll :: [Digit k v] -> MMap k v
164+linkAll = foldl' link Leaf
165+
166+link :: MMap k v -> Digit k v -> MMap k v
167+link l (Uno k v t) = Node B l k v t
168+--link l (Due k1 v1 t1 k2 v2 t2) = Node B (Node R l k1 v1 t1) k2 v2 t2
169+link l (Due k1 v1 t1 k2 v2 t2) = Node B l k1 v1 (Node R t1 k2 v2 t2)
71
170
72----------------------------------------------------------------
171----------------------------------------------------------------
73
172
74−-- | O(n)
173+-- | O(N)
75−toList :: MultiMap v -> [(FilePath,v)]
174+toSortedList :: MMap k v -> [(k,Some v)]
76−toList (MultiMap mm) = concatMap snd $ I.toAscList mm
175+toSortedList t = inorder t []
176+ where
177+ inorder Leaf xs = xs
178+ inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs)
77
179
78----------------------------------------------------------------
180----------------------------------------------------------------
79
181
80−-- | O(n)
182+-- | O(N)
81−pruneWith :: MultiMap v
183+pruneWith :: Ord k =>
82− -> ((FilePath,v) -> IO Bool)
184+ MMap k v
83− -> IO (MultiMap v)
185+ -> (k -> Some v -> IO [(k, Some v)])
84−pruneWith (MultiMap mm) action = MultiMap <$> mm'
186+ -> IO (MMap k v)
187+pruneWith t run = fromSortedList <$> inorder t []
85 where
188 where
86− !mm' = I.fromAscList <$> go (I.toDescList mm) []
189+ inorder Leaf xs = return xs
87− go [] !acc = return acc
190+ inorder (Node _ l k v r) xs = do
88− go ((h,s):kss) !acc = do
191+ ys <- run k v
89− rs <- prune action s
192+ zs <- inorder r xs
90− case rs of
193+ inorder l (ys ++ zs)
91− [] -> go kss acc
92− _ -> go kss ((h,rs) : acc)
93
194
94----------------------------------------------------------------
195----------------------------------------------------------------
95
196
96−-- O(n + m) where N is the size of the second argument
197+-- O(N log N) where N is the size of the second argument
97−merge :: MultiMap v -> MultiMap v -> MultiMap v
198+merge :: Ord k => MMap k v -> MMap k v -> MMap k v
98−merge (MultiMap m1) (MultiMap m2) = MultiMap mm
199+merge base m = foldl' ins base xs
99 where
200 where
100− !mm = I.unionWith (<>) m1 m2
201+ ins t (k,v) = insert k v t
202+ xs = toList m
101
203
102----------------------------------------------------------------
204----------------------------------------------------------------
205+-- for testing
206+
207+valid :: Ord k => MMap k v -> Bool
208+valid t = isBalanced t && isOrdered t
103
209
104−prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]
210+isBalanced :: MMap k v -> Bool
105−prune action xs0 = go xs0
211+isBalanced t = isBlackSame t && isRedSeparate t
212+
213+isBlackSame :: MMap k v -> Bool
214+isBlackSame t = all (n==) ns
215+ where
216+ n:ns = blacks t
217+
218+blacks :: MMap k v -> [Int]
219+blacks = blacks' 0
220+ where
221+ blacks' n Leaf = [n+1]
222+ blacks' n (Node R l _ _ r) = blacks' n l ++ blacks' n r
223+ blacks' n (Node B l _ _ r) = blacks' n' l ++ blacks' n' r
224+ where
225+ n' = n + 1
226+
227+isRedSeparate :: MMap k v -> Bool
228+isRedSeparate = reds B
229+
230+reds :: Color -> MMap k v -> Bool
231+reds _ Leaf = True
232+reds R (Node R _ _ _ _) = False
233+reds _ (Node c l _ _ r) = reds c l && reds c r
234+
235+isOrdered :: Ord k => MMap k v -> Bool
236+isOrdered t = ordered $ toSortedList t
106 where
237 where
107− go [] = return []
238+ ordered [] = True
108− go (x:xs) = do
239+ ordered [_] = True
109− keep <- action x
240+ ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)
110− rs <- go xs
111− return $ if keep then x:rs else rs
warp/Network/Wai/Handler/Warp/PackInt.hsdeleted−56
@@ -1,56 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, BangPatterns #-}
2−
3−module Network.Wai.Handler.Warp.PackInt where
4−
5−import Data.ByteString.Internal (unsafeCreate)
6−import Foreign.Ptr (Ptr, plusPtr)
7−import Foreign.Storable (poke)
8−import qualified Network.HTTP.Types as H
9−
10−import Network.Wai.Handler.Warp.Imports
11−
12−-- $setup
13−-- >>> import Data.ByteString.Char8 as C8
14−-- >>> import Test.QuickCheck (Large(..))
15−
16−-- |
17−--
18−-- prop> packIntegral (abs n) == C8.pack (show (abs n))
19−-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.pack (show n')
20−
21−packIntegral :: Integral a => a -> ByteString
22−packIntegral 0 = "0"
23−packIntegral n | n < 0 = error "packIntegral"
24−packIntegral n = unsafeCreate len go0
25− where
26− n' = fromIntegral n + 1 :: Double
27− len = ceiling $ logBase 10 n'
28− go0 p = go n $ p `plusPtr` (len - 1)
29− go :: Integral a => a -> Ptr Word8 -> IO ()
30− go i p = do
31− let (d,r) = i `divMod` 10
32− poke p (48 + fromIntegral r)
33− when (d /= 0) $ go d (p `plusPtr` (-1))
34−
35−{-# SPECIALIZE packIntegral :: Int -> ByteString #-}
36−{-# SPECIALIZE packIntegral :: Integer -> ByteString #-}
37−
38−-- |
39−--
40−-- >>> packStatus H.status200
41−-- "200"
42−-- >>> packStatus H.preconditionFailed412
43−-- "412"
44−
45−packStatus :: H.Status -> ByteString
46−packStatus status = unsafeCreate 3 $ \p -> do
47− poke p (toW8 r2)
48− poke (p `plusPtr` 1) (toW8 r1)
49− poke (p `plusPtr` 2) (toW8 r0)
50− where
51− toW8 :: Int -> Word8
52− toW8 n = 48 + fromIntegral n
53− !s = fromIntegral $ H.statusCode status
54− (!q0,!r0) = s `divMod` 10
55− (!q1,!r1) = q0 `divMod` 10
56− !r2 = q1 `mod` 10
warp/Network/Wai/Handler/Warp/ReadInt.hs+2−2
@@ -13,13 +13,13 @@ module Network.Wai.Handler.Warp.ReadInt (
13-- This function lives in its own file because the MagicHash pragma interacts
13-- This function lives in its own file because the MagicHash pragma interacts
14-- poorly with the CPP pragma.
14-- poorly with the CPP pragma.
15
15
16+import Data.ByteString (ByteString)
16import qualified Data.ByteString as S
17import qualified Data.ByteString as S
18+import Data.Int (Int64)
17import GHC.Prim
19import GHC.Prim
18import GHC.Types
20import GHC.Types
19import GHC.Word
21import GHC.Word
20
22
21−import Network.Wai.Handler.Warp.Imports hiding (readInt)
22−
23{-# INLINE readInt #-}
23{-# INLINE readInt #-}
24readInt :: Integral a => ByteString -> a
24readInt :: Integral a => ByteString -> a
25readInt bs = fromIntegral $ readInt64 bs
25readInt bs = fromIntegral $ readInt64 bs
warp/Network/Wai/Handler/Warp/Recv.hs+17−122
@@ -1,35 +1,23 @@
1−{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
1+{-# LANGUAGE ForeignFunctionInterface #-}
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3
3
4module Network.Wai.Handler.Warp.Recv (
4module Network.Wai.Handler.Warp.Recv (
5 receive
5 receive
6− , receiveBuf
7− , makeReceiveN
8− , makePlainReceiveN
9− , spell
10 ) where
6 ) where
11
7
12−import qualified Control.Exception as E
8+#if __GLASGOW_HASKELL__ < 709
9+import Control.Applicative ((<$>))
10+#endif
13−import qualified Data.ByteString as BS
11+import Data.ByteString (ByteString)
14−import Data.IORef
12+import Data.Word (Word8)
15import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
13import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
16import Foreign.C.Types
14import Foreign.C.Types
17−import Foreign.ForeignPtr (withForeignPtr)
18−import Foreign.Ptr (Ptr, castPtr, plusPtr)
15+import Foreign.Ptr (Ptr, castPtr)
19import GHC.Conc (threadWaitRead)
16import GHC.Conc (threadWaitRead)
20−import qualified GHC.IO.Exception as E
21−import Network.Socket (Socket)
17+import Network.Socket (Socket, fdSocket)
22−import qualified System.IO.Error as E
23−#if MIN_VERSION_network(3,1,0)
24−import Network.Socket (withFdSocket)
25−#else
26−import Network.Socket (fdSocket)
27−#endif
28−import System.Posix.Types (Fd(..))
29−
30−import Network.Wai.Handler.Warp.Buffer
31−import Network.Wai.Handler.Warp.Imports
32import Network.Wai.Handler.Warp.Types
18import Network.Wai.Handler.Warp.Types
19+import Network.Wai.Handler.Warp.Buffer
20+import System.Posix.Types (Fd(..))
33
21
34#ifdef mingw32_HOST_OS
22#ifdef mingw32_HOST_OS
35import GHC.IO.FD (FD(..), readRawBufferPtr)
23import GHC.IO.FD (FD(..), readRawBufferPtr)
@@ -38,108 +26,17 @@ import Network.Wai.Handler.Warp.Windows
38
26
39----------------------------------------------------------------
27----------------------------------------------------------------
40
28
41−makeReceiveN :: ByteString -> Recv -> RecvBuf -> IO (BufSize -> IO ByteString)
42−makeReceiveN bs0 recv recvBuf = do
43− ref <- newIORef bs0
44− return $ receiveN ref recv recvBuf
45−
46−-- | This function returns a receiving function
47−-- based on two receiving functions.
48−-- The returned function efficiently manages received data
49−-- which is initialized by the first argument.
50−-- The returned function may allocate a byte string with malloc().
51−makePlainReceiveN :: Socket -> ByteString -> IO (BufSize -> IO ByteString)
52−makePlainReceiveN s bs0 = do
53− ref <- newIORef bs0
54− pool <- newBufferPool
55− return $ receiveN ref (receive s pool) (receiveBuf s)
56−
57−receiveN :: IORef ByteString -> Recv -> RecvBuf -> BufSize -> IO ByteString
58−receiveN ref recv recvBuf size = E.handle handler $ do
59− cached <- readIORef ref
60− (bs, leftover) <- spell cached size recv recvBuf
61− writeIORef ref leftover
62− return bs
63− where
64− handler :: E.SomeException -> IO ByteString
65− handler _ = return ""
66−
67−----------------------------------------------------------------
68−
69−spell :: ByteString -> BufSize -> IO ByteString -> RecvBuf -> IO (ByteString, ByteString)
70−spell init0 siz0 recv recvBuf
71− | siz0 <= len0 = return $ BS.splitAt siz0 init0
72− -- fixme: hard coding 4096
73− | siz0 <= 4096 = loop [init0] (siz0 - len0)
74− | otherwise = do
75− bs@(PS fptr _ _) <- mallocBS siz0
76− withForeignPtr fptr $ \ptr -> do
77− ptr' <- copy ptr init0
78− full <- recvBuf ptr' (siz0 - len0)
79− if full then
80− return (bs, "")
81− else
82− return ("", "") -- fixme
83− where
84− len0 = BS.length init0
85− loop bss siz = do
86− bs <- recv
87− let len = BS.length bs
88− if len == 0 then
89− return ("", "")
90− else if len >= siz then do
91− let (consume, leftover) = BS.splitAt siz bs
92− ret = BS.concat $ reverse (consume : bss)
93− return (ret, leftover)
94− else do
95− let bss' = bs : bss
96− siz' = siz - len
97− loop bss' siz'
98−
99−-- The timeout manager may close the socket.
100−-- In that case, an error of "Bad file descriptor" occurs.
101−-- We ignores it because we expect TimeoutThread.
102−receive :: Socket -> BufferPool -> Recv
29+receive :: Socket -> BufferPool -> IO ByteString
103−receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do
30+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
31+ let sock' = fdSocket sock
110−#endif
111− let size' = fromIntegral size
32+ size' = fromIntegral size
112− fromIntegral <$> receiveloop fd ptr size'
33+ received <- fromIntegral <$> receiveloop sock' ptr size'
113− where
34+ return received
114− handler :: E.IOException -> IO ByteString
115− handler e
116− | E.ioeGetErrorType e == E.InvalidArgument = return ""
117− | otherwise = E.throwIO e
118−
119−receiveBuf :: Socket -> RecvBuf
120−receiveBuf sock buf0 siz0 = do
121−#if MIN_VERSION_network(3,1,0)
122− withFdSocket sock $ \fd -> do
123−#elif MIN_VERSION_network(3,0,0)
124− fd <- fdSocket sock
125−#else
126− let fd = fdSocket sock
127−#endif
128− loop fd buf0 siz0
129− where
130− loop _ _ 0 = return True
131− loop fd buf siz = do
132− n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)
133− -- fixme: what should we do in the case of n == 0
134− if n == 0 then
135− return False
136− else
137− loop fd (buf `plusPtr` n) (siz - n)
138
35
139receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt
36receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt
140receiveloop sock ptr size = do
37receiveloop sock ptr size = do
141#ifdef mingw32_HOST_OS
38#ifdef mingw32_HOST_OS
142− bytes <- windowsThreadBlockHack $ fromIntegral <$> readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size
39+ bytes <- windowsThreadBlockHack $ fmap fromIntegral $ readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size
143#else
40#else
144 bytes <- c_recv sock (castPtr ptr) size 0
41 bytes <- c_recv sock (castPtr ptr) size 0
145#endif
42#endif
@@ -153,8 +50,6 @@ receiveloop sock ptr size = do
153 else
50 else
154 return bytes
51 return bytes
155
52
156−#ifndef mingw32_HOST_OS
157-- fixme: the type of the return value
53-- fixme: the type of the return value
158foreign import ccall unsafe "recv"
54foreign import ccall unsafe "recv"
159 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
55 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
160−#endif
warp/Network/Wai/Handler/Warp/Request.hs+40−63
@@ -1,57 +1,53 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE CPP #-}
3{-# LANGUAGE CPP #-}
4−{-# LANGUAGE DeriveDataTypeable #-}
5{-# OPTIONS_GHC -fno-warn-deprecations #-}
4{-# OPTIONS_GHC -fno-warn-deprecations #-}
6
5
7module Network.Wai.Handler.Warp.Request (
6module Network.Wai.Handler.Warp.Request (
8 recvRequest
7 recvRequest
9 , headerLines
8 , headerLines
10 , pauseTimeoutKey
9 , pauseTimeoutKey
11− , getFileInfoKey
12− , getClientCertificateKey
13− , NoKeepAliveRequest (..)
14 ) where
10 ) where
15
11
16import qualified Control.Concurrent as Conc (yield)
12import qualified Control.Concurrent as Conc (yield)
17−import Control.Exception (throwIO, Exception)
13+import Control.Exception (throwIO)
18import Data.Array ((!))
14import Data.Array ((!))
15+import Data.ByteString (ByteString)
19import qualified Data.ByteString as S
16import qualified Data.ByteString as S
20import qualified Data.ByteString.Unsafe as SU
17import qualified Data.ByteString.Unsafe as SU
21import qualified Data.CaseInsensitive as CI
18import qualified Data.CaseInsensitive as CI
22import qualified Data.IORef as I
19import qualified Data.IORef as I
23−import Data.Typeable (Typeable)
24−import qualified Data.Vault.Lazy as Vault
25−import Data.X509
26import qualified Network.HTTP.Types as H
20import qualified Network.HTTP.Types as H
27import Network.Socket (SockAddr)
21import Network.Socket (SockAddr)
28import Network.Wai
22import Network.Wai
23+import Network.Wai.Handler.Warp.Conduit
24+import Network.Wai.Handler.Warp.Header
25+import Network.Wai.Handler.Warp.ReadInt
26+import Network.Wai.Handler.Warp.RequestHeader
27+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)
28+import qualified Network.Wai.Handler.Warp.Timeout as Timeout
29import Network.Wai.Handler.Warp.Types
29import Network.Wai.Handler.Warp.Types
30import Network.Wai.Internal
30import Network.Wai.Internal
31import Prelude hiding (lines)
31import Prelude hiding (lines)
32+import Control.Monad (when)
33+import qualified Data.Vault.Lazy as Vault
32import System.IO.Unsafe (unsafePerformIO)
34import System.IO.Unsafe (unsafePerformIO)
33−import qualified System.TimeManager as Timeout
34
35
35−import Network.Wai.Handler.Warp.Conduit
36+----------------------------------------------------------------
36−import Network.Wai.Handler.Warp.FileInfoCache
37+
37−import Network.Wai.Handler.Warp.Header
38+-- FIXME come up with good values here
38−import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)
39+maxTotalHeaderLength :: Int
39−import Network.Wai.Handler.Warp.ReadInt
40+maxTotalHeaderLength = 50 * 1024
40−import Network.Wai.Handler.Warp.RequestHeader
41−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)
42
41
43----------------------------------------------------------------
42----------------------------------------------------------------
44
43
45-- | Receiving a HTTP request from 'Connection' and parsing its header
44-- | Receiving a HTTP request from 'Connection' and parsing its header
46-- to create 'Request'.
45-- to create 'Request'.
47−recvRequest :: Bool -- ^ first request on this connection?
48− -> Settings
46+recvRequest :: Settings
49 -> Connection
47 -> Connection
50 -> InternalInfo
48 -> InternalInfo
51− -> Timeout.Handle
52 -> SockAddr -- ^ Peer's address.
49 -> SockAddr -- ^ Peer's address.
53 -> Source -- ^ Where HTTP request comes from.
50 -> Source -- ^ Where HTTP request comes from.
54− -> Transport
55 -> IO (Request
51 -> IO (Request
56 ,Maybe (I.IORef Int)
52 ,Maybe (I.IORef Int)
57 ,IndexedHeader
53 ,IndexedHeader
@@ -61,19 +57,14 @@ recvRequest :: Bool -- ^ first request on this connection?
61 -- 'IndexedHeader' of HTTP request for internal use,
57 -- 'IndexedHeader' of HTTP request for internal use,
62 -- Body producing action used for flushing the request body
58 -- Body producing action used for flushing the request body
63
59
64−recvRequest firstRequest settings conn ii th addr src transport = do
60+recvRequest settings conn ii addr src = do
65− hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src
61+ hdrlines <- headerLines src
66 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
62 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
67 let idxhdr = indexRequestHeader hdr
63 let idxhdr = indexRequestHeader hdr
68− expect = idxhdr ! fromEnum ReqExpect
64+ expect = idxhdr ! idxExpect
69− cl = idxhdr ! fromEnum ReqContentLength
65+ cl = idxhdr ! idxContentLength
70− te = idxhdr ! fromEnum ReqTransferEncoding
66+ te = idxhdr ! idxTransferEncoding
71 handle100Continue = handleExpect conn httpversion expect
67 handle100Continue = handleExpect conn httpversion expect
72− rawPath = if settingsNoParsePath settings then unparsedPath else path
73− vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
74− $ Vault.insert getFileInfoKey (getFileInfo ii)
75− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)
76− Vault.empty
77 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te
68 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te
78 -- body producing function which will produce '100-continue', if needed
69 -- body producing function which will produce '100-continue', if needed
79 rbody' <- timeoutBody remainingRef th rbody handle100Continue
70 rbody' <- timeoutBody remainingRef th rbody handle100Continue
@@ -83,38 +74,32 @@ recvRequest firstRequest settings conn ii th addr src transport = do
83 requestMethod = method
74 requestMethod = method
84 , httpVersion = httpversion
75 , httpVersion = httpversion
85 , pathInfo = H.decodePathSegments path
76 , pathInfo = H.decodePathSegments path
86− , rawPathInfo = rawPath
77+ , rawPathInfo = if settingsNoParsePath settings then unparsedPath else path
87 , rawQueryString = query
78 , rawQueryString = query
88 , queryString = H.parseQuery query
79 , queryString = H.parseQuery query
89 , requestHeaders = hdr
80 , requestHeaders = hdr
90− , isSecure = isTransportSecure transport
81+ , isSecure = False
91 , remoteHost = addr
82 , remoteHost = addr
92 , requestBody = rbody'
83 , requestBody = rbody'
93− , vault = vaultValue
84+ , vault = Vault.insert pauseTimeoutKey
85+ (Timeout.pause th)
86+ Vault.empty
94 , requestBodyLength = bodyLength
87 , requestBodyLength = bodyLength
95− , requestHeaderHost = idxhdr ! fromEnum ReqHost
88+ , requestHeaderHost = idxhdr ! idxHost
96− , requestHeaderRange = idxhdr ! fromEnum ReqRange
89+ , requestHeaderRange = idxhdr ! idxRange
97− , requestHeaderReferer = idxhdr ! fromEnum ReqReferer
98− , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent
99 }
90 }
100 return (req, remainingRef, idxhdr, rbodyFlush)
91 return (req, remainingRef, idxhdr, rbodyFlush)
92+ where
93+ th = threadHandle ii
101
94
102----------------------------------------------------------------
95----------------------------------------------------------------
103
96
104−headerLines :: Int -> Bool -> Source -> IO [ByteString]
97+headerLines :: Source -> IO [ByteString]
105−headerLines maxTotalHeaderLength firstRequest src = do
98+headerLines src = do
106 bs <- readSource src
99 bs <- readSource src
107 if S.null bs
100 if S.null bs
108− -- When we're working on a keep-alive connection and trying to
109− -- get the second or later request, we don't want to treat the
110− -- lack of data as a real exception. See the http1 function in
111− -- the Run module for more details.
112− then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest
101+ then throwIO $ ConnectionClosedByPeer
113− else push maxTotalHeaderLength src (THStatus 0 id id) bs
102+ else push src (THStatus 0 id id) bs
114−
115−data NoKeepAliveRequest = NoKeepAliveRequest
116− deriving (Show, Typeable)
117−instance Exception NoKeepAliveRequest
118
103
119----------------------------------------------------------------
104----------------------------------------------------------------
120
105
@@ -220,8 +205,8 @@ close :: Sink ByteString IO a
220close = throwIO IncompleteHeaders
205close = throwIO IncompleteHeaders
221-}
206-}
222
207
223−push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]
208+push :: Source -> THStatus -> ByteString -> IO [ByteString]
224−push maxTotalHeaderLength src (THStatus len lines prepend) bs'
209+push src (THStatus len lines prepend) bs'
225 -- Too many bytes
210 -- Too many bytes
226 | len > maxTotalHeaderLength = throwIO OverLargeHeader
211 | len > maxTotalHeaderLength = throwIO OverLargeHeader
227 | otherwise = push' mnl
212 | otherwise = push' mnl
@@ -249,13 +234,13 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'
249 push' Nothing = do
234 push' Nothing = do
250 bst <- readSource' src
235 bst <- readSource' src
251 when (S.null bst) $ throwIO IncompleteHeaders
236 when (S.null bst) $ throwIO IncompleteHeaders
252− push maxTotalHeaderLength src status bst
237+ push src status bst
253 where
238 where
254 len' = len + bsLen
239 len' = len + bsLen
255 prepend' = S.append bs
240 prepend' = S.append bs
256 status = THStatus len' lines prepend'
241 status = THStatus len' lines prepend'
257 -- Found a newline, but next line continues as a multiline header
242 -- Found a newline, but next line continues as a multiline header
258− push' (Just (end, True)) = push maxTotalHeaderLength src status rest
243+ push' (Just (end, True)) = push src status rest
259 where
244 where
260 rest = S.drop (end + 1) bs
245 rest = S.drop (end + 1) bs
261 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)
246 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)
@@ -274,12 +259,12 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'
274 in if start < bsLen then
259 in if start < bsLen then
275 -- more bytes in this chunk, push again
260 -- more bytes in this chunk, push again
276 let bs'' = SU.unsafeDrop start bs
261 let bs'' = SU.unsafeDrop start bs
277− in push maxTotalHeaderLength src status bs''
262+ in push src status bs''
278 else do
263 else do
279 -- no more bytes in this chunk, ask for more
264 -- no more bytes in this chunk, ask for more
280 bst <- readSource' src
265 bst <- readSource' src
281 when (S.null bs) $ throwIO IncompleteHeaders
266 when (S.null bs) $ throwIO IncompleteHeaders
282− push maxTotalHeaderLength src status bst
267+ push src status bst
283 where
268 where
284 start = end + 1 -- start of next chunk
269 start = end + 1 -- start of next chunk
285 line = SU.unsafeTake (checkCR bs end) bs
270 line = SU.unsafeTake (checkCR bs end) bs
@@ -293,11 +278,3 @@ checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR
293pauseTimeoutKey :: Vault.Key (IO ())
278pauseTimeoutKey :: Vault.Key (IO ())
294pauseTimeoutKey = unsafePerformIO Vault.newKey
279pauseTimeoutKey = unsafePerformIO Vault.newKey
295{-# NOINLINE pauseTimeoutKey #-}
280{-# NOINLINE pauseTimeoutKey #-}
296−
297−getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)
298−getFileInfoKey = unsafePerformIO Vault.newKey
299−{-# NOINLINE getFileInfoKey #-}
300−
301−getClientCertificateKey :: Vault.Key (Maybe CertificateChain)
302−getClientCertificateKey = unsafePerformIO Vault.newKey
303−{-# NOINLINE getClientCertificateKey #-}
warp/Network/Wai/Handler/Warp/RequestHeader.hs+40−15
@@ -1,22 +1,24 @@
1+{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
2
3
3module Network.Wai.Handler.Warp.RequestHeader (
4module Network.Wai.Handler.Warp.RequestHeader (
4 parseHeaderLines
5 parseHeaderLines
6+ , parseByteRanges
5 ) where
7 ) where
6
8
7import Control.Exception (throwIO)
9import Control.Exception (throwIO)
10+import Control.Monad (when)
8import qualified Data.ByteString as S
11import qualified Data.ByteString as S
9−import qualified Data.ByteString.Char8 as C8 (unpack)
12+import qualified Data.ByteString.Char8 as B (unpack, readInteger)
10−import Data.ByteString.Internal (memchr)
13+import Data.ByteString.Internal (ByteString(..), memchr)
11import qualified Data.CaseInsensitive as CI
14import qualified Data.CaseInsensitive as CI
15+import Data.Word (Word8)
12import Foreign.ForeignPtr (withForeignPtr)
16import Foreign.ForeignPtr (withForeignPtr)
13import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
17import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
14import Foreign.Storable (peek)
18import Foreign.Storable (peek)
15import qualified Network.HTTP.Types as H
19import qualified Network.HTTP.Types as H
16−
17−import Network.Wai.Handler.Warp.Imports
18import Network.Wai.Handler.Warp.Types
20import Network.Wai.Handler.Warp.Types
19−
21+import qualified Network.HTTP.Types.Header as HH
20-- $setup
22-- $setup
21-- >>> :set -XOverloadedStrings
23-- >>> :set -XOverloadedStrings
22
24
@@ -49,8 +51,6 @@ parseHeaderLines (firstLine:otherLines) = do
49-- *** Exception: Warp: Invalid first line of request: "GET "
51-- *** Exception: Warp: Invalid first line of request: "GET "
50-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"
52-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"
51-- *** Exception: Warp: Request line specified a non-HTTP request
53-- *** Exception: Warp: Request line specified a non-HTTP request
52−-- >>> parseRequestLine "PRI * HTTP/2.0"
53−-- ("PRI","*","",HTTP/2.0)
54parseRequestLine :: ByteString
54parseRequestLine :: ByteString
55 -> IO (H.Method
55 -> IO (H.Method
56 ,ByteString -- Path
56 ,ByteString -- Path
@@ -88,7 +88,7 @@ parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> d
88
88
89 return (method,path,query,hv)
89 return (method,path,query,hv)
90 where
90 where
91− baderr = BadFirstLine $ C8.unpack requestLine
91+ baderr = BadFirstLine $ B.unpack requestLine
92 check :: Ptr Word8 -> Int -> Word8 -> IO ()
92 check :: Ptr Word8 -> Int -> Word8 -> IO ()
93 check p n w = do
93 check p n w = do
94 w0 <- peek $ p `plusPtr` n
94 w0 <- peek $ p `plusPtr` n
@@ -101,13 +101,12 @@ parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> d
101 check httpptr 4 47 -- '/'
101 check httpptr 4 47 -- '/'
102 check httpptr 6 46 -- '.'
102 check httpptr 6 46 -- '.'
103 httpVersion httpptr = do
103 httpVersion httpptr = do
104− major <- peek (httpptr `plusPtr` 5) :: IO Word8
104+ major <- peek $ httpptr `plusPtr` 5
105− minor <- peek (httpptr `plusPtr` 7) :: IO Word8
105+ minor <- peek $ httpptr `plusPtr` 7
106− let version
106+ return $ if major == (49 :: Word8) && minor == (49 :: Word8) then
107− | major == 49 = if minor == 49 then H.http11 else H.http10
107+ H.http11
108− | major == 50 && minor == 48 = H.HttpVersion 2 0
108+ else
109− | otherwise = H.http10
109+ H.http10
110− return version
111 bs ptr p0 p1 = PS fptr o l
110 bs ptr p0 p1 = PS fptr o l
112 where
111 where
113 o = p0 `minusPtr` ptr
112 o = p0 `minusPtr` ptr
@@ -131,3 +130,29 @@ parseHeader s =
131 let (k, rest) = S.break (== 58) s -- ':'
130 let (k, rest) = S.break (== 58) s -- ':'
132 rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
131 rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
133 in (CI.mk k, rest')
132 in (CI.mk k, rest')
133+
134+parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges
135+parseByteRanges bs1 = do
136+ bs2 <- stripPrefix "bytes=" bs1
137+ (r, bs3) <- range bs2
138+ ranges (r:) bs3
139+ where
140+ range bs2 = do
141+ (i, bs3) <- B.readInteger bs2
142+ if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")
143+ then Just (HH.ByteRangeSuffix (negate i), bs3)
144+ else do
145+ bs4 <- stripPrefix "-" bs3
146+ case B.readInteger bs4 of
147+ Just (j, bs5) | j >= i -> Just (HH.ByteRangeFromTo i j, bs5)
148+ _ -> Just (HH.ByteRangeFrom i, bs4)
149+ ranges front bs3
150+ | S.null bs3 = Just (front [])
151+ | otherwise = do
152+ bs4 <- stripPrefix "," bs3
153+ (r, bs5) <- range bs4
154+ ranges (front . (r:)) bs5
155+
156+ stripPrefix x y
157+ | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)
158+ | otherwise = Nothing
warp/Network/Wai/Handler/Warp/Response.hs+218−195
@@ -1,60 +1,137 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE CPP #-}
5{-# LANGUAGE CPP #-}
5−{-# LANGUAGE BangPatterns #-}
6
6
7module Network.Wai.Handler.Warp.Response (
7module Network.Wai.Handler.Warp.Response (
8 sendResponse
8 sendResponse
9− , sanitizeHeaderValue -- for testing
9+ , fileRange -- for testing
10 , warpVersion
10 , warpVersion
11− , hasBody
11+ , defaultServerValue
12− , replaceHeader
13− , addServer -- testing
14 ) where
12 ) where
15
13
14+#ifndef MIN_VERSION_base
15+#define MIN_VERSION_base(x,y,z) 1
16+#endif
17+
18+import Blaze.ByteString.Builder (fromByteString, Builder, flush)
16−import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)
19+import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
20+#if __GLASGOW_HASKELL__ < 709
21+import Control.Applicative
22+#endif
17−import qualified Control.Exception as E
23+import Control.Exception
18import Data.Array ((!))
24import Data.Array ((!))
25+import Data.ByteString (ByteString)
26+import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)
19import qualified Data.ByteString as S
27import qualified Data.ByteString as S
20−import Data.ByteString.Builder (byteString, Builder)
28+import Control.Monad (unless, when)
21−import Data.ByteString.Builder.Extra (flush)
22−import qualified Data.ByteString.Char8 as C8
29+import qualified Data.ByteString.Char8 as B (pack)
23import qualified Data.CaseInsensitive as CI
30import qualified Data.CaseInsensitive as CI
24import Data.Function (on)
31import Data.Function (on)
25−import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)
32+import Data.List (deleteBy)
33+import Data.Maybe (isJust, listToMaybe)
34+#if MIN_VERSION_base(4,5,0)
35+# if __GLASGOW_HASKELL__ < 709
36+import Data.Monoid (mempty)
37+# endif
38+import Data.Monoid ((<>))
39+#else
40+import Data.Monoid (mappend, mempty)
41+#endif
26import Data.Version (showVersion)
42import Data.Version (showVersion)
27−import Data.Word8 (_cr, _lf)
28import qualified Network.HTTP.Types as H
43import qualified Network.HTTP.Types as H
29−import qualified Network.HTTP.Types.Header as H
30import Network.Wai
44import Network.Wai
31−import Network.Wai.Internal
45+import Network.Wai.Handler.Warp.Buffer (toBlazeBuffer)
32−import qualified Paths_warp
33−import qualified System.TimeManager as T
34−
35−import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
36import qualified Network.Wai.Handler.Warp.Date as D
46import qualified Network.Wai.Handler.Warp.Date as D
37−import Network.Wai.Handler.Warp.File
47+import qualified Network.Wai.Handler.Warp.FdCache as F
38import Network.Wai.Handler.Warp.Header
48import Network.Wai.Handler.Warp.Header
39import Network.Wai.Handler.Warp.IO (toBufIOWith)
49import Network.Wai.Handler.Warp.IO (toBufIOWith)
40−import Network.Wai.Handler.Warp.Imports
50+import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)
41import Network.Wai.Handler.Warp.ResponseHeader
51import Network.Wai.Handler.Warp.ResponseHeader
42−import Network.Wai.Handler.Warp.Settings
52+import qualified Network.Wai.Handler.Warp.Timeout as T
43import Network.Wai.Handler.Warp.Types
53import Network.Wai.Handler.Warp.Types
54+import Network.Wai.Internal
55+import Numeric (showInt)
56+import qualified Paths_warp
57+import qualified System.PosixCompat.Files as P
58+
59+#if !MIN_VERSION_base(4,5,0)
60+(<>) :: Monoid m => m -> m -> m
61+(<>) = mappend
62+#endif
44
63
45-- $setup
64-- $setup
46-- >>> :set -XOverloadedStrings
65-- >>> :set -XOverloadedStrings
47
66
67+mapRight :: (b -> c) -> Either a b -> Either a c
68+mapRight f eith = case eith of
69+ Right x -> Right (f x)
70+ Left l -> Left l
71+
72+----------------------------------------------------------------
73+
74+fileRange :: H.Status -> H.ResponseHeaders -> FilePath
75+ -> Maybe FilePart -> Maybe HeaderValue
76+ -> IO (Either IOException
77+ (H.Status, H.ResponseHeaders, Integer, Integer))
78+fileRange s0 hs0 path Nothing mRange =
79+ mapRight (fileRangeSized s0 hs0 Nothing mRange . fromIntegral . P.fileSize) <$>
80+ try (P.getFileStatus path)
81+fileRange s0 hs0 _ mPart@(Just part) mRange =
82+ return . Right $ fileRangeSized s0 hs0 mPart mRange size
83+ where
84+ size = filePartFileSize part
85+
86+fileRangeSized :: H.Status -> H.ResponseHeaders
87+ -> Maybe FilePart -> Maybe HeaderValue -> Integer
88+ -> (H.Status, H.ResponseHeaders, Integer, Integer)
89+fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)
90+ where
91+ (beg, end, len, isEntire) = checkPartRange fileSize mPart mRange
92+ hs1 = addContentLength len hs0
93+ hs | isEntire = hs1
94+ | otherwise = addContentRange beg end fileSize hs1
95+ s | isEntire = s0
96+ | otherwise = H.status206
97+
98+checkPartRange :: Integer -> Maybe FilePart -> Maybe HeaderValue
99+ -> (Integer, Integer, Integer, Bool)
100+checkPartRange fileSize = checkPart
101+ where
102+ checkPart Nothing Nothing = (0, fileSize - 1, fileSize, True)
103+ checkPart Nothing (Just range) = case parseByteRanges range >>= listToMaybe of
104+ -- Range is broken
105+ Nothing -> (0, fileSize - 1, fileSize, True)
106+ Just hrange -> checkRange hrange
107+ -- Ignore Range if FilePart is specified.
108+ -- We assume that an application handled Range and specified
109+ -- FilePart.
110+ checkPart (Just part) _ = (beg, end, len, isEntire)
111+ where
112+ beg = filePartOffset part
113+ len = filePartByteCount part
114+ end = beg + len - 1
115+ isEntire = beg == 0 && len == fileSize
116+
117+ checkRange (H.ByteRangeFrom beg) = fromRange beg (fileSize - 1)
118+ checkRange (H.ByteRangeFromTo beg end) = fromRange beg (min (fileSize - 1) end)
119+ checkRange (H.ByteRangeSuffix count) = fromRange (max 0 (fileSize - count)) (fileSize - 1)
120+
121+ fromRange beg end = (beg, end, len, isEntire)
122+ where
123+ len = end - beg + 1
124+ isEntire = beg == 0 && len == fileSize
125+
48----------------------------------------------------------------
126----------------------------------------------------------------
49
127
50-- | Sending a HTTP response to 'Connection' according to 'Response'.
128-- | Sending a HTTP response to 'Connection' according to 'Response'.
51--
129--
52−-- Applications/middlewares MUST provide a proper 'H.ResponseHeaders'.
130+-- Applications/middlewares MUST specify a proper 'H.ResponseHeaders'.
53-- so that inconsistency does not happen.
131-- so that inconsistency does not happen.
54-- No header is deleted by this function.
132-- No header is deleted by this function.
55--
133--
56−-- Especially, Applications/middlewares MUST provide a proper
134+-- Especially, Applications/middlewares MUST take care of
57−-- Content-Type. They MUST NOT provide
58-- Content-Length, Content-Range, and Transfer-Encoding
135-- Content-Length, Content-Range, and Transfer-Encoding
59-- because they are inserted, when necessary,
136-- because they are inserted, when necessary,
60-- regardless they already exist.
137-- regardless they already exist.
@@ -66,6 +143,22 @@ import Network.Wai.Handler.Warp.Types
66--
143--
67-- There are three basic APIs to create 'Response':
144-- There are three basic APIs to create 'Response':
68--
145--
146+-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']
147+-- HTTP response body is sent by sendfile() for GET method.
148+-- HTTP response body is not sent by HEAD method.
149+-- Applications are categorized into simple and sophisticated.
150+-- Simple applications should specify 'Nothing' to
151+-- 'Maybe' 'FilePart'. The size of the specified file is obtained
152+-- by disk access. Then Range is handled.
153+-- Sophisticated applications should specify 'Just' to
154+-- 'Maybe' 'FilePart'. They should treat Range (and If-Range) by
155+-- themselves. In both cases,
156+-- Content-Length and Content-Range (if necessary) are automatically
157+-- added into the HTTP response header.
158+-- If Content-Length and Content-Range exist in the HTTP response header,
159+-- they would cause inconsistency.
160+-- Status is also changed to 206 (Partial Content) if necessary.
161+--
69-- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']
162-- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']
70-- HTTP response body is created from 'Builder'.
163-- HTTP response body is created from 'Builder'.
71-- Transfer-Encoding: chunked is used in HTTP/1.1.
164-- Transfer-Encoding: chunked is used in HTTP/1.1.
@@ -76,81 +169,46 @@ import Network.Wai.Handler.Warp.Types
76--
169--
77-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']
170-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']
78-- No header is added and no Transfer-Encoding: is applied.
171-- No header is added and no Transfer-Encoding: is applied.
79−--
80−-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']
81−-- HTTP response body is sent (by sendfile(), if possible) for GET method.
82−-- HTTP response body is not sent by HEAD method.
83−-- Content-Length and Content-Range are automatically
84−-- added into the HTTP response header if necessary.
85−-- If Content-Length and Content-Range exist in the HTTP response header,
86−-- they would cause inconsistency.
87−-- \"Accept-Ranges: bytes\" is also inserted.
88−--
89−-- Applications are categorized into simple and sophisticated.
90−-- Sophisticated applications should specify 'Just' to
91−-- 'Maybe' 'FilePart'. They should treat the conditional request
92−-- by themselves. A proper 'Status' (200 or 206) must be provided.
93−--
94−-- Simple applications should specify 'Nothing' to
95−-- 'Maybe' 'FilePart'. The size of the specified file is obtained
96−-- by disk access or from the file infor cache.
97−-- If-Modified-Since, If-Unmodified-Since, If-Range and Range
98−-- are processed. Since a proper status is chosen, 'Status' is
99−-- ignored. Last-Modified is inserted.
100
172
101−sendResponse :: Settings
173+sendResponse :: ByteString -- ^ default server value
102 -> Connection
174 -> Connection
103 -> InternalInfo
175 -> InternalInfo
104− -> T.Handle
105 -> Request -- ^ HTTP request.
176 -> Request -- ^ HTTP request.
106 -> IndexedHeader -- ^ Indexed header of HTTP request.
177 -> IndexedHeader -- ^ Indexed header of HTTP request.
107 -> IO ByteString -- ^ source from client, for raw response
178 -> IO ByteString -- ^ source from client, for raw response
108 -> Response -- ^ HTTP response including status code and response header.
179 -> Response -- ^ HTTP response including status code and response header.
109 -> IO Bool -- ^ Returing True if the connection is persistent.
180 -> IO Bool -- ^ Returing True if the connection is persistent.
110−sendResponse settings conn ii th req reqidxhdr src response = do
181+sendResponse defServer conn ii req reqidxhdr src response = do
111 hs <- addServerAndDate hs0
182 hs <- addServerAndDate hs0
112 if hasBody s then do
183 if hasBody s then do
113− -- The response to HEAD does not have body.
184+ -- HEAD comes here even if it does not have body.
114− -- But to handle the conditional requests defined RFC 7232 and
115− -- to generate appropriate content-length, content-range,
116− -- and status, the response to HEAD is processed here.
117− --
118− -- See definition of rsp below for proper body stripping.
119− (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp
185+ sendRsp conn mfdc ver s hs rsp
120− case ms of
121− Nothing -> return ()
122− Just realStatus -> logger req realStatus mlen
123 T.tickle th
186 T.tickle th
124 return ret
187 return ret
125 else do
188 else do
126− _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody
189+ sendResponseNoBody conn ver s hs
127− logger req s Nothing
128 T.tickle th
190 T.tickle th
129 return isPersist
191 return isPersist
130 where
192 where
131− defServer = settingsServerName settings
132− logger = settingsLogger settings
133 ver = httpVersion req
193 ver = httpVersion req
134 s = responseStatus response
194 s = responseStatus response
135− hs0 = sanitizeHeaders $ responseHeaders response
195+ hs0 = responseHeaders response
136 rspidxhdr = indexResponseHeader hs0
196 rspidxhdr = indexResponseHeader hs0
137− getdate = getDate ii
197+ th = threadHandle ii
198+ dc = dateCacher ii
199+ mfdc = fdCacher ii
138− addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr
200+ addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
201+ mRange = reqidxhdr ! idxRange
139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr
202 (isPersist,isChunked0) = infoFromRequest req reqidxhdr
140− isChunked = not isHead && isChunked0
203+ isChunked = if isHead then False else isChunked0
141 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)
204 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)
142 isHead = requestMethod req == H.methodHead
205 isHead = requestMethod req == H.methodHead
143 rsp = case response of
206 rsp = case response of
144− ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)
207+ ResponseFile _ _ path mPart -> RspFile path mPart mRange isHead (T.tickle th)
145− ResponseBuilder _ _ b
146− | isHead -> RspNoBody
147− | otherwise -> RspBuilder b needsChunked
208+ ResponseBuilder _ _ b -> RspBuilder b needsChunked
148− ResponseStream _ _ fb
149− | isHead -> RspNoBody
150− | otherwise -> RspStream fb needsChunked th
209+ ResponseStream _ _ fb -> RspStream fb needsChunked th
151 ResponseRaw raw _ -> RspRaw raw src (T.tickle th)
210 ResponseRaw raw _ -> RspRaw raw src (T.tickle th)
152− -- Make sure we don't hang on to 'response' (avoid space leak)
153− !ret = case response of
211+ ret = case response of
154 ResponseFile {} -> isPersist
212 ResponseFile {} -> isPersist
155 ResponseBuilder {} -> isKeepAlive
213 ResponseBuilder {} -> isKeepAlive
156 ResponseStream {} -> isKeepAlive
214 ResponseStream {} -> isKeepAlive
@@ -158,33 +216,7 @@ sendResponse settings conn ii th req reqidxhdr src response = do
158
216
159----------------------------------------------------------------
217----------------------------------------------------------------
160
218
161−sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders
162−sanitizeHeaders = map (sanitize <$>)
163− where
164− sanitize v
165− | containsNewlines v = sanitizeHeaderValue v -- slow path
166− | otherwise = v -- fast path
167−
168−{-# INLINE containsNewlines #-}
169−containsNewlines :: ByteString -> Bool
170−containsNewlines = S.any (\w -> w == _cr || w == _lf)
171−
172−{-# INLINE sanitizeHeaderValue #-}
173−sanitizeHeaderValue :: ByteString -> ByteString
174−sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of
175− [] -> ""
176− x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)
177− where
178− addSpaceIfMissing line = case C8.uncons line of
179− Nothing -> Nothing
180− Just (first, _)
181− | first == ' ' || first == '\t' -> Just line
182− | otherwise -> Just $ " " <> line
183−
184−----------------------------------------------------------------
185−
186−data Rsp = RspNoBody
187− | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ())
219+data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) Bool (IO ())
188 | RspBuilder Builder Bool
220 | RspBuilder Builder Bool
189 | RspStream StreamingBody Bool T.Handle
221 | RspStream StreamingBody Bool T.Handle
190 | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())
222 | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())
@@ -192,25 +224,52 @@ data Rsp = RspNoBody
192----------------------------------------------------------------
224----------------------------------------------------------------
193
225
194sendRsp :: Connection
226sendRsp :: Connection
195− -> InternalInfo
227+ -> Maybe F.MutableFdCache
196 -> H.HttpVersion
228 -> H.HttpVersion
197 -> H.Status
229 -> H.Status
198 -> H.ResponseHeaders
230 -> H.ResponseHeaders
199− -> IndexedHeader -- Response
200 -> Rsp
231 -> Rsp
201− -> IO (Maybe H.Status, Maybe Integer)
232+ -> IO ()
202−
233+sendRsp conn mfdc ver s0 hs0 (RspFile path mPart mRange isHead hook) = do
203−----------------------------------------------------------------
234+ ex <- fileRange s0 hs path mPart mRange
204−
235+ case ex of
205−sendRsp conn _ ver s hs _ RspNoBody = do
236+ Left _ex ->
206− -- Not adding Content-Length.
237+#ifdef WARP_DEBUG
207− -- User agents treats it as Content-Length: 0.
238+ print _ex >>
239+#endif
240+ sendRsp conn mfdc ver s2 hs2 (RspBuilder body True)
241+ Right (s, hs1, beg, len)
242+ | len >= 0 ->
243+ if isHead then
244+ sendRsp conn mfdc ver s hs1 (RspBuilder mempty False)
245+ else do
208− composeHeader ver s hs >>= connSendAll conn
246+ lheader <- composeHeader ver s hs1
247+#ifdef WINDOWS
248+ let fid = FileId path Nothing
249+ hook' = hook
250+#else
251+ (mfd, hook') <- case mfdc of
252+ -- Windows or settingsFdCacheDuration is 0
253+ Nothing -> return (Nothing, hook)
254+ Just fdc -> do
255+ (fd, fresher) <- F.getFd fdc path
209− return (Just s, Nothing)
256+ return (Just fd, hook >> fresher)
257+ let fid = FileId path mfd
258+#endif
259+ connSendFile conn fid beg len hook' [lheader]
260+ | otherwise -> do
261+ sendRsp conn mfdc ver H.status416
262+ (filter (\(k, _) -> k /= "content-length") hs1)
263+ (RspBuilder mempty True)
264+ where
265+ hs = addAcceptRanges hs0
266+ s2 = H.status404
267+ hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
268+ body = fromByteString "File not found"
210
269
211----------------------------------------------------------------
270----------------------------------------------------------------
212
271
213−sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do
272+sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do
214 header <- composeHeaderBuilder ver s hs needsChunked
273 header <- composeHeaderBuilder ver s hs needsChunked
215 let hdrBdy
274 let hdrBdy
216 | needsChunked = header <> chunkedTransferEncoding body
275 | needsChunked = header <> chunkedTransferEncoding body
@@ -219,14 +278,13 @@ sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do
219 buffer = connWriteBuffer conn
278 buffer = connWriteBuffer conn
220 size = connBufferSize conn
279 size = connBufferSize conn
221 toBufIOWith buffer size (connSendAll conn) hdrBdy
280 toBufIOWith buffer size (connSendAll conn) hdrBdy
222− return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?
223
281
224----------------------------------------------------------------
282----------------------------------------------------------------
225
283
226−sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do
284+sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do
227 header <- composeHeaderBuilder ver s hs needsChunked
285 header <- composeHeaderBuilder ver s hs needsChunked
228− (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy
286+ (recv, finish) <- newBlazeRecv $ reuseBufferStrategy
229− $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)
287+ $ toBlazeBuffer (connWriteBuffer conn) (connBufferSize conn)
230 let send builder = do
288 let send builder = do
231 popper <- recv builder
289 popper <- recv builder
232 let loop = do
290 let loop = do
@@ -243,13 +301,11 @@ sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do
243 when needsChunked $ send chunkedTransferTerminator
301 when needsChunked $ send chunkedTransferTerminator
244 mbs <- finish
302 mbs <- finish
245 maybe (return ()) (sendFragment conn th) mbs
303 maybe (return ()) (sendFragment conn th) mbs
246− return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?
247
304
248----------------------------------------------------------------
305----------------------------------------------------------------
249
306
250−sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do
307+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) =
251 withApp recv send
308 withApp recv send
252− return (Nothing, Nothing)
253 where
309 where
254 recv = do
310 recv = do
255 bs <- src
311 bs <- src
@@ -259,66 +315,12 @@ sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do
259
315
260----------------------------------------------------------------
316----------------------------------------------------------------
261
317
262−-- Sophisticated WAI applications.
318+sendResponseNoBody :: Connection
263−-- We respect s0. s0 MUST be a proper value.
264−sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =
265− sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook
266− where
267− beg = filePartOffset part
268− len = filePartByteCount part
269− hs = addContentHeadersForFilePart hs0 part
270−
271−----------------------------------------------------------------
272−
273−-- Simple WAI applications.
274−-- Status is ignored
275−sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do
276− efinfo <- E.try $ getFileInfo ii path
277− case efinfo of
278− Left (_ex :: E.IOException) ->
279−#ifdef WARP_DEBUG
280− print _ex >>
281−#endif
282− sendRspFile404 conn ii ver hs0 rspidxhdr
283− Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of
284− WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody
285− WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook
286−
287−----------------------------------------------------------------
288−
289−sendRspFile2XX :: Connection
290− -> InternalInfo
291− -> H.HttpVersion
319+ -> H.HttpVersion
292− -> H.Status
320+ -> H.Status
293− -> H.ResponseHeaders
321+ -> H.ResponseHeaders
294− -> IndexedHeader
295− -> FilePath
296− -> Integer
297− -> Integer
298− -> Bool
299− -> IO ()
322+ -> IO ()
300− -> IO (Maybe H.Status, Maybe Integer)
301−sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook
302− | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody
303− | otherwise = do
304− lheader <- composeHeader ver s hs
323+sendResponseNoBody conn ver s hs = composeHeader ver s hs >>= connSendAll conn
305− (mfd, fresher) <- getFd ii path
306− let fid = FileId path mfd
307− hook' = hook >> fresher
308− connSendFile conn fid beg len hook' [lheader]
309− return (Just s, Just len)
310−
311−sendRspFile404 :: Connection
312− -> InternalInfo
313− -> H.HttpVersion
314− -> H.ResponseHeaders
315− -> IndexedHeader
316− -> IO (Maybe H.Status, Maybe Integer)
317−sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)
318− where
319− s = H.notFound404
320− hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
321− body = byteString "File not found"
322
324
323----------------------------------------------------------------
325----------------------------------------------------------------
324----------------------------------------------------------------
326----------------------------------------------------------------
@@ -346,7 +348,7 @@ checkPersist req reqidxhdr
346 | otherwise = checkPersist10 conn
348 | otherwise = checkPersist10 conn
347 where
349 where
348 ver = httpVersion req
350 ver = httpVersion req
349− conn = reqidxhdr ! fromEnum ReqConnection
351+ conn = reqidxhdr ! idxConnection
350 checkPersist11 (Just x)
352 checkPersist11 (Just x)
351 | CI.foldCase x == "close" = False
353 | CI.foldCase x == "close" = False
352 checkPersist11 _ = True
354 checkPersist11 _ = True
@@ -371,7 +373,7 @@ infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked)
371 where
373 where
372 needsChunked = isChunked && not hasLength
374 needsChunked = isChunked && not hasLength
373 isKeepAlive = isPersist && (isChunked || hasLength)
375 isKeepAlive = isPersist && (isChunked || hasLength)
374− hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength
376+ hasLength = isJust $ rspidxhdr ! idxContentLength
375
377
376----------------------------------------------------------------
378----------------------------------------------------------------
377
379
@@ -384,13 +386,35 @@ hasBody s = sc /= 204
384
386
385----------------------------------------------------------------
387----------------------------------------------------------------
386
388
389+addAcceptRanges :: H.ResponseHeaders -> H.ResponseHeaders
390+addAcceptRanges hdrs = (hAcceptRanges, "bytes") : hdrs
391+
387addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders
392addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders
388−addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs
393+addTransferEncoding hdrs = (hTransferEncoding, "chunked") : hdrs
389
394
395+addContentLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
396+addContentLength cl hdrs = (H.hContentLength, len) : hdrs
397+ where
398+ len = B.pack $ show cl
399+
400+addContentRange :: Integer -> Integer -> Integer
401+ -> H.ResponseHeaders -> H.ResponseHeaders
402+addContentRange beg end total hdrs = (hContentRange, range) : hdrs
403+ where
404+ range = B.pack
405+ -- building with ShowS
406+ $ 'b' : 'y': 't' : 'e' : 's' : ' '
407+ : (if beg > end then ('*':) else
408+ (showInt beg)
409+ . ('-' :)
410+ . (showInt end))
411+ ( '/'
412+ : showInt total "")
413+
390−addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
414+addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
391−addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of
415+addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of
392 Nothing -> do
416 Nothing -> do
393− gmtdate <- getdate
417+ gmtdate <- D.getDate dc
394 return $ (H.hDate, gmtdate) : hdrs
418 return $ (H.hDate, gmtdate) : hdrs
395 Just _ -> return hdrs
419 Just _ -> return hdrs
396
420
@@ -400,13 +424,12 @@ addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of
400warpVersion :: String
424warpVersion :: String
401warpVersion = showVersion Paths_warp.version
425warpVersion = showVersion Paths_warp.version
402
426
403−{-# INLINE addServer #-}
427+defaultServerValue :: HeaderValue
428+defaultServerValue = B.pack $ "Warp/" ++ warpVersion
429+
404addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders
430addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders
405−addServer "" rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of
431+addServer defaultServerValue' rspidxhdr hdrs = case rspidxhdr ! idxServer of
406− Nothing -> hdrs
407− _ -> filter ((/= H.hServer) . fst) hdrs
408−addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of
409− Nothing -> (H.hServer, serverName) : hdrs
432+ Nothing -> (hServer, defaultServerValue') : hdrs
410 _ -> hdrs
433 _ -> hdrs
411
434
412----------------------------------------------------------------
435----------------------------------------------------------------
@@ -422,6 +445,6 @@ replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs
422
445
423composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
446composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
424composeHeaderBuilder ver s hs True =
447composeHeaderBuilder ver s hs True =
425− byteString <$> composeHeader ver s (addTransferEncoding hs)
448+ fromByteString <$> composeHeader ver s (addTransferEncoding hs)
426composeHeaderBuilder ver s hs False =
449composeHeaderBuilder ver s hs False =
427− byteString <$> composeHeader ver s hs
450+ fromByteString <$> composeHeader ver s hs
warp/Network/Wai/Handler/Warp/ResponseHeader.hs+5−3
@@ -3,15 +3,17 @@
3
3
4module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where
4module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where
5
5
6+import Control.Monad
7+import Data.ByteString (ByteString)
6import qualified Data.ByteString as S
8import qualified Data.ByteString as S
7import Data.ByteString.Internal (create)
9import Data.ByteString.Internal (create)
8import qualified Data.CaseInsensitive as CI
10import qualified Data.CaseInsensitive as CI
11+import Data.List (foldl')
12+import Data.Word (Word8)
9import Foreign.Ptr
13import Foreign.Ptr
10import GHC.Storable
14import GHC.Storable
11import qualified Network.HTTP.Types as H
15import qualified Network.HTTP.Types as H
12−
13import Network.Wai.Handler.Warp.Buffer (copy)
16import Network.Wai.Handler.Warp.Buffer (copy)
14−import Network.Wai.Handler.Warp.Imports
15
17
16----------------------------------------------------------------
18----------------------------------------------------------------
17
19
@@ -22,7 +24,7 @@ composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do
22 void $ copyCRLF ptr2
24 void $ copyCRLF ptr2
23 where
25 where
24 !len = 17 + slen + foldl' fieldLength 0 responseHeaders
26 !len = 17 + slen + foldl' fieldLength 0 responseHeaders
25− fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4
27+ fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4
26 !slen = S.length $ H.statusMessage status
28 !slen = S.length $ H.statusMessage status
27
29
28httpVer11 :: ByteString
30httpVer11 :: ByteString
warp/Network/Wai/Handler/Warp/Run.hs+118−243
@@ -1,97 +1,71 @@
1−{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
3{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE PackageImports #-}
5−{-# LANGUAGE PatternGuards #-}
6−{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE ViewPatterns #-}
10{-# OPTIONS_GHC -fno-warn-deprecations #-}
5{-# OPTIONS_GHC -fno-warn-deprecations #-}
11
6
12module Network.Wai.Handler.Warp.Run where
7module Network.Wai.Handler.Warp.Run where
13
8
14−import "iproute" Data.IP (toHostAddress, toHostAddress6)
15import Control.Arrow (first)
9import Control.Arrow (first)
10+import Control.Concurrent (threadDelay)
16import qualified Control.Concurrent as Conc (yield)
11import qualified Control.Concurrent as Conc (yield)
17import Control.Exception as E
12import Control.Exception as E
13+import Control.Monad (when, unless, void)
14+import Data.ByteString (ByteString)
18import qualified Data.ByteString as S
15import qualified Data.ByteString as S
19import Data.Char (chr)
16import Data.Char (chr)
17+import Data.IP (toHostAddress, toHostAddress6)
20import Data.IORef (IORef, newIORef, readIORef, writeIORef)
18import Data.IORef (IORef, newIORef, readIORef, writeIORef)
21import Data.Streaming.Network (bindPortTCP)
19import Data.Streaming.Network (bindPortTCP)
22−import Foreign.C.Error (Errno(..), eCONNABORTED)
20+import Network (sClose, Socket)
23−import GHC.IO.Exception (IOException(..))
24−import qualified Network.HTTP2 as H2
25−import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
21+import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6))
26−#if MIN_VERSION_network(3,1,1)
27−import Network.Socket (gracefulClose)
28−#endif
29import qualified Network.Socket.ByteString as Sock
22import qualified Network.Socket.ByteString as Sock
30import Network.Wai
23import Network.Wai
31−import Network.Wai.Internal (ResponseReceived (ResponseReceived))
32−import System.Environment (lookupEnv)
33−import qualified System.TimeManager as T
34−import System.Timeout (timeout)
35−
36import Network.Wai.Handler.Warp.Buffer
24import Network.Wai.Handler.Warp.Buffer
37import Network.Wai.Handler.Warp.Counter
25import Network.Wai.Handler.Warp.Counter
38import qualified Network.Wai.Handler.Warp.Date as D
26import qualified Network.Wai.Handler.Warp.Date as D
39import qualified Network.Wai.Handler.Warp.FdCache as F
27import qualified Network.Wai.Handler.Warp.FdCache as F
40−import qualified Network.Wai.Handler.Warp.FileInfoCache as I
41−import Network.Wai.Handler.Warp.HTTP2 (http2)
42−import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
43import Network.Wai.Handler.Warp.Header
28import Network.Wai.Handler.Warp.Header
44−import Network.Wai.Handler.Warp.Imports hiding (readInt)
45import Network.Wai.Handler.Warp.ReadInt
29import Network.Wai.Handler.Warp.ReadInt
46import Network.Wai.Handler.Warp.Recv
30import Network.Wai.Handler.Warp.Recv
47import Network.Wai.Handler.Warp.Request
31import Network.Wai.Handler.Warp.Request
48import Network.Wai.Handler.Warp.Response
32import Network.Wai.Handler.Warp.Response
49import Network.Wai.Handler.Warp.SendFile
33import Network.Wai.Handler.Warp.SendFile
50import Network.Wai.Handler.Warp.Settings
34import Network.Wai.Handler.Warp.Settings
35+import qualified Network.Wai.Handler.Warp.Timeout as T
51import Network.Wai.Handler.Warp.Types
36import Network.Wai.Handler.Warp.Types
52−
37+import Network.Wai.Internal (ResponseReceived (ResponseReceived))
38+import System.Environment (getEnvironment)
39+import System.IO.Error (isFullErrorType, ioeGetErrorType)
53
40
54#if WINDOWS
41#if WINDOWS
55import Network.Wai.Handler.Warp.Windows
42import Network.Wai.Handler.Warp.Windows
56#else
43#else
44+import System.Posix.IO (FdOption(CloseOnExec), setFdOption)
57import Network.Socket (fdSocket)
45import Network.Socket (fdSocket)
58#endif
46#endif
59
47
60-- | Creating 'Connection' for plain HTTP based on a given socket.
48-- | Creating 'Connection' for plain HTTP based on a given socket.
61−socketConnection :: Settings -> Socket -> IO Connection
49+socketConnection :: Socket -> IO Connection
62−#if MIN_VERSION_network(3,1,1)
63−socketConnection set s = do
64−#else
65−socketConnection _ s = do
50+socketConnection s = do
66−#endif
67 bufferPool <- newBufferPool
51 bufferPool <- newBufferPool
68 writeBuf <- allocateBuffer bufferSize
52 writeBuf <- allocateBuffer bufferSize
69 let sendall = Sock.sendAll s
53 let sendall = Sock.sendAll s
70− isH2 <- newIORef False -- HTTP/1.x
71 return Connection {
54 return Connection {
72 connSendMany = Sock.sendMany s
55 connSendMany = Sock.sendMany s
73 , connSendAll = sendall
56 , connSendAll = sendall
74 , connSendFile = sendFile s writeBuf bufferSize sendall
57 , 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
86−#endif
87− , connFree = freeBuffer writeBuf
58+ , connClose = sClose s >> freeBuffer writeBuf
88 , connRecv = receive s bufferPool
59 , connRecv = receive s bufferPool
89− , connRecvBuf = receiveBuf s
90 , connWriteBuffer = writeBuf
60 , connWriteBuffer = writeBuf
91 , connBufferSize = bufferSize
61 , connBufferSize = bufferSize
92− , connHTTP2 = isH2
93 }
62 }
94
63
64+#if __GLASGOW_HASKELL__ < 702
65+allowInterrupt :: IO ()
66+allowInterrupt = unblock $ return ()
67+#endif
68+
95-- | Run an 'Application' on the given port.
69-- | Run an 'Application' on the given port.
96-- This calls 'runSettings' with 'defaultSettings'.
70-- This calls 'runSettings' with 'defaultSettings'.
97run :: Port -> Application -> IO ()
71run :: Port -> Application -> IO ()
@@ -104,7 +78,7 @@ run p = runSettings defaultSettings { settingsPort = p }
104-- Since 3.0.9
78-- Since 3.0.9
105runEnv :: Port -> Application -> IO ()
79runEnv :: Port -> Application -> IO ()
106runEnv p app = do
80runEnv p app = do
107− mp <- lookupEnv "PORT"
81+ mp <- fmap (lookup "PORT") getEnvironment
108
82
109 maybe (run p app) runReadPort mp
83 maybe (run p app) runReadPort mp
110
84
@@ -121,7 +95,7 @@ runSettings :: Settings -> Application -> IO ()
121runSettings set app = withSocketsDo $
95runSettings set app = withSocketsDo $
122 bracket
96 bracket
123 (bindPortTCP (settingsPort set) (settingsHost set))
97 (bindPortTCP (settingsPort set) (settingsHost set))
124− close
98+ sClose
125 (\socket -> do
99 (\socket -> do
126 setSocketCloseOnExec socket
100 setSocketCloseOnExec socket
127 runSettingsSocket set socket app)
101 runSettingsSocket set socket app)
@@ -149,12 +123,10 @@ runSettingsSocket set socket app = do
149 (s, sa) <- accept socket
123 (s, sa) <- accept socket
150#endif
124#endif
151 setSocketCloseOnExec s
125 setSocketCloseOnExec s
152− -- NoDelay causes an error for AF_UNIX.
153− setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
154− conn <- socketConnection set s
126+ conn <- socketConnection s
155 return (conn, sa)
127 return (conn, sa)
156
128
157− closeListenSocket = close socket
129+ closeListenSocket = sClose socket
158
130
159-- | The connection setup action would be expensive. A good example
131-- | The connection setup action would be expensive. A good example
160-- is initialization of TLS.
132-- is initialization of TLS.
@@ -176,9 +148,9 @@ runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMa
176-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
148-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
177runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
149runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
178runSettingsConnectionMaker x y =
150runSettingsConnectionMaker x y =
179− runSettingsConnectionMakerSecure x (toTCP <$> y)
151+ runSettingsConnectionMakerSecure x (go y)
180 where
152 where
181− toTCP = first ((, TCP) <$>)
153+ go = fmap (first (fmap (, TCP)))
182
154
183----------------------------------------------------------------
155----------------------------------------------------------------
184
156
@@ -192,23 +164,17 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),
192runSettingsConnectionMakerSecure set getConnMaker app = do
164runSettingsConnectionMakerSecure set getConnMaker app = do
193 settingsBeforeMainLoop set
165 settingsBeforeMainLoop set
194 counter <- newCounter
166 counter <- newCounter
167+
168+ D.withDateCache $ \dc ->
169+ F.withFdCache fdCacheDurationInSeconds $ \fc ->
170+ withTimeoutManager $ \tm ->
195− withII $ acceptConnection set getConnMaker app counter
171+ acceptConnection set getConnMaker app dc fc tm counter
196 where
172 where
197− withII action =
198− withTimeoutManager $ \tm ->
199− D.withDateCache $ \dc ->
200− F.withFdCache fdCacheDurationInSeconds $ \fdc ->
201− I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
202− let ii = InternalInfo tm dc fdc fic
203− action ii
204−
205− !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
173+ fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
206− !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
207− !timeoutInSeconds = settingsTimeout set * 1000000
208 withTimeoutManager f = case settingsManager set of
174 withTimeoutManager f = case settingsManager set of
209 Just tm -> f tm
175 Just tm -> f tm
210 Nothing -> bracket
176 Nothing -> bracket
211− (T.initialize timeoutInSeconds)
177+ (T.initialize $ settingsTimeout set * 1000000)
212 T.stopManager
178 T.stopManager
213 f
179 f
214
180
@@ -228,20 +194,17 @@ runSettingsConnectionMakerSecure set getConnMaker app = do
228acceptConnection :: Settings
194acceptConnection :: Settings
229 -> IO (IO (Connection, Transport), SockAddr)
195 -> IO (IO (Connection, Transport), SockAddr)
230 -> Application
196 -> Application
197+ -> D.DateCache
198+ -> Maybe F.MutableFdCache
199+ -> T.Manager
231 -> Counter
200 -> Counter
232− -> InternalInfo
233 -> IO ()
201 -> IO ()
234−acceptConnection set getConnMaker app counter ii = do
202+acceptConnection set getConnMaker app dc fc tm counter = do
235 -- First mask all exceptions in acceptLoop. This is necessary to
203 -- First mask all exceptions in acceptLoop. This is necessary to
236 -- ensure that no async exception is throw between the call to
204 -- ensure that no async exception is throw between the call to
237 -- acceptNewConnection and the registering of connClose.
205 -- acceptNewConnection and the registering of connClose.
238− --
239− -- acceptLoop can be broken by closing the listing socket.
240− void $ mask_ acceptLoop
206+ 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
207+ gracefulShutdown counter
245 where
208 where
246 acceptLoop = do
209 acceptLoop = do
247 -- Allow async exceptions before receiving the next connection maker.
210 -- Allow async exceptions before receiving the next connection maker.
@@ -258,21 +221,24 @@ acceptConnection set getConnMaker app counter ii = do
258 case mx of
221 case mx of
259 Nothing -> return ()
222 Nothing -> return ()
260 Just (mkConn, addr) -> do
223 Just (mkConn, addr) -> do
261− fork set mkConn addr app counter ii
224+ fork set mkConn addr app dc fc tm counter
262 acceptLoop
225 acceptLoop
263
226
264 acceptNewConnection = do
227 acceptNewConnection = do
265 ex <- try getConnMaker
228 ex <- try getConnMaker
266 case ex of
229 case ex of
267 Right x -> return $ Just x
230 Right x -> return $ Just x
268− Left e -> do
231+ Left e -> do
269− let eConnAborted = getErrno eCONNABORTED
232+ settingsOnException set Nothing $ toException e
270− getErrno (Errno cInt) = cInt
233+ if isFullErrorType (ioeGetErrorType e) then do
271− if ioe_errno e == Just eConnAborted
234+ -- "resource exhausted (Too many open files)" may
235+ -- happen by accept(). Wait a second hoping that
236+ -- resource will be available.
237+ threadDelay 1000000
272− then acceptNewConnection
238+ acceptNewConnection
273− else do
239+ else
274− settingsOnException set Nothing $ toException e
240+ -- Assuming the listen socket is closed.
275− return Nothing
241+ return Nothing
276
242
277-- Fork a new worker thread for this connection maker, and ask for a
243-- Fork a new worker thread for this connection maker, and ask for a
278-- function to unmask (i.e., allow async exceptions to be thrown).
244-- function to unmask (i.e., allow async exceptions to be thrown).
@@ -280,97 +246,63 @@ fork :: Settings
280 -> IO (Connection, Transport)
246 -> IO (Connection, Transport)
281 -> SockAddr
247 -> SockAddr
282 -> Application
248 -> Application
249+ -> D.DateCache
250+ -> Maybe F.MutableFdCache
251+ -> T.Manager
283 -> Counter
252 -> Counter
284− -> InternalInfo
285 -> IO ()
253 -> IO ()
286−fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
254+fork set mkConn addr app dc fc tm counter = settingsFork set $ \ unmask ->
287− -- Call the user-supplied on exception code if any
288− -- exceptions are thrown.
289− handle (settingsOnException set Nothing) $
290− -- Run the connection maker to get a new connection, and ensure
255+ -- Run the connection maker to get a new connection, and ensure
291− -- that the connection is closed. If the mkConn call throws an
256+ -- that the connection is closed. If the mkConn call throws an
292− -- exception, we will leak the connection. If the mkConn call is
257+ -- exception, we will leak the connection. If the mkConn call is
293− -- vulnerable to attacks (e.g., Slowloris), we do nothing to
258+ -- vulnerable to attacks (e.g., Slowloris), we do nothing to
294− -- protect the server. It is therefore vital that mkConn is well
259+ -- protect the server. It is therefore vital that mkConn is well
295− -- vetted.
260+ -- vetted.
296− --
261+ --
297− -- We grab the connection before registering timeouts since the
262+ -- We grab the connection before registering timeouts since the
298− -- timeouts will be useless during connection creation, due to the
263+ -- timeouts will be useless during connection creation, due to the
299− -- fact that async exceptions are still masked.
264+ -- fact that async exceptions are still masked.
300− bracket mkConn cleanUp (serve unmask)
265+ bracket mkConn closeConn $ \(conn, transport) ->
301− where
302− cleanUp (conn, _) = connClose conn `finally` connFree conn
303
266
304 -- We need to register a timeout handler for this thread, and
267 -- We need to register a timeout handler for this thread, and
305 -- cancel that handler as soon as we exit.
268 -- cancel that handler as soon as we exit.
306− serve unmask (conn, transport) = bracket register cancel $ \th -> do
269+ bracket (T.registerKillThread tm) T.cancel $ \th ->
270+
271+ let ii = InternalInfo th fc dc
307− -- We now have fully registered a connection close handler in
272+ -- We now have fully registered a connection close handler
308− -- the case of all exceptions, so it is safe to once again
273+ -- in the case of all exceptions, so it is safe to one
309− -- allow async exceptions.
274+ -- again allow async exceptions.
310− unmask .
275+ in unmask .
276+ -- Call the user-supplied on exception code if any
277+ -- exceptions are thrown.
278+ handle (settingsOnException set Nothing) .
279+
311− -- Call the user-supplied code for connection open and
280+ -- Call the user-supplied code for connection open and close events
312− -- close events
313− bracket (onOpen addr) (onClose addr) $ \goingon ->
281+ bracket (onOpen addr) (onClose addr) $ \goingon ->
282+
314− -- Actually serve this connection. bracket with closeConn
283+ -- Actually serve this connection.
315− -- above ensures the connection is closed.
284+ -- bracket with closeConn above ensures the connection is closed.
316− when goingon $ serveConnection conn ii th addr transport set app
285+ when goingon $ serveConnection conn ii addr transport set app
317− where
286+ where
318− register = T.registerKillThread (timeoutManager ii) (connClose conn)
287+ closeConn (conn, _transport) = connClose conn
319− cancel = T.cancel
320
288
321 onOpen adr = increase counter >> settingsOnOpen set adr
289 onOpen adr = increase counter >> settingsOnOpen set adr
322 onClose adr _ = decrease counter >> settingsOnClose set adr
290 onClose adr _ = decrease counter >> settingsOnClose set adr
323
291
324serveConnection :: Connection
292serveConnection :: Connection
325 -> InternalInfo
293 -> InternalInfo
326− -> T.Handle
327 -> SockAddr
294 -> SockAddr
328 -> Transport
295 -> Transport
329 -> Settings
296 -> Settings
330 -> Application
297 -> Application
331 -> IO ()
298 -> IO ()
332−serveConnection conn ii th origAddr transport settings app = do
299+serveConnection conn ii origAddr transport settings app = do
333− -- fixme: Upgrading to HTTP/2 should be supported.
334− (h2,bs) <- if isHTTP2 transport then
335− return (True, "")
336− else do
337− bs0 <- connRecv conn
338− if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0 then
339− return (True, bs0)
340− else
341− return (False, bs0)
342 istatus <- newIORef False
300 istatus <- newIORef False
343− if settingsHTTP2Enabled settings && h2 then do
344− rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
345− -- This thread becomes the sender in http2 library.
346− -- In the case of event source, one request comes and one
347− -- worker gets busy. But it is likely that the receiver does
348− -- not receive any data at all while the sender is sending
349− -- output data from the worker. It's not good enough to tickle
350− -- the time handler in the receiver only. So, we should tickle
351− -- the time handler in both the receiver and the sender.
352− let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
353− sendBS x = connSendAll conn x >> T.tickle th
354− -- fixme: origAddr
355− checkTLS
356− setConnHTTP2 conn True
357− http2 conn transport ii origAddr settings recvN sendBS app
358− else do
359− src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
301+ src <- mkSource (connSource conn th istatus)
360− writeIORef istatus True
361− leftoverSource src bs
362− addr <- getProxyProtocolAddr src
302+ addr <- getProxyProtocolAddr src
363− http1 True addr istatus src `E.catch` \e ->
303+ http1 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
304+ sendErrorResponse addr istatus e
373− throwIO e
305+ throwIO (e :: SomeException)
374
306
375 where
307 where
376 getProxyProtocolAddr src =
308 getProxyProtocolAddr src =
@@ -413,38 +345,30 @@ serveConnection conn ii th origAddr transport settings app = do
413
345
414 decodeAscii = map (chr . fromEnum) . S.unpack
346 decodeAscii = map (chr . fromEnum) . S.unpack
415
347
416− shouldSendErrorResponse se
348+ th = threadHandle ii
417− | Just ConnectionClosedByPeer <- fromException se = False
418− | otherwise = True
419
349
420− sendErrorResponse req istatus e = do
350+ sendErrorResponse addr istatus e = do
421 status <- readIORef istatus
351 status <- readIORef istatus
422− if shouldSendErrorResponse e && status
352+ when status $ void $
423− then do
353+ sendResponse
354+ (settingsServerName settings)
424− sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)
355+ conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)
425− else return False
426
356
427 dummyreq addr = defaultRequest { remoteHost = addr }
357 dummyreq addr = defaultRequest { remoteHost = addr }
428
358
429 errorResponse e = settingsOnExceptionResponse settings e
359 errorResponse e = settingsOnExceptionResponse settings e
430
360
431− http1 firstRequest addr istatus src = do
361+ http1 addr istatus src = do
432− (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport
362+ (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest settings conn ii addr src
363+ let req = req' { isSecure = isTransportSecure transport }
433 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
364 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
434 `E.catch` \e -> do
365 `E.catch` \e -> do
366+ -- Call the user-supplied exception handlers, passing the request.
367+ sendErrorResponse addr istatus e
435 settingsOnException settings (Just req) e
368 settingsOnException settings (Just req) e
436 -- Don't throw the error again to prevent calling settingsOnException twice.
369 -- Don't throw the error again to prevent calling settingsOnException twice.
437 return False
370 return False
438−
439− -- When doing a keep-alive connection, the other side may just
440− -- close the connection. We don't want to treat that as an
441− -- exceptional situation, so we pass in False to http1 (which
442− -- in turn passes in False to recvRequest), indicating that
443− -- this is not the first request. If, when trying to read the
444− -- request headers, no data is available, recvRequest will
445− -- throw a NoKeepAliveRequest exception, which we catch here
446− -- and ignore. See: https://github.com/yesodweb/wai/issues/618
447− when keepAlive $ http1 False addr istatus src
371+ when keepAlive $ http1 addr istatus src
448
372
449 processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do
373 processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do
450 -- Let the application run for as long as it wants
374 -- Let the application run for as long as it wants
@@ -454,38 +378,32 @@ serveConnection conn ii th origAddr transport settings app = do
454 -- creating the request, we need to make sure that we don't get
378 -- creating the request, we need to make sure that we don't get
455 -- an async exception before calling the ResponseSource.
379 -- an async exception before calling the ResponseSource.
456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
380 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
457− r <- E.try $ app req $ \res -> do
381+ _ <- app req $ \res -> do
458 T.resume th
382 T.resume th
459 -- FIXME consider forcing evaluation of the res here to
383 -- FIXME consider forcing evaluation of the res here to
460 -- send more meaningful error messages to the user.
384 -- send more meaningful error messages to the user.
461 -- However, it may affect performance.
385 -- However, it may affect performance.
462 writeIORef istatus False
386 writeIORef istatus False
387+ keepAlive <- sendResponse
388+ (settingsServerName settings)
463− keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res
389+ conn ii req idxhdr (readSource src) res
464 writeIORef keepAliveRef keepAlive
390 writeIORef keepAliveRef keepAlive
465 return ResponseReceived
391 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
392 keepAlive <- readIORef keepAliveRef
476
393
477 -- We just send a Response and it takes a time to
394 -- We just send a Response and it takes a time to
478 -- receive a Request again. If we immediately call recv,
395 -- receive a Request again. If we immediately call recv,
479− -- it is likely to fail and cause the IO manager to do some work.
396+ -- it is likely to fail and the IO manager works.
480− -- It is very costly, so we yield to another Haskell
397+ -- It is very costly. So, we yield to another Haskell
481 -- thread hoping that the next Request will arrive
398 -- thread hoping that the next Request will arrive
482 -- when this Haskell thread will be re-scheduled.
399 -- when this Haskell thread will be re-scheduled.
483 -- This improves performance at least when
400 -- This improves performance at least when
484 -- the number of cores is small.
401 -- the number of cores is small.
485 Conc.yield
402 Conc.yield
486
403
487− if keepAlive
404+ if not keepAlive then
488− then
405+ return False
406+ else do
489 -- If there is an unknown or large amount of data to still be read
407 -- 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
408 -- from the request body, simple drop this connection instead of
491 -- reading it all in to satisfy a keep-alive request.
409 -- reading it all in to satisfy a keep-alive request.
@@ -511,21 +429,6 @@ serveConnection conn ii th origAddr transport settings app = do
511 else
429 else
512 return False
430 return False
513 Nothing -> tryKeepAlive
431 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
432
530flushEntireBody :: IO ByteString -> IO ()
433flushEntireBody :: IO ByteString -> IO ()
531flushEntireBody src =
434flushEntireBody src =
@@ -550,50 +453,22 @@ flushBody src =
550 | toRead' >= 0 -> loop toRead'
453 | toRead' >= 0 -> loop toRead'
551 | otherwise -> return False
454 | otherwise -> return False
552
455
553−wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString
456+connSource :: Connection -> T.Handle -> IORef Bool -> IO ByteString
554−wrappedRecv Connection { connRecv = recv } th istatus slowlorisSize = do
457+connSource Connection { connRecv = recv } th istatus = do
555 bs <- recv
458 bs <- recv
556 unless (S.null bs) $ do
459 unless (S.null bs) $ do
557 writeIORef istatus True
460 writeIORef istatus True
558− when (S.length bs >= slowlorisSize) $ T.tickle th
461+ when (S.length bs >= 2048) $ T.tickle th
559 return bs
462 return bs
560
463
561−wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
562−wrappedRecvN th istatus slowlorisSize readN bufsize = do
563− bs <- readN bufsize
564− unless (S.null bs) $ do
565− writeIORef istatus True
566− -- TODO: think about the slowloris protection in HTTP2: current code
567− -- might open a slow-loris attack vector. Rather than timing we should
568− -- consider limiting the per-client connections assuming that in HTTP2
569− -- we should allow only few connections per host (real-world
570− -- deployments with large NATs may be trickier).
571− when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th
572− return bs
573−
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
464-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs
577−--
578−-- @since 3.2.17
579setSocketCloseOnExec :: Socket -> IO ()
465setSocketCloseOnExec :: Socket -> IO ()
580#if WINDOWS
466#if WINDOWS
581setSocketCloseOnExec _ = return ()
467setSocketCloseOnExec _ = return ()
582#else
468#else
583−setSocketCloseOnExec socket = do
469+setSocketCloseOnExec socket =
584−#if MIN_VERSION_network(3,0,0)
470+ setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True
585− fd <- fdSocket socket
586−#else
587− let fd = fdSocket socket
588−#endif
589− F.setFileCloseOnExec $ fromIntegral fd
590#endif
471#endif
591
472
592−gracefulShutdown :: Settings -> Counter -> IO ()
473+gracefulShutdown :: Counter -> IO ()
593−gracefulShutdown set counter =
474+gracefulShutdown counter = waitForZero counter
594− case settingsGracefulShutdownTimeout set of
595− Nothing ->
596− waitForZero counter
597− (Just seconds) ->
598− void (timeout (seconds * microsPerSecond) (waitForZero counter))
599− where microsPerSecond = 1000000
warp/Network/Wai/Handler/Warp/SendFile.hs+29−28
@@ -4,35 +4,35 @@ module Network.Wai.Handler.Warp.SendFile (
4 sendFile
4 sendFile
5 , readSendFile
5 , readSendFile
6 , packHeader -- for testing
6 , packHeader -- for testing
7−#ifndef WINDOWS
8− , positionRead
9−#endif
10 ) where
7 ) where
11
8
9+import Control.Monad (void)
10+import Data.ByteString (ByteString)
12import qualified Data.ByteString as BS
11import qualified Data.ByteString as BS
12+import Network.Sendfile
13import Network.Socket (Socket)
13import Network.Socket (Socket)
14+import Network.Wai.Handler.Warp.Buffer
15+import Network.Wai.Handler.Warp.Types
14
16
15#ifdef WINDOWS
17#ifdef WINDOWS
16−import Foreign.ForeignPtr (newForeignPtr_)
18+import Control.Monad (when)
17−import Foreign.Ptr (plusPtr)
18import qualified System.IO as IO
19import qualified System.IO as IO
20+import Foreign.Ptr (plusPtr)
19#else
21#else
22+# if __GLASGOW_HASKELL__ < 709
23+import Control.Applicative ((<$>))
24+# endif
25+import Data.Word (Word8)
20import Control.Exception
26import Control.Exception
21−import Foreign.C.Error (throwErrno)
22import Foreign.C.Types
27import Foreign.C.Types
23import Foreign.Ptr (Ptr, castPtr, plusPtr)
28import Foreign.Ptr (Ptr, castPtr, plusPtr)
24−import Network.Sendfile
29+import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)
25−import Network.Wai.Handler.Warp.FdCache (openFile, closeFile)
26import System.Posix.Types
30import System.Posix.Types
27#endif
31#endif
28
32
29−import Network.Wai.Handler.Warp.Buffer
30−import Network.Wai.Handler.Warp.Imports
31−import Network.Wai.Handler.Warp.Types
32−
33----------------------------------------------------------------
33----------------------------------------------------------------
34
34
35−-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.
35+-- | Function to send a file based on sendfiel() for Linux\/Mac\/FreeBSD.
36-- This makes use of the file descriptor cache.
36-- This makes use of the file descriptor cache.
37-- For other OSes, this is identical to 'readSendFile'.
37-- For other OSes, this is identical to 'readSendFile'.
38--
38--
@@ -66,7 +66,8 @@ packHeader buf siz send hook (bs:bss) n
66 let dst = buf `plusPtr` n
66 let dst = buf `plusPtr` n
67 (bs1, bs2) = BS.splitAt room bs
67 (bs1, bs2) = BS.splitAt room bs
68 void $ copy dst bs1
68 void $ copy dst bs1
69− bufferIO buf siz send
69+ entire <- toBS buf siz
70+ send entire
70 hook
71 hook
71 packHeader buf siz send hook (bs2:bss) 0
72 packHeader buf siz send hook (bs2:bss) 0
72 where
73 where
@@ -92,10 +93,10 @@ readSendFile buf siz send fid off0 len0 hook headers = do
92 IO.withBinaryFile path IO.ReadMode $ \h -> do
93 IO.withBinaryFile path IO.ReadMode $ \h -> do
93 IO.hSeek h IO.AbsoluteSeek off0
94 IO.hSeek h IO.AbsoluteSeek off0
94 n <- IO.hGetBufSome h buf' (mini room len0)
95 n <- IO.hGetBufSome h buf' (mini room len0)
95− bufferIO buf (hn + n) send
96+ bs <- toBSD buf (hn + n)
96− hook
97 let n' = fromIntegral n
97 let n' = fromIntegral n
98− fptr <- newForeignPtr_ buf
98+ send bs
99+ hook
99 loop h fptr (len0 - n')
100 loop h fptr (len0 - n')
100 where
101 where
101 path = fileIdPath fid
102 path = fileIdPath fid
@@ -117,33 +118,33 @@ readSendFile buf siz send fid off0 len0 hook headers =
117 let room = siz - hn
118 let room = siz - hn
118 buf' = buf `plusPtr` hn
119 buf' = buf `plusPtr` hn
119 n <- positionRead fd buf' (mini room len0) off0
120 n <- positionRead fd buf' (mini room len0) off0
120− bufferIO buf (hn + n) send
121+ bs <- toBS buf (hn + n)
121− hook
122 let n' = fromIntegral n
122 let n' = fromIntegral n
123+ send bs
124+ hook
123 loop fd (len0 - n') (off0 + n')
125 loop fd (len0 - n') (off0 + n')
124 where
126 where
125 path = fileIdPath fid
127 path = fileIdPath fid
126 setup = case fileIdFd fid of
128 setup = case fileIdFd fid of
127 Just fd -> return fd
129 Just fd -> return fd
128− Nothing -> openFile path
130+ Nothing -> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}
129 teardown fd = case fileIdFd fid of
131 teardown fd = case fileIdFd fid of
130 Just _ -> return ()
132 Just _ -> return ()
131− Nothing -> closeFile fd
133+ Nothing -> closeFd fd
132 loop fd len off
134 loop fd len off
133 | len <= 0 = return ()
135 | len <= 0 = return ()
134 | otherwise = do
136 | otherwise = do
135 n <- positionRead fd buf (mini siz len) off
137 n <- positionRead fd buf (mini siz len) off
136− bufferIO buf n send
138+ bs <- toBS buf n
137 let n' = fromIntegral n
139 let n' = fromIntegral n
140+ send bs
138 hook
141 hook
139 loop fd (len - n') (off + n')
142 loop fd (len - n') (off + n')
140
143
141−positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int
144+positionRead :: Fd -> Ptr Word8 -> Int -> Integer -> IO Int
142−positionRead fd buf siz off = do
145+positionRead (Fd fd) buf siz off =
143− bytes <- fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)
146+ fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)
144− when (bytes < 0) $ throwErrno "positionRead"
145− return bytes
146
147
147foreign import ccall unsafe "pread"
148foreign import ccall unsafe "pread"
148− c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize
149+ c_pread :: CInt -> Ptr CChar -> ByteCount -> FileOffset -> IO ByteCount -- fixme
149#endif
150#endif
warp/Network/Wai/Handler/Warp/Settings.hs+31−93
@@ -1,30 +1,29 @@
1{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}
1{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}
2{-# LANGUAGE PatternGuards, RankNTypes #-}
2{-# LANGUAGE PatternGuards, RankNTypes #-}
3−{-# LANGUAGE ImpredicativeTypes, CPP #-}
3+{-# LANGUAGE ImpredicativeTypes #-}
4
4
5module Network.Wai.Handler.Warp.Settings where
5module Network.Wai.Handler.Warp.Settings where
6
6
7−import Control.Concurrent (forkIOWithUnmask)
8import Control.Exception
7import Control.Exception
9−import Data.ByteString.Builder (byteString)
8+import Control.Monad (when, void)
10−import qualified Data.ByteString.Char8 as C8
9+import Control.Concurrent (forkIOWithUnmask)
11−import Data.ByteString.Lazy (fromStrict)
12−import Data.Streaming.Network (HostPreference)
13import qualified Data.Text as T
10import qualified Data.Text as T
14import qualified Data.Text.IO as TIO
11import qualified Data.Text.IO as TIO
15−import Data.Version (showVersion)
12+import Data.Streaming.Network (HostPreference)
16import GHC.IO.Exception (IOErrorType(..))
13import GHC.IO.Exception (IOErrorType(..))
17import qualified Network.HTTP.Types as H
14import qualified Network.HTTP.Types as H
18−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
19import Network.Socket (SockAddr)
15import Network.Socket (SockAddr)
20import Network.Wai
16import Network.Wai
21−import qualified Paths_warp
17+import Network.Wai.Handler.Warp.Timeout
18+import Network.Wai.Handler.Warp.Types
22import System.IO (stderr)
19import System.IO (stderr)
23import System.IO.Error (ioeGetErrorType)
20import System.IO.Error (ioeGetErrorType)
24−import System.TimeManager
21+import qualified Data.Text.Lazy as TL
25−
22+import qualified Data.Text.Lazy.Encoding as TLE
26−import Network.Wai.Handler.Warp.Imports
23+import Data.ByteString (ByteString)
27−import Network.Wai.Handler.Warp.Types
24+import qualified Data.ByteString.Char8 as S8
25+import Data.Version (showVersion)
26+import qualified Paths_warp
28
27
29-- | Various Warp server settings. This is purposely kept as an abstract data
28-- | Various Warp server settings. This is purposely kept as an abstract data
30-- type so that new settings can be added without breaking backwards
29-- type so that new settings can be added without breaking backwards
@@ -47,7 +46,6 @@ data Settings = Settings
47 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
46 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
48 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
47 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
49 , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0
48 , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0
50− , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0
51 , settingsBeforeMainLoop :: IO ()
49 , settingsBeforeMainLoop :: IO ()
52 -- ^ Code to run after the listening socket is ready but before entering
50 -- ^ Code to run after the listening socket is ready but before entering
53 -- the main event loop. Useful for signaling to tests that they can start
51 -- the main event loop. Useful for signaling to tests that they can start
@@ -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,7 @@ 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
99− -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048
100− --
101− -- Since 3.1.2
102− , settingsHTTP2Enabled :: Bool
103− -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True
104− --
105− -- Since 3.1.7
106− , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()
107− -- ^ A log function. Default: no action.
108− --
109− -- Since 3.1.10
110− , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
111− -- ^ A HTTP/2 server push log function. Default: no action.
112− --
113− -- Since 3.2.7
114− , settingsGracefulShutdownTimeout :: Maybe Int
115− -- ^ An optional timeout to limit the time (in seconds) waiting for
116− -- a graceful shutdown of the web server.
117− --
118− -- Since 3.2.8
119− , settingsGracefulCloseTimeout1 :: Int
120− -- ^ A timeout to limit the time (in milliseconds) waiting for
121− -- FIN for HTTP/1.x. 0 means uses immediate close.
122− -- Default: 0.
123− --
124− -- Since 3.3.5
125− , settingsGracefulCloseTimeout2 :: Int
126− -- ^ A timeout to limit the time (in milliseconds) waiting for
127− -- FIN for HTTP/2. 0 means uses immediate close.
128− -- Default: 2000.
129− --
130− -- Since 3.3.5
131− , settingsMaxTotalHeaderLength :: Int
132− -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.
133− --
134− -- Since 3.3.8
135 }
89 }
136
90
137-- | Specify usage of the PROXY protocol.
91-- | Specify usage of the PROXY protocol.
@@ -155,22 +109,13 @@ defaultSettings = Settings
155 , settingsTimeout = 30
109 , settingsTimeout = 30
156 , settingsManager = Nothing
110 , settingsManager = Nothing
157 , settingsFdCacheDuration = 0
111 , settingsFdCacheDuration = 0
158− , settingsFileInfoCacheDuration = 0
159 , settingsBeforeMainLoop = return ()
112 , settingsBeforeMainLoop = return ()
160 , settingsFork = void . forkIOWithUnmask
113 , settingsFork = void . forkIOWithUnmask
161 , settingsNoParsePath = False
114 , settingsNoParsePath = False
162 , settingsInstallShutdownHandler = const $ return ()
115 , settingsInstallShutdownHandler = const $ return ()
163− , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version
116+ , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version
164 , settingsMaximumBodyFlush = Just 8192
117 , settingsMaximumBodyFlush = Just 8192
165 , settingsProxyProtocol = ProxyProtocolNone
118 , settingsProxyProtocol = ProxyProtocolNone
166− , settingsSlowlorisSize = 2048
167− , settingsHTTP2Enabled = True
168− , settingsLogger = \_ _ _ -> return ()
169− , settingsServerPushLogger = \_ _ _ -> return ()
170− , settingsGracefulShutdownTimeout = Nothing
171− , settingsGracefulCloseTimeout1 = 0
172− , settingsGracefulCloseTimeout2 = 2000
173− , settingsMaxTotalHeaderLength = 50 * 1024
174 }
119 }
175
120
176-- | Apply the logic provided by 'defaultOnException' to determine if an
121-- | Apply the logic provided by 'defaultOnException' to determine if an
@@ -196,36 +141,29 @@ defaultOnException _ e =
196 when (defaultShouldDisplayException e)
141 when (defaultShouldDisplayException e)
197 $ TIO.hPutStrLn stderr $ T.pack $ show e
142 $ TIO.hPutStrLn stderr $ T.pack $ show e
198
143
199−-- | Sending 400 for bad requests.
200−-- Sending 500 for internal server errors.
144+-- | Sending 400 for bad requests. Sending 500 for internal server errors.
145+--
201-- Since: 3.1.0
146-- 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
147defaultOnExceptionResponse :: SomeException -> Response
206defaultOnExceptionResponse e
148defaultOnExceptionResponse e
207− | Just (_ :: InvalidRequest) <-
208− fromException e = responseLBS H.badRequest400
149+ | 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
150+ | 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
151
223-- | Exception handler for the debugging purpose.
152-- | Exception handler for the debugging purpose.
224-- 500, text/plain, a showed exception.
153-- 500, text/plain, a showed exception.
225--
154--
226-- Since: 2.0.3.2
155-- Since: 2.0.3.2
227exceptionResponseForDebug :: SomeException -> Response
156exceptionResponseForDebug :: SomeException -> Response
228−exceptionResponseForDebug e =
229− responseBuilder H.internalServerError500
230− [(H.hContentType, "text/plain; charset=utf-8")]
157+exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] (TLE.encodeUtf8 $ TL.pack $ "Exception: " ++ show e)
231− $ byteString . C8.pack $ "Exception: " ++ show e
158+
159+{-# DEPRECATED settingsPort "Use setPort instead" #-}
160+{-# DEPRECATED settingsHost "Use setHost instead" #-}
161+{-# DEPRECATED settingsOnException "Use setOnException instead" #-}
162+{-# DEPRECATED settingsOnExceptionResponse "Use setOnExceptionResponse instead" #-}
163+{-# DEPRECATED settingsOnOpen "Use setOnOpen instead" #-}
164+{-# DEPRECATED settingsOnClose "Use setOnClose instead" #-}
165+{-# DEPRECATED settingsTimeout "Use setTimeout instead" #-}
166+{-# DEPRECATED settingsManager "Use setManager instead" #-}
167+{-# DEPRECATED settingsFdCacheDuration "Use setFdCacheDuration instead" #-}
168+{-# DEPRECATED settingsBeforeMainLoop "Use setBeforeMainLoop instead" #-}
169+{-# DEPRECATED settingsNoParsePath "Use setNoParsePath instead" #-}
time-manager/System/TimeManager.hs → warp/Network/Wai/Handler/Warp/Timeout.hsrenamed+51−39
@@ -1,6 +1,9 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE UnboxedTuples #-} -- for GHC 7.4 or earlier
2
5
3−module System.TimeManager (
6+module Network.Wai.Handler.Warp.Timeout (
4 -- ** Types
7 -- ** Types
5 Manager
8 Manager
6 , TimeoutAction
9 , TimeoutAction
@@ -8,7 +11,6 @@ module System.TimeManager (
8 -- ** Manager
11 -- ** Manager
9 , initialize
12 , initialize
10 , stopManager
13 , stopManager
11− , killManager
12 , withManager
14 , withManager
13 -- ** Registration
15 -- ** Registration
14 , register
16 , register
@@ -22,12 +24,25 @@ module System.TimeManager (
22 , TimeoutThread (..)
24 , TimeoutThread (..)
23 ) where
25 ) where
24
26
27+#ifndef MIN_VERSION_base
28+#define MIN_VERSION_base(x,y,z) 1
29+#endif
30+
31+#if MIN_VERSION_base(4,6,0)
32+import Control.Concurrent (mkWeakThreadId, ThreadId)
33+#else
34+import GHC.Conc (ThreadId(..))
35+import GHC.Exts (mkWeak#)
36+import GHC.IO (IO (IO))
37+#endif
25import Control.Concurrent (myThreadId)
38import Control.Concurrent (myThreadId)
26import qualified Control.Exception as E
39import qualified Control.Exception as E
27−import Control.Reaper
40+import GHC.Weak (Weak (..))
41+import Network.Wai.Handler.Warp.IORef (IORef)
42+import qualified Network.Wai.Handler.Warp.IORef as I
43+import System.Mem.Weak (deRefWeak)
28import Data.Typeable (Typeable)
44import Data.Typeable (Typeable)
29−import Data.IORef (IORef)
45+import Control.Reaper
30−import qualified Data.IORef as I
31
46
32----------------------------------------------------------------
47----------------------------------------------------------------
33
48
@@ -38,7 +53,7 @@ type Manager = Reaper [Handle] Handle
38type TimeoutAction = IO ()
53type TimeoutAction = IO ()
39
54
40-- | A handle used by 'Manager'
55-- | A handle used by 'Manager'
41−data Handle = Handle !(IORef TimeoutAction) !(IORef State)
56+data Handle = Handle TimeoutAction (IORef State)
42
57
43data State = Active -- Manager turns it to Inactive.
58data State = Active -- Manager turns it to Inactive.
44 | Inactive -- Manager removes it with timeout action.
59 | Inactive -- Manager removes it with timeout action.
@@ -55,11 +70,10 @@ initialize timeout = mkReaper defaultReaperSettings
55 , reaperDelay = timeout
70 , reaperDelay = timeout
56 }
71 }
57 where
72 where
58− prune m@(Handle actionRef stateRef) = do
73+ prune m@(Handle onTimeout iactive) = do
59− state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x))
74+ state <- I.atomicModifyIORef' iactive (\x -> (inactivate x, x))
60 case state of
75 case state of
61 Inactive -> do
76 Inactive -> do
62− onTimeout <- I.readIORef actionRef
63 onTimeout `E.catch` ignoreAll
77 onTimeout `E.catch` ignoreAll
64 return Nothing
78 return Nothing
65 Canceled -> return Nothing
79 Canceled -> return Nothing
@@ -70,70 +84,68 @@ initialize timeout = mkReaper defaultReaperSettings
70
84
71----------------------------------------------------------------
85----------------------------------------------------------------
72
86
73−-- | Stopping timeout manager with onTimeout fired.
87+-- | Stopping timeout manager.
74stopManager :: Manager -> IO ()
88stopManager :: Manager -> IO ()
75stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)
89stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)
76 where
90 where
77− fire (Handle actionRef _) = do
78− onTimeout <- I.readIORef actionRef
79− onTimeout `E.catch` ignoreAll
91+ fire (Handle onTimeout _) = onTimeout `E.catch` ignoreAll
80
92
81ignoreAll :: E.SomeException -> IO ()
93ignoreAll :: E.SomeException -> IO ()
82ignoreAll _ = return ()
94ignoreAll _ = return ()
83
95
84−-- | Killing timeout manager immediately without firing onTimeout.
85−killManager :: Manager -> IO ()
86−killManager = reaperKill
87−
88----------------------------------------------------------------
96----------------------------------------------------------------
89
97
90-- | Registering a timeout action.
98-- | Registering a timeout action.
91register :: Manager -> TimeoutAction -> IO Handle
99register :: Manager -> TimeoutAction -> IO Handle
92register mgr onTimeout = do
100register mgr onTimeout = do
93− actionRef <- I.newIORef onTimeout
94− stateRef <- I.newIORef Active
101+ iactive <- I.newIORef Active
95− let h = Handle actionRef stateRef
102+ let h = Handle onTimeout iactive
96 reaperAdd mgr h
103 reaperAdd mgr h
97 return h
104 return h
98
105
99-- | Registering a timeout action of killing this thread.
106-- | Registering a timeout action of killing this thread.
100−registerKillThread :: Manager -> TimeoutAction -> IO Handle
107+registerKillThread :: Manager -> IO Handle
101−registerKillThread m onTimeout = do
108+registerKillThread m = do
102− -- If we hold ThreadId, the stack and data of the thread is leaked.
109+ wtid <- myThreadId >>= mkWeakThreadId
103− -- If we hold Weak ThreadId, the stack is released. However, its
110+ register m $ killIfExist wtid
104− -- data is still leaked probably because of a bug of GHC.
111+
105− -- So, let's just use ThreadId and release ThreadId by
112+-- If ThreadId is hold referred by a strong reference,
106− -- overriding the timeout action by "cancel".
113+-- it leaks even after the thread is killed.
107− tid <- myThreadId
114+-- So, let's use a weak reference so that CG can throw ThreadId away.
108− -- First run the timeout action in case the child thread is masked.
115+-- deRefWeak checks if ThreadId referenced by the weak reference
109− register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread
116+-- exists. If exists, it means that the thread is alive.
117+killIfExist :: Weak ThreadId -> TimeoutAction
118+killIfExist wtid = deRefWeak wtid >>= maybe (return ()) (`E.throwTo` TimeoutThread)
110
119
111data TimeoutThread = TimeoutThread
120data TimeoutThread = TimeoutThread
112 deriving Typeable
121 deriving Typeable
113−instance E.Exception TimeoutThread where
122+instance E.Exception TimeoutThread
114− toException = E.asyncExceptionToException
115− fromException = E.asyncExceptionFromException
116instance Show TimeoutThread where
123instance Show TimeoutThread where
117− show TimeoutThread = "Thread killed by timeout manager"
124+ show TimeoutThread = "Thread killed by Warp's timeout reaper"
125+
126+#if !MIN_VERSION_base(4,6,0)
127+mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
128+mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
129+ case mkWeak# t# t Nothing s of
130+ (# s1, w #) -> (# s1, Weak w #)
131+#endif
118
132
119----------------------------------------------------------------
133----------------------------------------------------------------
120
134
121-- | Setting the state to active.
135-- | Setting the state to active.
122-- 'Manager' turns active to inactive repeatedly.
136-- 'Manager' turns active to inactive repeatedly.
123tickle :: Handle -> IO ()
137tickle :: Handle -> IO ()
124−tickle (Handle _ stateRef) = I.writeIORef stateRef Active
138+tickle (Handle _ iactive) = I.writeIORef iactive Active
125
139
126-- | Setting the state to canceled.
140-- | Setting the state to canceled.
127-- 'Manager' eventually removes this without timeout action.
141-- 'Manager' eventually removes this without timeout action.
128cancel :: Handle -> IO ()
142cancel :: Handle -> IO ()
129−cancel (Handle actionRef stateRef) = do
143+cancel (Handle _ iactive) = I.writeIORef iactive Canceled
130− I.writeIORef actionRef (return ()) -- ensuring to release ThreadId
131− I.writeIORef stateRef Canceled
132
144
133-- | Setting the state to paused.
145-- | Setting the state to paused.
134-- 'Manager' does not change the value.
146-- 'Manager' does not change the value.
135pause :: Handle -> IO ()
147pause :: Handle -> IO ()
136−pause (Handle _ stateRef) = I.writeIORef stateRef Paused
148+pause (Handle _ iactive) = I.writeIORef iactive Paused
137
149
138-- | Setting the paused state to active.
150-- | Setting the paused state to active.
139-- This is an alias to 'tickle'.
151-- This is an alias to 'tickle'.
warp/Network/Wai/Handler/Warp/Types.hs+30−50
@@ -5,18 +5,20 @@
5module Network.Wai.Handler.Warp.Types where
5module Network.Wai.Handler.Warp.Types where
6
6
7import Control.Exception
7import Control.Exception
8+import Data.ByteString (ByteString)
8import qualified Data.ByteString as S
9import qualified Data.ByteString as S
9import Data.IORef (IORef, readIORef, writeIORef, newIORef)
10import Data.IORef (IORef, readIORef, writeIORef, newIORef)
10import Data.Typeable (Typeable)
11import Data.Typeable (Typeable)
11−import Data.X509
12+import Data.Word (Word16, Word8)
12import Foreign.Ptr (Ptr)
13import Foreign.Ptr (Ptr)
13−import System.Posix.Types (Fd)
14+import Network.HTTP.Types.Header
14−import qualified System.TimeManager as T
15−
16import qualified Network.Wai.Handler.Warp.Date as D
15import qualified Network.Wai.Handler.Warp.Date as D
17import qualified Network.Wai.Handler.Warp.FdCache as F
16import qualified Network.Wai.Handler.Warp.FdCache as F
18−import qualified Network.Wai.Handler.Warp.FileInfoCache as I
17+import qualified Network.Wai.Handler.Warp.Timeout as T
19−import Network.Wai.Handler.Warp.Imports
18+
19+#ifndef WINDOWS
20+import System.Posix.Types (Fd)
21+#endif
20
22
21----------------------------------------------------------------
23----------------------------------------------------------------
22
24
@@ -28,6 +30,18 @@ type Port = Int
28-- | The type for header value used with 'HeaderName'.
30-- | The type for header value used with 'HeaderName'.
29type HeaderValue = ByteString
31type HeaderValue = ByteString
30
32
33+hTransferEncoding :: HeaderName
34+hTransferEncoding = "Transfer-Encoding"
35+
36+hContentRange :: HeaderName
37+hContentRange = "Content-Range"
38+
39+hAcceptRanges :: HeaderName
40+hAcceptRanges = "Accept-Ranges"
41+
42+hServer :: HeaderName
43+hServer = "Server"
44+
31----------------------------------------------------------------
45----------------------------------------------------------------
32
46
33-- | Error types for bad 'Request'.
47-- | Error types for bad 'Request'.
@@ -53,19 +67,9 @@ instance Exception InvalidRequest
53
67
54----------------------------------------------------------------
68----------------------------------------------------------------
55
69
56−-- | Exception thrown if something goes wrong while in the midst of
70+#ifdef WINDOWS
57−-- sending a response, since the status code can't be altered at that
71+type Fd = ()
58−-- point.
72+#endif
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
73
70-- | Data type to abstract file identifiers.
74-- | Data type to abstract file identifiers.
71-- On Unix, a file descriptor would be specified to make use of
75-- On Unix, a file descriptor would be specified to make use of
@@ -91,13 +95,6 @@ type Buffer = Ptr Word8
91-- | Type for buffer size
95-- | Type for buffer size
92type BufSize = Int
96type BufSize = Int
93
97
94−-- | Type for the action to receive input data
95−type Recv = IO ByteString
96−
97−-- | Type for the action to receive input data with a buffer.
98−-- The result boolean indicates whether or not the buffer is fully filled.
99−type RecvBuf = Buffer -> BufSize -> IO Bool
100−
101-- | Data type to manipulate IO actions for connections.
98-- | Data type to manipulate IO actions for connections.
102-- This is used to abstract IO actions for plain HTTP and HTTP over TLS.
99-- This is used to abstract IO actions for plain HTTP and HTTP over TLS.
103data Connection = Connection {
100data Connection = Connection {
@@ -107,39 +104,23 @@ data Connection = Connection {
107 , connSendAll :: ByteString -> IO ()
104 , connSendAll :: ByteString -> IO ()
108 -- | The sending function for files in HTTP/1.1.
105 -- | The sending function for files in HTTP/1.1.
109 , connSendFile :: SendFile
106 , connSendFile :: SendFile
110− -- | The connection closing function. Warp guarantees it will only be
107+ -- | The connection closing function.
111− -- called once. Other functions (like 'connRecv') may be called after
112− -- 'connClose' is called.
113 , connClose :: IO ()
108 , connClose :: IO ()
114− -- | Free any buffers allocated. Warp guarantees it will only be
109+ -- | The connection receiving function.
115− -- called once, and no other functions will be called after it.
110+ , connRecv :: IO ByteString
116− , connFree :: IO ()
117− -- | The connection receiving function. This returns "" for EOF.
118− , connRecv :: Recv
119− -- | The connection receiving function. This tries to fill the buffer.
120− -- This returns when the buffer is filled or reaches EOF.
121− , connRecvBuf :: RecvBuf
122 -- | The write buffer.
111 -- | The write buffer.
123 , connWriteBuffer :: Buffer
112 , connWriteBuffer :: Buffer
124 -- | The size of the write buffer.
113 -- | The size of the write buffer.
125 , connBufferSize :: BufSize
114 , connBufferSize :: BufSize
126− -- | Is this connection HTTP/2?
127− , connHTTP2 :: IORef Bool
128 }
115 }
129
116
130−getConnHTTP2 :: Connection -> IO Bool
131−getConnHTTP2 conn = readIORef (connHTTP2 conn)
132−
133−setConnHTTP2 :: Connection -> Bool -> IO ()
134−setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b
135−
136----------------------------------------------------------------
117----------------------------------------------------------------
137
118
119+-- | Internal information.
138data InternalInfo = InternalInfo {
120data InternalInfo = InternalInfo {
139− timeoutManager :: T.Manager
121+ threadHandle :: T.Handle
140− , getDate :: IO D.GMTDate
122+ , fdCacher :: Maybe F.MutableFdCache
141− , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)
123+ , dateCacher :: D.DateCache
142− , getFileInfo :: FilePath -> IO I.FileInfo
143 }
124 }
144
125
145----------------------------------------------------------------
126----------------------------------------------------------------
@@ -180,7 +161,6 @@ data Transport = TCP -- ^ Plain channel: TCP
180 , tlsMinorVersion :: Int
161 , tlsMinorVersion :: Int
181 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301
162 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301
182 , tlsChiperID :: Word16
163 , tlsChiperID :: Word16
183− , tlsClientCertificate :: Maybe CertificateChain
184 } -- ^ Encrypted channel: TLS or SSL
164 } -- ^ Encrypted channel: TLS or SSL
185
165
186isTransportSecure :: Transport -> Bool
166isTransportSecure :: Transport -> Bool
warp/Network/Wai/Handler/Warp/Windows.hs+1−5
@@ -7,12 +7,8 @@ module Network.Wai.Handler.Warp.Windows
7import Control.Exception
7import Control.Exception
8import Control.Concurrent.MVar
8import Control.Concurrent.MVar
9import Control.Concurrent
9import Control.Concurrent
10+import Control.Monad
10
11
11−import Network.Wai.Handler.Warp.Imports
12−
13−-- | Allow main socket listening thread to be interrupted on Windows platform
14−--
15−-- @since 3.2.17
16windowsThreadBlockHack :: IO a -> IO a
12windowsThreadBlockHack :: IO a -> IO a
17windowsThreadBlockHack act = do
13windowsThreadBlockHack act = do
18 var <- newEmptyMVar :: IO (MVar (Either SomeException a))
14 var <- newEmptyMVar :: IO (MVar (Either SomeException a))
warp/Network/Wai/Handler/Warp/WithApplication.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.Handler.Warp.WithApplication (
3− withApplication,
4− withApplicationSettings,
5− testWithApplication,
6− testWithApplicationSettings,
7− openFreePort,
8− withFreePort,
9−) where
10−
11−import Control.Concurrent
12−import Control.Concurrent.Async
13−import Control.Exception
14−import Control.Monad (when)
15−import Data.Streaming.Network (bindRandomPortTCP)
16−import Network.Socket
17−import Network.Wai
18−import Network.Wai.Handler.Warp.Run
19−import Network.Wai.Handler.Warp.Settings
20−import Network.Wai.Handler.Warp.Types
21−
22−-- | Runs the given 'Application' on a free port. Passes the port to the given
23−-- operation and executes it, while the 'Application' is running. Shuts down the
24−-- server before returning.
25−--
26−-- @since 3.2.4
27−withApplication :: IO Application -> (Port -> IO a) -> IO a
28−withApplication = withApplicationSettings defaultSettings
29−
30−-- | 'withApplication' with given 'Settings'. This will ignore the port value
31−-- set by 'setPort' in 'Settings'.
32−--
33−-- @since 3.2.7
34−withApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a
35−withApplicationSettings settings' mkApp action = do
36− app <- mkApp
37− withFreePort $ \ (port, sock) -> do
38− started <- mkWaiter
39− let settings =
40− settings' {
41− settingsBeforeMainLoop
42− = notify started () >> settingsBeforeMainLoop settings'
43− }
44− result <- race
45− (runSettingsSocket settings sock app)
46− (waitFor started >> action port)
47− case result of
48− Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"
49− Right x -> return x
50−
51−-- | Same as 'withApplication' but with different exception handling: If the
52−-- given 'Application' throws an exception, 'testWithApplication' will re-throw
53−-- the exception to the calling thread, possibly interrupting the execution of
54−-- the given operation.
55−--
56−-- This is handy for running tests against an 'Application' over a real network
57−-- port. When running tests, it's useful to let exceptions thrown by your
58−-- 'Application' propagate to the main thread of the test-suite.
59−--
60−-- __The exception handling makes this function unsuitable for use in production.__
61−-- Use 'withApplication' instead.
62−--
63−-- @since 3.2.4
64−testWithApplication :: IO Application -> (Port -> IO a) -> IO a
65−testWithApplication = testWithApplicationSettings defaultSettings
66−
67−-- | 'testWithApplication' with given 'Settings'.
68−--
69−-- @since 3.2.7
70−testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a
71−testWithApplicationSettings settings mkApp action = do
72− callingThread <- myThreadId
73− app <- mkApp
74− let wrappedApp request respond =
75− app request respond `catch` \ e -> do
76− when
77− (defaultShouldDisplayException e)
78− (throwTo callingThread e)
79− throwIO e
80− withApplicationSettings settings (return wrappedApp) action
81−
82−data Waiter a
83− = Waiter {
84− notify :: a -> IO (),
85− waitFor :: IO a
86− }
87−
88−mkWaiter :: IO (Waiter a)
89−mkWaiter = do
90− mvar <- newEmptyMVar
91− return Waiter {
92− notify = putMVar mvar,
93− waitFor = readMVar mvar
94− }
95−
96−-- | Opens a socket on a free port and returns both port and socket.
97−--
98−-- @since 3.2.4
99−openFreePort :: IO (Port, Socket)
100−openFreePort = bindRandomPortTCP "127.0.0.1"
101−
102−-- | Like 'openFreePort' but closes the socket before exiting.
103−withFreePort :: ((Port, Socket) -> IO a) -> IO a
104−withFreePort = bracket openFreePort (close . snd)
warp/README.md+3−2
@@ -1,3 +1,4 @@
1−# Warp
1+## warp
2
2
3−Warp is a server library for HTTP/1.x and HTTP/2 based WAI(Web Application Interface in Haskell). For more information, see [Warp](http://www.aosabook.org/en/posa/warp.html).
3+The premier WAI handler. For more information, see [Warp: A Haskell Web
4+Server](http://steve.vinoski.net/blog/2011/05/01/warp-a-haskell-web-server/).
warp/attic/server-no-keepalive.hs+1−1
@@ -12,7 +12,7 @@ import Network.Wai (responseLBS)
12import Network.HTTP.Types (status200)
12import Network.HTTP.Types (status200)
13import Data.Enumerator (($$), run_)
13import Data.Enumerator (($$), run_)
14
14
15−app = const $ return $ responseLBS status200 [("Content-type", "text/plain")] "This is not kept alive under any circumstances"
15+app = const $ return $ responseLBS status200 [("Content-type", "text/plain")] "This is not kept alive under any circumtances"
16
16
17main = withManager 30000000 $ \man -> bracket
17main = withManager 30000000 $ \man -> bracket
18 (bindPort (settingsPort set) (settingsHost set))
18 (bindPort (settingsPort set) (settingsHost set))
warp/bench/Parser.hs+16−21
@@ -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
@@ -37,15 +32,15 @@ main = do
37 defaultMain [
32 defaultMain [
38 bgroup "requestLine1" [
33 bgroup "requestLine1" [
39 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1
34 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1
40− , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1
35+ , bench "parseRequestLine2" $ parseRequestLine2 requestLine1
41− , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1
36+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine1
42− , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1
37+ , bench "parseRequestLine0" $ parseRequestLine0 requestLine1
43 ]
38 ]
44 , bgroup "requestLine2" [
39 , bgroup "requestLine2" [
45 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2
40 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2
46− , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2
41+ , bench "parseRequestLine2" $ parseRequestLine2 requestLine2
47− , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2
42+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine2
48− , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2
43+ , bench "parseRequestLine0" $ parseRequestLine0 requestLine2
49 ]
44 ]
50 ]
45 ]
51
46
@@ -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/BufferPoolSpec.hsdeleted−47
@@ -1,47 +0,0 @@
1−module BufferPoolSpec where
2−
3−import qualified Data.ByteString as B
4−import qualified Data.ByteString.Internal as B (ByteString(PS))
5−import Foreign.ForeignPtr (withForeignPtr)
6−import Foreign.Marshal.Utils (copyBytes)
7−import Foreign.Ptr (plusPtr)
8−
9−import Test.Hspec (Spec, hspec, shouldBe, describe, it)
10−
11−import Network.Wai.Handler.Warp.Buffer
12− ( bufferSize
13− , newBufferPool
14− , withBufferPool
15− )
16−import Network.Wai.Handler.Warp.Types (Buffer, BufSize)
17−
18−main :: IO ()
19−main = hspec spec
20−
21−-- Two ByteStrings each big enough to fill a 'bufferSize' buffer (16K).
22−wantData, otherData :: B.ByteString
23−wantData = B.replicate bufferSize 0xac
24−otherData = B.replicate bufferSize 0x77
25−
26−spec :: Spec
27−spec = describe "withBufferPool" $ do
28− it "does not clobber buffers" $ do
29− pool <- newBufferPool
30− -- 'pool' contains B.empty; prime it to contain a real buffer.
31− _ <- withBufferPool pool $ const $ return 0
32− -- 'pool' contains a 16K buffer; fill it with \xac and keep the result.
33− got <- withBufferPool pool $ blitBuffer wantData
34− got `shouldBe` wantData
35− -- 'pool' should now be empty and reallocate, rather than clobber the
36− -- previous buffer.
37− _ <- withBufferPool pool $ blitBuffer otherData
38− got `shouldBe` wantData
39−
40−-- Fill the Buffer with the contents of the ByteString and return the number of
41−-- bytes written. To be used with 'withBufferPool'.
42−blitBuffer :: B.ByteString -> (Buffer, BufSize) -> IO Int
43−blitBuffer (B.PS fp off len) (dst, len') = withForeignPtr fp $ \ptr -> do
44− let src = ptr `plusPtr` off
45− n = min len len'
46− copyBytes dst src n
47− return n
warp/test/ExceptionSpec.hs+30−15
@@ -6,17 +6,17 @@ module ExceptionSpec (main, spec) where
6import Control.Applicative
6import Control.Applicative
7#endif
7#endif
8import Control.Monad
8import Control.Monad
9+import Network.HTTP
10+import Network.Stream
9import Network.HTTP.Types hiding (Header)
11import Network.HTTP.Types hiding (Header)
10−import Network.Wai hiding (Response, responseStatus)
12+import Network.Wai hiding (Response)
11import Network.Wai.Internal (Request(..))
13import Network.Wai.Internal (Request(..))
12import Network.Wai.Handler.Warp
14import Network.Wai.Handler.Warp
13import Test.Hspec
15import Test.Hspec
14import Control.Exception
16import Control.Exception
15import qualified Data.Streaming.Network as N
17import qualified Data.Streaming.Network as N
16import Control.Concurrent.Async (withAsync)
18import Control.Concurrent.Async (withAsync)
17−import Network.Socket (close)
19+import Network.Socket (sClose)
18−
19−import HTTP
20
20
21main :: IO ()
21main :: IO ()
22main = hspec spec
22main = hspec spec
@@ -24,7 +24,7 @@ main = hspec spec
24withTestServer :: (Int -> IO a) -> IO a
24withTestServer :: (Int -> IO a) -> IO a
25withTestServer inner = bracket
25withTestServer inner = bracket
26 (N.bindRandomPortTCP "127.0.0.1")
26 (N.bindRandomPortTCP "127.0.0.1")
27− (close . snd)
27+ (sClose . snd)
28 $ \(prt, lsocket) -> do
28 $ \(prt, lsocket) -> do
29 withAsync (runSettingsSocket defaultSettings lsocket testApp)
29 withAsync (runSettingsSocket defaultSettings lsocket testApp)
30 $ \_ -> inner prt
30 $ \_ -> inner prt
@@ -49,18 +49,33 @@ 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 (concat $ ["http://127.0.0.1:", show prt, "/ioException"])
66− sc `shouldBe` internalServerError500
66+ sc `shouldBe` (5,0,0)
67+
68+----------------------------------------------------------------
69+
70+sendGET :: String -> IO (Response String)
71+sendGET url = sendGETwH url []
72+
73+sendGETwH :: String -> [Header] -> IO (Response String)
74+sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }
75+
76+unResult :: IO (Result (Response String)) -> IO (Response String)
77+unResult action = do
78+ res <- action
79+ case res of
80+ Right rsp -> return rsp
81+ Left _ -> error "Connection error"
warp/test/FdCacheSpec.hs+2−2
@@ -16,8 +16,8 @@ spec :: Spec
16spec = describe "withFdCache" $ do
16spec = 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 $ \(Just mfc) -> do
20− (Just fd,_) <- getFd "warp.cabal"
20+ (fd,_) <- getFd mfc "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.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−module FileSpec (main, spec) where
4−
5−import Network.HTTP.Types
6−import Network.Wai.Handler.Warp.File
7−import Network.Wai.Handler.Warp.FileInfoCache
8−import Network.Wai.Handler.Warp.Header
9−
10−import Test.Hspec
11−
12−main :: IO ()
13−main = hspec spec
14−
15−testFileRange :: String
16− -> RequestHeaders -> FilePath
17− -> RspFileInfo
18− -> Spec
19−testFileRange desc reqhs file ans = it desc $ do
20− finfo <- getInfo file
21− let WithBody s hs off len = ans
22− hs' = ("Last-Modified",fileInfoDate finfo) : hs
23− ans' = WithBody s hs' off len
24− conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans'
25−
26−spec :: Spec
27−spec = do
28− describe "conditionalRequest" $ do
29− testFileRange
30− "gets a file size from file system"
31− [] "attic/hex"
32− $ WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16
33− testFileRange
34− "gets a file size from file system and handles Range and returns Partical Content"
35− [("Range","bytes=2-14")] "attic/hex"
36− $ WithBody status206 [("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")] 2 13
37− testFileRange
38− "truncates end point of range to file size"
39− [("Range","bytes=10-20")] "attic/hex"
40− $ WithBody status206 [("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")] 10 6
41− testFileRange
42− "gets a file size from file system and handles Range and returns OK if Range means the entire"
43− [("Range:","bytes=0-15")] "attic/hex"
44− $ WithBody status200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16
45−
warp/test/HTTP.hsdeleted−41
@@ -1,41 +0,0 @@
1−module HTTP (
2− sendGET
3− , sendGETwH
4− , sendHEAD
5− , sendHEADwH
6− , responseBody
7− , responseStatus
8− , responseHeaders
9− , getHeaderValue
10− , HeaderName
11− ) where
12−
13−import Network.HTTP.Client
14−import Network.HTTP.Types
15−import Data.ByteString
16−import qualified Data.ByteString.Lazy as BL
17−
18−sendGET :: String -> IO (Response BL.ByteString)
19−sendGET url = sendGETwH url []
20−
21−sendGETwH :: String -> [Header] -> IO (Response BL.ByteString)
22−sendGETwH url hdr = do
23− manager <- newManager defaultManagerSettings
24− request <- parseRequest url
25− let request' = request { requestHeaders = hdr }
26− response <- httpLbs request' manager
27− return response
28−
29−sendHEAD :: String -> IO (Response BL.ByteString)
30−sendHEAD url = sendHEADwH url []
31−
32−sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString)
33−sendHEADwH url hdr = do
34− manager <- newManager defaultManagerSettings
35− request <- parseRequest url
36− let request' = request { requestHeaders = hdr, method = methodHead }
37− response <- httpLbs request' manager
38− return response
39−
40−getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString
41−getHeaderValue = lookup
warp/test/MultiMapSpec.hsnew file+30
@@ -0,0 +1,30 @@
1+module MultiMapSpec where
2+
3+import Network.Wai.Handler.Warp.MultiMap
4+import Test.Hspec
5+import Test.QuickCheck (property)
6+
7+type Alist = [(Int,Char)]
8+
9+spec :: Spec
10+spec = do
11+ describe "fromList" $ do
12+ it "generates a valid tree" $ property $ \xs ->
13+ valid $ fromList (xs :: Alist)
14+ describe "toSortedList" $ do
15+ it "generated a sorted list" $ property $ \xs ->
16+ ordered $ toSortedList $ fromList (xs :: Alist)
17+ describe "search" $ do
18+ it "acts as the list model" $ property $ \x xs ->
19+ search x (fromList xs) == lookup x (xs :: Alist)
20+ describe "fromSortedList" $ do
21+ it "generates a valid tree" $ property $ \xs ->
22+ valid . fromSortedList . toSortedList . fromList $ (xs :: Alist)
23+ it "maintains the tree with toSortedList" $ property $ \xs ->
24+ let t1 = fromList (xs :: Alist)
25+ t2 = fromSortedList $ toSortedList t1
26+ in t1 == t2
27+
28+ordered :: Ord a => [(a, b)] -> Bool
29+ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)
30+ordered _ = True
warp/test/RequestSpec.hs+8−12
@@ -4,10 +4,9 @@
4
4
5module RequestSpec (main, spec) where
5module RequestSpec (main, spec) where
6
6
7−import Network.Wai.Handler.Warp.File (parseByteRanges)
8import Network.Wai.Handler.Warp.Request
7import Network.Wai.Handler.Warp.Request
8+import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)
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 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 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 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 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 src
91 x `shouldBe` []
87 x `shouldBe` []
92− y <- headerLines defaultMaxTotalHeaderLength True src
88+ y <- headerLines 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 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+5−25
@@ -5,44 +5,24 @@ module ResponseHeaderSpec (main, spec) where
5import Data.ByteString
5import Data.ByteString
6import qualified Network.HTTP.Types as H
6import qualified Network.HTTP.Types as H
7import Network.Wai.Handler.Warp.ResponseHeader
7import Network.Wai.Handler.Warp.ResponseHeader
8−import Network.Wai.Handler.Warp.Response
9−import Network.Wai.Handler.Warp.Header
10import Test.Hspec
8import Test.Hspec
11
9
12main :: IO ()
10main :: IO ()
13main = hspec spec
11main = hspec spec
14
12
15spec :: Spec
13spec :: Spec
16−spec = do
17− describe "composeHeader" $ do
14+spec = describe "composeHeader" $ do
18− it "composes a HTTP header" $
15+ it "composes a HTTP header" $
19− composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader
16+ composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader
20− describe "addServer" $ do
21− it "adds Server if not exist" $ do
22− let hdrs = []
23− rspidxhdr = indexResponseHeader hdrs
24− addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server","MyServer")]
25− it "does not add Server if exists" $ do
26− let hdrs = [("Server","MyServer")]
27− rspidxhdr = indexResponseHeader hdrs
28− addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs
29− it "does not add Server if empty" $ do
30− let hdrs = []
31− rspidxhdr = indexResponseHeader hdrs
32− addServer "" rspidxhdr hdrs `shouldBe` hdrs
33− it "deletes Server " $ do
34− let hdrs = [("Server","MyServer")]
35− rspidxhdr = indexResponseHeader hdrs
36− addServer "" rspidxhdr hdrs `shouldBe` []
37
17
38headers :: H.ResponseHeaders
18headers :: H.ResponseHeaders
39headers = [
19headers = [
40 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")
20 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")
41− , ("Content-Length", "151")
21+ , ("Content-Lenght", "151")
42 , ("Server", "Mighttpd/2.5.8")
22 , ("Server", "Mighttpd/2.5.8")
43 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")
23 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")
44 , ("Content-Type", "text/html")
24 , ("Content-Type", "text/html")
45 ]
25 ]
46
26
47composedHeader :: ByteString
27composedHeader :: 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"
28+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+65−42
@@ -1,16 +1,17 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2−
3module ResponseSpec (main, spec) where
2module ResponseSpec (main, spec) where
4
3
5import Control.Concurrent (threadDelay)
4import Control.Concurrent (threadDelay)
6import qualified Data.ByteString as S
5import qualified Data.ByteString as S
7import qualified Data.ByteString.Char8 as S8
6import qualified Data.ByteString.Char8 as S8
8import Data.Maybe (mapMaybe)
7import Data.Maybe (mapMaybe)
8+import Network (connectTo, PortID (PortNumber))
9import Network.HTTP.Types
9import Network.HTTP.Types
10−import Network.Wai hiding (responseHeaders)
10+import Network.Wai
11import Network.Wai.Handler.Warp
11import Network.Wai.Handler.Warp
12import Network.Wai.Handler.Warp.Response
12import Network.Wai.Handler.Warp.Response
13−import RunSpec (withApp, msWrite, msRead, withMySocket)
13+import RunSpec (withApp)
14+import System.IO (hClose, hFlush)
14import Test.Hspec
15import Test.Hspec
15
16
16main :: IO ()
17main :: IO ()
@@ -20,13 +21,16 @@ testRange :: S.ByteString -- ^ range value
20 -> String -- ^ expected output
21 -> String -- ^ expected output
21 -> Maybe String -- ^ expected content-range value
22 -> Maybe String -- ^ expected content-range value
22 -> Spec
23 -> Spec
23−testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do
24+testRange range out crange = it title $ withApp defaultSettings app $ \port -> do
25+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
24− msWrite ms "GET / HTTP/1.0\r\n"
26+ S.hPutStr handle "GET / HTTP/1.0\r\n"
25− msWrite ms "Range: bytes="
27+ S.hPutStr handle "Range: bytes="
26− msWrite ms range
28+ S.hPutStr handle range
27− msWrite ms "\r\n\r\n"
29+ S.hPutStr handle "\r\n\r\n"
30+ hFlush handle
28 threadDelay 10000
31 threadDelay 10000
29− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024
32+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024
33+ hClose handle
30 last bss `shouldBe` out
34 last bss `shouldBe` out
31 let hs = mapMaybe toHeader bss
35 let hs = mapMaybe toHeader bss
32 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange
36 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange
@@ -44,10 +48,13 @@ testPartial :: Integer -- ^ file size
44 -> Integer -- ^ byte count
48 -> Integer -- ^ byte count
45 -> String -- ^ expected output
49 -> String -- ^ expected output
46 -> Spec
50 -> Spec
47−testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do
51+testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do
52+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
48− msWrite ms "GET / HTTP/1.0\r\n\r\n"
53+ S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"
54+ hFlush handle
49 threadDelay 10000
55 threadDelay 10000
50− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024
56+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024
57+ hClose handle
51 out `shouldBe` last bss
58 out `shouldBe` last bss
52 let hs = mapMaybe toHeader bss
59 let hs = mapMaybe toHeader bss
53 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)
60 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)
@@ -61,38 +68,20 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ wit
61 _ -> Nothing
68 _ -> Nothing
62 range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size
69 range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size
63
70
71+testFileRange :: String
72+ -> Status -> ResponseHeaders -> FilePath
73+ -> Maybe FilePart -> Maybe HeaderValue
74+ -> Either String (Status, ResponseHeaders, Integer, Integer)
75+ -> Spec
76+testFileRange desc s rsphdr file mPart mRange ans = it desc $ do
77+ eres <- fileRange s rsphdr file mPart mRange
78+ let res = case eres of
79+ Left e -> Left $ show e
80+ Right r -> Right r
81+ res `shouldBe` ans
82+
64spec :: Spec
83spec :: Spec
65spec = do
84spec = do
66−{- http-client does not support this.
67− describe "preventing response splitting attack" $ do
68− it "sanitizes header values" $ do
69− let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"
70− withApp defaultSettings app $ \port -> do
71− res <- sendGET $ "http://127.0.0.1:" ++ show port
72− getHeaderValue "foo" (responseHeaders res) `shouldBe`
73− Just "foo bar" -- HTTP inserts two spaces for \r\n.
74−-}
75−
76− describe "sanitizeHeaderValue" $ do
77− it "doesn't alter valid multiline header values" $ do
78− sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar"
79−
80− it "adds missing spaces after \r\n" $ do
81− sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar"
82−
83− it "discards empty lines" $ do
84− sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"
85−
86− context "when sanitizing single occurrences of \n" $ do
87− it "replaces \n with \r\n" $ do
88− sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"
89−
90− it "adds missing spaces after \n" $ do
91− sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar"
92−
93− it "discards single occurrences of \r" $ do
94− sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar"
95−
96 describe "range requests" $ do
85 describe "range requests" $ do
97 testRange "2-3" "23" $ Just "2-3/16"
86 testRange "2-3" "23" $ Just "2-3/16"
98 testRange "5-" "56789abcdef" $ Just "5-15/16"
87 testRange "5-" "56789abcdef" $ Just "5-15/16"
@@ -105,3 +94,37 @@ spec = do
105 testPartial 16 2 2 "23"
94 testPartial 16 2 2 "23"
106 testPartial 16 0 2 "01"
95 testPartial 16 0 2 "01"
107 testPartial 16 3 8 "3456789a"
96 testPartial 16 3 8 "3456789a"
97+
98+ describe "fileRange" $ do
99+ testFileRange
100+ "gets a file size from file system"
101+ status200 [] "attic/hex" Nothing Nothing
102+ $ Right (status200,[("Content-Length","16")],0,16)
103+ testFileRange
104+ "gets an error if a file does not exist"
105+ status200 [] "attic/nonexist" Nothing Nothing
106+ $ Left "attic/nonexist: getFileStatus: does not exist (No such file or directory)"
107+ testFileRange
108+ "changes status if FileParts is specified"
109+ status200 [] "attic/hex" (Just (FilePart 2 10 16)) Nothing
110+ $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10")],2,10)
111+ testFileRange
112+ "does not change status and does not add Content-Range if FileParts means the entire"
113+ status200 [] "attic/hex" (Just (FilePart 0 16 16)) Nothing
114+ $ Right (status200,[("Content-Length","16")],0,16)
115+ testFileRange
116+ "gets a file size from file system and handles Range and returns Partical Content"
117+ status200 [] "attic/hex" Nothing (Just "bytes=2-14")
118+ $ Right (status206,[("Content-Range","bytes 2-14/16"),("Content-Length","13")],2,13)
119+ testFileRange
120+ "truncates end point of range to file size"
121+ status200 [] "attic/hex" Nothing (Just "bytes=10-20")
122+ $ Right (status206,[("Content-Range","bytes 10-15/16"),("Content-Length","6")],10,6)
123+ testFileRange
124+ "gets a file size from file system and handles Range and returns OK if Range means the entire"
125+ status200 [] "attic/hex" Nothing (Just "bytes=0-15")
126+ $ Right (status200,[("Content-Length","16")],0,16)
127+ testFileRange
128+ "igores Range if FilePart is specified"
129+ status200 [] "attic/hex" (Just (FilePart 2 10 16)) (Just "bytes=8-9")
130+ $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10")],2,10)
warp/test/RunSpec.hs+95−169
@@ -1,33 +1,33 @@
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)
7−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
8−import Control.Concurrent.STM
9−import qualified Control.Exception as E
10−import Control.Exception.Lifted (bracket, try, IOException, onException)
11import Control.Monad (forM_, replicateM_, unless)
8import Control.Monad (forM_, replicateM_, unless)
9+import System.Timeout (timeout)
12import Control.Monad.IO.Class (MonadIO, liftIO)
10import Control.Monad.IO.Class (MonadIO, liftIO)
13−import Data.ByteString (ByteString)
11+import Data.ByteString (ByteString, hPutStr, hGetSome)
12+import qualified Control.Exception as E
14import qualified Data.ByteString as S
13import qualified Data.ByteString as S
15−import Data.ByteString.Builder (byteString)
16import qualified Data.ByteString.Char8 as S8
14import qualified Data.ByteString.Char8 as S8
17import qualified Data.ByteString.Lazy as L
15import qualified Data.ByteString.Lazy as L
18import qualified Data.IORef as I
16import qualified Data.IORef as I
19−import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)
17+import Network (connectTo, PortID (PortNumber))
20import Network.HTTP.Types
18import Network.HTTP.Types
21−import Network.Socket
19+import Network.Wai
22−import Network.Socket.ByteString (sendAll)
23−import Network.Wai hiding (responseHeaders)
24−import Network.Wai.Internal (getRequestBodyChunk)
25import Network.Wai.Handler.Warp
20import Network.Wai.Handler.Warp
21+import System.IO (hFlush, hClose)
26import System.IO.Unsafe (unsafePerformIO)
22import System.IO.Unsafe (unsafePerformIO)
27−import System.Timeout (timeout)
28import Test.Hspec
23import Test.Hspec
29−
24+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
30−import HTTP
25+import Control.Exception.Lifted (bracket, try, IOException, onException)
26+import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)
27+import Network.Socket (sClose)
28+import qualified Network.HTTP as HTTP
29+import Blaze.ByteString.Builder (fromByteString)
30+import Network.Socket.ByteString (sendAll)
31
31
32main :: IO ()
32main :: IO ()
33main = hspec spec
33main = hspec spec
@@ -35,52 +35,6 @@ main = hspec spec
35type Counter = I.IORef (Either String Int)
35type Counter = I.IORef (Either String Int)
36type CounterApplication = Counter -> Application
36type CounterApplication = Counter -> Application
37
37
38−data MySocket = MySocket
39− { msSocket :: !Socket
40− , msBuffer :: !(I.IORef ByteString)
41− }
42−
43−msWrite :: MySocket -> ByteString -> IO ()
44−msWrite ms bs = sendAll (msSocket ms) bs
45−
46−msRead :: MySocket -> Int -> IO ByteString
47−msRead (MySocket s ref) expected = do
48− bs <- I.readIORef ref
49− inner (bs:) (S.length bs)
50− where
51− inner front total =
52− case compare total expected of
53− EQ -> do
54− I.writeIORef ref mempty
55− pure $ S.concat $ front []
56− GT -> do
57− let bs = S.concat $ front []
58− (x, y) = S.splitAt expected bs
59− I.writeIORef ref y
60− pure x
61− LT -> do
62− bs <- safeRecv s 4096
63− if S.null bs
64− then do
65− I.writeIORef ref mempty
66− pure $ S.concat $ front []
67− else inner (front . (bs:)) (total + S.length bs)
68−
69−msClose :: MySocket -> IO ()
70−msClose = Network.Socket.close . msSocket
71−
72−connectTo :: Int -> IO MySocket
73−connectTo port = do
74− s <- fst <$> getSocketTCP "127.0.0.1" port
75− ref <- I.newIORef mempty
76− return MySocket {
77− msSocket = s
78− , msBuffer = ref
79− }
80−
81−withMySocket :: (MySocket -> IO a) -> Int -> IO a
82−withMySocket body port = bracket (connectTo port) msClose body
83−
84incr :: MonadIO m => Counter -> m ()
38incr :: MonadIO m => Counter -> m ()
85incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
39incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->
86 ((case ecount of
40 ((case ecount of
@@ -92,7 +46,7 @@ err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg
92
46
93readBody :: CounterApplication
47readBody :: CounterApplication
94readBody icount req f = do
48readBody icount req f = do
95− body <- consumeBody $ getRequestBodyChunk req
49+ body <- consumeBody $ requestBody req
96 case () of
50 case () of
97 ()
51 ()
98 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
52 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"
@@ -113,8 +67,8 @@ ignoreBody icount req f = do
113
67
114doubleConnect :: CounterApplication
68doubleConnect :: CounterApplication
115doubleConnect icount req f = do
69doubleConnect icount req f = do
116− _ <- consumeBody $ getRequestBodyChunk req
70+ _ <- consumeBody $ requestBody req
117− _ <- consumeBody $ getRequestBodyChunk req
71+ _ <- consumeBody $ requestBody req
118 incr icount
72 incr icount
119 f $ responseLBS status200 [] "double connect"
73 f $ responseLBS status200 [] "double connect"
120
74
@@ -128,8 +82,8 @@ getPort = do
128 esocket <- try $ bindPortTCP port "127.0.0.1"
82 esocket <- try $ bindPortTCP port "127.0.0.1"
129 case esocket of
83 case esocket of
130 Left (_ :: IOException) -> RunSpec.getPort
84 Left (_ :: IOException) -> RunSpec.getPort
131− Right sock -> do
85+ Right socket -> do
132− close sock
86+ sClose socket
133 return port
87 return port
134
88
135withApp :: Settings -> Application -> (Int -> IO a) -> IO a
89withApp :: Settings -> Application -> (Int -> IO a) -> IO a
@@ -143,13 +97,7 @@ withApp settings app f = do
143 bracket
97 bracket
144 (forkIO $ runSettings settings' app `onException` putMVar baton ())
98 (forkIO $ runSettings settings' app `onException` putMVar baton ())
145 killThread
99 killThread
146− (const $ do
147− takeMVar baton
100+ (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
101
154runTest :: Int -- ^ expected number of requests
102runTest :: Int -- ^ expected number of requests
155 -> CounterApplication
103 -> CounterApplication
@@ -157,9 +105,10 @@ runTest :: Int -- ^ expected number of requests
157 -> IO ()
105 -> IO ()
158runTest expected app chunks = do
106runTest expected app chunks = do
159 ref <- I.newIORef (Right 0)
107 ref <- I.newIORef (Right 0)
160− withApp defaultSettings (app ref) $ withMySocket $ \ms -> do
108+ withApp defaultSettings (app ref) $ \port -> do
109+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
161− forM_ chunks $ \chunk -> msWrite ms chunk
110+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
162− _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096
111+ _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096
163 res <- I.readIORef ref
112 res <- I.readIORef ref
164 case res of
113 case res of
165 Left s -> error s
114 Left s -> error s
@@ -174,9 +123,11 @@ runTerminateTest :: InvalidRequest
174runTerminateTest expected input = do
123runTerminateTest expected input = do
175 ref <- I.newIORef Nothing
124 ref <- I.newIORef Nothing
176 let onExc _ = I.writeIORef ref . Just
125 let onExc _ = I.writeIORef ref . Just
177− withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do
126+ withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do
178− msWrite ms input
127+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
179− msClose ms -- explicitly
128+ hPutStr handle input
129+ hFlush handle
130+ hClose handle
180 threadDelay 1000
131 threadDelay 1000
181 res <- I.readIORef ref
132 res <- I.readIORef ref
182 show res `shouldBe` show (Just expected)
133 show res `shouldBe` show (Just expected)
@@ -247,11 +198,14 @@ spec = do
247 let app req f = do
198 let app req f = do
248 liftIO $ I.writeIORef iheaders $ requestHeaders req
199 liftIO $ I.writeIORef iheaders $ requestHeaders req
249 f $ responseLBS status200 [] ""
200 f $ responseLBS status200 [] ""
250− withApp defaultSettings app $ withMySocket $ \ms -> do
201+ withApp defaultSettings app $ \port -> do
202+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
251 let input = S.concat
203 let input = S.concat
252 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
204 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
253 ]
205 ]
254− msWrite ms input
206+ hPutStr handle input
207+ hFlush handle
208+ hClose handle
255 threadDelay 1000
209 threadDelay 1000
256 headers <- I.readIORef iheaders
210 headers <- I.readIORef iheaders
257 headers `shouldBe`
211 headers `shouldBe`
@@ -262,11 +216,14 @@ spec = do
262 let app req f = do
216 let app req f = do
263 liftIO $ I.writeIORef iheaders $ requestHeaders req
217 liftIO $ I.writeIORef iheaders $ requestHeaders req
264 f $ responseLBS status200 [] ""
218 f $ responseLBS status200 [] ""
265− withApp defaultSettings app $ withMySocket $ \ms -> do
219+ withApp defaultSettings app $ \port -> do
220+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
266 let input = S.concat
221 let input = S.concat
267 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
222 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
268 ]
223 ]
269− msWrite ms input
224+ hPutStr handle input
225+ hFlush handle
226+ hClose handle
270 threadDelay 1000
227 threadDelay 1000
271 headers <- I.readIORef iheaders
228 headers <- I.readIORef iheaders
272 headers `shouldBe`
229 headers `shouldBe`
@@ -275,24 +232,23 @@ spec = do
275
232
276 describe "chunked bodies" $ do
233 describe "chunked bodies" $ do
277 it "works" $ do
234 it "works" $ do
278− countVar <- newTVarIO (0 :: Int)
279 ifront <- I.newIORef id
235 ifront <- I.newIORef id
280 let app req f = do
236 let app req f = do
281− bss <- consumeBody $ getRequestBodyChunk req
237+ bss <- consumeBody $ requestBody req
282 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
238 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
283− atomically $ modifyTVar countVar (+ 1)
284 f $ responseLBS status200 [] ""
239 f $ responseLBS status200 [] ""
285− withApp defaultSettings app $ withMySocket $ \ms -> do
240+ withApp defaultSettings app $ \port -> do
241+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
286 let input = S.concat
242 let input = S.concat
287 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
243 [ "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"
244 , "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"
245 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
290 , "b\r\nHello World\r\n0\r\n\r\n"
246 , "b\r\nHello World\r\n0\r\n\r\n"
291 ]
247 ]
292− msWrite ms input
248+ hPutStr handle input
293− atomically $ do
249+ hFlush handle
294− count <- readTVar countVar
250+ hClose handle
295− check $ count == 2
251+ threadDelay 1000
296 front <- I.readIORef ifront
252 front <- I.readIORef ifront
297 front [] `shouldBe`
253 front [] `shouldBe`
298 [ "Hello World\nBye"
254 [ "Hello World\nBye"
@@ -300,44 +256,38 @@ spec = do
300 ]
256 ]
301 it "lots of chunks" $ do
257 it "lots of chunks" $ do
302 ifront <- I.newIORef id
258 ifront <- I.newIORef id
303− countVar <- newTVarIO (0 :: Int)
304 let app req f = do
259 let app req f = do
305− bss <- consumeBody $ getRequestBodyChunk req
260+ bss <- consumeBody $ requestBody req
306 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
261 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
307− atomically $ modifyTVar countVar (+ 1)
308 f $ responseLBS status200 [] ""
262 f $ responseLBS status200 [] ""
309− withApp defaultSettings app $ withMySocket $ \ms -> do
263+ withApp defaultSettings app $ \port -> do
264+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
310 let input = concat $ replicate 2 $
265 let input = concat $ replicate 2 $
311 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
266 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
312 (replicate 50 "5\r\n12345\r\n") ++
267 (replicate 50 "5\r\n12345\r\n") ++
313 ["0\r\n\r\n"]
268 ["0\r\n\r\n"]
314− mapM_ (msWrite ms) input
269+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
315− atomically $ do
270+ hClose handle
316− count <- readTVar countVar
271+ threadDelay 100000 -- FIXME why does this delay need to be so high?
317− check $ count == 2
318 front <- I.readIORef ifront
272 front <- I.readIORef ifront
319 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
273 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
274 it "in chunks" $ do
323 ifront <- I.newIORef id
275 ifront <- I.newIORef id
324− countVar <- newTVarIO (0 :: Int)
325 let app req f = do
276 let app req f = do
326− bss <- consumeBody $ getRequestBodyChunk req
277+ bss <- consumeBody $ requestBody req
327 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
278 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
328− atomically $ modifyTVar countVar (+ 1)
329 f $ responseLBS status200 [] ""
279 f $ responseLBS status200 [] ""
330− withApp defaultSettings app $ withMySocket $ \ms -> do
280+ withApp defaultSettings app $ \port -> do
281+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
331 let input = S.concat
282 let input = S.concat
332 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
283 [ "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"
284 , "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"
285 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
335 , "b\r\nHello World\r\n0\r\n\r\n"
286 , "b\r\nHello World\r\n0\r\n\r\n"
336 ]
287 ]
337− mapM_ (msWrite ms) $ map S.singleton $ S.unpack input
288+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
338− atomically $ do
289+ hClose handle
339− count <- readTVar countVar
290+ threadDelay 1000
340− check $ count == 2
341 front <- I.readIORef ifront
291 front <- I.readIORef ifront
342 front [] `shouldBe`
292 front [] `shouldBe`
343 [ "Hello World\nBye"
293 [ "Hello World\nBye"
@@ -346,7 +296,7 @@ spec = do
346 it "timeout in request body" $ do
296 it "timeout in request body" $ do
347 ifront <- I.newIORef id
297 ifront <- I.newIORef id
348 let app req f = do
298 let app req f = do
349− bss <- (consumeBody $ getRequestBodyChunk req) `onException`
299+ bss <- (consumeBody $ requestBody req) `onException`
350 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))
300 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))
351 liftIO $ threadDelay 4000000 `E.catch` \e -> do
301 liftIO $ threadDelay 4000000 `E.catch` \e -> do
352 I.atomicModifyIORef ifront (\front ->
302 I.atomicModifyIORef ifront (\front ->
@@ -355,18 +305,20 @@ spec = do
355 E.throwIO (e :: E.SomeException)
305 E.throwIO (e :: E.SomeException)
356 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
306 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
357 f $ responseLBS status200 [] ""
307 f $ responseLBS status200 [] ""
358− withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do
308+ withApp (setTimeout 1 defaultSettings) app $ \port -> do
359 let bs1 = S.replicate 2048 88
309 let bs1 = S.replicate 2048 88
360 bs2 = "This is short"
310 bs2 = "This is short"
361 bs = S.append bs1 bs2
311 bs = S.append bs1 bs2
312+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
362− msWrite ms "POST / HTTP/1.1\r\n"
313+ hPutStr handle "POST / HTTP/1.1\r\n"
363− msWrite ms "content-length: "
314+ hPutStr handle "content-length: "
364− msWrite ms $ S8.pack $ show $ S.length bs
315+ hPutStr handle $ S8.pack $ show $ S.length bs
365− msWrite ms "\r\n\r\n"
316+ hPutStr handle "\r\n\r\n"
366 threadDelay 100000
317 threadDelay 100000
367− msWrite ms bs1
318+ hPutStr handle bs1
368 threadDelay 100000
319 threadDelay 100000
369− msWrite ms bs2
320+ hPutStr handle bs2
321+ hClose handle
370 threadDelay 5000000
322 threadDelay 5000000
371 front <- I.readIORef ifront
323 front <- I.readIORef ifront
372 S.concat (front []) `shouldBe` bs
324 S.concat (front []) `shouldBe` bs
@@ -382,75 +334,49 @@ spec = do
382 loop
334 loop
383 loop
335 loop
384 doubleBS = S.concatMap $ \w -> S.pack [w, w]
336 doubleBS = S.concatMap $ \w -> S.pack [w, w]
385− withApp defaultSettings app $ withMySocket $ \ms -> do
337+ withApp defaultSettings app $ \port -> do
338+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
386− msWrite ms "POST / HTTP/1.1\r\n\r\n12345"
339+ hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"
340+ hFlush handle
387− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")
341+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")
388− msWrite ms "67890"
342+ hPutStr handle "67890"
343+ hFlush handle
389− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")
344+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")
345+
390 it "only one date and server header" $ do
346 it "only one date and server header" $ do
391 let app _ f = f $ responseLBS status200
347 let app _ f = f $ responseLBS status200
392 [ ("server", "server")
348 [ ("server", "server")
393 , ("date", "date")
349 , ("date", "date")
394 ] ""
350 ] ""
395− getValues key = map snd
396− . filter (\(key', _) -> key == key')
397− . responseHeaders
398 withApp defaultSettings app $ \port -> do
351 withApp defaultSettings app $ \port -> do
399− res <- sendGET $ "http://127.0.0.1:" ++ show port
352+ Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)
353+ map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrServer res)
400− getValues hServer res `shouldBe` ["server"]
354+ `shouldBe` ["server"]
355+ map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrDate res)
401− getValues hDate res `shouldBe` ["date"]
356+ `shouldBe` ["date"]
402
357
403 it "streaming echo #249" $ do
358 it "streaming echo #249" $ do
404− countVar <- newTVarIO (0 :: Int)
405 let app req f = f $ responseStream status200 [] $ \write _ -> do
359 let app req f = f $ responseStream status200 [] $ \write _ -> do
406− let loop = do
360+ let loop = do
407− bs <- getRequestBodyChunk req
361+ bs <- requestBody req
408 unless (S.null bs) $ do
362 unless (S.null bs) $ do
409− write $ byteString bs
363+ write $ fromByteString bs
410− atomically $ modifyTVar countVar (+ 1)
411 loop
364 loop
412− loop
365+ loop
413− withApp defaultSettings app $ withMySocket $ \ms -> do
366+ withApp defaultSettings app $ \port -> do
367+ (socket, _addr) <- getSocketTCP "127.0.0.1" port
414− msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"
368+ sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"
415 threadDelay 10000
369 threadDelay 10000
416− msWrite ms "5\r\nhello\r\n0\r\n\r\n"
370+ 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
371+ bs <- safeRecv socket 4096
421 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"
372 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"
422
373
423 it "streaming response with length" $ do
374 it "streaming response with length" $ do
424 let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do
375 let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do
425− replicateM_ 4 $ write $ byteString "Hello"
376+ replicateM_ 4 $ write $ fromByteString "Hello"
426 withApp defaultSettings app $ \port -> do
377 withApp defaultSettings app $ \port -> do
427− res <- sendGET $ "http://127.0.0.1:" ++ show port
378+ Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)
428− responseBody res `shouldBe` "HelloHelloHelloHello"
379+ HTTP.rspBody res `shouldBe` "HelloHelloHelloHello"
429−
430− describe "head requests" $ do
431− let fp = "test/head-response"
432− let app req f =
433− f $ case pathInfo req of
434− ["builder"] -> responseBuilder status200 [] $ error "should never be evaluated"
435− ["streaming"] -> responseStream status200 [] $ \write _ ->
436− write $ error "should never be evaluated"
437− ["file"] -> responseFile status200 [] fp Nothing
438− _ -> error "invalid path"
439− it "builder" $ withApp defaultSettings app $ \port -> do
440− res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]
441− responseBody res `shouldBe` ""
442− it "streaming" $ withApp defaultSettings app $ \port -> do
443− res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]
444− responseBody res `shouldBe` ""
445− it "file, no range" $ withApp defaultSettings app $ \port -> do
446− bs <- S.readFile fp
447− res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]
448− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs)
449− it "file, with range" $ withApp defaultSettings app $ \port -> do
450− res <- sendHEADwH
451− (concat ["http://127.0.0.1:", show port, "/file"])
452− [(hRange, "bytes=0-1")]
453− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2"
454
380
455consumeBody :: IO ByteString -> IO [ByteString]
381consumeBody :: IO ByteString -> IO [ByteString]
456consumeBody body =
382consumeBody body =
warp/test/WithApplicationSpec.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−module WithApplicationSpec where
4−
5−import Control.Exception
6−import Network.HTTP.Types
7−import Network.Wai
8−import System.Environment
9−import System.Process
10−import Test.Hspec
11−
12−import Network.Wai.Handler.Warp.WithApplication
13−
14−spec :: Spec
15−spec = do
16− runIO $ do
17− unsetEnv "http_proxy"
18− unsetEnv "https_proxy"
19− describe "withApplication" $ do
20− it "runs a wai Application while executing the given action" $ do
21− let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"
22− withApplication mkApp $ \ port -> do
23− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
24− output `shouldBe` "foo"
25−
26− it "does not propagate exceptions from the server to the executing thread" $ do
27− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
28− withApplication mkApp $ \ port -> do
29− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""
30− output `shouldContain` "Something went wron"
31−
32− describe "testWithApplication" $ do
33− it "propagates exceptions from the server to the executing thread" $ do
34− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"
35− (testWithApplication mkApp $ \ port -> do
36− readProcess "curl" ["-s", "localhost:" ++ show port] "")
37− `shouldThrow` (errorCall "foo")
38−
39−{- The future netwrok library will not export MkSocket.
40− describe "withFreePort" $ do
41− it "closes the socket before exiting" $ do
42− MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do
43− return sock
44− readMVar statusMVar `shouldReturn` Closed
45−-}
warp/test/doctests.hs+8−1
@@ -1,4 +1,11 @@
1+module Main where
2+
1import Test.DocTest
3import Test.DocTest
2
4
3main :: IO ()
5main :: IO ()
4−main = doctest ["Network"]
6+main = doctest [
7+ "-idist/build/autogen/"
8+ , "-optP-include"
9+ , "-optPdist/build/autogen/cabal_macros.h"
10+ , "Network/Wai/Handler/Warp.hs"
11+ ]
warp/test/head-responsedeleted−1
@@ -1 +0,0 @@
1−This is the body
warp/warp.cabal+59−151
@@ -1,5 +1,5 @@
1Name: warp
1Name: warp
2−Version: 3.3.9
2+Version: 3.0.13.1
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,18 +8,12 @@ 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
13−description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.
14− For HTTP\/2, Warp supports direct and ALPN (in TLS)
15− but not upgrade.
16− API docs and the README are available at
13+description: API docs and the README are available at <http://www.stackage.org/package/warp>.
17− <http://www.stackage.org/package/warp>.
18extra-source-files: attic/hex
14extra-source-files: attic/hex
19 ChangeLog.md
15 ChangeLog.md
20 README.md
16 README.md
21− test/head-response
22− test/inputFile
23
17
24Flag network-bytestring
18Flag network-bytestring
25 Default: False
19 Default: False
@@ -32,38 +26,37 @@ Flag warp-debug
32 Description: print debug output. not suitable for production
26 Description: print debug output. not suitable for production
33 Default: False
27 Default: False
34
28
29+Flag use-bytestring-builder
30+ description: Use bytestring-builder package
31+ default: False
32+
35Library
33Library
36− Build-Depends: base >= 4.8 && < 5
34+ Build-Depends: base >= 3 && < 5
37 , array
35 , array
38− , async
39− , auto-update >= 0.1.3 && < 0.2
36+ , auto-update >= 0.1.1 && < 0.2
40− , bsb-http-chunked < 0.1
37+ , blaze-builder >= 0.3.3 && < 0.5
41 , bytestring >= 0.9.1.4
38 , bytestring >= 0.9.1.4
42 , case-insensitive >= 0.2
39 , case-insensitive >= 0.2
43− , containers
44 , ghc-prim
40 , ghc-prim
45− , hashable
46− , http-date
47− , http-types >= 0.12
41+ , http-types >= 0.8.5
48− , http2 >= 2.0 && < 2.1
49 , iproute >= 1.3.1
42 , iproute >= 1.3.1
50 , simple-sendfile >= 0.2.7 && < 0.3
43 , 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
44 , unix-compat >= 0.2
45+ , wai >= 3.0 && < 3.1
46+ , text
47+ , streaming-commons >= 0.1.10
56 , vault >= 0.3
48 , vault >= 0.3
57− , wai >= 3.2 && < 3.3
49+ , stm >= 2.3
58− , word8
59− , x509
60− if impl(ghc < 8)
61− Build-Depends: semigroups
62 if flag(network-bytestring)
50 if flag(network-bytestring)
63 Build-Depends: network >= 2.2.1.5 && < 2.2.3
51 Build-Depends: network >= 2.2.1.5 && < 2.2.3
64 , network-bytestring >= 0.1.3 && < 0.1.4
52 , network-bytestring >= 0.1.3 && < 0.1.4
65 else
53 else
66 Build-Depends: network >= 2.3
54 Build-Depends: network >= 2.3
55+ if flag(use-bytestring-builder)
56+ Build-Depends: bytestring < 0.10.2.0
57+ , bytestring-builder
58+ else
59+ Build-Depends: bytestring >= 0.10.2.0
67 Exposed-modules: Network.Wai.Handler.Warp
60 Exposed-modules: Network.Wai.Handler.Warp
68 Network.Wai.Handler.Warp.Internal
61 Network.Wai.Handler.Warp.Internal
69 Other-modules: Network.Wai.Handler.Warp.Buffer
62 Other-modules: Network.Wai.Handler.Warp.Buffer
@@ -71,19 +64,9 @@ Library
71 Network.Wai.Handler.Warp.Counter
64 Network.Wai.Handler.Warp.Counter
72 Network.Wai.Handler.Warp.Date
65 Network.Wai.Handler.Warp.Date
73 Network.Wai.Handler.Warp.FdCache
66 Network.Wai.Handler.Warp.FdCache
74− Network.Wai.Handler.Warp.File
75− Network.Wai.Handler.Warp.FileInfoCache
76− Network.Wai.Handler.Warp.HashMap
77− Network.Wai.Handler.Warp.HTTP2
78− Network.Wai.Handler.Warp.HTTP2.File
79− Network.Wai.Handler.Warp.HTTP2.PushPromise
80− Network.Wai.Handler.Warp.HTTP2.Request
81− Network.Wai.Handler.Warp.HTTP2.Response
82− Network.Wai.Handler.Warp.HTTP2.Types
83 Network.Wai.Handler.Warp.Header
67 Network.Wai.Handler.Warp.Header
84 Network.Wai.Handler.Warp.IO
68 Network.Wai.Handler.Warp.IO
85− Network.Wai.Handler.Warp.Imports
69+ Network.Wai.Handler.Warp.IORef
86− Network.Wai.Handler.Warp.PackInt
87 Network.Wai.Handler.Warp.ReadInt
70 Network.Wai.Handler.Warp.ReadInt
88 Network.Wai.Handler.Warp.Recv
71 Network.Wai.Handler.Warp.Recv
89 Network.Wai.Handler.Warp.Request
72 Network.Wai.Handler.Warp.Request
@@ -93,9 +76,9 @@ Library
93 Network.Wai.Handler.Warp.Run
76 Network.Wai.Handler.Warp.Run
94 Network.Wai.Handler.Warp.SendFile
77 Network.Wai.Handler.Warp.SendFile
95 Network.Wai.Handler.Warp.Settings
78 Network.Wai.Handler.Warp.Settings
79+ Network.Wai.Handler.Warp.Timeout
96 Network.Wai.Handler.Warp.Types
80 Network.Wai.Handler.Warp.Types
97 Network.Wai.Handler.Warp.Windows
81 Network.Wai.Handler.Warp.Windows
98− Network.Wai.Handler.Warp.WithApplication
99 Paths_warp
82 Paths_warp
100 Ghc-Options: -Wall
83 Ghc-Options: -Wall
101
84
@@ -103,167 +86,92 @@ Library
103 Cpp-Options: -DWARP_DEBUG
86 Cpp-Options: -DWARP_DEBUG
104 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)
87 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)
105 Cpp-Options: -DSENDFILEFD
88 Cpp-Options: -DSENDFILEFD
89+ Build-Depends: hashable
90+ Other-modules: Network.Wai.Handler.Warp.MultiMap
106 if os(windows)
91 if os(windows)
107 Cpp-Options: -DWINDOWS
92 Cpp-Options: -DWINDOWS
108 Build-Depends: time
93 Build-Depends: time
94+ , old-locale
109 else
95 else
110 Build-Depends: unix
96 Build-Depends: unix
111− Other-modules: Network.Wai.Handler.Warp.MultiMap
97+ , http-date
112− if impl(ghc >= 8)
113− Default-Extensions: Strict StrictData
114− Default-Language: Haskell2010
115
98
116Test-Suite doctest
99Test-Suite doctest
117− buildable: False
118 Type: exitcode-stdio-1.0
100 Type: exitcode-stdio-1.0
119 HS-Source-Dirs: test
101 HS-Source-Dirs: test
120 Ghc-Options: -threaded -Wall
102 Ghc-Options: -threaded -Wall
121 Main-Is: doctests.hs
103 Main-Is: doctests.hs
122− Build-Depends: base >= 4.8 && < 5
104+ Build-Depends: base
123− , doctest >= 0.10.1
105+ , doctest >= 0.9.3
124− if os(windows)
125− Buildable: False
126− if impl(ghc >= 8)
127− Default-Extensions: Strict StrictData
128− Default-Language: Haskell2010
129
106
130Test-Suite spec
107Test-Suite spec
131 Main-Is: Spec.hs
108 Main-Is: Spec.hs
132− Other-modules: BufferPoolSpec
133− ConduitSpec
109+ Other-modules: ConduitSpec
134 ExceptionSpec
110 ExceptionSpec
135 FdCacheSpec
111 FdCacheSpec
136− FileSpec
112+ MultiMapSpec
137 ReadIntSpec
113 ReadIntSpec
138 RequestSpec
114 RequestSpec
139 ResponseHeaderSpec
115 ResponseHeaderSpec
140 ResponseSpec
116 ResponseSpec
141 RunSpec
117 RunSpec
142 SendFileSpec
118 SendFileSpec
143− WithApplicationSpec
144− HTTP
145− Network.Wai.Handler.Warp
146− Network.Wai.Handler.Warp.Buffer
147− Network.Wai.Handler.Warp.Conduit
148− Network.Wai.Handler.Warp.Counter
149− Network.Wai.Handler.Warp.Date
150− Network.Wai.Handler.Warp.FdCache
151− Network.Wai.Handler.Warp.File
152− Network.Wai.Handler.Warp.FileInfoCache
153− Network.Wai.Handler.Warp.HTTP2
154− Network.Wai.Handler.Warp.HTTP2.File
155− Network.Wai.Handler.Warp.HTTP2.PushPromise
156− Network.Wai.Handler.Warp.HTTP2.Request
157− Network.Wai.Handler.Warp.HTTP2.Response
158− Network.Wai.Handler.Warp.HTTP2.Types
159− Network.Wai.Handler.Warp.HashMap
160− Network.Wai.Handler.Warp.Header
161− Network.Wai.Handler.Warp.IO
162− Network.Wai.Handler.Warp.Imports
163− Network.Wai.Handler.Warp.MultiMap
164− Network.Wai.Handler.Warp.PackInt
165− Network.Wai.Handler.Warp.ReadInt
166− Network.Wai.Handler.Warp.Recv
167− Network.Wai.Handler.Warp.Request
168− Network.Wai.Handler.Warp.RequestHeader
169− Network.Wai.Handler.Warp.Response
170− Network.Wai.Handler.Warp.ResponseHeader
171− Network.Wai.Handler.Warp.Run
172− Network.Wai.Handler.Warp.SendFile
173− Network.Wai.Handler.Warp.Settings
174− Network.Wai.Handler.Warp.Types
175− Network.Wai.Handler.Warp.Windows
176− Network.Wai.Handler.Warp.WithApplication
177− Paths_warp
178−
179 Hs-Source-Dirs: test, .
119 Hs-Source-Dirs: test, .
180 Type: exitcode-stdio-1.0
120 Type: exitcode-stdio-1.0
181
121
182− Ghc-Options: -Wall -threaded
122+ Ghc-Options: -Wall
183− Build-Depends: base >= 4.8 && < 5
123+ Build-Depends: base >= 4 && < 5
184− , HUnit
185− , QuickCheck
186 , array
124 , array
187− , async
188 , auto-update
125 , auto-update
189− , bsb-http-chunked < 0.1
126+ , blaze-builder >= 0.3.3 && < 0.5
190 , bytestring >= 0.9.1.4
127 , bytestring >= 0.9.1.4
191 , case-insensitive >= 0.2
128 , case-insensitive >= 0.2
192− , containers
193− , directory
194 , ghc-prim
129 , ghc-prim
195− , hashable
130+ , HTTP
196− , hspec >= 1.3
197− , http-client
198− , http-date
199− , http-types >= 0.12
131+ , http-types >= 0.8.4
200− , http2 >= 2.0 && < 2.1
201 , iproute >= 1.3.1
132 , iproute >= 1.3.1
202 , lifted-base >= 0.1
133 , lifted-base >= 0.1
203− , network
204− , process
205 , simple-sendfile >= 0.2.4 && < 0.3
134 , simple-sendfile >= 0.2.4 && < 0.3
206− , stm >= 2.3
135+ , transformers >= 0.2.2
207− , streaming-commons >= 0.1.10
208− , text
209− , time
210− , time-manager
211 , unix-compat >= 0.2
136 , unix-compat >= 0.2
137+ , wai
138+ , network
139+ , HUnit
140+ , QuickCheck
141+ , hspec >= 1.3
142+ , time
143+ , old-locale
144+ , text
145+ , streaming-commons >= 0.1.10
146+ , async
212 , vault
147 , vault
213− , wai >= 3.2 && < 3.3
148+ , stm >= 2.3
214− , word8
149+ , directory
215− , x509
150+ , process
216− -- Build-Tool-Depends: hspec-discover:hspec-discover
151+ if flag(use-bytestring-builder)
217− if impl(ghc < 8)
218− Build-Depends: semigroups
152+ Build-Depends: bytestring < 0.10.2.0
219− , transformers
153+ , bytestring-builder
154+ else
155+ Build-Depends: bytestring >= 0.10.2.0
220
156
221 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)
157 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)
222 Cpp-Options: -DSENDFILEFD
158 Cpp-Options: -DSENDFILEFD
223 Build-Depends: unix
159 Build-Depends: unix
160+ , hashable
161+ , http-date
224 if os(windows)
162 if os(windows)
225− Cpp-Options: -DWINDOWS
163+ Cpp-Options: -DWINDOWS
226− Build-Depends: time
227− if impl(ghc >= 8)
228− Default-Extensions: Strict StrictData
229− Default-Language: Haskell2010
230
164
231Benchmark parser
165Benchmark parser
232 Type: exitcode-stdio-1.0
166 Type: exitcode-stdio-1.0
233 Main-Is: Parser.hs
167 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 .
168 HS-Source-Dirs: bench .
242− Build-Depends: base >= 4.8 && < 5
169+ Build-Depends: base
243− , auto-update
244 , bytestring
170 , bytestring
245− , containers
171+ , criterion
246− , gauge
247− , hashable
248− , http-date
249 , http-types
172 , http-types
250 , network
173 , network
251 , network
174 , network
252− , time-manager
253− , unix-compat
254− , x509
255− if impl(ghc < 8)
256− Build-Depends: semigroups
257−
258− if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)
259− Cpp-Options: -DSENDFILEFD
260− Build-Depends: unix
261− if os(windows)
262− Cpp-Options: -DWINDOWS
263− Build-Depends: time
264− if impl(ghc >= 8)
265− Default-Extensions: Strict StrictData
266− Default-Language: Haskell2010
267
175
268Source-Repository head
176Source-Repository head
269 Type: git
177 Type: git