git.iko.soy/typeable/wai
on f2f54ca help sign in
e083f6e
swap
0 ahead, 2551 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+2−10
@@ -1,12 +1,4 @@
1dist/
1dist/
2*.swp
2*.swp
3−*.hi
4−*.o
5−tarballs/
6−/.hsenv
7−/.shelly
8−.cabal-sandbox/
3+cabal-dev
9−cabal.sandbox.config
4+.virthualenv
10−.stack-work/
11−*~
12−stack*.yaml.lock
.gitmodulesnew file+3
@@ -0,0 +1,3 @@
1+[submodule "scripts"]
2+ path = scripts
3+ url = git://github.com/yesodweb/scripts.git
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+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2010, Michael Snoyman. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+2−5
@@ -6,8 +6,5 @@ The premier WAI backend is the Warp web server.
6WAI also adds modularity and code-sharing through middleware and WAI applications.
6WAI also adds modularity and code-sharing through middleware and WAI applications.
7Code can be written that works with any web framework targeting WAI.
7Code can be written that works with any web framework targeting WAI.
8
8
9−[Documentation](http://www.yesodweb.com/book/web-application-interface)
9+[http://www.yesodweb.com/book/wai](Documentation)
10−
11−[Haddock Documentation](http://hackage.haskell.org/package/wai)
10+[http://hackage.haskell.org/package/wai](Haddock Documentation)
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.mddeleted−34
@@ -1,34 +0,0 @@
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
auto-update/Control/AutoUpdate.hsdeleted−201
@@ -1,201 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-- | In a multithreaded environment, running actions on a regularly scheduled
3−-- background thread can dramatically improve performance.
4−-- For example, web servers need to return the current time with each HTTP response.
5−-- For a high-volume server, it's much faster for a dedicated thread to run every
6−-- second, and write the current time to a shared 'IORef', than it is for each
7−-- request to make its own call to 'getCurrentTime'.
8−--
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
14−-- either be performed by a dedicated thread, or, in times of low volume, will
15−-- be 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>.
31−module Control.AutoUpdate (
32− -- * Type
33− UpdateSettings
34− , defaultUpdateSettings
35− -- * Accessors
36− , updateAction
37− , updateFreq
38− , updateSpawnThreshold
39− -- * Creation
40− , mkAutoUpdate
41− , mkAutoUpdateWithModify
42− ) where
43−
44−#if __GLASGOW_HASKELL__ < 709
45−import Control.Applicative ((<*>))
46−#endif
47−import Control.Concurrent (forkIO, threadDelay)
48−import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
49− takeMVar, tryPutMVar)
50−import Control.Exception (SomeException, catch, mask_, throw,
51− try)
52−import Control.Monad (void)
53−import Data.IORef (newIORef, readIORef, writeIORef)
54−
55−-- | Default value for creating an 'UpdateSettings'.
56−--
57−-- @since 0.1.0
58−defaultUpdateSettings :: UpdateSettings ()
59−defaultUpdateSettings = UpdateSettings
60− { updateFreq = 1000000
61− , updateSpawnThreshold = 3
62− , updateAction = return ()
63− }
64−
65−-- | Settings to control how values are updated.
66−--
67−-- This should be constructed using 'defaultUpdateSettings' and record
68−-- update syntax, e.g.:
69−--
70−-- @
71−-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }
72−-- @
73−--
74−-- @since 0.1.0
75−data UpdateSettings a = UpdateSettings
76− { updateFreq :: Int
77− -- ^ Microseconds between update calls. Same considerations as
78− -- 'threadDelay' apply.
79− --
80− -- Default: 1 second (1000000)
81− --
82− -- @since 0.1.0
83− , updateSpawnThreshold :: Int
84− -- ^ NOTE: This value no longer has any effect, since worker threads are
85− -- dedicated instead of spawned on demand.
86− --
87− -- Previously, this determined how many times the data must be requested
88− -- before we decide to spawn a dedicated thread.
89− --
90− -- Default: 3
91− --
92− -- @since 0.1.0
93− , updateAction :: IO a
94− -- ^ Action to be performed to get the current value.
95− --
96− -- Default: does nothing.
97− --
98− -- @since 0.1.0
99− }
100−
101−-- | Generate an action which will either read from an automatically
102−-- updated value, or run the update action in the current thread.
103−--
104−-- @since 0.1.0
105−mkAutoUpdate :: UpdateSettings a -> IO (IO a)
106−mkAutoUpdate us = mkAutoUpdateHelper us Nothing
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.
119− needsRunning <- newEmptyMVar
120−
121− -- The initial response variable. Response variables allow the requesting
122− -- thread to block until a value is generated by the worker thread.
123− responseVar0 <- newEmptyMVar
124−
125− -- The current value, if available. We start off with a Left value
126− -- indicating no value is available, and the above-created responseVar0 to
127− -- give a variable to block on.
128− currRef <- newIORef $ Left responseVar0
129−
130− -- This is used to set a value in the currRef variable when the worker
131− -- thread exits. In reality, that value should never be used, since the
132− -- worker thread exiting only occurs if an async exception is thrown, which
133− -- should only occur if there are no references to needsRunning left.
134− -- However, this handler will make error messages much clearer if there's a
135− -- bug in the implementation.
136− let fillRefOnExit f = do
137− eres <- try f
138− case eres of
139− Left e -> writeIORef currRef $ error $
140− "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
141− ++ show (e :: SomeException)
142− Right () -> writeIORef currRef $ error $
143− "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
144− ++ "which should be impossible due to usage of infinite loop"
145−
146− -- fork the worker thread immediately. Note that we mask async exceptions,
147− -- but *not* in an uninterruptible manner. This will allow a
148− -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take
149− -- down this thread when all references to the returned function are
150− -- garbage collected, and therefore there is no thread that can fill the
151− -- needsRunning MVar.
152− --
153− -- Note that since we throw away the ThreadId of this new thread and never
154− -- calls myThreadId, normal async exceptions can never be thrown to it,
155− -- only RTS exceptions.
156− mask_ $ void $ forkIO $ fillRefOnExit $ do
157− -- 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
159− -- the benefit of any requesters currently blocked on it.
160− let loop responseVar maybea = do
161− -- block until a value is actually needed
162− takeMVar needsRunning
163−
164− -- new value requested, so run the updateAction
165− a <- catchSome $ maybe (updateAction us) id (updateActionModify <*> maybea)
166−
167− -- we got a new value, update currRef and lastValue
168− writeIORef currRef $ Right a
169− putMVar responseVar a
170−
171− -- delay until we're needed again
172− threadDelay $ updateFreq us
173−
174− -- delay's over. create a new response variable and set currRef
175− -- to use it, so that the next requester will block on that
176− -- variable. Then loop again with the updated response
177− -- variable.
178− responseVar' <- newEmptyMVar
179− writeIORef currRef $ Left responseVar'
180− loop responseVar' (Just a)
181−
182− -- Kick off the loop, with the initial responseVar0 variable.
183− loop responseVar0 Nothing
184−
185− return $ do
186− mval <- readIORef currRef
187− case mval of
188− Left responseVar -> do
189− -- no current value, force the worker thread to run...
190− void $ tryPutMVar needsRunning ()
191−
192− -- and block for the result from the worker
193− readMVar responseVar
194− -- we have a current value, use it
195− Right val -> return val
196−
197−-- | Turn a runtime exception into an impure exception, so that all 'IO'
198−-- actions will complete successfully. This simply defers the exception until
199−-- the value is forced.
200−catchSome :: IO a -> IO a
201−catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException)
auto-update/Control/AutoUpdate/Util.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−module Control.AutoUpdate.Util
3− ( atomicModifyIORef'
4− ) where
5−
6−#ifndef MIN_VERSION_base
7−#define MIN_VERSION_base(x,y,z) 1
8−#endif
9−
10−#if MIN_VERSION_base(4,6,0)
11−import Data.IORef (atomicModifyIORef')
12−#else
13−import Data.IORef (IORef, atomicModifyIORef)
14−-- | Strict version of 'atomicModifyIORef'. This forces both the value stored
15−-- in the 'IORef' as well as the value returned.
16−atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
17−atomicModifyIORef' ref f = do
18− c <- atomicModifyIORef ref
19− (\x -> let (a, b) = f x -- Lazy application of "f"
20− in (a, a `seq` b)) -- Lazy application of "seq"
21− -- The following forces "a `seq` b", so it also forces "f x".
22− c `seq` return c
23−#endif
auto-update/Control/Debounce.hsdeleted−60
@@ -1,60 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−-- | Debounce an action, ensuring it doesn't occur more than once for a given
3−-- period of time.
4−--
5−-- This is useful as an optimization, for example to ensure that logs are only
6−-- flushed to disk at most once per second.
7−--
8−-- Example usage:
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
27−module Control.Debounce
28− ( -- * Type
29− DI.DebounceSettings
30− , defaultDebounceSettings
31− -- * Accessors
32− , DI.debounceFreq
33− , DI.debounceAction
34− , DI.debounceEdge
35− , DI.leadingEdge
36− , DI.trailingEdge
37− -- * Creation
38− , mkDebounce
39− ) where
40−
41−import Control.Concurrent (newEmptyMVar, threadDelay)
42−import qualified Control.Debounce.Internal as DI
43−
44−-- | Default value for creating a 'DebounceSettings'.
45−--
46−-- @since 0.1.2
47−defaultDebounceSettings :: DI.DebounceSettings
48−defaultDebounceSettings = DI.DebounceSettings
49− { DI.debounceFreq = 1000000
50− , DI.debounceAction = return ()
51− , DI.debounceEdge = DI.leadingEdge
52− }
53−
54−-- | Generate an action which will trigger the debounced action to be performed.
55−--
56−-- @since 0.1.2
57−mkDebounce :: DI.DebounceSettings -> IO (IO ())
58−mkDebounce settings = do
59− baton <- newEmptyMVar
60− DI.mkDebounceInternal baton threadDelay settings
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.hsdeleted−280
@@ -1,280 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE BangPatterns #-}
3−
4−-- | This module provides the ability to create reapers: dedicated cleanup
5−-- threads. These threads will automatically spawn and die based on the
6−-- presence of a workload to process on. Example uses include:
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".
14−module Control.Reaper (
15− -- * Example: Regularly cleaning a cache
16− -- $example1
17−
18− -- * Settings
19− ReaperSettings
20− , defaultReaperSettings
21− -- * Accessors
22− , reaperAction
23− , reaperDelay
24− , reaperCons
25− , reaperNull
26− , reaperEmpty
27− -- * Type
28− , Reaper(..)
29− -- * Creation
30− , mkReaper
31− -- * Helper
32− , mkListAction
33− ) where
34−
35−import Control.AutoUpdate.Util (atomicModifyIORef')
36−import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
37−import Control.Exception (mask_)
38−import Data.IORef (IORef, newIORef, readIORef, writeIORef)
39−
40−-- | Settings for creating a reaper. This type has two parameters:
41−-- @workload@ gives the entire workload, whereas @item@ gives an
42−-- individual piece of the queue. A common approach is to have @workload@
43−-- be a list of @item@s. This is encouraged by 'defaultReaperSettings' and
44−-- 'mkListAction'.
45−--
46−-- @since 0.1.1
47−data ReaperSettings workload item = ReaperSettings
48− { reaperAction :: workload -> IO (workload -> workload)
49− -- ^ The action to perform on a workload. The result of this is a
50− -- \"workload modifying\" function. In the common case of using lists,
51− -- the result should be a difference list that prepends the remaining
52− -- workload to the temporary workload. The temporary workload here
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'.
55− --
56− -- Default: do nothing with the workload, and then prepend it to the
57− -- temporary workload. This is incredibly useless; you should
58− -- definitely override this default.
59− --
60− -- @since 0.1.1
61− , reaperDelay :: {-# UNPACK #-} !Int
62− -- ^ Number of microseconds to delay between calls of 'reaperAction'.
63− --
64− -- Default: 30 seconds.
65− --
66− -- @since 0.1.1
67− , reaperCons :: item -> workload -> workload
68− -- ^ Add an item onto a workload.
69− --
70− -- Default: list consing.
71− --
72− -- @since 0.1.1
73− , reaperNull :: workload -> Bool
74− -- ^ Check if a workload is empty, in which case the worker thread
75− -- will shut down.
76− --
77− -- Default: 'null'.
78− --
79− -- @since 0.1.1
80− , reaperEmpty :: workload
81− -- ^ An empty workload.
82− --
83− -- Default: empty list.
84− --
85− -- @since 0.1.1
86− }
87−
88−-- | Default @ReaperSettings@ value, biased towards having a list of work
89−-- items.
90−--
91−-- @since 0.1.1
92−defaultReaperSettings :: ReaperSettings [item] item
93−defaultReaperSettings = ReaperSettings
94− { reaperAction = \wl -> return (wl ++)
95− , reaperDelay = 30000000
96− , reaperCons = (:)
97− , reaperNull = null
98− , reaperEmpty = []
99− }
100−
101−-- | A data structure to hold reaper APIs.
102−data Reaper workload item = Reaper {
103− -- | Adding an item to the workload
104− reaperAdd :: item -> IO ()
105− -- | Reading workload.
106− , reaperRead :: IO workload
107− -- | Stopping the reaper thread if exists.
108− -- The current workload is returned.
109− , reaperStop :: IO workload
110− -- | Killing the reaper thread immediately if exists.
111− , reaperKill :: IO ()
112− }
113−
114−-- | State of reaper.
115−data State workload = NoReaper -- ^ No reaper thread
116− | Workload !workload -- ^ The current jobs
117−
118−-- | Create a reaper addition function. This function can be used to add
119−-- new items to the workload. Spawning of reaper threads will be handled
120−-- for you automatically.
121−--
122−-- @since 0.1.1
123−mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)
124−mkReaper settings@ReaperSettings{..} = do
125− stateRef <- newIORef NoReaper
126− tidRef <- newIORef Nothing
127− return Reaper {
128− reaperAdd = add settings stateRef tidRef
129− , reaperRead = readRef stateRef
130− , reaperStop = stop stateRef
131− , reaperKill = kill tidRef
132− }
133− where
134− readRef stateRef = do
135− mx <- readIORef stateRef
136− case mx of
137− NoReaper -> return reaperEmpty
138− Workload wl -> return wl
139− stop stateRef = atomicModifyIORef' stateRef $ \mx ->
140− case mx of
141− NoReaper -> (NoReaper, reaperEmpty)
142− 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−
149−add :: ReaperSettings workload item
150− -> IORef (State workload) -> IORef (Maybe ThreadId)
151− -> item -> IO ()
152−add settings@ReaperSettings{..} stateRef tidRef item =
153− mask_ $ do
154− next <- atomicModifyIORef' stateRef cons
155− next
156− where
157− cons NoReaper = let wl = reaperCons item reaperEmpty
158− in (Workload wl, spawn settings stateRef tidRef)
159− cons (Workload wl) = let wl' = reaperCons item wl
160− in (Workload wl', return ())
161−
162−spawn :: ReaperSettings workload item
163− -> IORef (State workload) -> IORef (Maybe ThreadId)
164− -> IO ()
165−spawn settings stateRef tidRef = do
166− tid <- forkIO $ reaper settings stateRef tidRef
167− writeIORef tidRef $ Just tid
168−
169−reaper :: ReaperSettings workload item
170− -> IORef (State workload) -> IORef (Maybe ThreadId)
171− -> IO ()
172−reaper settings@ReaperSettings{..} stateRef tidRef = do
173− threadDelay reaperDelay
174− -- Getting the current jobs. Push an empty job to the reference.
175− wl <- atomicModifyIORef' stateRef swapWithEmpty
176− -- Do the jobs. A function to merge the left jobs and
177− -- new jobs is returned.
178− !merge <- reaperAction wl
179− -- Merging the left jobs and new jobs.
180− -- If there is no jobs, this thread finishes.
181− next <- atomicModifyIORef' stateRef (check merge)
182− next
183− where
184− swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)"
185− swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl)
186−
187− check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"
188− check merge (Workload wl)
189− -- If there is no job, reaper is terminated.
190− | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing)
191− -- If there are jobs, carry them out.
192− | otherwise = (Workload wl', reaper settings stateRef tidRef)
193− where
194− wl' = merge wl
195−
196−-- | A helper function for creating 'reaperAction' functions. You would
197−-- provide this function with a function to process a single work item and
198−-- return either a new work item, or @Nothing@ if the work item is
199−-- expired.
200−--
201−-- @since 0.1.1
202−mkListAction :: (item -> IO (Maybe item'))
203− -> [item]
204− -> IO ([item'] -> [item'])
205−mkListAction f =
206− go id
207− where
208− go !front [] = return front
209− go !front (x:xs) = do
210− my <- f x
211− let front' =
212− case my of
213− Nothing -> front
214− Just y -> front . (y:)
215− 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/LICENSEdeleted−20
@@ -1,20 +0,0 @@
1−Copyright (c) 2014 Michael Snoyman
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 included
12−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 NONINFRINGEMENT.
17−IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18−CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19−TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20−SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
auto-update/README.mddeleted−13
@@ -1,13 +0,0 @@
1−## auto-update
2−
3−A common problem is the desire to have an action run at a scheduled interval,
4−but only if it is needed. For example, instead of having every web request
5−result in a new `getCurrentTime` call, we'd like to have a single worker thread
6−run every second, updating an `IORef`. However, if the request frequency is
7−less than once per second, this is a pessimization, and worse, kills idle GC.
8−
9−This library allows you to define actions which will either be performed by a
10−dedicated thread or, in times of low volume, will be executed by the calling
11−thread.
12−
13−For original use case, see [yesod-scaffold issue #15](https://github.com/yesodweb/yesod-scaffold/pull/15).
auto-update/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
auto-update/auto-update.cabaldeleted−38
@@ -1,38 +0,0 @@
1−name: auto-update
2−version: 0.1.6
3−synopsis: Efficiently run periodic, on-demand actions
4−description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.
5−homepage: https://github.com/yesodweb/wai
6−license: MIT
7−license-file: LICENSE
8−author: Michael Snoyman
9−maintainer: michael@snoyman.com
10−category: Control
11−build-type: Simple
12−extra-source-files: README.md
13− ChangeLog.md
14−cabal-version: >=1.10
15−
16−library
17− ghc-options: -Wall
18− exposed-modules: Control.AutoUpdate
19− Control.Debounce
20− Control.Debounce.Internal
21− Control.Reaper
22− other-modules: Control.AutoUpdate.Util
23− build-depends: base >= 4 && < 5
24− default-language: Haskell2010
25− if impl(ghc >= 8)
26− default-extensions: Strict StrictData
27−
28−-- Test suite is currently not robust enough, gives too many false negatives.
29−
30−test-suite spec
31− main-is: Spec.hs
32− other-modules: Control.AutoUpdateSpec
33− Control.DebounceSpec
34− Control.ReaperSpec
35− hs-source-dirs: test
36− type: exitcode-stdio-1.0
37− build-depends: base, auto-update, exceptions, hspec, retry, HUnit
38− default-language: Haskell2010
auto-update/test/Control/AutoUpdateSpec.hsdeleted−35
@@ -1,35 +0,0 @@
1−module Control.AutoUpdateSpec (spec) where
2−
3−import Control.AutoUpdate
4−import Control.Concurrent (threadDelay)
5−import Control.Monad (replicateM_, forM_)
6−import Data.IORef
7−import Test.Hspec
8−import Test.Hspec.QuickCheck
9−
10−spec :: Spec
11−spec = return ()
12− -- do
13− -- prop "incrementer" $ \st' -> do
14− -- let st = abs st' `mod` 10000
15− -- ref <- newIORef 0
16− -- next <- mkAutoUpdate defaultUpdateSettings
17− -- { updateAction = atomicModifyIORef ref $ \i ->
18− -- let i' = succ i in i' `seq` (i', i')
19− -- , updateSpawnThreshold = st
20− -- , updateFreq = 10000
21− -- }
22−
23− -- forM_ [1..st + 1] $ \i -> do
24− -- j <- next
25− -- j `shouldBe` i
26−
27− -- replicateM_ 50 $ do
28− -- i <- next
29− -- i `shouldBe` st + 2
30−
31− -- threadDelay 60000
32− -- last1 <- readIORef ref
33− -- threadDelay 20000
34− -- last2 <- readIORef ref
35− -- 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.hsdeleted−39
@@ -1,39 +0,0 @@
1−module Control.ReaperSpec (spec) where
2−
3−import Control.Concurrent
4−import Control.Reaper
5−import Data.IORef
6−import Test.Hspec
7−import Test.Hspec.QuickCheck
8−
9−
10−spec :: Spec
11−spec = return ()
12−-- prop "works" $ \is -> do
13−-- reaper <- mkReaper defaultReaperSettings
14−-- { reaperAction = action
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−
25−-- let test (expected, ref) = do
26−-- actual <- readIORef ref
27−-- actual `shouldBe` (expected :: Int)
28−-- threadDelay 100000
29−-- mapM_ test testCases
30−-- [] <- reaperRead reaper
31−-- return ()
32−
33−-- type Item = (Int, IORef Int)
34−
35−-- action = mkListAction $ \(i, ref) -> do
36−-- modifyIORef ref succ
37−-- return $ if i > 1
38−-- then Just (pred i, ref)
39−-- else Nothing
auto-update/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
mime-types/ChangeLog.mddeleted−15
@@ -1,15 +0,0 @@
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
14−
15−* Add woff2 mime type [#350](https://github.com/yesodweb/wai/pull/350)
mime-types/LICENSEdeleted−20
@@ -1,20 +0,0 @@
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.
mime-types/Network/Mime.hsdeleted−1096
@@ -1,1096 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Mime
3− ( -- * Lookups
4− mimeByExt
5− , defaultMimeLookup
6− -- * Defaults
7− , defaultMimeType
8− , defaultMimeMap
9− -- * Utilities
10− , fileNameExtensions
11− -- * Types
12− , FileName
13− , MimeType
14− , MimeMap
15− , Extension
16− ) where
17−
18−import Data.Text (Text)
19−import qualified Data.Text as T
20−import Data.ByteString (ByteString)
21−import Data.ByteString.Char8 ()
22−import qualified Data.Map as Map
23−
24−-- | Maps extensions to mime types.
25−type MimeMap = Map.Map Extension MimeType
26−
27−-- | The filename component of a filepath, leaving off the directory but
28−-- keeping all extensions.
29−type FileName = Text
30−
31−-- | Individual mime type for be served over the wire.
32−type MimeType = ByteString
33−
34−-- | Look up a mime type from the given mime map and default mime type.
35−mimeByExt :: MimeMap
36− -> MimeType -- ^ default mime type
37− -> FileName
38− -> MimeType
39−mimeByExt mm def =
40− go . fileNameExtensions
41− where
42− go [] = def
43− go (e:es) =
44− case Map.lookup e mm of
45− Nothing -> go es
46− Just mt -> mt
47−
48−-- | @mimeByExt@ applied to @defaultMimeType@ and @defaultMimeMap@.
49−defaultMimeLookup :: FileName -> MimeType
50−defaultMimeLookup = mimeByExt defaultMimeMap defaultMimeType
51−
52−-- | Get a list of all of the file name extensions.
53−--
54−-- > fileNameExtensions "foo.tar.gz" == ["tar.gz", "gz"]
55−fileNameExtensions :: FileName -> [Extension]
56−fileNameExtensions =
57− go . T.toLower . dropToExt
58− where
59− dropToExt = T.drop 1 . T.dropWhile (/= '.')
60−
61− go e
62− | T.null e = []
63− | otherwise = e : go next
64− where
65− next = dropToExt e
66−
67−-- | Path extension. May include multiple components, e.g. tar.gz
68−type Extension = Text
69−
70−-- | The default fallback mime type \"application/octet-stream\".
71−defaultMimeType :: MimeType
72−defaultMimeType = "application/octet-stream"
73−
74−-- | A default mapping from filename extension to mime type.
75−--
76−-- Generated from the Apache and nginx mime.types files.
77−defaultMimeMap :: MimeMap
78−defaultMimeMap = Map.fromAscList [
79− ("123", "application/vnd.lotus-1-2-3")
80− , ("3dml", "text/vnd.in3d.3dml")
81− , ("3ds", "image/x-3ds")
82− , ("3g2", "video/3gpp2")
83− , ("3gp", "video/3gpp")
84− , ("3gpp", "video/3gpp")
85− , ("7z", "application/x-7z-compressed")
86− , ("aab", "application/x-authorware-bin")
87− , ("aac", "audio/x-aac")
88− , ("aam", "application/x-authorware-map")
89− , ("aas", "application/x-authorware-seg")
90− , ("abw", "application/x-abiword")
91− , ("ac", "application/pkix-attr-cert")
92− , ("acc", "application/vnd.americandynamics.acc")
93− , ("ace", "application/x-ace-compressed")
94− , ("acu", "application/vnd.acucobol")
95− , ("acutc", "application/vnd.acucorp")
96− , ("adp", "audio/adpcm")
97− , ("aep", "application/vnd.audiograph")
98− , ("afm", "application/x-font-type1")
99− , ("afp", "application/vnd.ibm.modcap")
100− , ("ahead", "application/vnd.ahead.space")
101− , ("ai", "application/postscript")
102− , ("aif", "audio/x-aiff")
103− , ("aifc", "audio/x-aiff")
104− , ("aiff", "audio/x-aiff")
105− , ("air", "application/vnd.adobe.air-application-installer-package+zip")
106− , ("ait", "application/vnd.dvb.ait")
107− , ("ami", "application/vnd.amiga.ami")
108− , ("apk", "application/vnd.android.package-archive")
109− , ("appcache", "text/cache-manifest")
110− , ("application", "application/x-ms-application")
111− , ("apr", "application/vnd.lotus-approach")
112− , ("arc", "application/x-freearc")
113− , ("asc", "text/plain")
114− , ("asf", "video/x-ms-asf")
115− , ("asm", "text/x-asm")
116− , ("aso", "application/vnd.accpac.simply.aso")
117− , ("asx", "video/x-ms-asf")
118− , ("atc", "application/vnd.acucorp")
119− , ("atom", "application/atom+xml")
120− , ("atomcat", "application/atomcat+xml")
121− , ("atomsvc", "application/atomsvc+xml")
122− , ("atx", "application/vnd.antix.game-component")
123− , ("au", "audio/basic")
124− , ("avi", "video/x-msvideo")
125− , ("aw", "application/applixware")
126− , ("azf", "application/vnd.airzip.filesecure.azf")
127− , ("azs", "application/vnd.airzip.filesecure.azs")
128− , ("azw", "application/vnd.amazon.ebook")
129− , ("bat", "application/x-msdownload")
130− , ("bcpio", "application/x-bcpio")
131− , ("bdf", "application/x-font-bdf")
132− , ("bdm", "application/vnd.syncml.dm+wbxml")
133− , ("bed", "application/vnd.realvnc.bed")
134− , ("bh2", "application/vnd.fujitsu.oasysprs")
135− , ("bin", "application/octet-stream")
136− , ("blb", "application/x-blorb")
137− , ("blorb", "application/x-blorb")
138− , ("bmi", "application/vnd.bmi")
139− , ("bmp", "image/bmp")
140− , ("book", "application/vnd.framemaker")
141− , ("box", "application/vnd.previewsystems.box")
142− , ("boz", "application/x-bzip2")
143− , ("bpk", "application/octet-stream")
144− , ("btif", "image/prs.btif")
145− , ("bz", "application/x-bzip")
146− , ("bz2", "application/x-bzip")
147− , ("c", "text/plain")
148− , ("c11amc", "application/vnd.cluetrust.cartomobile-config")
149− , ("c11amz", "application/vnd.cluetrust.cartomobile-config-pkg")
150− , ("c4d", "application/vnd.clonk.c4group")
151− , ("c4f", "application/vnd.clonk.c4group")
152− , ("c4g", "application/vnd.clonk.c4group")
153− , ("c4p", "application/vnd.clonk.c4group")
154− , ("c4u", "application/vnd.clonk.c4group")
155− , ("cab", "application/vnd.ms-cab-compressed")
156− , ("caf", "audio/x-caf")
157− , ("cap", "application/vnd.tcpdump.pcap")
158− , ("car", "application/vnd.curl.car")
159− , ("cat", "application/vnd.ms-pki.seccat")
160− , ("cb7", "application/x-cbr")
161− , ("cba", "application/x-cbr")
162− , ("cbr", "application/x-cbr")
163− , ("cbt", "application/x-cbr")
164− , ("cbz", "application/x-cbr")
165− , ("cc", "text/x-c")
166− , ("cco", "application/x-cocoa")
167− , ("cct", "application/x-director")
168− , ("ccxml", "application/ccxml+xml")
169− , ("cdbcmsg", "application/vnd.contact.cmsg")
170− , ("cdf", "application/x-netcdf")
171− , ("cdkey", "application/vnd.mediastation.cdkey")
172− , ("cdmia", "application/cdmi-capability")
173− , ("cdmic", "application/cdmi-container")
174− , ("cdmid", "application/cdmi-domain")
175− , ("cdmio", "application/cdmi-object")
176− , ("cdmiq", "application/cdmi-queue")
177− , ("cdx", "chemical/x-cdx")
178− , ("cdxml", "application/vnd.chemdraw+xml")
179− , ("cdy", "application/vnd.cinderella")
180− , ("cer", "application/pkix-cert")
181− , ("cfs", "application/x-cfs-compressed")
182− , ("cgm", "image/cgm")
183− , ("chat", "application/x-chat")
184− , ("chm", "application/vnd.ms-htmlhelp")
185− , ("chrt", "application/vnd.kde.kchart")
186− , ("cif", "chemical/x-cif")
187− , ("cii", "application/vnd.anser-web-certificate-issue-initiation")
188− , ("cil", "application/vnd.ms-artgalry")
189− , ("cla", "application/vnd.claymore")
190− , ("class", "application/java-vm")
191− , ("clkk", "application/vnd.crick.clicker.keyboard")
192− , ("clkp", "application/vnd.crick.clicker.palette")
193− , ("clkt", "application/vnd.crick.clicker.template")
194− , ("clkw", "application/vnd.crick.clicker.wordbank")
195− , ("clkx", "application/vnd.crick.clicker")
196− , ("clp", "application/x-msclip")
197− , ("cmc", "application/vnd.cosmocaller")
198− , ("cmdf", "chemical/x-cmdf")
199− , ("cml", "chemical/x-cml")
200− , ("cmp", "application/vnd.yellowriver-custom-menu")
201− , ("cmx", "image/x-cmx")
202− , ("cod", "application/vnd.rim.cod")
203− , ("com", "application/x-msdownload")
204− , ("conf", "text/plain")
205− , ("cpio", "application/x-cpio")
206− , ("cpp", "text/plain")
207− , ("cpt", "application/mac-compactpro")
208− , ("crd", "application/x-mscardfile")
209− , ("crl", "application/pkix-crl")
210− , ("crt", "application/x-x509-ca-cert")
211− , ("cryptonote", "application/vnd.rig.cryptonote")
212− , ("csh", "application/x-csh")
213− , ("csml", "chemical/x-csml")
214− , ("csp", "application/vnd.commonspace")
215− , ("css", "text/css")
216− , ("cst", "application/x-director")
217− , ("csv", "text/csv")
218− , ("cu", "application/cu-seeme")
219− , ("curl", "text/vnd.curl")
220− , ("cww", "application/prs.cww")
221− , ("cxt", "application/x-director")
222− , ("cxx", "text/plain")
223− , ("dae", "model/vnd.collada+xml")
224− , ("daf", "application/vnd.mobius.daf")
225− , ("dart", "application/vnd.dart")
226− , ("dataless", "application/vnd.fdsn.seed")
227− , ("davmount", "application/davmount+xml")
228− , ("dbk", "application/docbook+xml")
229− , ("dcr", "application/x-director")
230− , ("dcurl", "text/vnd.curl.dcurl")
231− , ("dd2", "application/vnd.oma.dd2+xml")
232− , ("ddd", "application/vnd.fujixerox.ddd")
233− , ("deb", "application/x-debian-package")
234− , ("def", "text/plain")
235− , ("deploy", "application/octet-stream")
236− , ("der", "application/x-x509-ca-cert")
237− , ("dfac", "application/vnd.dreamfactory")
238− , ("dgc", "application/x-dgc-compressed")
239− , ("dic", "text/x-c")
240− , ("dir", "application/x-director")
241− , ("dis", "application/vnd.mobius.dis")
242− , ("dist", "application/octet-stream")
243− , ("distz", "application/octet-stream")
244− , ("djv", "image/vnd.djvu")
245− , ("djvu", "image/vnd.djvu")
246− , ("dll", "application/x-msdownload")
247− , ("dmg", "application/x-apple-diskimage")
248− , ("dmp", "application/vnd.tcpdump.pcap")
249− , ("dms", "application/octet-stream")
250− , ("dna", "application/vnd.dna")
251− , ("doc", "application/msword")
252− , ("docm", "application/vnd.ms-word.document.macroenabled.12")
253− , ("docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
254− , ("dot", "application/msword")
255− , ("dotm", "application/vnd.ms-word.template.macroenabled.12")
256− , ("dotx", "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
257− , ("dp", "application/vnd.osgi.dp")
258− , ("dpg", "application/vnd.dpgraph")
259− , ("dra", "audio/vnd.dra")
260− , ("dsc", "text/prs.lines.tag")
261− , ("dssc", "application/dssc+der")
262− , ("dtb", "application/x-dtbook+xml")
263− , ("dtd", "application/xml-dtd")
264− , ("dts", "audio/vnd.dts")
265− , ("dtshd", "audio/vnd.dts.hd")
266− , ("dump", "application/octet-stream")
267− , ("dvb", "video/vnd.dvb.file")
268− , ("dvi", "application/x-dvi")
269− , ("dwf", "model/vnd.dwf")
270− , ("dwg", "image/vnd.dwg")
271− , ("dxf", "image/vnd.dxf")
272− , ("dxp", "application/vnd.spotfire.dxp")
273− , ("dxr", "application/x-director")
274− , ("ear", "application/java-archive")
275− , ("ecelp4800", "audio/vnd.nuera.ecelp4800")
276− , ("ecelp7470", "audio/vnd.nuera.ecelp7470")
277− , ("ecelp9600", "audio/vnd.nuera.ecelp9600")
278− , ("ecma", "application/ecmascript")
279− , ("edm", "application/vnd.novadigm.edm")
280− , ("edx", "application/vnd.novadigm.edx")
281− , ("efif", "application/vnd.picsel")
282− , ("ei6", "application/vnd.pg.osasli")
283− , ("elc", "application/octet-stream")
284− , ("emf", "application/x-msmetafile")
285− , ("eml", "message/rfc822")
286− , ("emma", "application/emma+xml")
287− , ("emz", "application/x-msmetafile")
288− , ("eol", "audio/vnd.digital-winds")
289− , ("eot", "application/vnd.ms-fontobject")
290− , ("eps", "application/postscript")
291− , ("epub", "application/epub+zip")
292− , ("es3", "application/vnd.eszigno3+xml")
293− , ("esa", "application/vnd.osgi.subsystem")
294− , ("esf", "application/vnd.epson.esf")
295− , ("et3", "application/vnd.eszigno3+xml")
296− , ("etx", "text/x-setext")
297− , ("eva", "application/x-eva")
298− , ("evy", "application/x-envoy")
299− , ("exe", "application/x-msdownload")
300− , ("exi", "application/exi")
301− , ("ext", "application/vnd.novadigm.ext")
302− , ("ez", "application/andrew-inset")
303− , ("ez2", "application/vnd.ezpix-album")
304− , ("ez3", "application/vnd.ezpix-package")
305− , ("f", "text/x-fortran")
306− , ("f4v", "video/x-f4v")
307− , ("f77", "text/x-fortran")
308− , ("f90", "text/x-fortran")
309− , ("fbs", "image/vnd.fastbidsheet")
310− , ("fcdt", "application/vnd.adobe.formscentral.fcdt")
311− , ("fcs", "application/vnd.isac.fcs")
312− , ("fdf", "application/vnd.fdf")
313− , ("fe_launch", "application/vnd.denovo.fcselayout-link")
314− , ("fg5", "application/vnd.fujitsu.oasysgp")
315− , ("fgd", "application/x-director")
316− , ("fh", "image/x-freehand")
317− , ("fh4", "image/x-freehand")
318− , ("fh5", "image/x-freehand")
319− , ("fh7", "image/x-freehand")
320− , ("fhc", "image/x-freehand")
321− , ("fig", "application/x-xfig")
322− , ("flac", "audio/x-flac")
323− , ("fli", "video/x-fli")
324− , ("flo", "application/vnd.micrografx.flo")
325− , ("flv", "video/x-flv")
326− , ("flw", "application/vnd.kde.kivio")
327− , ("flx", "text/vnd.fmi.flexstor")
328− , ("fly", "text/vnd.fly")
329− , ("fm", "application/vnd.framemaker")
330− , ("fnc", "application/vnd.frogans.fnc")
331− , ("for", "text/x-fortran")
332− , ("fpx", "image/vnd.fpx")
333− , ("frame", "application/vnd.framemaker")
334− , ("fsc", "application/vnd.fsc.weblaunch")
335− , ("fst", "image/vnd.fst")
336− , ("ftc", "application/vnd.fluxtime.clip")
337− , ("fti", "application/vnd.anser-web-funds-transfer-initiation")
338− , ("fvt", "video/vnd.fvt")
339− , ("fxp", "application/vnd.adobe.fxp")
340− , ("fxpl", "application/vnd.adobe.fxp")
341− , ("fzs", "application/vnd.fuzzysheet")
342− , ("g2w", "application/vnd.geoplan")
343− , ("g3", "image/g3fax")
344− , ("g3w", "application/vnd.geospace")
345− , ("gac", "application/vnd.groove-account")
346− , ("gam", "application/x-tads")
347− , ("gbr", "application/rpki-ghostbusters")
348− , ("gca", "application/x-gca-compressed")
349− , ("gdl", "model/vnd.gdl")
350− , ("geo", "application/vnd.dynageo")
351− , ("gex", "application/vnd.geometry-explorer")
352− , ("ggb", "application/vnd.geogebra.file")
353− , ("ggt", "application/vnd.geogebra.tool")
354− , ("ghf", "application/vnd.groove-help")
355− , ("gif", "image/gif")
356− , ("gim", "application/vnd.groove-identity-message")
357− , ("gml", "application/gml+xml")
358− , ("gmx", "application/vnd.gmx")
359− , ("gnumeric", "application/x-gnumeric")
360− , ("gph", "application/vnd.flographit")
361− , ("gpx", "application/gpx+xml")
362− , ("gqf", "application/vnd.grafeq")
363− , ("gqs", "application/vnd.grafeq")
364− , ("gram", "application/srgs")
365− , ("gramps", "application/x-gramps-xml")
366− , ("gre", "application/vnd.geometry-explorer")
367− , ("grv", "application/vnd.groove-injector")
368− , ("grxml", "application/srgs+xml")
369− , ("gsf", "application/x-font-ghostscript")
370− , ("gtar", "application/x-gtar")
371− , ("gtm", "application/vnd.groove-tool-message")
372− , ("gtw", "model/vnd.gtw")
373− , ("gv", "text/vnd.graphviz")
374− , ("gxf", "application/gxf")
375− , ("gxt", "application/vnd.geonext")
376− , ("gz", "application/x-gzip")
377− , ("h", "text/x-c")
378− , ("h261", "video/h261")
379− , ("h263", "video/h263")
380− , ("h264", "video/h264")
381− , ("hal", "application/vnd.hal+xml")
382− , ("hbci", "application/vnd.hbci")
383− , ("hdf", "application/x-hdf")
384− , ("hh", "text/x-c")
385− , ("hlp", "application/winhlp")
386− , ("hpgl", "application/vnd.hp-hpgl")
387− , ("hpid", "application/vnd.hp-hpid")
388− , ("hps", "application/vnd.hp-hps")
389− , ("hqx", "application/mac-binhex40")
390− , ("hs", "text/plain")
391− , ("htc", "text/x-component")
392− , ("htke", "application/vnd.kenameaapp")
393− , ("htm", "text/html")
394− , ("html", "text/html")
395− , ("hvd", "application/vnd.yamaha.hv-dic")
396− , ("hvp", "application/vnd.yamaha.hv-voice")
397− , ("hvs", "application/vnd.yamaha.hv-script")
398− , ("i2g", "application/vnd.intergeo")
399− , ("icc", "application/vnd.iccprofile")
400− , ("ice", "x-conference/x-cooltalk")
401− , ("icm", "application/vnd.iccprofile")
402− , ("ico", "image/vnd.microsoft.icon")
403− , ("ics", "text/calendar")
404− , ("ief", "image/ief")
405− , ("ifb", "text/calendar")
406− , ("ifm", "application/vnd.shana.informed.formdata")
407− , ("iges", "model/iges")
408− , ("igl", "application/vnd.igloader")
409− , ("igm", "application/vnd.insors.igm")
410− , ("igs", "model/iges")
411− , ("igx", "application/vnd.micrografx.igx")
412− , ("iif", "application/vnd.shana.informed.interchange")
413− , ("img", "application/octet-stream")
414− , ("imp", "application/vnd.accpac.simply.imp")
415− , ("ims", "application/vnd.ms-ims")
416− , ("in", "text/plain")
417− , ("ink", "application/inkml+xml")
418− , ("inkml", "application/inkml+xml")
419− , ("install", "application/x-install-instructions")
420− , ("iota", "application/vnd.astraea-software.iota")
421− , ("ipfix", "application/ipfix")
422− , ("ipk", "application/vnd.shana.informed.package")
423− , ("irm", "application/vnd.ibm.rights-management")
424− , ("irp", "application/vnd.irepository.package+xml")
425− , ("iso", "application/x-iso9660-image")
426− , ("itp", "application/vnd.shana.informed.formtemplate")
427− , ("ivp", "application/vnd.immervision-ivp")
428− , ("ivu", "application/vnd.immervision-ivu")
429− , ("jad", "text/vnd.sun.j2me.app-descriptor")
430− , ("jam", "application/vnd.jam")
431− , ("jar", "application/java-archive")
432− , ("jardiff", "application/x-java-archive-diff")
433− , ("java", "text/x-java-source")
434− , ("jisp", "application/vnd.jisp")
435− , ("jlt", "application/vnd.hp-jlyt")
436− , ("jng", "image/x-jng")
437− , ("jnlp", "application/x-java-jnlp-file")
438− , ("joda", "application/vnd.joost.joda-archive")
439− , ("jpe", "image/jpeg")
440− , ("jpeg", "image/jpeg")
441− , ("jpg", "image/jpeg")
442− , ("jpgm", "video/jpm")
443− , ("jpgv", "video/jpeg")
444− , ("jpm", "video/jpm")
445− , ("js", "application/javascript")
446− , ("json", "application/json")
447− , ("jsonml", "application/jsonml+json")
448− , ("kar", "audio/midi")
449− , ("karbon", "application/vnd.kde.karbon")
450− , ("kfo", "application/vnd.kde.kformula")
451− , ("kia", "application/vnd.kidspiration")
452− , ("kml", "application/vnd.google-earth.kml+xml")
453− , ("kmz", "application/vnd.google-earth.kmz")
454− , ("kne", "application/vnd.kinar")
455− , ("knp", "application/vnd.kinar")
456− , ("kon", "application/vnd.kde.kontour")
457− , ("kpr", "application/vnd.kde.kpresenter")
458− , ("kpt", "application/vnd.kde.kpresenter")
459− , ("kpxx", "application/vnd.ds-keypoint")
460− , ("ksp", "application/vnd.kde.kspread")
461− , ("ktr", "application/vnd.kahootz")
462− , ("ktx", "image/ktx")
463− , ("ktz", "application/vnd.kahootz")
464− , ("kwd", "application/vnd.kde.kword")
465− , ("kwt", "application/vnd.kde.kword")
466− , ("lasxml", "application/vnd.las.las+xml")
467− , ("latex", "application/x-latex")
468− , ("lbd", "application/vnd.llamagraphics.life-balance.desktop")
469− , ("lbe", "application/vnd.llamagraphics.life-balance.exchange+xml")
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")
477− , ("link66", "application/vnd.route66.link66+xml")
478− , ("list", "text/plain")
479− , ("list3820", "application/vnd.ibm.modcap")
480− , ("listafp", "application/vnd.ibm.modcap")
481− , ("lnk", "application/x-ms-shortcut")
482− , ("log", "text/plain")
483− , ("lostxml", "application/lost+xml")
484− , ("lrf", "application/octet-stream")
485− , ("lrm", "application/vnd.ms-lrm")
486− , ("ltf", "application/vnd.frogans.ltf")
487− , ("lvp", "audio/vnd.lucent.voice")
488− , ("lwp", "application/vnd.lotus-wordpro")
489− , ("lzh", "application/x-lzh-compressed")
490− , ("m13", "application/x-msmediaview")
491− , ("m14", "application/x-msmediaview")
492− , ("m1v", "video/mpeg")
493− , ("m21", "application/mp21")
494− , ("m2a", "audio/mpeg")
495− , ("m2v", "video/mpeg")
496− , ("m3a", "audio/mpeg")
497− , ("m3u", "audio/x-mpegurl")
498− , ("m3u8", "application/vnd.apple.mpegurl")
499− , ("m4a", "audio/x-m4a")
500− , ("m4u", "video/vnd.mpegurl")
501− , ("m4v", "video/x-m4v")
502− , ("ma", "application/mathematica")
503− , ("mads", "application/mads+xml")
504− , ("mag", "application/vnd.ecowin.chart")
505− , ("maker", "application/vnd.framemaker")
506− , ("man", "text/troff")
507− , ("manifest", "text/cache-manifest")
508− , ("mar", "application/octet-stream")
509− , ("mathml", "application/mathml+xml")
510− , ("mb", "application/mathematica")
511− , ("mbk", "application/vnd.mobius.mbk")
512− , ("mbox", "application/mbox")
513− , ("mc1", "application/vnd.medcalcdata")
514− , ("mcd", "application/vnd.mcd")
515− , ("mcurl", "text/vnd.curl.mcurl")
516− , ("mdb", "application/x-msaccess")
517− , ("mdi", "image/vnd.ms-modi")
518− , ("me", "text/troff")
519− , ("mesh", "model/mesh")
520− , ("meta4", "application/metalink4+xml")
521− , ("metalink", "application/metalink+xml")
522− , ("mets", "application/mets+xml")
523− , ("mfm", "application/vnd.mfmp")
524− , ("mft", "application/rpki-manifest")
525− , ("mgp", "application/vnd.osgeo.mapguide.package")
526− , ("mgz", "application/vnd.proteus.magazine")
527− , ("mid", "audio/midi")
528− , ("midi", "audio/midi")
529− , ("mie", "application/x-mie")
530− , ("mif", "application/vnd.mif")
531− , ("mime", "message/rfc822")
532− , ("mj2", "video/mj2")
533− , ("mjp2", "video/mj2")
534− , ("mjs", "application/javascript")
535− , ("mk3d", "video/x-matroska")
536− , ("mka", "audio/x-matroska")
537− , ("mks", "video/x-matroska")
538− , ("mkv", "video/x-matroska")
539− , ("mlp", "application/vnd.dolby.mlp")
540− , ("mmd", "application/vnd.chipnuts.karaoke-mmd")
541− , ("mmf", "application/vnd.smaf")
542− , ("mml", "text/mathml")
543− , ("mmr", "image/vnd.fujixerox.edmics-mmr")
544− , ("mng", "video/x-mng")
545− , ("mny", "application/x-msmoney")
546− , ("mobi", "application/x-mobipocket-ebook")
547− , ("mods", "application/mods+xml")
548− , ("mov", "video/quicktime")
549− , ("movie", "video/x-sgi-movie")
550− , ("mp2", "audio/mpeg")
551− , ("mp21", "application/mp21")
552− , ("mp2a", "audio/mpeg")
553− , ("mp3", "audio/mpeg")
554− , ("mp4", "video/mp4")
555− , ("mp4a", "audio/mp4")
556− , ("mp4s", "application/mp4")
557− , ("mp4v", "video/mp4")
558− , ("mpc", "application/vnd.mophun.certificate")
559− , ("mpe", "video/mpeg")
560− , ("mpeg", "video/mpeg")
561− , ("mpg", "video/mpeg")
562− , ("mpg4", "video/mp4")
563− , ("mpga", "audio/mpeg")
564− , ("mpkg", "application/vnd.apple.installer+xml")
565− , ("mpm", "application/vnd.blueice.multipass")
566− , ("mpn", "application/vnd.mophun.application")
567− , ("mpp", "application/vnd.ms-project")
568− , ("mpt", "application/vnd.ms-project")
569− , ("mpy", "application/vnd.ibm.minipay")
570− , ("mqy", "application/vnd.mobius.mqy")
571− , ("mrc", "application/marc")
572− , ("mrcx", "application/marcxml+xml")
573− , ("ms", "text/troff")
574− , ("mscml", "application/mediaservercontrol+xml")
575− , ("mseed", "application/vnd.fdsn.mseed")
576− , ("mseq", "application/vnd.mseq")
577− , ("msf", "application/vnd.epson.msf")
578− , ("msh", "model/mesh")
579− , ("msi", "application/x-msdownload")
580− , ("msl", "application/vnd.mobius.msl")
581− , ("msm", "application/octet-stream")
582− , ("msp", "application/octet-stream")
583− , ("msty", "application/vnd.muvee.style")
584− , ("mts", "model/vnd.mts")
585− , ("mus", "application/vnd.musician")
586− , ("musicxml", "application/vnd.recordare.musicxml+xml")
587− , ("mvb", "application/x-msmediaview")
588− , ("mwf", "application/vnd.mfer")
589− , ("mxf", "application/mxf")
590− , ("mxl", "application/vnd.recordare.musicxml")
591− , ("mxml", "application/xv+xml")
592− , ("mxs", "application/vnd.triscape.mxs")
593− , ("mxu", "video/vnd.mpegurl")
594− , ("n-gage", "application/vnd.nokia.n-gage.symbian.install")
595− , ("n3", "text/n3")
596− , ("nb", "application/mathematica")
597− , ("nbp", "application/vnd.wolfram.player")
598− , ("nc", "application/x-netcdf")
599− , ("ncx", "application/x-dtbncx+xml")
600− , ("nfo", "text/x-nfo")
601− , ("ngdat", "application/vnd.nokia.n-gage.data")
602− , ("nitf", "application/vnd.nitf")
603− , ("nlu", "application/vnd.neurolanguage.nlu")
604− , ("nml", "application/vnd.enliven")
605− , ("nnd", "application/vnd.noblenet-directory")
606− , ("nns", "application/vnd.noblenet-sealer")
607− , ("nnw", "application/vnd.noblenet-web")
608− , ("npx", "image/vnd.net-fpx")
609− , ("nsc", "application/x-conference")
610− , ("nsf", "application/vnd.lotus-notes")
611− , ("ntf", "application/vnd.nitf")
612− , ("nzb", "application/x-nzb")
613− , ("oa2", "application/vnd.fujitsu.oasys2")
614− , ("oa3", "application/vnd.fujitsu.oasys3")
615− , ("oas", "application/vnd.fujitsu.oasys")
616− , ("obd", "application/x-msbinder")
617− , ("obj", "application/x-tgif")
618− , ("oda", "application/oda")
619− , ("odb", "application/vnd.oasis.opendocument.database")
620− , ("odc", "application/vnd.oasis.opendocument.chart")
621− , ("odf", "application/vnd.oasis.opendocument.formula")
622− , ("odft", "application/vnd.oasis.opendocument.formula-template")
623− , ("odg", "application/vnd.oasis.opendocument.graphics")
624− , ("odi", "application/vnd.oasis.opendocument.image")
625− , ("odm", "application/vnd.oasis.opendocument.text-master")
626− , ("odp", "application/vnd.oasis.opendocument.presentation")
627− , ("ods", "application/vnd.oasis.opendocument.spreadsheet")
628− , ("odt", "application/vnd.oasis.opendocument.text")
629− , ("oga", "audio/ogg")
630− , ("ogg", "audio/ogg")
631− , ("ogv", "video/ogg")
632− , ("ogx", "application/ogg")
633− , ("omdoc", "application/omdoc+xml")
634− , ("onepkg", "application/onenote")
635− , ("onetmp", "application/onenote")
636− , ("onetoc", "application/onenote")
637− , ("onetoc2", "application/onenote")
638− , ("opf", "application/oebps-package+xml")
639− , ("opml", "text/x-opml")
640− , ("oprc", "application/vnd.palm")
641− , ("org", "application/vnd.lotus-organizer")
642− , ("osf", "application/vnd.yamaha.openscoreformat")
643− , ("osfpvg", "application/vnd.yamaha.openscoreformat.osfpvg+xml")
644− , ("otc", "application/vnd.oasis.opendocument.chart-template")
645− , ("otf", "application/x-font-otf")
646− , ("otg", "application/vnd.oasis.opendocument.graphics-template")
647− , ("oth", "application/vnd.oasis.opendocument.text-web")
648− , ("oti", "application/vnd.oasis.opendocument.image-template")
649− , ("otp", "application/vnd.oasis.opendocument.presentation-template")
650− , ("ots", "application/vnd.oasis.opendocument.spreadsheet-template")
651− , ("ott", "application/vnd.oasis.opendocument.text-template")
652− , ("oxps", "application/oxps")
653− , ("oxt", "application/vnd.openofficeorg.extension")
654− , ("p", "text/x-pascal")
655− , ("p10", "application/pkcs10")
656− , ("p12", "application/x-pkcs12")
657− , ("p7b", "application/x-pkcs7-certificates")
658− , ("p7c", "application/pkcs7-mime")
659− , ("p7m", "application/pkcs7-mime")
660− , ("p7r", "application/x-pkcs7-certreqresp")
661− , ("p7s", "application/pkcs7-signature")
662− , ("p8", "application/pkcs8")
663− , ("pac", "application/x-ns-proxy-autoconfig")
664− , ("pas", "text/x-pascal")
665− , ("paw", "application/vnd.pawaafile")
666− , ("pbd", "application/vnd.powerbuilder6")
667− , ("pbm", "image/x-portable-bitmap")
668− , ("pcap", "application/vnd.tcpdump.pcap")
669− , ("pcf", "application/x-font-pcf")
670− , ("pcl", "application/vnd.hp-pcl")
671− , ("pclxl", "application/vnd.hp-pclxl")
672− , ("pct", "image/x-pict")
673− , ("pcurl", "application/vnd.curl.pcurl")
674− , ("pcx", "image/x-pcx")
675− , ("pdb", "application/vnd.palm")
676− , ("pdf", "application/pdf")
677− , ("pem", "application/x-x509-ca-cert")
678− , ("pfa", "application/x-font-type1")
679− , ("pfb", "application/x-font-type1")
680− , ("pfm", "application/x-font-type1")
681− , ("pfr", "application/font-tdpfr")
682− , ("pfx", "application/x-pkcs12")
683− , ("pgm", "image/x-portable-graymap")
684− , ("pgn", "application/x-chess-pgn")
685− , ("pgp", "application/pgp-encrypted")
686− , ("pic", "image/x-pict")
687− , ("pkg", "application/octet-stream")
688− , ("pki", "application/pkixcmp")
689− , ("pkipath", "application/pkix-pkipath")
690− , ("pl", "application/x-perl")
691− , ("plb", "application/vnd.3gpp.pic-bw-large")
692− , ("plc", "application/vnd.mobius.plc")
693− , ("plf", "application/vnd.pocketlearn")
694− , ("pls", "application/pls+xml")
695− , ("pm", "application/x-perl")
696− , ("pml", "application/vnd.ctc-posml")
697− , ("png", "image/png")
698− , ("pnm", "image/x-portable-anymap")
699− , ("portpkg", "application/vnd.macports.portpkg")
700− , ("pot", "application/vnd.ms-powerpoint")
701− , ("potm", "application/vnd.ms-powerpoint.template.macroenabled.12")
702− , ("potx", "application/vnd.openxmlformats-officedocument.presentationml.template")
703− , ("ppam", "application/vnd.ms-powerpoint.addin.macroenabled.12")
704− , ("ppd", "application/vnd.cups-ppd")
705− , ("ppm", "image/x-portable-pixmap")
706− , ("pps", "application/vnd.ms-powerpoint")
707− , ("ppsm", "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
708− , ("ppsx", "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
709− , ("ppt", "application/vnd.ms-powerpoint")
710− , ("pptm", "application/vnd.ms-powerpoint.presentation.macroenabled.12")
711− , ("pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation")
712− , ("pqa", "application/vnd.palm")
713− , ("prc", "application/x-mobipocket-ebook")
714− , ("pre", "application/vnd.lotus-freelance")
715− , ("prf", "application/pics-rules")
716− , ("ps", "application/postscript")
717− , ("psb", "application/vnd.3gpp.pic-bw-small")
718− , ("psd", "image/vnd.adobe.photoshop")
719− , ("psf", "application/x-font-linux-psf")
720− , ("pskcxml", "application/pskc+xml")
721− , ("ptid", "application/vnd.pvi.ptid1")
722− , ("pub", "application/x-mspublisher")
723− , ("pvb", "application/vnd.3gpp.pic-bw-var")
724− , ("pwn", "application/vnd.3m.post-it-notes")
725− , ("pya", "audio/vnd.ms-playready.media.pya")
726− , ("pyv", "video/vnd.ms-playready.media.pyv")
727− , ("qam", "application/vnd.epson.quickanime")
728− , ("qbo", "application/vnd.intu.qbo")
729− , ("qfx", "application/vnd.intu.qfx")
730− , ("qps", "application/vnd.publishare-delta-tree")
731− , ("qt", "video/quicktime")
732− , ("qwd", "application/vnd.quark.quarkxpress")
733− , ("qwt", "application/vnd.quark.quarkxpress")
734− , ("qxb", "application/vnd.quark.quarkxpress")
735− , ("qxd", "application/vnd.quark.quarkxpress")
736− , ("qxl", "application/vnd.quark.quarkxpress")
737− , ("qxt", "application/vnd.quark.quarkxpress")
738− , ("ra", "audio/x-pn-realaudio")
739− , ("ram", "audio/x-pn-realaudio")
740− , ("rar", "application/x-rar-compressed")
741− , ("ras", "image/x-cmu-raster")
742− , ("rcprofile", "application/vnd.ipunplugged.rcprofile")
743− , ("rdf", "application/rdf+xml")
744− , ("rdz", "application/vnd.data-vision.rdz")
745− , ("rep", "application/vnd.businessobjects")
746− , ("res", "application/x-dtbresource+xml")
747− , ("rgb", "image/x-rgb")
748− , ("rif", "application/reginfo+xml")
749− , ("rip", "audio/vnd.rip")
750− , ("ris", "application/x-research-info-systems")
751− , ("rl", "application/resource-lists+xml")
752− , ("rlc", "image/vnd.fujixerox.edmics-rlc")
753− , ("rld", "application/resource-lists-diff+xml")
754− , ("rm", "application/vnd.rn-realmedia")
755− , ("rmi", "audio/midi")
756− , ("rmp", "audio/x-pn-realaudio-plugin")
757− , ("rms", "application/vnd.jcp.javame.midlet-rms")
758− , ("rmvb", "application/vnd.rn-realmedia-vbr")
759− , ("rnc", "application/relax-ng-compact-syntax")
760− , ("roa", "application/rpki-roa")
761− , ("roff", "text/troff")
762− , ("rp9", "application/vnd.cloanto.rp9")
763− , ("rpm", "application/x-redhat-package-manager")
764− , ("rpss", "application/vnd.nokia.radio-presets")
765− , ("rpst", "application/vnd.nokia.radio-preset")
766− , ("rq", "application/sparql-query")
767− , ("rs", "application/rls-services+xml")
768− , ("rsd", "application/rsd+xml")
769− , ("rss", "application/rss+xml")
770− , ("rtf", "application/rtf")
771− , ("rtx", "text/richtext")
772− , ("run", "application/x-makeself")
773− , ("s", "text/x-asm")
774− , ("s3m", "audio/s3m")
775− , ("saf", "application/vnd.yamaha.smaf-audio")
776− , ("sbml", "application/sbml+xml")
777− , ("sc", "application/vnd.ibm.secure-container")
778− , ("scd", "application/x-msschedule")
779− , ("scm", "application/vnd.lotus-screencam")
780− , ("scq", "application/scvp-cv-request")
781− , ("scs", "application/scvp-cv-response")
782− , ("scurl", "text/vnd.curl.scurl")
783− , ("sda", "application/vnd.stardivision.draw")
784− , ("sdc", "application/vnd.stardivision.calc")
785− , ("sdd", "application/vnd.stardivision.impress")
786− , ("sdkd", "application/vnd.solent.sdkm+xml")
787− , ("sdkm", "application/vnd.solent.sdkm+xml")
788− , ("sdp", "application/sdp")
789− , ("sdw", "application/vnd.stardivision.writer")
790− , ("sea", "application/x-sea")
791− , ("see", "application/vnd.seemail")
792− , ("seed", "application/vnd.fdsn.seed")
793− , ("sema", "application/vnd.sema")
794− , ("semd", "application/vnd.semd")
795− , ("semf", "application/vnd.semf")
796− , ("ser", "application/java-serialized-object")
797− , ("setpay", "application/set-payment-initiation")
798− , ("setreg", "application/set-registration-initiation")
799− , ("sfd-hdstx", "application/vnd.hydrostatix.sof-data")
800− , ("sfs", "application/vnd.spotfire.sfs")
801− , ("sfv", "text/x-sfv")
802− , ("sgi", "image/sgi")
803− , ("sgl", "application/vnd.stardivision.writer-global")
804− , ("sgm", "text/sgml")
805− , ("sgml", "text/sgml")
806− , ("sh", "application/x-sh")
807− , ("shar", "application/x-shar")
808− , ("shf", "application/shf+xml")
809− , ("shtml", "text/html")
810− , ("sid", "image/x-mrsid-image")
811− , ("sig", "application/pgp-signature")
812− , ("sil", "audio/silk")
813− , ("silo", "model/mesh")
814− , ("sis", "application/vnd.symbian.install")
815− , ("sisx", "application/vnd.symbian.install")
816− , ("sit", "application/x-stuffit")
817− , ("sitx", "application/x-stuffitx")
818− , ("skd", "application/vnd.koan")
819− , ("skm", "application/vnd.koan")
820− , ("skp", "application/vnd.koan")
821− , ("skt", "application/vnd.koan")
822− , ("sldm", "application/vnd.ms-powerpoint.slide.macroenabled.12")
823− , ("sldx", "application/vnd.openxmlformats-officedocument.presentationml.slide")
824− , ("slt", "application/vnd.epson.salt")
825− , ("sm", "application/vnd.stepmania.stepchart")
826− , ("smf", "application/vnd.stardivision.math")
827− , ("smi", "application/smil+xml")
828− , ("smil", "application/smil+xml")
829− , ("smv", "video/x-smv")
830− , ("smzip", "application/vnd.stepmania.package")
831− , ("snd", "audio/basic")
832− , ("snf", "application/x-font-snf")
833− , ("so", "application/octet-stream")
834− , ("spc", "application/x-pkcs7-certificates")
835− , ("spf", "application/vnd.yamaha.smaf-phrase")
836− , ("spl", "application/futuresplash")
837− , ("spot", "text/vnd.in3d.spot")
838− , ("spp", "application/scvp-vp-response")
839− , ("spq", "application/scvp-vp-request")
840− , ("spx", "audio/ogg")
841− , ("sql", "application/x-sql")
842− , ("src", "application/x-wais-source")
843− , ("srt", "application/x-subrip")
844− , ("sru", "application/sru+xml")
845− , ("srx", "application/sparql-results+xml")
846− , ("ssdl", "application/ssdl+xml")
847− , ("sse", "application/vnd.kodak-descriptor")
848− , ("ssf", "application/vnd.epson.ssf")
849− , ("ssml", "application/ssml+xml")
850− , ("st", "application/vnd.sailingtracker.track")
851− , ("stc", "application/vnd.sun.xml.calc.template")
852− , ("std", "application/vnd.sun.xml.draw.template")
853− , ("stf", "application/vnd.wt.stf")
854− , ("sti", "application/vnd.sun.xml.impress.template")
855− , ("stk", "application/hyperstudio")
856− , ("stl", "application/vnd.ms-pki.stl")
857− , ("str", "application/vnd.pg.format")
858− , ("stw", "application/vnd.sun.xml.writer.template")
859− , ("sub", "text/vnd.dvb.subtitle")
860− , ("sus", "application/vnd.sus-calendar")
861− , ("susp", "application/vnd.sus-calendar")
862− , ("sv4cpio", "application/x-sv4cpio")
863− , ("sv4crc", "application/x-sv4crc")
864− , ("svc", "application/vnd.dvb.service")
865− , ("svd", "application/vnd.svd")
866− , ("svg", "image/svg+xml")
867− , ("svgz", "image/svg+xml")
868− , ("swa", "application/x-director")
869− , ("swf", "application/x-shockwave-flash")
870− , ("swi", "application/vnd.aristanetworks.swi")
871− , ("sxc", "application/vnd.sun.xml.calc")
872− , ("sxd", "application/vnd.sun.xml.draw")
873− , ("sxg", "application/vnd.sun.xml.writer.global")
874− , ("sxi", "application/vnd.sun.xml.impress")
875− , ("sxm", "application/vnd.sun.xml.math")
876− , ("sxw", "application/vnd.sun.xml.writer")
877− , ("t", "text/troff")
878− , ("t3", "application/x-t3vm-image")
879− , ("taglet", "application/vnd.mynfc")
880− , ("tao", "application/vnd.tao.intent-module-archive")
881− , ("tar", "application/x-tar")
882− , ("tar.bz2", "application/x-bzip-compressed-tar")
883− , ("tar.gz", "application/x-tgz")
884− , ("tbz", "application/x-bzip-compressed-tar")
885− , ("tcap", "application/vnd.3gpp2.tcap")
886− , ("tcl", "application/x-tcl")
887− , ("teacher", "application/vnd.smart.teacher")
888− , ("tei", "application/tei+xml")
889− , ("teicorpus", "application/tei+xml")
890− , ("tex", "application/x-tex")
891− , ("texi", "application/x-texinfo")
892− , ("texinfo", "application/x-texinfo")
893− , ("text", "text/plain")
894− , ("tfi", "application/thraud+xml")
895− , ("tfm", "application/x-tex-tfm")
896− , ("tga", "image/x-tga")
897− , ("tgz", "application/x-tgz")
898− , ("thmx", "application/vnd.ms-officetheme")
899− , ("tif", "image/tiff")
900− , ("tiff", "image/tiff")
901− , ("tk", "application/x-tcl")
902− , ("tmo", "application/vnd.tmobile-livetv")
903− , ("torrent", "application/x-bittorrent")
904− , ("tpl", "application/vnd.groove-tool-template")
905− , ("tpt", "application/vnd.trid.tpt")
906− , ("tr", "text/troff")
907− , ("tra", "application/vnd.trueapp")
908− , ("trm", "application/x-msterminal")
909− , ("tsd", "application/timestamped-data")
910− , ("tsv", "text/tab-separated-values")
911− , ("ttc", "application/x-font-ttf")
912− , ("ttf", "application/x-font-ttf")
913− , ("ttl", "text/turtle")
914− , ("twd", "application/vnd.simtech-mindmapper")
915− , ("twds", "application/vnd.simtech-mindmapper")
916− , ("txd", "application/vnd.genomatix.tuxedo")
917− , ("txf", "application/vnd.mobius.txf")
918− , ("txt", "text/plain")
919− , ("u32", "application/x-authorware-bin")
920− , ("udeb", "application/x-debian-package")
921− , ("ufd", "application/vnd.ufdl")
922− , ("ufdl", "application/vnd.ufdl")
923− , ("ulx", "application/x-glulx")
924− , ("umj", "application/vnd.umajin")
925− , ("unityweb", "application/vnd.unity")
926− , ("uoml", "application/vnd.uoml+xml")
927− , ("uri", "text/uri-list")
928− , ("uris", "text/uri-list")
929− , ("urls", "text/uri-list")
930− , ("ustar", "application/x-ustar")
931− , ("utz", "application/vnd.uiq.theme")
932− , ("uu", "text/x-uuencode")
933− , ("uva", "audio/vnd.dece.audio")
934− , ("uvd", "application/vnd.dece.data")
935− , ("uvf", "application/vnd.dece.data")
936− , ("uvg", "image/vnd.dece.graphic")
937− , ("uvh", "video/vnd.dece.hd")
938− , ("uvi", "image/vnd.dece.graphic")
939− , ("uvm", "video/vnd.dece.mobile")
940− , ("uvp", "video/vnd.dece.pd")
941− , ("uvs", "video/vnd.dece.sd")
942− , ("uvt", "application/vnd.dece.ttml+xml")
943− , ("uvu", "video/vnd.uvvu.mp4")
944− , ("uvv", "video/vnd.dece.video")
945− , ("uvva", "audio/vnd.dece.audio")
946− , ("uvvd", "application/vnd.dece.data")
947− , ("uvvf", "application/vnd.dece.data")
948− , ("uvvg", "image/vnd.dece.graphic")
949− , ("uvvh", "video/vnd.dece.hd")
950− , ("uvvi", "image/vnd.dece.graphic")
951− , ("uvvm", "video/vnd.dece.mobile")
952− , ("uvvp", "video/vnd.dece.pd")
953− , ("uvvs", "video/vnd.dece.sd")
954− , ("uvvt", "application/vnd.dece.ttml+xml")
955− , ("uvvu", "video/vnd.uvvu.mp4")
956− , ("uvvv", "video/vnd.dece.video")
957− , ("uvvx", "application/vnd.dece.unspecified")
958− , ("uvvz", "application/vnd.dece.zip")
959− , ("uvx", "application/vnd.dece.unspecified")
960− , ("uvz", "application/vnd.dece.zip")
961− , ("vcard", "text/vcard")
962− , ("vcd", "application/x-cdlink")
963− , ("vcf", "text/x-vcard")
964− , ("vcg", "application/vnd.groove-vcard")
965− , ("vcs", "text/x-vcalendar")
966− , ("vcx", "application/vnd.vcx")
967− , ("vis", "application/vnd.visionary")
968− , ("viv", "video/vnd.vivo")
969− , ("vob", "video/x-ms-vob")
970− , ("vor", "application/vnd.stardivision.writer")
971− , ("vox", "application/x-authorware-bin")
972− , ("vrml", "model/vrml")
973− , ("vsd", "application/vnd.visio")
974− , ("vsf", "application/vnd.vsf")
975− , ("vss", "application/vnd.visio")
976− , ("vst", "application/vnd.visio")
977− , ("vsw", "application/vnd.visio")
978− , ("vtu", "model/vnd.vtu")
979− , ("vxml", "application/voicexml+xml")
980− , ("w3d", "application/x-director")
981− , ("wad", "application/x-doom")
982− , ("war", "application/java-archive")
983− , ("wasm", "application/wasm")
984− , ("wav", "audio/x-wav")
985− , ("wax", "audio/x-ms-wax")
986− , ("wbmp", "image/vnd.wap.wbmp")
987− , ("wbs", "application/vnd.criticaltools.wbs+xml")
988− , ("wbxml", "application/vnd.wap.wbxml")
989− , ("wcm", "application/vnd.ms-works")
990− , ("wdb", "application/vnd.ms-works")
991− , ("wdp", "image/vnd.ms-photo")
992− , ("weba", "audio/webm")
993− , ("webm", "video/webm")
994− , ("webp", "image/webp")
995− , ("wg", "application/vnd.pmi.widget")
996− , ("wgt", "application/widget")
997− , ("wks", "application/vnd.ms-works")
998− , ("wm", "video/x-ms-wm")
999− , ("wma", "audio/x-ms-wma")
1000− , ("wmd", "application/x-ms-wmd")
1001− , ("wmf", "application/x-msmetafile")
1002− , ("wml", "text/vnd.wap.wml")
1003− , ("wmlc", "application/vnd.wap.wmlc")
1004− , ("wmls", "text/vnd.wap.wmlscript")
1005− , ("wmlsc", "application/vnd.wap.wmlscriptc")
1006− , ("wmv", "video/x-ms-wmv")
1007− , ("wmx", "video/x-ms-wmx")
1008− , ("wmz", "application/x-msmetafile")
1009− , ("woff", "application/font-woff")
1010− , ("woff2", "application/font-woff2")
1011− , ("wpd", "application/vnd.wordperfect")
1012− , ("wpl", "application/vnd.ms-wpl")
1013− , ("wps", "application/vnd.ms-works")
1014− , ("wqd", "application/vnd.wqd")
1015− , ("wri", "application/x-mswrite")
1016− , ("wrl", "model/vrml")
1017− , ("wsdl", "application/wsdl+xml")
1018− , ("wspolicy", "application/wspolicy+xml")
1019− , ("wtb", "application/vnd.webturbo")
1020− , ("wvx", "video/x-ms-wvx")
1021− , ("x32", "application/x-authorware-bin")
1022− , ("x3d", "model/x3d+xml")
1023− , ("x3db", "model/x3d+binary")
1024− , ("x3dbz", "model/x3d+binary")
1025− , ("x3dv", "model/x3d+vrml")
1026− , ("x3dvz", "model/x3d+vrml")
1027− , ("x3dz", "model/x3d+xml")
1028− , ("xaml", "application/xaml+xml")
1029− , ("xap", "application/x-silverlight-app")
1030− , ("xar", "application/vnd.xara")
1031− , ("xbap", "application/x-ms-xbap")
1032− , ("xbd", "application/vnd.fujixerox.docuworks.binder")
1033− , ("xbm", "image/x-xbitmap")
1034− , ("xdf", "application/xcap-diff+xml")
1035− , ("xdm", "application/vnd.syncml.dm+xml")
1036− , ("xdp", "application/vnd.adobe.xdp+xml")
1037− , ("xdssc", "application/dssc+xml")
1038− , ("xdw", "application/vnd.fujixerox.docuworks")
1039− , ("xenc", "application/xenc+xml")
1040− , ("xer", "application/patch-ops-error+xml")
1041− , ("xfdf", "application/vnd.adobe.xfdf")
1042− , ("xfdl", "application/vnd.xfdl")
1043− , ("xht", "application/xhtml+xml")
1044− , ("xhtml", "application/xhtml+xml")
1045− , ("xhvml", "application/xv+xml")
1046− , ("xif", "image/vnd.xiff")
1047− , ("xla", "application/vnd.ms-excel")
1048− , ("xlam", "application/vnd.ms-excel.addin.macroenabled.12")
1049− , ("xlc", "application/vnd.ms-excel")
1050− , ("xlf", "application/x-xliff+xml")
1051− , ("xlm", "application/vnd.ms-excel")
1052− , ("xls", "application/vnd.ms-excel")
1053− , ("xlsb", "application/vnd.ms-excel.sheet.binary.macroenabled.12")
1054− , ("xlsm", "application/vnd.ms-excel.sheet.macroenabled.12")
1055− , ("xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
1056− , ("xlt", "application/vnd.ms-excel")
1057− , ("xltm", "application/vnd.ms-excel.template.macroenabled.12")
1058− , ("xltx", "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
1059− , ("xlw", "application/vnd.ms-excel")
1060− , ("xm", "audio/xm")
1061− , ("xml", "text/xml")
1062− , ("xo", "application/vnd.olpc-sugar")
1063− , ("xop", "application/xop+xml")
1064− , ("xpi", "application/x-xpinstall")
1065− , ("xpl", "application/xproc+xml")
1066− , ("xpm", "image/x-xpixmap")
1067− , ("xpr", "application/vnd.is-xpr")
1068− , ("xps", "application/vnd.ms-xpsdocument")
1069− , ("xpw", "application/vnd.intercon.formnet")
1070− , ("xpx", "application/vnd.intercon.formnet")
1071− , ("xsl", "application/xml")
1072− , ("xslt", "application/xslt+xml")
1073− , ("xsm", "application/vnd.syncml+xml")
1074− , ("xspf", "application/xspf+xml")
1075− , ("xul", "application/vnd.mozilla.xul+xml")
1076− , ("xvm", "application/xv+xml")
1077− , ("xvml", "application/xv+xml")
1078− , ("xwd", "image/x-xwindowdump")
1079− , ("xyz", "chemical/x-xyz")
1080− , ("xz", "application/x-xz")
1081− , ("yang", "application/yang")
1082− , ("yin", "application/yin+xml")
1083− , ("z1", "application/x-zmachine")
1084− , ("z2", "application/x-zmachine")
1085− , ("z3", "application/x-zmachine")
1086− , ("z4", "application/x-zmachine")
1087− , ("z5", "application/x-zmachine")
1088− , ("z6", "application/x-zmachine")
1089− , ("z7", "application/x-zmachine")
1090− , ("z8", "application/x-zmachine")
1091− , ("zaz", "application/vnd.zzazz.deck+xml")
1092− , ("zip", "application/zip")
1093− , ("zir", "application/vnd.zul")
1094− , ("zirz", "application/vnd.zul")
1095− , ("zmm", "application/vnd.handheld-entertainment+xml")
1096− ]
mime-types/README.mddeleted−3
@@ -1,3 +0,0 @@
1−## mime-types
2−
3−Basic mime-type handling types and functions
mime-types/mime-types.cabaldeleted−24
@@ -1,24 +0,0 @@
1−name: mime-types
2−version: 0.1.0.9
3−synopsis: Basic mime-type handling types and functions
4−description: API docs and the README are available at <http://www.stackage.org/package/mime-types>.
5−homepage: https://github.com/yesodweb/wai
6−license: MIT
7−license-file: LICENSE
8−author: Michael Snoyman
9−maintainer: michael@snoyman.com
10−category: Web
11−build-type: Simple
12−cabal-version: >=1.8
13−extra-source-files: README.md ChangeLog.md
14−
15−library
16− exposed-modules: Network.Mime
17− build-depends: base >= 4 && < 5
18− , containers
19− , text
20− , bytestring
21−
22−source-repository head
23− type: git
24− location: git://github.com/yesodweb/wai.git
package-list.shnew file+16
@@ -0,0 +1,16 @@
1+#!/bin/bash
2+
3+pkgs=( ./wai
4+ ./wai-test
5+ ./wai-extra
6+ ./warp
7+ ./warp-tls
8+ ./wai-app-static
9+ ./wai-handler-fastcgi
10+ ./wai-handler-launch
11+ ./wai-handler-scgi
12+ ./wai-frontend-monadcgi
13+ ./warp-static
14+ ./wai-websockets
15+ ./wai-eventsource
16+ )
scriptsnew file+1

Submodule changed.

sources.txtnew file+13
@@ -0,0 +1,13 @@
1+./wai
2+./wai-test
3+./wai-extra
4+./warp
5+./warp-tls
6+./wai-app-static
7+./wai-handler-fastcgi
8+./wai-handler-launch
9+./wai-handler-scgi
10+./wai-frontend-monadcgi
11+./warp-static
12+./wai-websockets
13+./wai-eventsource
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.yamldeleted−25
@@ -1,25 +0,0 @@
1−resolver: lts-14.22
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
time-manager/LICENSEdeleted−20
@@ -1,20 +0,0 @@
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.
time-manager/System/TimeManager.hsdeleted−152
@@ -1,152 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−
3−module System.TimeManager (
4− -- ** Types
5− Manager
6− , TimeoutAction
7− , Handle
8− -- ** Manager
9− , initialize
10− , stopManager
11− , killManager
12− , withManager
13− -- ** Registration
14− , register
15− , registerKillThread
16− -- ** Control
17− , tickle
18− , cancel
19− , pause
20− , resume
21− -- ** Exceptions
22− , TimeoutThread (..)
23− ) where
24−
25−import Control.Concurrent (myThreadId)
26−import qualified Control.Exception as E
27−import Control.Reaper
28−import Data.Typeable (Typeable)
29−import Data.IORef (IORef)
30−import qualified Data.IORef as I
31−
32−----------------------------------------------------------------
33−
34−-- | A timeout manager
35−type Manager = Reaper [Handle] Handle
36−
37−-- | An action to be performed on timeout.
38−type TimeoutAction = IO ()
39−
40−-- | A handle used by 'Manager'
41−data Handle = Handle !(IORef TimeoutAction) !(IORef State)
42−
43−data State = Active -- Manager turns it to Inactive.
44− | Inactive -- Manager removes it with timeout action.
45− | Paused -- Manager does not change it.
46− | Canceled -- Manager removes it without timeout action.
47−
48−----------------------------------------------------------------
49−
50−-- | Creating timeout manager which works every N micro seconds
51−-- where N is the first argument.
52−initialize :: Int -> IO Manager
53−initialize timeout = mkReaper defaultReaperSettings
54− { reaperAction = mkListAction prune
55− , reaperDelay = timeout
56− }
57− where
58− prune m@(Handle actionRef stateRef) = do
59− state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x))
60− case state of
61− Inactive -> do
62− onTimeout <- I.readIORef actionRef
63− onTimeout `E.catch` ignoreAll
64− return Nothing
65− Canceled -> return Nothing
66− _ -> return $ Just m
67−
68− inactivate Active = Inactive
69− inactivate x = x
70−
71−----------------------------------------------------------------
72−
73−-- | Stopping timeout manager with onTimeout fired.
74−stopManager :: Manager -> IO ()
75−stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)
76− where
77− fire (Handle actionRef _) = do
78− onTimeout <- I.readIORef actionRef
79− onTimeout `E.catch` ignoreAll
80−
81−ignoreAll :: E.SomeException -> IO ()
82−ignoreAll _ = return ()
83−
84−-- | Killing timeout manager immediately without firing onTimeout.
85−killManager :: Manager -> IO ()
86−killManager = reaperKill
87−
88−----------------------------------------------------------------
89−
90−-- | Registering a timeout action.
91−register :: Manager -> TimeoutAction -> IO Handle
92−register mgr onTimeout = do
93− actionRef <- I.newIORef onTimeout
94− stateRef <- I.newIORef Active
95− let h = Handle actionRef stateRef
96− reaperAdd mgr h
97− return h
98−
99−-- | Registering a timeout action of killing this thread.
100−registerKillThread :: Manager -> TimeoutAction -> IO Handle
101−registerKillThread m onTimeout = do
102− -- If we hold ThreadId, the stack and data of the thread is leaked.
103− -- If we hold Weak ThreadId, the stack is released. However, its
104− -- data is still leaked probably because of a bug of GHC.
105− -- So, let's just use ThreadId and release ThreadId by
106− -- overriding the timeout action by "cancel".
107− tid <- myThreadId
108− -- First run the timeout action in case the child thread is masked.
109− register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread
110−
111−data TimeoutThread = TimeoutThread
112− deriving Typeable
113−instance E.Exception TimeoutThread where
114− toException = E.asyncExceptionToException
115− fromException = E.asyncExceptionFromException
116−instance Show TimeoutThread where
117− show TimeoutThread = "Thread killed by timeout manager"
118−
119−----------------------------------------------------------------
120−
121−-- | Setting the state to active.
122−-- 'Manager' turns active to inactive repeatedly.
123−tickle :: Handle -> IO ()
124−tickle (Handle _ stateRef) = I.writeIORef stateRef Active
125−
126−-- | Setting the state to canceled.
127−-- 'Manager' eventually removes this without timeout action.
128−cancel :: Handle -> IO ()
129−cancel (Handle actionRef stateRef) = do
130− I.writeIORef actionRef (return ()) -- ensuring to release ThreadId
131− I.writeIORef stateRef Canceled
132−
133−-- | Setting the state to paused.
134−-- 'Manager' does not change the value.
135−pause :: Handle -> IO ()
136−pause (Handle _ stateRef) = I.writeIORef stateRef Paused
137−
138−-- | Setting the paused state to active.
139−-- This is an alias to 'tickle'.
140−resume :: Handle -> IO ()
141−resume = tickle
142−
143−----------------------------------------------------------------
144−
145−-- | Call the inner function with a timeout manager.
146−withManager :: Int -- ^ timeout in microseconds
147− -> (Manager -> IO a)
148− -> IO a
149−withManager timeout f = do
150− -- FIXME when stopManager is available, use it
151− man <- initialize timeout
152− f man
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/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -itest -optP-include -optPdist/build/autogen/cabal_macros.h -XCPP
wai-app-static/ChangeLog.mddeleted−76
@@ -1,76 +0,0 @@
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
55−
56−* Drop system-filepath
57−
58−## 3.0.1.1
59−
60−* Fix root links
61−
62−## 3.0.1
63−
64−* Better HEAD support [#354](https://github.com/yesodweb/wai/issues/354)
65−
66−## 3.0.0.6
67−
68−Fix trailing slashes for `UrlMap` and other non-root setups [#325](https://github.com/yesodweb/wai/issues/325)
69−
70−## 3.0.0.4
71−
72−Add missing trailing slashes [#312](https://github.com/yesodweb/wai/issues/312)
73−
74−## 3.0.0.3
75−
76−Support for time 1.5
wai-app-static/LICENSE+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2010, Michael Snoyman. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-app-static/Network/Wai/Application/Static.hs+701−207
@@ -1,65 +1,219 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TemplateHaskell, CPP #-}
3{-# LANGUAGE TemplateHaskell, CPP #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE PatternGuards #-}
6-- | Static file serving for WAI.
4-- | Static file serving for WAI.
7module Network.Wai.Application.Static
5module Network.Wai.Application.Static
8 ( -- * WAI application
6 ( -- * WAI application
9 staticApp
7 staticApp
10− -- ** Default Settings
8+ -- ** Settings
11 , defaultWebAppSettings
9 , defaultWebAppSettings
12− , webAppSettingsWithLookup
10+ , webAppSettingsWithLookup
13 , defaultFileServerSettings
11 , defaultFileServerSettings
14− , embeddedSettings
15− -- ** Settings
16 , StaticSettings
12 , StaticSettings
17− , ssLookupFile
13+ , ssFolder
18 , ssMkRedirect
14 , ssMkRedirect
19 , ssGetMimeType
15 , ssGetMimeType
20 , ssListing
16 , ssListing
21 , ssIndices
17 , ssIndices
22 , ssMaxAge
18 , ssMaxAge
23 , ssRedirectToIndex
19 , ssRedirectToIndex
24− , ssAddTrailingSlash
20+ -- * Generic, non-WAI code
25− , ss404Handler
21+ -- ** Mime types
22+ , MimeType
23+ , defaultMimeType
24+ -- ** Mime type by file extension
25+ , Extension
26+ , MimeMap
27+ , takeExtensions
28+ , defaultMimeTypes
29+ , mimeTypeByExt
30+ , defaultMimeTypeByExt
31+ -- ** Finding files
32+ , Pieces
33+ , pathFromPieces
34+ -- ** Directory listings
35+ , Listing
36+ , defaultListing
37+ -- ** Lookup functions
38+ , fileSystemLookup
39+ , fileSystemLookupHash
40+ , embeddedLookup
41+ -- ** Embedded
42+ , Embedded
43+ , EmbeddedEntry (..)
44+ , toEmbedded
45+ -- ** Redirecting
46+ , defaultMkRedirect
47+ -- * Other data types
48+ , File (..)
49+ , FilePath (..)
50+ , toFilePath
51+ , fromFilePath
52+ , MaxAge (..)
53+ , ETagLookup
26 ) where
54 ) where
27
55
28import Prelude hiding (FilePath)
56import Prelude hiding (FilePath)
57+import qualified Prelude
29import qualified Network.Wai as W
58import qualified Network.Wai as W
30import qualified Network.HTTP.Types as H
59import qualified Network.HTTP.Types as H
60+import Data.Map (Map)
61+import qualified Data.Map as Map
31import Data.ByteString (ByteString)
62import Data.ByteString (ByteString)
63+import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
32import qualified Data.ByteString.Char8 as S8
64import qualified Data.ByteString.Char8 as S8
33import qualified Data.ByteString.Lazy as L
65import qualified Data.ByteString.Lazy as L
34import Data.ByteString.Lazy.Char8 ()
66import Data.ByteString.Lazy.Char8 ()
67+import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
68+import System.Posix.Types (EpochTime)
35import Control.Monad.IO.Class (liftIO)
69import Control.Monad.IO.Class (liftIO)
70+import qualified Crypto.Hash.MD5 as MD5
71+import Control.Monad (forM)
72+import Control.Exception (SomeException, try)
73+
74+import Text.Blaze ((!))
75+import qualified Text.Blaze.Html5 as H
76+import qualified Text.Blaze.Renderer.Utf8 as HU
77+import qualified Text.Blaze.Html5.Attributes as A
36
78
37−import Data.ByteString.Builder (toLazyByteString)
79+import Blaze.ByteString.Builder (toByteString, fromByteString)
80+
81+import Data.Time
82+import Data.Time.Clock.POSIX
83+import System.Locale (defaultTimeLocale)
38
84
39import Data.FileEmbed (embedFile)
85import Data.FileEmbed (embedFile)
40
86
41import Data.Text (Text)
87import Data.Text (Text)
42import qualified Data.Text as T
88import qualified Data.Text as T
43import qualified Data.Text.Encoding as TE
89import qualified Data.Text.Encoding as TE
90+import qualified Data.Text.Encoding.Error as TEE
44
91
92+import Control.Arrow ((&&&), second)
93+import Data.List (groupBy, sortBy, find, foldl')
94+import Data.Function (on)
95+import Data.Ord (comparing)
96+import qualified Data.ByteString.Base64 as B64
97+import Data.Either (rights)
98+import Data.Maybe (isJust, fromJust)
45import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
99import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
100+import Data.String (IsString (..))
101+
102+newtype FilePath = FilePath { unFilePath :: Text }
103+ deriving (Ord, Eq, Show)
104+instance IsString FilePath where
105+ fromString = toFilePath
106+
107+(</>) :: FilePath -> FilePath -> FilePath
108+(FilePath a) </> (FilePath b) = FilePath $ T.concat [a, "/", b]
109+
110+-- | A list of all possible extensions, starting from the largest.
111+takeExtensions :: FilePath -> [FilePath]
112+takeExtensions (FilePath s) =
113+ case T.break (== '.') s of
114+ (_, "") -> []
115+ (_, x) -> FilePath (T.drop 1 x) : takeExtensions (FilePath $ T.drop 1 x)
116+
117+type MimeType = ByteString
118+type Extension = FilePath
119+type MimeMap = Map Extension MimeType
120+
121+defaultMimeType :: MimeType
122+defaultMimeType = "application/octet-stream"
123+
124+-- taken from snap-core Snap.Util.FileServer
125+defaultMimeTypes :: MimeMap
126+defaultMimeTypes = Map.fromList [
127+ ( "apk" , "application/vnd.android.package-archive" ),
128+ ( "asc" , "text/plain" ),
129+ ( "asf" , "video/x-ms-asf" ),
130+ ( "asx" , "video/x-ms-asf" ),
131+ ( "avi" , "video/x-msvideo" ),
132+ ( "bz2" , "application/x-bzip" ),
133+ ( "c" , "text/plain" ),
134+ ( "class" , "application/octet-stream" ),
135+ ( "conf" , "text/plain" ),
136+ ( "cpp" , "text/plain" ),
137+ ( "css" , "text/css" ),
138+ ( "cxx" , "text/plain" ),
139+ ( "dtd" , "text/xml" ),
140+ ( "dvi" , "application/x-dvi" ),
141+ ( "epub" , "application/epub+zip" ),
142+ ( "gif" , "image/gif" ),
143+ ( "gz" , "application/x-gzip" ),
144+ ( "hs" , "text/plain" ),
145+ ( "htm" , "text/html" ),
146+ ( "html" , "text/html" ),
147+ ( "ico" , "image/vnd.microsoft.icon" ),
148+ ( "jar" , "application/x-java-archive" ),
149+ ( "jpeg" , "image/jpeg" ),
150+ ( "jpg" , "image/jpeg" ),
151+ ( "js" , "text/javascript" ),
152+ ( "json" , "application/json" ),
153+ ( "log" , "text/plain" ),
154+ ( "manifest", "text/cache-manifest" ),
155+ ( "m3u" , "audio/x-mpegurl" ),
156+ ( "mov" , "video/quicktime" ),
157+ ( "mp3" , "audio/mpeg" ),
158+ ( "mpeg" , "video/mpeg" ),
159+ ( "mpg" , "video/mpeg" ),
160+ ( "ogg" , "application/ogg" ),
161+ ( "pac" , "application/x-ns-proxy-autoconfig" ),
162+ ( "pdf" , "application/pdf" ),
163+ ( "png" , "image/png" ),
164+ ( "bmp" , "image/bmp" ),
165+ ( "ps" , "application/postscript" ),
166+ ( "qt" , "video/quicktime" ),
167+ ( "sig" , "application/pgp-signature" ),
168+ ( "spl" , "application/futuresplash" ),
169+ ( "svg" , "image/svg+xml" ),
170+ ( "swf" , "application/x-shockwave-flash" ),
171+ ( "tar" , "application/x-tar" ),
172+ ( "tar.bz2" , "application/x-bzip-compressed-tar" ),
173+ ( "tar.gz" , "application/x-tgz" ),
174+ ( "tbz" , "application/x-bzip-compressed-tar" ),
175+ ( "text" , "text/plain" ),
176+ ( "tgz" , "application/x-tgz" ),
177+ ( "torrent" , "application/x-bittorrent" ),
178+ ( "ttf" , "application/x-font-truetype" ),
179+ ( "txt" , "text/plain" ),
180+ ( "wav" , "audio/x-wav" ),
181+ ( "wax" , "audio/x-ms-wax" ),
182+ ( "wma" , "audio/x-ms-wma" ),
183+ ( "wmv" , "video/x-ms-wmv" ),
184+ ( "xbm" , "image/x-xbitmap" ),
185+ ( "xhtml" , "application/xhtml+xml" ),
186+ ( "xml" , "text/xml" ),
187+ ( "xpm" , "image/x-xpixmap" ),
188+ ( "xwd" , "image/x-xwindowdump" ),
189+ ( "zip" , "application/zip" )]
46
190
47−import WaiAppStatic.Types
191+mimeTypeByExt :: MimeMap
48−import Util
192+ -> MimeType -- ^ default mime type
49−import WaiAppStatic.Storage.Filesystem
193+ -> FilePath
50−import WaiAppStatic.Storage.Embedded
194+ -> MimeType
51−import Network.Mime (MimeType)
195+mimeTypeByExt mm def =
196+ go . takeExtensions
197+ where
198+ go [] = def
199+ go (e:es) =
200+ case Map.lookup e mm of
201+ Nothing -> go es
202+ Just mt -> mt
203+
204+defaultMimeTypeByExt :: FilePath -> MimeType
205+defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType
52
206
53−data StaticResponse =
207+data CheckPieces =
54 -- | Just the etag hash or Nothing for no etag hash
208 -- | Just the etag hash or Nothing for no etag hash
55 Redirect Pieces (Maybe ByteString)
209 Redirect Pieces (Maybe ByteString)
56− | RawRedirect ByteString
210+ | Forbidden
57 | NotFound
211 | NotFound
58 | FileResponse File H.ResponseHeaders
212 | FileResponse File H.ResponseHeaders
59 | NotModified
213 | NotModified
214+ | DirectoryResponse Folder
60 -- TODO: add file size
215 -- TODO: add file size
61 | SendContent MimeType L.ByteString
216 | SendContent MimeType L.ByteString
62− | WaiResponse W.Response
63
217
64safeInit :: [a] -> [a]
218safeInit :: [a] -> [a]
65safeInit [] = []
219safeInit [] = []
@@ -72,218 +226,558 @@ filterButLast f (x:xs)
72 | f x = x : filterButLast f xs
226 | f x = x : filterButLast f xs
73 | otherwise = filterButLast f xs
227 | otherwise = filterButLast f xs
74
228
75−-- | Serve an appropriate response for a folder request.
76−serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse
77−serveFolder StaticSettings {..} pieces req folder@Folder {..} =
78− case ssListing of
79− Just _ | Just path <- addTrailingSlash req, ssAddTrailingSlash ->
80− return $ RawRedirect path
81− Just listing -> do
82− -- directory listings turned on, display it
83− builder <- listing pieces folder
84− return $ WaiResponse $ W.responseBuilder H.status200
85− [ ("Content-Type", "text/html; charset=utf-8")
86− ] builder
87− Nothing -> return $ WaiResponse $ W.responseLBS H.status403
88− [ ("Content-Type", "text/plain")
89− ] "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
97− rp = W.rawPathInfo req
98
229
99−checkPieces :: StaticSettings
230+unsafe :: FilePath -> Bool
231+unsafe (FilePath s)
232+ | T.null s = False
233+ | T.head s == '.' = True
234+ | otherwise = T.any (== '/') s
235+
236+nullFilePath :: FilePath -> Bool
237+nullFilePath = T.null . unFilePath
238+
239+{-
240+stripTrailingSlash :: FilePath -> FilePath
241+stripTrailingSlash fp@(FilePath t)
242+ | T.null t || T.last t /= '/' = fp
243+ | otherwise = FilePath $ T.init t
244+ -}
245+
246+type Pieces = [FilePath]
247+
248+relativeDirFromPieces :: Pieces -> T.Text
249+relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
250+
251+pathFromPieces :: FilePath -> Pieces -> FilePath
252+pathFromPieces = foldl' (</>)
253+
254+checkSpecialDirListing :: Pieces -> Maybe CheckPieces
255+checkSpecialDirListing [".hidden", "folder.png"] =
256+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/folder.png")]
257+checkSpecialDirListing [".hidden", "haskell.png"] =
258+ Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/haskell.png")]
259+checkSpecialDirListing _ = Nothing
260+
261+checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
262+ -> [FilePath] -- ^ List of default index files. Cannot contain slashes.
100 -> Pieces -- ^ parsed request
263 -> Pieces -- ^ parsed request
101 -> W.Request
264 -> W.Request
102− -> IO StaticResponse
265+ -> MaxAge
103−-- If we have any empty pieces in the middle of the requested path, generate a
266+ -> Bool -- ^ use hash?
104−-- redirect to get rid of them.
267+ -> Bool -- ^ Redirect to Index?
105−checkPieces _ pieces _ | any (T.null . fromPiece) $ safeInit pieces =
268+ -> IO CheckPieces
269+checkPieces fileLookup indices pieces req maxAge useHash redirectToIndex
270+ | any unsafe pieces = return Forbidden
271+ | any nullFilePath $ safeInit pieces =
106− return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing
272+ return $ Redirect (filterButLast (not . nullFilePath) pieces) Nothing
107−
273+ | otherwise = do
108−checkPieces ss@StaticSettings {..} pieces req = do
274+ let (isFile, isFolder) =
109− res <- lookupResult
275+ case () of
110− case res of
276+ ()
111− Left location -> return $ RawRedirect location
277+ | null pieces -> (True, True)
112− Right LRNotFound -> return NotFound
278+ | nullFilePath (last pieces) -> (False, True)
113− Right (LRFile file) -> serveFile ss req file
279+ | otherwise -> (True, False)
114− Right (LRFolder folder) -> serveFolder ss pieces req folder
280+
281+ fl <- fileLookup pieces
282+ case (fl, isFile) of
283+ (Nothing, _) -> return NotFound
284+ (Just (Right file), True) -> handleCache file
285+ (Just Right{}, False) -> return $ Redirect (init pieces) Nothing
286+ (Just (Left folder@(Folder _ contents)), _) -> do
287+ case checkIndices $ map fileName $ rights contents of
288+ Just index ->
289+ if redirectToIndex then
290+ return $ Redirect (setLast pieces index) Nothing
291+ else
292+ checkPieces fileLookup indices (setLast pieces index) req maxAge useHash redirectToIndex
293+ Nothing ->
294+ if isFolder
295+ then return $ DirectoryResponse folder
296+ else return $ Redirect (pieces ++ [""]) Nothing
115 where
297 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−
155−serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse
156−serveFile StaticSettings {..} req file
157− -- First check etag values, if turned on
158− | ssUseHash = do
159− mHash <- fileGetHash file
160− case (mHash, lookup "if-none-match" $ W.requestHeaders req) of
298+ headers = W.requestHeaders req
161− -- if-none-match matches the actual hash, return a 304
299+ queryString = W.queryString req
162− (Just hash, Just lastHash) | hash == lastHash -> return NotModified
300+
163−
301+ -- HTTP caching has a cache control header that you can set an expire time for a resource.
164− -- Didn't match, but we have a hash value. Send the file contents
302+ -- Max-Age is easiest because it is a simple number
165− -- with an ETag header.
303+ -- a cache-control asset will only be downloaded once (if the browser maintains its cache)
166− --
304+ -- and the server will never be contacted for the resource again (until it expires)
167− -- RFC7232 (HTTP 1.1):
305+ --
168− -- > A recipient MUST ignore If-Modified-Since if the request contains an
306+ -- A second caching mechanism is ETag and last-modified
169− -- > If-None-Match header field; the condition in If-None-Match is
307+ -- this form of caching is not as good as the static- the browser can avoid downloading the file, but it always need to send a request with the etag value or the last-modified value to the server to see if its copy is up to date
170− -- > considered to be a more accurate replacement for the condition in
308+ --
171− -- > If-Modified-Since, and the two are only combined for the sake of
309+ -- We should set a cache control and one of ETag or last-modifed whenever possible
172− -- > interoperating with older intermediaries that might not implement
310+ --
173− -- > If-None-Match.
311+ -- In a Yesod web application we can append an etag parameter to static assets.
174− (Just hash, _) -> respond [("ETag", hash)]
312+ -- This signals that both a max-age and ETag header should be set
175−
313+ -- if there is no etag parameter
176− -- No hash value available, fall back to last modified support.
314+ -- * don't set the max-age
177− (Nothing, _) -> lastMod
315+ -- * set ETag or last-modified
178− -- etag turned off, so jump straight to last modified
316+ -- * ETag must be calculated ahead of time.
179− | otherwise = lastMod
317+ -- * last-modified is just the file mtime.
318+ handleCache file =
319+ if not useHash then lastModifiedCache file
320+ else do
321+ let etagParam = lookup "etag" queryString
322+
323+ case etagParam of
324+ Nothing -> do -- no query parameter. Set appropriate ETag headers
325+ mHash <- fileGetHash file
326+ case mHash of
327+ Nothing -> lastModifiedCache file
328+ Just hash ->
329+ case lookup "if-none-match" headers of
330+ Just lastHash ->
331+ if hash == lastHash
332+ then return NotModified
333+ else return $ FileResponse file $ [("ETag", hash)]
334+ Nothing -> return $ FileResponse file $ [("ETag", hash)]
335+
336+ Just mEtag -> do
337+ mHash <- fileGetHash file
338+ case mHash of
339+ -- a file used to have an etag parameter, but no longer does
340+ Nothing -> return $ Redirect pieces Nothing
341+ Just hash ->
342+ if isJust mEtag && hash == fromJust mEtag
343+ then return $ FileResponse file $ ("ETag", hash):cacheControl
344+ else return $ Redirect pieces (Just hash)
345+
346+
347+ lastModifiedCache file =
348+ case (lookup "if-modified-since" headers >>= parseHTTPDate, fileGetModified file) of
349+ (mLastSent, Just modified) -> do
350+ let mdate = epochTimeToHTTPDate modified in
351+ case mLastSent of
352+ Just lastSent ->
353+ if lastSent == mdate
354+ then return NotModified
355+ else return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]
356+ Nothing -> return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]
357+ _ -> return $ FileResponse file []
358+
359+ setLast :: Pieces -> FilePath -> Pieces
360+ setLast [] x = [x]
361+ setLast [""] x = [x]
362+ setLast (a:b) x = a : setLast b x
363+
364+ checkIndices :: [FilePath] -> Maybe FilePath
365+ checkIndices contents = find (flip elem indices) contents
366+
367+ cacheControl = case ccInt of
368+ Nothing -> []
369+ Just i -> [("Cache-Control", S8.append "max-age=" $ S8.pack $ show i)]
370+ where
371+ ccInt =
372+ case maxAge of
373+ NoMaxAge -> Nothing
374+ MaxAgeSeconds i -> Just i
375+ MaxAgeForever -> Just oneYear
376+ oneYear :: Int
377+ oneYear = 60 * 60 * 24 * 365
378+
379+type Listing = (Pieces -> Folder -> IO L.ByteString)
380+
381+
382+type FileLookup = Maybe (Either Folder File)
383+
384+data Folder = Folder
385+ { folderName :: FilePath
386+ , folderContents :: [Either Folder File]
387+ }
388+
389+data File = File
390+ { fileGetSize :: Int
391+ , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
392+ , fileName :: FilePath
393+ , fileGetHash :: IO (Maybe ByteString)
394+ , fileGetModified :: Maybe EpochTime
395+ }
396+
397+data StaticSettings = StaticSettings
398+ { ssFolder :: Pieces -> IO FileLookup -- TODO: not a folder, so rename
399+ , ssMkRedirect :: Pieces -> ByteString -> ByteString
400+ , ssGetMimeType :: File -> IO MimeType
401+ , ssListing :: Maybe Listing
402+ , ssIndices :: [T.Text] -- index.html
403+ , ssRedirectToIndex :: Bool
404+ , ssMaxAge :: MaxAge
405+ , ssUseHash :: Bool
406+ }
407+
408+data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever
409+
410+defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
411+defaultMkRedirect pieces newPath
412+ | S8.null newPath || S8.null relDir ||
413+ S8.last relDir /= '/' || S8.head newPath /= '/' =
414+ relDir `S8.append` newPath
415+ | otherwise = relDir `S8.append` S8.tail newPath
180 where
416 where
181− mLastSent = lookup "if-modified-since" (W.requestHeaders req) >>= parseHTTPDate
417+ relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)
182− lastMod =
418+
183− case (fmap epochTimeToHTTPDate $ fileGetModified file, mLastSent) of
419+webAppSettingsWithLookup :: FilePath -> ETagLookup -> StaticSettings
184− -- File modified time is equal to the if-modified-since header,
420+webAppSettingsWithLookup dir etagLookup =
421+ defaultWebAppSettings { ssFolder = webAppLookup etagLookup dir}
422+
423+
424+defaultWebAppSettings :: StaticSettings
425+defaultWebAppSettings = StaticSettings
426+ { ssFolder = webAppLookup hashFileIfExists "static"
427+ , ssMkRedirect = defaultMkRedirect
428+ , ssGetMimeType = return . defaultMimeTypeByExt . fileName
429+ , ssMaxAge = MaxAgeForever
430+ , ssListing = Nothing
431+ , ssIndices = []
432+ , ssRedirectToIndex = False
433+ , ssUseHash = True
434+ }
435+
436+defaultFileServerSettings :: StaticSettings
437+defaultFileServerSettings = StaticSettings
438+ { ssFolder = fileSystemLookup "static"
439+ , ssMkRedirect = defaultMkRedirect
440+ , ssGetMimeType = return . defaultMimeTypeByExt . fileName
441+ , ssMaxAge = MaxAgeSeconds $ 60 * 60
442+ , ssListing = Just defaultListing
443+ , ssIndices = ["index.html", "index.htm"]
444+ , ssRedirectToIndex = False
445+ , ssUseHash = False
446+ }
447+
448+fileHelper :: ETagLookup
449+ -> FilePath -> FilePath -> IO (Maybe File)
450+fileHelper hashFunc fp name = do
451+ efs <- try $ getFileStatus $ fromFilePath fp
452+ case efs of
453+ Left (_ :: SomeException) -> return Nothing
454+ Right fs -> return $ Just File
455+ { fileGetSize = fromIntegral $ fileSize fs
456+ , fileToResponse = \s h -> W.ResponseFile s h (fromFilePath fp) Nothing
457+ , fileName = name
458+ , fileGetHash = hashFunc fp
459+ , fileGetModified = Just $ modificationTime fs
460+ }
461+
462+type ETagLookup = (FilePath -> IO (Maybe ByteString))
463+
464+webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO FileLookup
465+webAppLookup cachedLookupHash prefix pieces = do
466+ mfile <- fileHelper cachedLookupHash fp (last pieces)
467+ return $ fmap Right mfile
468+ where
469+ fp = pathFromPieces prefix pieces
470+
471+defaultFileSystemHash :: ETagLookup
472+defaultFileSystemHash fp = fmap Just $ hashFile fp
473+
474+-- FIXME replace lazy IO with enumerators
475+-- FIXME let's use a dictionary to cache these values?
476+hashFile :: FilePath -> IO ByteString
477+hashFile fp = do
478+ l <- L.readFile $ fromFilePath fp
479+ return $ runHashL l
480+
481+hashFileIfExists :: ETagLookup
482+hashFileIfExists fp = do
483+ fe <- doesFileExist $ fromFilePath fp
484+ if fe
185− -- return a 304.
485+ then return Nothing
186− --
486+ else defaultFileSystemHash fp
187− -- Question: should the comparison be, date <= lastSent?
487+
188− (Just mdate, Just lastSent)
488+fileSystemLookup :: FilePath -> Pieces -> IO FileLookup
189− | mdate == lastSent -> return NotModified
489+fileSystemLookup = fileSystemLookupHash defaultFileSystemHash
190−
490+
191− -- Did not match, but we have a new last-modified header
491+fileSystemLookupHash :: ETagLookup
192− (Just mdate, _) -> respond [("last-modified", formatHTTPDate mdate)]
492+ -> FilePath -> Pieces -> IO FileLookup
193−
493+fileSystemLookupHash hashFunc prefix pieces = do
194− -- No modification time available
494+ let fp = pathFromPieces prefix pieces
195− (Nothing, _) -> respond []
495+ fe <- doesFileExist $ fromFilePath fp
196−
496+ if fe
197− -- Send a file response with the additional weak headers provided.
497+ then (fmap . fmap) Right $ fileHelper hashFunc fp $ last pieces
198− respond headers = return $ FileResponse file $ cacheControl ssMaxAge headers
498+ else do
199−
499+ de <- doesDirectoryExist $ fromFilePath fp
200−-- | Return a difference list of headers based on the specified MaxAge.
500+ if de
201−--
501+ then do
202−-- This function will return both Cache-Control and Expires headers, as
502+ let isVisible ('.':_) = False
203−-- relevant.
503+ isVisible "" = False
204−cacheControl :: MaxAge -> (H.ResponseHeaders -> H.ResponseHeaders)
504+ isVisible _ = True
205−cacheControl maxage =
505+ entries' <- fmap (filter isVisible) $ getDirectoryContents (fromFilePath fp)
206− headerCacheControl . headerExpires
506+ entries <- forM entries' $ \nameRaw -> do
507+ let name = toFilePath nameRaw
508+ let fp' = fp </> name
509+ mfile' <- fileHelper hashFunc fp' name
510+ case mfile' of
511+ Nothing -> return $ Left $ Folder name []
512+ Just file' -> return $ Right file'
513+ return $ Just $ Left $ Folder (error "Network.Wai.Application.Static.fileSystemLookup") entries
514+ else return Nothing
515+
516+type Embedded = Map.Map FilePath EmbeddedEntry
517+
518+data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
519+
520+embeddedLookup :: Embedded -> Pieces -> IO FileLookup
521+embeddedLookup root pieces =
522+ return $ elookup "<root>" pieces root
207 where
523 where
208− ccInt =
524+ elookup :: FilePath -> [FilePath] -> Embedded -> FileLookup
209− case maxage of
525+ elookup p [] x = Just $ Left $ Folder p $ map toEntry $ Map.toList x
210− NoMaxAge -> Nothing
526+ elookup p [""] x = elookup p [] x
211− MaxAgeSeconds i -> Just i
527+ elookup _ (p:ps) x =
212− MaxAgeForever -> Just oneYear
213− oneYear :: Int
214− oneYear = 60 * 60 * 24 * 365
215−
216− headerCacheControl =
217− case ccInt of
528+ case Map.lookup p x of
218− Nothing -> id
529+ Nothing -> Nothing
219− Just i -> (:) ("Cache-Control", S8.append "public, max-age=" $ S8.pack $ show i)
530+ Just (EEFile f) ->
220− headerExpires =
531+ case ps of
221− case maxage of
532+ [] -> Just $ Right $ bsToFile p f
222− NoMaxAge -> id
533+ _ -> Nothing
223− MaxAgeSeconds _ -> id -- FIXME
534+ Just (EEFolder y) -> elookup p ps y
224− MaxAgeForever -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT")
535+
225−
536+toEntry :: (FilePath, EmbeddedEntry) -> Either Folder File
226−-- | Turn a @StaticSettings@ into a WAI application.
537+toEntry (name, EEFolder{}) = Left $ Folder name []
538+toEntry (name, EEFile bs) = Right $ File
539+ { fileGetSize = S8.length bs
540+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
541+ , fileName = name
542+ , fileGetHash = return $ Just $ runHash bs
543+ , fileGetModified = Nothing
544+ }
545+
546+toEmbedded :: [(Prelude.FilePath, S8.ByteString)] -> Embedded
547+toEmbedded fps =
548+ go texts
549+ where
550+ texts = map (\(x, y) -> (filter (not . T.null . unFilePath) $ toPieces x, y)) fps
551+ toPieces "" = []
552+ toPieces x =
553+ let (y, z) = break (== '/') x
554+ in toFilePath y : toPieces (drop 1 z)
555+ go :: [([FilePath], S8.ByteString)] -> Embedded
556+ go orig =
557+ Map.fromList $ map (second go') hoisted
558+ where
559+ next = map (\(x, y) -> (head x, (tail x, y))) orig
560+ grouped :: [[(FilePath, ([FilePath], S8.ByteString))]]
561+ grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
562+ hoisted :: [(FilePath, [([FilePath], S8.ByteString)])]
563+ hoisted = map (fst . head &&& map snd) grouped
564+ go' :: [([FilePath], S8.ByteString)] -> EmbeddedEntry
565+ go' [([], content)] = EEFile content
566+ go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
567+
568+bsToFile :: FilePath -> S8.ByteString -> File
569+bsToFile name bs = File
570+ { fileGetSize = S8.length bs
571+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
572+ , fileName = name
573+ , fileGetHash = return $ Just $ runHash bs
574+ , fileGetModified = Nothing
575+ }
576+
577+runHash :: S8.ByteString -> S8.ByteString
578+runHash = B64.encode . MD5.hash
579+
580+runHashL :: L.ByteString -> ByteString
581+runHashL = B64.encode . MD5.hashlazy
582+
227staticApp :: StaticSettings -> W.Application
583staticApp :: StaticSettings -> W.Application
228−staticApp set req = staticAppPieces set (W.pathInfo req) req
584+staticApp set req = staticAppPieces set (map FilePath $ W.pathInfo req) req
585+
586+status304, statusNotModified :: H.Status
587+status304 = H.Status 304 "Not Modified"
588+statusNotModified = status304
589+
590+-- alist helper functions
591+replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
592+replace k v [] = [(k,v)]
593+replace k v (x:xs) | fst x == k = (k,v):xs
594+ | otherwise = x:replace k v xs
595+
596+remove :: Eq a => a -> [(a, b)] -> [(a, b)]
597+remove _ [] = []
598+remove k (x:xs) | fst x == k = xs
599+ | otherwise = x:remove k xs
229
600
601+
230−staticAppPieces :: StaticSettings -> [Text] -> W.Application
602+staticAppPieces :: StaticSettings -> Pieces -> W.Application
231−staticAppPieces _ _ req sendResponse
603+staticAppPieces _ _ req
232− | notElem (W.requestMethod req) ["GET", "HEAD"] = sendResponse $ W.responseLBS
604+ | W.requestMethod req /= "GET" = return $ W.responseLBS
233 H.status405
605 H.status405
234 [("Content-Type", "text/plain")]
606 [("Content-Type", "text/plain")]
235− "Only GET or HEAD is supported"
607+ "Only GET is supported"
236−staticAppPieces _ [".hidden", "folder.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")]
608+staticAppPieces ss pieces req = liftIO $ do
237−staticAppPieces _ [".hidden", "haskell.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")]
609+ let indices = ssIndices ss
238−staticAppPieces ss rawPieces req sendResponse = liftIO $ do
610+ case checkSpecialDirListing pieces of
239− case toPieces rawPieces of
611+ Just res -> response res
240− Just pieces -> checkPieces ss pieces req >>= response
612+ Nothing -> checkPieces (ssFolder ss) (map FilePath indices) pieces req (ssMaxAge ss) (ssUseHash ss) (ssRedirectToIndex ss) >>= response
241− Nothing -> sendResponse $ W.responseLBS H.status403
242− [ ("Content-Type", "text/plain")
243− ] "Forbidden"
244 where
613 where
245− response :: StaticResponse -> IO W.ResponseReceived
614+ response cp = case cp of
246− response (FileResponse file ch) = do
615+ FileResponse file ch -> do
247− mimetype <- ssGetMimeType ss file
616+ mimetype <- ssGetMimeType ss file
248− -- let filesize = fileGetSize file
617+ let filesize = fileGetSize file
249− let headers = ("Content-Type", mimetype)
618+ let headers = ("Content-Type", mimetype)
250− -- Let Warp provide the content-length, since it takes
251− -- range requests into account
252− -- : ("Content-Length", S8.pack $ show filesize)
619+ : ("Content-Length", S8.pack $ show filesize)
253− : ch
620+ : ch
254− sendResponse $ fileToResponse file H.status200 headers
621+ return $ fileToResponse file H.status200 headers
255−
256− response NotModified =
622+ NotModified ->
623+ return $ W.responseLBS statusNotModified
624+ [ ("Content-Type", "text/plain")
625+ ] "Not Modified"
626+ DirectoryResponse fp -> do
627+ case ssListing ss of
628+ (Just f) -> do
629+ lbs <- f pieces fp
257− sendResponse $ W.responseLBS H.status304 [] ""
630+ return $ W.responseLBS H.status200
258−
631+ [ ("Content-Type", "text/html; charset=utf-8")
632+ ] lbs
633+ Nothing -> return $ W.responseLBS H.status403
634+ [ ("Content-Type", "text/plain")
635+ ] "Directory listings disabled"
259− response (SendContent mt lbs) = do
636+ SendContent mt lbs -> do
260 -- TODO: set caching headers
637 -- TODO: set caching headers
261− sendResponse $ W.responseLBS H.status200
638+ return $ W.responseLBS H.status200
262 [ ("Content-Type", mt)
639 [ ("Content-Type", mt)
263 -- TODO: set Content-Length
640 -- TODO: set Content-Length
264 ] lbs
641 ] lbs
265
642
266− response (Redirect pieces' mHash) = do
643+ Redirect pieces' mHash -> do
267− let loc = ssMkRedirect ss pieces' $ L.toStrict $ toLazyByteString (H.encodePathSegments $ map fromPiece pieces')
644+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map unFilePath pieces')
268 let qString = case mHash of
645 let qString = case mHash of
269 Just hash -> replace "etag" (Just hash) (W.queryString req)
646 Just hash -> replace "etag" (Just hash) (W.queryString req)
270 Nothing -> remove "etag" (W.queryString req)
647 Nothing -> remove "etag" (W.queryString req)
271
648
272− sendResponse $ W.responseLBS H.status302
649+ return $ W.responseLBS H.status301
273 [ ("Content-Type", "text/plain")
650 [ ("Content-Type", "text/plain")
274 , ("Location", S8.append loc $ H.renderQuery True qString)
651 , ("Location", S8.append loc $ H.renderQuery True qString)
275 ] "Redirect"
652 ] "Redirect"
276−
653+ Forbidden -> return $ W.responseLBS H.status403
277− response (RawRedirect path) =
278− sendResponse $ W.responseLBS H.status302
279− [ ("Content-Type", "text/plain")
654+ [ ("Content-Type", "text/plain")
280− , ("Location", path)
655+ ] "Forbidden"
281− ] "Redirect"
282−
283− response NotFound = case (ss404Handler ss) of
284− Just app -> app req sendResponse
285− Nothing -> sendResponse $ W.responseLBS H.status404
656+ NotFound -> return $ W.responseLBS H.status404
286 [ ("Content-Type", "text/plain")
657 [ ("Content-Type", "text/plain")
287 ] "File not found"
658 ] "File not found"
288
659
289− response (WaiResponse r) = sendResponse r
660+-- | System.Directory functions are a lie:
661+-- they claim to be using String, but it's really just a raw byte sequence.
662+-- We're assuming that non-Windows systems use UTF-8 encoding (there was
663+-- a discussion regarding this, it wasn't an arbitrary decision). So we
664+-- need to encode/decode the byte sequence to/from UTF8. That's the use
665+-- case for fixPathName/unfixPathName. I'm starting to use John
666+-- Millikin's system-filepath package for some stuff with work, and might
667+-- consider migrating over to it for this in the future.
668+toFilePath :: Prelude.FilePath -> FilePath
669+#if defined(mingw32_HOST_OS)
670+toFilePath = FilePath . T.pack
671+#else
672+toFilePath = FilePath . TE.decodeUtf8With TEE.lenientDecode . S8.pack
673+#endif
674+
675+fromFilePath :: FilePath -> Prelude.FilePath
676+#if defined(mingw32_HOST_OS)
677+fromFilePath = T.unpack . unFilePath
678+#else
679+fromFilePath = S8.unpack . TE.encodeUtf8 . unFilePath
680+#endif
681+
682+-- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs
683+defaultListing :: Listing
684+defaultListing pieces (Folder _ contents) = do
685+ let isTop = null pieces || pieces == [""]
686+ let fps'' :: [Either Folder File]
687+ fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents
688+ return $ HU.renderHtml
689+ $ H.html $ do
690+ H.head $ do
691+ let title = T.unpack $ T.intercalate "/" $ map unFilePath pieces
692+ let title' = if null title then "root folder" else title
693+ H.title $ H.toHtml title'
694+ H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
695+ , "table, th, td { border: 1px solid #353948; }"
696+ , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
697+ , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
698+ , "td { padding-right: 1em; padding-left: 1em; }"
699+ , "th.first { background-color: white; width: 24px }"
700+ , "td.first { padding-right: 0; padding-left: 0; text-align: center }"
701+ , "tr { background-color: white; }"
702+ , "tr.alt { background-color: #A3B5BA}"
703+ , "th { background-color: #3C4569; color: white; font-size: 1.125em; }"
704+ , "h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }"
705+ , "img { width: 20px }"
706+ , "a { text-decoration: none }"
707+ ]
708+ H.body $ do
709+ H.h1 $ showFolder $ map unFilePath $ filter (not . nullFilePath) pieces
710+ renderDirectoryContentsTable haskellSrc folderSrc fps''
711+ where
712+ image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
713+ folderSrc = image "folder"
714+ haskellSrc = image "haskell"
715+ showName "" = "root"
716+ showName x = x
717+ showFolder [] = "/"
718+ showFolder [x] = H.toHtml $ showName x
719+ showFolder (x:xs) = do
720+ let href = concat $ replicate (length xs) "../" :: String
721+ H.a ! A.href (H.toValue href) $ H.toHtml $ showName x
722+ " / " :: H.Html
723+ showFolder xs
724+
725+-- | a function to generate an HTML table showing the contents of a directory on the disk
726+--
727+-- This function generates most of the content of the
728+-- 'renderDirectoryContents' page. If you want to style the page
729+-- differently, or add google analytics code, etc, you can just create
730+-- a new page template to wrap around this HTML.
731+--
732+-- see also: 'getMetaData', 'renderDirectoryContents'
733+renderDirectoryContentsTable :: String
734+ -> String
735+ -> [Either Folder File]
736+ -> H.Html
737+renderDirectoryContentsTable haskellSrc folderSrc fps =
738+ H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
739+ H.th "Name"
740+ H.th "Modified"
741+ H.th "Size"
742+ H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
743+ where
744+ sortMD :: Either Folder File -> Either Folder File -> Ordering
745+ sortMD Left{} Right{} = LT
746+ sortMD Right{} Left{} = GT
747+ sortMD (Left a) (Left b) = compare (folderName a) (folderName b)
748+ sortMD (Right a) (Right b) = compare (fileName a) (fileName b)
749+ mkRow :: (Either Folder File, Bool) -> H.Html
750+ mkRow (md, alt) =
751+ (if alt then (! A.class_ "alt") else id) $
752+ H.tr $ do
753+ H.td ! A.class_ "first"
754+ $ case md of
755+ Left{} -> H.img ! A.src (H.toValue folderSrc)
756+ ! A.alt "Folder"
757+ Right{} -> return ()
758+ let name = either folderName fileName md
759+ let isFile = either (const False) (const True) md
760+ H.td (H.a ! A.href (H.toValue $ unFilePath name `T.append` if isFile then "" else "/") $ H.toHtml $ unFilePath name)
761+ H.td ! A.class_ "date" $ H.toHtml $
762+ case md of
763+ Right File { fileGetModified = Just t } ->
764+ formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
765+ _ -> ""
766+ H.td ! A.class_ "size" $ H.toHtml $
767+ case md of
768+ Right File { fileGetSize = s } -> prettyShow s
769+ Left{} -> ""
770+ formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
771+ prettyShow x
772+ | x > 1024 = prettyShowK $ x `div` 1024
773+ | otherwise = addCommas "B" x
774+ prettyShowK x
775+ | x > 1024 = prettyShowM $ x `div` 1024
776+ | otherwise = addCommas "KB" x
777+ prettyShowM x
778+ | x > 1024 = prettyShowG $ x `div` 1024
779+ | otherwise = addCommas "MB" x
780+ prettyShowG x = addCommas "GB" x
781+ addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show
782+ addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
783+ addCommas' x = x
wai-app-static/README.mddeleted−5
@@ -1,5 +0,0 @@
1−## wai-app-static
2−
3−WAI application for static serving
4−
5−Also provides some helper functions and datatypes for use outside of WAI.
wai-app-static/Util.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
2−module Util
3− ( relativeDirFromPieces
4− , defaultMkRedirect
5− , replace
6− , remove
7− , dropLastIfNull
8− ) where
9−
10−import WaiAppStatic.Types
11−import qualified Data.Text as T
12−import Data.ByteString (ByteString)
13−import qualified Data.ByteString.Char8 as S8
14−import qualified Data.Text.Encoding as TE
15−
16−-- alist helper functions
17−replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
18−replace k v [] = [(k,v)]
19−replace k v (x:xs) | fst x == k = (k,v):xs
20− | otherwise = x:replace k v xs
21−
22−remove :: Eq a => a -> [(a, b)] -> [(a, b)]
23−remove _ [] = []
24−remove k (x:xs) | fst x == k = xs
25− | otherwise = x:remove k xs
26−
27−-- | Turn a list of pieces into a relative path to the root folder.
28−relativeDirFromPieces :: Pieces -> T.Text
29−relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
30−
31−-- | Construct redirects with relative paths.
32−defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString
33−defaultMkRedirect pieces newPath
34− | S8.null newPath || S8.null relDir ||
35− S8.last relDir /= '/' || S8.head newPath /= '/' =
36− relDir `S8.append` newPath
37− | otherwise = relDir `S8.append` S8.tail newPath
38− where
39− 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.hsdeleted−118
@@ -1,118 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2−-- | Command line version of wai-app-static, used for the warp-static server.
3−module WaiAppStatic.CmdLine
4− ( runCommandLine
5− , Args (..)
6− ) where
7−
8−import Network.Wai (Middleware)
9−import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
10−import Network.Wai.Handler.Warp
11− ( runSettings, defaultSettings, setHost, setPort
12− )
13−import Options.Applicative
14−import Text.Printf (printf)
15−import System.Directory (canonicalizePath)
16−import Control.Monad (unless)
17−import Network.Wai.Middleware.RequestLogger (logStdout)
18−import Network.Wai.Middleware.Gzip
19−import qualified Data.Map as Map
20−import qualified Data.ByteString.Char8 as S8
21−import Control.Arrow ((***))
22−import Data.Text (pack)
23−import Data.String (fromString)
24−import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType)
25−import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)
26−import Data.Maybe (mapMaybe)
27−import Control.Arrow (second)
28−import Data.Monoid ((<>))
29−
30−data Args = Args
31− { docroot :: FilePath
32− , index :: [FilePath]
33− , port :: Int
34− , noindex :: Bool
35− , quiet :: Bool
36− , verbose :: Bool
37− , mime :: [(String, String)]
38− , host :: String
39− }
40−
41−#if MIN_VERSION_optparse_applicative(0, 10, 0)
42−option' :: Mod OptionFields Int -> Parser Int
43−option' = option auto
44−#else
45−option' = option
46−#endif
47−
48−args :: Parser Args
49−args = Args
50− <$> strOption
51− ( long "docroot"
52− <> short 'd'
53− <> metavar "DOCROOT"
54− <> value "."
55− <> help "directory containing files to serve")
56− <*> (defIndex <$> many (strOption
57− ( long "index"
58− <> short 'i'
59− <> metavar "INDEX"
60− <> help "index files to serve when a directory is required"
61− )))
62− <*> option'
63− ( long "port"
64− <> short 'p'
65− <> metavar "PORT"
66− <> value 3000)
67− <*> switch
68− ( long "noindex"
69− <> short 'n')
70− <*> switch
71− ( long "quiet"
72− <> short 'q')
73− <*> switch
74− ( long "verbose"
75− <> short 'v')
76− <*> many (toPair <$> strOption
77− ( long "mime"
78− <> short 'm'
79− <> metavar "MIME"
80− <> help "extra file extension/mime type mappings"))
81− <*> strOption
82− ( long "host"
83− <> short 'h'
84− <> metavar "HOST"
85− <> value "*"
86− <> help "interface to bind to, special values: *, *4, *6")
87− where
88− toPair = second (drop 1) . break (== '=')
89− defIndex [] = ["index.html", "index.htm"]
90− defIndex x = x
91−
92−-- | Run with the given middleware and parsing options from the command line.
93−--
94−-- Since 2.0.1
95−runCommandLine :: (Args -> Middleware) -> IO ()
96−runCommandLine middleware = do
97− args@Args {..} <- execParser $ info (helperOption <*> args) fullDesc
98− let mime' = map (pack *** S8.pack) mime
99− let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap
100− docroot' <- canonicalizePath docroot
101− unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
102− let middle = gzip def { gzipFiles = GzipCompress }
103− . (if verbose then logStdout else id)
104− . (middleware args)
105− runSettings
106− ( setPort port
107− $ setHost (fromString host)
108− defaultSettings
109− )
110− $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)
111− { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
112− , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
113− }
114− where
115− helperOption :: Parser (a -> a)
116− helperOption =
117− abortOption ShowHelpText $
118− mconcat [long "help", help "Show this help text", hidden]
wai-app-static/WaiAppStatic/Listing.hsdeleted−150
@@ -1,150 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ViewPatterns #-}
4−module WaiAppStatic.Listing
5− ( defaultListing
6− ) where
7−
8−import qualified Text.Blaze.Html5.Attributes as A
9−import qualified Text.Blaze.Html5 as H
10−import Text.Blaze ((!))
11−import qualified Data.Text as T
12−import Data.Time
13−import Data.Time.Clock.POSIX
14−import WaiAppStatic.Types
15−#if !MIN_VERSION_time(1,5,0)
16−import System.Locale (defaultTimeLocale)
17−#endif
18−import Data.List (sortBy)
19−import Util
20−
21−import qualified Text.Blaze.Html.Renderer.Utf8 as HU
22−
23−-- | Provides a default directory listing, suitable for most apps.
24−--
25−-- Code below taken from Happstack: <https://github.com/Happstack/happstack-server/blob/87e6c01a65c687d06c61345430a112fc9a444a95/src/Happstack/Server/FileServe/BuildingBlocks.hs>
26−defaultListing :: Listing
27−defaultListing pieces (Folder contents) = do
28− let isTop = null pieces || map Just pieces == [toPiece ""]
29− let fps'' :: [Either FolderName File]
30− fps'' = (if isTop then id else (Left (unsafeToPiece "") :)) contents -- FIXME emptyParentFolder feels like a bit of a hack
31− return $ HU.renderHtmlBuilder
32− $ H.html $ do
33− H.head $ do
34− let title = T.intercalate "/" $ map fromPiece pieces
35− let title' = if T.null title then "root folder" else title
36− H.title $ H.toHtml title'
37− H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
38− , "table, th, td { border: 1px solid #353948; }"
39− , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
40− , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
41− , "td { padding-right: 1em; padding-left: 1em; }"
42− , "th.first { background-color: white; width: 24px }"
43− , "td.first { padding-right: 0; padding-left: 0; text-align: center }"
44− , "tr { background-color: white; }"
45− , "tr.alt { background-color: #A3B5BA}"
46− , "th { background-color: #3C4569; color: white; font-size: 1.125em; }"
47− , "h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }"
48− , "img { width: 20px }"
49− , "a { text-decoration: none }"
50− ]
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
57− renderDirectoryContentsTable (map fromPiece pieces) haskellSrc folderSrc fps''
58− where
59− image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
60− folderSrc = image "folder"
61− haskellSrc = image "haskell"
62− showName "" = "root"
63− showName x = x
64−
65− -- Add a link to the root of the tree
66− showFolder' :: Bool -> Pieces -> H.Html
67− showFolder' hasTrailingSlash pieces' = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces')
68−
69− showFolder :: Bool -> Pieces -> H.Html
70− showFolder _ [] = "/" -- won't happen
71− showFolder _ [x] = H.toHtml $ showName $ fromPiece x
72− showFolder hasTrailingSlash (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
77− H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x
78− " / " :: H.Html
79− showFolder hasTrailingSlash xs
80−
81−-- | a function to generate an HTML table showing the contents of a directory on the disk
82−--
83−-- This function generates most of the content of the
84−-- 'renderDirectoryContents' page. If you want to style the page
85−-- differently, or add google analytics code, etc, you can just create
86−-- a new page template to wrap around this HTML.
87−--
88−-- see also: 'getMetaData', 'renderDirectoryContents'
89−renderDirectoryContentsTable :: [T.Text] -- ^ requested path info
90− -> String
91− -> String
92− -> [Either FolderName File]
93− -> H.Html
94−renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps =
95− H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)
96− H.th "Name"
97− H.th "Modified"
98− H.th "Size"
99− H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True])
100− where
101− sortMD :: Either FolderName File -> Either FolderName File -> Ordering
102− sortMD Left{} Right{} = LT
103− sortMD Right{} Left{} = GT
104− sortMD (Left a) (Left b) = compare a b
105− sortMD (Right a) (Right b) = compare (fileName a) (fileName b)
106−
107− mkRow :: (Either FolderName File, Bool) -> H.Html
108− mkRow (md, alt) =
109− (if alt then (! A.class_ "alt") else id) $
110− H.tr $ do
111− H.td ! A.class_ "first"
112− $ case md of
113− Left{} -> H.img ! A.src (H.toValue folderSrc)
114− ! A.alt "Folder"
115− Right{} -> return ()
116− let name =
117− case either id fileName md of
118− (fromPiece -> "") -> unsafeToPiece ".."
119− x -> x
120− 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)
128− H.td ! A.class_ "date" $ H.toHtml $
129− case md of
130− Right File { fileGetModified = Just t } ->
131− formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t
132− _ -> ""
133− H.td ! A.class_ "size" $ H.toHtml $
134− case md of
135− Right File { fileGetSize = s } -> prettyShow s
136− Left{} -> ""
137− formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime)
138− prettyShow x
139− | x > 1024 = prettyShowK $ x `div` 1024
140− | otherwise = addCommas "B" x
141− prettyShowK x
142− | x > 1024 = prettyShowM $ x `div` 1024
143− | otherwise = addCommas "KB" x
144− prettyShowM x
145− | x > 1024 = prettyShowG $ x `div` 1024
146− | otherwise = addCommas "MB" x
147− prettyShowG x = addCommas "GB" x
148− addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show
149− addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
150− addCommas' x = x
wai-app-static/WaiAppStatic/Storage/Embedded.hsdeleted−12
@@ -1,12 +0,0 @@
1−module WaiAppStatic.Storage.Embedded(
2− -- * Basic
3− embeddedSettings
4−
5− -- * Template Haskell
6− , Etag
7− , EmbeddableEntry(..)
8− , mkSettings
9− ) where
10−
11−import WaiAppStatic.Storage.Embedded.Runtime
12−import WaiAppStatic.Storage.Embedded.TH
wai-app-static/WaiAppStatic/Storage/Embedded/Runtime.hsdeleted−97
@@ -1,97 +0,0 @@
1−-- | Lookup files stored in memory instead of from the filesystem.
2−module WaiAppStatic.Storage.Embedded.Runtime
3− ( -- * Settings
4− embeddedSettings
5− ) where
6−
7−import WaiAppStatic.Types
8−import Data.ByteString (ByteString)
9−import Control.Arrow ((&&&), second)
10−import Data.List
11−import Data.ByteString.Builder (byteString)
12−import qualified Network.Wai as W
13−import qualified Data.Map as Map
14−import Data.Function (on)
15−import qualified Data.Text as T
16−import Data.Ord
17−import qualified Data.ByteString as S
18−import Crypto.Hash (hash, MD5, Digest)
19−import Data.ByteArray.Encoding
20−import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)
21−import System.FilePath (isPathSeparator)
22−
23−-- | Serve the list of path/content pairs directly from memory.
24−embeddedSettings :: [(Prelude.FilePath, ByteString)] -> StaticSettings
25−embeddedSettings files = (defaultFileServerSettings $ error "unused")
26− { ssLookupFile = embeddedLookup $ toEmbedded files
27− }
28−
29−type Embedded = Map.Map Piece EmbeddedEntry
30−
31−data EmbeddedEntry = EEFile ByteString | EEFolder Embedded
32−
33−embeddedLookup :: Embedded -> Pieces -> IO LookupResult
34−embeddedLookup root pieces =
35− return $ elookup pieces root
36− where
37− elookup :: Pieces -> Embedded -> LookupResult
38− elookup [] x = LRFolder $ Folder $ map toEntry $ Map.toList x
39− elookup [p] x | T.null (fromPiece p) = elookup [] x
40− elookup (p:ps) x =
41− case Map.lookup p x of
42− Nothing -> LRNotFound
43− Just (EEFile f) ->
44− case ps of
45− [] -> LRFile $ bsToFile p f
46− _ -> LRNotFound
47− Just (EEFolder y) -> elookup ps y
48−
49−toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File
50−toEntry (name, EEFolder{}) = Left name
51−toEntry (name, EEFile bs) = Right File
52− { fileGetSize = fromIntegral $ S.length bs
53− , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs
54− , fileName = name
55− , fileGetHash = return $ Just $ runHash bs
56− , fileGetModified = Nothing
57− }
58−
59−toEmbedded :: [(Prelude.FilePath, ByteString)] -> Embedded
60−toEmbedded fps =
61− go texts
62− where
63− texts = map (\(x, y) -> (filter (not . T.null . fromPiece) $ toPieces' x, y)) fps
64− toPieces' "" = []
65− toPieces' x =
66− -- See https://github.com/yesodweb/yesod/issues/626
67− --
68− -- We want to separate on the forward slash on *all* OSes, and on
69− -- Windows, also separate on a backslash.
70− let (y, z) = break isPathSeparator x
71− in unsafeToPiece (T.pack y) : toPieces' (drop 1 z)
72−
73− go :: [(Pieces, ByteString)] -> Embedded
74− go orig =
75− Map.fromList $ map (second go') hoisted
76− where
77− next = map (\(x, y) -> (head x, (tail x, y))) orig
78− grouped :: [[(Piece, ([Piece], ByteString))]]
79− grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
80− hoisted :: [(Piece, [([Piece], ByteString)])]
81− hoisted = map (fst . head &&& map snd) grouped
82−
83− go' :: [(Pieces, ByteString)] -> EmbeddedEntry
84− go' [([], content)] = EEFile content
85− go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
86−
87−bsToFile :: Piece -> ByteString -> File
88−bsToFile name bs = File
89− { fileGetSize = fromIntegral $ S.length bs
90− , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs
91− , fileName = name
92− , fileGetHash = return $ Just $ runHash bs
93− , fileGetModified = Nothing
94− }
95−
96−runHash :: ByteString -> ByteString
97−runHash = convertToBase Base64 . (hash :: S.ByteString -> Digest MD5)
wai-app-static/WaiAppStatic/Storage/Embedded/TH.hsdeleted−277
@@ -1,277 +0,0 @@
1−{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash #-}
2−module WaiAppStatic.Storage.Embedded.TH(
3− Etag
4− , EmbeddableEntry(..)
5− , mkSettings
6−) where
7−
8−import Data.ByteString.Builder.Extra (byteStringInsert)
9−import Codec.Compression.GZip (compress)
10−import Data.ByteString.Unsafe (unsafePackAddressLen)
11−import Data.Either (lefts, rights)
12−import GHC.Exts (Int(..))
13−import Language.Haskell.TH
14−import Network.Mime (MimeType, defaultMimeLookup)
15−import System.IO.Unsafe (unsafeDupablePerformIO)
16−import WaiAppStatic.Types
17−import WaiAppStatic.Storage.Filesystem (defaultWebAppSettings)
18−import qualified Data.ByteString as B
19−import qualified Data.ByteString.Lazy as BL
20−#if !MIN_VERSION_template_haskell(2, 8, 0)
21−import qualified Data.ByteString.Char8 as B8
22−import qualified Data.ByteString.Lazy.Char8 as BL8
23−#endif
24−import qualified Data.HashMap.Strict as M
25−import qualified Data.Text as T
26−import qualified Data.Text.Encoding as T
27−import qualified Network.Wai as W
28−
29−-- | An Etag is used to return 304 Not Modified responses so the client does not need
30−-- to download resources a second time. Usually the etag is built from a hash of
31−-- the content. To disable Etags, you can pass the empty string. This will cause the
32−-- content to be redownloaded on every request.
33−type Etag = T.Text
34−
35−-- | Used at compile time to hold data about an entry to embed into the compiled executable.
36−data EmbeddableEntry = EmbeddableEntry {
37− eLocation :: T.Text -- ^ The location where this resource should be served from. The
38− -- location can contain forward slashes (/) to simulate directories,
39− -- but must not end with a forward slash.
40− , eMimeType :: MimeType -- ^ The mime type.
41− , eContent :: Either (Etag, BL.ByteString) ExpQ
42− -- ^ The content itself. The content can be given as a tag and bytestring,
43− -- in which case the content will be embedded directly into the execuatble.
44− -- Alternatively, the content can be given as a template haskell expression
45− -- returning @IO ('Etag', 'BL.ByteString')@ in which case this action will
46− -- be executed on every request to reload the content (this is useful
47− -- for a debugging mode).
48−}
49−
50−-- | This structure is used at runtime to hold the entry.
51−data EmbeddedEntry = EmbeddedEntry {
52− embLocation :: !T.Text
53− , embMime :: !MimeType
54− , embEtag :: !B.ByteString
55− , embCompressed :: !Bool
56− , embContent :: !B.ByteString
57−}
58−
59−-- | This structure is used at runtime to hold the reload entries.
60−data ReloadEntry = ReloadEntry {
61− reloadLocation :: !T.Text
62− , reloadMime :: !MimeType
63− , reloadContent :: IO (T.Text, BL.ByteString)
64−}
65−
66−-- The use of unsafePackAddressLen is safe here because the length
67−-- is correct and we will only be reading from the bytestring, never
68−-- modifying it.
69−--
70−-- The only IO within unsafePackAddressLen is within newForeignPtr_ where
71−-- a new IORef is created as newIORef (NoFinalizers, []) to hold the finalizer
72−-- for the pointer. Since the pointer for the content will never have a finalizer
73−-- added, we do not care if this finalizer IORef gets created more than once since
74−-- the IORef will always be holding (NoFinalizers, []). Therefore
75−-- unsafeDupablePerformIO is safe.
76−bytestringE :: B.ByteString -> ExpQ
77−#if MIN_VERSION_template_haskell(2, 8, 0)
78−bytestringE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
79− where
80− lenE = litE $ intPrimL $ toInteger $ B.length b
81− ctE = litE $ stringPrimL $ B.unpack b
82−#else
83−bytestringE b =
84− [| B8.pack $s |]
85− where
86− s = litE $ stringL $ B8.unpack b
87−#endif
88−
89−bytestringLazyE :: BL.ByteString -> ExpQ
90−#if MIN_VERSION_template_haskell(2, 8, 0)
91−bytestringLazyE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
92− where
93− lenE = litE $ intPrimL $ toInteger $ BL.length b
94− ctE = litE $ stringPrimL $ BL.unpack b
95−#else
96−bytestringLazyE b =
97− [| B8.pack $s |]
98− where
99− s = litE $ stringL $ BL8.unpack b
100−#endif
101−
102−-- | A template haskell expression which creates either an EmbeddedEntry or ReloadEntry.
103−mkEntry :: EmbeddableEntry -> ExpQ
104−mkEntry (EmbeddableEntry loc mime (Left (etag, ct))) =
105− [| Left $ EmbeddedEntry (T.pack $locE)
106− $(bytestringE mime)
107− $(bytestringE $ T.encodeUtf8 etag)
108− (1 == I# $compressedE)
109− $(bytestringLazyE ct')
110− |]
111− where
112− locE = litE $ stringL $ T.unpack loc
113− (compressed, ct') = tryCompress mime ct
114− compressedE = litE $ intPrimL $ if compressed then 1 else 0
115−
116−mkEntry (EmbeddableEntry loc mime (Right expr)) =
117− [| Right $ ReloadEntry (T.pack $locE)
118− $(bytestringE mime)
119− $expr
120− |]
121− where
122− locE = litE $ stringL $ T.unpack loc
123−
124−-- | Converts an embedded entry to a file
125−embeddedToFile :: EmbeddedEntry -> File
126−embeddedToFile entry = File
127− { fileGetSize = fromIntegral $ B.length $ embContent entry
128− , fileToResponse = \s h ->
129− let h' = if embCompressed entry
130− then h ++ [("Content-Encoding", "gzip")]
131− else h
132− in W.responseBuilder s h' $ byteStringInsert $ embContent entry
133−
134− -- 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− -- possible. lookupMime is provided only with the File and from that
137− -- we must find the mime type. Putting the path here is OK since
138− -- within staticApp the fileName is used for directory listings which
139− -- we have disabled.
140− , fileName = unsafeToPiece $ embLocation entry
141− , fileGetHash = return $ if B.null (embEtag entry)
142− then Nothing
143− else Just $ embEtag entry
144− , fileGetModified = Nothing
145− }
146−
147−-- | Converts a reload entry to a file
148−reloadToFile :: ReloadEntry -> IO File
149−reloadToFile entry = do
150− (etag, ct) <- reloadContent entry
151− let etag' = T.encodeUtf8 etag
152− return $ File
153− { fileGetSize = fromIntegral $ BL.length ct
154− , fileToResponse = \s h -> W.responseLBS s h ct
155− -- Similar to above the entire path needs to be in the fileName.
156− , fileName = unsafeToPiece $ reloadLocation entry
157− , fileGetHash = return $ if T.null etag then Nothing else Just etag'
158− , fileGetModified = Nothing
159− }
160−
161−
162−-- | Build a static settings based on a filemap.
163−filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings
164−filemapToSettings mfiles = (defaultWebAppSettings "")
165− { ssLookupFile = lookupFile
166− , ssGetMimeType = lookupMime
167− }
168− where
169− piecesToFile p = T.intercalate "/" $ map fromPiece p
170−
171− lookupFile [] = return LRNotFound
172− lookupFile p =
173− case M.lookup (piecesToFile p) mfiles of
174− Nothing -> return LRNotFound
175− Just (_,act) -> LRFile <$> act
176−
177− lookupMime (File { fileName = p }) =
178− case M.lookup (fromPiece p) mfiles of
179− Just (mime,_) -> return mime
180− Nothing -> return $ defaultMimeLookup $ fromPiece p
181−
182−-- | Create a 'StaticSettings' from a list of entries. Executed at run time.
183−entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings
184−entriesToSt entries = hmap `seq` filemapToSettings hmap
185− where
186− embFiles = [ (embLocation e, (embMime e, return $ embeddedToFile e)) | e <- lefts entries]
187− reloadFiles = [ (reloadLocation r, (reloadMime r, reloadToFile r)) | r <- rights entries]
188− hmap = M.fromList $ embFiles ++ reloadFiles
189−
190−-- | Create a 'StaticSettings' at compile time that embeds resources directly into the compiled
191−-- executable. The embedded resources are precompressed (depending on mime type)
192−-- so that during runtime the resource can be served very quickly.
193−--
194−-- Because of GHC Template Haskell stage restrictions, you must define
195−-- the entries in a different module than where you create the 'StaticSettings'.
196−-- For example,
197−--
198−-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
199−-- > module A (mkEmbedded) where
200−-- >
201−-- > import WaiAppStatic.Storage.Embedded
202−-- > import Crypto.Hash.MD5 (hashlazy)
203−-- > import qualified Data.ByteString.Lazy as BL
204−-- > import qualified Data.ByteString.Base64 as B64
205−-- > import qualified Data.Text as T
206−-- > import qualified Data.Text.Encoding as T
207−-- >
208−-- > hash :: BL.ByteString -> T.Text
209−-- > hash = T.take 8 . T.decodeUtf8 . B64.encode . hashlazy
210−-- >
211−-- > mkEmbedded :: IO [EmbeddableEntry]
212−-- > mkEmbedded = do
213−-- > file <- BL.readFile "test.css"
214−-- > let emb = EmbeddableEntry {
215−-- > eLocation = "somedir/test.css"
216−-- > , eMimeType = "text/css"
217−-- > , eContent = Left (hash file, file)
218−-- > }
219−-- >
220−-- > let reload = EmbeddableEntry {
221−-- > eLocation = "anotherdir/test2.txt"
222−-- > , eMimeType = "text/plain"
223−-- > , eContent = Right [| BL.readFile "test2.txt" >>= \c -> return (hash c, c) |]
224−-- > }
225−-- >
226−-- > return [emb, reload]
227−--
228−-- The above @mkEmbedded@ will be executed at compile time. It loads the contents of test.css and
229−-- computes the hash of test.css for the etag. The content will be available at the URL somedir/test.css.
230−-- Internally, 'embedApp' below will attempt to compress the content at compile time. The compression will
231−-- only happen if the compressed content is shorter than the original and the mime type is either text or
232−-- javascript. If the content is compressed, at runtime the precomputed compressed content will be served
233−-- with the appropriate HTTP header. If 'embedApp' decides not to compress the content, it will be
234−-- served directly.
235−--
236−-- Secondly, @mkEmbedded@ creates a reloadable entry. This will be available at the URL anotherdir/test2.txt.
237−-- Whenver a request comes in for anotherdir/test2.txt, the action inside the quasiquote in eContent will
238−-- be executed. This will re-read the test2.txt file and recompute its hash.
239−--
240−-- Finally, here is a module which uses the above action to create a 'W.Application'.
241−--
242−-- > {-# LANGUAGE TemplateHaskell #-}
243−-- > module B where
244−-- >
245−-- > import A
246−-- > import Network.Wai (Application)
247−-- > import Network.Wai.Application.Static (staticApp)
248−-- > import WaiAppStatic.Storage.Embedded
249−-- > import Network.Wai.Handler.Warp (run)
250−-- >
251−-- > myApp :: Application
252−-- > myApp = staticApp $(mkSettings mkEmbedded)
253−-- >
254−-- > main :: IO ()
255−-- > main = run 3000 myApp
256−mkSettings :: IO [EmbeddableEntry] -> ExpQ
257−mkSettings action = do
258− entries <- runIO action
259− [| entriesToSt $(listE $ map mkEntry entries) |]
260−
261−shouldCompress :: MimeType -> Bool
262−shouldCompress m = "text/" `B.isPrefixOf` m || m `elem` extra
263− where
264− extra = [ "application/json"
265− , "application/javascript"
266− , "application/ecmascript"
267− ]
268−
269−-- | Only compress if the mime type is correct and the compressed text is actually shorter.
270−tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString)
271−tryCompress mime ct
272− | shouldCompress mime = (c, ct')
273− | otherwise = (False, ct)
274− where
275− compressed = compress ct
276− c = BL.length compressed < BL.length ct
277− ct' = if c then compressed else ct
wai-app-static/WaiAppStatic/Storage/Filesystem.hsdeleted−170
@@ -1,170 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE BangPatterns #-}
4−-- | Access files on the filesystem.
5−module WaiAppStatic.Storage.Filesystem
6− ( -- * Types
7− ETagLookup
8− -- * Settings
9− , defaultWebAppSettings
10− , defaultFileServerSettings
11− , webAppSettingsWithLookup
12− ) where
13−
14−import WaiAppStatic.Types
15−import System.FilePath ((</>))
16−import System.IO (withBinaryFile, IOMode(..))
17−import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
18−import Data.List (foldl')
19−import Control.Monad (forM)
20−import Util
21−import Data.ByteString (ByteString)
22−import Control.Exception (SomeException, try)
23−import qualified Network.Wai as W
24−import WaiAppStatic.Listing
25−import Network.Mime
26−import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRegularFile)
27−import Data.Maybe (catMaybes)
28−import Data.ByteArray.Encoding
29−import Crypto.Hash (hashlazy, MD5, Digest)
30−import qualified Data.ByteString.Lazy as BL (hGetContents)
31−import qualified Data.Text as T
32−
33−-- | Construct a new path from a root and some @Pieces@.
34−pathFromPieces :: FilePath -> Pieces -> FilePath
35−pathFromPieces = foldl' (\fp p -> fp </> T.unpack (fromPiece p))
36−
37−-- | Settings optimized for a web application. Files will have aggressive
38−-- caching applied and hashes calculated, and indices and listings are disabled.
39−defaultWebAppSettings :: FilePath -- ^ root folder to serve from
40− -> StaticSettings
41−defaultWebAppSettings root = StaticSettings
42− { ssLookupFile = webAppLookup hashFileIfExists root
43− , ssMkRedirect = defaultMkRedirect
44− , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName
45− , ssMaxAge = MaxAgeForever
46− , ssListing = Nothing
47− , ssIndices = []
48− , ssRedirectToIndex = False
49− , ssUseHash = True
50− , ssAddTrailingSlash = False
51− , ss404Handler = Nothing
52− }
53−
54−-- | Settings optimized for a file server. More conservative caching will be
55−-- applied, and indices and listings are enabled.
56−defaultFileServerSettings :: FilePath -- ^ root folder to serve from
57− -> StaticSettings
58−defaultFileServerSettings root = StaticSettings
59− { ssLookupFile = fileSystemLookup (fmap Just . hashFile) root
60− , ssMkRedirect = defaultMkRedirect
61− , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName
62− , ssMaxAge = NoMaxAge
63− , ssListing = Just defaultListing
64− , ssIndices = map unsafeToPiece ["index.html", "index.htm"]
65− , ssRedirectToIndex = False
66− , ssUseHash = False
67− , ssAddTrailingSlash = False
68− , ss404Handler = Nothing
69− }
70−
71−-- | Same as @defaultWebAppSettings@, but additionally uses a specialized
72−-- @ETagLookup@ in place of the standard one. This can allow you to cache your
73−-- hash values, or even precompute them.
74−webAppSettingsWithLookup :: FilePath -- ^ root folder to serve from
75− -> ETagLookup
76− -> StaticSettings
77−webAppSettingsWithLookup dir etagLookup =
78− (defaultWebAppSettings dir) { ssLookupFile = webAppLookup etagLookup dir}
79−
80−-- | Convenience wrapper for @fileHelper@.
81−fileHelperLR :: ETagLookup
82− -> FilePath -- ^ file location
83− -> Piece -- ^ file name
84− -> IO LookupResult
85−fileHelperLR a b c = fmap (maybe LRNotFound LRFile) $ fileHelper a b c
86−
87−-- | Attempt to load up a @File@ from the given path.
88−fileHelper :: ETagLookup
89− -> FilePath -- ^ file location
90− -> Piece -- ^ file name
91− -> IO (Maybe File)
92−fileHelper hashFunc fp name = do
93− efs <- try $ getFileStatus fp
94− case efs of
95− Left (_ :: SomeException) -> return Nothing
96− Right fs | isRegularFile fs -> return $ Just File
97− { fileGetSize = fromIntegral $ fileSize fs
98− , fileToResponse = \s h -> W.responseFile s h fp Nothing
99− , fileName = name
100− , fileGetHash = hashFunc fp
101− , fileGetModified = Just $ modificationTime fs
102− }
103− Right _ -> return Nothing
104−
105−-- | How to calculate etags. Can perform filesystem reads on each call, or use
106−-- some caching mechanism.
107−type ETagLookup = FilePath -> IO (Maybe ByteString)
108−
109−-- | More efficient than @fileSystemLookup@ as it only concerns itself with
110−-- finding files, not folders.
111−webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO LookupResult
112−webAppLookup hashFunc prefix pieces =
113− fileHelperLR hashFunc fp lastPiece
114− where
115− fp = pathFromPieces prefix pieces
116− lastPiece
117− | null pieces = unsafeToPiece ""
118− | otherwise = last pieces
119−
120−-- | MD5 hash and base64-encode the file contents. Does not check if the file
121−-- exists.
122−hashFile :: FilePath -> IO ByteString
123−hashFile fp = withBinaryFile fp ReadMode $ \h -> do
124− f <- BL.hGetContents h
125− let !hash = hashlazy f :: Digest MD5
126− return $ convertToBase Base64 hash
127−
128−hashFileIfExists :: ETagLookup
129−hashFileIfExists fp = do
130− res <- try $ hashFile fp
131− return $ case res of
132− Left (_ :: SomeException) -> Nothing
133− Right x -> Just x
134−
135−isVisible :: FilePath -> Bool
136−isVisible ('.':_) = False
137−isVisible "" = False
138−isVisible _ = True
139−
140−-- | Get a proper @LookupResult@, checking if the path is a file or folder.
141−-- Compare with @webAppLookup@, which only deals with files.
142−fileSystemLookup :: ETagLookup
143− -> FilePath -> Pieces -> IO LookupResult
144−fileSystemLookup hashFunc prefix pieces = do
145− let fp = pathFromPieces prefix pieces
146− fe <- doesFileExist fp
147− if fe
148− then fileHelperLR hashFunc fp lastPiece
149− else do
150− de <- doesDirectoryExist fp
151− if de
152− then do
153− entries' <- fmap (filter isVisible) $ getDirectoryContents fp
154− entries <- forM entries' $ \fpRel' -> do
155− let name = unsafeToPiece $ T.pack fpRel'
156− fp' = fp </> fpRel'
157− de' <- doesDirectoryExist fp'
158− if de'
159− then return $ Just $ Left name
160− else do
161− mfile <- fileHelper hashFunc fp' name
162− case mfile of
163− Nothing -> return Nothing
164− Just file -> return $ Just $ Right file
165− return $ LRFolder $ Folder $ catMaybes entries
166− else return LRNotFound
167− where
168− lastPiece
169− | null pieces = unsafeToPiece ""
170− | otherwise = last pieces
wai-app-static/WaiAppStatic/Types.hsdeleted−153
@@ -1,153 +0,0 @@
1−module WaiAppStatic.Types
2− ( -- * Pieces
3− Piece
4− , toPiece
5− , fromPiece
6− , unsafeToPiece
7− , Pieces
8− , toPieces
9− -- * Caching
10− , MaxAge (..)
11− -- * File\/folder serving
12− , FolderName
13− , Folder (..)
14− , File (..)
15− , LookupResult (..)
16− , Listing
17− -- * Settings
18− , StaticSettings (..)
19− ) where
20−
21−import Data.Text (Text)
22−import qualified Network.HTTP.Types as H
23−import qualified Network.Wai as W
24−import Data.ByteString (ByteString)
25−import System.Posix.Types (EpochTime)
26−import qualified Data.Text as T
27−import Data.ByteString.Builder (Builder)
28−import Network.Mime (MimeType)
29−
30−-- | An individual component of a path, or of a filepath.
31−--
32−-- This is the core type used by wai-app-static for doing lookups. It provides
33−-- a smart constructor to avoid the possibility of constructing unsafe path
34−-- segments (though @unsafeToPiece@ can get around that as necessary).
35−--
36−-- Individual file lookup backends must know how to convert from a @Piece@ to
37−-- their storage system.
38−newtype Piece = Piece { fromPiece :: Text }
39− deriving (Show, Eq, Ord)
40−
41−-- | Smart constructor for a @Piece@. Won\'t allow unsafe components, such as
42−-- pieces beginning with a period or containing a slash. This /will/, however,
43−-- allow null pieces.
44−toPiece :: Text -> Maybe Piece
45−toPiece t
46− | T.null t = Just $ Piece t
47− | T.head t == '.' = Nothing
48− | T.any (== '/') t = Nothing
49− | otherwise = Just $ Piece t
50−
51−-- | Construct a @Piece@ without input validation.
52−unsafeToPiece :: Text -> Piece
53−unsafeToPiece = Piece
54−
55−-- | Call @toPiece@ on a list.
56−--
57−-- > toPieces = mapM toPiece
58−toPieces :: [Text] -> Maybe Pieces
59−toPieces = mapM toPiece
60−
61−-- | Request coming from a user. Corresponds to @pathInfo@.
62−--
63−-- The root path is the empty list.
64−type Pieces = [Piece]
65−
66−-- | Values for the max-age component of the cache-control response header.
67−data MaxAge = NoMaxAge -- ^ no cache-control set
68− | MaxAgeSeconds Int -- ^ set to the given number of seconds
69− | MaxAgeForever -- ^ essentially infinite caching; in reality, probably one year
70−
71−-- | Just the name of a folder.
72−type FolderName = Piece
73−
74−-- | Represent contents of a single folder, which can be itself either a file
75−-- or a folder.
76−data Folder = Folder
77− { folderContents :: [Either FolderName File]
78− }
79−
80−-- | Information on an individual file.
81−data File = File
82− { -- | Size of file in bytes
83− fileGetSize :: Integer
84− -- | 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
86− -- in memory and should use @ResponseBuilder@.
87− , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response
88− -- | Last component of the filename.
89− , fileName :: Piece
90− -- | Calculate a hash of the contents of this file, such as for etag.
91− , fileGetHash :: IO (Maybe ByteString)
92− -- | Last modified time, used for both display in listings and if-modified-since.
93− , fileGetModified :: Maybe EpochTime
94− }
95−
96−-- | Result of looking up a file in some storage backend.
97−--
98−-- The lookup is either a file or folder, or does not exist.
99−data LookupResult = LRFile File
100− | LRFolder Folder
101− | LRNotFound
102−
103−-- | How to construct a directory listing page for the given request path and
104−-- the resulting folder.
105−type Listing = Pieces -> Folder -> IO Builder
106−
107−-- | All of the settings available to users for tweaking wai-app-static.
108−--
109−-- Note that you should use the settings type approach for modifying values.
110−-- See <http://www.yesodweb.com/book/settings-types> for more information.
111−data StaticSettings = StaticSettings
112− {
113− -- | Lookup a single file or folder. This is how you can control storage
114− -- backend (filesystem, embedded, etc) and where to lookup.
115− ssLookupFile :: Pieces -> IO LookupResult
116−
117− -- | Determine the mime type of the given file. Note that this function
118− -- lives in @IO@ in case you want to perform more complicated mimetype
119− -- analysis, such as via the @file@ utility.
120− , ssGetMimeType :: File -> IO MimeType
121−
122− -- | Ordered list of filenames to be used for indices. If the user
123− -- requests a folder, and a file with the given name is found in that
124− -- folder, that file is served. This supercedes any directory listing.
125− , ssIndices :: [Piece]
126−
127− -- | How to perform a directory listing. Optional. Will be used when the
128− -- user requested a folder.
129− , ssListing :: Maybe Listing
130−
131− -- | Value to provide for max age in the cache-control.
132− , ssMaxAge :: MaxAge
133−
134− -- | Given a requested path and a new destination, construct a string
135− -- that will go there. Default implementation will use relative paths.
136− , ssMkRedirect :: Pieces -> ByteString -> ByteString
137−
138− -- | If @True@, send a redirect to the user when a folder is requested
139− -- and an index page should be displayed. When @False@, display the
140− -- content immediately.
141− , ssRedirectToIndex :: Bool
142−
143− -- | Prefer usage of etag caching to last-modified caching.
144− , 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− }
wai-app-static/app/warp-static.hsdeleted−7
@@ -1,7 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2−module Main (main) where
3−
4−import WaiAppStatic.CmdLine (runCommandLine)
5−
6−main :: IO ()
7−main = runCommandLine (const id)
wai-app-static/embedded-sample.hs+3−5
@@ -1,13 +1,11 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE OverloadedStrings #-}
3import Network.Wai.Application.Static
2import Network.Wai.Application.Static
4import Network.Wai.Handler.Warp (run)
3import Network.Wai.Handler.Warp (run)
5import Data.FileEmbed
4import Data.FileEmbed
6−import WaiAppStatic.Types
7−import WaiAppStatic.Storage.Embedded
8
5
9main :: IO ()
6main :: IO ()
10−main = run 3000 $ staticApp (embeddedSettings $(embedDir "test"))
7+main = run 3000 $ staticApp defaultFileServerSettings
8+ { ssFolder = embeddedLookup $ toEmbedded $(embedDir ".")
11− { ssIndices = []
9+ , ssIndices = []
12 , ssMaxAge = NoMaxAge
10 , ssMaxAge = NoMaxAge
13 }
11 }
wai-app-static/sample.hs+6−13
@@ -1,17 +1,10 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+import Network.Wai.Application.Static
3+import Network.Wai.Handler.Warp (run)
2
4
3−import Data.String
4−import Data.Text (pack)
5−import Data.Maybe (mapMaybe)
6−import WaiAppStatic.Types (ssIndices, toPiece)
7−import Network.Wai.Application.Static (staticApp,defaultFileServerSettings)
8−import Network.Wai.Handler.Warp (runSettings, settingsPort, defaultSettings)
9−
10main :: IO ()
5main :: IO ()
11−main = runSettings defaultSettings
6+main = run 3000 $ staticApp defaultWebAppSettings
12− {
7+ { ssFolder = fileSystemLookup "."
13− settingsPort = 3000
8+ , ssMaxAge = MaxAgeForever
14− } $ staticApp (defaultFileServerSettings $ fromString ".")
9+ , ssIndices = []
15− {
16− ssIndices = mapMaybe (toPiece . pack) ["index.html"]
17 }
10 }
wai-app-static/test/EmbeddedTestEntries.hsdeleted−55
@@ -1,55 +0,0 @@
1−{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
2−
3−module EmbeddedTestEntries where
4−
5−import WaiAppStatic.Storage.Embedded
6−import qualified Data.Text as T
7−import qualified Data.Text.Lazy as TL
8−import qualified Data.Text.Lazy.Encoding as TL
9−import qualified Data.ByteString.Lazy as BL
10−
11−body :: Int -> Char -> BL.ByteString
12−body i c = TL.encodeUtf8 $ TL.pack $ take i $ repeat c
13−
14−mkEntries :: IO [EmbeddableEntry]
15−mkEntries = return
16− -- An entry that should be compressed
17− [ EmbeddableEntry "e1.txt"
18− "text/plain"
19− (Left ("Etag 1", body 1000 'A'))
20−
21− -- An entry so short that the compressed text is longer
22− , EmbeddableEntry "e2.txt"
23− "text/plain"
24− (Left ("Etag 2", "ABC"))
25−
26− -- An entry that is not compressed because of the mime
27− , EmbeddableEntry "somedir/e3.txt"
28− "xxx"
29− (Left ("Etag 3", body 1000 'A'))
30−
31− -- A reloadable entry
32− , EmbeddableEntry "e4.css"
33− "text/css"
34− (Right [| return ("Etag 4" :: T.Text, body 2000 'Q') |])
35−
36− -- An entry without etag
37− , EmbeddableEntry "e5.txt"
38− "text/plain"
39− (Left ("", body 1000 'Z'))
40−
41− -- A reloadable entry without etag
42− , EmbeddableEntry "e6.txt"
43− "text/plain"
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− ]
wai-app-static/test/WaiAppEmbeddedTest.hsdeleted−94
@@ -1,94 +0,0 @@
1−{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
2−module WaiAppEmbeddedTest (embSpec) where
3−
4−import Codec.Compression.GZip (compress)
5−import EmbeddedTestEntries
6−import Network.Wai
7−import Network.Wai.Application.Static (staticApp)
8−import Network.Wai.Test
9−import Test.Hspec
10−import WaiAppStatic.Storage.Embedded
11−import WaiAppStatic.Types
12−
13−defRequest :: Request
14−defRequest = defaultRequest
15−
16−embSpec :: Spec
17−embSpec = do
18− let embedSettings settings = flip runSession (staticApp settings)
19− let embed = embedSettings $(mkSettings mkEntries)
20− describe "embedded, compressed entry" $ do
21− it "served correctly" $ embed $ do
22− req <- request (setRawPathInfo defRequest "e1.txt")
23− assertStatus 200 req
24− assertHeader "Content-Type" "text/plain" req
25− assertHeader "Content-Encoding" "gzip" req
26− assertHeader "ETag" "Etag 1" req
27− assertNoHeader "Last-Modified req" req
28− assertBody (compress $ body 1000 'A') req
29−
30− it "304 when valid if-none-match sent" $ embed $ do
31− req <- request (setRawPathInfo defRequest "e1.txt")
32− { requestHeaders = [("If-None-Match", "Etag 1")] }
33− assertStatus 304 req
34−
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
54− it "too short" $ embed $ do
55− req <- request (setRawPathInfo defRequest "e2.txt")
56− assertStatus 200 req
57− assertHeader "Content-Type" "text/plain" req
58− assertNoHeader "Content-Encoding" req
59− assertHeader "ETag" "Etag 2" req
60− assertBody "ABC" req
61−
62− it "wrong mime" $ embed $ do
63− req <- request (setRawPathInfo defRequest "somedir/e3.txt")
64− assertStatus 200 req
65− assertHeader "Content-Type" "xxx" req
66− assertNoHeader "Content-Encoding" req
67− assertHeader "ETag" "Etag 3" req
68− assertBody (body 1000 'A') req
69−
70− describe "reloadable entry" $
71− it "served correctly" $ embed $ do
72− req <- request (setRawPathInfo defRequest "e4.css")
73− assertStatus 200 req
74− assertHeader "Content-Type" "text/css" req
75− assertNoHeader "Content-Encoding" req
76− assertHeader "ETag" "Etag 4" req
77− assertBody (body 2000 'Q') req
78−
79− describe "entries without etags" $ do
80− it "embedded entry" $ embed $ do
81− req <- request (setRawPathInfo defRequest "e5.txt")
82− assertStatus 200 req
83− assertHeader "Content-Type" "text/plain" req
84− assertHeader "Content-Encoding" "gzip" req
85− assertNoHeader "ETag" req
86− assertBody (compress $ body 1000 'Z') req
87−
88− it "reload entry" $ embed $ do
89− req <- request (setRawPathInfo defRequest "e6.txt")
90− assertStatus 200 req
91− assertHeader "Content-Type" "text/plain" req
92− assertNoHeader "Content-Encoding" req
93− assertNoHeader "ETag" req
94− assertBody (body 1000 'W') req
wai-app-static/test/WaiAppStaticTest.hs+40−81
@@ -1,50 +1,50 @@
1{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
1{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
2−module WaiAppStaticTest (spec) where
2+module WaiAppStaticTest (specs) where
3
3
4import Network.Wai.Application.Static
4import Network.Wai.Application.Static
5−import WaiAppStatic.Types
6
5
7−import Test.Hspec
6+import Test.Hspec.Monadic
7+import Test.Hspec.QuickCheck
8+import Test.Hspec.HUnit ()
8−import Test.Mockery.Directory
9+import Test.HUnit ((@?=))
10+import Data.List (isInfixOf)
9import qualified Data.ByteString.Char8 as S8
11import qualified Data.ByteString.Char8 as S8
10-- import qualified Data.ByteString.Lazy.Char8 as L8
12-- import qualified Data.ByteString.Lazy.Char8 as L8
13+import qualified Data.Text as T
14+import qualified Data.Text.Encoding as TE
11import System.PosixCompat.Files (getFileStatus, modificationTime)
15import System.PosixCompat.Files (getFileStatus, modificationTime)
12−import System.FilePath
13−import System.IO.Temp
14
16
15import Network.HTTP.Date
17import Network.HTTP.Date
16−import Network.HTTP.Types (status500)
17{-import System.Locale (defaultTimeLocale)-}
18{-import System.Locale (defaultTimeLocale)-}
18{-import Data.Time.Format (formatTime)-}
19{-import Data.Time.Format (formatTime)-}
19
20
20import Network.Wai
21import Network.Wai
21import Network.Wai.Test
22import Network.Wai.Test
22
23
24+import Network.Socket.Internal as Sock
25+import qualified Network.HTTP.Types as H
23import Control.Monad.IO.Class (liftIO)
26import Control.Monad.IO.Class (liftIO)
24−import Network.Mime
27+import Data.Monoid (mempty)
25
28
26defRequest :: Request
29defRequest :: Request
27defRequest = defaultRequest
30defRequest = defaultRequest
28
31
29−spec :: Spec
32+specs :: Specs
30−spec = do
33+specs = do
31− let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"
34+ let webApp = flip runSession $ staticApp defaultWebAppSettings {ssFolder = fileSystemLookup "test"}
32− let fileServerAppWithSettings settings = flip runSession $ staticApp settings
33− let fileServerApp = fileServerAppWithSettings (defaultFileServerSettings "test")
35+ let fileServerApp = flip runSession $ staticApp defaultFileServerSettings {ssFolder = fileSystemLookup "test"}
34− { ssAddTrailingSlash = True
35− }
36
36
37 let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
37 let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="
38 let file = "a/b"
38 let file = "a/b"
39 let statFile = setRawPathInfo defRequest file
39 let statFile = setRawPathInfo defRequest file
40
40
41− describe "mime types" $ do
41+ describe "Pieces: pathFromPieces" $ do
42− it "fileNameExtensions" $
42+ it "converts to a file path" $
43− fileNameExtensions "foo.tar.gz" `shouldBe` ["tar.gz", "gz"]
43+ (pathFromPieces "prefix" ["a", "bc"]) @?= "prefix/a/bc"
44− it "handles multi-extensions" $
44+
45− defaultMimeLookup "foo.tar.gz" `shouldBe` "application/x-tgz"
45+ prop "each piece is in file path" $ \piecesS ->
46− it "defaults correctly" $
46+ let pieces = map (FilePath . T.pack) piecesS
47− defaultMimeLookup "foo.unknown" `shouldBe` "application/octet-stream"
47+ in all (\p -> ("/" ++ p) `isInfixOf` (T.unpack $ unFilePath $ pathFromPieces "root" $ pieces)) piecesS
48
48
49 describe "webApp" $ do
49 describe "webApp" $ do
50 it "403 for unsafe paths" $ webApp $
50 it "403 for unsafe paths" $ webApp $
@@ -57,35 +57,44 @@ spec = do
57 assertStatus 200 =<<
57 assertStatus 200 =<<
58 request (setRawPathInfo defRequest path)
58 request (setRawPathInfo defRequest path)
59
59
60− it "404 for non-existent files" $ webApp $
60+ it "404 for non-existant files" $ webApp $
61 assertStatus 404 =<<
61 assertStatus 404 =<<
62 request (setRawPathInfo defRequest "doesNotExist")
62 request (setRawPathInfo defRequest "doesNotExist")
63
63
64− it "302 redirect when multiple slashes" $ webApp $ do
64+ it "301 redirect when multiple slashes" $ webApp $ do
65 req <- request (setRawPathInfo defRequest "a//b/c")
65 req <- request (setRawPathInfo defRequest "a//b/c")
66− assertStatus 302 req
66+ assertStatus 301 req
67 assertHeader "Location" "../../a/b/c" req
67 assertHeader "Location" "../../a/b/c" req
68
68
69− let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {
69+ let absoluteApp = flip runSession $ staticApp $ defaultWebAppSettings {
70− ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
70+ ssFolder = fileSystemLookup "test", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u
71 }
71 }
72− it "302 redirect when multiple slashes" $ absoluteApp $
72+ it "301 redirect when multiple slashes" $ absoluteApp $
73 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
73 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do
74 req <- request (setRawPathInfo defRequest path)
74 req <- request (setRawPathInfo defRequest path)
75− assertStatus 302 req
75+ assertStatus 301 req
76 assertHeader "Location" "http://www.example.com/a/b/c" req
76 assertHeader "Location" "http://www.example.com/a/b/c" req
77
77
78 describe "webApp when requesting a static asset" $ do
78 describe "webApp when requesting a static asset" $ do
79 it "200 and etag when no etag query parameters" $ webApp $ do
79 it "200 and etag when no etag query parameters" $ webApp $ do
80 req <- request statFile
80 req <- request statFile
81 assertStatus 200 req
81 assertStatus 200 req
82+ assertNoHeader "Cache-Control" req
82 assertHeader "ETag" etag req
83 assertHeader "ETag" etag req
83 assertNoHeader "Last-Modified" req
84 assertNoHeader "Last-Modified" req
84
85
86+ it "200 when no cache headers and bad cache query string" $ webApp $ do
87+ flip mapM_ [Just "cached", Nothing] $ \badETag -> do
88+ req <- request statFile { queryString = [("etag", badETag)] }
89+ assertStatus 301 req
90+ assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req
91+ assertNoHeader "Cache-Control" req
92+ assertNoHeader "Last-Modified" req
93+
85 it "Cache-Control set when etag parameter is correct" $ webApp $ do
94 it "Cache-Control set when etag parameter is correct" $ webApp $ do
86 req <- request statFile { queryString = [("etag", Just etag)] }
95 req <- request statFile { queryString = [("etag", Just etag)] }
87 assertStatus 200 req
96 assertStatus 200 req
88− assertHeader "Cache-Control" "public, max-age=31536000" req
97+ assertHeader "Cache-Control" "max-age=31536000" req
89 assertNoHeader "Last-Modified" req
98 assertNoHeader "Last-Modified" req
90
99
91 it "200 when invalid in-none-match sent" $ webApp $
100 it "200 when invalid in-none-match sent" $ webApp $
@@ -120,6 +129,7 @@ spec = do
120 requestHeaders = [("If-Modified-Since", badDate)]
129 requestHeaders = [("If-Modified-Since", badDate)]
121 }
130 }
122 assertStatus 200 req
131 assertStatus 200 req
132+ assertNoHeader "Cache-Control" req
123 fdate <- fileDate
133 fdate <- fileDate
124 assertHeader "Last-Modified" fdate req
134 assertHeader "Last-Modified" fdate req
125
135
@@ -131,54 +141,3 @@ spec = do
131 assertStatus 304 req
141 assertStatus 304 req
132 assertNoHeader "Cache-Control" req
142 assertNoHeader "Cache-Control" req
133
143
134− context "302 redirect to add a trailing slash on directories if missing" $ do
135− it "works at the root" $ fileServerApp $ do
136− req <- request (setRawPathInfo defRequest "/a")
137− assertStatus 302 req
138− assertHeader "Location" "/a/" req
139−
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 ->
151− case pathInfo req of
152− "subPath":rest ->
153− let req' = req { pathInfo = rest }
154− in (staticApp (defaultFileServerSettings "test")
155− { ssAddTrailingSlash = True
156− }) req' send
157− _ -> send $ responseLBS status500 []
158− "urlMapApp: only works at subPath"
159− it "works with subpath at the root of the file server" $ urlMapApp $ do
160− req <- request (setRawPathInfo defRequest "/subPath")
161− assertStatus 302 req
162− 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/tests.hs+4−5
@@ -1,6 +1,5 @@
1−import WaiAppStaticTest (spec)
1+import WaiAppStaticTest (specs)
2−import WaiAppEmbeddedTest (embSpec)
3−import Test.Hspec
2+import Test.Hspec.Monadic
4
3
5−main :: IO ()
4+main :: IO a
6−main = hspec $ spec >> embSpec
5+main = hspecX specs
wai-app-static/wai-app-static.cabal+26−60
@@ -1,24 +1,22 @@
1name: wai-app-static
1name: wai-app-static
2−version: 3.1.7.1
2+version: 1.2.0
3license: MIT
3license: MIT
4license-file: LICENSE
4license-file: LICENSE
5author: Michael Snoyman <michael@snoyman.com>
5author: Michael Snoyman <michael@snoyman.com>
6−maintainer: Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info>
6+maintainer: Michael Snoyman <michael@snoyman.com>
7synopsis: WAI application for static serving
7synopsis: WAI application for static serving
8−description: API docs and the README are available at <http://www.stackage.org/package/wai-app-static>.
8+description: Also provides some helper functions and datatypes for use outside of WAI.
9category: Web, Yesod
9category: Web, Yesod
10stability: Stable
10stability: Stable
11cabal-version: >= 1.8
11cabal-version: >= 1.8
12build-type: Simple
12build-type: Simple
13−homepage: http://www.yesodweb.com/book/web-application-interface
13+homepage: http://www.yesodweb.com/book/wai
14Extra-source-files:
14Extra-source-files:
15 images/folder.png
15 images/folder.png
16 images/haskell.png
16 images/haskell.png
17− test/*.hs
17+ test/WaiAppStaticTest.hs
18 test/a/b
18 test/a/b
19 tests.hs
19 tests.hs
20− README.md
21− ChangeLog.md
22
20
23Flag print
21Flag print
24 Description: print debug info
22 Description: print debug info
@@ -26,83 +24,51 @@ Flag print
26
24
27library
25library
28 build-depends: base >= 4 && < 5
26 build-depends: base >= 4 && < 5
29− , wai >= 3.0 && < 3.3
27+ , wai >= 1.2 && < 1.3
30− , bytestring >= 0.10.4
28+ , bytestring >= 0.9.1.4 && < 0.10
31− , http-types >= 0.7
29+ , http-types >= 0.6 && < 0.7
32− , transformers >= 0.2.2
30+ , transformers >= 0.2.2 && < 0.4
33 , unix-compat >= 0.2
31 , unix-compat >= 0.2
34− , directory >= 1.0.1
32+ , directory >= 1.0.1 && < 1.2
35− , containers >= 0.2
33+ , containers >= 0.2 && < 0.5
34+ , blaze-html >= 0.4 && < 0.5
36 , time >= 1.1.4
35 , time >= 1.1.4
37− , old-locale >= 1.0.0.2
36+ , old-locale >= 1.0.0.2 && < 1.1
38− , file-embed >= 0.0.3.1
37+ , file-embed >= 0.0.3.1 && < 0.1
39− , text >= 0.7
38+ , text >= 0.7 && < 0.12
40− , cryptonite >= 0.6
39+ , blaze-builder >= 0.2.1.4 && < 0.4
41− , memory >= 0.7
40+ , base64-bytestring >= 0.1 && < 0.2
41+ , cryptohash >= 0.7 && < 0.8
42 , http-date
42 , http-date
43− , blaze-html >= 0.5
44− , blaze-markup >= 0.5.1
45− , mime-types >= 0.1 && < 0.2
46− , unordered-containers >= 0.2
47− , template-haskell >= 2.7
48− , zlib >= 0.5
49− , filepath
50− , wai-extra >= 3.0 && < 3.1
51− , optparse-applicative >= 0.7
52− , warp >= 3.0.11 && < 3.4
53−
54 exposed-modules: Network.Wai.Application.Static
43 exposed-modules: Network.Wai.Application.Static
55− WaiAppStatic.Storage.Filesystem
56− WaiAppStatic.Storage.Embedded
57− WaiAppStatic.Listing
58− WaiAppStatic.Types
59− WaiAppStatic.CmdLine
60− other-modules: Util
61− WaiAppStatic.Storage.Embedded.Runtime
62− WaiAppStatic.Storage.Embedded.TH
63 ghc-options: -Wall
44 ghc-options: -Wall
64 extensions: CPP
45 extensions: CPP
65
46
66 if flag(print)
47 if flag(print)
67 cpp-options: -DPRINT
48 cpp-options: -DPRINT
68
49
69−Executable warp
70− Main-is: warp-static.hs
71− hs-source-dirs: app
72− Build-depends: base >= 4 && < 5
73− , wai-app-static
74− , directory >= 1.0
75− , containers >= 0.2
76− , bytestring >= 0.10.4
77− , text >= 0.7
78− , mime-types >= 0.1 && < 0.2
79−
80test-suite runtests
50test-suite runtests
81 hs-source-dirs: test
51 hs-source-dirs: test
82 main-is: ../tests.hs
52 main-is: ../tests.hs
83 type: exitcode-stdio-1.0
53 type: exitcode-stdio-1.0
84
54
85 build-depends: base >= 4 && < 5
55 build-depends: base >= 4 && < 5
86− , hspec >= 1.3
56+ , hspec >= 0.8 && < 0.10
57+ , HUnit
87− , unix-compat
58+ , unix-compat >= 0.2
88− , time
59+ , time >= 1.1.4
89− , old-locale
60+ , old-locale >= 1.0.0.2 && < 1.1
90 , http-date
61 , http-date
91− , wai-app-static
62+ , wai-app-static >= 1.2
92− , wai-extra
63+ , wai-test
93 , wai
64 , wai
94 , http-types
65 , http-types
95 , network
66 , network
96 , bytestring
67 , bytestring
97 , text
68 , text
98 , transformers
69 , transformers
99− , mime-types
100− , zlib
101− , filepath
102− , temporary
103− , mockery
104 -- , containers
70 -- , containers
105− ghc-options: -Wall
71+ ghc-options: -Wall
106
72
107source-repository head
73source-repository head
108 type: git
74 type: git
wai-conduit/ChangeLog.mddeleted−7
@@ -1,7 +0,0 @@
1−## 3.0.0.4
2−
3−* Drop dependency on blaze-builder
4−
5−## 3.0.0.3
6−
7−* Support wai 3.2
wai-conduit/LICENSEdeleted−20
@@ -1,20 +0,0 @@
1−Copyright (c) 2014 Michael Snoyman
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 included
12−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 NONINFRINGEMENT.
17−IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18−CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19−TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20−SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
wai-conduit/Network/Wai/Conduit.hsdeleted−66
@@ -1,66 +0,0 @@
1−-- | A light-weight wrapper around @Network.Wai@ to provide easy conduit support.
2−module Network.Wai.Conduit
3− ( -- * Request body
4− sourceRequestBody
5− -- * Response body
6− , responseSource
7− , responseRawSource
8− -- * Re-export
9− , module Network.Wai
10− ) where
11−
12−import Network.Wai
13−import Data.Conduit
14−import Control.Monad.IO.Class (MonadIO, liftIO)
15−import Data.ByteString (ByteString)
16−import qualified Data.ByteString as S
17−import Control.Monad (unless)
18−import Network.HTTP.Types
19−import Data.ByteString.Builder (Builder)
20−import qualified Data.Conduit.List as CL
21−
22−-- | Stream the request body.
23−--
24−-- Since 3.0.0
25−sourceRequestBody :: MonadIO m => Request -> ConduitT () ByteString m ()
26−sourceRequestBody req =
27− loop
28− where
29− go = liftIO (getRequestBodyChunk req)
30−
31− loop = do
32− bs <- go
33− unless (S.null bs) $ do
34− yield bs
35− loop
36−
37−-- | Create an HTTP response out of a @Source@.
38−--
39−-- Since 3.0.0
40−responseSource :: Status -> ResponseHeaders -> ConduitT () (Flush Builder) IO () -> Response
41−responseSource s hs src = responseStream s hs $ \send flush ->
42− runConduit $ src .| CL.mapM_ (\mbuilder ->
43− case mbuilder of
44− Chunk b -> send b
45− Flush -> flush)
46−
47−-- | Create a raw response using a @Source@ and @Sink@ to represent the input
48−-- and output, respectively.
49−--
50−-- Since 3.0.0
51−responseRawSource :: (MonadIO m, MonadIO n)
52− => (ConduitT () ByteString m () -> ConduitT ByteString Void n () -> IO ())
53− -> Response
54− -> Response
55−responseRawSource app =
56− responseRaw app'
57− where
58− app' recv send =
59− app src sink
60− where
61− src = do
62− bs <- liftIO recv
63− unless (S.null bs) $ do
64− yield bs
65− src
66− sink = CL.mapM_ $ liftIO . send
wai-conduit/README.mddeleted−4
@@ -1,4 +0,0 @@
1−## wai-conduit
2−
3−Since version 3.0.0, WAI has no built-in streaming data abstraction. This
4−library provides similar functionality to what existed in WAI 2.x.
wai-conduit/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
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.cabaldeleted−23
@@ -1,23 +0,0 @@
1−name: wai-conduit
2−version: 3.0.0.4
3−synopsis: conduit wrappers for WAI
4−description: API docs and the README are available at <http://www.stackage.org/package/wai-conduit>.
5−homepage: https://github.com/yesodweb/wai
6−license: MIT
7−license-file: LICENSE
8−author: Michael Snoyman
9−maintainer: michael@snoyman.com
10−category: Web, Conduit
11−build-type: Simple
12−cabal-version: >=1.10
13−extra-source-files: README.md ChangeLog.md
14−
15−library
16− exposed-modules: Network.Wai.Conduit
17− build-depends: base >= 4 && < 5
18− , wai >= 3.0 && < 3.3
19− , conduit
20− , transformers
21− , bytestring >= 0.10.4
22− , http-types
23− default-language: Haskell2010
wai-eventsource/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2012, Chris Smith, Mathias Biilmann Christensen. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
mime-types/Setup.lhs → wai-eventsource/Setup.lhsrenamed

The content is the same.

wai-eventsource/src/Main.hsnew file+56
@@ -0,0 +1,56 @@
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 (statusOK)
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 statusOK [("Content-Type", "text/html")] "static/index.html" Nothing
22+ ["esold"] -> eventSourceApp 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 IO ServerEvent
43+eventSource = C.sourceState () (const pull)
44+ where
45+ pull = do
46+ time <- liftIO $ do
47+ threadDelay 1000000
48+ getPOSIXTime
49+ return $ C.StateOpen () $ ServerEvent (Just $ fromString "source")
50+ Nothing
51+ [fromString . show $ time]
52+
53+main = do
54+ chan <- newChan
55+ _ <- forkIO . eventChan $ chan
56+ run 8000 (gzip def $ app chan)
wai-eventsource/src/Network/Wai/EventSource.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.EventSource (
3+ ServerEvent(..),
4+ eventSourceAppChan,
5+ eventSourceAppSource,
6+ eventSourceAppIO
7+ ) where
8+
9+import Blaze.ByteString.Builder (Builder)
10+import Control.Concurrent.Chan (Chan, dupChan, readChan)
11+import Control.Monad.IO.Class (liftIO)
12+import Data.Conduit (($=))
13+import qualified Data.Conduit as C
14+import qualified Data.Conduit.List as CL
15+import Network.HTTP.Types (status200)
16+import Network.Wai (Application, Response(..))
17+
18+import Network.Wai.EventSource.EventStream
19+
20+-- | Make a new WAI EventSource application reading events from
21+-- the given channel.
22+eventSourceAppChan :: Chan ServerEvent -> Application
23+eventSourceAppChan chan _ = do
24+ chan' <- liftIO $ dupChan chan
25+ return $ response chanToSource chan'
26+
27+-- | Make a new WAI EventSource application reading events from
28+-- the given source.
29+eventSourceAppSource :: C.Source (C.ResourceT IO) ServerEvent -> Application
30+eventSourceAppSource src _ = return $ response sourceToSource src
31+
32+-- | Make a new WAI EventSource application reading events from
33+-- the given IO action.
34+eventSourceAppIO :: IO ServerEvent -> Application
35+eventSourceAppIO act _ = return $ response ioToSource act
36+
37+response :: (a -> C.Source (C.ResourceT IO) (C.Flush Builder)) -> a -> Response
38+response f a = ResponseSource status200 [("Content-Type", "text/event-stream")] $ f a
39+
40+chanToSource :: Chan ServerEvent -> C.Source (C.ResourceT IO) (C.Flush Builder)
41+chanToSource chan =
42+ C.sourceState Nothing pull
43+ where
44+ pull Nothing = do
45+ x <- liftIO $ readChan chan
46+ return $ case eventToBuilder x of
47+ Nothing -> C.StateClosed
48+ Just y -> C.StateOpen (Just C.Flush) (C.Chunk y)
49+ pull (Just x) = return $ C.StateOpen Nothing x
50+
51+ioToSource :: IO ServerEvent -> C.Source (C.ResourceT IO) (C.Flush Builder)
52+ioToSource act =
53+ C.sourceState Nothing pull
54+ where
55+ pull Nothing = do
56+ x <- liftIO act
57+ return $ case eventToBuilder x of
58+ Nothing -> C.StateClosed
59+ Just y -> C.StateOpen (Just C.Flush) (C.Chunk y)
60+ pull (Just x) = return $ C.StateOpen Nothing x
61+
62+sourceToSource :: Monad m => C.Source m ServerEvent -> C.Source m (C.Flush Builder)
63+sourceToSource src = src $= CL.concatMap eventToFlushBuilder
64+ where
65+ eventToFlushBuilder event =
66+ case eventToBuilder event of
67+ Nothing -> []
68+ Just x -> [C.Chunk x, C.Flush]
wai-extra/Network/Wai/EventSource/EventStream.hs → wai-eventsource/src/Network/Wai/EventSource/EventStream.hsrenamed+22−15
@@ -1,18 +1,18 @@
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+ A WAI adapter to the HTML5 Server-Sent Events API. Push-mode and
6+ pull-mode interfaces are both available.
6-}
7-}
7module Network.Wai.EventSource.EventStream (
8module Network.Wai.EventSource.EventStream (
8 ServerEvent(..),
9 ServerEvent(..),
9 eventToBuilder
10 eventToBuilder
10 ) where
11 ) where
11
12
12−import Data.ByteString.Builder
13+import Blaze.ByteString.Builder
13−#if __GLASGOW_HASKELL__ < 710
14+import Blaze.ByteString.Builder.Char8
14import Data.Monoid
15import Data.Monoid
15−#endif
16
16
17{-|
17{-|
18 Type representing a communication over an event stream. This can be an
18 Type representing a communication over an event stream. This can be an
@@ -38,18 +38,18 @@ data ServerEvent
38 Newline as a Builder.
38 Newline as a Builder.
39-}
39-}
40nl :: Builder
40nl :: Builder
41−nl = char7 '\n'
41+nl = fromChar '\n'
42
42
43
43
44{-|
44{-|
45 Field names as Builder
45 Field names as Builder
46-}
46-}
47nameField, idField, dataField, retryField, commentField :: Builder
47nameField, idField, dataField, retryField, commentField :: Builder
48−nameField = string7 "event:"
48+nameField = fromString "event:"
49−idField = string7 "id:"
49+idField = fromString "id:"
50−dataField = string7 "data:"
50+dataField = fromString "data:"
51−retryField = string7 "retry:"
51+retryField = fromString "retry:"
52−commentField = char7 ':'
52+commentField = fromChar ':'
53
53
54
54
55{-|
55{-|
@@ -59,15 +59,22 @@ field :: Builder -> Builder -> Builder
59field l b = l `mappend` b `mappend` nl
59field l b = l `mappend` b `mappend` nl
60
60
61
61
62+{-|
63+ Appends a buffer flush to the end of a Builder.
64+-}
65+flushAfter :: Builder -> Builder
66+flushAfter b = b `mappend` flush
67+
68+
62{-|
69{-|
63 Converts a 'ServerEvent' to its wire representation as specified by the
70 Converts a 'ServerEvent' to its wire representation as specified by the
64 @text/event-stream@ content type.
71 @text/event-stream@ content type.
65-}
72-}
66eventToBuilder :: ServerEvent -> Maybe Builder
73eventToBuilder :: ServerEvent -> Maybe Builder
67−eventToBuilder (CommentEvent txt) = Just $ field commentField txt
74+eventToBuilder (CommentEvent txt) = Just $ flushAfter $ field commentField txt
68−eventToBuilder (RetryEvent n) = Just $ field retryField (string8 . show $ n)
75+eventToBuilder (RetryEvent n) = Just $ flushAfter $ field retryField (fromShow n)
69eventToBuilder (CloseEvent) = Nothing
76eventToBuilder (CloseEvent) = Nothing
70−eventToBuilder (ServerEvent n i d)= Just $
77+eventToBuilder (ServerEvent n i d)= Just $ flushAfter $
71 (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
78 (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
72 where
79 where
73 name Nothing = id
80 name Nothing = id
wai-extra/example/index.html → wai-eventsource/static/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-eventsource/wai-eventsource.cabalnew file+33
@@ -0,0 +1,33 @@
1+Name: wai-eventsource
2+Version: 1.2.0
3+Synopsis: WAI support for server-sent events
4+Description: WAI support for server-sent events
5+License: MIT
6+Author: Chris Smith, Mathias Biilmann Christensen
7+Maintainer: greg@gregweber.info
8+Stability: Experimental
9+Category: Web
10+Build-type: Simple
11+Cabal-version: >=1.8
12+homepage: http://www.yesodweb.com/book/wai
13+license-file: LICENSE
14+
15+Library
16+ Build-depends:
17+ base >= 4.3 && < 5
18+ , bytestring >= 0.9.1.4 && < 0.10
19+ , blaze-builder >= 0.3 && < 0.4
20+ , conduit >= 0.4 && < 0.5
21+ , http-types >= 0.6 && < 0.7
22+ , wai >= 1.2 && < 1.3
23+ , warp >= 1.2 && < 1.3
24+ , transformers
25+
26+ ghc-options: -Wall
27+ hs-source-dirs: src
28+ exposed-modules: Network.Wai.EventSource
29+ other-modules: Network.Wai.EventSource.EventStream
30+
31+source-repository head
32+ type: git
33+ location: git://github.com/yesodweb/wai.git
wai-extra/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -itest -optP-include -optPdist/build/autogen/cabal_macros.h
wai-extra/ChangeLog.mddeleted−209
@@ -1,209 +0,0 @@
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
164−
165−* Add appearsSecure: check if a request appears to be using SSL even in the
166− presence of reverse proxies [#362](https://github.com/yesodweb/wai/pull/362)
167−* Add ForceSSL middleware [#363](https://github.com/yesodweb/wai/pull/363)
168−* Add Approot middleware
169−
170−## 3.0.6.1
171−
172−* Test code: only include a Cookie header if there are cookies. Without this
173− patch, yesod-test cookie handling is broken.
174−
175−## 3.0.6
176−
177−* Add Cookie Handling to Network.Wai.Test [#356](https://github.com/yesodweb/wai/pull/356)
178−
179−## 3.0.5
180−
181−* add functions to extract authentication data from Authorization header [#352](add functions to extract authentication data from Authorization header #352)
182−
183−## 3.0.4.6
184−
185−* Access log sequence not valid [#336](https://github.com/yesodweb/wai/issues/336)
186−
187−## 3.0.4.5
188−
189−* Allow fast-logger 2.3
190−
191−## 3.0.4.3
192−
193−Test suite warning cleanup
194−
195−## 3.0.4.2
196−
197−Allow blaze-builder 0.4
198−
199−## 3.0.4.1
200−
201−Fix compilation failure on Windows [#321](https://github.com/yesodweb/wai/issues/321)
202−
203−## 3.0.4
204−
205−Add the `StreamFile` middleware.
206−
207−## 3.0.3
208−
209−Add the `AddHeaders` middleware.
wai-extra/LICENSE+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2010, Michael Snoyman. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-extra/Network/Wai/EventSource.hsdeleted−59
@@ -1,59 +0,0 @@
1−{-|
2− 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−-}
11−module Network.Wai.EventSource (
12− ServerEvent(..),
13− eventSourceAppChan,
14− eventSourceAppIO,
15− eventStreamAppRaw
16− ) where
17−
18−import Data.Function (fix)
19−import Control.Concurrent.Chan (Chan, dupChan, readChan)
20−import Control.Monad.IO.Class (liftIO)
21−import Network.HTTP.Types (status200, hContentType)
22−import Network.Wai (Application, responseStream)
23−
24−import Network.Wai.EventSource.EventStream
25−
26−-- | Make a new WAI EventSource application reading events from
27−-- the given channel.
28−eventSourceAppChan :: Chan ServerEvent -> Application
29−eventSourceAppChan chan req sendResponse = do
30− chan' <- liftIO $ dupChan chan
31− eventSourceAppIO (readChan chan') req sendResponse
32−
33−-- | Make a new WAI EventSource application reading events from
34−-- the given IO action.
35−eventSourceAppIO :: IO ServerEvent -> Application
36−eventSourceAppIO src _ sendResponse =
37− sendResponse $ responseStream
38− status200
39− [(hContentType, "text/event-stream")]
40− $ \sendChunk flush -> fix $ \loop -> do
41− se <- src
42− case eventToBuilder se of
43− Nothing -> return ()
44− Just b -> sendChunk b >> flush >> loop
45−
46−-- | Make a new WAI EventSource application with a handler that emits events.
47−--
48−-- @since 3.0.28
49−eventStreamAppRaw :: ((ServerEvent -> IO()) -> IO () -> IO ()) -> Application
50−eventStreamAppRaw handler _ sendResponse =
51− sendResponse $ responseStream
52− status200
53− [(hContentType, "text/event-stream")]
54− $ \sendChunk flush -> handler (sendEvent sendChunk) flush
55− where
56− sendEvent sendChunk event =
57− case eventToBuilder event of
58− Nothing -> return ()
59− Just b -> sendChunk b
wai-extra/Network/Wai/Handler/CGI.hs+73−90
@@ -1,4 +1,5 @@
1+{-# LANGUAGE OverloadedStrings #-}
1−{-# LANGUAGE RankNTypes, CPP #-}
2+{-# LANGUAGE RankNTypes #-}
2-- | Backend for Common Gateway Interface. Almost all users should use the
3-- | Backend for Common Gateway Interface. Almost all users should use the
3-- 'run' function.
4-- 'run' function.
4module Network.Wai.Handler.CGI
5module Network.Wai.Handler.CGI
@@ -9,9 +10,8 @@ module Network.Wai.Handler.CGI
9 ) where
10 ) where
10
11
11import Network.Wai
12import Network.Wai
12−import Network.Wai.Internal
13import Network.Socket (getAddrInfo, addrAddress)
13import Network.Socket (getAddrInfo, addrAddress)
14−import Data.IORef
14+import System.Environment (getEnvironment)
15import Data.Maybe (fromMaybe)
15import Data.Maybe (fromMaybe)
16import qualified Data.ByteString.Char8 as B
16import qualified Data.ByteString.Char8 as B
17import qualified Data.ByteString.Lazy as L
17import qualified Data.ByteString.Lazy as L
@@ -19,29 +19,19 @@ import Control.Arrow ((***))
19import Data.Char (toLower)
19import Data.Char (toLower)
20import qualified System.IO
20import qualified System.IO
21import qualified Data.String as String
21import qualified Data.String as String
22+import Data.Monoid (mconcat, mempty)
22−import Data.ByteString.Builder (byteString, toLazyByteString, char7, string8)
23+import Blaze.ByteString.Builder (fromByteString, toLazyByteString)
23−import Data.ByteString.Builder.Extra (flush)
24+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
25+import Data.Conduit.Blaze (builderToByteStringFlush)
26+import Control.Monad.IO.Class (liftIO)
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.Conduit as C
34−import Data.Function (fix)
35−import Control.Monad (unless, void)
36−
37−#if WINDOWS
38−import System.Environment (getEnvironment)
39−#else
40−import qualified System.Posix.Env.ByteString as Env
34+import qualified Data.Conduit.List as CL
41−
42−getEnvironment :: IO [(String, String)]
43−getEnvironment = map (B.unpack *** B.unpack) `fmap` Env.getEnvironment
44−#endif
45
35
46safeRead :: Read a => a -> String -> a
36safeRead :: Read a => a -> String -> a
47safeRead d s =
37safeRead d s =
@@ -76,7 +66,7 @@ runSendfile sf app = do
76-- stick with 'run' or 'runSendfile'.
66-- stick with 'run' or 'runSendfile'.
77runGeneric
67runGeneric
78 :: [(String, String)] -- ^ all variables
68 :: [(String, String)] -- ^ all variables
79− -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input
69+ -> (Int -> C.Source (C.ResourceT IO) B.ByteString) -- ^ responseBody of input
80 -> (B.ByteString -> IO ()) -- ^ destination for output
70 -> (B.ByteString -> IO ()) -- ^ destination for output
81 -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
71 -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?
82 -> Application
72 -> Application
@@ -85,6 +75,8 @@ runGeneric vars inputH outputH xsendfile app = do
85 let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
75 let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars
86 pinfo = lookup' "PATH_INFO" vars
76 pinfo = lookup' "PATH_INFO" vars
87 qstring = lookup' "QUERY_STRING" vars
77 qstring = lookup' "QUERY_STRING" vars
78+ servername = lookup' "SERVER_NAME" vars
79+ serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
88 contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
80 contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
89 remoteHost' =
81 remoteHost' =
90 case lookup "REMOTE_ADDR" vars of
82 case lookup "REMOTE_ADDR" vars of
@@ -98,81 +90,72 @@ runGeneric vars inputH outputH xsendfile app = do
98 "https" -> True
90 "https" -> True
99 _ -> False
91 _ -> False
100 addrs <- getAddrInfo Nothing (Just remoteHost') Nothing
92 addrs <- getAddrInfo Nothing (Just remoteHost') Nothing
101− requestBody' <- inputH contentLength
102 let addr =
93 let addr =
103 case addrs of
94 case addrs of
104 a:_ -> addrAddress a
95 a:_ -> addrAddress a
105 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
96 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'
106− reqHeaders = map (cleanupVarName *** B.pack) vars
97+ C.runResourceT $ do
107− env = Request
98+ let env = Request
108− { requestMethod = rmethod
99+ { requestMethod = rmethod
109− , rawPathInfo = B.pack pinfo
100+ , rawPathInfo = B.pack pinfo
110− , pathInfo = H.decodePathSegments $ B.pack pinfo
101+ , pathInfo = H.decodePathSegments $ B.pack pinfo
111− , rawQueryString = B.pack qstring
102+ , rawQueryString = B.pack qstring
112− , queryString = H.parseQuery $ B.pack qstring
103+ , queryString = H.parseQuery $ B.pack qstring
104+ , serverName = B.pack servername
105+ , serverPort = serverport
113− , requestHeaders = reqHeaders
106+ , requestHeaders = map (cleanupVarName *** B.pack) vars
114− , isSecure = isSecure'
107+ , isSecure = isSecure'
115− , remoteHost = addr
108+ , remoteHost = addr
116− , httpVersion = H.http11 -- FIXME
109+ , httpVersion = H.http11 -- FIXME
117− , requestBody = requestBody'
110+ , requestBody = inputH contentLength
118− , vault = mempty
111+ , vault = mempty
119− , requestBodyLength = KnownLength $ fromIntegral contentLength
120− , requestHeaderHost = lookup "host" reqHeaders
121− , requestHeaderRange = lookup hRange reqHeaders
122−#if MIN_VERSION_wai(3,2,0)
123− , requestHeaderReferer = lookup "referer" reqHeaders
124− , requestHeaderUserAgent = lookup "user-agent" reqHeaders
125−#endif
126− }
112+ }
127− void $ app env $ \res ->
113+ -- FIXME worry about exception?
114+ res <- app env
128 case (xsendfile, res) of
115 case (xsendfile, res) of
129− (Just sf, ResponseFile s hs fp Nothing) -> do
116+ (Just sf, ResponseFile s hs fp Nothing) ->
130− mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
117+ liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp
131− return ResponseReceived
132 _ -> do
118 _ -> do
133− let (s, hs, wb) = responseToStream res
119+ let (s, hs, b) = responseSource res
134− (blazeRecv, blazeFinish) <- Builder.newBuilderRecv Builder.defaultStrategy
135− wb $ \b -> do
136− let sendBuilder builder = do
137− popper <- blazeRecv builder
138− fix $ \loop -> do
139− bs <- popper
140− unless (B.null bs) $ do
141− outputH bs
142− loop
143− sendBuilder $ headers s hs `mappend` char7 '\n'
120+ src = CL.sourceList [C.Chunk $ headers s hs `mappend` fromChar '\n']
144− b sendBuilder (sendBuilder flush)
121+ `mappend` b
145− blazeFinish >>= maybe (return ()) outputH
122+ src C.$$ builderSink
146− return ResponseReceived
147 where
123 where
148 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
124 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))
149− status (Status i m) = (byteString "Status", mconcat
125+ status (Status i m) = (fromByteString "Status", mconcat
150− [ string8 $ show i
126+ [ fromString $ show i
151− , char7 ' '
127+ , fromChar ' '
152− , byteString m
128+ , fromByteString m
153 ])
129 ])
154− header' (x, y) = (byteString $ CI.original x, byteString y)
130+ header' (x, y) = (fromByteString $ CI.original x, fromByteString y)
155 header (x, y) = mconcat
131 header (x, y) = mconcat
156 [ x
132 [ x
157− , byteString ": "
133+ , fromByteString ": "
158 , y
134 , y
159− , char7 '\n'
135+ , fromChar '\n'
160 ]
136 ]
161 sfBuilder s hs sf fp = mconcat
137 sfBuilder s hs sf fp = mconcat
162 [ headers s hs
138 [ headers s hs
163− , header $ (byteString sf, string8 fp)
139+ , header $ (fromByteString sf, fromString fp)
164− , char7 '\n'
140+ , fromChar '\n'
165− , byteString sf
141+ , fromByteString sf
166− , byteString " not supported"
142+ , fromByteString " not supported"
167 ]
143 ]
144+ bsSink = C.NeedInput push (return ())
145+ push (C.Chunk bs) = C.PipeM (do
146+ liftIO $ outputH bs
147+ return bsSink) (return ())
148+ -- FIXME actually flush?
149+ push C.Flush = bsSink
150+ builderSink = builderToByteStringFlush C.=$ bsSink
168 fixHeaders h =
151 fixHeaders h =
169− case lookup hContentType h of
152+ case lookup "content-type" h of
170− Nothing -> (hContentType, "text/html; charset=utf-8") : h
153+ Nothing -> ("Content-Type", "text/html; charset=utf-8") : h
171 Just _ -> h
154 Just _ -> h
172
155
173cleanupVarName :: String -> CI.CI B.ByteString
156cleanupVarName :: String -> CI.CI B.ByteString
174−cleanupVarName "CONTENT_TYPE" = hContentType
157+cleanupVarName "CONTENT_TYPE" = "Content-Type"
175−cleanupVarName "CONTENT_LENGTH" = hContentLength
158+cleanupVarName "CONTENT_LENGTH" = "Content-Length"
176cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
159cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
177cleanupVarName s =
160cleanupVarName s =
178 case s of
161 case s of
@@ -183,19 +166,19 @@ cleanupVarName s =
183 helper' (x:rest) = toLower x : helper' rest
166 helper' (x:rest) = toLower x : helper' rest
184 helper' [] = []
167 helper' [] = []
185
168
186−requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString)
169+requestBodyHandle :: Handle -> Int -> C.Source (C.ResourceT IO) B.ByteString
187requestBodyHandle h = requestBodyFunc $ \i -> do
170requestBodyHandle h = requestBodyFunc $ \i -> do
188 bs <- B.hGet h i
171 bs <- B.hGet h i
189 return $ if B.null bs then Nothing else Just bs
172 return $ if B.null bs then Nothing else Just bs
190
173
191−requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString)
174+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> C.Source (C.ResourceT IO) B.ByteString
192−requestBodyFunc get count0 = do
175+requestBodyFunc get count0 =
193− ref <- newIORef count0
176+ C.sourceState count0 pull
194− return $ do
177+ where
195− count <- readIORef ref
178+ pull 0 = return C.StateClosed
196− if count <= 0
179+ pull count = do
197− then return B.empty
198− else do
199− mbs <- get $ min count defaultChunkSize
180+ mbs <- liftIO $ get $ min count defaultChunkSize
200− writeIORef ref $ count - maybe 0 B.length mbs
181+ let count' = count - maybe 0 B.length mbs
201− return $ fromMaybe B.empty mbs
182+ return $ case mbs of
183+ Nothing -> C.StateClosed
184+ Just bs -> C.StateOpen count' bs
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.hsdeleted−24
@@ -1,24 +0,0 @@
1−-- |
2−--
3−-- Since 3.0.3
4−module Network.Wai.Middleware.AddHeaders
5− ( addHeaders
6− ) where
7−
8−import Network.HTTP.Types (Header)
9−import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)
10−import Network.Wai.Internal (Response(..))
11−import Data.ByteString (ByteString)
12−
13−import qualified Data.CaseInsensitive as CI
14−import Control.Arrow (first)
15−
16−addHeaders :: [(ByteString, ByteString)] -> Middleware
17−-- ^ Prepend a list of headers without any checks
18−--
19−-- Since 3.0.3
20−
21−addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h)
22−
23−addHeaders' :: [Header] -> Response -> Response
24−addHeaders' h = mapResponseHeaders (\hs -> h ++ hs)
wai-extra/Network/Wai/Middleware/Approot.hsdeleted−121
@@ -1,121 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−-- | Middleware for establishing the root of the application.
3−--
4−-- Many application need the ability to create URLs referring back to the
5−-- application itself. For example: generate RSS feeds or sitemaps, giving
6−-- users copy-paste links, or sending emails. In many cases, the approot can be
7−-- determined correctly from the request headers. However, some things can
8−-- prevent this, especially reverse proxies. This module provides multiple ways
9−-- of configuring approot discovery, and functions for applications to get that
10−-- approot.
11−--
12−-- Approots are structured such that they can be prepended to a string such as
13−-- @/foo/bar?baz=bin@. For example, if your application is hosted on
14−-- example.com using HTTPS, the approot would be @https://example.com@. Note
15−-- the lack of a trailing slash.
16−module Network.Wai.Middleware.Approot
17− ( -- * Middleware
18− approotMiddleware
19− -- * Common providers
20− , envFallback
21− , envFallbackNamed
22− , hardcoded
23− , fromRequest
24− -- * Functions for applications
25− , getApproot
26− , getApprootMay
27− ) where
28−
29−import Control.Exception (Exception, throw)
30−import Data.ByteString (ByteString)
31−import qualified Data.ByteString.Char8 as S8
32−import Data.Maybe (fromMaybe)
33−import Data.Typeable (Typeable)
34−import qualified Data.Vault.Lazy as V
35−import Network.Wai (Request, vault, Middleware)
36−import Network.Wai.Request (guessApproot)
37−import System.Environment (getEnvironment)
38−import System.IO.Unsafe (unsafePerformIO)
39−
40−approotKey :: V.Key ByteString
41−approotKey = unsafePerformIO V.newKey
42−{-# NOINLINE approotKey #-}
43−
44−-- | The most generic version of the middleware, allowing you to provide a
45−-- function to get the approot for each request. For many use cases, one of the
46−-- helper functions provided by this module will give the necessary
47−-- functionality more conveniently.
48−--
49−-- Since 3.0.7
50−approotMiddleware :: (Request -> IO ByteString) -- ^ get the approot
51− -> Middleware
52−approotMiddleware getRoot app req respond = do
53− ar <- getRoot req
54− let req' = req { vault = V.insert approotKey ar $ vault req }
55− app req' respond
56−
57−-- | Same as @'envFallbackNamed' "APPROOT"@.
58−--
59−-- The environment variable @APPROOT@ is used by Keter, School of Haskell, and yesod-devel.
60−--
61−-- Since 3.0.7
62−envFallback :: IO Middleware
63−envFallback = envFallbackNamed "APPROOT"
64−
65−-- | Produce a middleware that takes the approot from the given environment
66−-- variable, falling back to the behavior of 'fromRequest' if the variable is
67−-- not set.
68−--
69−-- Since 3.0.7
70−envFallbackNamed :: String -> IO Middleware
71−envFallbackNamed name = do
72− env <- getEnvironment
73− case lookup name env of
74− Just s -> return $ hardcoded $ S8.pack s
75− Nothing -> return fromRequest
76−
77−-- | Hard-code the given value as the approot.
78−--
79−-- Since 3.0.7
80−hardcoded :: ByteString -> Middleware
81−hardcoded ar = approotMiddleware (const $ return ar)
82−
83−-- | Get the approot by analyzing the request. This is not a full-proof
84−-- approach, but in many common cases will work. Situations that can break this
85−-- are:
86−--
87−-- * Requests which spoof headers and imply the connection is over HTTPS
88−--
89−-- * Reverse proxies that change ports in surprising ways
90−--
91−-- * Invalid Host headers
92−--
93−-- * Reverse proxies which modify the path info
94−--
95−-- Normally trusting headers in this way is insecure, however in the case of
96−-- approot, the worst that can happen is that the client will get an incorrect
97−-- URL. If you are relying on the approot for some security-sensitive purpose,
98−-- it is highly recommended to use @hardcoded@, which cannot be spoofed.
99−--
100−-- Since 3.0.7
101−fromRequest :: Middleware
102−fromRequest = approotMiddleware (return . guessApproot)
103−
104−data ApprootMiddlewareNotSetup = ApprootMiddlewareNotSetup
105− deriving (Show, Typeable)
106−instance Exception ApprootMiddlewareNotSetup
107−
108−-- | Get the approot set by the middleware. If the middleware is not in use,
109−-- then this function will return an exception. For a total version of the
110−-- function, see 'getApprootMay'.
111−--
112−-- Since 3.0.7
113−getApproot :: Request -> ByteString
114−getApproot = fromMaybe (throw ApprootMiddlewareNotSetup) . getApprootMay
115−
116−-- | A total version of 'getApproot', which returns 'Nothing' if the middleware
117−-- is not in use.
118−--
119−-- Since 3.0.7
120−getApprootMay :: Request -> Maybe ByteString
121−getApprootMay req = V.lookup approotKey $ vault req
wai-extra/Network/Wai/Middleware/Autohead.hs+9−8
@@ -1,17 +1,18 @@
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
12−autohead app req sendResponse
10+autohead app req
11+ | requestMethod req == "HEAD" = do
13− | requestMethod req == "HEAD" = app req { requestMethod = "GET" } $ \res -> do
12+ res <- app req { requestMethod = "GET" }
14− let (s, hs, _) = responseToStream res
13+ case res of
15− sendResponse $ responseBuilder s hs mempty
14+ ResponseFile s hs _ _ -> return $ ResponseBuilder s hs mempty
15+ ResponseBuilder s hs _ -> return $ ResponseBuilder s hs mempty
16+ ResponseSource s hs _ -> return $ ResponseBuilder s hs mempty
16− | otherwise = app req sendResponse
17+ | otherwise = app req
17
18
wai-extra/Network/Wai/Middleware/CleanPath.hs+6−8
@@ -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,22 +6,20 @@ 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
17 -> ([Text] -> Application)
15 -> ([Text] -> Application)
18 -> Application
16 -> Application
19−cleanPath splitter prefix app env sendResponse =
17+cleanPath splitter prefix app env =
20 case splitter $ pathInfo env of
18 case splitter $ pathInfo env of
21− Right pieces -> app pieces env sendResponse
19+ Right pieces -> app pieces env
22− Left p -> sendResponse
20+ Left p -> return
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.hsdeleted−37
@@ -1,37 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-- | Redirect non-SSL requests to https
3−--
4−-- Since 3.0.7
5−module Network.Wai.Middleware.ForceSSL
6− ( forceSSL
7− ) where
8−
9−import Network.Wai
10−import Network.Wai.Request
11−
12−#if __GLASGOW_HASKELL__ < 710
13−import Control.Applicative ((<$>))
14−import Data.Monoid (mempty)
15−#endif
16−
17−import Data.Monoid ((<>))
18−import Network.HTTP.Types (hLocation, methodGet, status301, status307)
19−
20−-- | For requests that don't appear secure, redirect to https
21−--
22−-- Since 3.0.7
23−forceSSL :: Middleware
24−forceSSL app req sendResponse =
25− case (appearsSecure req, redirectResponse req) of
26− (False, Just resp) -> sendResponse resp
27− _ -> app req sendResponse
28−
29−redirectResponse :: Request -> Maybe Response
30−redirectResponse req = do
31− host <- requestHeaderHost req
32− return $ responseBuilder status [(hLocation, location host)] mempty
33− where
34− location h = "https://" <> h <> rawPathInfo req <> rawQueryString req
35− status
36− | requestMethod req == methodGet = status301
37− | otherwise = status307
wai-extra/Network/Wai/Middleware/Gzip.hs+49−142
@@ -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
@@ -17,155 +19,85 @@ module Network.Wai.Middleware.Gzip
17 , GzipSettings
19 , GzipSettings
18 , gzipFiles
20 , gzipFiles
19 , GzipFiles (..)
21 , GzipFiles (..)
20− , gzipCheckMime
21 , def
22 , def
22 , defaultCheckMime
23 , defaultCheckMime
23 ) where
24 ) where
24
25
25import Network.Wai
26import Network.Wai
26−import Data.Maybe (fromMaybe, isJust)
27+import Data.Maybe (fromMaybe)
27import qualified Data.ByteString.Char8 as S8
28import qualified Data.ByteString.Char8 as S8
28import qualified Data.ByteString as S
29import qualified Data.ByteString as S
29−import Data.Default.Class
30+import Data.Default
30−import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent
31+import Network.HTTP.Types (Status, Header)
31− , hContentType, hContentLength)
32+import Control.Monad.IO.Class (liftIO)
32import System.Directory (doesFileExist, createDirectoryIfMissing)
33import System.Directory (doesFileExist, createDirectoryIfMissing)
33−import Data.ByteString.Builder (byteString)
34+import qualified Data.Conduit as C
35+import qualified Data.Conduit.Zlib as CZ
34−import qualified Data.ByteString.Builder.Extra as Blaze (flush)
36+import qualified Data.Conduit.Binary as CB
37+import qualified Data.Conduit.List as CL
38+import Data.Conduit.Blaze (builderToByteStringFlush)
39+import Blaze.ByteString.Builder (fromByteString)
35import Control.Exception (try, SomeException)
40import Control.Exception (try, SomeException)
36−import qualified Data.Set as Set
37−import Network.Wai.Header
38−import Network.Wai.Internal
39−import qualified Data.Streaming.ByteString.Builder as B
40−import qualified Data.Streaming.Zlib as Z
41−import Control.Monad (unless)
42−import Data.Function (fix)
43−import Control.Exception (throwIO)
44−import qualified System.IO as IO
45−import Data.ByteString.Lazy.Internal (defaultChunkSize)
46−import Data.Word8 (_semicolon)
47
41
48data GzipSettings = GzipSettings
42data GzipSettings = GzipSettings
49 { gzipFiles :: GzipFiles
43 { gzipFiles :: GzipFiles
50 , gzipCheckMime :: S.ByteString -> Bool
44 , gzipCheckMime :: S.ByteString -> Bool
51 }
45 }
52
46
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
47+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)
48 deriving (Show, Eq, Read)
66
49
67−-- | Use default MIME settings; /do not/ compress files.
68instance Default GzipSettings where
50instance Default GzipSettings where
69 def = GzipSettings GzipIgnore defaultCheckMime
51 def = GzipSettings GzipIgnore defaultCheckMime
70
52
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
53defaultCheckMime :: S.ByteString -> Bool
75−defaultCheckMime bs =
54+defaultCheckMime = S8.isPrefixOf "text/"
76− S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress
77− where
78− bs' = fst $ S.break (== _semicolon) bs
79− toCompress = Set.fromList
80− [ "application/json"
81− , "application/javascript"
82− , "application/ecmascript"
83− , "image/x-icon"
84− ]
85
55
86-- | Use gzip to compress the body of the response.
56-- | Use gzip to compress the body of the response.
87--
57--
88-- Analyzes the \"Accept-Encoding\" header from the client to determine
58-- Analyzes the \"Accept-Encoding\" header from the client to determine
89-- if gzip is supported.
59-- if gzip is supported.
90--
60--
91−-- File responses will be compressed according to the 'GzipFiles' setting.
61+-- Possible future enhancements:
92--
62--
93−-- Will only be applied based on the 'gzipCheckMime' setting. For default
63+-- * Only compress if the response is above a certain size.
94−-- behavior, see 'defaultCheckMime'.
95gzip :: GzipSettings -> Middleware
64gzip :: GzipSettings -> Middleware
96−gzip set app env sendResponse = app env $ \res ->
65+gzip set app env = do
66+ res <- app env
97 case res of
67 case res of
98− ResponseRaw{} -> sendResponse res
99− ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res
68+ ResponseFile{} | gzipFiles set == GzipIgnore -> return res
100− _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res)
69+ _ -> if "gzip" `elem` enc && not isMSIE6
101 then
70 then
102− let runAction x = case x of
71+ 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) ->
72+ (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
112− case lookup hContentType hs of
73+ case lookup "content-type" hs of
113− Just m
74+ Just m
114− | gzipCheckMime set m -> compressFile s hs file cache sendResponse
75+ | gzipCheckMime set m -> liftIO $ compressFile s hs file cache
115− _ -> sendResponse res
76+ _ -> return res
116− (ResponseFile {}, GzipIgnore) -> sendResponse res
117− _ -> compressE set res sendResponse
77+ _ -> return $ compressE set res
118− in runAction (res, gzipFiles set)
119− else sendResponse res
78+ else return res
120 where
79 where
121 enc = fromMaybe [] $ (splitCommas . S8.unpack)
80 enc = fromMaybe [] $ (splitCommas . S8.unpack)
122 `fmap` lookup "Accept-Encoding" (requestHeaders env)
81 `fmap` lookup "Accept-Encoding" (requestHeaders env)
123− ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env
82+ ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env
124 isMSIE6 = "MSIE 6" `S.isInfixOf` ua
83 isMSIE6 = "MSIE 6" `S.isInfixOf` ua
125− isEncoded res = isJust $ lookup hContentEncoding $ 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
84
137−compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a
85+compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response
138−compressFile s hs file cache sendResponse = do
86+compressFile s hs file cache = do
139 e <- doesFileExist tmpfile
87 e <- doesFileExist tmpfile
140 if e
88 if e
141 then onSucc
89 then onSucc
142 else do
90 else do
143 createDirectoryIfMissing True cache
91 createDirectoryIfMissing True cache
144− x <- try $
92+ x <-
145− IO.withBinaryFile file IO.ReadMode $ \inH ->
93+ try $ C.runResourceT $ CB.sourceFile file
146− IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do
94+ C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile
147− deflate <- Z.initDeflate 7 $ Z.WindowBits 31
148− -- FIXME this code should write to a temporary file, then
149− -- rename to the final file
150− let goPopper popper = fix $ \loop -> do
151− res <- popper
152− case res of
153− Z.PRDone -> return ()
154− Z.PRNext bs -> do
155− S.hPut outH bs
156− loop
157− Z.PRError ex -> throwIO ex
158− fix $ \loop -> do
159− bs <- S.hGetSome inH defaultChunkSize
160− unless (S.null bs) $ do
161− Z.feedDeflate deflate bs >>= goPopper
162− loop
163− goPopper $ Z.finishDeflate deflate
164− either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!
95+ either onErr (const onSucc) x
165 where
96 where
166− onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing
97+ onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing
167
98
99+ onErr :: SomeException -> IO Response
168− onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message
100+ onErr = const $ return $ ResponseFile s hs file Nothing -- FIXME log the error message
169
101
170 tmpfile = cache ++ '/' : map safe file
102 tmpfile = cache ++ '/' : map safe file
171 safe c
103 safe c
@@ -178,50 +110,25 @@ compressFile s hs file cache sendResponse = do
178
110
179compressE :: GzipSettings
111compressE :: GzipSettings
180 -> Response
112 -> Response
181− -> (Response -> IO a)
113+ -> Response
182− -> IO a
183−compressE set res sendResponse =
114+compressE set res =
184− case lookup hContentType hs of
115+ case lookup "content-type" hs of
185 Just m | gzipCheckMime set m ->
116 Just m | gzipCheckMime set m ->
186 let hs' = fixHeaders hs
117 let hs' = fixHeaders hs
187− in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do
118+ in ResponseSource s hs' $ b C.$= builderToByteStringFlush
188− (blazeRecv, _) <- B.newBuilderRecv B.defaultStrategy
189− deflate <- Z.initDeflate 1 (Z.WindowBits 31)
119+ C.$= CZ.compressFlush 1 (CZ.WindowBits 31)
190− let sendBuilder builder = do
120+ C.$= CL.map (fmap fromByteString)
191− popper <- blazeRecv builder
192− fix $ \loop -> do
193− bs <- popper
194− unless (S.null bs) $ do
195− sendBS bs
196− loop
197− sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper
198− flushBuilder = do
199− sendBuilder Blaze.flush
200− deflatePopper $ Z.flushDeflate deflate
201− flush
202− deflatePopper popper = fix $ \loop -> do
203− result <- popper
204− case result of
205− Z.PRDone -> return ()
206− Z.PRNext bs' -> do
207− sendChunk $ byteString bs'
208− loop
209− Z.PRError e -> throwIO e
210−
211− body sendBuilder flushBuilder
212− sendBuilder Blaze.flush
213− deflatePopper $ Z.finishDeflate deflate
214− _ -> sendResponse res
121+ _ -> res
215 where
122 where
216− (s, hs, wb) = responseToStream res
123+ (s, hs, b) = responseSource res
217
124
218-- Remove Content-Length header, since we will certainly have a
125-- Remove Content-Length header, since we will certainly have a
219-- different length after gzip compression.
126-- different length after gzip compression.
220fixHeaders :: [Header] -> [Header]
127fixHeaders :: [Header] -> [Header]
221fixHeaders =
128fixHeaders =
222− ((hContentEncoding, "gzip") :) . filter notLength
129+ (("Content-Encoding", "gzip") :) . filter notLength
223 where
130 where
224− notLength (x, _) = x /= hContentLength
131+ notLength (x, _) = x /= "content-length"
225
132
226splitCommas :: String -> [String]
133splitCommas :: String -> [String]
227splitCommas [] = []
134splitCommas [] = []
wai-extra/Network/Wai/Middleware/HttpAuth.hsdeleted−132
@@ -1,132 +0,0 @@
1−{-# LANGUAGE RecordWildCards, TupleSections, CPP #-}
2−-- | Implements HTTP Basic Authentication.
3−--
4−-- This module may add digest authentication in the future.
5−module Network.Wai.Middleware.HttpAuth
6− ( -- * Middleware
7− basicAuth
8− , basicAuth'
9− , CheckCreds
10− , AuthSettings
11− , authRealm
12− , authOnNoAuth
13− , authIsProtected
14− -- * Helping functions
15− , extractBasicAuth
16− , extractBearerAuth
17− ) where
18−#if __GLASGOW_HASKELL__ < 710
19−import Control.Applicative
20−#endif
21−import Data.ByteString (ByteString)
22−import Data.ByteString.Base64 (decodeLenient)
23−import Data.String (IsString (..))
24−import Data.Word8 (isSpace, _colon, toLower)
25−import Network.HTTP.Types (status401, hContentType, hAuthorization)
26−import Network.Wai
27−
28−import qualified Data.ByteString as S
29−
30−
31−-- | Check if a given username and password is valid.
32−type CheckCreds = ByteString
33− -> ByteString
34− -> IO Bool
35−
36−-- | Perform basic authentication.
37−--
38−-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
39−--
40−-- @since 1.3.4
41−basicAuth :: CheckCreds
42− -> AuthSettings
43− -> 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
53− isProtected <- authIsProtected req
54− allowed <- if isProtected then check else return True
55− if allowed
56− then app req sendResponse
57− else authOnNoAuth authRealm req sendResponse
58− where
59− check =
60− case (lookup hAuthorization $ requestHeaders req)
61− >>= extractBasicAuth of
62− Nothing -> return False
63− Just (username, password) -> checkCreds req username password
64−
65−-- | Basic authentication settings. This value is an instance of
66−-- @IsString@, so the recommended approach to create a value is to
67−-- provide a string literal (which will be the realm) and then
68−-- overriding individual fields.
69−--
70−-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
71−--
72−-- @since 1.3.4
73−data AuthSettings = AuthSettings
74− { authRealm :: !ByteString
75− -- ^
76− --
77− -- @since 1.3.4
78− , authOnNoAuth :: !(ByteString -> Application)
79− -- ^ Takes the realm and returns an appropriate 401 response when
80− -- authentication is not provided.
81− --
82− -- @since 1.3.4
83− , authIsProtected :: !(Request -> IO Bool)
84− -- ^ Determine if access to the requested resource is restricted.
85− --
86− -- Default: always returns @True@.
87− --
88− -- @since 1.3.4
89− }
90−
91−instance IsString AuthSettings where
92− fromString s = AuthSettings
93− { authRealm = fromString s
94− , authOnNoAuth = \realm _req f -> f $ responseLBS
95− status401
96− [ (hContentType, "text/plain")
97− , ("WWW-Authenticate", S.concat
98− [ "Basic realm=\""
99− , realm
100− , "\""
101− ])
102− ]
103− "Basic authentication is required"
104− , authIsProtected = const $ return True
105− }
106−
107−-- | Extract basic authentication data from usually __Authorization__
108−-- header value. Returns username and password
109−--
110−-- @since 3.0.5
111−extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)
112−extractBasicAuth bs =
113− let (x, y) = S.break isSpace bs
114− in if S.map toLower x == "basic"
115− then extract $ S.dropWhile isSpace y
116− else Nothing
117− where
118− extract encoded =
119− let raw = decodeLenient encoded
120− (username, password') = S.break (== _colon) raw
121− in ((username,) . snd) <$> S.uncons password'
122−
123−-- | Extract bearer authentication data from __Authorization__ header
124−-- value. Returns bearer token
125−--
126−-- @since 3.0.5
127−extractBearerAuth :: ByteString -> Maybe ByteString
128−extractBearerAuth bs =
129− let (x, y) = S.break isSpace bs
130− in if S.map toLower x == "bearer"
131− then Just $ S.dropWhile isSpace y
132− else Nothing
wai-extra/Network/Wai/Middleware/Jsonp.hs+30−31
@@ -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
@@ -15,29 +16,27 @@
15module Network.Wai.Middleware.Jsonp (jsonp) where
16module Network.Wai.Middleware.Jsonp (jsonp) where
16
17
17import Network.Wai
18import Network.Wai
18−import Network.Wai.Internal
19import Data.ByteString (ByteString)
19import Data.ByteString (ByteString)
20import qualified Data.ByteString.Char8 as B8
20import qualified Data.ByteString.Char8 as B8
21−import Data.ByteString.Builder.Extra (byteStringCopy)
21+import Blaze.ByteString.Builder (copyByteString)
22−import Data.ByteString.Builder (char7)
22+import Blaze.ByteString.Builder.Char8 (fromChar)
23−#if __GLASGOW_HASKELL__ < 710
24import Data.Monoid (mappend)
23import Data.Monoid (mappend)
25−#endif
26import Control.Monad (join)
24import Control.Monad (join)
27import Data.Maybe (fromMaybe)
25import Data.Maybe (fromMaybe)
28import qualified Data.ByteString as S
26import qualified Data.ByteString as S
29−import Network.HTTP.Types (hAccept, hContentType)
27+import qualified Data.Conduit as C
28+import qualified Data.Conduit.List as CL
30
29
31-- | Wrap json responses in a jsonp callback.
30-- | Wrap json responses in a jsonp callback.
32--
31--
33-- Basically, if the user requested a \"text\/javascript\" and supplied a
32-- Basically, if the user requested a \"text\/javascript\" and supplied a
34-- \"callback\" GET parameter, ask the application for an
33-- \"callback\" GET parameter, ask the application for an
35−-- \"application/json\" response, then convert that into a JSONP response,
34+-- \"application/json\" response, then convern that into a JSONP response,
36-- having a content type of \"text\/javascript\" and calling the specified
35-- having a content type of \"text\/javascript\" and calling the specified
37-- callback function.
36-- callback function.
38jsonp :: Middleware
37jsonp :: Middleware
39−jsonp app env sendResponse = do
38+jsonp app env = do
40− let accept = fromMaybe B8.empty $ lookup hAccept $ requestHeaders env
39+ let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env
41 let callback :: Maybe B8.ByteString
40 let callback :: Maybe B8.ByteString
42 callback =
41 callback =
43 if B8.pack "text/javascript" `B8.isInfixOf` accept
42 if B8.pack "text/javascript" `B8.isInfixOf` accept
@@ -47,43 +46,43 @@ jsonp app env sendResponse = do
47 case callback of
46 case callback of
48 Nothing -> env
47 Nothing -> env
49 Just _ -> env
48 Just _ -> env
50− { requestHeaders = changeVal hAccept
49+ { requestHeaders = changeVal "Accept"
51 "application/json"
50 "application/json"
52 $ requestHeaders env
51 $ requestHeaders env
53 }
52 }
54− app env' $ \res ->
53+ res <- app env'
55− case callback of
54+ case callback of
56− Nothing -> sendResponse res
55+ Nothing -> return res
57− Just c -> go c res
56+ Just c -> go c res
58 where
57 where
59 go c r@(ResponseBuilder s hs b) =
58 go c r@(ResponseBuilder s hs b) =
60− sendResponse $ case checkJSON hs of
59+ case checkJSON hs of
61− Nothing -> r
60+ Nothing -> return r
62− Just hs' -> responseBuilder s hs' $
61+ Just hs' -> return $ ResponseBuilder s hs' $
63− byteStringCopy c
62+ copyByteString c
64− `mappend` char7 '('
63+ `mappend` fromChar '('
65 `mappend` b
64 `mappend` b
66− `mappend` char7 ')'
65+ `mappend` fromChar ')'
67 go c r =
66 go c r =
68 case checkJSON hs of
67 case checkJSON hs of
69− Just hs' -> addCallback c s hs' wb
68+ Just hs' -> addCallback c s hs' b
70− Nothing -> sendResponse r
69+ Nothing -> return r
71 where
70 where
72− (s, hs, wb) = responseToStream r
71+ (s, hs, b) = responseSource r
73
72
74 checkJSON hs =
73 checkJSON hs =
75− case lookup hContentType hs of
74+ case lookup "Content-Type" hs of
76 Just x
75 Just x
77 | B8.pack "application/json" `S.isPrefixOf` x ->
76 | B8.pack "application/json" `S.isPrefixOf` x ->
78 Just $ fixHeaders hs
77 Just $ fixHeaders hs
79 _ -> Nothing
78 _ -> Nothing
80− fixHeaders = changeVal hContentType "text/javascript"
79+ fixHeaders = changeVal "Content-Type" "text/javascript"
81
80
82− addCallback cb s hs wb =
81+ addCallback cb s hs b =
83− wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do
82+ return $ ResponseSource s hs $
84− sendChunk $ byteStringCopy cb `mappend` char7 '('
83+ CL.sourceList [C.Chunk $ copyByteString cb `mappend` fromChar '(']
85− _ <- body sendChunk flush
84+ `mappend` b
86− sendChunk $ char7 ')'
85+ `mappend` CL.sourceList [C.Chunk $ fromChar ')']
87
86
88changeVal :: Eq a
87changeVal :: Eq a
89 => a
88 => a
wai-extra/Network/Wai/Middleware/Local.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-- | Only allow local connections.
3−--
4−module Network.Wai.Middleware.Local
5− ( local
6− ) where
7−
8−import Network.Wai (Middleware,remoteHost, Response)
9−import Network.Socket (SockAddr(..))
10−
11−-- | This middleware rejects non-local connections with a specific response.
12−-- It is useful when supporting web-based local applications, which would
13−-- typically want to reject external connections.
14−
15−local :: Response -> Middleware
16−local resp f r k = case remoteHost r of
17− SockAddrInet _ h | h == fromIntegral home
18− -> f r k
19−#if !defined(mingw32_HOST_OS) && !defined(_WIN32)
20− SockAddrUnix _ -> f r k
21−#endif
22− _ -> k $ resp
23− where
24− home :: Integer
25− home = 127 + (256 * 256 * 256) * 1
26−
wai-extra/Network/Wai/Middleware/MethodOverride.hs+4−8
@@ -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,16 +6,11 @@ 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−--
10−-- This middleware only applies when the initial request method is POST.
11−-- Allows submitting of normal HTML forms, without worries of semantic
12−-- mismatches with the HTTP spec.
13methodOverride :: Middleware
9methodOverride :: Middleware
14methodOverride app req =
10methodOverride app req =
15 app req'
11 app req'
16 where
12 where
17 req' =
13 req' =
18− case (requestMethod req, join $ lookup "_method" $ queryString req) of
14+ case join $ lookup "_method" $ queryString req of
15+ Nothing -> req
19− ("POST", Just m) -> req { requestMethod = m }
16+ Just m -> req { requestMethod = m }
20− _ -> req
wai-extra/Network/Wai/Middleware/MethodOverridePost.hsdeleted−44
@@ -1,44 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-----------------------------------------------------------------
3−-- | Module : Network.Wai.Middleware.MethodOverridePost
4−--
5−-- Changes the request-method via first post-parameter _method.
6−-----------------------------------------------------------------
7−module Network.Wai.Middleware.MethodOverridePost
8− ( methodOverridePost
9− ) where
10−
11−import Network.Wai
12−import Network.HTTP.Types (parseQuery, hContentType)
13−
14−#if __GLASGOW_HASKELL__ < 710
15−import Data.Monoid (mconcat, mempty)
16−#endif
17−import Data.IORef
18−import Data.ByteString.Lazy (toChunks)
19−
20−-- | Allows overriding of the HTTP request method via the _method post string parameter.
21−--
22−-- * Looks for the Content-Type requestHeader.
23−--
24−-- * If the header is set to application/x-www-form-urlencoded
25−-- and the first POST parameter is _method
26−-- then it changes the request-method to the value of that
27−-- parameter.
28−--
29−-- * This middleware only applies when the initial request method is POST.
30−--
31−methodOverridePost :: Middleware
32−methodOverridePost app req send =
33− case (requestMethod req, lookup hContentType (requestHeaders req)) of
34− ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send
35− _ -> app req send
36−
37−setPost :: Request -> IO Request
38−setPost req = do
39− body <- (mconcat . toChunks) `fmap` lazyRequestBody req
40− ref <- newIORef body
41− let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)
42− case parseQuery body of
43− (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod}
44− _ -> return $ req {requestBody = rb}
wai-extra/Network/Wai/Middleware/RequestLogger.hs+140−310
@@ -1,207 +1,95 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE OverloadedStrings #-}
2−-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should
3−-- not use CPP.
4module Network.Wai.Middleware.RequestLogger
2module Network.Wai.Middleware.RequestLogger
5− ( -- * Basic stdout logging
6− logStdout
3+ ( logStdout
4+ , logCallback
7 , logStdoutDev
5 , logStdoutDev
8− -- * Create more versions
6+ , logCallbackDev
9− , mkRequestLogger
7+ -- * Deprecated
10− , RequestLoggerSettings
8+ , logHandle
11− , outputFormat
9+ , logHandleDev
12− , autoFlush
13− , destination
14− , OutputFormat (..)
15− , OutputFormatter
16− , OutputFormatterWithDetails
17− , OutputFormatterWithDetailsAndHeaders
18− , Destination (..)
19− , Callback
20− , IPAddrSource (..)
21 ) where
10 ) where
22
11
23−import System.IO (Handle, hFlush, stdout)
12+import System.IO (stdout, hFlush)
24−import qualified Data.ByteString.Builder as B (Builder, byteString)
25import qualified Data.ByteString as BS
13import qualified Data.ByteString as BS
26−import Data.ByteString.Char8 (pack)
14+import Data.ByteString.Char8 (pack, unpack)
27−import Control.Monad (when)
28import Control.Monad.IO.Class (liftIO)
15import Control.Monad.IO.Class (liftIO)
29−import Network.Wai
16+import Network.Wai (Request(..), Middleware, responseStatus, Response)
30− ( Request(..), requestBodyLength, RequestBodyLength(..)
31− , Middleware
32− , Response, responseStatus, responseHeaders
33− )
34import System.Log.FastLogger
17import System.Log.FastLogger
35import Network.HTTP.Types as H
18import Network.HTTP.Types as H
36import Data.Maybe (fromMaybe)
19import Data.Maybe (fromMaybe)
37−import Data.Monoid (mconcat, (<>))
20+
38−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
39−import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File
21+import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
40− , getRequestBodyType)
41import qualified Data.ByteString.Lazy as LBS
22import qualified Data.ByteString.Lazy as LBS
23+
24+import qualified Data.Conduit as C
42−import qualified Data.ByteString.Char8 as S8
25+import qualified Data.Conduit.List as CL
26+
43import System.Console.ANSI
27import System.Console.ANSI
44import Data.IORef
28import Data.IORef
45import System.IO.Unsafe
29import System.IO.Unsafe
46−import Network.Wai.Internal (Response (..))
47−import Data.Default.Class (Default (def))
48−import Network.Wai.Logger
49−import Network.Wai.Middleware.RequestLogger.Internal
50−import Network.Wai.Header (contentLength)
51−import Data.Text.Encoding (decodeUtf8')
52−
53−data OutputFormat
54− = Apache IPAddrSource
55− | Detailed Bool -- ^ use colors?
56− | CustomOutputFormat OutputFormatter
57− | CustomOutputFormatWithDetails OutputFormatterWithDetails
58− | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders
59−
60−type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr
61−
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−
90−data Destination = Handle Handle
91− | Logger LoggerSet
92− | Callback Callback
93−
94−type Callback = LogStr -> IO ()
95−
96−-- | @RequestLoggerSettings@ is an instance of Default. See <https://hackage.haskell.org/package/data-default Data.Default> for more information.
97−--
98−-- @outputFormat@, @autoFlush@, and @destination@ are record fields
99−-- for the record type @RequestLoggerSettings@, so they can be used to
100−-- modify settings values using record syntax.
101−data RequestLoggerSettings = RequestLoggerSettings
102− {
103− -- | Default value: @Detailed@ @True@.
104− outputFormat :: OutputFormat
105− -- | Only applies when using the @Handle@ constructor for @destination@.
106− --
107− -- Default value: @True@.
108− , autoFlush :: Bool
109− -- | Default: @Handle@ @stdout@.
110− , destination :: Destination
111− }
112−
113−instance Default RequestLoggerSettings where
114− def = RequestLoggerSettings
115− { outputFormat = Detailed True
116− , autoFlush = True
117− , destination = Handle stdout
118− }
119−
120−mkRequestLogger :: RequestLoggerSettings -> IO Middleware
121−mkRequestLogger RequestLoggerSettings{..} = do
122− let (callback, flusher) =
123− case destination of
124− Handle h -> (BS.hPutStr h . logToByteString, when autoFlush (hFlush h))
125− Logger l -> (pushLogStr l, when autoFlush (flushLogStr l))
126− Callback c -> (c, return ())
127− callbackAndFlush str = callback str >> flusher
128− case outputFormat of
129− Apache ipsrc -> do
130− getdate <- getDateGetter flusher
131− apache <- initLogger ipsrc (LogCallback callback flusher) getdate
132− return $ apacheMiddleware apache
133− Detailed useColors -> detailedMiddleware callbackAndFlush useColors
134− 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
142− return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter
143−
144−apacheMiddleware :: ApacheLoggerActions -> Middleware
145−apacheMiddleware ala app req sendResponse = app req $ \res -> do
146− let msize = contentLength (responseHeaders res)
147− apacheLogger ala req (responseStatus res) msize
148− sendResponse res
149−
150−customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
151−customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do
152− date <- liftIO getdate
153− let msize = contentLength (responseHeaders res)
154− liftIO $ cb $ formatter date req (responseStatus res) msize
155− sendResponse res
156
30
157−customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware
31+logHandle :: (BS.ByteString -> IO ()) -> Middleware
158−customMiddlewareWithDetails cb getdate formatter app req sendResponse = do
32+logHandle = logCallback
159− (req', reqBody) <- getRequestBody req
33+{-# DEPRECATED logHandle "Please use logCallback instead." #-}
160− t0 <- getCurrentTime
34+logHandleDev :: (BS.ByteString -> IO ()) -> Middleware
161− app req' $ \res -> do
35+logHandleDev = logCallbackDev
162− t1 <- getCurrentTime
36+{-# DEPRECATED logHandleDev "Please use logCallbackDev instead." #-}
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
37
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.
38-- | Production request logger middleware.
192−--
39+-- 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
40logStdout :: Middleware
197−logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }
41+logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]
198
42
199-- | Development request logger middleware.
43-- | Development request logger middleware.
44+-- Implemented on top of "logCallbackDev", but prints to 'stdout'
200--
45--
201−-- This uses the 'Detailed' 'True' logging format and logs to 'stdout'.
46+-- Flushes 'stdout' on each request, which would be inefficient in production use.
202−{-# NOINLINE logStdoutDev #-}
47+-- Use "logStdout" in production.
203logStdoutDev :: Middleware
48logStdoutDev :: Middleware
49+logStdoutDev = logCallbackDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
50+
51+-- | Prints a message using the given callback function for each request.
52+-- Designed for fast production use at the expense of convenience.
53+-- In particular, no POST parameter information is currently given
54+--
55+-- This is lower-level - use "logStdout" unless you need this greater control
56+logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
57+ -> Middleware
58+logCallback cb app req = do
59+ rsp <- app req
60+ liftIO $ cb $ BS.concat
61+ [ requestMethod req
62+ , " "
63+ , rawPathInfo req
64+ , rawQueryString req
65+ , " "
66+ , "Accept: "
67+ , maybe "" toBS $ lookup "Accept" $ requestHeaders req
68+ , "\n"
69+ , "Status: "
70+ , statusBS rsp
71+ , " "
72+ , msgBS rsp
73+ ]
74+ return rsp
75+
76+toBS :: H.Ascii -> BS.ByteString
77+toBS = id
78+
79+-- no black or white which are expected to be existing terminal colors.
80+colors :: IORef [Color]
204−logStdoutDev = unsafePerformIO $ mkRequestLogger def
81+colors = unsafePerformIO $ newIORef [
82+ Red
83+ , Green
84+ , Yellow
85+ , Blue
86+ , Magenta
87+ , Cyan
88+ ]
89+
90+rotateColors :: [Color] -> ([Color], Color)
91+rotateColors [] = error "Impossible! There must be colors!"
92+rotateColors (c:cs) = (cs ++ [c], c)
205
93
206-- | Prints a message using the given callback function for each request.
94-- | Prints a message using the given callback function for each request.
207-- This is not for serious production use- it is inefficient.
95-- This is not for serious production use- it is inefficient.
@@ -211,148 +99,87 @@ logStdoutDev = unsafePerformIO $ mkRequestLogger def
211-- This meanst that you can accurately see the interleaving of requests.
99-- This meanst that you can accurately see the interleaving of requests.
212-- And if the app crashes you have still logged the request.
100-- And if the app crashes you have still logged the request.
213-- However, if you are simulating 10 simultaneous users you may find this confusing.
101-- However, if you are simulating 10 simultaneous users you may find this confusing.
102+-- The request and response are connected by color on Unix and also by the request path.
214--
103--
215−-- This is lower-level - use 'logStdoutDev' unless you need greater control.
104+-- This is lower-level - use "logStdoutDev" unless you need greater control.
216--
105--
217-- Example ouput:
106-- Example ouput:
218--
107--
219−-- > GET search
108+-- GET search
220−-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
109+-- Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
110+--
221−-- > Status: 200 OK 0.010555s
111+-- Status: 200 OK. search
222−-- >
112+--
223−-- > GET static/css/normalize.css
113+-- GET static/css/normalize.css
114+-- Accept: text/css,*/*;q=0.1
224−-- > Params: [("LXwioiBG","")]
115+-- GET [("LXwioiBG","")]
225−-- > Accept: text/css,*/*;q=0.1
116+--
226−-- > Status: 304 Not Modified 0.010555s
117+-- Status: 304 Not Modified. static/css/normalize.css
227−
118+logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
228−detailedMiddleware :: Callback -> Bool -> IO Middleware
229−detailedMiddleware cb useColors =
230− let (ansiColor, ansiMethod, ansiStatusCode) =
231− if useColors
232− then (ansiColor', ansiMethod', ansiStatusCode')
233− else (\_ t -> [t], (:[]), \_ t -> [t])
234−
235− in return $ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode
236−
237−ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
238−ansiColor' color bs =
239− [ pack $ setSGRCode [SetColor Foreground Dull color]
240− , bs
241− , pack $ setSGRCode [Reset]
242− ]
243−
244−-- | Tags http method with a unique color.
245−ansiMethod' :: BS.ByteString -> [BS.ByteString]
246−ansiMethod' m = case m of
247− "GET" -> ansiColor' Cyan m
248− "HEAD" -> ansiColor' Cyan m
249− "PUT" -> ansiColor' Green m
250− "POST" -> ansiColor' Yellow m
251− "DELETE" -> ansiColor' Red m
252− _ -> ansiColor' Magenta m
253−
254−ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
255−ansiStatusCode' c t = case S8.take 1 c of
256− "2" -> ansiColor' Green t
257− "3" -> ansiColor' Yellow t
258− "4" -> ansiColor' Red t
259− "5" -> ansiColor' Magenta t
260− _ -> ansiColor' Blue t
261−
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−
296−detailedMiddleware' :: Callback
297− -> (Color -> BS.ByteString -> [BS.ByteString])
298− -> (BS.ByteString -> [BS.ByteString])
299− -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
300− -> Middleware
119+ -> Middleware
301−detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do
120+logCallbackDev cb app req = do
121+ let mlen = lookup "content-length" (requestHeaders req) >>= readInt
302 (req', body) <-
122 (req', body) <-
303− -- second tuple item should not be necessary, but a test runner might mess it up
123+ case mlen of
304− case (requestBodyLength req, contentLength (requestHeaders req)) of
305 -- log the request body if it is small
124 -- log the request body if it is small
306− (KnownLength len, _) | len <= 2048 -> getRequestBody req
307− (_, Just len) | len <= 2048 -> getRequestBody req
125+ Just len | len <= 2048 -> do
126+ body <- requestBody req C.$$ CL.consume
127+ -- logging the body here consumes it, so fill it back up
128+ -- obviously not efficient, but this is the development logger
129+ let req' = req { requestBody = CL.sourceList body }
130+ return (req', body)
308 _ -> return (req, [])
131 _ -> return (req, [])
309
132
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"]
133 postParams <- if requestMethod req `elem` ["GET", "HEAD"]
313− then return []
134+ then return []
314− else do postParams <- liftIO $ allPostParams body
135+ else do postParams <- liftIO $ allPostParams body
315− return $ collectPostParams postParams
136+ return $ collectPostParams postParams
316
137
317 let getParams = map emptyGetParam $ queryString req
138 let getParams = map emptyGetParam $ queryString req
318− accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req
319− params = let par | not $ null postParams = [pack (show postParams)]
320− | not $ null getParams = [pack (show getParams)]
321− | otherwise = []
322− in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"]
323
139
324− t0 <- getCurrentTime
140+ color <- liftIO $ atomicModifyIORef colors rotateColors
141+
142+ -- log the request immediately.
143+ liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) ++
144+ [ " "
145+ , rawPathInfo req
146+ , "\n"
147+ , "Accept: "
148+ , fromMaybe "" $ lookup "Accept" $ requestHeaders req
149+ , paramsToBS "GET " getParams
150+ , paramsToBS "POST " postParams
151+ , "\n"
152+ ]
153+
325− app req' $ \rsp -> do
154+ rsp <- app req'
326− let isRaw =
155+
327− case rsp of
156+ -- log the status of the response
328− ResponseRaw{} -> True
157+ -- this is color coordinated with the request logging
329− _ -> False
158+ -- also includes the request path to connect it to the request
159+ liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
330− stCode = statusBS rsp
160+ statusBS rsp
161+ , " "
331− stMsg = msgBS rsp
162+ , msgBS rsp
332− t1 <- getCurrentTime
163+ , ". "
164+ , rawPathInfo req -- if you need help matching the 2 logging statements
165+ , "\n"
166+ ]
167+ return rsp
168+ where
169+ ansiColor color bs = [
170+ pack $ setSGRCode [SetColor Foreground Vivid color]
171+ , bs
172+ , pack $ setSGRCode [Reset]
173+ ]
333
174
334− -- log the status of the response
175+ paramsToBS prefix params =
335− cb $ mconcat $ map toLogStr $
176+ if null params then ""
336− ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++
177+ else BS.concat ["\n", prefix, pack (show params)]
337− params ++ reqbody ++
338− ansiColor White " Accept: " ++ [accept, "\n"] ++
339− if isRaw then [] else
340− ansiColor White " Status: " ++
341− ansiStatusCode stCode (stCode <> " " <> stMsg) ++
342− [" ", pack $ show $ diffUTCTime t1 t0, "\n"]
343
178
344− sendResponse rsp
345− where
346 allPostParams body =
179 allPostParams body =
347 case getRequestBodyType req of
180 case getRequestBodyType req of
348 Nothing -> return ([], [])
181 Nothing -> return ([], [])
349− Just rbt -> do
350− ichunks <- newIORef body
351− let rbody = atomicModifyIORef ichunks $ \chunks ->
352− case chunks of
353− [] -> ([], S8.empty)
354− x:y -> (y, x)
355− sinkRequestBody lbsBackEnd rbt rbody
182+ Just rbt -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt
356
183
357 emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)
184 emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)
358 emptyGetParam (k, Just v) = (k,v)
185 emptyGetParam (k, Just v) = (k,v)
@@ -360,9 +187,12 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse
360
187
361 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
188 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
362 collectPostParams (postParams, files) = postParams ++
189 collectPostParams (postParams, files) = postParams ++
363− map (\(k,v) -> (k, "FILE: " <> fileName v)) files
190+ map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files
364−
365
191
192+ readInt bs =
193+ case reads $ unpack bs of
194+ (i, _):_ -> Just (i :: Int)
195+ [] -> Nothing
366
196
367statusBS :: Response -> BS.ByteString
197statusBS :: Response -> BS.ByteString
368statusBS = pack . show . statusCode . responseStatus
198statusBS = pack . show . statusCode . responseStatus
wai-extra/Network/Wai/Middleware/RequestLogger/Internal.hsdeleted−33
@@ -1,33 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-- | A module for containing some CPPed code, due to:
3−--
4−-- https://github.com/yesodweb/wai/issues/192
5−module Network.Wai.Middleware.RequestLogger.Internal
6− ( module Network.Wai.Middleware.RequestLogger.Internal
7− ) where
8−
9−import Data.ByteString (ByteString)
10−import Network.Wai.Logger (clockDateCacher)
11−#if !MIN_VERSION_wai_logger(2, 2, 0)
12−import Control.Concurrent (forkIO, threadDelay)
13−import Control.Monad (forever)
14−#endif
15−import System.Log.FastLogger (LogStr, fromLogStr)
16−
17−logToByteString :: LogStr -> ByteString
18−logToByteString = fromLogStr
19−
20−getDateGetter :: IO () -- ^ flusher
21− -> IO (IO ByteString)
22−#if !MIN_VERSION_wai_logger(2, 2, 0)
23−getDateGetter flusher = do
24− (getter, updater) <- clockDateCacher
25− _ <- forkIO $ forever $ do
26− threadDelay 1000000
27− updater
28− flusher
29−#else
30−getDateGetter _ = do
31− (getter, _) <- clockDateCacher
32−#endif
33− 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
13
55−-- $howto
14+-- | rewrite based on your own conversion rules
56−-- This module provides 'Middleware' to rewrite URL paths. It also provides
15+rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware
57−-- functions that will convert a 'Request' to a modified 'Request'.
16+rewrite convert app req = do
58−-- Both operations require a function that takes URL parameters and
17+ newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)
59−-- headers, and returns new URL parameters. Parameters are pieces of URL
18+ let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo
60−-- paths and query parameters.
19+ app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo }
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−
66−-- $semantics
67−--
68−-- Versions of this library in wai-extra ≤ 3.0.16.1 exported only
69−-- 'rewrite' and 'rewritePure' and both modified 'rawPathInfo' of the
70−-- underlying requests. Such modification has been proscribed. The
71−-- semantics of these functions have not changed; instead the recommended
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.hsdeleted−43
@@ -1,43 +0,0 @@
1−-- |
2−--
3−-- Since 3.0.4
4−module Network.Wai.Middleware.StreamFile
5− (streamFile) where
6−
7−import Network.Wai (responseStream)
8−import Network.Wai.Internal
9−import Network.Wai (Middleware, responseToStream)
10−import qualified Data.ByteString.Char8 as S8
11−import System.PosixCompat (getFileStatus, fileSize, FileOffset)
12−import Network.HTTP.Types (hContentLength)
13−
14−-- |Convert ResponseFile type responses into ResponseStream type
15−--
16−-- Checks the response type, and if it's a ResponseFile, converts it
17−-- into a ResponseStream. Other response types are passed through
18−-- unchanged.
19−--
20−-- Converted responses get a Content-Length header.
21−--
22−-- Streaming a file will bypass a sendfile system call, and may be
23−-- useful to work around systems without working sendfile
24−-- implementations.
25−--
26−-- Since 3.0.4
27−streamFile :: Middleware
28−streamFile app env sendResponse = app env $ \res ->
29− case res of
30− ResponseFile _ _ fp _ -> withBody sendBody
31− where
32− (s, hs, withBody) = responseToStream res
33− sendBody :: StreamingBody -> IO ResponseReceived
34− sendBody body = do
35− len <- getFileSize fp
36− let hs' = (hContentLength, (S8.pack (show len))) : hs
37− sendResponse $ responseStream s hs' body
38− _ -> sendResponse res
39−
40−getFileSize :: FilePath -> IO FileOffset
41−getFileSize path = do
42− stat <- getFileStatus path
43− return (fileSize stat)
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+7−21
@@ -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) where
3
3
4import Network.Wai
4import Network.Wai
5
5
@@ -7,9 +7,6 @@ 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
11−import Data.Monoid (mappend)
12−#endif
13
10
14vhost :: [(Request -> Bool, Application)] -> Application -> Application
11vhost :: [(Request -> Bool, Application)] -> Application -> Application
15vhost vhosts def req =
12vhost vhosts def req =
@@ -18,20 +15,9 @@ vhost vhosts def req =
18 (_, app):_ -> app req
15 (_, app):_ -> app req
19
16
20redirectWWW :: Text -> Application -> Application -- W.MiddleWare
17redirectWWW :: Text -> Application -> Application -- W.MiddleWare
21−redirectWWW home =
18+redirectWWW home app req =
22− redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)
19+ if BS.isPrefixOf "www" $ serverName req
20+ then return $ responseLBS H.status301
21+ [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect"
22+ else app req
23
23
24−redirectIf :: Text -> (Request -> Bool) -> Application -> Application
25−redirectIf home cond app req sendResponse =
26− if cond req
27− then sendResponse $ redirectTo $ TE.encodeUtf8 home
28− else app req sendResponse
29−
30−redirectTo :: BS.ByteString -> Response
31−redirectTo location = responseLBS H.status301
32− [ (H.hContentType, "text/plain") , (H.hLocation, location) ] "Redirect"
33−
34−redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response
35−redirectToLogged logger loc = do
36− logger $ "redirecting to: " `mappend` TE.decodeUtf8 loc
37− return $ redirectTo loc
wai-extra/Network/Wai/Parse.hs+190−557
@@ -1,8 +1,6 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
3−{-# LANGUAGE PatternGuards #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE RankNTypes #-}
6-- | Some helpers for parsing data out of a raw WAI 'Request'.
4-- | Some helpers for parsing data out of a raw WAI 'Request'.
7
5
8module Network.Wai.Parse
6module Network.Wai.Parse
@@ -11,33 +9,16 @@ module Network.Wai.Parse
11 , RequestBodyType (..)
9 , RequestBodyType (..)
12 , getRequestBodyType
10 , getRequestBodyType
13 , sinkRequestBody
11 , sinkRequestBody
14− , sinkRequestBodyEx
12+ , conduitRequestBody
15− , BackEnd
16 , lbsBackEnd
13 , lbsBackEnd
17 , tempFileBackEnd
14 , tempFileBackEnd
18− , tempFileBackEndOpts
15+ , BackEnd (..)
19 , Param
16 , Param
20 , File
17 , File
21 , FileInfo (..)
18 , FileInfo (..)
22− , parseContentType
19+ -- ** Deprecated
23− , ParseRequestBodyOptions
20+ , lbsSink
24− , defaultParseRequestBodyOptions
21+ , tempFileSink
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
22#if TEST
42 , Bound (..)
23 , Bound (..)
43 , findBound
24 , findBound
@@ -48,241 +29,114 @@ module Network.Wai.Parse
48#endif
29#endif
49 ) where
30 ) where
50
31
51−import qualified Control.Exception as E
52import qualified Data.ByteString as S
32import qualified Data.ByteString as S
53import qualified Data.ByteString.Lazy as L
33import qualified Data.ByteString.Lazy as L
54import qualified Data.ByteString.Char8 as S8
34import qualified Data.ByteString.Char8 as S8
55import Data.Word (Word8)
35import Data.Word (Word8)
56−import Data.Int (Int64)
36+import Data.Bits
57−import Data.Maybe (catMaybes, fromMaybe)
37+import Data.Maybe (fromMaybe)
58import Data.List (sortBy)
38import Data.List (sortBy)
59−import Data.Function (on, fix)
39+import Data.Function (on)
60import System.Directory (removeFile, getTemporaryDirectory)
40import System.Directory (removeFile, getTemporaryDirectory)
61import System.IO (hClose, openBinaryTempFile)
41import System.IO (hClose, openBinaryTempFile)
62−import System.IO.Error (isDoesNotExistError)
63import Network.Wai
42import Network.Wai
43+import qualified Data.Conduit as C
44+import qualified Data.Conduit.List as CL
45+import Control.Monad.IO.Class (liftIO)
64import qualified Network.HTTP.Types as H
46import qualified Network.HTTP.Types as H
65−import Control.Applicative ((<$>))
47+import Data.Either (partitionEithers)
66−import Control.Exception (catchJust)
67−import Control.Monad (when, unless, guard)
68−import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)
69−import Data.IORef
70−import Network.HTTP.Types (hContentType)
71−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
72−import Data.CaseInsensitive (mk)
73
48
74−import Prelude hiding (lines)
49+uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
50+uncons s
51+ | S.null s = Nothing
52+ | otherwise = Just (S.head s, S.tail s)
75
53
76breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
54breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
77breakDiscard w s =
55breakDiscard w s =
78 let (x, y) = S.break (== w) s
56 let (x, y) = S.break (== w) s
79 in (x, S.drop 1 y)
57 in (x, S.drop 1 y)
80
58
59+qsDecode :: S.ByteString -> S.ByteString
60+qsDecode z = fst $ S.unfoldrN (S.length z) go z
61+ where
62+ go bs =
63+ case uncons bs of
64+ Nothing -> Nothing
65+ Just (43, ws) -> Just (32, ws) -- plus to space
66+ Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent
67+ (x, xs) <- uncons ws
68+ x' <- hexVal x
69+ (y, ys) <- uncons xs
70+ y' <- hexVal y
71+ Just $ (combine x' y', ys)
72+ Just (w, ws) -> Just (w, ws)
73+ hexVal w
74+ | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9
75+ | 65 <= w && w <= 70 = Just $ w - 55 -- A - F
76+ | 97 <= w && w <= 102 = Just $ w - 87 -- a - f
77+ | otherwise = Nothing
78+ combine :: Word8 -> Word8 -> Word8
79+ combine a b = shiftL a 4 .|. b
80+
81-- | Parse the HTTP accept string to determine supported content types.
81-- | Parse the HTTP accept string to determine supported content types.
82parseHttpAccept :: S.ByteString -> [S.ByteString]
82parseHttpAccept :: S.ByteString -> [S.ByteString]
83parseHttpAccept = map fst
83parseHttpAccept = map fst
84 . sortBy (rcompare `on` snd)
84 . sortBy (rcompare `on` snd)
85− . map (addSpecificity . grabQ)
85+ . map grabQ
86 . S.split 44 -- comma
86 . S.split 44 -- comma
87 where
87 where
88− rcompare :: (Double,Int) -> (Double,Int) -> Ordering
88+ rcompare :: Double -> Double -> Ordering
89 rcompare = flip compare
89 rcompare = flip compare
90− addSpecificity (s, q) =
91− -- Prefer higher-specificity types
92− let semicolons = S.count 0x3B s
93− stars = S.count 0x2A s
94− in (s, (q, semicolons - stars))
95 grabQ s =
90 grabQ s =
96− -- Stripping all spaces may be too harsh.
91+ let (s', q) = breakDiscard 59 s -- semicolon
97− -- Maybe just strip either side of semicolon?
92+ (_, q') = breakDiscard 61 q -- equals sign
98− let (s', q) = S.breakSubstring ";q=" (S.filter (/=0x20) s) -- 0x20 is space
99− q' = S.takeWhile (/=0x3B) (S.drop 3 q) -- 0x3B is semicolon
100− in (s', readQ q')
93+ in (trimWhite s', readQ $ trimWhite q')
101 readQ s = case reads $ S8.unpack s of
94 readQ s = case reads $ S8.unpack s of
102 (x, _):_ -> x
95 (x, _):_ -> x
103 _ -> 1.0
96 _ -> 1.0
97+ trimWhite = S.dropWhile (== 32) -- space
98+
99+-- | A destination for file data, with concrete implemtations
100+-- provided by 'lbsBackEnd' and 'tempFileBackEnd'
101+data BackEnd y = forall x . BackEnd
102+ { initialize :: IO x
103+ , append :: x -> S.ByteString -> IO x
104+ , close :: x -> IO y
105+ , finalize :: y -> IO ()
106+ }
104
107
105-- | Store uploaded files in memory
108-- | Store uploaded files in memory
106−lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString
109+lbsBackEnd :: BackEnd L.ByteString
107−lbsBackEnd _ _ popper =
110+lbsBackEnd = BackEnd
108− loop id
111+ { initialize = return id
109− where
112+ , append = \front bs -> return $ front . (:) bs
110− loop front = do
111− bs <- popper
112− if S.null bs
113− then return $ L.fromChunks $ front []
113+ , close = \front -> return $ L.fromChunks $ front []
114− else loop $ front . (bs:)
114+ , finalize = \_ -> return ()
115+ }
115
116
116-- | Save uploaded files on disk as temporary files
117-- | Save uploaded files on disk as temporary files
117−--
118+tempFileBackEnd :: BackEnd FilePath
118−-- Note: starting with version 2.0, removal of temp files is registered with
119+tempFileBackEnd = BackEnd
119−-- the provided @InternalState@. It is the responsibility of the caller to
120+ { initialize = do
120−-- ensure that this @InternalState@ gets cleaned up.
121−tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath
122−tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"
121+ tempDir <- getTemporaryDirectory
123−
122+ openBinaryTempFile tempDir "webenc.buf"
124−-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.
125−tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory
126− -> String -- ^ filename pattern
127− -> InternalState
128− -> ignored1
129− -> ignored2
130− -> IO S.ByteString
131− -> IO FilePath
132−tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do
133− (key, (fp, h)) <- flip runInternalState internalState $ allocate it (hClose . snd)
134− _ <- runInternalState (register $ removeFileQuiet fp) internalState
135− fix $ \loop -> do
136− bs <- popper
137− unless (S.null bs) $ do
138− S.hPut h bs
123+ , append = \(fp, h) bs -> S.hPut h bs >> return (fp, h)
139− loop
124+ , close = \(fp, h) -> do
140− release key
125+ hClose h
141− return fp
126+ return fp
142− where
143− it = do
144− tempDir <- getTmpDir
145− openBinaryTempFile tempDir pattrn
146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)
147− (removeFile fp)
127+ , finalize = \fp -> removeFile fp
148− (const $ return ())
128+ }
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
129
248−-- | Do not limit the maximum header lines per mime/multipart entry.
130+-- | This function has been renamed to 'lbsBackEnd'
249−--
131+lbsSink :: BackEnd L.ByteString
250−-- @since 3.0.16.0
132+lbsSink = lbsBackEnd
251−clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions
252−clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }
253
133
254−-- | A reasonable default set of parsing options.
134+-- | This function has been renamed to 'tempFileBackEnd'
255−-- Maximum key/filename length: 32 bytes;
135+tempFileSink :: BackEnd FilePath
256−-- maximum files: 10; filesize unlimited; maximum
136+tempFileSink = tempFileBackEnd
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
137
274−-- | Do not impose any memory limits.
138+{-# DEPRECATED lbsSink "Please use 'lbsBackEnd'" #-}
275−--
139+{-# DEPRECATED tempFileSink "Please use 'tempFileBackEnd'" #-}
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
140
287-- | Information on an uploaded file.
141-- | Information on an uploaded file.
288data FileInfo c = FileInfo
142data FileInfo c = FileInfo
@@ -292,229 +146,96 @@ data FileInfo c = FileInfo
292 }
146 }
293 deriving (Eq, Show)
147 deriving (Eq, Show)
294
148
295−-- | Post parameter name and value.
296type Param = (S.ByteString, S.ByteString)
149type Param = (S.ByteString, S.ByteString)
297−
298−-- | Post parameter name and associated file information.
299type File y = (S.ByteString, FileInfo y)
150type File y = (S.ByteString, FileInfo y)
300
151
301−-- | A file uploading backend. Takes the parameter name, file name, and a
302−-- stream of data.
303−type BackEnd a = S.ByteString -- ^ parameter name
304− -> FileInfo ()
305− -> IO S.ByteString
306− -> IO a
307−
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
152+data RequestBodyType = UrlEncoded | Multipart S.ByteString
316
153
317−-- | Get the mimetype of the body of an http request.
318getRequestBodyType :: Request -> Maybe RequestBodyType
154getRequestBodyType :: Request -> Maybe RequestBodyType
319getRequestBodyType req = do
155getRequestBodyType req = do
320− ctype' <- lookup hContentType $ requestHeaders req
156+ ctype <- lookup "Content-Type" $ requestHeaders req
321− let (ctype, attrs) = parseContentType ctype'
157+ if urlenc `S.isPrefixOf` ctype
322− case ctype of
158+ then Just UrlEncoded
323− "application/x-www-form-urlencoded" -> return UrlEncoded
159+ else case boundary ctype of
324− "multipart/form-data" | Just bound <- lookup "boundary" attrs -> return $ Multipart bound
160+ Just x -> Just $ Multipart x
325− _ -> Nothing
161+ Nothing -> Nothing
326−
327−-- | Parse a content type value, turning a single @ByteString@ into the actual
328−-- content type and a list of pairs of attributes.
329−--
330−-- @since 1.3.2
331−parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])
332−parseContentType a = do
333− let (ctype, b) = S.break (== semicolon) a
334− attrs = goAttrs id $ S.drop 1 b
335− in (ctype, attrs)
336 where
162 where
337− semicolon = 59
163+ urlenc = S8.pack "application/x-www-form-urlencoded"
338− equals = 61
164+ formBound = S8.pack "multipart/form-data;"
339− space = 32
165+ bound' = "boundary="
340− dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote
166+ boundary s =
341− then S.tail $ S.init s
167+ if "multipart/form-data;" `S.isPrefixOf` s
342− else s
168+ then
343− goAttrs front bs
169+ let s' = S.dropWhile (== 32) $ S.drop (S.length formBound) s
344− | S.null bs = front []
170+ in if bound' `S.isPrefixOf` s'
345− | otherwise =
171+ then Just $ S.drop (S.length bound') s'
346− let (x, rest) = S.break (== semicolon) bs
172+ else Nothing
347− in goAttrs (front . (goAttr x:)) $ S.drop 1 rest
173+ else Nothing
348− goAttr bs =
349− let (k, v') = S.break (== equals) bs
350− v = S.drop 1 v'
351− in (strip k, dq $ strip v)
352− strip = S.dropWhile (== space) . fst . S.breakEnd (/= space)
353
174
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
175parseRequestBody :: BackEnd y
361 -> Request
176 -> Request
362− -> IO ([Param], [File y])
177+ -> C.ResourceT IO ([Param], [File y])
363−parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions
178+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
179 case getRequestBodyType r of
377 Nothing -> return ([], [])
180 Nothing -> return ([], [])
378− Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)
181+ Just rbt -> fmap partitionEithers $ requestBody r C.$$ conduitRequestBody s rbt C.=$ CL.consume
379
182
380sinkRequestBody :: BackEnd y
183sinkRequestBody :: BackEnd y
381 -> RequestBodyType
184 -> RequestBodyType
382− -> IO S.ByteString
383− -> IO ([Param], [File y])
185+ -> C.Sink S.ByteString (C.ResourceT IO) ([Param], [File y])
384−sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions
186+sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r C.=$ CL.consume
385
187
386−-- |
387−--
388−-- @since 3.0.16.0
389−sinkRequestBodyEx :: ParseRequestBodyOptions
390− -> BackEnd y
188+conduitRequestBody :: BackEnd y
391− -> RequestBodyType
189+ -> RequestBodyType
392− -> IO S.ByteString
393− -> IO ([Param], [File y])
394−sinkRequestBodyEx o s r body = do
395− ref <- newIORef ([], [])
396− let add x = atomicModifyIORef ref $ \(y, z) ->
397− case x of
398− Left y' -> ((y':y, z), ())
399− Right z' -> ((y, z':z), ())
400− conduitRequestBodyEx o s r body add
401− (\(a, b) -> (reverse a, reverse b)) <$> readIORef ref
402−
403−conduitRequestBodyEx :: ParseRequestBodyOptions
404− -> BackEnd y
405− -> RequestBodyType
406− -> IO S.ByteString
407− -> (Either Param (File y) -> IO ())
190+ -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))
408− -> IO ()
191+conduitRequestBody _ UrlEncoded = C.sequenceSink () $ \() -> do -- url-encoded
409−conduitRequestBodyEx o _ UrlEncoded rbody add = do
410 -- NOTE: in general, url-encoded data will be in a single chunk.
192 -- NOTE: in general, url-encoded data will be in a single chunk.
411 -- Therefore, I'm optimizing for the usual case by sticking with
193 -- Therefore, I'm optimizing for the usual case by sticking with
412 -- strict byte strings here.
194 -- strict byte strings here.
413− let loop size front = do
195+ bs <- CL.consume
414− bs <- rbody
415− if S.null bs
416− 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:)
424− bs <- loop 0 id
425− mapM_ (add . Left) $ H.parseSimpleQuery bs
196+ return $ C.Emit () $ map Left $ H.parseSimpleQuery $ S.concat bs
426−conduitRequestBodyEx o backend (Multipart bound) rbody add =
197+conduitRequestBody backend (Multipart bound) =
427− parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add
198+ parsePieces backend $ S8.pack "--" `S.append` bound
428−
199+
429−
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)
200+takeLine :: C.Sink S.ByteString (C.ResourceT IO) (Maybe S.ByteString)
434−takeLine maxlen src =
201+takeLine =
435− go ""
202+ C.sinkState id push close'
436 where
203 where
437− go front = do
438− 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
445− then close front
446− else push front bs
447−
448− close front = leftover src front >> return Nothing
204+ close' _ = return Nothing
449 push front bs = do
205 push front bs = do
450− let (x, y) = S.break (== 10) bs -- LF
206+ let (x, y) = S.break (== 10) $ front bs -- LF
451 in if S.null y
207 in if S.null y
452− then go $ front `S.append` x
208+ then return $ C.StateProcessing $ S.append x
453 else do
209 else do
454− when (S.length y > 1) $ leftover src $ S.drop 1 y
210+ let lo = if S.length y > 1 then Just (S.drop 1 y) else Nothing
455− let res = front `S.append` x
456− case maxlen of
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
211+ return $ C.StateDone lo $ Just $ killCR x
462−
463−takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]
464−takeLines' lineLength maxLines source =
465− reverse <$> takeLines'' [] lineLength maxLines source
466
212
467−takeLines''
468− :: [S.ByteString]
469− -> Maybe Int
470− -> Maybe Int
471− -> Source
472− -> IO [S.ByteString]
213+takeLines :: C.Sink S.ByteString (C.ResourceT IO) [S.ByteString]
473−takeLines'' lines lineLength maxLines src = do
214+takeLines = 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
215+ res <- takeLine
480 case res of
216 case res of
481− Nothing -> return lines
217+ Nothing -> return []
482 Just l
218 Just l
483− | S.null l -> return lines
219+ | S.null l -> return []
484− | otherwise -> takeLines'' (l:lines) lineLength maxLines src
220+ | otherwise -> do
485−
221+ ls <- takeLines
486−data Source = Source (IO S.ByteString) (IORef S.ByteString)
222+ return $ l : ls
487−
223+
488−mkSource :: IO S.ByteString -> IO Source
224+parsePieces :: BackEnd y -> S.ByteString
489−mkSource f = do
225+ -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))
490− ref <- newIORef S.empty
226+parsePieces sink bound = C.sequenceSink True (parsePiecesSink sink bound)
491− return $ Source f ref
227+
492−
493−readSource :: Source -> IO S.ByteString
494−readSource (Source f ref) = do
495− bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs)
496− if S.null bs
497− then f
498− else return bs
499−
500−leftover :: Source -> S.ByteString -> IO ()
501−leftover (Source _ ref) bs = writeIORef ref bs
502−
503−parsePiecesEx :: ParseRequestBodyOptions
504− -> BackEnd y
228+parsePiecesSink :: BackEnd y
505− -> S.ByteString
229+ -> S.ByteString
506− -> IO S.ByteString
507− -> (Either Param (File y) -> IO ())
230+ -> C.SequencedSink Bool S.ByteString (C.ResourceT IO) (Either Param (File y))
508− -> IO ()
231+parsePiecesSink _ _ False = return C.Stop
509−parsePiecesEx o sink bound rbody add =
232+parsePiecesSink BackEnd{initialize=initialize',append=append',close=close'}
510− mkSource rbody >>= loop 0 0 0 0
233+ bound True = do
511− where
512− loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()
513− loop numParms numFiles parmSize filesSize src = do
514− _boundLine <- takeLine (prboMaxHeaderLineLength o) src
234+ _boundLine <- takeLine
515− res' <- takeLines' (prboMaxHeaderLineLength o)
235+ res' <- takeLines
516− (prboMaxHeaderLines o) src
236+ case res' of
517− unless (null res') $ do
237+ [] -> return C.Stop
238+ _ -> do
518 let ls' = map parsePair res'
239 let ls' = map parsePair res'
519 let x = do
240 let x = do
520 cd <- lookup contDisp ls'
241 cd <- lookup contDisp ls'
@@ -524,57 +245,34 @@ parsePiecesEx o sink bound rbody add =
524 return (ct, name, lookup "filename" attrs)
245 return (ct, name, lookup "filename" attrs)
525 case x of
246 case x of
526 Just (mct, name, Just filename) -> do
247 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
248 let ct = fromMaybe "application/octet-stream" mct
249+ seed <- liftIO initialize'
250+ (seed', wasFound) <-
251+ sinkTillBound bound append' seed
252+ y <- liftIO $ close' seed'
537− fi0 = FileInfo filename ct ()
253+ let fi = FileInfo filename ct y
538− fs = catMaybes [ prboMaxFileSize o
254+ let y' = (name, fi)
539− , subtract filesSize <$> prboMaxFilesSize o ]
255+ return $ C.Emit wasFound [Right y']
540− mfs = if fs == [] then Nothing else Just $ minimum fs
541− ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs
542− let newFilesSize = filesSize + fileSize
543− add $ Right (name, fi0 { fileContent = y })
544− when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src
545 Just (_ct, name, Nothing) -> do
256 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
257 let seed = id
552 let iter front bs = return $ front . (:) bs
258 let iter front bs = return $ front . (:) bs
259+ (front, wasFound) <-
553− ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src
260+ sinkTillBound bound iter seed
554− (fromIntegral <$> prboMaxParmsSize o)
555 let bs = S.concat $ front []
261 let bs = S.concat $ front []
556− let x' = (name, bs)
262+ let x' = (name, qsDecode bs)
557− let newParmSize = parmSize + S.length name + S.length bs
263+ return $ C.Emit wasFound [Left x']
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'
563− when wasFound $ loop (numParms + 1) numFiles
564− newParmSize filesSize src
565 _ -> do
264 _ -> do
566 -- ignore this part
265 -- ignore this part
567 let seed = ()
266 let seed = ()
568 iter () _ = return ()
267 iter () _ = return ()
569− ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing
268+ ((), wasFound) <- sinkTillBound bound iter seed
570− when wasFound $ loop numParms numFiles parmSize filesSize src
269+ return $ C.Emit wasFound []
571− where
270+ where
572− contDisp = mk $ S8.pack "Content-Disposition"
271+ contDisp = S8.pack "Content-Disposition"
573− contType = mk $ S8.pack "Content-Type"
272+ contType = S8.pack "Content-Type"
574− parsePair s =
273+ parsePair s =
575− let (x, y) = breakDiscard 58 s -- colon
274+ let (x, y) = breakDiscard 58 s -- colon
576− in (mk $ x, S.dropWhile (== 32) y) -- space
275+ in (x, S.dropWhile (== 32) y) -- space
577−
578
276
579data Bound = FoundBound S.ByteString S.ByteString
277data Bound = FoundBound S.ByteString S.ByteString
580 | NoBound
278 | NoBound
@@ -582,14 +280,8 @@ data Bound = FoundBound S.ByteString S.ByteString
582 deriving (Eq, Show)
280 deriving (Eq, Show)
583
281
584findBound :: S.ByteString -> S.ByteString -> Bound
282findBound :: S.ByteString -> S.ByteString -> Bound
585−findBound b bs = handleBreak $ S.breakSubstring b bs
283+findBound b bs = go [0..S.length bs - 1]
586 where
284 where
587− handleBreak (h, t)
588− | S.null t = go [lowBound..S.length bs - 1]
589− | otherwise = FoundBound h $ S.drop (S.length b) t
590−
591− lowBound = max 0 $ S.length bs - S.length b
592−
593 go [] = NoBound
285 go [] = NoBound
594 go (i:is)
286 go (i:is)
595 | mismatch [0..S.length b - 1] [i..S.length bs - 1] = go is
287 | mismatch [0..S.length b - 1] [i..S.length bs - 1] = go is
@@ -604,94 +296,35 @@ findBound b bs = handleBreak $ S.breakSubstring b bs
604 | S.index b x == S.index bs y = mismatch xs ys
296 | S.index b x == S.index bs y = mismatch xs ys
605 | otherwise = True
297 | otherwise = True
606
298
607−sinkTillBound' :: S.ByteString
608− -> S.ByteString
609− -> FileInfo ()
610− -> BackEnd y
611− -> Source
612− -> Maybe Int64
613− -> IO ((Bool, Int64), y)
614−sinkTillBound' bound name fi sink src max' = do
615− (next, final) <- wrapTillBound bound src max'
616− y <- sink name fi next
617− b <- final
618− return (b, y)
619−
620−data WTB = WTBWorking (S.ByteString -> S.ByteString)
621− | WTBDone Bool
622−wrapTillBound :: S.ByteString -- ^ bound
623− -> Source
624− -> Maybe Int64
625− -> IO (IO S.ByteString, IO (Bool, Int64)) -- ^ Bool indicates if the bound was found
626−wrapTillBound bound src max' = do
627− ref <- newIORef $ WTBWorking id
628− sref <- newIORef (0 :: Int64)
629− return (go ref sref, final ref sref)
630− where
631− final ref sref = do
632− x <- readIORef ref
633− case x of
634− WTBWorking _ -> error "wrapTillBound did not finish"
635− WTBDone y -> do
636− siz <- readIORef sref
637− return (y, siz)
638−
639− go ref sref = do
640− state <- readIORef ref
641− case state of
642− WTBDone _ -> return S.empty
643− WTBWorking front -> do
644− 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
652− then do
653− writeIORef ref $ WTBDone False
654− return $ front bs
655− else push $ front bs
656− where
657− push bs = do
658− case findBound bound bs of
659− FoundBound before after -> do
660− let before' = killCRLF before
661− leftover src after
662− writeIORef ref $ WTBDone True
663− return before'
664− NoBound -> do
665− -- don't emit newlines, in case it's part of a bound
666− let (toEmit, front') =
667− if not (S8.null bs) && S8.last bs `elem` ['\r','\n']
668− then let (x, y) = S.splitAt (S.length bs - 2) bs
669− in (x, S.append y)
670− else (bs, id)
671− writeIORef ref $ WTBWorking front'
672− if S.null toEmit
673− then go ref sref
674− else return toEmit
675− PartialBound -> do
676− writeIORef ref $ WTBWorking $ S.append bs
677− go ref sref
678−
679sinkTillBound :: S.ByteString
299sinkTillBound :: S.ByteString
680 -> (x -> S.ByteString -> IO x)
300 -> (x -> S.ByteString -> IO x)
681 -> x
301 -> x
682− -> Source
302+ -> C.Sink S.ByteString (C.ResourceT IO) (x, Bool)
683− -> Maybe Int64
684− -> IO ((Bool, Int64), x)
685−sinkTillBound bound iter seed0 src max' = do
303+sinkTillBound bound iter seed0 = C.sinkState
686− (next, final) <- wrapTillBound bound src max'
304+ (id, seed0)
305+ push
306+ close'
307+ where
308+ close' (front, seed) = do
309+ seed' <- liftIO $ iter seed $ front S.empty
310+ return (seed', False)
687− let loop seed = do
311+ push (front, seed) bs' = do
688− bs <- next
312+ let bs = front bs'
313+ case findBound bound bs of
314+ FoundBound before after -> do
315+ let before' = killCRLF before
316+ seed' <- liftIO $ iter seed before'
317+ return $ C.StateDone (Just after) (seed', True)
318+ NoBound -> do
319+ -- don't emit newlines, in case it's part of a bound
320+ let (toEmit, front') =
689− if S.null bs
321+ if not (S8.null bs) && S8.last bs `elem` "\r\n"
690− then return seed
322+ then let (x, y) = S.splitAt (S.length bs - 2) bs
323+ in (x, S.append y)
691− else iter seed bs >>= loop
324+ else (bs, id)
692− seed <- loop seed0
325+ seed' <- liftIO $ iter seed toEmit
693− b <- final
326+ return $ C.StateProcessing (front', seed')
694− return (b, seed)
327+ PartialBound -> return $ C.StateProcessing (S.append bs, seed)
695
328
696parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
329parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]
697parseAttrs = map go . S.split 59 -- semicolon
330parseAttrs = map go . S.split 59 -- semicolon
wai-extra/Network/Wai/Request.hsdeleted−101
@@ -1,101 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−-- | Some helpers for interrogating a WAI 'Request'.
3−
4−module Network.Wai.Request
5− ( appearsSecure
6− , guessApproot
7− , RequestSizeException(..)
8− , requestSizeCheck
9− ) where
10−
11−import Data.ByteString (ByteString)
12−import Data.Maybe (fromMaybe)
13−import Network.HTTP.Types (HeaderName)
14−import Network.Wai
15−
16−import qualified Data.ByteString as S
17−import 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−
24−-- | Does this request appear to have been made over an SSL connection?
25−--
26−-- This function first checks @'isSecure'@, but also checks for headers that may
27−-- indicate a secure connection even in the presence of reverse proxies.
28−--
29−-- Note: these headers can be easily spoofed, so decisions which require a true
30−-- SSL connection (i.e. sending sensitive information) should only use
31−-- @'isSecure'@. This is not always the case though: for example, deciding to
32−-- 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.
34−--
35−-- @since 3.0.7
36−appearsSecure :: Request -> Bool
37−appearsSecure request = isSecure request || any (uncurry matchHeader)
38− [ ("HTTPS" , (== "on"))
39− , ("HTTP_X_FORWARDED_SSL" , (== "on"))
40− , ("HTTP_X_FORWARDED_SCHEME", (== "https"))
41− , ("HTTP_X_FORWARDED_PROTO" , ((== ["https"]) . take 1 . C.split ','))
42− , ("X-Forwarded-Proto" , (== "https")) -- Used by Nginx and AWS ELB.
43− ]
44−
45− where
46− matchHeader :: HeaderName -> (ByteString -> Bool) -> Bool
47− matchHeader h f = maybe False f $ lookup h $ requestHeaders request
48−
49−-- | Guess the \"application root\" based on the given request.
50−--
51−-- The application root is the basis for forming URLs pointing at the current
52−-- application. For more information and relevant caveats, please see
53−-- "Network.Wai.Middleware.Approot".
54−--
55−-- @since 3.0.7
56−guessApproot :: Request -> ByteString
57−guessApproot req =
58− (if appearsSecure req then "https://" else "http://") `S.append`
59− (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.hsdeleted−333
@@ -1,333 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−module Network.Wai.Test
5− ( -- * Session
6− Session
7− , runSession
8− -- * Client Cookies
9− , ClientCookies
10− , getClientCookies
11− , modifyClientCookies
12− , setClientCookie
13− , deleteClientCookie
14− -- * Requests
15− , request
16− , srequest
17− , SRequest (..)
18− , SResponse (..)
19− , defaultRequest
20− , setPath
21− , setRawPathInfo
22− -- * Assertions
23− , assertStatus
24− , assertContentType
25− , assertBody
26− , assertBodyContains
27− , assertHeader
28− , assertNoHeader
29− , assertClientCookieExists
30− , assertNoClientCookieExists
31− , assertClientCookieValue
32− , WaiTestFailure (..)
33− ) where
34−
35−#if __GLASGOW_HASKELL__ < 710
36−import Control.Applicative ((<$>))
37−import Data.Monoid (mempty, mappend)
38−#endif
39−
40−import Network.Wai
41−import Network.Wai.Internal (ResponseReceived (ResponseReceived))
42−import Network.Wai.Test.Internal
43−import Control.Monad.IO.Class (liftIO)
44−import Control.Monad.Trans.Class (lift)
45−import qualified Control.Monad.Trans.State as ST
46−import Control.Monad.Trans.Reader (runReaderT, ask)
47−import Control.Monad (unless)
48−import Control.DeepSeq (deepseq)
49−import Control.Exception (throwIO, Exception)
50−import Data.Typeable (Typeable)
51−import qualified Data.Map as Map
52−import qualified Web.Cookie as Cookie
53−import Data.ByteString (ByteString)
54−import qualified Data.ByteString.Char8 as S8
55−import Data.ByteString.Builder (toLazyByteString)
56−import qualified Data.ByteString.Lazy as L
57−import qualified Data.ByteString.Lazy.Char8 as L8
58−import qualified Network.HTTP.Types as H
59−import Data.CaseInsensitive (CI)
60−import qualified Data.ByteString as S
61−import qualified Data.Text as T
62−import qualified Data.Text.Encoding as TE
63−import Data.IORef
64−import Data.Time.Clock (getCurrentTime)
65−
66−-- |
67−--
68−-- Since 3.0.6
69−getClientCookies :: Session ClientCookies
70−getClientCookies = clientCookies <$> lift ST.get
71−
72−-- |
73−--
74−-- Since 3.0.6
75−modifyClientCookies :: (ClientCookies -> ClientCookies) -> Session ()
76−modifyClientCookies f =
77− lift (ST.modify (\cs -> cs { clientCookies = f $ clientCookies cs }))
78−
79−-- |
80−--
81−-- Since 3.0.6
82−setClientCookie :: Cookie.SetCookie -> Session ()
83−setClientCookie c =
84− modifyClientCookies
85− (Map.insert (Cookie.setCookieName c) c)
86−
87−-- |
88−--
89−-- Since 3.0.6
90−deleteClientCookie :: ByteString -> Session ()
91−deleteClientCookie cookieName =
92− modifyClientCookies
93− (Map.delete cookieName)
94−
95−-- | See also: 'runSessionWith'.
96−runSession :: Session a -> Application -> IO a
97−runSession session app = ST.evalStateT (runReaderT session app) initState
98−
99−data SRequest = SRequest
100− { simpleRequest :: Request
101− , simpleRequestBody :: L.ByteString
102− -- ^ Request body that will override the one set in 'simpleRequest'.
103− --
104− -- This is usually simpler than setting the body as a stateful IO-action
105− -- in 'simpleRequest'.
106− }
107−data SResponse = SResponse
108− { simpleStatus :: H.Status
109− , simpleHeaders :: H.ResponseHeaders
110− , simpleBody :: L.ByteString
111− }
112− deriving (Show, Eq)
113−
114−request :: Request -> Session SResponse
115−request req = do
116− app <- ask
117− req' <- addCookiesToRequest req
118− response <- liftIO $ do
119− ref <- newIORef $ error "runResponse gave no result"
120− ResponseReceived <- app req' (runResponse ref)
121− readIORef ref
122− extractSetCookieFromSResponse response
123−
124−-- | Set whole path (request path + query string).
125−setPath :: Request -> S8.ByteString -> Request
126−setPath req path = req {
127− pathInfo = segments
128− , rawPathInfo = (L8.toStrict . toLazyByteString) (H.encodePathSegments segments)
129− , queryString = query
130− , rawQueryString = (H.renderQuery True query)
131− }
132− where
133− (segments, query) = H.decodePath path
134−
135−setRawPathInfo :: Request -> S8.ByteString -> Request
136−setRawPathInfo r rawPinfo =
137− let pInfo = dropFrontSlash $ T.split (== '/') $ TE.decodeUtf8 rawPinfo
138− in r { rawPathInfo = rawPinfo, pathInfo = pInfo }
139− where
140− dropFrontSlash ("":"":[]) = [] -- homepage, a single slash
141− dropFrontSlash ("":path) = path
142− dropFrontSlash path = path
143−
144−addCookiesToRequest :: Request -> Session Request
145−addCookiesToRequest req = do
146− oldClientCookies <- getClientCookies
147− let requestPath = "/" `T.append` T.intercalate "/" (pathInfo req)
148− currentUTCTime <- liftIO getCurrentTime
149− let cookiesForRequest =
150− Map.filter
151− (\c -> checkCookieTime currentUTCTime c
152− && checkCookiePath requestPath c)
153− oldClientCookies
154− let cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
155− | c <- map snd $ Map.toList cookiesForRequest
156− ]
157− let cookieValue = L8.toStrict . toLazyByteString $ Cookie.renderCookies cookiePairs
158− addCookieHeader rest
159− | null cookiePairs = rest
160− | otherwise = ("Cookie", cookieValue) : rest
161− return $ req { requestHeaders = addCookieHeader $ requestHeaders req }
162− where checkCookieTime t c =
163− case Cookie.setCookieExpires c of
164− Nothing -> True
165− Just t' -> t < t'
166− checkCookiePath p c =
167− case Cookie.setCookiePath c of
168− Nothing -> True
169− Just p' -> p' `S8.isPrefixOf` TE.encodeUtf8 p
170−
171−extractSetCookieFromSResponse :: SResponse -> Session SResponse
172−extractSetCookieFromSResponse response = do
173− let setCookieHeaders =
174− filter (("Set-Cookie"==) . fst) $ simpleHeaders response
175− let newClientCookies = map (Cookie.parseSetCookie . snd) setCookieHeaders
176− modifyClientCookies
177− (Map.union
178− (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))
179− return response
180−
181−-- | Similar to 'request', but allows setting the request body as a plain
182−-- 'L.ByteString'.
183−srequest :: SRequest -> Session SResponse
184−srequest (SRequest req bod) = do
185− refChunks <- liftIO $ newIORef $ L.toChunks bod
186− request $
187− req
188− { requestBody = atomicModifyIORef refChunks $ \bss ->
189− case bss of
190− [] -> ([], S.empty)
191− x:y -> (y, x)
192− }
193−
194−runResponse :: IORef SResponse -> Response -> IO ResponseReceived
195−runResponse ref res = do
196− refBuilder <- newIORef mempty
197− let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ())
198− withBody $ \body -> body add (return ())
199− builder <- readIORef refBuilder
200− let lbs = toLazyByteString builder
201− len = L.length lbs
202− -- Force evaluation of the body to have exceptions thrown at the right
203− -- time.
204− seq len $ writeIORef ref $ SResponse s h $ toLazyByteString builder
205− return ResponseReceived
206− where
207− (s, h, withBody) = responseToStream res
208−
209−assertBool :: String -> Bool -> Session ()
210−assertBool s b = unless b $ assertFailure s
211−
212−assertString :: String -> Session ()
213−assertString s = unless (null s) $ assertFailure s
214−
215−assertFailure :: String -> Session ()
216−assertFailure msg = msg `deepseq` liftIO (throwIO (WaiTestFailure msg))
217−
218−data WaiTestFailure = WaiTestFailure String
219− deriving (Show, Eq, Typeable)
220−instance Exception WaiTestFailure
221−
222−assertContentType :: ByteString -> SResponse -> Session ()
223−assertContentType ct SResponse{simpleHeaders = h} =
224− case lookup "content-type" h of
225− Nothing -> assertString $ concat
226− [ "Expected content type "
227− , show ct
228− , ", but no content type provided"
229− ]
230− Just ct' -> assertBool (concat
231− [ "Expected content type "
232− , show ct
233− , ", but received "
234− , show ct'
235− ]) (go ct == go ct')
236− where
237− go = S8.takeWhile (/= ';')
238−
239−assertStatus :: Int -> SResponse -> Session ()
240−assertStatus i SResponse{simpleStatus = s} = assertBool (concat
241− [ "Expected status code "
242− , show i
243− , ", but received "
244− , show sc
245− ]) $ i == sc
246− where
247− sc = H.statusCode s
248−
249−assertBody :: L.ByteString -> SResponse -> Session ()
250−assertBody lbs SResponse{simpleBody = lbs'} = assertBool (concat
251− [ "Expected response body "
252− , show $ L8.unpack lbs
253− , ", but received "
254− , show $ L8.unpack lbs'
255− ]) $ lbs == lbs'
256−
257−assertBodyContains :: L.ByteString -> SResponse -> Session ()
258−assertBodyContains lbs SResponse{simpleBody = lbs'} = assertBool (concat
259− [ "Expected response body to contain "
260− , show $ L8.unpack lbs
261− , ", but received "
262− , show $ L8.unpack lbs'
263− ]) $ strict lbs `S.isInfixOf` strict lbs'
264− where
265− strict = S.concat . L.toChunks
266−
267−assertHeader :: CI ByteString -> ByteString -> SResponse -> Session ()
268−assertHeader header value SResponse{simpleHeaders = h} =
269− case lookup header h of
270− Nothing -> assertString $ concat
271− [ "Expected header "
272− , show header
273− , " to be "
274− , show value
275− , ", but it was not present"
276− ]
277− Just value' -> assertBool (concat
278− [ "Expected header "
279− , show header
280− , " to be "
281− , show value
282− , ", but received "
283− , show value'
284− ]) (value == value')
285−
286−assertNoHeader :: CI ByteString -> SResponse -> Session ()
287−assertNoHeader header SResponse{simpleHeaders = h} =
288− case lookup header h of
289− Nothing -> return ()
290− Just s -> assertString $ concat
291− [ "Unexpected header "
292− , show header
293− , " containing "
294− , show s
295− ]
296−
297−-- |
298−--
299−-- Since 3.0.6
300−assertClientCookieExists :: String -> ByteString -> Session ()
301−assertClientCookieExists s cookieName = do
302− cookies <- getClientCookies
303− assertBool s $ Map.member cookieName cookies
304−
305−-- |
306−--
307−-- Since 3.0.6
308−assertNoClientCookieExists :: String -> ByteString -> Session ()
309−assertNoClientCookieExists s cookieName = do
310− cookies <- getClientCookies
311− assertBool s $ not $ Map.member cookieName cookies
312−
313−-- |
314−--
315−-- Since 3.0.6
316−assertClientCookieValue :: String -> ByteString -> ByteString -> Session ()
317−assertClientCookieValue s cookieName cookieValue = do
318− cookies <- getClientCookies
319− case Map.lookup cookieName cookies of
320− Nothing ->
321− assertFailure (s ++ " (cookie does not exist)")
322− Just c ->
323− assertBool
324− (concat
325− [ s
326− , " (actual value "
327− , show $ Cookie.setCookieValue c
328− , " expected value "
329− , show cookieValue
330− , ")"
331− ]
332− )
333− (Cookie.setCookieValue c == cookieValue)
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.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2−{-# LANGUAGE ExistentialQuantification #-}
3−{- | This module gives you a way to mount applications under sub-URIs.
4−For example:
5−
6−> bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application
7−>
8−> myApp :: Application
9−> myApp = mapUrls $
10−> mount "bugs" bugsApp
11−> <|> mount "helpdesk" helpdeskApp
12−> <|> mount "api"
13−> ( mount "v1" apiV1
14−> <|> mount "v2" apiV2
15−> )
16−> <|> mountRoot mainApp
17−
18−-}
19−module Network.Wai.UrlMap (
20− UrlMap',
21− UrlMap,
22− mount',
23− mount,
24− mountRoot,
25− mapUrls
26−) where
27−
28−import Control.Applicative
29−import Data.List
30−import Data.Text (Text)
31−import qualified Data.Text as T
32−import qualified Data.Text.Encoding as T
33−import qualified Data.ByteString as B
34−import Network.HTTP.Types
35−import Network.Wai
36−
37−type Path = [Text]
38−newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }
39−
40−instance Functor UrlMap' where
41− fmap f (UrlMap' xs) = UrlMap' (fmap (\(p, a) -> (p, f a)) xs)
42−
43−instance Applicative UrlMap' where
44− pure x = UrlMap' [([], x)]
45− (UrlMap' xs) <*> (UrlMap' ys) = UrlMap' [ (p, f y) |
46− (p, y) <- ys,
47− f <- map snd xs ]
48−
49−instance Alternative UrlMap' where
50− empty = UrlMap' empty
51− (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)
52−
53−type UrlMap = UrlMap' Application
54−
55−-- | Mount an application under a given path. The ToApplication typeclass gives
56−-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'
57−-- as the second argument.
58−mount' :: ToApplication a => Path -> a -> UrlMap
59−mount' prefix thing = UrlMap' [(prefix, toApplication thing)]
60−
61−-- | A convenience function like mount', but for mounting things under a single
62−-- path segment.
63−mount :: ToApplication a => Text -> a -> UrlMap
64−mount prefix thing = mount' [prefix] thing
65−
66−-- | Mount something at the root. Use this for the last application in the
67−-- block, to avoid 500 errors from none of the applications matching.
68−mountRoot :: ToApplication a => a -> UrlMap
69−mountRoot = mount' []
70−
71−try :: Eq a
72− => [a] -- ^ Path info of request
73− -> [([a], b)] -- ^ List of applications to match
74− -> Maybe ([a], b)
75−try xs tuples = foldl go Nothing tuples
76− where
77− go (Just x) _ = Just x
78− go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)
79−
80−class ToApplication a where
81− toApplication :: a -> Application
82−
83−instance ToApplication Application where
84− toApplication = id
85−
86−instance ToApplication UrlMap where
87− toApplication urlMap req sendResponse =
88− case try (pathInfo req) (unUrlMap urlMap) of
89− Just (newPath, app) ->
90− app (req { pathInfo = newPath
91− , rawPathInfo = makeRaw newPath
92− }) sendResponse
93− Nothing ->
94− sendResponse $ responseLBS
95− status404
96− [(hContentType, "text/plain")]
97− "Not found\n"
98−
99− where
100− makeRaw :: [Text] -> B.ByteString
101− makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
102−
103−mapUrls :: UrlMap -> Application
104−mapUrls = toApplication
wai-extra/READMEnew file+1
@@ -0,0 +1 @@
1+Provides some basic WAI handlers and middleware.
wai-extra/README.mddeleted−16
@@ -1,16 +0,0 @@
1−# wai-extra
2−
3−The 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/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/ApprootSpec.hsdeleted−37
@@ -1,37 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.Middleware.ApprootSpec
3− ( main
4− , spec
5− ) where
6−
7−import Test.Hspec
8−
9−import Network.Wai.Middleware.Approot
10−import Network.Wai.Test
11−import Network.Wai
12−import Network.HTTP.Types
13−import Data.ByteString (ByteString)
14−
15−main :: IO ()
16−main = hspec spec
17−
18−spec :: Spec
19−spec = do
20− let test name host secure headers expected = it name $ do
21− resp <- runApp host secure headers
22− simpleHeaders resp `shouldBe` [("Approot", expected)]
23− test "respects host header" "foobar" False [] "http://foobar"
24− test "respects isSecure" "foobar" True [] "https://foobar"
25− test "respects SSL headers" "foobar" False
26− [("HTTP_X_FORWARDED_SSL", "on")] "https://foobar"
27−
28−runApp :: ByteString -> Bool -> RequestHeaders -> IO SResponse
29−runApp host secure headers = runSession
30− (request defaultRequest
31− { requestHeaderHost = Just host
32− , isSecure = secure
33− , requestHeaders = headers
34− }) $ fromRequest app
35−
36− where
37− app req respond = respond $ responseLBS status200 [("Approot", getApproot req)] ""
wai-extra/test/Network/Wai/Middleware/ForceSSLSpec.hsdeleted−60
@@ -1,60 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.Middleware.ForceSSLSpec
3− ( main
4− , spec
5− ) where
6−
7−import Test.Hspec
8−
9−import Network.Wai.Middleware.ForceSSL
10−
11−import Control.Monad
12−import Data.ByteString (ByteString)
13−import Data.Monoid ((<>))
14−import Network.HTTP.Types (methodPost, status200, status301, status307)
15−import Network.Wai
16−import Network.Wai.Test
17−
18−main :: IO ()
19−main = hspec spec
20−
21−spec :: Spec
22−spec = describe "forceSSL" (forM_ hosts $ \host -> hostSpec host)
23− where
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−
29− it "redirects non-https requests to https" $ do
30− resp <- runApp host forceSSL defaultRequest
31−
32− simpleStatus resp `shouldBe` status301
33− simpleHeaders resp `shouldBe` [("Location", "https://" <> host)]
34−
35− it "redirects with 307 in the case of a non-GET request" $ do
36− resp <- runApp host forceSSL defaultRequest
37− { requestMethod = methodPost }
38−
39− simpleStatus resp `shouldBe` status307
40− simpleHeaders resp `shouldBe` [("Location", "https://" <> host)]
41−
42− it "does not redirect already-secure requests" $ do
43− resp <- runApp host forceSSL defaultRequest { isSecure = True }
44−
45− simpleStatus resp `shouldBe` status200
46−
47− it "preserves the original host, path, and query string" $ do
48− resp <- runApp host forceSSL defaultRequest
49− { rawPathInfo = "/foo/bar"
50− , rawQueryString = "?baz=bat"
51− }
52−
53− simpleHeaders resp `shouldBe`
54− [("Location", "https://" <> host <> "/foo/bar?baz=bat")]
55−
56−runApp :: ByteString -> Middleware -> Request -> IO SResponse
57−runApp host mw req = runSession
58− (request req { requestHeaderHost = Just host }) $ mw app
59− where
60− 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.hsdeleted−294
@@ -1,294 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.ParseSpec (main, spec) where
3−
4−import Test.Hspec
5−import Test.HUnit
6−
7−import System.IO
8−import Data.Monoid
9−import qualified Data.IORef as I
10−import qualified Data.ByteString as S
11−import qualified Data.ByteString.Char8 as S8
12−import qualified Data.ByteString.Lazy as L
13−import qualified Data.Text as TS
14−import qualified Data.Text.Encoding as TE
15−import Control.Monad.Trans.Resource (withInternalState, runResourceT)
16−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )
17−
18−import Network.Wai
19−import Network.Wai.Test
20−import Network.Wai.Parse
21−import WaiExtraSpec (toRequest)
22−
23−main :: IO ()
24−main = hspec spec
25−
26−spec :: Spec
27−spec = do
28− describe "parseContentType" $ do
29− let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)
30− mapM_ go
31− [ ("text/plain", "text/plain", [])
32− , ("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")])
34− , ("text/plain; charset=UTF-8 ; boundary = \"quoted\"", "text/plain", [("charset", "UTF-8"), ("boundary", "quoted")])
35− ]
36− it "parseHttpAccept" caseParseHttpAccept
37− describe "parseRequestBody" $ do
38− caseParseRequestBody
39− it "multipart with plus" caseMultipartPlus
40− it "multipart with multiple attributes" caseMultipartAttrs
41− it "urlencoded with plus" caseUrlEncPlus
42− describe "dalvik multipart" $ do
43− it "non-chunked" $ dalvikHelper True
44− it "chunked" $ dalvikHelper False
45−
46−caseParseHttpAccept :: Assertion
47−caseParseHttpAccept = do
48− let input = "text/plain; q=0.5, text/html;charset=utf-8, text/*;q=0.8;ext=blah, text/x-dvi; q=0.8, text/x-c"
49− expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]
50− expected @=? parseHttpAccept input
51−
52−parseRequestBody' :: BackEnd file
53− -> SRequest
54− -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)])
55−parseRequestBody' sink (SRequest req bod) =
56− case getRequestBodyType req of
57− Nothing -> return ([], [])
58− Just rbt -> do
59− ref <- I.newIORef $ L.toChunks bod
60− let rb = I.atomicModifyIORef ref $ \chunks ->
61− case chunks of
62− [] -> ([], S.empty)
63− x:y -> (y, x)
64− sinkRequestBody sink rbt rb
65−
66−caseParseRequestBody :: Spec
67−caseParseRequestBody = do
68− it "parsing post x-www-form-urlencoded" $ do
69− let content1 = "foo=bar&baz=bin"
70− let ctype1 = "application/x-www-form-urlencoded"
71− result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1
72− result1 `shouldBe` ([("foo", "bar"), ("baz", "bin")], [])
73−
74− let ctype2 = "multipart/form-data; boundary=AaB03x"
75− let expectedsmap2 =
76− [ ("title", "A File")
77− , ("summary", "This is my file\nfile test")
78− ]
79− let textPlain = "text/plain; charset=iso-8859-1"
80− let expectedfile2 =
81− [("document", FileInfo "b.txt" textPlain "This is a file.\nIt has two lines.")]
82− let expected2 = (expectedsmap2, expectedfile2)
83−
84− it "parsing post multipart/form-data" $ do
85− result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2
86− result2 `shouldBe` expected2
87−
88− it "parsing post multipart/form-data 2" $ do
89− result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2
90− result2' `shouldBe` expected2
91−
92−
93− let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
94− let expectedsmap3 = []
95− let expectedfile3 = [("yaml", FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n")]
96− let expected3 = (expectedsmap3, expectedfile3)
97−
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
104− result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
105− result3 `shouldBe` expected3
106−
107− it "parsing actual post multipart/form-data 2" $ do
108− result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
109− 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
166− content2 =
167− "--AaB03x\n"
168− <> "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n"
169− <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
170− <> "This is a file.\n"
171− <> "It has two lines.\n"
172− <> "--AaB03x\n"
173− <> "Content-Disposition: form-data; name=\"title\"\n"
174− <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
175− <> "A File\n"
176− <> "--AaB03x\n"
177− <> "Content-Disposition: form-data; name=\"summary\"\n"
178− <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
179− <> "This is my file\n"
180− <> "file test\n"
181− <> "--AaB03x--"
182− content3 =
183− "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
184− <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"
185− <> "Content-Type: application/octet-stream\r\n\r\n"
186− <> "Photo blog using Hack.\n\r\n"
187− <> "------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−
210−caseMultipartPlus :: Assertion
211−caseMultipartPlus = do
212− result <- parseRequestBody' lbsBackEnd $ toRequest ctype content
213− result @?= ([("email", "has+plus")], [])
214− where
215− content =
216− "--AaB03x\n" <>
217− "Content-Disposition: form-data; name=\"email\"\n" <>
218− "Content-Type: text/plain; charset=iso-8859-1\n\n" <>
219− "has+plus\n" <>
220− "--AaB03x--"
221− ctype = "multipart/form-data; boundary=AaB03x"
222−
223−caseMultipartAttrs :: Assertion
224−caseMultipartAttrs = do
225− result <- parseRequestBody' lbsBackEnd $ toRequest ctype content
226− result @?= ([("email", "has+plus")], [])
227− where
228− content =
229− "--AaB03x\n" <>
230− "Content-Disposition: form-data; name=\"email\"\n" <>
231− "Content-Type: text/plain; charset=iso-8859-1\n\n" <>
232− "has+plus\n" <>
233− "--AaB03x--"
234− ctype = "multipart/form-data; charset=UTF-8; boundary=AaB03x"
235−
236−caseUrlEncPlus :: Assertion
237−caseUrlEncPlus = do
238− result <- runResourceT $ withInternalState $ \state ->
239− parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content
240− result @?= ([("email", "has+plus")], [])
241− where
242− content = "email=has%2Bplus"
243− ctype = "application/x-www-form-urlencoded"
244−
245−dalvikHelper :: Bool -> Assertion
246−dalvikHelper includeLength = do
247− let headers' =
248− [ ("content-type", "multipart/form-data;boundary=*****")
249− , ("GATEWAY_INTERFACE", "CGI/1.1")
250− , ("PATH_INFO", "/")
251− , ("QUERY_STRING", "")
252− , ("REMOTE_ADDR", "192.168.1.115")
253− , ("REMOTE_HOST", "ganjizza")
254− , ("REQUEST_URI", "http://192.168.1.115:3000/")
255− , ("REQUEST_METHOD", "POST")
256− , ("HTTP_CONNECTION", "Keep-Alive")
257− , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
258− , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
259− , ("HTTP_HOST", "192.168.1.115:3000")
260− , ("HTTP_ACCEPT", "*, */*")
261− , ("HTTP_VERSION", "HTTP/1.1")
262− , ("REQUEST_PATH", "/")
263− ]
264− headers
265− | includeLength = ("content-length", "12098") : headers'
266− | otherwise = headers'
267− let request' = defaultRequest
268− { requestHeaders = headers
269− }
270− (params, files) <-
271− case getRequestBodyType request' of
272− Nothing -> return ([], [])
273− Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->
274− sinkRequestBody lbsBackEnd rbt $ S.hGetSome h 2048
275− lookup "scannedTime" params @?= Just "1.298590056748E9"
276− lookup "geoLong" params @?= Just "0"
277− lookup "geoLat" params @?= Just "0"
278− length files @?= 1
279−
280−toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
281−toRequest' ctype content = SRequest defaultRequest
282− { requestHeaders = [("Content-Type", ctype)]
283− } (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.hsdeleted−93
@@ -1,93 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.RequestSpec
3− ( main
4− , spec
5− ) where
6−
7−import Test.Hspec
8−
9−import Data.ByteString (ByteString)
10−import Network.HTTP.Types (HeaderName)
11−import Network.Wai (Request(..), defaultRequest, RequestBodyLength(..))
12−
13−import Network.Wai.Request
14−import Control.Exception (try)
15−import Control.Monad (forever)
16−
17−main :: IO ()
18−main = hspec spec
19−
20−spec :: Spec
21−spec = do
22− describe "requestSizeCheck" $ do
23− it "too large content length should throw RequestSizeException" $ do
24− let limit = 1024
25− largeRequest = 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
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 =
53− [ ("HTTPS", "off")
54− , ("HTTP_X_FORWARDED_SSL", "off")
55− , ("HTTP_X_FORWARDED_SCHEME", "http")
56− , ("HTTP_X_FORWARDED_PROTO", "http,xyz")
57− ]
58− }
59−
60− it "returns False for an insecure request" $
61− insecureRequest `shouldSatisfy` not . appearsSecure
62−
63− it "checks if the Request is actually secure" $ do
64− let req = insecureRequest { isSecure = True }
65−
66− req `shouldSatisfy` appearsSecure
67−
68− it "checks for HTTP: on" $ do
69− let req = addHeader "HTTPS" "on" insecureRequest
70−
71− req `shouldSatisfy` appearsSecure
72−
73− it "checks for HTTP_X_FORWARDED_SSL: on" $ do
74− let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest
75−
76− req `shouldSatisfy` appearsSecure
77−
78− it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do
79− let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest
80−
81− req `shouldSatisfy` appearsSecure
82−
83− it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do
84− let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest
85−
86− req `shouldSatisfy` appearsSecure
87−
88−addHeader :: HeaderName -> ByteString -> Request -> Request
89−addHeader name value req = req
90− { requestHeaders = (name, value) : otherHeaders }
91−
92− where
93− otherHeaders = filter ((/= name) . fst) $ requestHeaders req
wai-extra/test/Network/Wai/TestSpec.hsdeleted−227
@@ -1,227 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Network.Wai.TestSpec (main, spec) where
3−
4−import Control.Monad (void)
5−
6−import qualified Data.IORef as IORef
7−
8−import qualified Data.Text.Encoding as TE
9−
10−import Data.Time.Calendar (fromGregorian)
11−import Data.Time.Clock (UTCTime(..))
12−
13−import Test.Hspec
14−
15−import Network.Wai
16−import Network.Wai.Test
17−
18−import Network.HTTP.Types (status200)
19−
20−import qualified Data.ByteString.Lazy.Char8 as L8
21−import Data.ByteString.Builder (Builder, toLazyByteString)
22−import Data.ByteString (ByteString)
23−
24−import qualified Web.Cookie as Cookie
25−
26−main :: IO ()
27−main = hspec spec
28−
29−toByteString :: Builder -> ByteString
30−toByteString = L8.toStrict . toLazyByteString
31−
32−spec :: Spec
33−spec = do
34− describe "setPath" $ do
35−
36− let req = setPath defaultRequest "/foo/bar/baz?foo=23&bar=42&baz"
37−
38− it "sets pathInfo" $ do
39− pathInfo req `shouldBe` ["foo", "bar", "baz"]
40−
41− it "utf8 path" $
42− pathInfo (setPath defaultRequest "/foo/%D7%A9%D7%9C%D7%95%D7%9D/bar") `shouldBe`
43− ["foo", "שלום", "bar"]
44−
45− it "sets rawPathInfo" $ do
46− rawPathInfo req `shouldBe` "/foo/bar/baz"
47−
48− it "sets queryString" $ do
49− queryString req `shouldBe` [("foo", Just "23"), ("bar", Just "42"), ("baz", Nothing)]
50−
51− it "sets rawQueryString" $ do
52− rawQueryString req `shouldBe` "?foo=23&bar=42&baz"
53−
54− context "when path has no query string" $ do
55− it "sets rawQueryString to empty string" $ do
56− rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""
57−
58− describe "srequest" $ do
59−
60− let echoApp req respond = do
61− reqBody <- L8.fromStrict <$> getRequestBodyChunk req
62− let reqHeaders = requestHeaders req
63− respond $
64− responseLBS
65− status200
66− reqHeaders
67− reqBody
68−
69− it "returns the response body of an echo app" $ do
70− sresp <- flip runSession echoApp $
71− srequest $ SRequest defaultRequest "request body"
72− simpleBody sresp `shouldBe` "request body"
73−
74− describe "request" $ do
75−
76− let echoApp req respond = do
77− reqBody <- L8.fromStrict <$> getRequestBodyChunk req
78− let reqHeaders = requestHeaders req
79− respond $
80− responseLBS
81− status200
82− reqHeaders
83− reqBody
84−
85− it "returns the status code of an echo app on default request" $ do
86− sresp <- runSession (request defaultRequest) echoApp
87− simpleStatus sresp `shouldBe` status200
88−
89− it "returns the response body of an echo app" $ do
90− bodyRef <- IORef.newIORef "request body"
91− let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover)
92− sresp <- flip runSession echoApp $
93− request $
94− defaultRequest
95− { requestBody = getBodyChunk
96− }
97− simpleBody sresp `shouldBe` "request body"
98−
99− it "returns the response headers of an echo app" $ do
100− sresp <- flip runSession echoApp $
101− request $
102− defaultRequest
103− { requestHeaders = [("foo", "bar")]
104− }
105− simpleHeaders sresp `shouldBe` [("foo", "bar")]
106−
107− let cookieApp req respond =
108− case pathInfo req of
109− ["set", name, val] ->
110− respond $
111− responseLBS
112− status200
113− [( "Set-Cookie"
114− , toByteString $ Cookie.renderSetCookie $
115− Cookie.def { Cookie.setCookieName = TE.encodeUtf8 name
116− , Cookie.setCookieValue = TE.encodeUtf8 val
117− }
118− )
119− ]
120− "set_cookie_body"
121− ["delete", name] ->
122− respond $
123− responseLBS
124− status200
125− [( "Set-Cookie"
126− , toByteString $ Cookie.renderSetCookie $
127− Cookie.def { Cookie.setCookieName =
128− TE.encodeUtf8 name
129− , Cookie.setCookieExpires =
130− Just $ UTCTime (fromGregorian 1970 1 1) 0
131− }
132− )
133− ]
134− "set_cookie_body"
135− _ ->
136− respond $
137− responseLBS
138− status200
139− []
140− ( L8.pack
141− $ show
142− $ map snd
143− $ filter ((=="Cookie") . fst)
144− $ requestHeaders req
145− )
146−
147− it "sends a Cookie header with correct value after receiving a Set-Cookie header" $ do
148− sresp <- flip runSession cookieApp $ do
149− void $ request $
150− setPath defaultRequest "/set/cookie_name/cookie_value"
151− request $
152− setPath defaultRequest "/get"
153− simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"
154−
155− it "sends a Cookie header with updated value after receiving a Set-Cookie header update" $ do
156− sresp <- flip runSession cookieApp $ do
157− void $ request $
158− setPath defaultRequest "/set/cookie_name/cookie_value"
159− void $ request $
160− setPath defaultRequest "/set/cookie_name/cookie_value2"
161− request $
162− setPath defaultRequest "/get"
163− simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]"
164−
165− it "handles multiple cookies" $ do
166− sresp <- flip runSession cookieApp $ do
167− void $ request $
168− setPath defaultRequest "/set/cookie_name/cookie_value"
169− void $ request $
170− setPath defaultRequest "/set/cookie_name2/cookie_value2"
171− request $
172− setPath defaultRequest "/get"
173− simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value;cookie_name2=cookie_value2\"]"
174−
175− it "removes a deleted cookie" $ do
176− sresp <- flip runSession cookieApp $ do
177− void $ request $
178− setPath defaultRequest "/set/cookie_name/cookie_value"
179− void $ request $
180− setPath defaultRequest "/set/cookie_name2/cookie_value2"
181− void $ request $
182− setPath defaultRequest "/delete/cookie_name2"
183− request $
184− setPath defaultRequest "/get"
185− simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"
186−
187− it "sends a cookie set with setClientCookie to server" $ do
188− sresp <- flip runSession cookieApp $ do
189− setClientCookie
190− (Cookie.def { Cookie.setCookieName = "cookie_name"
191− , Cookie.setCookieValue = "cookie_value"
192− }
193− )
194− request $
195− setPath defaultRequest "/get"
196− simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value\"]"
197−
198− it "sends a cookie updated with setClientCookie to server" $ do
199− sresp <- flip runSession cookieApp $ do
200− setClientCookie
201− (Cookie.def { Cookie.setCookieName = "cookie_name"
202− , Cookie.setCookieValue = "cookie_value"
203− }
204− )
205− setClientCookie
206− (Cookie.def { Cookie.setCookieName = "cookie_name"
207− , Cookie.setCookieValue = "cookie_value2"
208− }
209− )
210− request $
211− setPath defaultRequest "/get"
212− simpleBody sresp `shouldBe` "[\"cookie_name=cookie_value2\"]"
213−
214− it "does not send a cookie deleted with deleteClientCookie to server" $ do
215− sresp <- flip runSession cookieApp $ do
216− setClientCookie
217− (Cookie.def { Cookie.setCookieName = "cookie_name"
218− , Cookie.setCookieValue = "cookie_value"
219− }
220− )
221− deleteClientCookie "cookie_name"
222− request $
223− setPath defaultRequest "/get"
224− simpleBody sresp `shouldBe` "[]"
225−
226−
227−
wai-extra/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
wai-extra/test/WaiExtraSpec.hsdeleted−451
@@ -1,451 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module WaiExtraSpec (spec, toRequest) where
4−
5−import Test.Hspec
6−import Test.HUnit hiding (Test)
7−#if MIN_VERSION_base(4,8,0)
8−import Data.Monoid ((<>))
9−#else
10−import Data.Monoid (mempty, mappend, (<>))
11−#endif
12−
13−import Network.Wai
14−import Network.Wai.Test
15−import Network.Wai.UrlMap
16−import qualified Data.ByteString as S
17−import qualified Data.ByteString.Char8 as S8
18−import qualified Data.ByteString.Lazy as L
19−import qualified Data.Text.Lazy as T
20−import qualified Data.Text as TS
21−import qualified Data.Text.Encoding as TE
22−import Control.Applicative
23−
24−import Network.Wai.Middleware.Jsonp
25−import Network.Wai.Middleware.Gzip
26−import Network.Wai.Middleware.Vhost
27−import Network.Wai.Middleware.Autohead
28−import Network.Wai.Middleware.MethodOverride
29−import Network.Wai.Middleware.MethodOverridePost
30−import Network.Wai.Middleware.AcceptOverride
31−import Network.Wai.Middleware.RequestLogger
32−import Codec.Compression.GZip (decompress)
33−import Network.Wai.Middleware.StreamFile
34−
35−import Control.Monad.IO.Class (liftIO)
36−import Data.Maybe (fromMaybe)
37−import Network.HTTP.Types (status200)
38−import System.Log.FastLogger
39−
40−import qualified Data.IORef as I
41−
42−spec :: Spec
43−spec = do
44− describe "Network.Wai.UrlMap" $ do
45− mapM_ (uncurry it) casesUrlMap
46−
47− describe "Network.Wai" $ do
48− {-
49− , it "findBound" caseFindBound
50− , it "sinkTillBound" caseSinkTillBound
51− , it "killCR" caseKillCR
52− , it "killCRLF" caseKillCRLF
53− , it "takeLine" caseTakeLine
54− -}
55− it "jsonp" caseJsonp
56− it "gzip" caseGzip
57− it "gzip not for MSIE" caseGzipMSIE
58− it "gzip bypass when precompressed" caseGzipBypassPre
59− it "defaultCheckMime" caseDefaultCheckMime
60− it "vhost" caseVhost
61− it "autohead" caseAutohead
62− it "method override" caseMethodOverride
63− it "method override post" caseMethodOverridePost
64− it "accept override" caseAcceptOverride
65− it "debug request body" caseDebugRequestBody
66− it "stream file" caseStreamFile
67− it "stream LBS" caseStreamLBS
68−
69−toRequest :: S8.ByteString -> S8.ByteString -> SRequest
70−toRequest ctype content = SRequest defaultRequest
71− { requestHeaders = [("Content-Type", ctype)]
72− , requestMethod = "POST"
73− , rawPathInfo = "/"
74− , rawQueryString = ""
75− , queryString = []
76− } (L.fromChunks [content])
77−
78−{-
79−caseFindBound :: Assertion
80−caseFindBound = do
81− findBound "def" "abcdefghi" @?=
82− FoundBound "abc" "ghi"
83− findBound "def" "ABC" @?= NoBound
84− findBound "def" "abcd" @?= PartialBound
85− findBound "def" "abcdE" @?= NoBound
86− findBound "def" "abcdEdef" @?=
87− FoundBound "abcdE" ""
88−
89−caseSinkTillBound :: Assertion
90−caseSinkTillBound = do
91− let iter () _ = return ()
92− let src = "this is some text"
93− bound1 = "some"
94− bound2 = "some!"
95− let enum = enumList 1 [src]
96− let helper _ _ = return ()
97− (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
98− res1 @?= True
99− (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
100− res2 @?= False
101−
102−caseKillCR :: Assertion
103−caseKillCR = do
104− "foo" @=? killCR "foo"
105− "foo" @=? killCR "foo\r"
106− "foo\r\n" @=? killCR "foo\r\n"
107− "foo\r'" @=? killCR "foo\r'"
108−
109−caseKillCRLF :: Assertion
110−caseKillCRLF = do
111− "foo" @=? killCRLF "foo"
112− "foo\r" @=? killCRLF "foo\r"
113− "foo" @=? killCRLF "foo\r\n"
114− "foo\r'" @=? killCRLF "foo\r'"
115− "foo" @=? killCRLF "foo\n"
116−
117−caseTakeLine :: Assertion
118−caseTakeLine = do
119− helper "foo\nbar\nbaz" "foo"
120− helper "foo\r\nbar\nbaz" "foo"
121− helper "foo\nbar\r\nbaz" "foo"
122− helper "foo\rbar\r\nbaz" "foo\rbar"
123− where
124− helper haystack needle = do
125− x <- run_ $ enumList 1 [haystack] $$ takeLine
126− Just needle @=? x
127−-}
128−
129−jsonpApp :: Application
130−jsonpApp = jsonp $ \_ f -> f $ responseLBS
131− status200
132− [("Content-Type", "application/json")]
133− "{\"foo\":\"bar\"}"
134−
135−caseJsonp :: Assertion
136−caseJsonp = flip runSession jsonpApp $ do
137− sres1 <- request defaultRequest
138− { queryString = [("callback", Just "test")]
139− , requestHeaders = [("Accept", "text/javascript")]
140− }
141− assertContentType "text/javascript" sres1
142− assertBody "test({\"foo\":\"bar\"})" sres1
143−
144− sres2 <- request defaultRequest
145− { queryString = [("call_back", Just "test")]
146− , requestHeaders = [("Accept", "text/javascript")]
147− }
148− assertContentType "application/json" sres2
149− assertBody "{\"foo\":\"bar\"}" sres2
150−
151− sres3 <- request defaultRequest
152− { queryString = [("callback", Just "test")]
153− , requestHeaders = [("Accept", "text/html")]
154− }
155− assertContentType "application/json" sres3
156− assertBody "{\"foo\":\"bar\"}" sres3
157−
158−gzipApp :: Application
159−gzipApp = gzip def $ \_ f -> f $ responseLBS status200
160− [("Content-Type", "text/plain")]
161− "test"
162−
163−-- Lie a little and don't compress the body. This way we test
164−-- that the compression is skipped based on the presence of
165−-- the Content-Encoding header.
166−gzipPrecompressedApp :: Application
167−gzipPrecompressedApp = gzip def $ \_ f -> f $ responseLBS status200
168− [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]
169− "test"
170−
171−caseGzip :: Assertion
172−caseGzip = flip runSession gzipApp $ do
173− sres1 <- request defaultRequest
174− { requestHeaders = [("Accept-Encoding", "gzip")]
175− }
176− assertHeader "Content-Encoding" "gzip" sres1
177− liftIO $ decompress (simpleBody sres1) @?= "test"
178−
179− sres2 <- request defaultRequest
180− { requestHeaders = []
181− }
182− assertNoHeader "Content-Encoding" sres2
183− assertBody "test" sres2
184−
185−caseDefaultCheckMime :: Assertion
186−caseDefaultCheckMime = do
187− let go x y = (x, defaultCheckMime x) `shouldBe` (x, y)
188− go "application/json" True
189− go "application/javascript" True
190− go "application/something" False
191− go "text/something" True
192− go "foo/bar" False
193− go "application/json; charset=utf-8" True
194−
195−caseGzipMSIE :: Assertion
196−caseGzipMSIE = flip runSession gzipApp $ do
197− sres1 <- request defaultRequest
198− { requestHeaders =
199− [ ("Accept-Encoding", "gzip")
200− , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
201− ]
202− }
203− assertNoHeader "Content-Encoding" sres1
204− liftIO $ simpleBody sres1 @?= "test"
205−
206−caseGzipBypassPre :: Assertion
207−caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do
208− sres1 <- request defaultRequest
209− { requestHeaders = [("Accept-Encoding", "gzip")]
210− }
211− assertHeader "Content-Encoding" "gzip" sres1
212− assertBody "test" sres1 -- the body is not actually compressed
213−
214−vhostApp1, vhostApp2, vhostApp :: Application
215−vhostApp1 _ f = f $ responseLBS status200 [] "app1"
216−vhostApp2 _ f = f $ responseLBS status200 [] "app2"
217−vhostApp = vhost
218− [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)
219− ]
220− vhostApp2
221−
222−caseVhost :: Assertion
223−caseVhost = flip runSession vhostApp $ do
224− sres1 <- request defaultRequest
225− { requestHeaders = [("Host", "foo.com")]
226− }
227− assertBody "app1" sres1
228−
229− sres2 <- request defaultRequest
230− { requestHeaders = [("Host", "bar.com")]
231− }
232− assertBody "app2" sres2
233−
234−autoheadApp :: Application
235−autoheadApp = autohead $ \_ f -> f $ responseLBS status200
236− [("Foo", "Bar")] "body"
237−
238−caseAutohead :: Assertion
239−caseAutohead = flip runSession autoheadApp $ do
240− sres1 <- request defaultRequest
241− { requestMethod = "GET"
242− }
243− assertHeader "Foo" "Bar" sres1
244− assertBody "body" sres1
245−
246− sres2 <- request defaultRequest
247− { requestMethod = "HEAD"
248− }
249− assertHeader "Foo" "Bar" sres2
250− assertBody "" sres2
251−
252−moApp :: Application
253−moApp = methodOverride $ \req f -> f $ responseLBS status200
254− [("Method", requestMethod req)] ""
255−
256−caseMethodOverride :: Assertion
257−caseMethodOverride = flip runSession moApp $ do
258− sres1 <- request defaultRequest
259− { requestMethod = "GET"
260− , queryString = []
261− }
262− assertHeader "Method" "GET" sres1
263−
264− sres2 <- request defaultRequest
265− { requestMethod = "POST"
266− , queryString = []
267− }
268− assertHeader "Method" "POST" sres2
269−
270− sres3 <- request defaultRequest
271− { requestMethod = "POST"
272− , queryString = [("_method", Just "PUT")]
273− }
274− assertHeader "Method" "PUT" sres3
275−
276−mopApp :: Application
277−mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] ""
278−
279−caseMethodOverridePost :: Assertion
280−caseMethodOverridePost = flip runSession mopApp $ do
281−
282− -- Get Request are unmodified
283− sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
284− s = simpleRequest r
285− m = s { requestMethod = "GET" }
286− b = r { simpleRequest = m }
287− in srequest b
288− assertHeader "Method" "GET" sres1
289−
290− -- Post requests are modified if _method comes first
291− sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
292− assertHeader "Method" "PUT" sres2
293−
294− -- Post requests are unmodified if _method doesn't come first
295− sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"
296− assertHeader "Method" "POST" sres3
297−
298− -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded"
299− sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin"
300− assertHeader "Method" "POST" sres4
301−
302−aoApp :: Application
303−aoApp = acceptOverride $ \req f -> f $ responseLBS status200
304− [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
305−
306−caseAcceptOverride :: Assertion
307−caseAcceptOverride = flip runSession aoApp $ do
308− sres1 <- request defaultRequest
309− { queryString = []
310− , requestHeaders = [("Accept", "foo")]
311− }
312− assertHeader "Accept" "foo" sres1
313−
314− sres2 <- request defaultRequest
315− { queryString = []
316− , requestHeaders = [("Accept", "bar")]
317− }
318− assertHeader "Accept" "bar" sres2
319−
320− sres3 <- request defaultRequest
321− { queryString = [("_accept", Just "baz")]
322− , requestHeaders = [("Accept", "bar")]
323− }
324− assertHeader "Accept" "baz" sres3
325−
326−caseDebugRequestBody :: Assertion
327−caseDebugRequestBody = do
328− flip runSession (debugApp postOutput) $ do
329− let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin"
330− res <- srequest req
331− assertStatus 200 res
332−
333− let qs = "?foo=bar&baz=bin"
334− flip runSession (debugApp $ getOutput params) $ do
335− assertStatus 200 =<< request defaultRequest
336− { requestMethod = "GET"
337− , queryString = map (\(k,v) -> (k, Just v)) params
338− , rawQueryString = qs
339− , requestHeaders = []
340− , rawPathInfo = "/location"
341− }
342− where
343− params = [("foo", "bar"), ("baz", "bin")]
344− -- the time cannot be known, so match around it
345− postOutput = (T.pack $ "POST /\n Params: " ++ (show params), "s\n")
346− getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n")
347−
348− debugApp (beginning, ending) req send = do
349− iactual <- I.newIORef mempty
350− middleware <- mkRequestLogger def
351− { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)
352− , outputFormat = Detailed False
353− }
354− res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send
355− actual <- logToBs <$> I.readIORef iactual
356− actual `shouldSatisfy` S.isPrefixOf begin
357− actual `shouldSatisfy` S.isSuffixOf end
358−
359− return res
360− where
361− begin = TE.encodeUtf8 $ T.toStrict beginning
362− end = TE.encodeUtf8 $ T.toStrict ending
363−
364− logToBs = fromLogStr
365−
366− {-debugApp = debug $ \req -> do-}
367− {-return $ responseLBS status200 [ ] ""-}
368−
369−urlMapTestApp :: Application
370−urlMapTestApp = mapUrls $
371− mount "bugs" bugsApp
372− <|> mount "helpdesk" helpdeskApp
373− <|> mount "api"
374− ( mount "v1" apiV1
375− <|> mount "v2" apiV2
376− )
377− <|> mountRoot mainApp
378−
379− where
380− trivialApp :: S.ByteString -> Application
381− trivialApp name req f =
382− f $
383− responseLBS
384− status200
385− [ ("content-type", "text/plain")
386− , ("X-pathInfo", S8.pack . show . pathInfo $ req)
387− , ("X-rawPathInfo", rawPathInfo req)
388− , ("X-appName", name)
389− ]
390− ""
391−
392− bugsApp = trivialApp "bugs"
393− helpdeskApp = trivialApp "helpdesk"
394− apiV1 = trivialApp "apiv1"
395− apiV2 = trivialApp "apiv2"
396− mainApp = trivialApp "main"
397−
398−casesUrlMap :: [(String, Assertion)]
399−casesUrlMap = [pair1, pair2, pair3, pair4]
400− where
401− makePair name session = (name, runSession session urlMapTestApp)
402− get reqPath = request $ setPath defaultRequest reqPath
403− s = S8.pack . show :: [TS.Text] -> S.ByteString
404−
405− pair1 = makePair "should mount root" $ do
406− res1 <- get "/"
407− assertStatus 200 res1
408− assertHeader "X-rawPathInfo" "/" res1
409− assertHeader "X-pathInfo" (s []) res1
410− assertHeader "X-appName" "main" res1
411−
412− pair2 = makePair "should mount apps" $ do
413− res2 <- get "/bugs"
414− assertStatus 200 res2
415− assertHeader "X-rawPathInfo" "/" res2
416− assertHeader "X-pathInfo" (s []) res2
417− assertHeader "X-appName" "bugs" res2
418−
419− pair3 = makePair "should preserve extra path info" $ do
420− res3 <- get "/helpdesk/issues/11"
421− assertStatus 200 res3
422− assertHeader "X-rawPathInfo" "/issues/11" res3
423− assertHeader "X-pathInfo" (s ["issues", "11"]) res3
424−
425− pair4 = makePair "should 404 if none match" $ do
426− res4 <- get "/api/v3"
427− assertStatus 404 res4
428−
429−testFile :: FilePath
430−testFile = "test/WaiExtraSpec.hs"
431−
432−streamFileApp :: Application
433−streamFileApp = streamFile $ \_ f -> f $ responseFile status200 [] testFile Nothing
434−
435−caseStreamFile :: Assertion
436−caseStreamFile = flip runSession streamFileApp $ do
437− sres <- request defaultRequest
438− assertStatus 200 sres
439− assertBodyContains "caseStreamFile" sres
440− assertNoHeader "Transfer-Encoding" sres
441−
442−streamLBSApp :: Application
443−streamLBSApp = streamFile $ \_ f -> f $ responseLBS status200
444− [("Content-Type", "text/plain")]
445− "test"
446−
447−caseStreamLBS :: Assertion
448−caseStreamLBS = flip runSession streamLBSApp $ do
449− sres <- request defaultRequest
450− assertStatus 200 sres
451− assertBody "test" sres
wai-extra/test/WaiExtraTest.hsnew file+442
@@ -0,0 +1,442 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module WaiExtraTest (specs) where
3+
4+import Test.Hspec.Monadic
5+import Test.Hspec.HUnit ()
6+import Test.HUnit hiding (Test)
7+
8+import Network.Wai
9+import Network.Wai.Test
10+import Network.Wai.Parse
11+import qualified Data.ByteString as S
12+import qualified Data.ByteString.Char8 as S8
13+import qualified Data.ByteString.Lazy.Char8 as L8
14+import qualified Data.ByteString.Lazy as L
15+import qualified Data.Text.Lazy as T
16+import qualified Data.Text.Encoding as TE
17+import Control.Arrow
18+
19+import Network.Wai.Middleware.Jsonp
20+import Network.Wai.Middleware.Gzip
21+import Network.Wai.Middleware.Vhost
22+import Network.Wai.Middleware.Autohead
23+import Network.Wai.Middleware.MethodOverride
24+import Network.Wai.Middleware.AcceptOverride
25+import Network.Wai.Middleware.RequestLogger (logCallback)
26+import Codec.Compression.GZip (decompress)
27+
28+import qualified Data.Conduit as C
29+import qualified Data.Conduit.List as CL
30+import Data.Conduit.Binary (sourceFile)
31+import Control.Monad.IO.Class (liftIO)
32+import Data.Maybe (fromMaybe)
33+import Network.HTTP.Types (parseSimpleQuery, status200)
34+import Data.Monoid (mappend)
35+
36+specs :: Specs
37+specs = do
38+ describe "Network.Wai.Parse" $ do
39+ it "parseQueryString" caseParseQueryString
40+ it "parseQueryString with question mark" caseParseQueryStringQM
41+ it "parseHttpAccept" caseParseHttpAccept
42+ it "parseRequestBody" caseParseRequestBody
43+ {-
44+ , it "findBound" caseFindBound
45+ , it "sinkTillBound" caseSinkTillBound
46+ , it "killCR" caseKillCR
47+ , it "killCRLF" caseKillCRLF
48+ , it "takeLine" caseTakeLine
49+ -}
50+ it "jsonp" caseJsonp
51+ it "gzip" caseGzip
52+ it "gzip not for MSIE" caseGzipMSIE
53+ it "vhost" caseVhost
54+ it "autohead" caseAutohead
55+ it "method override" caseMethodOverride
56+ it "accept override" caseAcceptOverride
57+ it "dalvik multipart" caseDalvikMultipart
58+ it "debug request body" caseDebugRequestBody
59+
60+caseParseQueryString :: Assertion
61+caseParseQueryString = do
62+ let go l r =
63+ map (S8.pack *** S8.pack) l @=? parseSimpleQuery (S8.pack r)
64+
65+ go [] ""
66+ go [("foo", "")] "foo"
67+ go [("foo", "bar")] "foo=bar"
68+ go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
69+ go [("%Q", "")] "%Q"
70+ go [("%1Q", "")] "%1Q"
71+ go [("%1", "")] "%1"
72+ go [("/", "")] "%2F"
73+ go [("/", "")] "%2f"
74+ go [("foo bar", "")] "foo+bar"
75+
76+caseParseQueryStringQM :: Assertion
77+caseParseQueryStringQM = do
78+ let go l r =
79+ map (S8.pack *** S8.pack) l
80+ @=? parseSimpleQuery (S8.pack $ '?' : r)
81+
82+ go [] ""
83+ go [("foo", "")] "foo"
84+ go [("foo", "bar")] "foo=bar"
85+ go [("foo", "bar"), ("baz", "bin")] "foo=bar&baz=bin"
86+ go [("%Q", "")] "%Q"
87+ go [("%1Q", "")] "%1Q"
88+ go [("%1", "")] "%1"
89+ go [("/", "")] "%2F"
90+ go [("/", "")] "%2f"
91+ go [("foo bar", "")] "foo+bar"
92+
93+caseParseHttpAccept :: Assertion
94+caseParseHttpAccept = do
95+ let input = "text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
96+ expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
97+ expected @=? parseHttpAccept input
98+
99+parseRequestBody' :: BackEnd L.ByteString
100+ -> SRequest
101+ -> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])
102+parseRequestBody' sink (SRequest req bod) =
103+ case getRequestBodyType req of
104+ Nothing -> return ([], [])
105+ Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt
106+
107+caseParseRequestBody :: Assertion
108+caseParseRequestBody =
109+ C.runResourceT t
110+ where
111+ content2 = S8.pack $
112+ "--AaB03x\n" ++
113+ "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
114+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
115+ "This is a file.\n" ++
116+ "It has two lines.\n" ++
117+ "--AaB03x\n" ++
118+ "Content-Disposition: form-data; name=\"title\"\n" ++
119+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
120+ "A File\n" ++
121+ "--AaB03x\n" ++
122+ "Content-Disposition: form-data; name=\"summary\"\n" ++
123+ "Content-Type: text/plain; charset=iso-8859-1\n\n" ++
124+ "This is my file\n" ++
125+ "file test\n" ++
126+ "--AaB03x--"
127+ content3 = S8.pack "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\nContent-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\nContent-Type: application/octet-stream\r\n\r\nPhoto blog using Hack.\n\r\n------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
128+ t = do
129+ let content1 = "foo=bar&baz=bin"
130+ let ctype1 = "application/x-www-form-urlencoded"
131+ result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1
132+ liftIO $ assertEqual "parsing post x-www-form-urlencoded"
133+ (map (S8.pack *** S8.pack) [("foo", "bar"), ("baz", "bin")], [])
134+ result1
135+
136+ let ctype2 = "multipart/form-data; boundary=AaB03x"
137+ result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2
138+ let expectedsmap2 =
139+ [ ("title", "A File")
140+ , ("summary", "This is my file\nfile test")
141+ ]
142+ let textPlain = S8.pack $ "text/plain; charset=iso-8859-1"
143+ let expectedfile2 =
144+ [(S8.pack "document", FileInfo (S8.pack "b.txt") textPlain $ L8.pack
145+ "This is a file.\nIt has two lines.")]
146+ let expected2 = (map (S8.pack *** S8.pack) expectedsmap2, expectedfile2)
147+ liftIO $ assertEqual "parsing post multipart/form-data"
148+ expected2
149+ result2
150+
151+ let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
152+ result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
153+ let expectedsmap3 = []
154+ let expectedfile3 = [(S8.pack "yaml", FileInfo (S8.pack "README") (S8.pack "application/octet-stream") $
155+ L8.pack "Photo blog using Hack.\n")]
156+ let expected3 = (expectedsmap3, expectedfile3)
157+ liftIO $ assertEqual "parsing actual post multipart/form-data"
158+ expected3
159+ result3
160+
161+ result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2
162+ liftIO $ assertEqual "parsing post multipart/form-data 2"
163+ expected2
164+ result2'
165+
166+ result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
167+ liftIO $ assertEqual "parsing actual post multipart/form-data 2"
168+ expected3
169+ result3'
170+
171+toRequest :: S8.ByteString -> S8.ByteString -> SRequest
172+toRequest ctype content = SRequest defaultRequest
173+ { requestHeaders = [("Content-Type", ctype)]
174+ , requestMethod = "POST"
175+ , rawPathInfo = "/"
176+ , rawQueryString = ""
177+ , queryString = []
178+ } (L.fromChunks [content])
179+
180+toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
181+toRequest' ctype content = SRequest defaultRequest
182+ { requestHeaders = [("Content-Type", ctype)]
183+ } (L.fromChunks $ map S.singleton $ S.unpack content)
184+
185+{-
186+caseFindBound :: Assertion
187+caseFindBound = do
188+ findBound (S8.pack "def") (S8.pack "abcdefghi") @?=
189+ FoundBound (S8.pack "abc") (S8.pack "ghi")
190+ findBound (S8.pack "def") (S8.pack "ABC") @?= NoBound
191+ findBound (S8.pack "def") (S8.pack "abcd") @?= PartialBound
192+ findBound (S8.pack "def") (S8.pack "abcdE") @?= NoBound
193+ findBound (S8.pack "def") (S8.pack "abcdEdef") @?=
194+ FoundBound (S8.pack "abcdE") (S8.pack "")
195+
196+caseSinkTillBound :: Assertion
197+caseSinkTillBound = do
198+ let iter () _ = return ()
199+ let src = S8.pack "this is some text"
200+ bound1 = S8.pack "some"
201+ bound2 = S8.pack "some!"
202+ let enum = enumList 1 [src]
203+ let helper _ _ = return ()
204+ (_, res1) <- run_ $ enum $$ sinkTillBound bound1 helper ()
205+ res1 @?= True
206+ (_, res2) <- run_ $ enum $$ sinkTillBound bound2 helper ()
207+ res2 @?= False
208+
209+caseKillCR :: Assertion
210+caseKillCR = do
211+ "foo" @=? killCR "foo"
212+ "foo" @=? killCR "foo\r"
213+ "foo\r\n" @=? killCR "foo\r\n"
214+ "foo\r'" @=? killCR "foo\r'"
215+
216+caseKillCRLF :: Assertion
217+caseKillCRLF = do
218+ "foo" @=? killCRLF "foo"
219+ "foo\r" @=? killCRLF "foo\r"
220+ "foo" @=? killCRLF "foo\r\n"
221+ "foo\r'" @=? killCRLF "foo\r'"
222+ "foo" @=? killCRLF "foo\n"
223+
224+caseTakeLine :: Assertion
225+caseTakeLine = do
226+ helper "foo\nbar\nbaz" "foo"
227+ helper "foo\r\nbar\nbaz" "foo"
228+ helper "foo\nbar\r\nbaz" "foo"
229+ helper "foo\rbar\r\nbaz" "foo\rbar"
230+ where
231+ helper haystack needle = do
232+ x <- run_ $ enumList 1 [haystack] $$ takeLine
233+ Just needle @=? x
234+-}
235+
236+jsonpApp :: Application
237+jsonpApp = jsonp $ const $ return $ responseLBS
238+ status200
239+ [("Content-Type", "application/json")]
240+ "{\"foo\":\"bar\"}"
241+
242+caseJsonp :: Assertion
243+caseJsonp = flip runSession jsonpApp $ do
244+ sres1 <- request defaultRequest
245+ { queryString = [("callback", Just "test")]
246+ , requestHeaders = [("Accept", "text/javascript")]
247+ }
248+ assertContentType "text/javascript" sres1
249+ assertBody "test({\"foo\":\"bar\"})" sres1
250+
251+ sres2 <- request defaultRequest
252+ { queryString = [("call_back", Just "test")]
253+ , requestHeaders = [("Accept", "text/javascript")]
254+ }
255+ assertContentType "application/json" sres2
256+ assertBody "{\"foo\":\"bar\"}" sres2
257+
258+ sres3 <- request defaultRequest
259+ { queryString = [("callback", Just "test")]
260+ , requestHeaders = [("Accept", "text/html")]
261+ }
262+ assertContentType "application/json" sres3
263+ assertBody "{\"foo\":\"bar\"}" sres3
264+
265+gzipApp :: Application
266+gzipApp = gzip def $ const $ return $ responseLBS status200
267+ [("Content-Type", "text/plain")]
268+ "test"
269+
270+caseGzip :: Assertion
271+caseGzip = flip runSession gzipApp $ do
272+ sres1 <- request defaultRequest
273+ { requestHeaders = [("Accept-Encoding", "gzip")]
274+ }
275+ assertHeader "Content-Encoding" "gzip" sres1
276+ liftIO $ decompress (simpleBody sres1) @?= "test"
277+
278+ sres2 <- request defaultRequest
279+ { requestHeaders = []
280+ }
281+ assertNoHeader "Content-Encoding" sres2
282+ assertBody "test" sres2
283+
284+caseGzipMSIE :: Assertion
285+caseGzipMSIE = flip runSession gzipApp $ do
286+ sres1 <- request defaultRequest
287+ { requestHeaders =
288+ [ ("Accept-Encoding", "gzip")
289+ , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")
290+ ]
291+ }
292+ assertNoHeader "Content-Encoding" sres1
293+ liftIO $ simpleBody sres1 @?= "test"
294+
295+vhostApp1, vhostApp2, vhostApp :: Application
296+vhostApp1 = const $ return $ responseLBS status200 [] "app1"
297+vhostApp2 = const $ return $ responseLBS status200 [] "app2"
298+vhostApp = vhost
299+ [ ((== "foo.com") . serverName, vhostApp1)
300+ ]
301+ vhostApp2
302+
303+caseVhost :: Assertion
304+caseVhost = flip runSession vhostApp $ do
305+ sres1 <- request defaultRequest
306+ { serverName = "foo.com"
307+ }
308+ assertBody "app1" sres1
309+
310+ sres2 <- request defaultRequest
311+ { serverName = "bar.com"
312+ }
313+ assertBody "app2" sres2
314+
315+autoheadApp :: Application
316+autoheadApp = autohead $ const $ return $ responseLBS status200
317+ [("Foo", "Bar")] "body"
318+
319+caseAutohead :: Assertion
320+caseAutohead = flip runSession autoheadApp $ do
321+ sres1 <- request defaultRequest
322+ { requestMethod = "GET"
323+ }
324+ assertHeader "Foo" "Bar" sres1
325+ assertBody "body" sres1
326+
327+ sres2 <- request defaultRequest
328+ { requestMethod = "HEAD"
329+ }
330+ assertHeader "Foo" "Bar" sres2
331+ assertBody "" sres2
332+
333+moApp :: Application
334+moApp = methodOverride $ \req -> return $ responseLBS status200
335+ [("Method", requestMethod req)] ""
336+
337+caseMethodOverride :: Assertion
338+caseMethodOverride = flip runSession moApp $ do
339+ sres1 <- request defaultRequest
340+ { requestMethod = "GET"
341+ , queryString = []
342+ }
343+ assertHeader "Method" "GET" sres1
344+
345+ sres2 <- request defaultRequest
346+ { requestMethod = "POST"
347+ , queryString = []
348+ }
349+ assertHeader "Method" "POST" sres2
350+
351+ sres3 <- request defaultRequest
352+ { requestMethod = "POST"
353+ , queryString = [("_method", Just "PUT")]
354+ }
355+ assertHeader "Method" "PUT" sres3
356+
357+aoApp :: Application
358+aoApp = acceptOverride $ \req -> return $ responseLBS status200
359+ [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
360+
361+caseAcceptOverride :: Assertion
362+caseAcceptOverride = flip runSession aoApp $ do
363+ sres1 <- request defaultRequest
364+ { queryString = []
365+ , requestHeaders = [("Accept", "foo")]
366+ }
367+ assertHeader "Accept" "foo" sres1
368+
369+ sres2 <- request defaultRequest
370+ { queryString = []
371+ , requestHeaders = [("Accept", "bar")]
372+ }
373+ assertHeader "Accept" "bar" sres2
374+
375+ sres3 <- request defaultRequest
376+ { queryString = [("_accept", Just "baz")]
377+ , requestHeaders = [("Accept", "bar")]
378+ }
379+ assertHeader "Accept" "baz" sres3
380+
381+caseDalvikMultipart :: Assertion
382+caseDalvikMultipart = do
383+ let headers =
384+ [ ("content-length", "12098")
385+ , ("content-type", "multipart/form-data;boundary=*****")
386+ , ("GATEWAY_INTERFACE", "CGI/1.1")
387+ , ("PATH_INFO", "/")
388+ , ("QUERY_STRING", "")
389+ , ("REMOTE_ADDR", "192.168.1.115")
390+ , ("REMOTE_HOST", "ganjizza")
391+ , ("REQUEST_URI", "http://192.168.1.115:3000/")
392+ , ("REQUEST_METHOD", "POST")
393+ , ("HTTP_CONNECTION", "Keep-Alive")
394+ , ("HTTP_COOKIE", "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD")
395+ , ("HTTP_USER_AGENT", "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)")
396+ , ("HTTP_HOST", "192.168.1.115:3000")
397+ , ("HTTP_ACCEPT", "*, */*")
398+ , ("HTTP_VERSION", "HTTP/1.1")
399+ , ("REQUEST_PATH", "/")
400+ ]
401+ let request' = defaultRequest
402+ { requestHeaders = headers
403+ }
404+ (params, files) <-
405+ case getRequestBodyType request' of
406+ Nothing -> return ([], [])
407+ Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request"
408+ C.$$ sinkRequestBody lbsBackEnd rbt
409+ lookup "scannedTime" params @?= Just "1.298590056748E9"
410+ lookup "geoLong" params @?= Just "0"
411+ lookup "geoLat" params @?= Just "0"
412+ length files @?= 1
413+
414+caseDebugRequestBody :: Assertion
415+caseDebugRequestBody = do
416+ flip runSession (debugApp postOutput) $ do
417+ let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin"
418+ res <- srequest req
419+ assertStatus 200 res
420+
421+ let qs = "?foo=bar&baz=bin"
422+ flip runSession (debugApp $ getOutput qs) $ do
423+ assertStatus 200 =<< request defaultRequest
424+ { requestMethod = "GET"
425+ , queryString = map (\(k,v) -> (k, Just v)) params
426+ , rawQueryString = qs
427+ , requestHeaders = []
428+ , rawPathInfo = "/location"
429+ }
430+ where
431+ params = [("foo", "bar"), ("baz", "bin")]
432+ -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
433+ postOutput = T.pack $ "POST / Accept: \nStatus: 200 OK"
434+ -- FIXME getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)
435+ getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \nStatus: 200 OK"
436+
437+ debugApp output' = logCallback (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do
438+ return $ responseLBS status200 [ ] ""
439+ where
440+ output = TE.encodeUtf8 $ T.toStrict output'
441+ {-debugApp = debug $ \req -> do-}
442+ {-return $ responseLBS status200 [ ] ""-}
wai-extra/test/sample.hs+15−16
@@ -1,26 +1,25 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−import Data.ByteString.Char8 (pack)
1+import Data.ByteString.Char8 (unpack, pack)
4import Data.ByteString.Lazy (fromChunks)
2import Data.ByteString.Lazy (fromChunks)
5−import Data.Text ()
6−import Network.HTTP.Types
7import Network.Wai
3import Network.Wai
4+import Network.Wai.Enumerator
8import Network.Wai.Middleware.Gzip
5import Network.Wai.Middleware.Gzip
9import Network.Wai.Middleware.Jsonp
6import Network.Wai.Middleware.Jsonp
10−import Network.Wai.Handler.Warp
7+import Network.Wai.Middleware.CleanPath
8+import Network.Wai.Handler.SimpleServer
11
9
12−app :: Application
10+app :: [String] -> Application
13−app request = return $ case pathInfo request of
11+app [] _ = return $ Response Status200 [] $ Right $ fromLBS
14− [] -> responseLBS status200 []
15− $ fromChunks $ flip map [1..10000] $ \i -> pack $ concat
12+ $ fromChunks $ flip map [1..10000] $ \i -> pack $
13+ concat
16 [ "<p>Just this same paragraph again. "
14 [ "<p>Just this same paragraph again. "
17− , show (i :: Int)
15+ , show i
18 , "</p>"
16 , "</p>"
19 ]
17 ]
20− ["test.html"] -> ResponseFile status200 [] "test.html" Nothing
18+app ["test.html"] _ = return $ Response Status200 [] $ Left "test.html"
21− ["json"] -> ResponseFile status200 [(hContentType, "application/json")]
19+app ["json"] _ =return $ Response Status200
20+ [(ContentType, pack "application/json")]
22− "json" Nothing
21+ $ Left "json"
23− _ -> ResponseFile status404 [] "../LICENSE" Nothing
22+app _ _ = return $ Response Status404 [] $ Left "../LICENSE"
24
23
25main :: IO ()
24main :: IO ()
26−main = run 3000 $ gzip def $ jsonp app
25+main = run 3000 $ jsonp $ gzip $ cleanPath app
wai-extra/tests.hsnew file+5
@@ -0,0 +1,5 @@
1+import Test.Hspec.Monadic
2+import qualified WaiExtraTest
3+
4+main :: IO ()
5+main = hspecX WaiExtraTest.specs
wai-extra/wai-extra.cabal+34−165
@@ -1,69 +1,7 @@
1Name: wai-extra
1Name: wai-extra
2−Version: 3.0.29.1
2+Version: 1.2.0
3Synopsis: Provides some basic WAI handlers and middleware.
3Synopsis: Provides some basic WAI handlers and middleware.
4−description:
4+Description: The goal here is to provide common features without many dependencies.
5− Provides basic WAI handler and middleware functionality:
6− .
7− * WAI Testing Framework
8− .
9− Hspec testing facilities and helpers for WAI.
10− .
11− * Event Source/Event Stream
12− .
13− Send server events to the client. Compatible with the JavaScript
14− EventSource API.
15− .
16− * Accept Override
17− .
18− Override the Accept header in a request. Special handling for the
19− _accept query parameter (which is used throughout WAI override the
20− Accept header).
21− .
22− * Add Headers
23− .
24− WAI Middleware for adding arbitrary headers to an HTTP request.
25− .
26− * Clean Path
27− .
28− Clean a request path to a canonical form.
29− .
30− * GZip Compression
31− .
32− Negotiate HTTP payload gzip compression.
33− .
34− * HTTP Basic Authentication
35− .
36− WAI Basic Authentication Middleware which uses Authorization header.
37− .
38− * JSONP
39− .
40− \"JSON with Padding\" middleware. Automatic wrapping of JSON
41− responses to convert into JSONP.
42− .
43− * Method Override / Post
44− .
45− Allows overriding of the HTTP request method via the _method query string
46− parameter.
47− .
48− * Request Logging
49− .
50− Request logging middleware for development and production environments
51− .
52− * Request Rewrite
53− .
54− Rewrite request path info based on a custom conversion rules.
55− .
56− * Stream Files
57− .
58− Convert ResponseFile type responses into ResponseStream type.
59− .
60− * Virtual Host
61− .
62− Redirect incoming requests to a new host based on custom rules.
63− .
64− .
65− API docs and the README are available at <http://www.stackage.org/package/wai-extra>.
66−
67License: MIT
5License: MIT
68License-file: LICENSE
6License-file: LICENSE
69Author: Michael Snoyman
7Author: Michael Snoyman
@@ -71,141 +9,72 @@ Maintainer: michael@snoyman.com
71Homepage: http://github.com/yesodweb/wai
9Homepage: http://github.com/yesodweb/wai
72Category: Web
10Category: Web
73Build-Type: Simple
11Build-Type: Simple
74−Cabal-Version: >=1.10
12+Cabal-Version: >=1.8
75Stability: Stable
13Stability: Stable
76extra-source-files:
14extra-source-files:
15+ tests.hs
77 test/requests/dalvik-request
16 test/requests/dalvik-request
78 test/json
17 test/json
79 test/test.html
18 test/test.html
80 test/sample.hs
19 test/sample.hs
81− ChangeLog.md
20+ test/WaiExtraTest.hs
82− README.md
83−
84−flag build-example
85− description: Build example executable.
86− manual: True
87− default: False
88
21
89Library
22Library
90− Build-Depends: base >= 4.8 && < 5
23+ Build-Depends: base >= 4 && < 5
91− , bytestring >= 0.10.4
24+ , bytestring >= 0.9.1.4 && < 0.10
92− , wai >= 3.0.3.0 && < 3.3
25+ , wai >= 1.2 && < 1.3
93 , old-locale >= 1.0.0.2 && < 1.1
26 , old-locale >= 1.0.0.2 && < 1.1
94 , time >= 1.1.4
27 , time >= 1.1.4
95− , network >= 2.6.1.0
28+ , network >= 2.2.1.5 && < 2.4
96− , directory >= 1.0.1
29+ , directory >= 1.0.1 && < 1.2
97− , transformers >= 0.2.2
30+ , transformers >= 0.2.2 && < 0.4
31+ , blaze-builder >= 0.2.1.4 && < 0.4
98− , http-types >= 0.7
32+ , http-types >= 0.6 && < 0.7
99− , text >= 0.7
33+ , text >= 0.7 && < 0.12
100 , case-insensitive >= 0.2
34 , case-insensitive >= 0.2
101− , data-default-class
35+ , data-default >= 0.3 && < 0.4
102− , fast-logger >= 2.4.5
36+ , fast-logger >= 0.0.2
103− , wai-logger >= 2.3.2
37+ , conduit >= 0.4 && < 0.5
38+ , zlib-conduit >= 0.4 && < 0.5
39+ , blaze-builder-conduit >= 0.4 && < 0.5
104 , ansi-terminal
40 , ansi-terminal
105− , resourcet >= 0.4.6 && < 1.3
106− , void >= 0.5
107− , containers
108− , base64-bytestring
109− , word8
110− , deepseq
111− , streaming-commons >= 0.2
112− , unix-compat
113− , cookie
114− , vault
115− , zlib
116− , aeson
117− , iproute
118− , http2
119−
120− if os(windows)
121− cpp-options: -DWINDOWS
122− else
123− build-depends: unix
124−
125− default-extensions: OverloadedStrings
126
41
127 Exposed-modules: Network.Wai.Handler.CGI
42 Exposed-modules: Network.Wai.Handler.CGI
128− Network.Wai.Handler.SCGI
129− Network.Wai.Header
130 Network.Wai.Middleware.AcceptOverride
43 Network.Wai.Middleware.AcceptOverride
131− Network.Wai.Middleware.AddHeaders
132− Network.Wai.Middleware.Approot
133 Network.Wai.Middleware.Autohead
44 Network.Wai.Middleware.Autohead
134 Network.Wai.Middleware.CleanPath
45 Network.Wai.Middleware.CleanPath
135− Network.Wai.Middleware.Local
136 Network.Wai.Middleware.RequestLogger
46 Network.Wai.Middleware.RequestLogger
137− Network.Wai.Middleware.RequestLogger.JSON
138 Network.Wai.Middleware.Gzip
47 Network.Wai.Middleware.Gzip
139 Network.Wai.Middleware.Jsonp
48 Network.Wai.Middleware.Jsonp
140 Network.Wai.Middleware.MethodOverride
49 Network.Wai.Middleware.MethodOverride
141− Network.Wai.Middleware.MethodOverridePost
142 Network.Wai.Middleware.Rewrite
50 Network.Wai.Middleware.Rewrite
143− Network.Wai.Middleware.StripHeaders
144 Network.Wai.Middleware.Vhost
51 Network.Wai.Middleware.Vhost
145− Network.Wai.Middleware.HttpAuth
146− Network.Wai.Middleware.StreamFile
147− Network.Wai.Middleware.ForceDomain
148− Network.Wai.Middleware.ForceSSL
149− Network.Wai.Middleware.Routed
150− Network.Wai.Middleware.Timeout
151 Network.Wai.Parse
52 Network.Wai.Parse
152− Network.Wai.Request
153− Network.Wai.UrlMap
154− Network.Wai.Test
155− Network.Wai.Test.Internal
156− Network.Wai.EventSource
157− Network.Wai.EventSource.EventStream
158− other-modules: Network.Wai.Middleware.RequestLogger.Internal
159− default-language: Haskell2010
160 ghc-options: -Wall
53 ghc-options: -Wall
161
54
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
55
178−test-suite spec
56+test-suite tests
57+ hs-source-dirs: test
58+ main-is: ../tests.hs
179− type: exitcode-stdio-1.0
59+ type: exitcode-stdio-1.0
180− hs-source-dirs: test
60+
181− main-is: Spec.hs
182− other-modules: Network.Wai.TestSpec
183− Network.Wai.ParseSpec
184− Network.Wai.RequestSpec
185− Network.Wai.Middleware.ApprootSpec
186− Network.Wai.Middleware.ForceSSLSpec
187− Network.Wai.Middleware.RoutedSpec
188− Network.Wai.Middleware.StripHeadersSpec
189− Network.Wai.Middleware.TimeoutSpec
190− WaiExtraSpec
191 build-depends: base >= 4 && < 5
61 build-depends: base >= 4 && < 5
192 , wai-extra
62 , wai-extra
63+ , wai-test
64+ , hspec >= 0.8 && < 0.10
65+ , HUnit
66+
193 , wai
67 , wai
194− , hspec >= 1.3
195− , transformers
196− , fast-logger
197 , http-types
68 , http-types
69+ , transformers
198 , zlib
70 , zlib
199 , text
71 , text
200− , resourcet
201 , bytestring
72 , bytestring
202− , HUnit
73+ , directory
203− , cookie
74+ , zlib-bindings
204− , time
75+ , blaze-builder >= 0.2.1.4 && < 0.4
205− , case-insensitive
76+ , data-default
206− , http2
77+ , conduit
207− ghc-options: -Wall
208− default-language: Haskell2010
209
78
210source-repository head
79source-repository head
211 type: git
80 type: git
wai-frontend-monadcgi/ChangeLog.mddeleted−7
@@ -1,7 +0,0 @@
1−## 3.0.0.3
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/LICENSE+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2008, Michael Snoyman. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-frontend-monadcgi/Network/Wai/Frontend/MonadCGI.hs+8−7
@@ -10,6 +10,8 @@ import Network.HTTP.Types (Status (..))
10import Control.Monad.IO.Class (liftIO)
10import Control.Monad.IO.Class (liftIO)
11import Data.CaseInsensitive (original)
11import Data.CaseInsensitive (original)
12
12
13+import Data.Conduit.Lazy (lazyConsume)
14+
13import qualified Data.Map as Map
15import qualified Data.Map as Map
14import qualified Data.ByteString.Lazy as BS
16import qualified Data.ByteString.Lazy as BS
15import qualified Data.ByteString.Char8 as S8
17import qualified Data.ByteString.Char8 as S8
@@ -30,8 +32,8 @@ cgiToAppGeneric :: Monad m
30 => (m (Headers, CGIResult) -> IO (Headers, CGIResult))
32 => (m (Headers, CGIResult) -> IO (Headers, CGIResult))
31 -> CGIT m CGIResult
33 -> CGIT m CGIResult
32 -> Application
34 -> Application
33−cgiToAppGeneric toIO cgi env sendResponse = do
35+cgiToAppGeneric toIO cgi env = do
34− input <- lazyRequestBody env
36+ input <- fmap BS.fromChunks $ lazyConsume $ requestBody env
35 let vars = map (first fixVarName . go) (requestHeaders env)
37 let vars = map (first fixVarName . go) (requestHeaders env)
36 ++ getCgiVars env
38 ++ getCgiVars env
37 (inputs, body') = decodeInput vars input
39 (inputs, body') = decodeInput vars input
@@ -49,7 +51,7 @@ cgiToAppGeneric toIO cgi env sendResponse = do
49 let status' = case lookup (fromString "Status") headers' of
51 let status' = case lookup (fromString "Status") headers' of
50 Nothing -> 200
52 Nothing -> 200
51 Just s -> safeRead 200 $ S8.unpack s
53 Just s -> safeRead 200 $ S8.unpack s
52− sendResponse $ responseLBS (Status status' S8.empty) headers' output
54+ return $ responseLBS (Status status' S8.empty) headers' output
53 where
55 where
54 go (x, y) = (S8.unpack $ original x, S8.unpack y)
56 go (x, y) = (S8.unpack $ original x, S8.unpack y)
55
57
@@ -64,8 +66,7 @@ getCgiVars :: Request -> [(String, String)]
64getCgiVars e =
66getCgiVars e =
65 [ ("PATH_INFO", S8.unpack $ rawPathInfo e)
67 [ ("PATH_INFO", S8.unpack $ rawPathInfo e)
66 , ("REQUEST_METHOD", show $ requestMethod e)
68 , ("REQUEST_METHOD", show $ requestMethod e)
67− , ("QUERY_STRING",
68− case S8.unpack $ rawQueryString e of
69+ , ("QUERY_STRING", S8.unpack $ rawQueryString e)
69− '?':rest -> rest
70+ , ("SERVER_NAME", S8.unpack $ serverName e)
70− x -> x)
71+ , ("SERVER_PORT", show $ serverPort e)
71 ]
72 ]
wai-frontend-monadcgi/READMEnew file+1
@@ -0,0 +1 @@
1+Run CGI apps on WAI handlers.
wai-frontend-monadcgi/README.mddeleted−5
@@ -1,5 +0,0 @@
1−## wai-frontend-monadcgi
2−
3−Allows programs written against MonadCGI to run with any WAI handler. This is
4−most useful for running your existing CGI apps on Warp. For true "yo
5−dawg"-ness, try running this through the WAI CGI backend.
wai-frontend-monadcgi/wai-frontend-monadcgi.cabal+4−4
@@ -1,26 +1,26 @@
1name: wai-frontend-monadcgi
1name: wai-frontend-monadcgi
2−version: 3.0.0.3
2+version: 1.2.0
3license: MIT
3license: MIT
4license-file: LICENSE
4license-file: LICENSE
5author: Michael Snoyman <michael@snoyman.com>
5author: Michael Snoyman <michael@snoyman.com>
6maintainer: Michael Snoyman <michael@snoyman.com>
6maintainer: Michael Snoyman <michael@snoyman.com>
7synopsis: Run CGI apps on WAI.
7synopsis: Run CGI apps on WAI.
8−description: API docs and the README are available at <http://www.stackage.org/package/wai-frontend-monadcgi>.
8+description: Allows programs written against MonadCGI to run with any WAI handler. This is most useful for running your existing CGI apps on Warp. For true "yo dawg"-ness, try running this through the WAI CGI backend.
9category: Web
9category: Web
10stability: stable
10stability: stable
11cabal-version: >= 1.6
11cabal-version: >= 1.6
12build-type: Simple
12build-type: Simple
13−extra-source-files: README.md ChangeLog.md
14
13
15library
14library
16 build-depends: base >= 4 && < 5
15 build-depends: base >= 4 && < 5
17 , bytestring
16 , bytestring
18 , containers >= 0.2
17 , containers >= 0.2
19 , cgi
18 , cgi
19+ , conduit >= 0.4
20 , http-types
20 , http-types
21 , transformers
21 , transformers
22 , case-insensitive
22 , case-insensitive
23− , wai >= 3.0 && < 3.3
23+ , wai >= 1.2 && < 1.3
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-devel/.gitignorenew file+2
@@ -0,0 +1,2 @@
1+*.swp
2+/dist/
wai-handler-devel/FullApp.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, GADTs #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module FullApp (fullApp) where
5+
6+import Network.Wai
7+import Network.HTTP.Types
8+import Data.ByteString.Lazy.Char8 (pack)
9+import Database.Persist.TH
10+import Database.Persist.Sqlite
11+import System.Directory
12+import Control.Monad (when)
13+import Helper
14+import Text.Hamlet
15+import Text.Blaze.Renderer.Text (renderHtml)
16+import Data.Text.Lazy.Encoding (encodeUtf16LE)
17+
18+mkPersist sqlSettings [persist|
19+Dummy
20+ dummy String
21+|]
22+
23+testApp handler = do
24+ putStrLn "testApp called, this should happen only once per reload"
25+ -- Swap between the following two lines as necessary to generate errors
26+ exi <- doesFileExist "db"
27+ --let exi = True
28+ when exi $ removeFile "db"
29+ withSqlitePool "db" 10 $ \pool -> do
30+ flip runSqlPool pool $ runMigration $ migrate $ Dummy ""
31+ handler $ \req -> do
32+ if pathInfo req == "/favicon.ico"
33+ then return $ responseLBS status301 [("Location", "http://docs.yesodweb.com/favicon.ico")]
34+ $ pack ""
35+ else do
36+ print $ pathInfo req
37+ x <- flip runSqlPool pool $ do
38+ insert $ Dummy ""
39+ count ([] :: [Filter Dummy])
40+ return $ responseLBS status200
41+ [("Content-Type", "text/html; charset=utf-8")] $
42+ encodeUtf16LE $ renderHtml
43+ $(htmlFile "hamlet/testapp.hamlet")
44+ putStrLn "handler completed, this should only happen at the beginning of a reload"
wai-handler-devel/Helper.hsnew file+3
@@ -0,0 +1,3 @@
1+module Helper where
2+
3+db = "test.db3"
wai-handler-devel/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2010, Michael Snoyman. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-handler-devel/Network/Wai/Application/Devel.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Application.Devel
3+ ( -- * Types
4+ AppHolder
5+ , AppRunner
6+ , WithAppRunner
7+ -- * Functions
8+ , initAppHolder
9+ , swapApp
10+ , swapAppSimple
11+ , toApp
12+ ) where
13+
14+import Control.Concurrent (forkIO)
15+import Control.Concurrent.MVar
16+ ( MVar, newEmptyMVar, newMVar
17+ , takeMVar, putMVar, readMVar
18+ )
19+import Network.Wai (Application, responseLBS)
20+import Network.HTTP.Types (status500)
21+import Data.ByteString.Lazy.Char8 ()
22+import Control.Monad.IO.Class (liftIO)
23+
24+type AppHolder = MVar (Application, MVar ())
25+type AppRunner = Application -> IO ()
26+type WithAppRunner = AppRunner -> IO ()
27+
28+initAppHolder :: IO AppHolder
29+initAppHolder = do
30+ flag <- newEmptyMVar
31+ newMVar (initApp, flag)
32+ where
33+ initApp _ = return
34+ $ responseLBS status500 [("Content-Type", "text/plain")]
35+ $ "No app has yet been loaded"
36+
37+swapAppSimple :: Application -> AppHolder -> IO ()
38+swapAppSimple app =
39+ swapApp war
40+ where
41+ war f = f app
42+
43+swapApp :: WithAppRunner -> AppHolder -> IO ()
44+swapApp war ah = void $ forkIO $ war $ \app -> do
45+ (_, oldFlag) <- takeMVar ah
46+ -- allow the old app to cleanup
47+ putMVar oldFlag ()
48+ -- now place the new app into the AppHolder, waiting for a termination
49+ -- signal
50+ flag <- newEmptyMVar
51+ putMVar ah (app, flag)
52+ takeMVar flag -- this causes execution to hang until we are terminated
53+ where
54+ void x = x >> return ()
55+
56+toApp :: AppHolder -> Application
57+toApp ah req = do
58+ (app, _) <- liftIO $ readMVar ah
59+ app req
wai-handler-devel/Network/Wai/Handler/DevelServer.hsnew file+199
@@ -0,0 +1,199 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+module Network.Wai.Handler.DevelServer
6+ ( run
7+ , runQuit
8+ , runNoWatch
9+ , runWithReloadActions
10+ , runQuitWithReloadActions
11+ ) where
12+
13+import Language.Haskell.Interpreter hiding (typeOf)
14+import Network.Wai
15+import Network.HTTP.Types (status200)
16+
17+import Data.Text.Lazy (pack)
18+import Data.Text.Lazy.Encoding (encodeUtf8)
19+import qualified Data.ByteString.Lazy.Char8 as L8
20+import Control.Exception (Exception, SomeException, toException, fromException)
21+import qualified Control.Exception as E
22+import Control.Concurrent (forkIO, threadDelay)
23+
24+import Data.Maybe
25+import Control.Monad
26+import Control.Concurrent.MVar
27+
28+import System.Directory (getModificationTime)
29+import qualified Network.Wai.Handler.Warp as Warp
30+import Network.Wai.Application.Devel
31+import Network.Wai.Middleware.Debug (debug)
32+
33+import Data.List (nub, group, sort)
34+import System.Time (ClockTime)
35+
36+type FunctionName = String
37+
38+runNoWatch :: Int -> ModuleName -> FunctionName
39+ -> (FilePath -> IO [FilePath]) -> IO ()
40+runNoWatch port modu func extras = do
41+ ah <- initAppHolder
42+ _ <- reload modu func extras Nothing ah []
43+ Warp.run port $ toApp ah
44+
45+runQuit :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
46+ -> IO ()
47+runQuit port modu func extras = runQuitWithReloadActions port modu func extras []
48+
49+runQuitWithReloadActions :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
50+ -> [IO (IO ())] -> IO ()
51+runQuitWithReloadActions port modu func extras actions = do
52+ sig <- newEmptyMVar
53+ _ <- forkIO $ runWithReloadActions port modu func extras (Just sig) actions
54+ go sig
55+ where
56+ go sig = do
57+ x <- getLine
58+ case x of
59+ 'q':_ -> putStrLn "Quitting, goodbye!"
60+ 'r':_ -> do
61+ putStrLn "Forcing reinterpretation"
62+ _ <- tryPutMVar sig ()
63+ go sig
64+ _ -> go sig
65+
66+runWithReloadActions :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
67+ -> Maybe (MVar ()) -> [IO (IO ())] -> IO ()
68+runWithReloadActions port modu func extras msig initActions = do
69+ actions <- mapM id initActions
70+ ah <- initAppHolder
71+ _ <- forkIO $ fillApp modu func extras ah msig actions
72+ Warp.run port $ toApp ah
73+ return ()
74+
75+run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath]) -> Maybe (MVar ())
76+ -> IO ()
77+run port modu func extras msig = runWithReloadActions port modu func extras msig []
78+
79+{-
80+startApp :: Queue -> Handler -> IO ()
81+startApp queue withApp = do
82+ forkIO (withApp go) >> return ()
83+ where
84+ go app = do
85+ msession <- C.readChan queue
86+ case msession of
87+ Nothing -> return ()
88+ Just (req, onRes) -> do
89+ void $ forkIO $ (E.handle onErr $ app req) >>= onRes
90+ go app
91+ onErr :: SomeException -> IO Response
92+ onErr e = return
93+ $ responseLBS
94+ status500
95+ [("Content-Type", "text/plain; charset=utf-8")]
96+ $ charsToLBS
97+ $ "Exception thrown while running application\n\n" ++ show e
98+ void x = x >> return ()
99+-}
100+
101+getTimes :: [FilePath] -> IO [ClockTime]
102+getTimes = E.handle (constSE $ return []) . mapM getModificationTime
103+
104+constSE :: x -> SomeException -> x
105+constSE = const
106+
107+fillApp :: String -> String
108+ -> (FilePath -> IO [FilePath]) -> AppHolder -> Maybe (MVar ()) -> [IO ()] -> IO ()
109+fillApp modu func dirs ah msig actions =
110+ go Nothing []
111+ where
112+ go prevError prevFiles = do
113+ forceReload <- maybe (return False) (fmap isJust . tryTakeMVar) msig
114+ toReload <-
115+ if forceReload || null prevFiles
116+ then return True
117+ else do
118+ times <- getTimes $ map fst prevFiles
119+ return $ times /= map snd prevFiles
120+ (newError, newFiles) <-
121+ if toReload
122+ then reload modu func dirs prevError ah actions
123+ else return (prevError, prevFiles)
124+ threadDelay 1000000
125+ go newError newFiles
126+
127+reload :: String -> String
128+ -> (FilePath -> IO [FilePath])
129+ -> Maybe SomeException
130+ -> AppHolder
131+ -> [IO ()]
132+ -> IO (Maybe SomeException, [(FilePath, ClockTime)])
133+reload modu func extras prevError ah actions = do
134+ case prevError of
135+ Nothing -> putStrLn "Attempting to interpret your app..."
136+ _ -> return ()
137+ loadingApp' prevError ah
138+ res <- theapp modu func
139+ case res of
140+ Left err -> do
141+ when (show (Just err) /= show prevError) $
142+ putStrLn $ "Compile failed: " ++ showInterpError err
143+ loadingApp' (Just $ toException err) ah
144+ return (Just $ toException err, [])
145+ Right (app, files') -> E.handle onInitErr $ do
146+ files'' <- mapM extras files'
147+ let files = map head $ group $ sort $ concat $ files' : files''
148+ putStrLn "Interpreting success, new app loaded"
149+ E.handle onInitErr $ do
150+ swapApp (\f -> app $ f . debug) ah
151+ times <- getTimes files
152+ sequence_ actions
153+ return (Nothing, zip files times)
154+ where
155+ onInitErr e = do
156+ putStrLn $ "Error initializing application: " ++ show e
157+ loadingApp' (Just e) ah
158+ return (Just e, [])
159+
160+showInterpError :: InterpreterError -> String
161+showInterpError (WontCompile errs) =
162+ concat . nub $ map (\(GhcError msg) -> '\n':'\n':msg) errs
163+showInterpError err = show err
164+
165+loadingApp' :: Maybe SomeException -> AppHolder -> IO ()
166+loadingApp' err = swapApp (loadingApp err)
167+
168+loadingApp :: Maybe SomeException -> Handler
169+loadingApp err f =
170+ f $ const $ return $ responseLBS status200
171+ ( ("Content-Type", "text/plain")
172+ : case err of
173+ Nothing -> [("Refresh", "1")]
174+ Just _ -> []
175+ ) $ toMessage err
176+ where
177+ toMessage Nothing = "Loading code changes, please wait"
178+ toMessage (Just err') = charsToLBS $ "Error loading code: " ++
179+ (case fromException err' of
180+ Just e -> showInterpError e
181+ Nothing -> show err')
182+
183+charsToLBS :: String -> L8.ByteString
184+charsToLBS = encodeUtf8 . pack
185+
186+type Handler = (Application -> IO ()) -> IO ()
187+
188+theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))
189+theapp modu func =
190+ runInterpreter $ do
191+ loadModules [modu]
192+ mods <- getLoadedModules
193+ setImports ["Prelude", "Network.Wai", "Data.Enumerator", "Data.ByteString.Internal", modu]
194+ app <- interpret func infer
195+ return (app, map toFile mods)
196+ where
197+ toFile s = map toSlash s ++ ".hs"
198+ toSlash '.' = '/'
199+ toSlash c = c
wai-handler-devel/READMEnew file

No changes to the content.

wai-handler-devel/Setup.lhsnew file+11
@@ -0,0 +1,11 @@
1+#!/usr/bin/env runhaskell
2+
3+> module Main where
4+> import Distribution.Simple
5+> import System.Cmd (system)
6+
7+> main :: IO ()
8+> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' })
9+
10+> runTests' :: a -> b -> c -> d -> IO ()
11+> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return ()
wai-handler-devel/SmallApp.hsnew file+10
@@ -0,0 +1,10 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module SmallApp where
3+
4+import Network.Wai
5+import Network.HTTP.Types
6+import Data.ByteString.Lazy.Char8 ()
7+
8+testapp' _ = return $ responseLBS status200 [("Content-Type", "text/html")] "test"
9+
10+smallApp f = f testapp'
wai-handler-devel/hamlet/testapp.hamletnew file+4
@@ -0,0 +1,4 @@
1+%h1 Hello World
2+%p Counter: $show x$
3+%p The database file is $db$
4+%p שלום
wai-handler-devel/run-fullapp.hsnew file+5
@@ -0,0 +1,5 @@
1+import Network.Wai.Handler.DevelServer (runQuit)
2+import Data.Enumerator (Iteratee)
3+import Data.ByteString (ByteString)
4+
5+main = runQuit 3000 "FullApp" "fullApp" (const $ return ["hamlet/testapp.hamlet"])
wai-handler-devel/run-onreloadapp.hsnew file+21
@@ -0,0 +1,21 @@
1+
2+import Network.Wai.Handler.DevelServer (runQuitWithReloadActions)
3+import System.Directory(findExecutable)
4+import System.Process(readProcess)
5+
6+main = runQuitWithReloadActions 4000 "SmallApp" "smallApp" (const $ return []) [browserRefresh]
7+
8+browserRefresh = do
9+ exe <- findExecutable "xdotool"
10+ case exe of
11+ Nothing -> do
12+ putStrLn "Install xdotool for automatic browser refresh"
13+ return $ return ()
14+ Just xdotool -> do
15+ putStrLn "Please click on the browser window..."
16+ pid <- readProcess xdotool ["selectwindow"] ""
17+ return $ do
18+ current <- readProcess xdotool ["getwindowfocus"] ""
19+ let cmds = ["windowfocus", pid, "key", "F5", "windowfocus", current]
20+ _ <- readProcess xdotool cmds ""
21+ return ()
wai-handler-devel/run-smallapp.hsnew file+3
@@ -0,0 +1,3 @@
1+import Network.Wai.Handler.DevelServer (runQuit)
2+
3+main = runQuit 3000 "SmallApp" "smallApp" (const $ return [])
wai-handler-devel/wai-handler-devel-unwatched.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+import Network.Wai.Handler.DevelServer (runNoWatch)
3+import System.Console.CmdArgs
4+import Control.Concurrent (forkIO)
5+
6+data Devel = Devel
7+ { port :: Int
8+ , moduleName :: String
9+ , function :: String
10+ }
11+ deriving (Show, Data, Typeable)
12+
13+main :: IO ()
14+main = do
15+ Devel p m f <- cmdArgs Devel
16+ { port = 3000 &= argPos 0 &= typ "PORT"
17+ , moduleName = "" &= argPos 1 &= typ "MODULE"
18+ , function = "" &= argPos 2 &= typ "FUNCTION"
19+ } &= summary "WAI development web server"
20+ _ <- forkIO $ runNoWatch p m f $ const $ return []
21+ go
22+ where
23+ go = do
24+ x <- getLine
25+ case x of
26+ 'q':_ -> putStrLn "Quitting, goodbye!"
27+ _ -> go
wai-handler-devel/wai-handler-devel.cabalnew file+49
@@ -0,0 +1,49 @@
1+Name: wai-handler-devel
2+Version: 1.2.0
3+Synopsis: WAI server that automatically reloads code after modification.
4+Description: This handler automatically reloads your source code upon any changes. It works by using the hint package, essentially embedding GHC inside the handler. The handler (both the executable and library) takes three arguments: the port to listen on, the module name containing the application function, and the name of the function.
5+ .
6+ One major note: the type of the application is most likely not what you expect. A common case for WAI applications is having a withApplication function, and this library assumes this is the case. Therefore, the type signature of your application function must be:
7+ .
8+ > withYourApp :: (Application -> IO ()) -> IO ()
9+License: MIT
10+License-file: LICENSE
11+Author: Michael Snoyman
12+Maintainer: michael@snoyman.com
13+Homepage: http://github.com/yesodweb/wai
14+Category: Web
15+Build-Type: Simple
16+Cabal-Version: >=1.6
17+Stability: Stable
18+
19+Source-repository head
20+ type: git
21+ location: git://github.com/yesodweb/wai.git
22+
23+Library
24+ Build-Depends: base >= 4 && < 5
25+ , wai >= 1.2 && < 1.3
26+ , wai-extra >= 1.2 && < 1.3
27+ , http-types >= 0.6 && < 0.7
28+ , warp >= 1.2 && < 1.3
29+ , directory >= 1.0.1 && < 1.2
30+ , network >= 2.2.1.5 && < 2.4
31+ , bytestring >= 0.9.1.4 && < 0.10
32+ , hint >= 0.3.2.3 && < 0.4
33+ , text >= 0.7 && < 0.12
34+ , old-time
35+ , transformers >= 0.2.2 && < 0.4
36+ , attoparsec >= 0.10
37+ Exposed-modules: Network.Wai.Handler.DevelServer
38+ Network.Wai.Application.Devel
39+ ghc-options: -Wall
40+
41+Executable wai-handler-devel
42+ Build-Depends: cmdargs >= 0.4
43+ ghc-options: -Wall -O2 -threaded
44+ main-is: wai-handler-devel.hs
45+
46+Executable wai-handler-devel-unwatched
47+ Build-Depends: cmdargs >= 0.4
48+ ghc-options: -Wall -O2 -threaded
49+ main-is: wai-handler-devel-unwatched.hs
wai-handler-devel/wai-handler-devel.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+import Network.Wai.Handler.DevelServer (runQuit)
4+import System.Console.CmdArgs
5+import qualified Data.Attoparsec.Text.Lazy as A
6+import qualified Data.Text.Lazy.IO as TIO
7+import Control.Applicative ((<|>), many)
8+import Data.Char (isSpace)
9+import Data.Maybe (mapMaybe)
10+
11+data Devel = Devel
12+ { port :: Int
13+ , moduleName :: String
14+ , function :: String
15+ , yesod :: Bool
16+ }
17+ deriving (Show, Data, Typeable)
18+
19+main :: IO ()
20+main = do
21+ Devel p m f y <- cmdArgs Devel
22+ { port = 3000 &= argPos 0 &= typ "PORT"
23+ , moduleName = "" &= argPos 1 &= typ "MODULE"
24+ , function = "" &= argPos 2 &= typ "FUNCTION"
25+ , yesod = False
26+ } &= summary "WAI development web server"
27+ runQuit p m f $ if y then determineHamletDeps else (const $ return [])
28+
29+data TempType = Hamlet | Cassius | Lucius | Julius | Widget | Verbatim
30+ deriving Show
31+
32+determineHamletDeps :: FilePath -> IO [FilePath]
33+determineHamletDeps x = do
34+ y <- TIO.readFile x
35+ let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y
36+ case z of
37+ A.Fail{} -> return []
38+ A.Done _ r -> return $ mapMaybe go r
39+ where
40+ go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet"
41+ go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet"
42+ go (Just (Verbatim, f)) = Just f
43+ go _ = Nothing
44+ parser = do
45+ ty <- (A.string "$(hamletFile " >> return Hamlet)
46+ <|> (A.string "$(cassiusFile " >> return Cassius)
47+ <|> (A.string "$(luciusFile " >> return Lucius)
48+ <|> (A.string "$(juliusFile " >> return Julius)
49+ <|> (A.string "$(widgetFile " >> return Widget)
50+ <|> (A.string "$(Settings.hamletFile " >> return Hamlet)
51+ <|> (A.string "$(Settings.cassiusFile " >> return Cassius)
52+ <|> (A.string "$(Settings.luciusFile " >> return Lucius)
53+ <|> (A.string "$(Settings.juliusFile " >> return Julius)
54+ <|> (A.string "$(Settings.widgetFile " >> return Widget)
55+ <|> (A.string "$(persistFile " >> return Verbatim)
56+ <|> (A.string "$(parseRoutesFile " >> return Verbatim)
57+ A.skipWhile isSpace
58+ _ <- A.char '"'
59+ y <- A.many1 $ A.satisfy (/= '"')
60+ _ <- A.char '"'
61+ A.skipWhile isSpace
62+ _ <- A.char ')'
63+ return $ Just (ty, y)
wai-handler-fastcgi/.gitignorenew file+4
@@ -0,0 +1,4 @@
1+/dist/
2+*.swp
3+*.hi
4+*.o
wai-handler-fastcgi/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2010, Michael Snoyman. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
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/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: 1.2.0
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+category: Web
9+stability: stable
10+cabal-version: >= 1.6
11+build-type: Configure
12+extra-source-files: configure fastcgi.buildinfo.in
13+homepage: http://www.yesodweb.com/book/wai
14+description: Calls out to the libfcgi C library.
15+
16+library
17+ build-depends: base >= 4 && < 5
18+ , wai >= 1.2 && < 1.3
19+ , wai-extra >= 1.2 && < 1.3
20+ , bytestring >= 0.9.1.4 && < 0.10
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/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c)2011, Michael Snoyman
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Michael Snoyman nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-handler-launch/Network/Wai/Handler/Launch.hsnew file+152
@@ -0,0 +1,152 @@
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.HTTP.Types
12+import qualified Network.Wai.Handler.Warp as Warp
13+import Data.IORef
14+import Control.Concurrent
15+import Control.Monad.IO.Class (liftIO)
16+import qualified Data.ByteString as S
17+import Blaze.ByteString.Builder (fromByteString)
18+#if WINDOWS
19+import Foreign
20+import Foreign.C.String
21+#else
22+import System.Cmd (rawSystem)
23+#endif
24+import Data.Conduit.Zlib (decompressFlush, WindowBits (WindowBits))
25+import Data.Conduit.Blaze (builderToByteStringFlush)
26+import qualified Data.Conduit as C
27+import qualified Data.Conduit.List as CL
28+
29+ping :: IORef Bool -> Middleware
30+ping var app req
31+ | pathInfo req == ["_ping"] = do
32+ liftIO $ writeIORef var True
33+ return $ responseLBS status200 [] ""
34+ | otherwise = do
35+ res <- app req
36+ let isHtml hs =
37+ case lookup "content-type" hs of
38+ Just ct -> "text/html" `S.isPrefixOf` ct
39+ Nothing -> False
40+ case res of
41+ ResponseFile _ hs _ _
42+ | not $ isHtml hs -> return res
43+ ResponseBuilder _ hs _
44+ | not $ isHtml hs -> return res
45+ ResponseSource _ hs _
46+ | not $ isHtml hs -> return res
47+ _ -> do
48+ let (s, hs, body) = responseSource res
49+ let (isEnc, headers') = fixHeaders id hs
50+ let headers'' = filter (\(x, _) -> x /= "content-length") headers'
51+ let fixEnc src =
52+ if isEnc then
53+ src C.$= decompressFlush (WindowBits 31)
54+ else src
55+ return $ ResponseSource s headers''
56+ $ fixEnc (body C.$= builderToByteStringFlush)
57+ C.$= insideHead
58+ C.$= CL.map (fmap fromByteString)
59+
60+toInsert :: S.ByteString
61+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>"
62+
63+insideHead :: C.Conduit (C.Flush S.ByteString) (C.ResourceT IO) (C.Flush S.ByteString)
64+insideHead =
65+ C.conduitState (Just (S.empty, whole)) push' close
66+ where
67+ whole = "<head>"
68+ push' state (C.Chunk x) = (fmap . fmap) C.Chunk (push state x)
69+ push' state C.Flush = return $ C.StateProducing state [C.Flush]
70+ push (Just (held, atFront)) x
71+ | atFront `S.isPrefixOf` x = do
72+ let y = S.drop (S.length atFront) x
73+ return $ C.StateProducing Nothing [held, atFront, toInsert, y]
74+ | whole `S.isInfixOf` x = do
75+ let (before, rest) = S.breakSubstring whole x
76+ let after = S.drop (S.length whole) rest
77+ return $ C.StateProducing Nothing [held, before, whole, toInsert, after]
78+ | x `S.isPrefixOf` atFront = do
79+ let held' = held `S.append` x
80+ atFront' = S.drop (S.length x) atFront
81+ return $ C.StateProducing (Just (held', atFront')) []
82+ | otherwise = do
83+ let (held', atFront', x') = getOverlap whole x
84+ return $ C.StateProducing (Just (held', atFront')) [held, x']
85+ push Nothing x = return $ C.StateProducing Nothing [x]
86+
87+ close (Just (held, _)) = return [C.Chunk held, C.Chunk toInsert]
88+ close Nothing = return []
89+
90+getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
91+getOverlap whole x =
92+ go whole
93+ where
94+ go piece
95+ | S.null piece = ("", whole, x)
96+ | piece `S.isSuffixOf` x =
97+ let x' = S.take (S.length x - S.length piece) x
98+ atFront = S.drop (S.length piece) whole
99+ in (piece, atFront, x')
100+ | otherwise = go $ S.init piece
101+
102+fixHeaders :: ([Header] -> [Header])
103+ -> [Header]
104+ -> (Bool, [Header])
105+fixHeaders front [] = (False, front [])
106+fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)
107+fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs
108+
109+#if WINDOWS
110+foreign import ccall "launch"
111+ launch' :: Int -> CString -> IO ()
112+#endif
113+
114+launch :: Int -> String -> IO ()
115+
116+#if WINDOWS
117+launch port s = withCString s $ launch' port
118+#else
119+launch port s = forkIO (rawSystem
120+#if MAC
121+ "open"
122+#else
123+ "xdg-open"
124+#endif
125+ ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return ()
126+#endif
127+
128+run :: Application -> IO ()
129+run = runUrl ""
130+
131+runUrl :: String -> Application -> IO ()
132+runUrl = runUrlPort 4587
133+
134+runUrlPort :: Int -> String -> Application -> IO ()
135+runUrlPort port url app = do
136+ x <- newIORef True
137+ _ <- forkIO $ Warp.runSettings Warp.defaultSettings
138+ { Warp.settingsPort = port
139+ , Warp.settingsOnException = const $ return ()
140+ , Warp.settingsHost = "127.0.0.1"
141+ } $ ping x app
142+ launch port url
143+ loop x
144+
145+loop :: IORef Bool -> IO ()
146+loop x = do
147+ let seconds = 120
148+ threadDelay $ 1000000 * seconds
149+ b <- readIORef x
150+ if b
151+ then writeIORef x False >> loop x
152+ else return ()
wai-handler-launch/READMEnew file

No changes to the content.

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 True $ \_ -> return $ responseLBS status200 [("Content-Type", "text/html; charset=utf8")] "<html><head></head><body>HELLO THERE"
wai-handler-launch/wai-handler-launch.cabalnew file+37
@@ -0,0 +1,37 @@
1+Name: wai-handler-launch
2+Version: 1.2.0
3+Synopsis: Launch a web app in the default browser.
4+Description: This handles cross-platform launching and inserts Javascript code to ping the server. When the server no longer receives pings, it shuts down.
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+
13+Library
14+ Exposed-modules: Network.Wai.Handler.Launch
15+ build-depends: base >= 4 && < 5
16+ , wai >= 1.2 && < 1.3
17+ , warp >= 1.2 && < 1.3
18+ , http-types >= 0.6 && < 0.7
19+ , transformers >= 0.2.2 && < 0.4
20+ , bytestring >= 0.9.1.4 && < 0.10
21+ , blaze-builder >= 0.2.1.4 && < 0.4
22+ , conduit >= 0.4 && < 0.5
23+ , blaze-builder-conduit >= 0.4 && < 0.5
24+ , zlib-conduit >= 0.4 && < 0.5
25+
26+ if os(windows)
27+ c-sources: windows.c
28+ cpp-options: -DWINDOWS
29+ extra-libraries: Shell32
30+ else
31+ build-depends: process >= 1.0 && < 1.2
32+ if os(darwin)
33+ cpp-options: -DMAC
34+
35+source-repository head
36+ type: git
37+ location: git://github.com/yesodweb/wai.git
wai-handler-launch/windows.cnew file+12
@@ -0,0 +1,12 @@
1+#include <windows.h>
2+#include <shellapi.h>
3+#include <stdio.h>
4+
5+void launch(int port, char *s)
6+{
7+ int len = 8 + strlen("http://127.0.0.1:") + strlen(s);
8+ char *buff = malloc(len);
9+ snprintf(buff, len, "http://127.0.0.1:%d/%s", port, s);
10+ ShellExecute(NULL, "open", buff, NULL, NULL, SW_SHOWNORMAL);
11+ free(buff);
12+}
wai-handler-scgi/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2010, Michael Snoyman. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-extra/Network/Wai/Handler/SCGI.hs → wai-handler-scgi/Network/Wai/Handler/SCGI.hsrenamed+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-handler-scgi/READMEnew file

No changes to the content.

wai-handler-scgi/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-scgi/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_scgi", "mod_rewrite")
5+
6+url.rewrite-once = (
7+ "(.*)" => "/app/$1"
8+)
9+
10+scgi.server = (
11+ "/app" => ((
12+ "socket" => "/tmp/test.scgi.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-scgi/test.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Network.Wai
3+import Network.Wai.Handler.SCGI (run)
4+import qualified Data.ByteString.Lazy as L
5+import qualified Data.ByteString.Lazy.Char8 as L8
6+import qualified Data.Enumerator.List as E
7+import Network.HTTP.Types (status200)
8+
9+main = run app
10+
11+app req
12+ | rawPathInfo 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-scgi/wai-handler-scgi.cabalnew file+25
@@ -0,0 +1,25 @@
1+name: wai-handler-scgi
2+version: 1.2.0
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 SCGI
8+category: Web
9+stability: stable
10+cabal-version: >= 1.6
11+build-type: Simple
12+homepage: http://www.yesodweb.com/book/wai
13+description: Wai handler to SCGI
14+
15+library
16+ build-depends: base >= 4 && < 5
17+ , wai >= 1.2 && < 1.3
18+ , wai-extra >= 1.2 && < 1.3
19+ , bytestring >= 0.9.1.4 && < 0.10
20+ exposed-modules: Network.Wai.Handler.SCGI
21+ ghc-options: -Wall
22+
23+source-repository head
24+ type: git
25+ location: git://github.com/yesodweb/wai.git
wai-handler-webkit/.gitignorenew file+2
@@ -0,0 +1,2 @@
1+dist
2+*.swp
wai-handler-webkit/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2008, Michael Snoyman. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
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 _ = return $ responseLBS status200 [("Content-Type", "text/html")] "<h1>Hello World!</h1>"
wai-handler-webkit/wai-handler-webkit.cabalnew file+31
@@ -0,0 +1,31 @@
1+name: wai-handler-webkit
2+version: 1.2.0
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: Runs any WAI application using
9+ the simpleserver handler and then pops up a Webkit browser
10+ to view it.
11+category: Web
12+stability: unstable
13+cabal-version: >= 1.6
14+build-type: Simple
15+homepage: http://www.yesodweb.com/book/wai
16+
17+library
18+ build-depends: base >= 4 && < 5
19+ , wai >= 1.2 && < 1.3
20+ , warp >= 1.2 && < 1.3
21+ ghc-options: -Wall
22+ exposed-modules: Network.Wai.Handler.Webkit
23+ c-sources: webkit.cpp
24+ if os(windows)
25+ extra-libraries: QtCore4, QtGui4, QtNetwork4, QtWebKit4
26+ else
27+ pkgconfig-depends: QtWebKit
28+
29+source-repository head
30+ type: git
31+ 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/LICENSEdeleted−20
@@ -1,20 +0,0 @@
1−Copyright (c) 2016 Kazu Yamamoto, 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-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-test/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2010, Michael Snoyman. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-test/Network/Wai/Test.hsnew file+194
@@ -0,0 +1,194 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Network.Wai.Test
3+ ( -- * Session
4+ Session
5+ , runSession
6+ -- * Requests
7+ , request
8+ , srequest
9+ , SRequest (..)
10+ , SResponse (..)
11+ , defaultRequest
12+ , setRawPathInfo
13+ -- * Assertions
14+ , assertStatus
15+ , assertContentType
16+ , assertBody
17+ , assertBodyContains
18+ , assertHeader
19+ , assertNoHeader
20+ ) where
21+import Network.Wai
22+import qualified Test.HUnit.Base as H
23+import Control.Monad.IO.Class (liftIO)
24+import Control.Monad.Trans.State (StateT, evalStateT)
25+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
26+import Data.Map (Map)
27+import qualified Data.Map as Map
28+import Data.ByteString (ByteString)
29+import qualified Data.ByteString.Char8 as S8
30+import Data.Conduit.Blaze (builderToByteString)
31+import Blaze.ByteString.Builder (flush)
32+import qualified Data.ByteString.Lazy as L
33+import qualified Data.ByteString.Lazy.Char8 as L8
34+import qualified Network.HTTP.Types as H
35+import Data.CaseInsensitive (CI)
36+import qualified Data.ByteString as S
37+import qualified Data.Text as T
38+import qualified Data.Text.Encoding as TE
39+import qualified Data.Conduit as C
40+import qualified Data.Conduit.List as CL
41+import Data.Monoid (mempty)
42+
43+type Session = ReaderT Application (StateT ClientState IO)
44+
45+data ClientState = ClientState
46+ { _clientCookies :: Map ByteString ByteString
47+ }
48+
49+initState :: ClientState
50+initState = ClientState Map.empty
51+
52+runSession :: Session a -> Application -> IO a
53+runSession session app = evalStateT (runReaderT session app) initState
54+
55+data SRequest = SRequest
56+ { simpleRequest :: Request
57+ , simpleRequestBody :: L.ByteString
58+ }
59+data SResponse = SResponse
60+ { simpleStatus :: H.Status
61+ , simpleHeaders :: H.ResponseHeaders
62+ , simpleBody :: L.ByteString
63+ }
64+ deriving (Show, Eq)
65+request :: Request -> Session SResponse
66+request = srequest . flip SRequest L.empty
67+
68+defaultRequest :: Request
69+defaultRequest = Request
70+ { requestMethod = "GET"
71+ , httpVersion = H.http11
72+ , rawPathInfo = "/"
73+ , rawQueryString = ""
74+ , serverName = "localhost"
75+ , serverPort = 80
76+ , requestHeaders = []
77+ , isSecure = False
78+ , remoteHost = error "Network.Wai.Test.defaultRequest{remoteHost}"
79+ , pathInfo = []
80+ , queryString = []
81+ , requestBody = mempty
82+ , vault = mempty
83+ }
84+
85+setRawPathInfo :: Request -> S8.ByteString -> Request
86+setRawPathInfo r rawPinfo =
87+ let pInfo = T.split (== '/') $ TE.decodeUtf8 rawPinfo
88+ in r { rawPathInfo = rawPinfo, pathInfo = pInfo }
89+
90+srequest :: SRequest -> Session SResponse
91+srequest (SRequest req bod) = do
92+ app <- ask
93+ liftIO $ C.runResourceT $ do
94+ let req' = req { requestBody = CL.sourceList $ L.toChunks bod }
95+ res <- app req'
96+ sres <- runResponse res
97+ -- FIXME cookie processing
98+ return sres
99+
100+runResponse :: Response -> C.ResourceT IO SResponse
101+runResponse res = do
102+ bss <- fmap2 toBuilder body C.$= builderToByteString C.$$ CL.consume
103+ return $ SResponse s h $ L.fromChunks bss
104+ where
105+ (s, h, body) = responseSource res
106+ toBuilder (C.Chunk builder) = builder
107+ toBuilder C.Flush = flush
108+
109+fmap2 :: Functor m => (a -> b) -> C.Source m a -> C.Source m b
110+fmap2 f (C.HaveOutput p c o) = C.HaveOutput (fmap2 f p) c (f o)
111+fmap2 f (C.NeedInput p c) = C.NeedInput (fmap2 f . p) (fmap2 f c)
112+fmap2 _ (C.Done i r) = C.Done i r
113+fmap2 f (C.PipeM mp c) = C.PipeM (fmap (fmap2 f) mp) c
114+
115+assertBool :: String -> Bool -> Session ()
116+assertBool s b = liftIO $ H.assertBool s b
117+
118+assertString :: String -> Session ()
119+assertString s = liftIO $ H.assertString s
120+
121+assertContentType :: ByteString -> SResponse -> Session ()
122+assertContentType ct SResponse{simpleHeaders = h} =
123+ case lookup "content-type" h of
124+ Nothing -> assertString $ concat
125+ [ "Expected content type "
126+ , show ct
127+ , ", but no content type provided"
128+ ]
129+ Just ct' -> assertBool (concat
130+ [ "Expected content type "
131+ , show ct
132+ , ", but received "
133+ , show ct'
134+ ]) (go ct == go ct')
135+ where
136+ go = S8.takeWhile (/= ';')
137+
138+assertStatus :: Int -> SResponse -> Session ()
139+assertStatus i SResponse{simpleStatus = s} = assertBool (concat
140+ [ "Expected status code "
141+ , show i
142+ , ", but received "
143+ , show sc
144+ ]) $ i == sc
145+ where
146+ sc = H.statusCode s
147+
148+assertBody :: L.ByteString -> SResponse -> Session ()
149+assertBody lbs SResponse{simpleBody = lbs'} = assertBool (concat
150+ [ "Expected response body "
151+ , show $ L8.unpack lbs
152+ , ", but received "
153+ , show $ L8.unpack lbs'
154+ ]) $ lbs == lbs'
155+
156+assertBodyContains :: L.ByteString -> SResponse -> Session ()
157+assertBodyContains lbs SResponse{simpleBody = lbs'} = assertBool (concat
158+ [ "Expected response body to contain "
159+ , show $ L8.unpack lbs
160+ , ", but received "
161+ , show $ L8.unpack lbs'
162+ ]) $ strict lbs `S.isInfixOf` strict lbs'
163+ where
164+ strict = S.concat . L.toChunks
165+
166+assertHeader :: CI ByteString -> ByteString -> SResponse -> Session ()
167+assertHeader header value SResponse{simpleHeaders = h} =
168+ case lookup header h of
169+ Nothing -> assertString $ concat
170+ [ "Expected header "
171+ , show header
172+ , " to be "
173+ , show value
174+ , ", but it was not present"
175+ ]
176+ Just value' -> assertBool (concat
177+ [ "Expected header "
178+ , show header
179+ , " to be "
180+ , show value
181+ , ", but received "
182+ , show value'
183+ ]) (value == value')
184+
185+assertNoHeader :: CI ByteString -> SResponse -> Session ()
186+assertNoHeader header SResponse{simpleHeaders = h} =
187+ case lookup header h of
188+ Nothing -> return ()
189+ Just s -> assertString $ concat
190+ [ "Unexpected header "
191+ , show header
192+ , " containing "
193+ , show s
194+ ]
wai-test/READMEnew file

No changes to the content.

wai-test/Setup.lhsnew file+8
@@ -0,0 +1,8 @@
1+#!/usr/bin/env runhaskell
2+
3+> module Main where
4+> import Distribution.Simple
5+> import System.Cmd (system)
6+
7+> main :: IO ()
8+> main = defaultMain
wai-test/wai-test.cabalnew file+34
@@ -0,0 +1,34 @@
1+name: wai-test
2+version: 1.2.0
3+license: MIT
4+license-file: LICENSE
5+author: Michael Snoyman <michael@snoyman.com>
6+maintainer: Michael Snoyman <michael@snoyman.com>
7+synopsis: Unit test framework (built on HUnit) for WAI applications.
8+category: Testing, Web, Yesod
9+stability: Stable
10+cabal-version: >= 1.6
11+build-type: Simple
12+homepage: http://www.yesodweb.com/book/wai
13+description: Unit test framework (built on HUnit) for WAI applications.
14+
15+library
16+ build-depends: base >= 4 && < 5
17+ , wai >= 1.2 && < 1.3
18+ , bytestring >= 0.9.1.4 && < 0.10
19+ , text >= 0.7 && < 0.12
20+ , blaze-builder >= 0.2.1.4 && < 0.4
21+ , transformers >= 0.2.2 && < 0.4
22+ , containers >= 0.2 && < 0.5
23+ , conduit >= 0.4 && < 0.5
24+ , blaze-builder-conduit >= 0.4 && < 0.5
25+ , cookie >= 0.2 && < 0.5
26+ , HUnit >= 1.2 && < 1.3
27+ , http-types >= 0.6 && < 0.7
28+ , case-insensitive >= 0.2
29+ exposed-modules: Network.Wai.Test
30+ ghc-options: -Wall
31+
32+source-repository head
33+ type: git
34+ location: git://github.com/yesodweb/wai.git
wai-websockets/ChangeLog.mddeleted−27
@@ -1,27 +0,0 @@
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
26−
27−Allow blaze-builder 0.4
wai-websockets/LICENSE+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2010, Suite Solutions. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai-websockets/Network/Wai/Handler/WebSockets.hs+54−107
@@ -1,118 +1,65 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Network.Wai.Handler.WebSockets
2module Network.Wai.Handler.WebSockets
3− ( websocketsOr
3+ ( intercept
4− , websocketsApp
4+ , interceptWith
5− , isWebSocketsReq
6− , getRequestHead
7− , runWebSockets
8 ) where
5 ) where
9
6
10−import Control.Exception (bracket, tryJust)
7+import Control.Monad.IO.Class (liftIO)
11−import Data.ByteString (ByteString)
8+import Data.ByteString (ByteString)
9+import Data.Char (toLower)
12−import qualified Data.ByteString.Char8 as BC
10+import qualified Data.ByteString.Char8 as S
13−import qualified Data.ByteString.Lazy as BL
11+import qualified Data.Conduit as C
14−import qualified Data.CaseInsensitive as CI
12+import qualified Data.Enumerator as E
15−import Network.HTTP.Types (status500)
16−import qualified Network.Wai as Wai
13+import qualified Network.Wai as Wai
17−import qualified Network.WebSockets as WS
14+import qualified Network.Wai.Handler.Warp as Warp
18−import qualified Network.WebSockets.Connection as WS
19−import qualified Network.WebSockets.Stream as WS
15+import qualified Network.WebSockets as WS
20
16
21−--------------------------------------------------------------------------------
17+-- | For use with 'settingsIntercept' from the Warp web server.
22−-- | Returns whether or not the given 'Wai.Request' is a WebSocket request.
18+intercept :: WS.Protocol p
23−isWebSocketsReq :: Wai.Request -> Bool
19+ => (WS.Request -> WS.WebSockets p ())
24−isWebSocketsReq req =
20+ -> Wai.Request
25− fmap CI.mk (lookup "upgrade" $ Wai.requestHeaders req) == Just "websocket"
21+ -> Maybe (C.Source (C.ResourceT IO) ByteString -> Warp.Connection -> C.ResourceT IO ())
22+intercept = interceptWith WS.defaultWebSocketsOptions
26
23
27−--------------------------------------------------------------------------------
24+-- | Variation of 'intercept' which allows custom options.
28−-- | Upgrade a @websockets@ 'WS.ServerApp' to a @wai@ 'Wai.Application'. Uses
25+interceptWith :: WS.Protocol p
29−-- the given backup 'Wai.Application' to handle 'Wai.Request's that are not
26+ => WS.WebSocketsOptions
30−-- WebSocket requests.
27+ -> (WS.Request -> WS.WebSockets p ())
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−-- @
54−websocketsOr :: WS.ConnectionOptions
55− -> WS.ServerApp
56− -> Wai.Application
57− -> Wai.Application
58−websocketsOr opts app backup req sendResponse =
59− case websocketsApp opts app req of
60− Nothing -> backup req sendResponse
61− Just res -> sendResponse res
62−
63−--------------------------------------------------------------------------------
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.
69−websocketsApp :: WS.ConnectionOptions
70− -> WS.ServerApp
71 -> Wai.Request
28 -> Wai.Request
72− -> Maybe Wai.Response
29+ -> Maybe (C.Source (C.ResourceT IO) ByteString -> Warp.Connection -> C.ResourceT IO ())
73−websocketsApp opts app req
30+interceptWith opts app req = case lookup "upgrade" $ Wai.requestHeaders req of
74− | isWebSocketsReq req =
31+ Just s
75− Just $ flip Wai.responseRaw backup $ \src sink ->
76− runWebSockets opts req' app src sink
32+ | S.map toLower s == "websocket" -> Just $ runWebSockets opts req' app
33+ | otherwise -> Nothing
77− | otherwise = Nothing
34+ _ -> Nothing
78 where
35 where
79− req' = getRequestHead req
80− backup = Wai.responseLBS status500 [("Content-Type", "text/plain")]
81− "The web application attempted to send a WebSockets response, but WebSockets are not supported by your WAI handler."
82−
83−--------------------------------------------------------------------------------
84−getRequestHead :: Wai.Request -> WS.RequestHead
85−getRequestHead req = WS.RequestHead
86− (Wai.rawPathInfo req `BC.append` Wai.rawQueryString req)
87− (Wai.requestHeaders req)
36+ req' = WS.RequestHttpPart (Wai.rawPathInfo req) (Wai.requestHeaders req)
88− (Wai.isSecure req)
37+ (Wai.isSecure req)
89
38
90−--------------------------------------------------------------------------------
91−-- | Internal function to run the WebSocket io-streams using the conduit library.
39+-- | Internal function to run the WebSocket iteratee using the conduit library
92−runWebSockets :: WS.ConnectionOptions
40+runWebSockets :: WS.Protocol p
93− -> WS.RequestHead
41+ => WS.WebSocketsOptions
94− -> (WS.PendingConnection -> IO a)
42+ -> WS.RequestHttpPart
43+ -> (WS.Request -> WS.WebSockets p ())
95− -> IO ByteString
44+ -> C.Source (C.ResourceT IO) ByteString
96− -> (ByteString -> IO ())
45+ -> Warp.Connection
97− -> IO a
46+ -> C.ResourceT IO ()
98−runWebSockets opts req app src sink = bracket mkStream ensureClose (app . pc)
47+runWebSockets opts req app source conn = do
48+ step <- liftIO $ E.runIteratee $ WS.runWebSocketsWith opts req app send
49+ source C.$$ C.sinkState (E.returnI step) push close
99 where
50 where
100− ensureClose = tryJust onConnectionException . WS.close
51+ send = iterConnection conn
101− onConnectionException :: WS.ConnectionException -> Maybe ()
102− onConnectionException WS.ConnectionClosed = Just ()
103− onConnectionException _ = Nothing
104− mkStream =
105− WS.makeStream
106− (do
107− bs <- src
108− return $ if BC.null bs then Nothing else Just bs)
109− (\mbBl -> case mbBl of
110− Nothing -> return ()
111− Just bl -> mapM_ sink (BL.toChunks bl))
112
52
113− pc stream = WS.PendingConnection
53+ push iter bs = do
114− { WS.pendingOptions = opts
54+ step <- liftIO $ E.runIteratee $ E.enumList 1 [bs] E.$$ iter
115− , WS.pendingRequest = req
55+ return $ C.StateProcessing $ E.returnI step
116− , WS.pendingOnAccept = \_ -> return ()
56+ close iter = do
117− , WS.pendingStream = stream
57+ _ <- liftIO $ E.runIteratee $ E.enumEOF E.$$ iter
118− }
58+ return ()
59+
60+iterConnection :: Warp.Connection -> E.Iteratee ByteString IO ()
61+iterConnection c = E.continue go
62+ where
63+ go (E.Chunks []) = E.continue go
64+ go (E.Chunks cs) = E.tryIO (Warp.connSendMany c cs) >> E.continue go
65+ go E.EOF = E.continue go
wai-websockets/README.mddeleted−3
@@ -1,3 +0,0 @@
1−## wai-websockets
2−
3−Use websockets with WAI applications, primarily those hosted via Warp.
wai-websockets/server.lhs+64−62
@@ -8,17 +8,16 @@ 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 (fromException)
17−> import Control.Monad (forM_, forever)
15+> import Control.Monad (forM_)
18−> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, modifyMVar)
16+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
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
20+
22> import qualified Network.WebSockets as WS
21> import qualified Network.WebSockets as WS
23> import qualified Network.Wai
22> import qualified Network.Wai
24> import qualified Network.Wai.Handler.Warp as Warp
23> import qualified Network.Wai.Handler.Warp as Warp
@@ -26,11 +25,14 @@ nearby to check out the functions we use.
26> import qualified Network.Wai.Application.Static as Static
25> import qualified Network.Wai.Application.Static as Static
27> import Data.FileEmbed (embedDir)
26> import Data.FileEmbed (embedDir)
28
27
28+We represent a client by his username and a 'WS.Sender'. We can use this sender
29+to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`
30+here does not imply that our server is only compatible with the `hybi-00`
31+version of the protocol, for more details on this, see the
32+[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html)
33+reference.
29
34
30−We represent a client by their username and a `WS.Connection`. We will see how we
31−obtain this `WS.Connection` later on.
32−
33−> type Client = (Text, WS.Connection)
35+> type Client = (Text, WS.Sink WS.Hybi00)
34
36
35The state kept on the server is simply a list of connected clients. We've added
37The state kept on the server is simply a list of connected clients. We've added
36an alias and some utility functions, so it will be easier to extend this state
38an alias and some utility functions, so it will be easier to extend this state
@@ -38,104 +40,101 @@ later on.
38
40
39> type ServerState = [Client]
41> type ServerState = [Client]
40
42
41−Create a new, initial state:
43+Create a new, initial state
42
44
43> newServerState :: ServerState
45> newServerState :: ServerState
44> newServerState = []
46> newServerState = []
45
47
46−Get the number of active clients:
48+Get the number of active clients
47
49
48> numClients :: ServerState -> Int
50> numClients :: ServerState -> Int
49> numClients = length
51> numClients = length
50
52
51−Check if a user already exists (based on username):
53+Check if a user already exists (based on username)
52
54
53> clientExists :: Client -> ServerState -> Bool
55> clientExists :: Client -> ServerState -> Bool
54> clientExists client = any ((== fst client) . fst)
56> clientExists client = any ((== fst client) . fst)
55
57
56−Add a client (this does not check if the client already exists, you should do
58+Add a client (first, you should verify the client is not already connected using
57−this yourself using `clientExists`):
59+'clientExists')
58
60
59> addClient :: Client -> ServerState -> ServerState
61> addClient :: Client -> ServerState -> ServerState
60> addClient client clients = client : clients
62> addClient client clients = client : clients
61
63
62−Remove a client:
64+Remove a client
63
65
64> removeClient :: Client -> ServerState -> ServerState
66> removeClient :: Client -> ServerState -> ServerState
65> removeClient client = filter ((/= fst client) . fst)
67> removeClient client = filter ((/= fst client) . fst)
66
68
67−Send a message to all clients, and log it on stdout:
69+Send a message to all clients, and log it on stdout.
68
70
69> broadcast :: Text -> ServerState -> IO ()
71> broadcast :: Text -> ServerState -> IO ()
70> broadcast message clients = do
72> broadcast message clients = do
71> T.putStrLn message
73> T.putStrLn message
72−> forM_ clients $ \(_, conn) -> WS.sendTextData conn message
74+> forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message
73
75
74The main function first creates a new state for the server, then spawns the
76The main function first creates a new state for the server, then spawns the
75−actual server.
77+actual server. For this purpose, we use the simple server provided by
78+'WS.runServer'.
76
79
77> main :: IO ()
80> main :: IO ()
78> main = do
81> main = do
79> putStrLn "http://localhost:9160/client.html"
82> putStrLn "http://localhost:9160/client.html"
80> state <- newMVar newServerState
83> state <- newMVar newServerState
81−> Warp.runSettings
84+> Warp.runSettings Warp.defaultSettings
82−> (Warp.setPort 9160 Warp.defaultSettings)
85+> { Warp.settingsPort = 9160
83−> $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp
86+> , Warp.settingsIntercept = WaiWS.intercept (application state)
87+> } staticApp
84
88
85> staticApp :: Network.Wai.Application
89> staticApp :: Network.Wai.Application
86−> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
90+> staticApp = Static.staticApp Static.defaultFileServerSettings
91+> { Static.ssFolder = Static.embeddedLookup $ Static.toEmbedded $(embedDir "static")
92+> }
87
93
88−Our main application has the type:
94+When a client connects, we accept the connection, regardless of the path.
89
95
90−> application :: MVar ServerState -> WS.ServerApp
96+> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
97+> application state rq = do
98+> WS.acceptRequest rq
91
99
92−Note that `WS.ServerApp` is nothing but a type synonym for
100+We log some information here: in particular, we are interested in the protocol
93−`WS.PendingConnection -> IO ()`.
101+version our client is using (for debugging purposes).
94
102
95−Our application starts by accepting the connection. In a more realistic
103+> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
96−application, you probably want to check the path and headers provided by the
97−pending request.
98
104
99−We also fork a pinging thread in the background. This will ensure the connection
105+If we want to be able to send data to this client later, from another thread, we
100−stays alive on some browsers.
106+obtain a sink. We will add this to the server state later.
101
107
102−> application state pending = do
108+> sink <- WS.getSink
103−> conn <- WS.acceptRequest pending
104−#if __GLASGOW_HASKELL__ >= 806
105−> WS.withPingThread conn 30 (return ()) $ do
106−#else
107−> WS.forkPingThread conn 30
108−#endif
109
109
110−When a client is successfully connected, we read the first message. This should
110+When a client is succesfully connected, we read the first message. This should
111−be in the format of "Hi! I am Jasper", where Jasper is the requested username.
111+be in the format of "Hi, I am Jasper", where Jasper is the requested username.
112
112
113−> msg <- WS.receiveData conn
113+> msg <- WS.receiveData
114> clients <- liftIO $ readMVar state
114> clients <- liftIO $ readMVar state
115> case msg of
115> case msg of
116
116
117−Check that the first message has the right format:
117+Check that the first message has the right format
118
118
119> _ | not (prefix `T.isPrefixOf` msg) ->
119> _ | not (prefix `T.isPrefixOf` msg) ->
120−> WS.sendTextData conn ("Wrong announcement" :: Text)
120+> WS.sendTextData ("Wrong announcement" :: Text)
121
121
122−Check the validity of the username:
122+Check the validity of the username
123
123
124> | any ($ fst client)
124> | any ($ fst client)
125> [T.null, T.any isPunctuation, T.any isSpace] ->
125> [T.null, T.any isPunctuation, T.any isSpace] ->
126−> WS.sendTextData conn ("Name cannot " `mappend`
126+> WS.sendTextData ("Name cannot " `mappend`
127> "contain punctuation or whitespace, and " `mappend`
127> "contain punctuation or whitespace, and " `mappend`
128> "cannot be empty" :: Text)
128> "cannot be empty" :: Text)
129
129
130−Check that the given username is not already taken:
130+Check that the given username is not already taken
131
131
132> | clientExists client clients ->
132> | clientExists client clients ->
133−> WS.sendTextData conn ("User already exists" :: Text)
133+> WS.sendTextData ("User already exists" :: Text)
134
134
135−All is right! We're going to allow the client, but for safety reasons we *first*
135+All is right!
136−setup a `disconnect` function that will be run when the exception is closed.
137
136
138−> | otherwise -> flip finally disconnect $ do
137+> | otherwise -> do
139
138
140We send a "Welcome!", according to our own little protocol. We add the client to
139We send a "Welcome!", according to our own little protocol. We add the client to
141the list and broadcast the fact that he has joined. Then, we give control to the
140the list and broadcast the fact that he has joined. Then, we give control to the
@@ -143,26 +142,29 @@ the list and broadcast the fact that he has joined. Then, we give control to the
143
142
144> liftIO $ modifyMVar_ state $ \s -> do
143> liftIO $ modifyMVar_ state $ \s -> do
145> let s' = addClient client s
144> let s' = addClient client s
146−> WS.sendTextData conn $
145+> WS.sendSink sink $ WS.textData $
147> "Welcome! Users: " `mappend`
146> "Welcome! Users: " `mappend`
148> T.intercalate ", " (map fst s)
147> T.intercalate ", " (map fst s)
149> broadcast (fst client `mappend` " joined") s'
148> broadcast (fst client `mappend` " joined") s'
150> return s'
149> return s'
151−> talk conn state client
150+> talk state client
152> where
151> where
153−> prefix = "Hi! I am "
152+> prefix = "Hi! I am "
154−> client = (T.drop (T.length prefix) msg, conn)
153+> client = (T.drop (T.length prefix) msg, sink)
155−> disconnect = do
156−> -- Remove client and return new state
157−> s <- modifyMVar state $ \s ->
158−> let s' = removeClient client s in return (s', s')
159−> broadcast (fst client `mappend` " disconnected") s
160
154
161The talk function continues to read messages from a single client until he
155The talk function continues to read messages from a single client until he
162disconnects. All messages are broadcasted to the other clients.
156disconnects. All messages are broadcasted to the other clients.
163
157
164−> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
158+> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()
165−> talk conn state (user, _) = forever $ do
159+> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do
166−> msg <- WS.receiveData conn
160+> msg <- WS.receiveData
167> liftIO $ readMVar state >>= broadcast
161> liftIO $ readMVar state >>= broadcast
168> (user `mappend` ": " `mappend` msg)
162> (user `mappend` ": " `mappend` msg)
163+> talk state client
164+> where
165+> catchDisconnect e = case fromException e of
166+> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
167+> let s' = removeClient client s
168+> broadcast (user `mappend` " disconnected") s'
169+> return s'
170+> _ -> return ()
wai-websockets/static/client.html+2−1
@@ -1,7 +1,8 @@
1<html>
1<html>
2 <head>
2 <head>
3 <title>Haskell WebSockets example</title>
3 <title>Haskell WebSockets example</title>
4+ <script type="text/JavaScript"
4− <script src="//ajax.googleapis.com/ajax/libs/jquery/1.9.0/jquery.min.js"></script>
5+ src="http://code.jquery.com/jquery-1.6.3.min.js"></script>
5 <script type="text/JavaScript" src="client.js"></script>
6 <script type="text/JavaScript" src="client.js"></script>
6 <link rel="stylesheet" type="text/css" href="screen.css"></script>
7 <link rel="stylesheet" type="text/css" href="screen.css"></script>
7 </head>
8 </head>
wai-websockets/wai-websockets.cabal+21−16
@@ -1,53 +1,58 @@
1Name: wai-websockets
1Name: wai-websockets
2−Version: 3.0.1.2
2+Version: 1.2.0
3−Synopsis: Provide a bridge between WAI and the websockets package.
3+Synopsis: Provide a bridge betweeen WAI and the websockets package.
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE
6−Author: Michael Snoyman, Jasper Van der Jeugt, Ting-Yen Lai
6+Author: Michael Snoyman, Jasper Van der Jeugt
7Maintainer: michael@snoyman.com
7Maintainer: 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
11Cabal-Version: >=1.8
11Cabal-Version: >=1.8
12Stability: Stable
12Stability: Stable
13−description: API docs and the README are available at <http://www.stackage.org/package/wai-websockets>.
13+Description: This is primarily intended for use with Warp and its settingsIntercept.
14
14
15extra-source-files: static/client.js, static/client.html, static/screen.css
15extra-source-files: static/client.js, static/client.html, static/screen.css
16− README.md ChangeLog.md
17
16
18flag example
17flag example
19
18
20Library
19Library
21 Build-Depends: base >= 3 && < 5
20 Build-Depends: base >= 3 && < 5
22− , bytestring >= 0.9.1.4
21+ , bytestring >= 0.9.1.4 && < 0.10
22+ , conduit >= 0.4 && < 0.5
23− , wai >= 3.0 && < 3.3
23+ , wai >= 1.2 && < 1.3
24+ , enumerator >= 0.4.8 && < 0.5
25+ , network-enumerator >= 0.1.2 && < 0.2
26+ , blaze-builder >= 0.2.1.4 && < 0.4
24 , case-insensitive >= 0.2
27 , case-insensitive >= 0.2
25− , network >= 2.2.1.5
28+ , network >= 2.2.1.5 && < 2.4
26− , transformers >= 0.2
29+ , transformers >= 0.2 && < 0.4
27− , websockets >= 0.9
30+ , websockets >= 0.6 && < 0.7
28− , http-types
31+ , warp >= 1.2 && < 1.3
29 Exposed-modules: Network.Wai.Handler.WebSockets
32 Exposed-modules: Network.Wai.Handler.WebSockets
30 ghc-options: -Wall
33 ghc-options: -Wall
31
34
32Executable wai-websockets-example
35Executable wai-websockets-example
33 if flag(example)
36 if flag(example)
34 buildable: True
37 buildable: True
38+ else
39+ buildable: False
35− Build-Depends: base >= 3 && < 5
40+ Build-Depends: base >= 3 && < 5
41+ , conduit
36 , wai-websockets
42 , wai-websockets
37 , websockets
43 , websockets
44+ , network-enumerator
38 , warp
45 , warp
39 , wai
46 , wai
40 , wai-app-static
47 , wai-app-static
41 , bytestring
48 , bytestring
42 , case-insensitive
49 , case-insensitive
50+ , blaze-builder
51+ , enumerator
43 , transformers
52 , transformers
44 , network
53 , network
45 , text
54 , text
46 , file-embed
55 , file-embed
47− , http-types
48− other-modules: Network.Wai.Handler.WebSockets
49− else
50− buildable: False
51
56
52 ghc-options: -Wall -threaded
57 ghc-options: -Wall -threaded
53 main-is: server.lhs
58 main-is: server.lhs
wai/.ghcideleted−2
@@ -1,2 +0,0 @@
1−:set -optP-include -optPdist/build/autogen/cabal_macros.h -pgmL markdown-unlit
2−:set -i../warp -i../warp/dist/build/autogen/ -optP-include -optP../warp/dist/build/autogen/cabal_macros.h
wai/ChangeLog.mddeleted−56
@@ -1,56 +0,0 @@
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
50−
51−* Allow blaze-builder 0.4
52−
53−## 3.0.2.2
54−
55−* Clarify some documentation on `rawPathInfo`. [Relevant Github
56− discussion](https://github.com/yesodweb/wai/issues/325#issuecomment-69896780).
wai/LICENSE+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2010, Michael Snoyman. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
wai/Network/Wai.hs+105−276
@@ -1,14 +1,16 @@
1+{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
1{-|
4{-|
2
5
3This module defines a generic web application interface. It is a common
6This module defines a generic web application interface. It is a common
4protocol between web servers and web applications.
7protocol between web servers and web applications.
5
8
6−The overriding design principles here are performance and generality. To
9+The overriding design principles here are performance and generality . To
7−address performance, this library uses a streaming interface for request and
10+address performance, this library is built on top of the enumerator and
8−response bodies, paired with bytestring's 'Builder' type. The advantages of a
11+blaze-builder packages. The advantages of enumerators 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
12+debated elsewhere and so will not be addressed here. However, helper functions
11−continue using lazy IO if you so desire.
13+like 'responseLBS' allow you to continue using lazy IO if you so desire.
12
14
13Generality is achieved by removing many variables commonly found in similar
15Generality is achieved by removing many variables commonly found in similar
14projects that are not universal to all servers. The goal is that the 'Request'
16projects that are not universal to all servers. The goal is that the 'Request'
@@ -30,83 +32,76 @@ include:
30
32
31[wai-extra] <http://hackage.haskell.org/package/wai-extra>
33[wai-extra] <http://hackage.haskell.org/package/wai-extra>
32
34
35+[wai-test] <http://hackage.haskell.org/package/wai-test>
36+
33-}
37-}
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
38module Network.Wai
37− (
39+ ( -- * WAI interface
38− -- * Types
40+ Request (..)
41+ , Response (..)
42+ , responseSource
39− Application
43+ , Application
40 , Middleware
44 , Middleware
41− , ResponseReceived
42− -- * Request
43− , Request
44− , defaultRequest
45− , RequestBodyLength (..)
46− -- ** Request accessors
47− , requestMethod
48− , httpVersion
49− , rawPathInfo
50− , rawQueryString
51− , requestHeaders
52− , isSecure
53− , remoteHost
54− , pathInfo
55− , queryString
56− , getRequestBodyChunk
57− , requestBody
58− , vault
59− , requestBodyLength
60− , requestHeaderHost
61− , requestHeaderRange
62− , requestHeaderReferer
63− , requestHeaderUserAgent
64− , strictRequestBody
65− , lazyRequestBody
66− -- * Response
67− , Response
68− , StreamingBody
69 , FilePart (..)
45 , FilePart (..)
70− -- ** Response composers
46+ -- * Response body smart constructors
71− , responseFile
72− , responseBuilder
73 , responseLBS
47 , responseLBS
74− , responseStream
75− , responseRaw
76− -- ** Response accessors
77 , responseStatus
48 , responseStatus
78− , responseHeaders
79− -- ** Response modifiers
80− , responseToStream
81− , mapResponseHeaders
82− , mapResponseStatus
83− -- * Middleware composition
84− , ifRequest
85− , modifyResponse
86 ) where
49 ) where
87
50
88−import Data.ByteString.Builder (Builder, lazyByteString)
89−import Data.ByteString.Builder (byteString)
90−import Control.Monad (unless)
91−import qualified Data.ByteString as B
51+import qualified Data.ByteString as B
92−import qualified Data.ByteString.Lazy as L
52+import qualified Data.ByteString.Lazy as L
93−import qualified Data.ByteString.Lazy.Internal as LI
53+import Data.Typeable (Typeable)
94−import Data.ByteString.Lazy.Internal (defaultChunkSize)
54+import qualified Data.Conduit as C
95−import Data.ByteString.Lazy.Char8 ()
55+import qualified Data.Conduit.List as CL
96−import Data.Function (fix)
56+import qualified Data.Conduit.Binary as CB
57+import Blaze.ByteString.Builder (Builder, fromLazyByteString)
58+import Network.Socket (SockAddr)
97−import qualified Network.HTTP.Types as H
59+import qualified Network.HTTP.Types as H
98−import Network.Socket (SockAddr (SockAddrInet))
60+import Data.Text (Text)
99−import Network.Wai.Internal
61+import Data.ByteString.Lazy.Char8 () -- makes it easier to use responseLBS
100−import qualified System.IO as IO
62+import Blaze.ByteString.Builder (fromByteString)
101−import System.IO.Unsafe (unsafeInterleaveIO)
63+import Data.Vault (Vault)
102−
64+
103−----------------------------------------------------------------
65+-- | Information on the request sent by the client. This abstracts away the
104−
66+-- details of the underlying implementation.
105−-- | Creating 'Response' from a file.
67+data Request = Request
106−responseFile :: H.Status -> H.ResponseHeaders -> FilePath -> Maybe FilePart -> Response
68+ { requestMethod :: H.Method
107−responseFile = ResponseFile
69+ , httpVersion :: H.HttpVersion
108−
70+ -- | Extra path information sent by the client. The meaning varies slightly
109−-- | Creating 'Response' from 'Builder'.
71+ -- depending on backend; in a standalone server setting, this is most likely
72+ -- all information after the domain name. In a CGI application, this would be
73+ -- the information following the path to the CGI executable itself.
74+ -- Do not modify this raw value- modify pathInfo instead.
75+ , rawPathInfo :: B.ByteString
76+ -- | If no query string was specified, this should be empty. This value
77+ -- /will/ include the leading question mark.
78+ -- Do not modify this raw value- modify queryString instead.
79+ , rawQueryString :: B.ByteString
80+ -- | Generally the host requested by the user via the Host request header.
81+ -- Backends are free to provide alternative values as necessary. This value
82+ -- should not be used to construct URLs.
83+ , serverName :: B.ByteString
84+ -- | The listening port that the server received this request on. It is
85+ -- possible for a server to listen on a non-numeric port (i.e., Unix named
86+ -- socket), in which case this value will be arbitrary. Like 'serverName',
87+ -- this value should not be used in URL construction.
88+ , serverPort :: Int
89+ , requestHeaders :: H.RequestHeaders
90+ -- | Was this request made over an SSL connection?
91+ , isSecure :: Bool
92+ -- | The client\'s host information.
93+ , remoteHost :: SockAddr
94+ -- | Path info in individual pieces- the url without a hostname/port and without a query string, split on forward slashes,
95+ , pathInfo :: [Text]
96+ -- | Parsed query string information
97+ , queryString :: H.Query
98+ , requestBody :: C.Source (C.ResourceT IO) B.ByteString
99+ -- | A location for arbitrary data to be shared by applications and middleware.
100+ , vault :: Vault
101+ }
102+ deriving (Typeable)
103+
104+-- |
110--
105--
111-- Some questions and answers about the usage of 'Builder' here:
106-- Some questions and answers about the usage of 'Builder' here:
112--
107--
@@ -121,172 +116,49 @@ responseFile = ResponseFile
121--
116--
122-- A2. No. If the ByteStrings are small, then they will be copied into a larger
117-- 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
118-- buffer, which should be a performance gain overall (less system calls). If
124−-- they are already large, then an insert operation is used
119+-- they are already large, then blaze-builder uses an InsertByteString
125−-- to avoid copying.
120+-- instruction to avoid copying.
126--
121--
127-- Q3. Doesn't this prevent us from creating comet-style servers, since data
122-- Q3. Doesn't this prevent us from creating comet-style servers, since data
128-- will be cached?
123-- will be cached?
129--
124--
130−-- A3. You can force a Builder to output a ByteString before it is an
125+-- A3. You can force blaze-builder to output a ByteString before it is an
131-- optimal size by sending a flush command.
126-- optimal size by sending a flush command.
127+data Response
132−responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response
128+ = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)
133−responseBuilder = ResponseBuilder
129+ | ResponseBuilder H.Status H.ResponseHeaders Builder
134−
130+ | ResponseSource H.Status H.ResponseHeaders (C.Source (C.ResourceT IO) (C.Flush Builder))
135−-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for
131+ deriving Typeable
136−-- 'responseBuilder'.
137−responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response
138−responseLBS s h = ResponseBuilder s h . lazyByteString
139
132
140−-- | Creating 'Response' from a stream of values.
141−--
142−-- In order to allocate resources in an exception-safe manner, you can use the
143−-- @bracket@ pattern outside of the call to @responseStream@. As a trivial
144−-- example:
145−--
146−-- @
147−-- app :: Application
148−-- app req respond = bracket_
149−-- (putStrLn \"Allocating scarce resource\")
150−-- (putStrLn \"Cleaning up\")
151−-- $ respond $ responseStream status200 [] $ \\write flush -> do
152−-- write $ byteString \"Hello\\n\"
153−-- flush
154−-- write $ byteString \"World\\n\"
155−-- @
156−--
157−-- Note that in some cases you can use @bracket@ from inside @responseStream@
158−-- as well. However, placing the call on the outside allows your status value
159−-- and response headers to depend on the scarce resource.
160−--
161−-- Since 3.0.0
162−responseStream :: H.Status
163− -> H.ResponseHeaders
164− -> StreamingBody
165− -> Response
166−responseStream = ResponseStream
167−
168−-- | Create a response for a raw application. This is useful for \"upgrade\"
169−-- situations such as WebSockets, where an application requests for the server
170−-- to grant it raw network access.
171−--
172−-- This function requires a backup response to be provided, for the case where
173−-- the handler in question does not support such upgrading (e.g., CGI apps).
174−--
175−-- In the event that you read from the request body before returning a
176−-- @responseRaw@, behavior is undefined.
177−--
178−-- Since 2.1.0
179−responseRaw :: (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ())
180− -> Response
181− -> Response
182−responseRaw = ResponseRaw
183−
184−----------------------------------------------------------------
185−
186−-- | Accessing 'H.Status' in 'Response'.
187responseStatus :: Response -> H.Status
133responseStatus :: Response -> H.Status
134+responseStatus rsp =
135+ case rsp of
188−responseStatus (ResponseFile s _ _ _) = s
136+ ResponseFile s _ _ _ -> s
189−responseStatus (ResponseBuilder s _ _ ) = s
137+ ResponseBuilder s _ _ -> s
190−responseStatus (ResponseStream s _ _ ) = s
138+ ResponseSource s _ _ -> s
191−responseStatus (ResponseRaw _ res ) = responseStatus res
139+
192−
140+data FilePart = FilePart
193−-- | Accessing 'H.ResponseHeaders' in 'Response'.
194−responseHeaders :: Response -> H.ResponseHeaders
195−responseHeaders (ResponseFile _ hs _ _) = hs
196−responseHeaders (ResponseBuilder _ hs _ ) = hs
197−responseHeaders (ResponseStream _ hs _ ) = hs
198−responseHeaders (ResponseRaw _ res) = responseHeaders res
199−
200−-- | Converting the body information in 'Response' to a 'StreamingBody'.
201−responseToStream :: Response
202− -> ( H.Status
203− , H.ResponseHeaders
204− , (StreamingBody -> IO a) -> IO a
205− )
206−responseToStream (ResponseStream s h b) = (s, h, ($ b))
207−responseToStream (ResponseFile s h fp (Just part)) =
208− ( s
209− , h
210− , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> withBody $ \sendChunk _flush -> do
211− IO.hSeek handle IO.AbsoluteSeek $ filePartOffset part
141+ { filePartOffset :: Integer
212− let loop remaining | remaining <= 0 = return ()
213− loop remaining = do
214− bs <- B.hGetSome handle defaultChunkSize
215− unless (B.null bs) $ do
216− let x = B.take remaining bs
217− sendChunk $ byteString x
218− loop $ remaining - B.length x
219− loop $ fromIntegral $ filePartByteCount part
142+ , filePartByteCount :: Integer
220− )
143+ } deriving Show
144+
145+responseSource :: Response -> (H.Status, H.ResponseHeaders, C.Source (C.ResourceT IO) (C.Flush Builder))
146+responseSource (ResponseSource s h b) = (s, h, b)
147+responseSource (ResponseFile s h fp (Just part)) =
148+ (s, h, sourceFilePart part fp C.$= CL.map (C.Chunk . fromByteString))
221−responseToStream (ResponseFile s h fp Nothing) =
149+responseSource (ResponseFile s h fp Nothing) =
222− ( s
150+ (s, h, CB.sourceFile fp C.$= CL.map (C.Chunk . fromByteString))
223− , h
224− , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle ->
225− withBody $ \sendChunk _flush -> fix $ \loop -> do
226− bs <- B.hGetSome handle defaultChunkSize
227− unless (B.null bs) $ do
228− sendChunk $ byteString bs
229− loop
230− )
231−responseToStream (ResponseBuilder s h b) =
151+responseSource (ResponseBuilder s h b) =
232− (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b)
152+ (s, h, CL.sourceList [C.Chunk b])
233−responseToStream (ResponseRaw _ res) = responseToStream res
153+
234−
154+sourceFilePart :: C.MonadResource m => FilePart -> FilePath -> C.Source m B.ByteString
235−-- | Apply the provided function to the response header list of the Response.
155+sourceFilePart (FilePart offset count) fp =
236−mapResponseHeaders :: (H.ResponseHeaders -> H.ResponseHeaders) -> Response -> Response
156+ CB.sourceFileRange fp (Just offset) (Just count)
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
157
242−-- | Apply the provided function to the response status of the Response.
158+responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response
243−mapResponseStatus :: (H.Status -> H.Status) -> Response -> Response
159+responseLBS s h = ResponseBuilder s h . fromLazyByteString
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−----------------------------------------------------------------
250−
251−-- | The WAI application.
252−--
253−-- Note that, since WAI 3.0, this type is structured in continuation passing
254−-- style to allow for proper safe resource handling. This was handled in the
255−-- past via other means (e.g., @ResourceT@). As a demonstration:
256−--
257−-- @
258−-- app :: Application
259−-- app req respond = bracket_
260−-- (putStrLn \"Allocating scarce resource\")
261−-- (putStrLn \"Cleaning up\")
262−-- (respond $ responseLBS status200 [] \"Hello World\")
263−-- @
264−type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
265−
266−
267−-- | A default, blank request.
268−--
269−-- Since 2.0.0
270−defaultRequest :: Request
271−defaultRequest = Request
272− { requestMethod = H.methodGet
273− , httpVersion = H.http10
274− , rawPathInfo = B.empty
275− , rawQueryString = B.empty
276− , requestHeaders = []
277− , isSecure = False
278− , remoteHost = SockAddrInet 0 0
279− , pathInfo = []
280− , queryString = []
281− , requestBody = return B.empty
282− , vault = mempty
283− , requestBodyLength = KnownLength 0
284− , requestHeaderHost = Nothing
285− , requestHeaderRange = Nothing
286− , requestHeaderReferer = Nothing
287− , requestHeaderUserAgent = Nothing
288− }
289
160
161+type Application = Request -> C.ResourceT IO Response
290
162
291-- | Middleware is a component that sits between the server and application. It
163-- | 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
164-- can do such tasks as GZIP encoding or response caching. What follows is the
@@ -295,7 +167,7 @@ defaultRequest = Request
295--
167--
296-- As an example of an alternate type for middleware, suppose you write a
168-- 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
169-- function to load up session information. The session information is simply a
298−-- string map \[(String, String)\]. A logical type signature for this middleware
170+-- string map \[(String, String)\]. A logical type signatures for this middleware
299-- might be:
171-- might be:
300--
172--
301-- @ loadSession :: ([(String, String)] -> Application) -> Application @
173-- @ loadSession :: ([(String, String)] -> Application) -> Application @
@@ -303,46 +175,3 @@ defaultRequest = Request
303-- Here, instead of taking a standard 'Application' as its first argument, the
175-- Here, instead of taking a standard 'Application' as its first argument, the
304-- middleware takes a function which consumes the session information as well.
176-- middleware takes a function which consumes the session information as well.
305type Middleware = Application -> Application
177type 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
321−-- I\/O, instead reading the entire body into memory strictly.
322−--
323−-- Since 3.0.1
324−strictRequestBody :: Request -> IO L.ByteString
325−strictRequestBody req =
326− loop id
327− where
328− loop front = do
329− bs <- getRequestBodyChunk req
330− if B.null bs
331− then return $ front LI.Empty
332− else loop (front . LI.Chunk bs)
333−
334−-- | Get the request body as a lazy ByteString. This uses lazy I\/O under the
335−-- surface, and therefore all typical warnings regarding lazy I/O apply.
336−--
337−-- Since 1.4.1
338−lazyRequestBody :: Request -> IO L.ByteString
339−lazyRequestBody req =
340− loop
341− where
342− loop = unsafeInterleaveIO $ do
343− bs <- getRequestBodyChunk req
344− if B.null bs
345− then return LI.Empty
346− else do
347− bss <- loop
348− return $ LI.Chunk bs bss
wai/Network/Wai/Internal.hsdeleted−161
@@ -1,161 +0,0 @@
1−{-# OPTIONS_HADDOCK not-home #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE RecordWildCards #-}
4−-- | Internal constructors and helper functions. Note that no guarantees are
5−-- given for stability of these interfaces.
6−module Network.Wai.Internal where
7−
8−import Data.ByteString.Builder (Builder)
9−import qualified Data.ByteString as B hiding (pack)
10−import Data.Text (Text)
11−import Data.Typeable (Typeable)
12−import Data.Vault.Lazy (Vault)
13−import Data.Word (Word64)
14−import qualified Network.HTTP.Types as H
15−import Network.Socket (SockAddr)
16−import Data.List (intercalate)
17−
18−-- | Information on the request sent by the client. This abstracts away the
19−-- details of the underlying implementation.
20−{-# DEPRECATED requestBody "requestBody's name is misleading because it only gets a partial chunk of the body. Use getRequestBodyChunk instead." #-}
21−data Request = Request {
22− -- | Request method such as GET.
23− requestMethod :: H.Method
24− -- | HTTP version such as 1.1.
25− , httpVersion :: H.HttpVersion
26− -- | Extra path information sent by the client. The meaning varies slightly
27− -- depending on backend; in a standalone server setting, this is most likely
28− -- all information after the domain name. In a CGI application, this would be
29− -- the information following the path to the CGI executable itself.
30− --
31− -- Middlewares and routing tools should not modify this raw value, as it may
32− -- be used for such things as creating redirect destinations by applications.
33− -- Instead, if you are writing a middleware or routing framework, modify the
34− -- @pathInfo@ instead. This is the approach taken by systems like Yesod
35− -- subsites.
36− --
37− -- /Note/: At the time of writing this documentation, there is at least one
38− -- system (@Network.Wai.UrlMap@ from @wai-extra@) that does not follow the
39− -- above recommendation. Therefore, it is recommended that you test the
40− -- behavior of your application when using @rawPathInfo@ and any form of
41− -- library that might modify the @Request@.
42− , rawPathInfo :: B.ByteString
43− -- | If no query string was specified, this should be empty. This value
44− -- /will/ include the leading question mark.
45− -- Do not modify this raw value - modify queryString instead.
46− , rawQueryString :: B.ByteString
47− -- | A list of headers (a pair of key and value) in an HTTP request.
48− , requestHeaders :: H.RequestHeaders
49− -- | Was this request made over an SSL connection?
50− --
51− -- Note that this value will /not/ tell you if the client originally made
52− -- this request over SSL, but rather whether the current connection is SSL.
53− -- The distinction lies with reverse proxies. In many cases, the client will
54− -- connect to a load balancer over SSL, but connect to the WAI handler
55− -- without SSL. In such a case, 'isSecure' will be 'False', but from a user
56− -- perspective, there is a secure connection.
57− , isSecure :: Bool
58− -- | The client\'s host information.
59− , remoteHost :: SockAddr
60− -- | Path info in individual pieces - the URL without a hostname/port and
61− -- without a query string, split on forward slashes.
62− , pathInfo :: [Text]
63− -- | Parsed query string information.
64− , queryString :: H.Query
65− -- | 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− , requestBody :: IO B.ByteString
68− -- | A location for arbitrary data to be shared by applications and middleware.
69− , vault :: Vault
70− -- | The size of the request body. In the case of a chunked request body,
71− -- this may be unknown.
72− --
73− -- Since 1.4.0
74− , requestBodyLength :: RequestBodyLength
75− -- | The value of the Host header in a HTTP request.
76− --
77− -- Since 2.0.0
78− , requestHeaderHost :: Maybe B.ByteString
79− -- | The value of the Range header in a HTTP request.
80− --
81− -- Since 2.0.0
82− , 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− }
92− deriving (Typeable)
93−
94−-- | Get the next chunk of the body. Returns 'B.empty' when the
95−-- body is fully consumed.
96−--
97−-- @since 3.2.2
98−getRequestBodyChunk :: Request -> IO B.ByteString
99−getRequestBodyChunk = requestBody
100−
101−instance Show Request where
102− show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"
103− where
104− fields =
105− [("requestMethod",show requestMethod)
106− ,("httpVersion",show httpVersion)
107− ,("rawPathInfo",show rawPathInfo)
108− ,("rawQueryString",show rawQueryString)
109− ,("requestHeaders",show requestHeaders)
110− ,("isSecure",show isSecure)
111− ,("remoteHost",show remoteHost)
112− ,("pathInfo",show pathInfo)
113− ,("queryString",show queryString)
114− ,("requestBody","<IO ByteString>")
115− ,("vault","<Vault>")
116− ,("requestBodyLength",show requestBodyLength)
117− ,("requestHeaderHost",show requestHeaderHost)
118− ,("requestHeaderRange",show requestHeaderRange)
119− ]
120−
121−
122−data Response
123− = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)
124− | ResponseBuilder H.Status H.ResponseHeaders Builder
125− | ResponseStream H.Status H.ResponseHeaders StreamingBody
126− | ResponseRaw (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) Response
127− deriving Typeable
128−
129−-- | Represents a streaming HTTP response body. It's a function of two
130−-- parameters; the first parameter provides a means of sending another chunk of
131−-- data, and the second parameter provides a means of flushing the data to the
132−-- client.
133−--
134−-- Since 3.0.0
135−type StreamingBody = (Builder -> IO ()) -> IO () -> IO ()
136−
137−-- | The size of the request body. In the case of chunked bodies, the size will
138−-- not be known.
139−--
140−-- Since 1.4.0
141−data RequestBodyLength = ChunkedBody | KnownLength Word64 deriving Show
142−
143−-- | Information on which part to be sent.
144−-- Sophisticated application handles Range (and If-Range) then
145−-- create 'FilePart'.
146−data FilePart = FilePart
147− { filePartOffset :: Integer
148− , filePartByteCount :: Integer
149− , filePartFileSize :: Integer
150− } deriving Show
151−
152−-- | A special datatype to indicate that the WAI handler has received the
153−-- response. This is to avoid the need for Rank2Types in the definition of
154−-- Application.
155−--
156−-- It is /highly/ advised that only WAI handlers import and use the data
157−-- constructor for this data type.
158−--
159−-- Since 3.0.0
160−data ResponseReceived = ResponseReceived
161− deriving Typeable
wai/README.lhsmode 120000 → 100644+113−1
@@ -1 +0,0 @@
1−README.md
@@ -0,0 +1,113 @@
1+WAI: Web Application Interface
2+==============================
3+
4+Getting started
5+---------------
6+
7+You want a minimal example? Here it is!
8+
9+> {-# LANGUAGE OverloadedStrings #-}
10+> import Network.Wai
11+> import Network.HTTP.Types
12+> import Network.Wai.Handler.Warp (run)
13+> import Data.ByteString.Lazy.Char8 () -- Just for an orphan instance
14+> import Control.Monad.IO.Class (liftIO)
15+>
16+> app :: Application
17+> app _ = do
18+> liftIO $ putStrLn "I've done some IO here"
19+> return $ responseLBS
20+> status200
21+> [("Content-Type", "text/plain")]
22+> "Hello, Web!"
23+>
24+> main :: IO ()
25+> main = do
26+> putStrLn $ "http://localhost:8080/"
27+> run 8080 app
28+
29+Put that code into a file named _hello.hs_ and install [wai] and
30+[warp] from Hackage:
31+
32+ cabal install wai warp
33+
34+Run it:
35+
36+ runhaskell hello.hs
37+
38+Point your browser to:
39+
40+ http://localhost:8080/
41+
42+
43+Serving static content
44+----------------------
45+
46+We can modify our previous example to serve static content. For this
47+create a file named _index.html_:
48+
49+ <p>Hello, Web!</p>
50+
51+Now we redefine `responseBody` to refer to that file:
52+
53+> app2 :: Application
54+> app2 _ = return index
55+>
56+> index = ResponseFile
57+> status200
58+> [("Content-Type", "text/html")]
59+> "index.html"
60+> Nothing
61+
62+
63+Basic dispatching
64+-----------------
65+
66+An `Application` maps `Request`s to `Response`s:
67+
68+ ghci> :info Application
69+ type Application = Request -> IO Response
70+
71+Depending on the path info provided with each `Request` we can serve
72+different `Response`s:
73+
74+> app3 :: Application
75+> app3 request = case rawPathInfo request of
76+> "/" -> return index
77+> "/raw/" -> return plainIndex
78+> _ -> return notFound
79+>
80+> plainIndex = ResponseFile
81+> status200
82+> [("Content-Type", "text/plain")]
83+> "index.html"
84+> Nothing
85+>
86+> notFound = responseLBS
87+> status404
88+> [("Content-Type", "text/plain")]
89+> "404 - Not Found"
90+
91+
92+Doing without overloaded strings
93+--------------------------------
94+
95+For the sake of efficiency, WAI uses the [bytestring] package. We used
96+GHCs [overloaded strings] to almost hide this fact. But we can easily do
97+without. What follows is a more verbose definition of `notFound`, that
98+works without GHC extensions:
99+
100+ import qualified Data.ByteString.Char8 as B8
101+ import qualified Data.ByteString.Lazy.Char8 as LB8
102+ import Data.CaseInsensitive (mk)
103+
104+ notFound = responseLBS
105+ status404
106+ [(mk $ B8.pack "Content-Type", B8.pack "text/plain")]
107+ (LB8.pack "404 - Not Found")
108+
109+
110+ [wai]: http://hackage.haskell.org/package/wai
111+ [warp]: http://hackage.haskell.org/package/warp
112+ [overloaded strings]: http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-strings
113+ [bytestring]: http://hackage.haskell.org/package/bytestring
wai/README.md+45−53
@@ -1,3 +1,4 @@
1+<!-- Generated from README.lhs, do not modify! -->
1WAI: Web Application Interface
2WAI: Web Application Interface
2==============================
3==============================
3
4
@@ -6,25 +7,25 @@ Getting started
6
7
7You want a minimal example? Here it is!
8You want a minimal example? Here it is!
8
9
9−~~~ {.haskell}
10−{-# LANGUAGE OverloadedStrings #-}
10+ {-# LANGUAGE OverloadedStrings #-}
11−import Network.Wai
11+ import Network.Wai
12−import Network.HTTP.Types
12+ import Network.HTTP.Types
13−import Network.Wai.Handler.Warp (run)
13+ import Network.Wai.Handler.Warp (run)
14−
14+ import Data.ByteString.Lazy.Char8 () -- Just for an orphan instance
15+ import Control.Monad.IO.Class (liftIO)
16+
15−app :: Application
17+ app :: Application
16−app _ respond = do
18+ app _ = do
17− putStrLn "I've done some IO here"
19+ liftIO $ putStrLn "I've done some IO here"
18− respond $ responseLBS
20+ return $ responseLBS
19 status200
21 status200
20 [("Content-Type", "text/plain")]
22 [("Content-Type", "text/plain")]
21 "Hello, Web!"
23 "Hello, Web!"
22
24
23−main :: IO ()
25+ main :: IO ()
24−main = do
26+ main = do
25− putStrLn $ "http://localhost:8080/"
27+ putStrLn $ "http://localhost:8080/"
26− run 8080 app
28+ run 8080 app
27−~~~
28
29
29Put that code into a file named _hello.hs_ and install [wai] and [warp] from Hackage:
30Put that code into a file named _hello.hs_ and install [wai] and [warp] from Hackage:
30
31
@@ -48,17 +49,14 @@ We can modify our previous example to serve static content. For this create a fi
48
49
49Now we redefine `responseBody` to refer to that file:
50Now we redefine `responseBody` to refer to that file:
50
51
51−~~~ {.haskell}
52−app2 :: Application
52+ app2 :: Application
53−app2 _ respond = respond index
53+ app2 _ = return index
54
54
55−index :: Response
55+ index = ResponseFile
56−index = responseFile
57− status200
56+ status200
58− [("Content-Type", "text/html")]
57+ [("Content-Type", "text/html")]
59− "index.html"
58+ "index.html"
60− Nothing
59+ Nothing
61−~~~
62
60
63
61
64Basic dispatching
62Basic dispatching
@@ -67,30 +65,26 @@ Basic dispatching
67An `Application` maps `Request`s to `Response`s:
65An `Application` maps `Request`s to `Response`s:
68
66
69 ghci> :info Application
67 ghci> :info Application
70− type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
68+ type Application = Request -> IO Response
71
69
72Depending on the path info provided with each `Request` we can serve different `Response`s:
70Depending on the path info provided with each `Request` we can serve different `Response`s:
73
71
74−~~~ {.haskell}
75−app3 :: Application
72+ app3 :: Application
76−app3 request respond = respond $ case rawPathInfo request of
73+ app3 request = case rawPathInfo request of
77− "/" -> index
74+ "/" -> return index
78− "/raw/" -> plainIndex
75+ "/raw/" -> return plainIndex
79− _ -> notFound
76+ _ -> return notFound
80
77
81−plainIndex :: Response
82−plainIndex = responseFile
78+ plainIndex = ResponseFile
83− status200
79+ status200
84− [("Content-Type", "text/plain")]
80+ [("Content-Type", "text/plain")]
85− "index.html"
81+ "index.html"
86− Nothing
82+ Nothing
87
83
88−notFound :: Response
89−notFound = responseLBS
84+ notFound = responseLBS
90− status404
85+ status404
91− [("Content-Type", "text/plain")]
86+ [("Content-Type", "text/plain")]
92− "404 - Not Found"
87+ "404 - Not Found"
93−~~~
94
88
95
89
96Doing without overloaded strings
90Doing without overloaded strings
@@ -98,16 +92,14 @@ Doing without overloaded strings
98
92
99For the sake of efficiency, WAI uses the [bytestring] package. We used GHCs [overloaded strings] to almost hide this fact. But we can easily do without. What follows is a more verbose definition of `notFound`, that works without GHC extensions:
93For the sake of efficiency, WAI uses the [bytestring] package. We used GHCs [overloaded strings] to almost hide this fact. But we can easily do without. What follows is a more verbose definition of `notFound`, that works without GHC extensions:
100
94
101−~~~ {.haskell .ignore}
102−import qualified Data.ByteString.Char8 as B8
95+ import qualified Data.ByteString.Char8 as B8
103−import qualified Data.ByteString.Lazy.Char8 as LB8
96+ import qualified Data.ByteString.Lazy.Char8 as LB8
104−import Data.CaseInsensitive (mk)
97+ import Data.CaseInsensitive (mk)
105
98
106−notFound = responseLBS
99+ notFound = responseLBS
107− status404
100+ status404
108− [(mk $ B8.pack "Content-Type", B8.pack "text/plain")]
101+ [(mk $ B8.pack "Content-Type", B8.pack "text/plain")]
109− (LB8.pack "404 - Not Found")
102+ (LB8.pack "404 - Not Found")
110−~~~
111
103
112
104
113 [wai]: http://hackage.haskell.org/package/wai
105 [wai]: http://hackage.haskell.org/package/wai
wai/lhs2md.shnew file+21
@@ -0,0 +1,21 @@
1+#!/bin/sh
2+#
3+# Convert a literate Haskell program (README.lhs) to GitHub Flavored
4+# Markdown (README.md).
5+#
6+# For more on GitHub Flavored Markdown see:
7+#
8+# http://github.github.com/github-flavored-markdown/
9+#
10+
11+# add a disclaimer
12+echo '<!-- Generated from README.lhs, do not modify! -->' > README.md
13+
14+cat README.lhs | \
15+
16+ # GFM does not ignore line breaks in paragraphs, so we remove them
17+ perl -0777 -pe 's/([]a-zA-Z,.`])\n([[a-zA-Z`])/\1 \2/g' | \
18+
19+ # convert Bird-style literate Haskell to Markdown code blocks
20+ perl -pe 's/^> / /' | \
21+ perl -pe 's/^>$//' >> README.md
wai/test.hsnew file+9
@@ -0,0 +1,9 @@
1+import Network.Wai
2+import Data.Enumerator.List (consume)
3+import Blaze.ByteString.Builder (toByteString)
4+import Data.Monoid (mconcat)
5+import Data.ByteString.Char8 (pack)
6+
7+main = do
8+ b <- responseEnumerator (ResponseFile undefined undefined "test.hs" (Just $ FilePart 7 7)) (const $ const consume)
9+ print $ toByteString (mconcat b) == pack "Network"
wai/test/Network/WaiSpec.hsdeleted−82
@@ -1,82 +0,0 @@
1−module Network.WaiSpec (spec) where
2−
3−import Test.Hspec
4−import Test.Hspec.QuickCheck (prop)
5−import Network.Wai
6−import Data.IORef
7−import qualified Data.ByteString as S
8−import qualified Data.ByteString.Lazy as L
9−import Data.ByteString.Builder (Builder, toLazyByteString, word8)
10−import Control.Monad (forM_)
11−
12−spec :: Spec
13−spec = do
14− describe "responseToStream" $ do
15− let getBody res = do
16− let (_, _, f) = responseToStream res
17− f $ \streamingBody -> do
18− builderRef <- newIORef mempty
19− let add :: Builder -> IO ()
20− add b = atomicModifyIORef builderRef $ \builder ->
21− (builder `mappend` b, ())
22− flush :: IO ()
23− flush = return ()
24− streamingBody add flush
25− fmap (L.toStrict . toLazyByteString) $ readIORef builderRef
26− prop "responseLBS" $ \bytes -> do
27− body <- getBody $ responseLBS undefined undefined $ L.pack bytes
28− body `shouldBe` S.pack bytes
29− prop "responseBuilder" $ \bytes -> do
30− body <- getBody $ responseBuilder undefined undefined
31− $ mconcat $ map word8 bytes
32− body `shouldBe` S.pack bytes
33− prop "responseStream" $ \chunks -> do
34− body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->
35− forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk
36− body `shouldBe` S.concat (map S.pack chunks)
37− it "responseFile total" $ do
38− let fp = "wai.cabal"
39− body <- getBody $ responseFile undefined undefined fp Nothing
40− expected <- S.readFile fp
41− body `shouldBe` expected
42− prop "responseFile partial" $ \offset' count' -> do
43− let fp = "wai.cabal"
44− totalBS <- S.readFile fp
45− let total = S.length totalBS
46− offset = abs offset' `mod` total
47− count = abs count' `mod` (total - offset)
48− body <- getBody $ responseFile undefined undefined fp $ Just FilePart
49− { filePartOffset = fromIntegral offset
50− , filePartByteCount = fromIntegral count
51− , filePartFileSize = fromIntegral total
52− }
53− let expected = S.take count $ S.drop offset totalBS
54− body `shouldBe` expected
55− describe "lazyRequestBody" $ do
56− prop "works" $ \chunks -> do
57− ref <- newIORef $ map S.pack $ filter (not . null) chunks
58− let req = defaultRequest
59− { requestBody = atomicModifyIORef ref $ \bss ->
60− case bss of
61− [] -> ([], S.empty)
62− x:y -> (y, x)
63− }
64− body <- lazyRequestBody req
65− body `shouldBe` L.fromChunks (map S.pack chunks)
66− it "is lazy" $ do
67− let req = defaultRequest
68− { requestBody = error "requestBody"
69− }
70− _ <- lazyRequestBody req
71− return ()
72− describe "strictRequestBody" $ do
73− prop "works" $ \chunks -> do
74− ref <- newIORef $ map S.pack $ filter (not . null) chunks
75− let req = defaultRequest
76− { requestBody = atomicModifyIORef ref $ \bss ->
77− case bss of
78− [] -> ([], S.empty)
79− x:y -> (y, x)
80− }
81− body <- strictRequestBody req
82− body `shouldBe` L.fromChunks (map S.pack chunks)
wai/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
wai/wai.cabal+11−29
@@ -1,9 +1,7 @@
1Name: wai
1Name: wai
2−Version: 3.2.2.1
2+Version: 1.2.0
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>.
7License: MIT
5License: MIT
8License-file: LICENSE
6License-file: LICENSE
9Author: Michael Snoyman
7Author: Michael Snoyman
@@ -11,38 +9,22 @@ Maintainer: michael@snoyman.com
11Homepage: https://github.com/yesodweb/wai
9Homepage: https://github.com/yesodweb/wai
12Category: Web
10Category: Web
13Build-Type: Simple
11Build-Type: Simple
14−Cabal-Version: >=1.8
12+Cabal-Version: >=1.6
15Stability: Stable
13Stability: Stable
16−extra-source-files: README.md ChangeLog.md
17
14
18Source-repository head
15Source-repository head
19 type: git
16 type: git
20 location: git://github.com/yesodweb/wai.git
17 location: git://github.com/yesodweb/wai.git
21
18
22Library
19Library
23− Build-Depends: base >= 4.8 && < 5
20+ Build-Depends: base >= 4 && < 5
24− , bytestring >= 0.10.4
21+ , bytestring >= 0.9.1.4 && < 0.10
22+ , blaze-builder >= 0.2.1.4 && < 0.4
23+ , conduit >= 0.4 && < 0.5
25− , network >= 2.2.1.5
24+ , network >= 2.2.1.5 && < 2.4
26− , http-types >= 0.7
25+ , http-types >= 0.6 && < 0.7
27− , text >= 0.7
26+ , text >= 0.7 && < 0.12
27+ , transformers >= 0.2.2 && < 0.4
28− , vault >= 0.3 && < 0.4
28+ , vault >= 0.1 && < 0.2
29 Exposed-modules: Network.Wai
29 Exposed-modules: Network.Wai
30− Network.Wai.Internal
31 ghc-options: -Wall
30 ghc-options: -Wall
32−
33−test-suite test
34− hs-source-dirs: test
35− main-is: Spec.hs
36− type: exitcode-stdio-1.0
37− ghc-options: -threaded -Wall
38− cpp-options: -DTEST
39− build-depends: base >= 4.8 && < 5
40− , wai
41− , hspec
42− , bytestring
43− other-modules: Network.WaiSpec
44− build-tool-depends: hspec-discover:hspec-discover
45−
46−source-repository head
47− type: git
48− location: git://github.com/yesodweb/wai.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-static/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c)2011, Michael Snoyman
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Michael Snoyman nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
warp-static/READMEnew file

No changes to the content.

warp-static/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
warp-static/warp-static.cabalnew file+29
@@ -0,0 +1,29 @@
1+Name: warp-static
2+Version: 1.2.0
3+Synopsis: Static file server based on Warp and wai-app-static
4+Homepage: http://github.com/yesodweb/wai
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+Description: Serve up static files by running the warp executable. Based on Warp and wai-app-static.
13+
14+
15+Executable warp
16+ Main-is: warp.hs
17+ Build-depends: base >= 4 && < 5
18+ , warp >= 1.2 && < 1.3
19+ , wai-app-static >= 1.2 && < 1.3
20+ , wai-extra >= 1.2 && < 1.3
21+ , cmdargs >= 0.6.7
22+ , directory >= 1.0
23+ , containers >= 0.2 && < 0.5
24+ , bytestring >= 0.9.1.4 && < 0.10
25+ , text >= 0.7 && < 0.12
26+
27+source-repository head
28+ type: git
29+ location: git://github.com/yesodweb/wai.git
warp-static/warp.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2+import Network.Wai.Application.Static
3+ ( StaticSettings (..), staticApp, defaultMimeType, defaultListing
4+ , defaultMimeTypes, mimeTypeByExt
5+ , defaultFileServerSettings, fileSystemLookup
6+ , fileName, toFilePath
7+ , ssRedirectToIndex
8+ )
9+import Network.Wai.Handler.Warp
10+ ( runSettings, defaultSettings, settingsHost, settingsPort
11+ )
12+import System.Console.CmdArgs hiding (def)
13+import Text.Printf (printf)
14+import System.Directory (canonicalizePath)
15+import Control.Monad (unless)
16+import Network.Wai.Middleware.Autohead
17+import Network.Wai.Middleware.RequestLogger (logStdout)
18+import Network.Wai.Middleware.Gzip
19+import qualified Data.Map as Map
20+import qualified Data.ByteString.Char8 as S8
21+import Control.Arrow ((***))
22+import Data.Text (pack)
23+import Data.String (fromString)
24+
25+data Args = Args
26+ { docroot :: FilePath
27+ , index :: [FilePath]
28+ , port :: Int
29+ , noindex :: Bool
30+ , quiet :: Bool
31+ , verbose :: Bool
32+ , mime :: [(String, String)]
33+ , host :: String
34+ }
35+ deriving (Show, Data, Typeable)
36+
37+defaultArgs :: Args
38+defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False [] "*"
39+
40+main :: IO ()
41+main = do
42+ Args {..} <- cmdArgs defaultArgs
43+ let mime' = map (toFilePath *** S8.pack) mime
44+ let mimeMap = Map.fromList mime' `Map.union` defaultMimeTypes
45+ docroot' <- canonicalizePath docroot
46+ unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
47+ let middle = gzip def
48+ . (if verbose then logStdout else id)
49+ . autohead
50+ runSettings defaultSettings
51+ { settingsPort = port
52+ , settingsHost = fromString host
53+ } $ middle $ staticApp defaultFileServerSettings
54+ { ssFolder = fileSystemLookup $ toFilePath docroot
55+ , ssIndices = if noindex then [] else map pack index
56+ , ssRedirectToIndex = False
57+ , ssListing = Just defaultListing
58+ , ssGetMimeType = return . mimeTypeByExt mimeMap defaultMimeType . fileName
59+ }
warp-tls/ChangeLog.mddeleted−117
@@ -1,117 +0,0 @@
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
88−
89−* Fix for leaked FDs [#378](https://github.com/yesodweb/wai/issues/378)
90−
91−## 3.0.4
92−
93−* Replace `acceptSafe` with `accept`, see [#361](https://github.com/yesodweb/wai/issues/361)
94−
95−## 3.0.3
96−
97−* Support chain certs [#349](https://github.com/yesodweb/wai/pull/349)
98−
99−## 3.0.2
100−
101−* Allow warp-tls to request client certificates. [#337](https://github.com/yesodweb/wai/pull/337)
102−
103−## 3.0.1.4
104−
105−Add additional Diffie-Hellman RSA and DSA ciphers to warp-tls.
106−
107−## 3.0.1.3
108−
109−[Unable to allow insecure connections with warp-tls #324](https://github.com/yesodweb/wai/issues/324)
110−
111−## 3.0.1.2
112−
113−[Make sure Timer is tickled in sendfile. #323](https://github.com/yesodweb/wai/pull/323)
114−
115−## 3.0.1
116−
117−[Support for in-memory certificates and keys](https://github.com/yesodweb/wai/issues/301)
warp-tls/LICENSE+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2010, Suite Solutions. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
warp-tls/Network/Wai/Handler/WarpTLS.hs+84−519
@@ -1,531 +1,96 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE DeriveDataTypeable #-}
6−{-# LANGUAGE PatternGuards #-}
7−
8−-- | HTTP over 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−
15−module Network.Wai.Handler.WarpTLS (
2+module Network.Wai.Handler.WarpTLS
16− -- * Settings
17− TLSSettings
3+ ( TLSSettings (..)
18− , defaultTlsSettings
19− -- * Smart constructors
20− , tlsSettings
21− , tlsSettingsMemory
22− , tlsSettingsChain
23− , tlsSettingsChainMemory
24− -- * Accessors
25− , certFile
26− , keyFile
27− , tlsLogging
28− , tlsAllowedVersions
29− , tlsCiphers
30− , tlsWantClientCert
31− , tlsServerHooks
32− , tlsServerDHEParams
33− , tlsSessionManagerConfig
34− , onInsecure
35− , OnInsecure (..)
36− -- * Runner
37 , runTLS
4 , runTLS
38− , runTLSSocket
39− -- * Exception
40− , WarpTLSException (..)
41− , DH.Params
42− , DH.generateParams
43 ) where
5 ) where
44
6
45−import Control.Applicative ((<|>))
46−import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)
47−import qualified Control.Exception as E
48−import Control.Monad (void, guard)
49−import qualified Data.ByteString as S
50−import qualified Data.ByteString.Lazy as L
51−import Data.Default.Class (def)
52−import qualified Data.IORef as I
53−import Data.Streaming.Network (bindPortTCP, safeRecv)
54−import Data.Typeable (Typeable)
55−import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)
56−#if MIN_VERSION_network(3,1,1)
57−import Network.Socket (gracefulClose)
58−#endif
59−import Network.Socket.ByteString (sendAll)
60import qualified Network.TLS as TLS
7import qualified Network.TLS as TLS
61−import qualified Crypto.PubKey.DH as DH
62−import qualified Network.TLS.Extra as TLSExtra
63−import qualified Network.TLS.SessionManager as SM
64−import Network.Wai (Application)
65import Network.Wai.Handler.Warp
8import Network.Wai.Handler.Warp
66−import Network.Wai.Handler.Warp.Internal
9+import Network.Wai
10+import Network.Socket
67−import System.IO.Error (isEOFError)
11+import System.IO
68−
12+import Crypto.Random
69−----------------------------------------------------------------
13+import qualified Data.ByteString.Lazy as L
70−
14+import Data.Conduit.Binary (sourceFileRange)
71−-- | Settings for WarpTLS.
15+import qualified Data.Conduit as C
72−data TLSSettings = TLSSettings {
16+import qualified Data.Conduit.List as CL
73− certFile :: FilePath
17+import Control.Exception (bracket, handle, SomeException)
74− -- ^ File containing the certificate.
18+import qualified Network.TLS.Extra as TLSExtra
75− , chainCertFiles :: [FilePath]
19+import qualified Data.Certificate.X509 as X509
76− -- ^ Files containing chain certificates.
20+import qualified Data.Certificate.PEM as PEM
77− , keyFile :: FilePath
21+import qualified Data.ByteString as B
78− -- ^ File containing the key
22+import qualified Data.Certificate.KeyRSA as KeyRSA
79− , certMemory :: Maybe S.ByteString
23+import Data.Conduit.Network (bindPort)
80− , chainCertsMemory :: [S.ByteString]
24+
81− , keyMemory :: Maybe S.ByteString
82− , onInsecure :: OnInsecure
83− -- ^ Do we allow insecure connections with this server as well?
84− --
85− -- >>> onInsecure defaultTlsSettings
86− -- DenyInsecure "This server only accepts secure HTTPS connections."
87− --
88− -- Since 1.4.0
89− , tlsLogging :: TLS.Logging
90− -- ^ The level of logging to turn on.
91− --
92− -- Default: 'TLS.defaultLogging'.
93− --
94− -- Since 1.4.0
95− , tlsAllowedVersions :: [TLS.Version]
96−#if MIN_VERSION_tls(1,5,0)
97− -- ^ The TLS versions this server accepts.
98− --
99− -- >>> tlsAllowedVersions defaultTlsSettings
100− -- [TLS13,TLS12,TLS11,TLS10]
101− --
102− -- Since 1.4.2
103−#else
104− -- ^ The TLS versions this server accepts.
105− --
106− -- >>> tlsAllowedVersions defaultTlsSettings
107− -- [TLS12,TLS11,TLS10]
108− --
109− -- Since 1.4.2
110−#endif
111− , tlsCiphers :: [TLS.Cipher]
112−#if MIN_VERSION_tls(1,5,0)
113− -- ^ The TLS ciphers this server accepts.
114− --
115− -- >>> tlsCiphers defaultTlsSettings
116− -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1,AES128GCM-SHA256,AES256GCM-SHA384]
117− --
118− -- Since 1.4.2
119−#else
120− -- ^ The TLS ciphers this server accepts.
121− --
122− -- >>> tlsCiphers defaultTlsSettings
123− -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1]
124− --
125− -- Since 1.4.2
126−#endif
127− , tlsWantClientCert :: Bool
128− -- ^ 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
130− -- or all connections will fail.
131− --
132− -- >>> tlsWantClientCert defaultTlsSettings
133− -- False
134− --
135− -- Since 3.0.2
136− , tlsServerHooks :: TLS.ServerHooks
137− -- ^ The server-side hooks called by the tls package, including actions
138− -- to take when a client certificate is received. See the "Network.TLS"
139− -- module for details.
140− --
141− -- Default: def
142− --
143− -- 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− }
161−
162−-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors).
163−defaultTlsSettings :: TLSSettings
164−defaultTlsSettings = TLSSettings {
165− certFile = "certificate.pem"
166− , chainCertFiles = []
167− , keyFile = "key.pem"
168− , certMemory = Nothing
169− , chainCertsMemory = []
170− , keyMemory = Nothing
171− , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
172− , tlsLogging = def
173−#if MIN_VERSION_tls(1,5,0)
174− , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]
175−#else
176− , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]
177−#endif
178− , tlsCiphers = ciphers
179− , tlsWantClientCert = False
180− , tlsServerHooks = def
181− , tlsServerDHEParams = Nothing
182− , tlsSessionManagerConfig = Nothing
183− }
184−
185−-- taken from stunnel example in tls-extra
186−ciphers :: [TLS.Cipher]
187−ciphers = TLSExtra.ciphersuite_strong
188−
189−----------------------------------------------------------------
190−
191−-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.
192−data OnInsecure = DenyInsecure L.ByteString
193− | AllowInsecure
194− deriving (Show)
195−
196−----------------------------------------------------------------
197−
198−-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.
199−tlsSettings :: FilePath -- ^ Certificate file
200− -> FilePath -- ^ Key file
201− -> TLSSettings
202−tlsSettings cert key = defaultTlsSettings {
203− certFile = cert
204− , keyFile = key
205− }
206−
207−-- | A smart constructor for 'TLSSettings' that allows specifying
208−-- chain certificates based on 'defaultTlsSettings'.
209−--
210−-- Since 3.0.3
211−tlsSettingsChain
212− :: FilePath -- ^ Certificate file
213− -> [FilePath] -- ^ Chain certificate files
214− -> FilePath -- ^ Key file
215− -> TLSSettings
216−tlsSettingsChain cert chainCerts key = defaultTlsSettings {
217− certFile = cert
218− , chainCertFiles = chainCerts
219− , keyFile = key
220− }
221−
222−-- | A smart constructor for 'TLSSettings', but uses in-memory representations
223−-- of the certificate and key based on 'defaultTlsSettings'.
224−--
225−-- Since 3.0.1
226−tlsSettingsMemory
227− :: S.ByteString -- ^ Certificate bytes
228− -> S.ByteString -- ^ Key bytes
229− -> TLSSettings
230−tlsSettingsMemory cert key = defaultTlsSettings
231− { certMemory = Just cert
232− , keyMemory = Just key
233− }
234−
235−-- | A smart constructor for 'TLSSettings', but uses in-memory representations
236−-- of the certificate and key based on 'defaultTlsSettings'.
237−--
238−-- Since 3.0.3
239−tlsSettingsChainMemory
240− :: S.ByteString -- ^ Certificate bytes
241− -> [S.ByteString] -- ^ Chain certificate bytes
242− -> S.ByteString -- ^ Key bytes
243− -> TLSSettings
25+data TLSSettings = TLSSettings
244−tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings
26+ { certFile :: FilePath
245− { certMemory = Just cert
27+ , keyFile :: FilePath
246− , chainCertsMemory = chainCerts
247− , keyMemory = Just key
248 }
28 }
249
29
250−----------------------------------------------------------------
251−
252−-- | Running 'Application' with 'TLSSettings' and 'Settings'.
253runTLS :: TLSSettings -> Settings -> Application -> IO ()
30runTLS :: TLSSettings -> Settings -> Application -> IO ()
254−runTLS tset set app = withSocketsDo $
31+runTLS tset set app = do
32+ cert <- readCertificate $ certFile tset
33+ pk <- readPrivateKey $ keyFile tset
34+ let params = TLS.defaultParams
35+ { TLS.pWantClientCert = False
36+ , TLS.pAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12]
37+ , TLS.pCiphers = ciphers
38+ , TLS.pCertificates = [(cert, Just pk)]
39+ }
255 bracket
40 bracket
256− (bindPortTCP (getPort set) (getHost set))
41+ (bindPort (settingsPort set) (settingsHost set))
257− close
42+ sClose
258− (\sock -> runTLSSocket tset set sock app)
43+ (\sock -> runSettingsConnection set (getter params sock) app)
259−
260−----------------------------------------------------------------
261−
262−-- | Running 'Application' with 'TLSSettings' and 'Settings' using
263−-- specified 'Socket'.
264−runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
265−runTLSSocket tlsset@TLSSettings{..} set sock app = do
266− credential <- case (certMemory, keyMemory) of
267− (Nothing, Nothing) ->
268− either error id <$>
269− TLS.credentialLoadX509Chain certFile chainCertFiles keyFile
270− (mcert, mkey) -> do
271− cert <- maybe (S.readFile certFile) return mcert
272− key <- maybe (S.readFile keyFile) return mkey
273− either error return $
274− 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
279−
280−runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager -> Socket -> Application -> IO ()
281−runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =
282− runSettingsConnectionMakerSecure set get app
283 where
44 where
284− get = getter tlsset set sock params
45+ retry :: TLS.TLSParams -> Socket -> SomeException -> IO (Connection, SockAddr)
285− params = def { -- TLS.ServerParams
46+ retry a b _ = getter a b
286− TLS.serverWantClientCert = tlsWantClientCert
47+
287− , TLS.serverCACertificates = []
48+ getter params sock = do
288− , TLS.serverDHEParams = tlsServerDHEParams
49+ (s, sa) <- accept sock
289− , TLS.serverHooks = hooks
50+ handle (retry params sock) $ do
290− , TLS.serverShared = shared
51+ h <- socketToHandle s ReadWriteMode
291− , TLS.serverSupported = supported
52+ hSetBuffering h NoBuffering
292−#if MIN_VERSION_tls(1,5,0)
53+ gen <- newGenIO
293− , TLS.serverEarlyDataSize = 2018
54+ ctx <- TLS.server params (gen :: SystemRandom) h
294−#endif
55+ TLS.handshake ctx
295− }
56+ let conn = Connection
296− -- Adding alpn to user's tlsServerHooks.
57+ { connSendMany = TLS.sendData ctx . L.fromChunks
297− hooks = tlsServerHooks {
58+ , connSendAll = TLS.sendData ctx . L.fromChunks . return
298− TLS.onALPNClientSuggest = TLS.onALPNClientSuggest tlsServerHooks <|>
59+ , connSendFile = \fp offset len _th -> C.runResourceT $ sourceFileRange fp (Just offset) (Just len) C.$$ CL.mapM_ (TLS.sendData ctx . L.fromChunks . return)
299− (if settingsHTTP2Enabled set then Just alpn else Nothing)
60+ , connClose = do
300− }
61+ TLS.bye ctx
301− shared = def {
62+ hClose h
302− TLS.sharedCredentials = TLS.Credentials [credential]
63+ , connRecv = TLS.recvData ctx
303− , TLS.sharedSessionManager = mgr
64+ }
304− }
65+ return (conn, sa)
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
66
318−alpn :: [S.ByteString] -> IO S.ByteString
67+-- taken from stunnel example in tls-extra
319−alpn xs
68+ciphers :: [TLS.Cipher]
320− | "h2" `elem` xs = return "h2"
69+ciphers =
321− | otherwise = return "http/1.1"
70+ [ TLSExtra.cipher_AES128_SHA1
322−
71+ , TLSExtra.cipher_AES256_SHA1
323−----------------------------------------------------------------
72+ , TLSExtra.cipher_RC4_128_MD5
324−
73+ , TLSExtra.cipher_RC4_128_SHA1
325−getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
74+ ]
326−getter tlsset@TLSSettings{..} set sock params = do
75+
327−#if WINDOWS
76+readCertificate :: FilePath -> IO X509.X509
328− (s, sa) <- windowsThreadBlockHack $ accept sock
77+readCertificate filepath = do
329−#else
78+ content <- B.readFile filepath
330− (s, sa) <- accept sock
79+ certdata <-
331−#endif
80+ case PEM.parsePEMCert content of
332− setSocketCloseOnExec s
81+ Nothing -> error "no valid certificate section"
333− return (mkConn tlsset set s params, sa)
82+ Just x -> return x
334−
83+ case X509.decodeCertificate $ L.fromChunks [certdata] of
335−mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)
84+ Left err -> error ("cannot decode certificate: " ++ err)
336−mkConn tlsset set s params = switch `onException` close s
85+ Right x -> return x
337− where
86+
338− switch = do
87+readPrivateKey :: FilePath -> IO TLS.PrivateKey
339− firstBS <- safeRecv s 4096
88+readPrivateKey filepath = do
340− if not (S.null firstBS) && S.head firstBS == 0x16 then
89+ content <- B.readFile filepath
341− httpOverTls tlsset set s firstBS params
90+ pkdata <-
342− else
91+ case PEM.parsePEMKeyRSA content of
343− plainHTTP tlsset set s firstBS
92+ Nothing -> error "no valid RSA key section"
344−
93+ Just x -> return (L.fromChunks [x])
345−----------------------------------------------------------------
94+ case KeyRSA.decodePrivate pkdata of
346−
95+ Left err -> error ("cannot decode key: " ++ err)
347−httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)
96+ Right (_pub, x) -> return $ TLS.PrivRSA x
348−httpOverTls TLSSettings{..} _set s bs0 params = do
349− recvN <- makePlainReceiveN s bs0
350− ctx <- TLS.contextNew (backend recvN) params
351− TLS.contextHookSetLogging ctx tlsLogging
352− TLS.handshake ctx
353− h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx
354− isH2 <- I.newIORef h2
355− writeBuf <- allocateBuffer bufferSize
356− -- Creating a cache for leftover input data.
357− ref <- I.newIORef ""
358− tls <- getTLSinfo ctx
359− return (conn ctx writeBuf ref isH2, tls)
360− where
361− backend recvN = TLS.Backend {
362− TLS.backendFlush = return ()
363−#if MIN_VERSION_network(3,1,1)
364− , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()
365−#else
366− , TLS.backendClose = close s
367−#endif
368− , TLS.backendSend = sendAll' s
369− , TLS.backendRecv = recvN
370− }
371− sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->
372− throwIO ConnectionClosedByPeer
373− conn ctx writeBuf ref isH2 = Connection {
374− connSendMany = TLS.sendData ctx . L.fromChunks
375− , connSendAll = sendall
376− , connSendFile = sendfile
377− , connClose = close'
378− , connFree = freeBuffer writeBuf
379− , connRecv = recv ref
380− , connRecvBuf = recvBuf ref
381− , connWriteBuffer = writeBuf
382− , connBufferSize = bufferSize
383− , connHTTP2 = isH2
384− }
385− where
386− sendall = TLS.sendData ctx . L.fromChunks . return
387− sendfile fid offset len hook headers =
388− readSendFile writeBuf bufferSize sendall fid offset len hook headers
389−
390− close' = void (tryIO sendBye) `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)
400−
401− -- TLS version of recv with a cache for leftover input data.
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
413− where
414− onEOF e
415− | Just TLS.Error_EOF <- fromException e = return S.empty
416− | Just ioe <- fromException e, isEOFError ioe = return S.empty | otherwise = throwIO e
417− go = do
418− x <- TLS.recvData ctx
419− if S.null x then
420− go
421− else
422− return x
423−
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−
455−getTLSinfo :: TLS.Context -> IO Transport
456−getTLSinfo ctx = do
457− proto <- TLS.getNegotiatedProtocol ctx
458− minfo <- TLS.contextGetInformation ctx
459− case minfo of
460− Nothing -> return TCP
461− Just TLS.Information{..} -> do
462− let (major, minor) = case infoVersion of
463− TLS.SSL2 -> (2,0)
464− TLS.SSL3 -> (3,0)
465− TLS.TLS10 -> (3,1)
466− TLS.TLS11 -> (3,2)
467− TLS.TLS12 -> (3,3)
468−#if MIN_VERSION_tls(1,5,0)
469− TLS.TLS13 -> (3,4)
470−#endif
471− clientCert <- TLS.getClientCertificateChain ctx
472− return TLS {
473− tlsMajorVersion = major
474− , tlsMinorVersion = minor
475− , tlsNegotiatedProtocol = proto
476− , tlsChiperID = TLS.cipherID infoCipher
477− , tlsClientCertificate = clientCert
478− }
479−
480−tryIO :: IO a -> IO (Either IOException a)
481−tryIO = try
482−
483−----------------------------------------------------------------
484−
485−plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)
486−plainHTTP TLSSettings{..} set s bs0 = case onInsecure of
487− AllowInsecure -> do
488− conn' <- socketConnection set s
489− cachedRef <- I.newIORef bs0
490− let conn'' = conn'
491− { connRecv = recvPlain cachedRef (connRecv conn')
492− }
493− return (conn'', TCP)
494− 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"
509− mapM_ (sendAll s) $ L.toChunks lbs
510− close s
511− throwIO InsecureConnectionDenied
512−
513−----------------------------------------------------------------
514−
515−-- | 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
517−-- empties out the @IORef@. Otherwise, calls the supplied receive function.
518−recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString
519−recvPlain ref fallback = do
520− bs <- I.readIORef ref
521− if S.null bs
522− then fallback
523− else do
524− I.writeIORef ref S.empty
525− return bs
526−
527−----------------------------------------------------------------
528−
529−data WarpTLSException = InsecureConnectionDenied
530− deriving (Show, Typeable)
531−instance Exception WarpTLSException
warp-tls/README.mddeleted−9
@@ -1,9 +0,0 @@
1−## warp-tls
2−
3−Serve WAI applications using the Warp webserver and the Haskell TLS library.
4−
5−In order to generate a self-signed certificate for testing, try the following:
6−
7− openssl genrsa -out key.pem 2048
8− openssl req -new -key key.pem -out certificate.csr
9− openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem
warp-tls/graceful-pong.hsdeleted−125
@@ -1,125 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−import Control.Concurrent
3−import Control.Concurrent.Async
4−import Network
5−import Network.Wai
6−import Network.Wai.Handler.Warp (defaultSettings)
7−import Network.Wai.Handler.WarpTLS
8−import Network.HTTP.Types (status200)
9−import Network.Socket (Socket(..), mkSocket, SocketStatus(..))
10−import Blaze.ByteString.Builder (copyByteString)
11−import Data.Monoid
12−import qualified Data.Conduit as C
13−import qualified Data.Conduit.List as CL
14−import System.Environment (getEnv)
15−import System.Posix.Process
16−import System.Posix.Signals
17−
18−envSocketName = "GRACEFUL_PONG_SOCKET"
19−
20−fromSocket2Env sock = [(envSocketName, show (fd, addrFamily, socketType, protocolNumber))]
21− where
22− MkSocket fd addrFamily socketType protocolNumber _socketStatus = sock
23−
24−handleSIGHUP proc spawn =
25− modifyMVar_ proc $ \oldpid -> do
26− pid <- spawn
27− signalProcess lostConnection oldpid
28− status <- waitpid oldpid
29− print (oldpid, status)
30− return pid
31−
32−waitpid pid = do
33− mstatus <- getProcessStatus False True pid
34− case mstatus of
35− Nothing -> waitpid pid
36− Just status -> return status
37−
38−handleSIGTERM proc finish =
39− takeMVar proc >>=
40− signalProcess softwareTermination >>
41− putMVar finish ()
42−
43−child (fd, addrFamily, socketType, protocolNumber) = do
44− sock <- mkSocket fd addrFamily socketType protocolNumber Listening
45− putStrLn "https://localhost:3000/"
46− finish <- newEmptyMVar
47− let sighup = Catch $ putMVar finish ()
48− _handler <- installHandler lostConnection sighup Nothing
49− runTLSSocket (TLSSettings "certificate.pem" "key.pem") defaultSettings sock app `race_` takeMVar finish
50−
51−parent = do
52− sock <- listenOn $ PortNumber $ toEnum 3000
53− let env = Just $ fromSocket2Env sock
54− spawn = forkProcess $ executeFile "./graceful-pong" False [] env
55− proc <- spawn >>= newMVar
56− finish <- newEmptyMVar
57− let sighup = Catch $ handleSIGHUP proc spawn
58− sigterm = Catch $ handleSIGTERM proc finish
59− _handler <- installHandler lostConnection sighup Nothing
60− _handler <- installHandler softwareTermination sigterm Nothing
61− takeMVar finish
62−
63−main = do
64− (getEnv envSocketName >>= child . read) `catch` const parent
65−
66−app req = return $
67− case rawPathInfo req of
68− "/builder/withlen" -> builderWithLen
69− "/builder/nolen" -> builderNoLen
70− "/file/withlen" -> fileWithLen
71− "/file/nolen" -> fileNoLen
72− "/source/withlen" -> sourceWithLen
73− "/source/nolen" -> sourceNoLen
74− x -> index x
75−
76−builderWithLen = ResponseBuilder
77− status200
78− [ ("Content-Type", "text/plain")
79− , ("Content-Length", "4")
80− ]
81− $ copyByteString "PONG"
82−
83−builderNoLen = ResponseBuilder
84− status200
85− [ ("Content-Type", "text/plain")
86− ]
87− $ copyByteString "PONG"
88−
89−sourceWithLen = ResponseSource
90− status200
91− [ ("Content-Type", "text/plain")
92− , ("Content-Length", "4")
93− ]
94− $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
95−
96−sourceNoLen = ResponseSource
97− status200
98− [ ("Content-Type", "text/plain")
99− ]
100− $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
101−
102−fileWithLen = ResponseFile
103− status200
104− [ ("Content-Type", "text/plain")
105− , ("Content-Length", "4")
106− ]
107− "pong.txt"
108− Nothing
109−
110−fileNoLen = ResponseFile
111− status200
112− [ ("Content-Type", "text/plain")
113− ]
114− "pong.txt"
115− Nothing
116−
117−index p = ResponseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString
118− [ "<p><a href='/builder/withlen'>builder withlen</a></p>\n"
119− , "<p><a href='/builder/nolen'>builder nolen</a></p>\n"
120− , "<p><a href='/file/withlen'>file withlen</a></p>\n"
121− , "<p><a href='/file/nolen'>file nolen</a></p>\n"
122− , "<p><a href='/source/withlen'>source withlen</a></p>\n"
123− , "<p><a href='/source/nolen'>source nolen</a></p>\n"
124− , p
125− ]
warp-tls/pong.hs+13−19
@@ -1,23 +1,18 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2import Network.Wai
2import Network.Wai
3−import Network.Wai.Handler.Warp (defaultSettings, setPort)
3+import Network.Wai.Handler.Warp (defaultSettings)
4import Network.Wai.Handler.WarpTLS
4import Network.Wai.Handler.WarpTLS
5import Network.HTTP.Types (status200)
5import Network.HTTP.Types (status200)
6import Blaze.ByteString.Builder (copyByteString)
6import Blaze.ByteString.Builder (copyByteString)
7import Data.Monoid
7import Data.Monoid
8import qualified Data.Conduit as C
8import qualified Data.Conduit as C
9import qualified Data.Conduit.List as CL
9import qualified Data.Conduit.List as CL
10−import Network.HTTP.ReverseProxy
11−import Network.HTTP.Conduit
12
10
13main = do
11main = do
14− putStrLn "https://localhost:3009/"
12+ putStrLn "https://localhost:3000/"
15− --manager <- newManager def
16− runTLS (tlsSettings "certificate.pem" "key.pem")
13+ runTLS (TLSSettings "certificate.pem" "key.pem") defaultSettings app
17− { onInsecure = AllowInsecure
18− } (setPort 3009 defaultSettings) app
19
14
20−app req f = f $
15+app req = return $
21 case rawPathInfo req of
16 case rawPathInfo req of
22 "/builder/withlen" -> builderWithLen
17 "/builder/withlen" -> builderWithLen
23 "/builder/nolen" -> builderNoLen
18 "/builder/nolen" -> builderNoLen
@@ -25,36 +20,35 @@ app req f = f $
25 "/file/nolen" -> fileNoLen
20 "/file/nolen" -> fileNoLen
26 "/source/withlen" -> sourceWithLen
21 "/source/withlen" -> sourceWithLen
27 "/source/nolen" -> sourceNoLen
22 "/source/nolen" -> sourceNoLen
28− "/secure" -> responseLBS status200 [] $ if isSecure req then "secure" else "insecure"
29 x -> index x
23 x -> index x
30
24
31−builderWithLen = responseBuilder
25+builderWithLen = ResponseBuilder
32 status200
26 status200
33 [ ("Content-Type", "text/plain")
27 [ ("Content-Type", "text/plain")
34 , ("Content-Length", "4")
28 , ("Content-Length", "4")
35 ]
29 ]
36 $ copyByteString "PONG"
30 $ copyByteString "PONG"
37
31
38−builderNoLen = responseBuilder
32+builderNoLen = ResponseBuilder
39 status200
33 status200
40 [ ("Content-Type", "text/plain")
34 [ ("Content-Type", "text/plain")
41 ]
35 ]
42 $ copyByteString "PONG"
36 $ copyByteString "PONG"
43
37
44−sourceWithLen = responseStream
38+sourceWithLen = ResponseSource
45 status200
39 status200
46 [ ("Content-Type", "text/plain")
40 [ ("Content-Type", "text/plain")
47 , ("Content-Length", "4")
41 , ("Content-Length", "4")
48 ]
42 ]
49− $ \sendChunk _flush -> sendChunk $ copyByteString "PONG"
43+ $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
50
44
51−sourceNoLen = responseStream
45+sourceNoLen = ResponseSource
52 status200
46 status200
53 [ ("Content-Type", "text/plain")
47 [ ("Content-Type", "text/plain")
54 ]
48 ]
55− $ \sendChunk _flush -> sendChunk $ copyByteString "PONG"
49+ $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
56
50
57−fileWithLen = responseFile
51+fileWithLen = ResponseFile
58 status200
52 status200
59 [ ("Content-Type", "text/plain")
53 [ ("Content-Type", "text/plain")
60 , ("Content-Length", "4")
54 , ("Content-Length", "4")
@@ -62,14 +56,14 @@ fileWithLen = responseFile
62 "pong.txt"
56 "pong.txt"
63 Nothing
57 Nothing
64
58
65−fileNoLen = responseFile
59+fileNoLen = ResponseFile
66 status200
60 status200
67 [ ("Content-Type", "text/plain")
61 [ ("Content-Type", "text/plain")
68 ]
62 ]
69 "pong.txt"
63 "pong.txt"
70 Nothing
64 Nothing
71
65
72−index p = responseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString
66+index p = ResponseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString
73 [ "<p><a href='/builder/withlen'>builder withlen</a></p>\n"
67 [ "<p><a href='/builder/withlen'>builder withlen</a></p>\n"
74 , "<p><a href='/builder/nolen'>builder nolen</a></p>\n"
68 , "<p><a href='/builder/nolen'>builder nolen</a></p>\n"
75 , "<p><a href='/file/withlen'>file withlen</a></p>\n"
69 , "<p><a href='/file/withlen'>file withlen</a></p>\n"
warp-tls/pong.txt+1−1
@@ -1 +1 @@
1−PONG
1+PONG
warp-tls/warp-tls.cabal+17−25
@@ -1,6 +1,6 @@
1Name: warp-tls
1Name: warp-tls
2−Version: 3.2.11
2+Version: 1.2.0
3−Synopsis: HTTP over TLS support for Warp via the TLS package
3+Synopsis: SSL 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,26 @@ 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.
13+Description: SSL support for Warp via the TLS package
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
17− <http://www.stackage.org/package/warp-tls>.
18−extra-source-files: ChangeLog.md README.md
19
14
20Library
15Library
21− Build-Depends: base >= 4.10 && < 5
16+ Build-Depends: base >= 4 && < 5
22− , bytestring >= 0.9
17+ , bytestring >= 0.9 && < 0.10
23− , wai >= 3.2 && < 3.3
18+ , wai >= 1.2 && < 1.3
24− , warp >= 3.3.6 && < 3.4
19+ , warp >= 1.2 && < 1.3
25− , data-default-class >= 0.0.1
20+ , transformers >= 0.2 && < 0.4
26− , tls >= 1.5.3
21+ , conduit >= 0.4 && < 0.5
27− , cryptonite >= 0.12
22+ , network-conduit >= 0.4 && < 0.5
28− , network >= 2.2.1
23+ , certificate >= 1.1 && < 1.2
29− , streaming-commons
24+ , cryptocipher >= 0.3 && < 0.4
30− , tls-session-manager >= 0.0.4
25+ , tls-extra >= 0.4.3 && < 0.5
26+ , tls >= 0.9 && < 0.10
27+ , crypto-api >= 0.8 && < 0.10
28+ , network >= 2.2.1 && < 2.4
31 Exposed-modules: Network.Wai.Handler.WarpTLS
29 Exposed-modules: Network.Wai.Handler.WarpTLS
32 ghc-options: -Wall
30 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
31
40source-repository head
32source-repository head
41 type: git
33 type: git
warp/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -itest -idist/build/autogen -i.stack-work/dist/x86_64-linux/Cabal-1.22.5.0/build/autogen
warp/ChangeLog.mddeleted−404
@@ -1,404 +0,0 @@
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
300−
301−* Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375)
302−
303−## 3.0.13
304−
305−* Turn off file descriptor cache by default [#371](https://github.com/yesodweb/wai/issues/371)
306−
307−## 3.0.12.1
308−
309−* Fix for: HEAD requests returning non-empty entity body [#369](https://github.com/yesodweb/wai/issues/369)
310−
311−## 3.0.12
312−
313−* Only conditionally produce HTTP 100 Continue
314−
315−## 3.0.11
316−
317−* Better HEAD support for files [#357](https://github.com/yesodweb/wai/pull/357)
318−
319−## 3.0.10
320−
321−* Fix [missing `IORef` tweak](https://github.com/yesodweb/wai/issues/351)
322−* Disable timeouts as soon as request body is fully consumed. This addresses
323− the common case of a non-chunked request body. Previously, we would wait
324− until a zero-length `ByteString` is returned, but that is suboptimal for some
325− cases. For more information, see [issue
326− 351](https://github.com/yesodweb/wai/issues/351).
327−* Add `pauseTimeout` function
328−
329−## 3.0.9.3
330−
331−* Don't serve a 416 status code for 0-length files [keter issue #75](https://github.com/snoyberg/keter/issues/75)
332−* Don't serve content-length for 416 responses [#346](https://github.com/yesodweb/wai/issues/346)
333−
334−## 3.0.9.2
335−
336−Fix support for old versions of bytestring
337−
338−## 3.0.9.1
339−
340−Add support for blaze-builder 0.4
341−
342−## 3.0.9
343−
344−* Add runEnv: like run but uses $PORT [#334](https://github.com/yesodweb/wai/pull/334)
345−
346−## 3.0.5.2
347−
348−* [Pass the Request to settingsOnException handlers when available. #326](https://github.com/yesodweb/wai/pull/326)
349−
350−## 3.0.5
351−
352−Support for PROXY protocol, such as used by Amazon ELB TCP. This is useful
353−since, for example, Amazon ELB HTTP does *not* have support for Websockets.
354−More information on the protocol [is available from
355−Amazon](http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol).
356−
357−## 3.0.4
358−
359−Added `setFork`.
360−
361−## 3.0.3
362−
363−Modify flushing of request bodies. Previously, regardless of the size of the
364−request body, the entire body would be flushed. When uploading large files to a
365−web app that does not accept such files (e.g., returns a 413 too large status),
366−browsers would still send the entire request body and the servers will still
367−receive it.
368−
369−The new behavior is to detect if there is a large amount of data still to be
370−consumed and, if so, immediately terminate the connection. In the case of
371−chunked request bodies, up to a maximum number of bytes is consumed before the
372−connection is terminated.
373−
374−This is controlled by the new setting `setMaximumBodyFlush`. A value of
375−@Nothing@ will return the original behavior of flushing the entire body.
376−
377−## 3.0.0
378−
379−WAI no longer uses conduit for its streaming interface.
380−
381−## 2.1.0
382−
383−The `onOpen` and `onClose` settings now provide the `SockAddr` of the client,
384−and `onOpen` can return a `Bool` which will close the connection. The
385−`responseRaw` response has been added, which provides a more elegant way to
386−handle WebSockets than the previous `settingsIntercept`. The old settings
387−accessors have been deprecated in favor of new setters, which will allow
388−settings changes to be made in the future without breaking backwards
389−compatibility.
390−
391−## 2.0.0
392−
393−ResourceT is not used anymore. Request and Response is now abstract data types.
394−To use their constructors, Internal module should be imported.
395−
396−## 1.3.9
397−
398−Support for byte range requests.
399−
400−## 1.3.7
401−
402−Sockets now have `FD_CLOEXEC` set on them. This behavior is more secure, and
403−the change should not affect the vast majority of use cases. However, it
404−appeared that this is buggy and is fixed in 2.0.0.
warp/LICENSE+22−17
@@ -1,20 +1,25 @@
1−Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
2
3
3−Permission is hereby granted, free of charge, to any person obtaining
4+Copyright 2010, Suite Solutions. All rights reserved.
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
5
11−The above copyright notice and this permission notice shall be
6+Redistribution and use in source and binary forms, with or without
12−included in all copies or substantial portions of the Software.
7+modification, are permitted provided that the following conditions are met:
13
8
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
14−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
15−EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
16−MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
17−NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
18−LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
19−OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
20−WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
warp/Network/Wai/Handler/Warp.hsmode 100644 → 100755+706−492
@@ -1,8 +1,10 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE CPP #-}
4{-# LANGUAGE CPP #-}
2−{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE PatternGuards #-}
6+{-# LANGUAGE MagicHash #-}
4−{-# OPTIONS_GHC -fno-warn-deprecations #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
5−
6---------------------------------------------------------
8---------------------------------------------------------
7--
9--
8-- Module : Network.Wai.Handler.Warp
10-- Module : Network.Wai.Handler.Warp
@@ -18,492 +20,704 @@
18---------------------------------------------------------
20---------------------------------------------------------
19
21
20-- | A fast, light-weight HTTP server handler for WAI.
22-- | A fast, light-weight HTTP server handler for WAI.
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
26−-- at various points in request receiving and response sending. One interesting
27−-- corner case is partial request body consumption; in that case, Warp's
28−-- timeout handling is still in effect, and the timeout will not be triggered
29−-- again. Therefore, it is recommended that once you start consuming the
30−-- request body, you either:
31−--
32−-- * consume the entire body promptly
33−--
34−-- * call the 'pauseTimeout' function
35−--
36−-- For more information, see <https://github.com/yesodweb/wai/issues/351>.
37−--
38−--
39−module Network.Wai.Handler.Warp (
23+module Network.Wai.Handler.Warp
40− -- * Run a Warp server
24+ ( -- * 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
25+ run
44− , runEnv
45− , runSettings
26+ , runSettings
46− , runSettingsSocket
27+ , runSettingsSocket
47− -- * Settings
28+ -- * Settings
48− , Settings
29+ , Settings
49− , defaultSettings
30+ , defaultSettings
50− -- ** Setters
31+ , settingsPort
51− , setPort
32+ , settingsHost
52− , setHost
33+ , settingsOnException
53− , setOnException
34+ , settingsTimeout
54− , setOnExceptionResponse
35+ , settingsIntercept
55− , setOnOpen
36+ , settingsManager
56− , setOnClose
57− , setTimeout
58− , setManager
59− , setFdCacheDuration
60− , setFileInfoCacheDuration
61− , setBeforeMainLoop
62− , setNoParsePath
63− , setInstallShutdownHandler
64− , setServerName
65− , setMaximumBodyFlush
66− , setFork
67− , setProxyProtocolNone
68− , setProxyProtocolRequired
69− , setProxyProtocolOptional
70− , setSlowlorisSize
71− , setHTTP2Disabled
72− , setLogger
73− , setServerPushLogger
74− , setGracefulShutdownTimeout
75− , setGracefulCloseTimeout1
76− , setGracefulCloseTimeout2
77− , setMaxTotalHeaderLength
78− -- ** Getters
79− , getPort
80− , getHost
81− , getOnOpen
82− , getOnClose
83− , getOnException
84− , getGracefulShutdownTimeout
85− , getGracefulCloseTimeout1
86− , getGracefulCloseTimeout2
87− -- ** Exception handler
88− , defaultOnException
89− , defaultShouldDisplayException
90− -- ** Exception response handler
91− , defaultOnExceptionResponse
92− , exceptionResponseForDebug
93− -- * Data types
37+ -- ** Data types
94− , HostPreference
38+ , HostPreference (..)
39+ -- * Connection
40+ , Connection (..)
41+ , runSettingsConnection
42+ -- * Datatypes
95− , Port
43+ , Port
96− , InvalidRequest (..)
44+ , InvalidRequest (..)
97− -- * Utilities
45+ -- * Internal
98− , pauseTimeout
46+ , Manager
99− , FileInfo(..)
47+ , withManager
100− , getFileInfo
48+ , parseRequest
101− , clientCertificate
49+ , sendResponse
102− , withApplication
50+ , registerKillThread
103− , withApplicationSettings
51+ , pause
104− , testWithApplication
52+ , resume
105− , testWithApplicationSettings
53+ , T.cancel
106− , openFreePort
54+ , T.register
107− -- * Version
55+ , T.initialize
108− , warpVersion
56+#if TEST
109− -- * HTTP/2
57+ , takeHeaders
110− -- ** HTTP2 data
58+ , readInt
111− , HTTP2Data
59+#endif
112− , http2dataPushPromise
113− , http2dataTrailers
114− , defaultHTTP2Data
115− , getHTTP2Data
116− , setHTTP2Data
117− , modifyHTTP2Data
118− -- ** Push promise
119− , PushPromise
120− , promisedPath
121− , promisedFile
122− , promisedResponseHeaders
123− , promisedWeight
124− , defaultPushPromise
125− ) where
60+ ) where
126−
61+
62+import Prelude hiding (catch, lines)
63+import Network.Wai
64+
65+import Data.ByteString (ByteString)
66+import qualified Data.ByteString as S
67+import qualified Data.ByteString.Unsafe as SU
68+import qualified Data.ByteString.Char8 as B
69+import qualified Data.ByteString.Lazy as L
70+import Network (sClose, Socket)
71+import Network.Socket (accept, SockAddr)
72+import qualified Network.Socket.ByteString as Sock
127−import Control.Exception (SomeException, throwIO)
73+import Control.Exception
128−import Data.Streaming.Network (HostPreference)
74+ ( bracket, finally, Exception, SomeException, catch
129−import qualified Data.Vault.Lazy as Vault
75+ , fromException, AsyncException (ThreadKilled)
130−import Data.X509
76+ , try
77+ )
78+import Control.Concurrent (forkIO)
79+import Data.Maybe (fromMaybe, isJust)
80+
81+import Data.Typeable (Typeable)
82+
83+import Data.Conduit (ResourceT, runResourceT)
84+import qualified Data.Conduit as C
85+import qualified Data.Conduit.List as CL
86+import Data.Conduit.Blaze (builderToByteString)
87+import Control.Exception.Lifted (throwIO)
88+import Blaze.ByteString.Builder.HTTP
89+ (chunkedTransferEncoding, chunkedTransferTerminator)
90+import Blaze.ByteString.Builder
91+ (copyByteString, Builder, toLazyByteString, toByteStringIO, flush)
92+import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
93+import Data.Monoid (mappend, mempty)
94+import Network.Sendfile
95+
96+import qualified System.PosixCompat.Files as P
97+
98+import Control.Monad.IO.Class (MonadIO, liftIO)
99+import qualified Timeout as T
100+import Timeout (Manager, registerKillThread, pause, resume)
101+import Data.Word (Word8)
102+import Data.List (foldl')
103+import Control.Monad (forever, when)
131import qualified Network.HTTP.Types as H
104import qualified Network.HTTP.Types as H
132−import Network.Socket (SockAddr)
105+import qualified Data.CaseInsensitive as CI
133−import Network.Wai (Request, Response, vault)
106+import System.IO (hPrint, stderr)
134−import System.TimeManager
107+import ReadInt (readInt64)
135−
108+import qualified Data.IORef as I
136−import Network.Wai.Handler.Warp.FileInfoCache
109+import Data.Conduit.Network (bindPort, HostPreference (HostIPv4))
137−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)
110+
138−import Network.Wai.Handler.Warp.HTTP2.Types
111+#if WINDOWS
139−import Network.Wai.Handler.Warp.Imports
112+import Control.Concurrent (threadDelay)
140−import Network.Wai.Handler.Warp.Request
113+import qualified Control.Concurrent.MVar as MV
141−import Network.Wai.Handler.Warp.Response (warpVersion)
114+import Network.Socket (withSocketsDo)
142−import Network.Wai.Handler.Warp.Run
115+#endif
143−import Network.Wai.Handler.Warp.Settings
116+
144−import Network.Wai.Handler.Warp.Types hiding (getFileInfo)
117+import Data.Version (showVersion)
145−import Network.Wai.Handler.Warp.WithApplication
118+import qualified Paths_warp
146−
119+
147−-- | Port to listen on. Default value: 3000
120+warpVersion :: String
148−--
121+warpVersion = showVersion Paths_warp.version
149−-- Since 2.1.0
122+
150−setPort :: Port -> Settings -> Settings
123+-- |
151−setPort x y = y { settingsPort = x }
124+--
152−
125+-- In order to provide slowloris protection, Warp provides timeout handlers. We
153−-- | Interface to bind to. Default value: HostIPv4
126+-- follow these rules:
154−--
127+--
155−-- Since 2.1.0
128+-- * A timeout is created when a connection is opened.
156−setHost :: HostPreference -> Settings -> Settings
129+--
157−setHost x y = y { settingsHost = x }
130+-- * When all request headers are read, the timeout is tickled.
158−
131+--
159−-- | What to do with exceptions thrown by either the application or server.
132+-- * Every time at least 2048 bytes of the request body are read, the timeout
160−-- Default: 'defaultOnException'
133+-- is tickled.
161−--
134+--
162−-- Since 2.1.0
135+-- * The timeout is paused while executing user code. This will apply to both
163−setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
136+-- the application itself, and a ResponseSource response. The timeout is
164−setOnException x y = y { settingsOnException = x }
137+-- resumed as soon as we return from user code.
165−
138+--
166−-- | A function to create a `Response` when an exception occurs.
139+-- * Every time data is successfully sent to the client, the timeout is tickled.
167−-- Default: 'defaultOnExceptionResponse'
140+data Connection = Connection
168−--
141+ { connSendMany :: [B.ByteString] -> IO ()
169−-- Note that an application can handle its own exceptions without interfering with Warp:
142+ , connSendAll :: B.ByteString -> IO ()
170−--
143+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> IO () -- ^ offset, length
171−-- > myApp :: Application
144+ , connClose :: IO ()
172−-- > myApp request respond = innerApp `catch` onError
145+ , connRecv :: IO B.ByteString
173−-- > where
146+ }
174−-- > onError = respond . response500 request
147+
175−-- >
148+socketConnection :: Socket -> Connection
176−-- > response500 :: Request -> SomeException -> Response
149+socketConnection s = Connection
177−-- > response500 req someEx = responseLBS status500 -- ...
150+ { connSendMany = Sock.sendMany s
178−--
151+ , connSendAll = Sock.sendAll s
179−-- Since 2.1.0
152+ , connSendFile = \fp off len act -> sendfile s fp (PartOfFile off len) act
180−setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings
153+ , connClose = sClose s
181−setOnExceptionResponse x y = y { settingsOnExceptionResponse = x }
154+ , connRecv = Sock.recv s bytesPerRead
182−
155+ }
183−-- | What to do when a connection is opened. When 'False' is returned, the
156+
184−-- connection is closed immediately. Otherwise, the connection is going on.
157+-- | Run an 'Application' on the given port. This calls 'runSettings' with
185−-- Default: always returns 'True'.
158+-- 'defaultSettings'.
186−--
159+run :: Port -> Application -> IO ()
187−-- Since 2.1.0
160+run p = runSettings defaultSettings { settingsPort = p }
188−setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings
161+
189−setOnOpen x y = y { settingsOnOpen = x }
162+-- | Run a Warp server with the given settings.
190−
163+runSettings :: Settings -> Application -> IO ()
191−-- | What to do when a connection is closed. Default: do nothing.
164+#if WINDOWS
192−--
165+runSettings set app = withSocketsDo $ do
193−-- Since 2.1.0
166+ var <- MV.newMVar Nothing
194−setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings
167+ let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing
195−setOnClose x y = y { settingsOnClose = x }
168+ _ <- forkIO $ bracket
196−
169+ (bindPort (settingsPort set) (settingsHost set))
197−-- | Timeout value in seconds. Default value: 30
170+ (const clean)
198−--
171+ (\s -> do
199−-- Since 2.1.0
172+ MV.modifyMVar_ var (\_ -> return $ Just s)
200−setTimeout :: Int -> Settings -> Settings
173+ runSettingsSocket set s app)
201−setTimeout x y = y { settingsTimeout = x }
174+ forever (threadDelay maxBound) `finally` clean
202−
175+#else
203−-- | Use an existing timeout manager instead of spawning a new one. If used,
176+runSettings set =
204−-- 'settingsTimeout' is ignored.
177+ bracket
205−--
178+ (bindPort (settingsPort set) (settingsHost set))
206−-- Since 2.1.0
179+ sClose .
207−setManager :: Manager -> Settings -> Settings
180+ flip (runSettingsSocket set)
208−setManager x y = y { settingsManager = Just x }
181+#endif
209−
182+
210−-- | Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used.
183+type Port = Int
211−--
184+
212−-- The FD cache is an optimization that is useful for servers dealing with
185+-- | Same as 'runSettings', but uses a user-supplied socket instead of opening
213−-- static files. However, if files are being modified, it can cause incorrect
186+-- one. This allows the user to provide, for example, Unix named socket, which
214−-- results in some cases. Therefore, we disable it by default. If you know that
187+-- can be used when reverse HTTP proxying into your application.
215−-- your files will be static or you prefer performance to file consistency,
188+--
216−-- it's recommended to turn this on; a reasonable value for those cases is 10.
189+-- Note that the 'settingsPort' will still be passed to 'Application's via the
217−-- Enabling this cache results in drastic performance improvement for file
190+-- 'serverPort' record.
218−-- transfers.
191+runSettingsSocket :: Settings -> Socket -> Application -> IO ()
219−--
192+runSettingsSocket set socket app =
220−-- Default value: 0, was previously 10
193+ runSettingsConnection set getter app
221−--
194+ where
222−-- Since 3.0.13
195+ getter = do
223−setFdCacheDuration :: Int -> Settings -> Settings
196+ (conn, sa) <- accept socket
224−setFdCacheDuration x y = y { settingsFdCacheDuration = x }
197+ return (socketConnection conn, sa)
225−
198+
226−-- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used.
199+runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
227−--
200+runSettingsConnection set getConn app = do
228−-- The file information cache is an optimization that is useful for servers dealing with
201+ let onE = settingsOnException set
229−-- static files. However, if files are being modified, it can cause incorrect
202+ port = settingsPort set
230−-- results in some cases. Therefore, we disable it by default. If you know that
203+ tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return
231−-- your files will be static or you prefer performance to file consistency,
204+ $ settingsManager set
232−-- it's recommended to turn this on; a reasonable value for those cases is 10.
205+ forever $ do
233−-- Enabling this cache results in drastic performance improvement for file
206+ (conn, addr) <- getConn
234−-- transfers.
207+ _ <- forkIO $ do
235−--
208+ th <- T.registerKillThread tm
236−-- Default value: 0
209+ serveConnection set th onE port app conn addr
237−setFileInfoCacheDuration :: Int -> Settings -> Settings
210+ T.cancel th
238−setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }
211+ return ()
239−
212+
240−-- | Code to run after the listening socket is ready but before entering
213+-- | Contains a @Source@ and a byte count that is still to be read in.
241−-- the main event loop. Useful for signaling to tests that they can start
214+newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, C.Source (ResourceT IO) ByteString))
242−-- running, or to drop permissions after binding to a restricted port.
215+
243−--
216+-- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the
244−-- Default: do nothing.
217+-- specified number of bytes to be passed downstream. All leftovers should be
245−--
218+-- retained within the @Source@. If there are not enough bytes available,
246−-- Since 2.1.0
219+-- throws a @ConnectionClosedByPeer@ exception.
247−setBeforeMainLoop :: IO () -> Settings -> Settings
220+ibsIsolate :: IsolatedBSSource -> C.Source (ResourceT IO) ByteString
248−setBeforeMainLoop x y = y { settingsBeforeMainLoop = x }
221+ibsIsolate ibs@(IsolatedBSSource ref) =
249−
222+ C.PipeM pull (return ())
250−-- | Perform no parsing on the rawPathInfo.
223+ where
251−--
224+ pull = do
252−-- This is useful for writing HTTP proxies.
225+ (count, src) <- liftIO $ I.readIORef ref
253−--
226+ if count == 0
254−-- Default: False
227+ -- No more bytes wanted downstream, so we're done.
255−--
228+ then return $ C.Done Nothing ()
256−-- Since 2.1.0
229+ else do
257−setNoParsePath :: Bool -> Settings -> Settings
230+ -- Get the next chunk (if available) and the updated source
258−setNoParsePath x y = y { settingsNoParsePath = x }
231+ (src', mbs) <- src C.$$+ CL.head
259−
232+
260−-- | Get the listening port.
233+ -- If no chunk available, then there aren't enough bytes in the
261−--
234+ -- stream. Throw a ConnectionClosedByPeer
262−-- Since 2.1.1
235+ bs <- maybe (liftIO $ throwIO ConnectionClosedByPeer) return mbs
263−getPort :: Settings -> Port
236+
264−getPort = settingsPort
237+ let -- How many of the bytes in this chunk to send downstream
265−
238+ toSend = min count (S.length bs)
266−-- | Get the interface to bind to.
239+ -- How many bytes will still remain to be sent downstream
267−--
240+ count' = count - toSend
268−-- Since 2.1.1
241+ case () of
269−getHost :: Settings -> HostPreference
242+ ()
270−getHost = settingsHost
243+ -- The expected count is greater than the size of the
271−
244+ -- chunk we just read. Send the entire chunk
272−-- | Get the action on opening connection.
245+ -- downstream, and then loop on this function for the
273−getOnOpen :: Settings -> SockAddr -> IO Bool
246+ -- next chunk.
274−getOnOpen = settingsOnOpen
247+ | count' > 0 -> do
275−
248+ liftIO $ I.writeIORef ref (count', src')
276−-- | Get the action on closeing connection.
249+ return $ C.HaveOutput (ibsIsolate ibs) (return ()) bs
277−getOnClose :: Settings -> SockAddr -> IO ()
250+
278−getOnClose = settingsOnClose
251+ -- The expected count is the total size of the chunk we
279−
252+ -- just read. Send this chunk downstream, and then
280−-- | Get the exception handler.
253+ -- terminate the stream.
281−getOnException :: Settings -> Maybe Request -> SomeException -> IO ()
254+ | count == S.length bs -> do
282−getOnException = settingsOnException
255+ liftIO $ I.writeIORef ref (count', src')
283−
256+ return $ C.HaveOutput (C.Done Nothing ()) (return ()) bs
284−-- | Get the graceful shutdown timeout
257+
285−--
258+ -- Some of the bytes in this chunk should not be sent
286−-- Since 3.2.8
259+ -- downstream. Split up the chunk into the sent and
287−getGracefulShutdownTimeout :: Settings -> Maybe Int
260+ -- not-sent parts, add the not-sent parts onto the new
288−getGracefulShutdownTimeout = settingsGracefulShutdownTimeout
261+ -- source, and send the rest of the chunk downstream.
289−
262+ | otherwise -> do
290−-- | A code to install shutdown handler.
263+ let (x, y) = S.splitAt toSend bs
291−--
264+ liftIO $ I.writeIORef ref (count', C.HaveOutput src' (return ()) y)
292−-- For instance, this code should set up a UNIX signal
265+ return $ C.HaveOutput (C.Done Nothing ()) (return ()) x
293−-- handler. The handler should call the first argument,
266+
294−-- which closes the listen socket, at shutdown.
267+-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not
295−--
268+-- perform any more isolation.
296−-- Example usage:
269+ibsDone :: IsolatedBSSource -> IO (C.Source (ResourceT IO) ByteString)
297−--
270+ibsDone (IsolatedBSSource ref) = fmap snd $ I.readIORef ref
298−-- @
271+
299−-- settings :: IO () -> 'Settings'
272+serveConnection :: Settings
300−-- settings shutdownAction = 'setInstallShutdownHandler' shutdownHandler 'defaultSettings'
273+ -> T.Handle
301−-- __where__
274+ -> (SomeException -> IO ())
302−-- shutdownHandler closeSocket =
275+ -> Port -> Application -> Connection -> SockAddr -> IO ()
303−-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'
276+serveConnection settings th onException port app conn remoteHost' =
304−-- @
277+ catch
305−--
278+ (finally
306−-- Note that by default, the graceful shutdown mode lasts indefinitely
279+ (runResourceT serveConnection')
307−-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,
280+ (connClose conn))
308−-- upon receiving that signal, the custon shutdown action will run /and/ all
281+ onException
309−-- outstanding requests will be handled.
282+ where
310−--
283+ serveConnection' :: ResourceT IO ()
311−-- You may instead prefer to do one or both of the following:
284+ serveConnection' = do
312−--
285+ let fromClient = connSource conn th
313−-- * Only wait a finite amount of time for outstanding requests to complete,
286+ serveConnection'' fromClient
314−-- using 'setGracefulShutdownTimeout'.
287+
315−-- * Only catch one signal, so the second hard-kills the Warp server, using
288+ serveConnection'' fromClient = do
316−-- 'System.Posix.Signals.CatchOnce'.
289+ (env, ibs) <- parseRequest conn port remoteHost' fromClient
317−--
290+ case settingsIntercept settings env of
318−-- Default: does not install any code.
291+ Nothing -> do
319−--
292+ -- Let the application run for as long as it wants
320−-- Since 3.0.1
293+ liftIO $ T.pause th
321−setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings
294+ res <- app env
322−setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }
295+
323−
296+ -- flush the rest of the request body
324−-- | Default server name to be sent as the \"Server:\" header
297+ ibsIsolate ibs C.$$ CL.sinkNull
325−-- if an application does not set one.
298+ fromClient' <- liftIO $ ibsDone ibs
326−-- If an empty string is set, the \"Server:\" header is not sent.
299+
327−-- This is true even if an application set one.
300+ liftIO $ T.resume th
328−--
301+ keepAlive <- sendResponse th env conn res
329−-- Since 3.0.2
302+ when keepAlive $ serveConnection'' fromClient'
330−setServerName :: ByteString -> Settings -> Settings
303+ Just intercept -> do
331−setServerName x y = y { settingsServerName = x }
304+ liftIO $ T.pause th
332−
305+ intercept fromClient conn
333−-- | The maximum number of bytes to flush from an unconsumed request body.
306+
334−--
307+parseRequest :: Connection -> Port -> SockAddr
335−-- By default, Warp does not flush the request body so that, if a large body is
308+ -> C.Source (ResourceT IO) S.ByteString
336−-- present, the connection is simply terminated instead of wasting time and
309+ -> ResourceT IO (Request, IsolatedBSSource)
337−-- bandwidth on transmitting it. However, some clients do not deal with that
310+parseRequest conn port remoteHost' src1 = do
338−-- situation well. You can either change this setting to @Nothing@ to flush the
311+ (src2, headers') <- src1 C.$$+ takeHeaders
339−-- entire body in all cases, or in your application ensure that you always
312+ parseRequest' conn port headers' remoteHost' src2
340−-- consume the entire request body.
313+
341−--
314+-- FIXME come up with good values here
342−-- Default: 8192 bytes.
315+bytesPerRead, maxTotalHeaderLength :: Int
343−--
316+bytesPerRead = 4096
344−-- Since 3.0.3
317+maxTotalHeaderLength = 50 * 1024
345−setMaximumBodyFlush :: Maybe Int -> Settings -> Settings
318+
346−setMaximumBodyFlush x y
319+data InvalidRequest =
347− | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive"
320+ NotEnoughLines [String]
348− | otherwise = y { settingsMaximumBodyFlush = x }
321+ | BadFirstLine String
349−
322+ | NonHttp
350−-- | Code to fork a new thread to accept a connection.
323+ | IncompleteHeaders
351−--
324+ | ConnectionClosedByPeer
352−-- This may be useful if you need OS bound threads, or if
325+ | OverLargeHeader
353−-- you wish to develop an alternative threading model.
326+ deriving (Show, Typeable, Eq)
354−--
327+instance Exception InvalidRequest
355−-- Default: void . forkIOWithUnmask
328+
356−--
329+handleExpect :: Connection
357−-- Since 3.0.4
330+ -> H.HttpVersion
358−setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings
331+ -> ([H.Header] -> [H.Header])
359−setFork fork' s = s { settingsFork = fork' }
332+ -> [H.Header]
360−
333+ -> IO [H.Header]
361−-- | Do not use the PROXY protocol.
334+handleExpect _ _ front [] = return $ front []
362−--
335+handleExpect conn hv front (("expect", "100-continue"):rest) = do
363−-- Since 3.0.5
336+ connSendAll conn $
364−setProxyProtocolNone :: Settings -> Settings
337+ if hv == H.http11
365−setProxyProtocolNone y = y { settingsProxyProtocol = ProxyProtocolNone }
338+ then "HTTP/1.1 100 Continue\r\n\r\n"
366−
339+ else "HTTP/1.0 100 Continue\r\n\r\n"
367−-- | Require PROXY header.
340+ return $ front rest
368−--
341+handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs
369−-- This is for cases where a "dumb" TCP/SSL proxy is being used, which cannot
342+
370−-- add an @X-Forwarded-For@ HTTP header field but has enabled support for the
343+-- | Parse a set of header lines and body into a 'Request'.
371−-- PROXY protocol.
344+parseRequest' :: Connection
372−--
345+ -> Port
373−-- See <http://www.haproxy.org/download/1.5/doc/proxy-protocol.txt> and
346+ -> [ByteString]
374−-- <http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol>.
347+ -> SockAddr
375−--
348+ -> C.Source (ResourceT IO) S.ByteString -- FIXME was buffered
376−-- Only the human-readable header format (version 1) is supported. The binary
349+ -> ResourceT IO (Request, IsolatedBSSource)
377−-- header format (version 2) is /not/ supported.
350+parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []
378−--
351+parseRequest' conn port (firstLine:otherLines) remoteHost' src = do
379−-- Since 3.0.5
352+ (method, rpath', gets, httpversion) <- parseFirst firstLine
380−setProxyProtocolRequired :: Settings -> Settings
353+ let (host',rpath)
381−setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }
354+ | S.null rpath' = ("", "/")
382−
355+ | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'
383−-- | Use the PROXY header if it exists, but also accept
356+ | otherwise = ("", rpath')
384−-- connections without the header. See 'setProxyProtocolRequired'.
357+ heads <- liftIO
385−--
358+ $ handleExpect conn httpversion id
386−-- WARNING: This is contrary to the PROXY protocol specification and
359+ (map parseHeaderNoAttr otherLines)
387−-- using it can indicate a security problem with your
360+ let host = fromMaybe host' $ lookup "host" heads
388−-- architecture if the web server is directly accessible
361+ let len0 =
389−-- to the public, since it would allow easy IP address
362+ case lookup "content-length" heads of
390−-- spoofing. However, it can be useful in some cases,
363+ Nothing -> 0
391−-- such as if a load balancer health check uses regular
364+ Just bs -> readInt bs
392−-- HTTP without the PROXY header, but proxied
365+ let serverName' = takeUntil 58 host -- ':'
393−-- connections /do/ include the PROXY header.
366+ (rbody, ibs) <- liftIO $ do
394−--
367+ ibs <- fmap IsolatedBSSource $ I.newIORef (len0, src)
395−-- Since 3.0.5
368+ return (ibsIsolate ibs, ibs)
396−setProxyProtocolOptional :: Settings -> Settings
369+ return (Request
397−setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional }
370+ { requestMethod = method
398−
371+ , httpVersion = httpversion
399−-- | Size in bytes read to prevent Slowloris attacks. Default value: 2048
372+ , pathInfo = H.decodePathSegments rpath
400−--
373+ , rawPathInfo = rpath
401−-- Since 3.1.2
374+ , rawQueryString = gets
402−setSlowlorisSize :: Int -> Settings -> Settings
375+ , queryString = H.parseQuery gets
403−setSlowlorisSize x y = y { settingsSlowlorisSize = x }
376+ , serverName = serverName'
404−
377+ , serverPort = port
405−-- | Disable HTTP2.
378+ , requestHeaders = heads
406−--
379+ , isSecure = False
407−-- Since 3.1.7
380+ , remoteHost = remoteHost'
408−setHTTP2Disabled :: Settings -> Settings
381+ , requestBody = rbody
409−setHTTP2Disabled y = y { settingsHTTP2Enabled = False }
382+ , vault = mempty
410−
383+ }, ibs)
411−-- | Setting a log function.
384+
412−--
385+
413−-- Since 3.X.X
386+takeUntil :: Word8 -> ByteString -> ByteString
414−setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -- ^ request, status, maybe file-size
387+takeUntil c bs =
415− -> Settings
388+ case S.elemIndex c bs of
416− -> Settings
389+ Just !idx -> SU.unsafeTake idx bs
417−setLogger lgr y = y { settingsLogger = lgr }
390+ Nothing -> bs
418−
391+{-# INLINE takeUntil #-}
419−-- | Setting a log function for HTTP/2 server push.
392+
420−--
393+parseFirst :: ByteString
421−-- Since: 3.2.7
394+ -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)
422−setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size
395+parseFirst s =
423− -> Settings
396+ case S.split 32 s of -- ' '
424− -> Settings
397+ [method, query, http'] -> do
425−setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }
398+ let (hfirst, hsecond) = B.splitAt 5 http'
426−
399+ if hfirst == "HTTP/"
427−-- | Set the graceful shutdown timeout. A timeout of `Nothing' will
400+ then let (rpath, qstring) = S.breakByte 63 query -- '?'
428−-- wait indefinitely, and a number, if provided, will be treated as seconds
401+ hv =
429−-- to wait for requests to finish, before shutting down the server entirely.
402+ case hsecond of
430−--
403+ "1.1" -> H.http11
431−-- Graceful shutdown mode is entered when the server socket is closed; see
404+ _ -> H.http10
432−-- 'setInstallShutdownHandler' for an example of how this could be done in
405+ in return (method, rpath, qstring, hv)
433−-- response to a UNIX signal.
406+ else throwIO NonHttp
434−--
407+ _ -> throwIO $ BadFirstLine $ B.unpack s
435−-- Since 3.2.8
408+{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported
436−setGracefulShutdownTimeout :: Maybe Int
409+
437− -> Settings -> Settings
410+httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder
438−setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }
411+ , colonSpaceBuilder :: Builder
439−
412+httpBuilder = copyByteString "HTTP/"
440−-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.
413+spaceBuilder = fromChar ' '
441−--
414+newlineBuilder = copyByteString "\r\n"
442−-- Since 3.3.8
415+transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"
443−setMaxTotalHeaderLength :: Int -> Settings -> Settings
416+colonSpaceBuilder = copyByteString ": "
444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings
417+
445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }
418+headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder
446−
419+headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}
447−-- | Explicitly pause the slowloris timeout.
420+ let !start = httpBuilder
448−--
421+ `mappend` copyByteString
449−-- This is useful for cases where you partially consume a request body. For
422+ (case httpversion of
450−-- more information, see <https://github.com/yesodweb/wai/issues/351>
423+ H.HttpVersion 1 1 -> "1.1"
451−--
424+ _ -> "1.0")
452−-- Since 3.0.10
425+ `mappend` spaceBuilder
453−pauseTimeout :: Request -> IO ()
426+ `mappend` fromShow (H.statusCode status)
454−pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault
427+ `mappend` spaceBuilder
455−
428+ `mappend` copyByteString (H.statusMessage status)
456−-- | Getting file information of the target file.
429+ `mappend` newlineBuilder
457−--
430+ !start' = foldl' responseHeaderToBuilder start (serverHeader responseHeaders)
458−-- This function first uses a stat(2) or similar system call
431+ !end = if isChunked'
459−-- to obtain information of the target file, then registers
432+ then transferEncodingBuilder
460−-- it into the internal cache.
433+ else newlineBuilder
461−-- From the next time, the information is obtained
434+ in start' `mappend` end
462−-- from the cache. This reduces the overhead to call the system call.
435+
463−-- The internal cache is refreshed every duration specified by
436+responseHeaderToBuilder :: Builder -> H.Header -> Builder
464−-- 'setFileInfoCacheDuration'.
437+responseHeaderToBuilder b (x, y) = b
465−--
438+ `mappend` copyByteString (CI.original x)
466−-- This function throws an 'IO' exception if the information is not
439+ `mappend` colonSpaceBuilder
467−-- available. For instance, the target file does not exist.
440+ `mappend` copyByteString y
468−-- If this function is used an a Request generated by a WAI
441+ `mappend` newlineBuilder
469−-- backend besides Warp, it also throws an 'IO' exception.
442+
470−--
443+checkPersist :: Request -> Bool
471−-- Since 3.1.10
444+checkPersist req
472−getFileInfo :: Request -> FilePath -> IO FileInfo
445+ | ver == H.http11 = checkPersist11 conn
473−getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault
446+ | otherwise = checkPersist10 conn
474−
447+ where
475−-- | A timeout to limit the time (in milliseconds) waiting for
448+ ver = httpVersion req
476−-- FIN for HTTP/1.x. 0 means uses immediate close.
449+ conn = lookup "connection" $ requestHeaders req
477−-- Default: 0.
450+ checkPersist11 (Just x)
478−--
451+ | CI.foldCase x == "close" = False
479−-- Since 3.3.5
452+ checkPersist11 _ = True
480−setGracefulCloseTimeout1 :: Int -> Settings -> Settings
453+ checkPersist10 (Just x)
481−setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }
454+ | CI.foldCase x == "keep-alive" = True
482−
455+ checkPersist10 _ = False
483−-- | A timeout to limit the time (in milliseconds) waiting for
456+
484−-- FIN for HTTP/1.x. 0 means uses immediate close.
457+isChunked :: H.HttpVersion -> Bool
485−--
458+isChunked = (==) H.http11
486−-- Since 3.3.5
459+
487−getGracefulCloseTimeout1 :: Settings -> Int
460+hasBody :: H.Status -> Request -> Bool
488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1
461+hasBody s req = s /= H.Status 204 "" && s /= H.status304 &&
489−
462+ H.statusCode s >= 200 && requestMethod req /= "HEAD"
490−-- | A timeout to limit the time (in milliseconds) waiting for
463+
491−-- FIN for HTTP/2. 0 means uses immediate close.
464+sendResponse :: T.Handle
492−-- Default: 2000.
465+ -> Request -> Connection -> Response -> ResourceT IO Bool
493−--
466+sendResponse th req conn r = sendResponse' r
494−-- Since 3.3.5
467+ where
495−setGracefulCloseTimeout2 :: Int -> Settings -> Settings
468+ version = httpVersion req
496−setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }
469+ isPersist = checkPersist req
497−
470+ isChunked' = isChunked version
498−-- | A timeout to limit the time (in milliseconds) waiting for
471+ needsChunked hs = isChunked' && not (hasLength hs)
499−-- FIN for HTTP/2. 0 means uses immediate close.
472+ isKeepAlive hs = isPersist && (isChunked' || hasLength hs)
500−--
473+ hasLength hs = isJust $ lookup "content-length" hs
501−-- Since 3.3.5
474+ sendHeader = connSendMany conn . L.toChunks . toLazyByteString
502−getGracefulCloseTimeout2 :: Settings -> Int
475+
503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2
476+ sendResponse' :: Response -> ResourceT IO Bool
504−
477+ sendResponse' (ResponseFile s hs fp mpart) = do
505−-- | Getting information of client certificate.
478+ eres <-
506−--
479+ case (readInt `fmap` lookup "content-length" hs, mpart) of
507−-- Since 3.3.5
480+ (Just cl, _) -> return $ Right (hs, cl)
508−clientCertificate :: Request -> Maybe CertificateChain
481+ (Nothing, Nothing) -> liftIO $ try $ do
509−clientCertificate = join . Vault.lookup getClientCertificateKey . vault
482+ cl <- P.fileSize `fmap` P.getFileStatus fp
483+ return $ addClToHeaders cl
484+ (Nothing, Just part) -> do
485+ let cl = filePartByteCount part
486+ return $ Right $ addClToHeaders cl
487+ case eres of
488+ Left (_ :: SomeException) -> sendResponse' $ responseLBS
489+ H.status404
490+ [("Content-Type", "text/plain")]
491+ "File not found"
492+ Right (lengthyHeaders, cl) -> liftIO $ do
493+ let headers' = headers version s lengthyHeaders
494+ sendHeader $ headers' False
495+ T.tickle th
496+ if hasBody s req then do
497+ case mpart of
498+ Nothing -> connSendFile conn fp 0 cl (T.tickle th)
499+ Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th)
500+ T.tickle th
501+ return isPersist
502+ else
503+ return isPersist
504+ where
505+ addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)
506+
507+ sendResponse' (ResponseBuilder s hs b)
508+ | hasBody s req = liftIO $ do
509+ toByteStringIO (\bs -> do
510+ connSendAll conn bs
511+ T.tickle th) body
512+ return (isKeepAlive hs)
513+ | otherwise = liftIO $ do
514+ sendHeader $ headers' False
515+ T.tickle th
516+ return isPersist
517+ where
518+ headers' = headers version s hs
519+ needsChunked' = needsChunked hs
520+ body = if needsChunked'
521+ then headers' needsChunked'
522+ `mappend` chunkedTransferEncoding b
523+ `mappend` chunkedTransferTerminator
524+ else headers' False `mappend` b
525+
526+ sendResponse' (ResponseSource s hs bodyFlush)
527+ | hasBody s req = do
528+ let src = CL.sourceList [headers' needsChunked'] `mappend`
529+ (if needsChunked' then body C.$= chunk else body)
530+ src C.$$ builderToByteString C.=$ connSink conn th
531+ return $ isKeepAlive hs
532+ | otherwise = liftIO $ do
533+ sendHeader $ headers' False
534+ T.tickle th
535+ return isPersist
536+ where
537+ body = fmap2 (\x -> case x of
538+ C.Flush -> flush
539+ C.Chunk builder -> builder) bodyFlush
540+ headers' = headers version s hs
541+ -- FIXME perhaps alloca a buffer per thread and reuse that in all
542+ -- functions below. Should lessen greatly the GC burden (I hope)
543+ needsChunked' = needsChunked hs
544+ chunk :: C.Conduit Builder (ResourceT IO) Builder
545+ chunk = C.NeedInput push close
546+ push x = C.HaveOutput chunk (return ()) (chunkedTransferEncoding x)
547+ close = C.HaveOutput (C.Done Nothing ()) (return ()) chunkedTransferTerminator
548+
549+fmap2 :: Functor m => (o1 -> o2) -> C.Pipe i o1 m r -> C.Pipe i o2 m r
550+fmap2 f (C.HaveOutput p c o) = C.HaveOutput (fmap2 f p) c (f o)
551+fmap2 f (C.NeedInput p c) = C.NeedInput (fmap2 f . p) (fmap2 f c)
552+fmap2 f (C.PipeM mp c) = C.PipeM (fmap (fmap2 f) mp) c
553+fmap2 _ (C.Done i x) = C.Done i x
554+
555+parseHeaderNoAttr :: ByteString -> H.Header
556+parseHeaderNoAttr s =
557+ let (k, rest) = S.breakByte 58 s -- ':'
558+ restLen = S.length rest
559+ -- FIXME check for colon without following space?
560+ rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": "
561+ then SU.unsafeDrop 2 rest
562+ else rest
563+ in (CI.mk k, rest')
564+
565+connSource :: Connection -> T.Handle -> C.Source (ResourceT IO) ByteString
566+connSource Connection { connRecv = recv } th =
567+ src
568+ where
569+ src = C.PipeM (do
570+ bs <- liftIO recv
571+ if S.null bs
572+ then return $ C.Done Nothing ()
573+ else do
574+ when (S.length bs >= 2048) $ liftIO $ T.tickle th
575+ return (C.HaveOutput src (return ()) bs))
576+ (return ())
577+
578+-- | Use 'connSendAll' to send this data while respecting timeout rules.
579+connSink :: Connection -> T.Handle -> C.Sink B.ByteString (ResourceT IO) ()
580+connSink Connection { connSendAll = send } th =
581+ sink
582+ where
583+ sink = C.NeedInput push close
584+ close = liftIO (T.resume th)
585+ push x = C.PipeM (liftIO $ do
586+ T.resume th
587+ send x
588+ T.pause th
589+ return sink) (liftIO $ T.resume th)
590+ -- We pause timeouts before passing control back to user code. This ensures
591+ -- that a timeout will only ever be executed when Warp is in control. We
592+ -- also make sure to resume the timeout after the completion of user code
593+ -- so that we can kill idle connections.
594+
595+------ The functions below are not warp-specific and could be split out into a
596+--separate package.
597+
598+-- | Various Warp server settings. This is purposely kept as an abstract data
599+-- type so that new settings can be added without breaking backwards
600+-- compatibility. In order to create a 'Settings' value, use 'defaultSettings'
601+-- and record syntax to modify individual records. For example:
602+--
603+-- > defaultSettings { settingsTimeout = 20 }
604+data Settings = Settings
605+ { settingsPort :: Int -- ^ Port to listen on. Default value: 3000
606+ , settingsHost :: HostPreference -- ^ Default value: HostIPv4
607+ , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
608+ , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
609+ , settingsIntercept :: Request -> Maybe (C.Source (ResourceT IO) S.ByteString -> Connection -> ResourceT IO ())
610+ , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
611+ }
612+
613+-- | The default settings for the Warp server. See the individual settings for
614+-- the default value.
615+defaultSettings :: Settings
616+defaultSettings = Settings
617+ { settingsPort = 3000
618+ , settingsHost = HostIPv4
619+ , settingsOnException = \e ->
620+ case fromException e of
621+ Just x -> go x
622+ Nothing ->
623+ when (go' $ fromException e) $
624+ hPrint stderr e
625+ , settingsTimeout = 30
626+ , settingsIntercept = const Nothing
627+ , settingsManager = Nothing
628+ }
629+ where
630+ go :: InvalidRequest -> IO ()
631+ go _ = return ()
632+ go' (Just ThreadKilled) = False
633+ go' _ = True
634+
635+type BSEndo = ByteString -> ByteString
636+type BSEndoList = [ByteString] -> [ByteString]
637+
638+data THStatus = THStatus
639+ {-# UNPACK #-} !Int -- running total byte count
640+ BSEndoList -- previously parsed lines
641+ BSEndo -- bytestrings to be prepended
642+
643+takeHeaders :: C.Sink ByteString (ResourceT IO) [ByteString]
644+takeHeaders =
645+ C.NeedInput (push (THStatus 0 id id)) close
646+ where
647+ close = throwIO IncompleteHeaders
648+
649+ push (THStatus len lines prepend) bs
650+ -- Too many bytes
651+ | len > maxTotalHeaderLength = throwIO OverLargeHeader
652+ | otherwise =
653+ case mnl of
654+ -- No newline find in this chunk. Add it to the prepend,
655+ -- update the length, and continue processing.
656+ Nothing ->
657+ let len' = len + bsLen
658+ prepend' = prepend . S.append bs
659+ status = THStatus len' lines prepend'
660+ in C.NeedInput (push status) close
661+ -- Found a newline at position end.
662+ Just end ->
663+ let start = end + 1 -- start of next chunk
664+ line
665+ -- There were some bytes before the newline, get them
666+ | end > 0 = prepend $ SU.unsafeTake (checkCR bs end) bs
667+ -- No bytes before the newline
668+ | otherwise = prepend S.empty
669+ in if S.null line
670+ -- no more headers
671+ then
672+ let lines' = lines []
673+ -- leftover
674+ rest = if start < bsLen
675+ then Just (SU.unsafeDrop start bs)
676+ else Nothing
677+ in C.Done rest lines'
678+ -- more headers
679+ else
680+ let len' = len + start
681+ lines' = lines . (line:)
682+ status = THStatus len' lines' id
683+ in if start < bsLen
684+ -- more bytes in this chunk, push again
685+ then let bs' = SU.unsafeDrop start bs
686+ in push status bs'
687+ -- no more bytes in this chunk, ask for more
688+ else C.NeedInput (push status) close
689+ where
690+ bsLen = S.length bs
691+ mnl = S.elemIndex 10 bs
692+{-# INLINE takeHeaders #-}
693+
694+checkCR :: ByteString -> Int -> Int
695+checkCR bs pos =
696+ let !p = pos - 1
697+ in if '\r' == B.index bs p
698+ then p
699+ else pos
700+{-# INLINE checkCR #-}
701+
702+readInt :: Integral a => ByteString -> a
703+readInt bs = fromIntegral $ readInt64 bs
704+{-# INLINE readInt #-}
705+
706+
707+-- | Call the inner function with a timeout manager.
708+withManager :: Int -- ^ timeout in microseconds
709+ -> (Manager -> IO a)
710+ -> IO a
711+withManager timeout f = do
712+ -- FIXME when stopManager is available, use it
713+ man <- T.initialize timeout
714+ f man
715+
716+serverHeader :: H.RequestHeaders -> H.RequestHeaders
717+serverHeader hdrs = case lookup key hdrs of
718+ Nothing -> server : hdrs
719+ Just _ -> hdrs
720+ where
721+ key = "Server"
722+ ver = B.pack $ "Warp/" ++ warpVersion
723+ server = (key, ver)
warp/Network/Wai/Handler/Warp/Buffer.hsdeleted−109
@@ -1,109 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−module Network.Wai.Handler.Warp.Buffer (
4− bufferSize
5− , allocateBuffer
6− , freeBuffer
7− , mallocBS
8− , newBufferPool
9− , withBufferPool
10− , toBuilderBuffer
11− , copy
12− , bufferIO
13− ) where
14−
15−import qualified Data.ByteString as BS
16−import Data.ByteString.Internal (memcpy)
17−import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)
18−import Data.IORef (newIORef, readIORef, writeIORef)
19−import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))
20−import Foreign.ForeignPtr
21−import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)
22−import Foreign.Ptr (castPtr, plusPtr)
23−
24−import Network.Wai.Handler.Warp.Imports
25−import Network.Wai.Handler.Warp.Types
26−
27−----------------------------------------------------------------
28−
29−-- | The default size of the write buffer: 16384 (2^14 = 1024 * 16).
30−-- This is the maximum size of TLS record.
31−-- This is also the maximum size of HTTP/2 frame payload
32−-- (excluding frame header).
33−bufferSize :: BufSize
34−bufferSize = 16384
35−
36−-- | Allocating a buffer with malloc().
37−allocateBuffer :: Int -> IO Buffer
38−allocateBuffer = mallocBytes
39−
40−-- | Releasing a buffer with free().
41−freeBuffer :: Buffer -> IO ()
42−freeBuffer = free
43−
44−----------------------------------------------------------------
45−
46−largeBufferSize :: Int
47−largeBufferSize = 16384
48−
49−minBufferSize :: Int
50−minBufferSize = 2048
51−
52−newBufferPool :: IO BufferPool
53−newBufferPool = newIORef BS.empty
54−
55−mallocBS :: Int -> IO ByteString
56−mallocBS size = do
57− ptr <- allocateBuffer size
58− fptr <- newForeignPtr finalizerFree ptr
59− return $! PS fptr 0 size
60−{-# INLINE mallocBS #-}
61−
62−usefulBuffer :: ByteString -> Bool
63−usefulBuffer buffer = BS.length buffer >= minBufferSize
64−{-# INLINE usefulBuffer #-}
65−
66−getBuffer :: BufferPool -> IO ByteString
67−getBuffer pool = do
68− buffer <- readIORef pool
69− if usefulBuffer buffer then return buffer else mallocBS largeBufferSize
70−{-# INLINE getBuffer #-}
71−
72−putBuffer :: BufferPool -> ByteString -> IO ()
73−putBuffer pool buffer = writeIORef pool buffer
74−{-# INLINE putBuffer #-}
75−
76−withForeignBuffer :: ByteString -> ((Buffer, BufSize) -> IO Int) -> IO Int
77−withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s, l)
78−{-# INLINE withForeignBuffer #-}
79−
80−withBufferPool :: BufferPool -> ((Buffer, BufSize) -> IO Int) -> IO ByteString
81−withBufferPool pool f = do
82− buffer <- getBuffer pool
83− consumed <- withForeignBuffer buffer f
84− putBuffer pool $! unsafeDrop consumed buffer
85− return $! unsafeTake consumed buffer
86−{-# INLINE withBufferPool #-}
87−
88−----------------------------------------------------------------
89−--
90−-- Utilities
91−--
92−
93−toBuilderBuffer :: Buffer -> BufSize -> IO B.Buffer
94−toBuilderBuffer ptr size = do
95− fptr <- newForeignPtr_ ptr
96− return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)
97−
98−-- | Copying the bytestring to the buffer.
99−-- This function returns the point where the next copy should start.
100−copy :: Buffer -> ByteString -> IO Buffer
101−copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do
102− memcpy ptr (p `plusPtr` o) (fromIntegral l)
103− return $! ptr `plusPtr` l
104−{-# INLINE copy #-}
105−
106−bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO ()
107−bufferIO ptr siz io = do
108− fptr <- newForeignPtr_ ptr
109− io $ PS fptr 0 siz
warp/Network/Wai/Handler/Warp/Conduit.hsdeleted−169
@@ -1,169 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Network.Wai.Handler.Warp.Conduit where
4−
5−import Control.Exception
6−import qualified Data.ByteString as S
7−import qualified Data.IORef as I
8−
9−import Network.Wai.Handler.Warp.Imports
10−import Network.Wai.Handler.Warp.Types
11−
12−----------------------------------------------------------------
13−
14−-- | Contains a @Source@ and a byte count that is still to be read in.
15−data ISource = ISource !Source !(I.IORef Int)
16−
17−mkISource :: Source -> Int -> IO ISource
18−mkISource src cnt = do
19− ref <- I.newIORef cnt
20− return $! ISource src ref
21−
22−-- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the
23−-- specified number of bytes to be passed downstream. All leftovers should be
24−-- retained within the @Source@. If there are not enough bytes available,
25−-- throws a @ConnectionClosedByPeer@ exception.
26−readISource :: ISource -> IO ByteString
27−readISource (ISource src ref) = do
28− count <- I.readIORef ref
29− if count == 0
30− then return S.empty
31− else do
32−
33− bs <- readSource src
34−
35− -- If no chunk available, then there aren't enough bytes in the
36− -- stream. Throw a ConnectionClosedByPeer
37− when (S.null bs) $ throwIO ConnectionClosedByPeer
38−
39− let -- How many of the bytes in this chunk to send downstream
40− toSend = min count (S.length bs)
41− -- How many bytes will still remain to be sent downstream
42− count' = count - toSend
43− case () of
44− ()
45− -- The expected count is greater than the size of the
46− -- chunk we just read. Send the entire chunk
47− -- downstream, and then loop on this function for the
48− -- next chunk.
49− | count' > 0 -> do
50− I.writeIORef ref count'
51− return bs
52−
53− -- Some of the bytes in this chunk should not be sent
54− -- downstream. Split up the chunk into the sent and
55− -- not-sent parts, add the not-sent parts onto the new
56− -- source, and send the rest of the chunk downstream.
57− | otherwise -> do
58− let (x, y) = S.splitAt toSend bs
59− leftoverSource src y
60− assert (count' == 0) $ I.writeIORef ref count'
61− return x
62−
63−----------------------------------------------------------------
64−
65−data CSource = CSource !Source !(I.IORef ChunkState)
66−
67−data ChunkState = NeedLen
68− | NeedLenNewline
69− | HaveLen Word
70− | DoneChunking
71− deriving Show
72−
73−mkCSource :: Source -> IO CSource
74−mkCSource src = do
75− ref <- I.newIORef NeedLen
76− return $! CSource src ref
77−
78−readCSource :: CSource -> IO ByteString
79−readCSource (CSource src ref) = do
80− mlen <- I.readIORef ref
81− go mlen
82− where
83− withLen 0 bs = do
84− leftoverSource src bs
85− dropCRLF
86− yield' S.empty DoneChunking
87− withLen len bs
88− | S.null bs = do
89− -- FIXME should this throw an exception if len > 0?
90− I.writeIORef ref DoneChunking
91− return S.empty
92− | otherwise =
93− case S.length bs `compare` fromIntegral len of
94− EQ -> yield' bs NeedLenNewline
95− LT -> yield' bs $ HaveLen $ len - fromIntegral (S.length bs)
96− GT -> do
97− let (x, y) = S.splitAt (fromIntegral len) bs
98− leftoverSource src y
99− yield' x NeedLenNewline
100−
101− yield' bs mlen = do
102− I.writeIORef ref mlen
103− return bs
104−
105− dropCRLF = do
106− bs <- readSource src
107− case S.uncons bs of
108− Nothing -> return ()
109− Just (13, bs') -> dropLF bs'
110− Just (10, bs') -> leftoverSource src bs'
111− Just _ -> leftoverSource src bs
112−
113− dropLF bs =
114− case S.uncons bs of
115− Nothing -> do
116− bs2 <- readSource' src
117− unless (S.null bs2) $ dropLF bs2
118− Just (10, bs') -> leftoverSource src bs'
119− Just _ -> leftoverSource src bs
120−
121− go NeedLen = getLen
122− go NeedLenNewline = dropCRLF >> getLen
123− go (HaveLen 0) = do
124− -- Drop the final CRLF
125− dropCRLF
126− I.writeIORef ref DoneChunking
127− return S.empty
128− go (HaveLen len) = do
129− bs <- readSource src
130− withLen len bs
131− go DoneChunking = return S.empty
132−
133− -- Get the length from the source, and then pass off control to withLen
134− getLen = do
135− bs <- readSource src
136− if S.null bs
137− then do
138− I.writeIORef ref $ assert False $ HaveLen 0
139− return S.empty
140− else do
141− (x, y) <-
142− case S.break (== 10) bs of
143− (x, y)
144− | S.null y -> do
145− bs2 <- readSource' src
146− return $ if S.null bs2
147− then (x, y)
148− else S.break (== 10) $ bs `S.append` bs2
149− | otherwise -> return (x, y)
150− let w =
151− S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0
152− $ S.takeWhile isHexDigit x
153−
154− let y' = S.drop 1 y
155− y'' <-
156− if S.null y'
157− then readSource src
158− else return y'
159− withLen w y''
160−
161− hexToWord w
162− | w < 58 = w - 48
163− | w < 71 = w - 55
164− | otherwise = w - 87
165−
166−isHexDigit :: Word8 -> Bool
167−isHexDigit w = w >= 48 && w <= 57
168− || w >= 65 && w <= 70
169− || w >= 97 && w <= 102
warp/Network/Wai/Handler/Warp/Counter.hsdeleted−30
@@ -1,30 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Network.Wai.Handler.Warp.Counter (
4− Counter
5− , newCounter
6− , waitForZero
7− , increase
8− , decrease
9− ) where
10−
11−import Control.Concurrent.STM
12−
13−import Network.Wai.Handler.Warp.Imports
14−
15−
16−newtype Counter = Counter (TVar Int)
17−
18−newCounter :: IO Counter
19−newCounter = Counter <$> newTVarIO 0
20−
21−waitForZero :: Counter -> IO ()
22−waitForZero (Counter ref) = atomically $ do
23− x <- readTVar ref
24− unless (x == 0) retry
25−
26−increase :: Counter -> IO ()
27−increase (Counter ref) = atomically $ modifyTVar' ref $ \x -> x + 1
28−
29−decrease :: Counter -> IO ()
30−decrease (Counter ref) = atomically $ modifyTVar' ref $ \x -> x - 1
warp/Network/Wai/Handler/Warp/Date.hsdeleted−41
@@ -1,41 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Network.Wai.Handler.Warp.Date (
4− withDateCache
5− , GMTDate
6− ) where
7−
8−import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)
9−import Data.ByteString
10−import Network.HTTP.Date
11−
12−#if WINDOWS
13−import Data.Time (UTCTime, getCurrentTime)
14−import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
15−import Foreign.C.Types (CTime(..))
16−#else
17−import System.Posix (epochTime)
18−#endif
19−
20−-- | The type of the Date header value.
21−type GMTDate = ByteString
22−
23−-- | Creating 'DateCache' and executing the action.
24−withDateCache :: (IO GMTDate -> IO a) -> IO a
25−withDateCache action = initialize >>= action
26−
27−initialize :: IO (IO GMTDate)
28−initialize = mkAutoUpdate defaultUpdateSettings {
29− updateAction = formatHTTPDate <$> getCurrentHTTPDate
30− }
31−
32−#ifdef WINDOWS
33−uToH :: UTCTime -> HTTPDate
34−uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds
35−
36−getCurrentHTTPDate :: IO HTTPDate
37−getCurrentHTTPDate = uToH <$> getCurrentTime
38−#else
39−getCurrentHTTPDate :: IO HTTPDate
40−getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime
41−#endif
warp/Network/Wai/Handler/Warp/FdCache.hsdeleted−142
@@ -1,142 +0,0 @@
1−{-# LANGUAGE BangPatterns, CPP #-}
2−
3−-- | File descriptor cache to avoid locks in kernel.
4−
5−module Network.Wai.Handler.Warp.FdCache (
6− withFdCache
7− , Fd
8− , Refresh
9−#ifndef WINDOWS
10− , openFile
11− , closeFile
12− , setFileCloseOnExec
13−#endif
14− ) where
15−
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.
28−type Refresh = IO ()
29−
30−getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)
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
40−#else
41−withFdCache 0 action = action getFdNothing
42−withFdCache duration action = bracket (initialize duration)
43− terminate
44− (action . getFd)
45−
46−----------------------------------------------------------------
47−
48−data Status = Active | Inactive
49−
50−newtype MutableStatus = MutableStatus (IORef Status)
51−
52−status :: MutableStatus -> IO Status
53−status (MutableStatus ref) = readIORef ref
54−
55−newActiveStatus :: IO MutableStatus
56−newActiveStatus = MutableStatus <$> newIORef Active
57−
58−refresh :: MutableStatus -> Refresh
59−refresh (MutableStatus ref) = writeIORef ref Active
60−
61−inactive :: MutableStatus -> IO ()
62−inactive (MutableStatus ref) = writeIORef ref Inactive
63−
64−----------------------------------------------------------------
65−
66−data FdEntry = FdEntry !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−
77−newFdEntry :: FilePath -> IO FdEntry
78−newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus
79−
80−setFileCloseOnExec :: Fd -> IO ()
81−setFileCloseOnExec fd = setFdOption fd CloseOnExec True
82−
83−----------------------------------------------------------------
84−
85−type FdCache = MultiMap FdEntry
86−
87−-- | Mutable Fd cacher.
88−newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))
89−
90−fdCache :: MutableFdCache -> IO FdCache
91−fdCache (MutableFdCache reaper) = reaperRead reaper
92−
93−look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)
94−look mfc path = MM.lookup path <$> fdCache mfc
95−
96−----------------------------------------------------------------
97−
98−-- The first argument is a cache duration in second.
99−initialize :: Int -> IO MutableFdCache
100−initialize duration = MutableFdCache <$> mkReaper settings
101− where
102− settings = defaultReaperSettings {
103− reaperAction = clean
104− , reaperDelay = duration
105− , reaperCons = uncurry insert
106− , reaperNull = isEmpty
107− , reaperEmpty = empty
108− }
109−
110−clean :: FdCache -> IO (FdCache -> FdCache)
111−clean old = do
112− new <- pruneWith old prune
113− return $ merge new
114− where
115− prune (_,FdEntry fd mst) = status mst >>= act
116− where
117− act Active = inactive mst >> return True
118− act Inactive = closeFd fd >> return False
119−
120−----------------------------------------------------------------
121−
122−terminate :: MutableFdCache -> IO ()
123−terminate (MutableFdCache reaper) = do
124− !t <- reaperStop reaper
125− mapM_ (closeIt . snd) $ toList t
126− where
127− closeIt (FdEntry fd _) = closeFd fd
128−
129−----------------------------------------------------------------
130−
131−-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.
132−getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)
133−getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get
134− where
135− get Nothing = do
136− ent@(FdEntry fd mst) <- newFdEntry path
137− reaperAdd reaper (path,ent)
138− return (Just fd, refresh mst)
139− get (Just (FdEntry fd mst)) = do
140− refresh mst
141− return (Just fd, refresh mst)
142−#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

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Header.hsdeleted−101

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/IO.hsdeleted−30

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Imports.hsdeleted−27

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Internal.hsdeleted−86

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/MultiMap.hsdeleted−111

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/PackInt.hsdeleted−56

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Recv.hsdeleted−160

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Request.hsdeleted−303

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/RequestHeader.hsdeleted−133

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Response.hsdeleted−427

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/ResponseHeader.hsdeleted−84

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Run.hsdeleted−599

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/SendFile.hsdeleted−149

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Settings.hsdeleted−231

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Types.hsdeleted−188

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/Windows.hsdeleted−27

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/WithApplication.hsdeleted−104

This diff is too big to show here.

warp/READMEnew file

No changes to the content.

warp/README.mddeleted−3

This diff is too big to show here.

warp/Network/Wai/Handler/Warp/ReadInt.hs → warp/ReadInt.hsrenamed+13−22

This diff is too big to show here.

warp/Timeout.hsnew file+66

This diff is too big to show here.

warp/attic/hexdeleted−1

This diff is too big to show here.

warp/attic/print-post.hsdeleted−18

This diff is too big to show here.

warp/bench/Parser.hsdeleted−220

This diff is too big to show here.

warp/attic/bigtable-single.hs → warp/bigtable-single.hsrenamed

The content is the same.

warp/attic/bigtable-stream.hs → warp/bigtable-stream.hsrenamed

The content is the same.

warp/attic/file-nolen.hs → warp/file-nolen.hsrenamed

The content is the same.

warp/attic/file.hs → warp/file.hsrenamed

The content is the same.

warp/attic/pong.hs → warp/pong.hsrenamed+12−12

This diff is too big to show here.

warp/attic/pong.txt → warp/pong.txtrenamed

The content is the same.

warp/attic/runtests.hs → warp/runtests.hsrenamed

The content is the same.

warp/attic/server-no-keepalive.hs → warp/server-no-keepalive.hsrenamed+1−1

This diff is too big to show here.

warp/attic/statuses.hs → warp/statuses.hsrenamed

The content is the same.

warp/attic/test.txt → warp/test.txtrenamed

The content is the same.

warp/test/BufferPoolSpec.hsdeleted−47

This diff is too big to show here.

warp/test/ConduitSpec.hsdeleted−67

This diff is too big to show here.

warp/test/ExceptionSpec.hsdeleted−66

This diff is too big to show here.

warp/test/FdCacheSpec.hsdeleted−27

This diff is too big to show here.

warp/test/FileSpec.hsdeleted−45

This diff is too big to show here.

warp/test/HTTP.hsdeleted−41

This diff is too big to show here.

warp/test/ReadIntSpec.hsdeleted−26

This diff is too big to show here.

warp/test/RequestSpec.hsdeleted−149

This diff is too big to show here.

warp/test/ResponseHeaderSpec.hsdeleted−48

This diff is too big to show here.

warp/test/ResponseSpec.hsdeleted−107

This diff is too big to show here.

warp/test/RunSpec.hsdeleted−463

This diff is too big to show here.

warp/test/SendFileSpec.hsdeleted−116

This diff is too big to show here.

warp/test/Spec.hsdeleted−1

This diff is too big to show here.

warp/test/WithApplicationSpec.hsdeleted−45

This diff is too big to show here.

warp/test/doctests.hsdeleted−4

This diff is too big to show here.

warp/test/head-responsedeleted−1

This diff is too big to show here.

warp/test/inputFiledeleted−100

This diff is too big to show here.

warp/test/main.hsnew file+148

This diff is too big to show here.

warp/attic/readInt.hs → warp/test/readInt.hsrenamed

The content is the same.

warp/attic/undrained.hs → warp/undrained.hsrenamed

The content is the same.

warp/warp.cabal+43−247

This diff is too big to show here.