master..09763ea · typeable/wai

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

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

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

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

6− strategy:

7− matrix:

8− stack-lts-11:

9− BUILD: stack

10− STACK_YAML: stack-lts-11.yaml

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

12− stack-lts-12:

13− BUILD: stack

14− STACK_YAML: stack-lts-12.yaml

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

16− stack-lts-14:

17− BUILD: stack

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

19− stack-nightly:

20− BUILD: stack

21− STACK_YAML: stack-nightly.yaml

22− ARGS: "--resolver nightly"

23− cabal-8.2.2:

24− BUILD: cabal

25− GHCVER: 8.4.4

26− CABALVER: 2.0

27− cabal-8.4.4:

28− BUILD: cabal

29− GHCVER: 8.4.4

30− CABALVER: 2.2

31− cabal-8.6.5:

32− BUILD: cabal

33− GHCVER: 8.6.5

34− CABALVER: 2.4

35− maxParallel: 6

36− steps:

37− - script: |

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

39− mkdir -p ~/.local/bin

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

41− case "$BUILD" in

42− cabal)

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

44− sudo apt-get update

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

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

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

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

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

50− else

51− sudo apt-get install happy alex

52− fi

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

54− cabal --version

55− cabal update

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

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

58− ;;

59− *)

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

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

62− ;;

63− esac

64− set -ex

65− case "$BUILD" in

66− cabal)

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

68−

69− ORIGDIR=$(pwd)

70− for dir in $PACKAGES

71− do

72− cd $dir

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

74− cabal sdist

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

76− SRC_TGZ=$PKGVER.tar.gz

77− cd dist

78− tar zxfv "$SRC_TGZ"

79− cd "$PKGVER"

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

81− cabal build

82− cabal test --show-details=streaming

83− cd $ORIGDIR

84− done

85− ;;

86− *)

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

88− ;;

89− esac

90− set +ex

91− env:

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

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

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

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

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

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

6− strategy:

7− matrix:

8− stack-lts-11:

9− BUILD: stack

10− STACK_YAML: stack-lts-11.yaml

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

12− stack-lts-12:

13− BUILD: stack

14− STACK_YAML: stack-lts-12.yaml

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

16− stack-lts-14:

17− BUILD: stack

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

19− maxParallel: 3

20− steps:

21− - script: |

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

23− mkdir -p ~/.local/bin

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

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

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

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

28− env:

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

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

.azure/azure-pipelines.ymldeleted−30

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

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

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

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

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

5−#

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

7−#

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

9−# named azure-pipelines.yml

10−#

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

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

13−jobs:

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

15− parameters:

16− name: Linux

17− vmImage: ubuntu-16.04

18− os: linux

19−

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

21− parameters:

22− name: macOS

23− vmImage: macOS-10.13

24− os: osx

25−

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

27− parameters:

28− name: Windows

29− vmImage: vs2017-win2016

30− os: windows

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

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

1−jobs:

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

3− timeoutInMinutes: 180

4− pool:

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

6− strategy:

7− matrix:

8− stack-lts-14:

9− BUILD: stack

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

11− maxParallel: 3

12− steps:

13− - bash: |

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

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

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

17− stack setup $ARGS > /dev/null

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

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

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

21− env:

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

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

.github/ISSUE_TEMPLATE.mddeleted−28

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

1−<!---

2−

3−### Bug Reports

4−

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

6−

7−* Your OS name and version

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

9−* The versions of dependencies you're using

10−

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

12−

13−```

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

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

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

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

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

19−```

20−

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

22−

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

24−

25−### Support

26−

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

28−-->

.github/PULL_REQUEST_TEMPLATE.mddeleted−14

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

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

2−

3−- [ ] Bumped the version number

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

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

6−

7−After submitting your PR:

8−

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

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

11−

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

13−

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

.gitignore−3

@@ -7,6 +7,3 @@ tarballs/

77/.shelly

88.cabal-sandbox/

99cabal.sandbox.config

10−.stack-work/

11−*~

12−stack*.yaml.lock

.travis.ymlnew file+16

@@ -0,0 +1,16 @@

1+language: haskell

2+

3+ghc:

4+ - 7.6

5+ - 7.8

6+

7+install:

8+ - ghc --version

9+ - cabal --version

10+ - sudo apt-get install libfcgi-dev

11+ - cabal unpack wai-logger

12+ - mv wai-logger-* wai-logger

13+ - cabal install hspec doctest HTTP cabal-meta cabal-src

14+ - cabal-meta install --force-reinstalls

15+

16+script: mega-sdist --test

CONTRIBUTING.mddeleted−94

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

1−# Contributing

2−

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

4−

5−## Development

6−

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

8−

9−* `stack build mime-types`

10−* `stack test auto-update`

11−* `stack haddock warp`

12−

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

14−

15−```

16−packages:

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

18−```

19−

20−## Coding Guidelines

21−

22−### Safety

23−

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

25−

26−### Style

27−

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

29−

30−### Dependencies

31−

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

33−

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

35−

36−### Backwards Compatibility

37−

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

39−

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

41−

42−## PR Guidelines

43−

44−### PR Scope

45−

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

47−

48−### Testing

49−

50−Tests are recommended, but not required.

51−

52−### Documentation

53−

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

55−

56−```

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

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

59−--

60−-- ==== __Examples__

61−--

62−-- > getTime <- mkAutoUpdate defaultUpdateSettings

63−--

64−-- @since 0.1.0

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

66−```

67−

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

69−

70−### Versioning

71−

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

73−

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

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

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

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

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

79−

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

81−

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

83−

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

85−

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

87−

88−### Changelog

89−

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

91−

92−### Releases

93−

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

LICENSE+1−1

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

22

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

44a copy of this software and associated documentation files (the

README.md−2

@@ -9,5 +9,3 @@ Code can be written that works with any web framework targeting WAI.

99[Documentation](http://www.yesodweb.com/book/web-application-interface)

1010

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

12−

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

auto-update/ChangeLog.md+1−34

@@ -1,34 +1 @@

1−# ChangeLog for auto-update

2−

3−## 0.1.6

4−

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

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

7−

8−## 0.1.5

9−

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

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

12−

13−## 0.1.4.1

14−

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

16− Improve documentation for `reaperAction` function.

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

18− Fixed memory leak in `reaperAdd` function.

19−

20−## 0.1.4

21−

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

23−

24−## 0.1.3.1

25−

26−* Doc improvements

27−

28−## 0.1.3

29−

30−* Adding a new AIP - reaperKill

31−

32−## 0.1.2

33−

34−* Added Control.Debounce

1+__0.1.2__ Added Control.Debounce

auto-update/Control/AutoUpdate.hs+28−64

@@ -1,60 +1,35 @@

1−{-# LANGUAGE CPP #-}

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'.

1+-- | A common problem is the desire to have an action run at a scheduled

2+-- interval, but only if it is needed. For example, instead of having

3+-- every web request result in a new @getCurrentTime@ call, we'd like to

4+-- have a single worker thread run every second, updating an @IORef@.

5+-- However, if the request frequency is less than once per second, this is

6+-- a pessimization, and worse, kills idle GC.

87--

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

8+-- This library allows you to define actions which will either be

9+-- performed by a dedicated thread or, in times of low volume, will be

10+-- executed by the calling thread.

3111module Control.AutoUpdate (

3212 -- * Type

3313 UpdateSettings

3414 , defaultUpdateSettings

3515 -- * Accessors

36− , updateAction

3716 , updateFreq

3817 , updateSpawnThreshold

18+ , updateAction

3919 -- * Creation

4020 , mkAutoUpdate

41− , mkAutoUpdateWithModify

4221 ) where

4322

44−#if __GLASGOW_HASKELL__ < 709

45−import Control.Applicative ((<*>))

46−#endif

4723import Control.Concurrent (forkIO, threadDelay)

4824import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,

4925 takeMVar, tryPutMVar)

50−import Control.Exception (SomeException, catch, mask_, throw,

51− try)

26+import Control.Exception (SomeException, catch, throw, mask_, try)

5227import Control.Monad (void)

5328import Data.IORef (newIORef, readIORef, writeIORef)

5429

55−-- | Default value for creating an 'UpdateSettings'.

30+-- | Default value for creating an @UpdateSettings@.

5631--

57−-- @since 0.1.0

32+-- Since 0.1.0

5833defaultUpdateSettings :: UpdateSettings ()

5934defaultUpdateSettings = UpdateSettings

6035 { updateFreq = 1000000

@@ -64,57 +39,46 @@ defaultUpdateSettings = UpdateSettings

6439

6540-- | Settings to control how values are updated.

6641--

67−-- This should be constructed using 'defaultUpdateSettings' and record

42+-- This should be constructed using @defaultUpdateSettings@ and record

6843-- update syntax, e.g.:

6944--

7045-- @

71−-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }

46+-- let set = defaultUpdateSettings { updateAction = getCurrentTime }

7247-- @

7348--

74−-- @since 0.1.0

49+-- Since 0.1.0

7550data UpdateSettings a = UpdateSettings

7651 { updateFreq :: Int

7752 -- ^ Microseconds between update calls. Same considerations as

78− -- 'threadDelay' apply.

53+ -- @threadDelay@ apply.

7954 --

8055 -- Default: 1 second (1000000)

8156 --

82− -- @since 0.1.0

57+ -- Since 0.1.0

8358 , updateSpawnThreshold :: Int

8459 -- ^ NOTE: This value no longer has any effect, since worker threads are

8560 -- dedicated instead of spawned on demand.

8661 --

87− -- Previously, this determined how many times the data must be requested

62+ -- Previously, this determined: How many times the data must be requested

8863 -- before we decide to spawn a dedicated thread.

8964 --

9065 -- Default: 3

9166 --

92− -- @since 0.1.0

67+ -- Since 0.1.0

9368 , updateAction :: IO a

9469 -- ^ Action to be performed to get the current value.

9570 --

9671 -- Default: does nothing.

9772 --

98− -- @since 0.1.0

73+ -- Since 0.1.0

9974 }

10075

10176-- | Generate an action which will either read from an automatically

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

10378--

104−-- @since 0.1.0

79+-- Since 0.1.0

10580mkAutoUpdate :: 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

81+mkAutoUpdate us = do

11882 -- A baton to tell the worker thread to generate a new value.

11983 needsRunning <- newEmptyMVar

12084

@@ -157,12 +121,12 @@ mkAutoUpdateHelper us updateActionModify = do

157121 -- This infinite loop makes up out worker thread. It takes an a

158122 -- responseVar value where the next value should be putMVar'ed to for

159123 -- the benefit of any requesters currently blocked on it.

160− let loop responseVar maybea = do

124+ let loop responseVar = do

161125 -- block until a value is actually needed

162126 takeMVar needsRunning

163127

164128 -- new value requested, so run the updateAction

165− a <- catchSome $ maybe (updateAction us) id (updateActionModify <*> maybea)

129+ a <- catchSome $ updateAction us

166130

167131 -- we got a new value, update currRef and lastValue

168132 writeIORef currRef $ Right a

@@ -177,10 +141,10 @@ mkAutoUpdateHelper us updateActionModify = do

177141 -- variable.

178142 responseVar' <- newEmptyMVar

179143 writeIORef currRef $ Left responseVar'

180− loop responseVar' (Just a)

144+ loop responseVar'

181145

182146 -- Kick off the loop, with the initial responseVar0 variable.

183− loop responseVar0 Nothing

147+ loop responseVar0

184148

185149 return $ do

186150 mval <- readIORef currRef

@@ -194,7 +158,7 @@ mkAutoUpdateHelper us updateActionModify = do

194158 -- we have a current value, use it

195159 Right val -> return val

196160

197−-- | Turn a runtime exception into an impure exception, so that all 'IO'

161+-- | Turn a runtime exception into an impure exception, so that all @IO@

198162-- actions will complete successfully. This simply defers the exception until

199163-- the value is forced.

200164catchSome :: IO a -> IO a

auto-update/Control/Debounce.hs+59−41

@@ -3,58 +3,76 @@

33-- period of time.

44--

55-- This is useful as an optimization, for example to ensure that logs are only

6−-- flushed to disk at most once per second.

6+-- flushed to disk at most once per second. See the fast-logger package for an

7+-- example usage.

78--

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

9+-- Since 0.1.2

2710module Control.Debounce

2811 ( -- * Type

29− DI.DebounceSettings

12+ DebounceSettings

3013 , defaultDebounceSettings

3114 -- * Accessors

32− , DI.debounceFreq

33− , DI.debounceAction

34− , DI.debounceEdge

35− , DI.leadingEdge

36− , DI.trailingEdge

15+ , debounceFreq

16+ , debounceAction

3717 -- * Creation

3818 , mkDebounce

3919 ) where

4020

41−import Control.Concurrent (newEmptyMVar, threadDelay)

42−import qualified Control.Debounce.Internal as DI

21+import Control.Concurrent (forkIO, threadDelay)

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

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

24+import Control.Monad (forever, void)

25+

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

27+--

28+-- This should be constructed using @defaultDebounceSettings@ and record

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

30+--

31+-- @

32+-- let set = defaultDebounceSettings { debounceAction = flushLog }

33+-- @

34+--

35+-- Since 0.1.2

36+data DebounceSettings = DebounceSettings

37+ { debounceFreq :: Int

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

39+ -- action.

40+ --

41+ -- Default: 1 second (1000000)

42+ --

43+ -- Since 0.1.2

44+ , debounceAction :: IO ()

45+ -- ^ Action to be performed.

46+ --

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

48+ --

49+ -- Default: does nothing.

50+ --

51+ -- Since 0.1.2

52+ }

4353

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

54+-- | Default value for creating a @DebounceSettings@.

4555--

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

56+-- Since 0.1.2

57+defaultDebounceSettings :: DebounceSettings

58+defaultDebounceSettings = DebounceSettings

59+ { debounceFreq = 1000000

60+ , debounceAction = return ()

5261 }

5362

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

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

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

65+-- current cooldown period has expired.

5566--

56−-- @since 0.1.2

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

58−mkDebounce settings = do

59− baton <- newEmptyMVar

60− DI.mkDebounceInternal baton threadDelay settings

67+-- Since 0.1.2

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

69+mkDebounce (DebounceSettings freq action) = do

70+ baton <- newEmptyMVar

71+ mask_ $ void $ forkIO $ forever $ do

72+ takeMVar baton

73+ ignoreExc action

74+ threadDelay freq

75+ return $ void $ tryPutMVar baton ()

76+

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

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

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

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

1−{-# LANGUAGE ScopedTypeVariables #-}

2−

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

4−module Control.Debounce.Internal (

5− DebounceSettings(..)

6− , DebounceEdge(..)

7− , leadingEdge

8− , trailingEdge

9− , mkDebounceInternal

10− ) where

11−

12−import Control.Concurrent (forkIO)

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

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

15−import Control.Monad (forever, void)

16−

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

18−--

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

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

21−--

22−-- @

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

24−-- @

25−--

26−-- @since 0.1.2

27−data DebounceSettings = DebounceSettings

28− { debounceFreq :: Int

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

30− --

31− -- Default: 1 second (1000000)

32− --

33− -- @since 0.1.2

34− , debounceAction :: IO ()

35− -- ^ Action to be performed.

36− --

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

38− --

39− -- Default: does nothing.

40− --

41− -- @since 0.1.2

42− , debounceEdge :: DebounceEdge

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

44− -- the timeout.

45− --

46− -- Default: 'trailingEdge'.

47− --

48− -- @since 0.1.6

49− }

50−

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

52−-- edge of the timeout.

53−--

54−-- @since 0.1.6

55−data DebounceEdge =

56− Leading

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

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

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

60− | Trailing

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

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

63− deriving (Show, Eq)

64−

65−

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

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

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

69−--

70−-- @since 0.1.6

71−leadingEdge :: DebounceEdge

72−leadingEdge = Leading

73−

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

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

76−--

77−-- @since 0.1.6

78−trailingEdge :: DebounceEdge

79−trailingEdge = Trailing

80−

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

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

83− mask_ $ void $ forkIO $ forever $ do

84− takeMVar baton

85− case edge of

86− Leading -> do

87− ignoreExc action

88− delayFn freq

89− Trailing -> do

90− delayFn freq

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

92− void $ tryTakeMVar baton

93− ignoreExc action

94−

95− return $ void $ tryPutMVar baton ()

96−

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

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

auto-update/Control/Reaper.hs+36−131

@@ -1,20 +1,9 @@

11{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE BangPatterns #-}

32

43-- | This module provides the ability to create reapers: dedicated cleanup

54-- 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".

5+-- presence of a workload to process on.

146module Control.Reaper (

15− -- * Example: Regularly cleaning a cache

16− -- $example1

17−

187 -- * Settings

198 ReaperSettings

209 , defaultReaperSettings

@@ -33,9 +22,10 @@ module Control.Reaper (

3322 ) where

3423

3524import Control.AutoUpdate.Util (atomicModifyIORef')

36−import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)

25+import Control.Concurrent (forkIO, threadDelay)

3726import Control.Exception (mask_)

38−import Data.IORef (IORef, newIORef, readIORef, writeIORef)

27+import Control.Monad (join, void)

28+import Data.IORef (IORef, newIORef, readIORef)

3929

4030-- | Settings for creating a reaper. This type has two parameters:

4131-- @workload@ gives the entire workload, whereas @item@ gives an

@@ -43,52 +33,51 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef)

4333-- be a list of @item@s. This is encouraged by 'defaultReaperSettings' and

4434-- 'mkListAction'.

4535--

46−-- @since 0.1.1

36+-- Since 0.1.1

4737data ReaperSettings workload item = ReaperSettings

4838 { reaperAction :: workload -> IO (workload -> workload)

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

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

5141 -- 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'.

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

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

5544 --

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

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

5847 -- definitely override this default.

5948 --

60− -- @since 0.1.1

49+ -- Since 0.1.1

6150 , reaperDelay :: {-# UNPACK #-} !Int

6251 -- ^ Number of microseconds to delay between calls of 'reaperAction'.

6352 --

6453 -- Default: 30 seconds.

6554 --

66− -- @since 0.1.1

55+ -- Since 0.1.1

6756 , reaperCons :: item -> workload -> workload

6857 -- ^ Add an item onto a workload.

6958 --

7059 -- Default: list consing.

7160 --

72− -- @since 0.1.1

61+ -- Since 0.1.1

7362 , reaperNull :: workload -> Bool

7463 -- ^ Check if a workload is empty, in which case the worker thread

7564 -- will shut down.

7665 --

7766 -- Default: 'null'.

7867 --

79− -- @since 0.1.1

68+ -- Since 0.1.1

8069 , reaperEmpty :: workload

8170 -- ^ An empty workload.

8271 --

8372 -- Default: empty list.

8473 --

85− -- @since 0.1.1

74+ -- Since 0.1.1

8675 }

8776

8877-- | Default @ReaperSettings@ value, biased towards having a list of work

8978-- items.

9079--

91−-- @since 0.1.1

80+-- Since 0.1.1

9281defaultReaperSettings :: ReaperSettings [item] item

9382defaultReaperSettings = ReaperSettings

9483 { reaperAction = \wl -> return (wl ++)

@@ -107,28 +96,24 @@ data Reaper workload item = Reaper {

10796 -- | Stopping the reaper thread if exists.

10897 -- The current workload is returned.

10998 , reaperStop :: IO workload

110− -- | Killing the reaper thread immediately if exists.

111− , reaperKill :: IO ()

11299 }

113100

114101-- | State of reaper.

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

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

103+ | Workload workload -- ^ The current jobs

117104

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

105+-- | Create a reaper addition function. This funciton can be used to add

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

120107-- for you automatically.

121108--

122−-- @since 0.1.1

109+-- Since 0.1.1

123110mkReaper :: ReaperSettings workload item -> IO (Reaper workload item)

124111mkReaper settings@ReaperSettings{..} = do

125112 stateRef <- newIORef NoReaper

126− tidRef <- newIORef Nothing

127113 return Reaper {

128− reaperAdd = add settings stateRef tidRef

114+ reaperAdd = update settings stateRef

129115 , reaperRead = readRef stateRef

130116 , reaperStop = stop stateRef

131− , reaperKill = kill tidRef

132117 }

133118 where

134119 readRef stateRef = do

@@ -140,46 +125,31 @@ mkReaper settings@ReaperSettings{..} = do

140125 case mx of

141126 NoReaper -> (NoReaper, reaperEmpty)

142127 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

148128

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

129+update :: ReaperSettings workload item -> IORef (State workload) -> item

130+ -> IO ()

131+update settings@ReaperSettings{..} stateRef item =

132+ mask_ $ join $ atomicModifyIORef' stateRef cons

156133 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 ())

134+ cons NoReaper = (Workload $ reaperCons item reaperEmpty

135+ ,spawn settings stateRef)

136+ cons (Workload wl) = (Workload $ reaperCons item wl

137+ ,return ())

161138

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

139+spawn :: ReaperSettings workload item -> IORef (State workload) -> IO ()

140+spawn settings stateRef = void . forkIO $ reaper settings stateRef

168141

169−reaper :: ReaperSettings workload item

170− -> IORef (State workload) -> IORef (Maybe ThreadId)

171− -> IO ()

172−reaper settings@ReaperSettings{..} stateRef tidRef = do

142+reaper :: ReaperSettings workload item -> IORef (State workload) -> IO ()

143+reaper settings@ReaperSettings{..} stateRef = do

173144 threadDelay reaperDelay

174145 -- Getting the current jobs. Push an empty job to the reference.

175146 wl <- atomicModifyIORef' stateRef swapWithEmpty

176147 -- Do the jobs. A function to merge the left jobs and

177148 -- new jobs is returned.

178− !merge <- reaperAction wl

149+ merge <- reaperAction wl

179150 -- Merging the left jobs and new jobs.

180151 -- If there is no jobs, this thread finishes.

181− next <- atomicModifyIORef' stateRef (check merge)

182− next

152+ join $ atomicModifyIORef' stateRef (check merge)

183153 where

184154 swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)"

185155 swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl)

@@ -187,9 +157,9 @@ reaper settings@ReaperSettings{..} stateRef tidRef = do

187157 check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"

188158 check merge (Workload wl)

189159 -- If there is no job, reaper is terminated.

190− | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing)

160+ | reaperNull wl' = (NoReaper, return ())

191161 -- If there are jobs, carry them out.

192− | otherwise = (Workload wl', reaper settings stateRef tidRef)

162+ | otherwise = (Workload wl', reaper settings stateRef)

193163 where

194164 wl' = merge wl

195165

@@ -198,83 +168,18 @@ reaper settings@ReaperSettings{..} stateRef tidRef = do

198168-- return either a new work item, or @Nothing@ if the work item is

199169-- expired.

200170--

201−-- @since 0.1.1

171+-- Since 0.1.1

202172mkListAction :: (item -> IO (Maybe item'))

203173 -> [item]

204174 -> IO ([item'] -> [item'])

205175mkListAction f =

206176 go id

207177 where

208− go !front [] = return front

209− go !front (x:xs) = do

178+ go front [] = return front

179+ go front (x:xs) = do

210180 my <- f x

211181 let front' =

212182 case my of

213183 Nothing -> front

214184 Just y -> front . (y:)

215185 go front' xs

216−

217−-- $example1

218−-- In this example code, we use a 'Data.Map.Strict.Map' to cache fibonacci numbers, and a 'Reaper' to prune the cache.

219−--

220−-- The @main@ function first creates a 'Reaper', with fields to initialize the

221−-- cache ('reaperEmpty'), add items to it ('reaperCons'), and prune it ('reaperAction').

222−-- The reaper will run every two seconds ('reaperDelay'), but will stop running while

223−-- 'reaperNull' is true.

224−--

225−-- @main@ then loops infinitely ('Control.Monad.forever'). Each second it calculates the fibonacci number

226−-- for a value between 30 and 34, first trying the cache ('reaperRead' and 'Data.Map.Strict.lookup'),

227−-- then falling back to manually calculating it (@fib@)

228−-- and updating the cache with the result ('reaperAdd')

229−--

230−-- @clean@ simply removes items cached for more than 10 seconds.

231−-- This function is where you would perform IO-related cleanup,

232−-- like killing threads or closing connections, if that was the purpose of your reaper.

233−--

234−-- @

235−-- module Main where

236−--

237−-- import "Data.Time" (UTCTime, getCurrentTime, diffUTCTime)

238−-- import "Control.Reaper"

239−-- import "Control.Concurrent" (threadDelay)

240−-- import "Data.Map.Strict" (Map)

241−-- import qualified "Data.Map.Strict" as Map

242−-- import "Control.Monad" (forever)

243−-- import "System.Random" (getStdRandom, randomR)

244−--

245−-- fib :: 'Int' -> 'Int'

246−-- fib 0 = 0

247−-- fib 1 = 1

248−-- fib n = fib (n-1) + fib (n-2)

249−--

250−-- type Cache = 'Data.Map.Strict.Map' 'Int' ('Int', 'Data.Time.Clock.UTCTime')

251−--

252−-- main :: IO ()

253−-- main = do

254−-- reaper <- 'mkReaper' 'defaultReaperSettings'

255−-- { 'reaperEmpty' = Map.'Data.Map.Strict.empty'

256−-- , 'reaperCons' = \\(k, v, time) workload -> Map.'Data.Map.Strict.insert' k (v, time) workload

257−-- , 'reaperAction' = clean

258−-- , 'reaperDelay' = 1000000 * 2 -- Clean every 2 seconds

259−-- , 'reaperNull' = Map.'Data.Map.Strict.null'

260−-- }

261−-- forever $ do

262−-- fibArg <- 'System.Random.getStdRandom' ('System.Random.randomR' (30,34))

263−-- cache <- 'reaperRead' reaper

264−-- let cachedResult = Map.'Data.Map.Strict.lookup' fibArg cache

265−-- case cachedResult of

266−-- 'Just' (fibResult, _createdAt) -> 'putStrLn' $ "Found in cache: `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult

267−-- 'Nothing' -> do

268−-- let fibResult = fib fibArg

269−-- 'putStrLn' $ "Calculating `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult

270−-- time <- 'Data.Time.Clock.getCurrentTime'

271−-- ('reaperAdd' reaper) (fibArg, fibResult, time)

272−-- 'threadDelay' 1000000 -- 1 second

273−--

274−-- -- Remove items > 10 seconds old

275−-- clean :: Cache -> IO (Cache -> Cache)

276−-- clean oldMap = do

277−-- currentTime <- 'Data.Time.Clock.getCurrentTime'

278−-- let pruned = Map.'Data.Map.Strict.filter' (\\(_, createdAt) -> currentTime \`diffUTCTime\` createdAt < 10.0) oldMap

279−-- return (\\newData -> Map.'Data.Map.Strict.union' pruned newData)

280−-- @

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

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

11name: auto-update

2−version: 0.1.6

2+version: 0.1.2.1

33synopsis: Efficiently run periodic, on-demand actions

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

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

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

1717 ghc-options: -Wall

1818 exposed-modules: Control.AutoUpdate

1919 Control.Debounce

20− Control.Debounce.Internal

2120 Control.Reaper

2221 other-modules: Control.AutoUpdate.Util

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

2423 default-language: Haskell2010

25− if impl(ghc >= 8)

26− default-extensions: Strict StrictData

2724

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

2926

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

27+-- test-suite spec

28+-- main-is: Spec.hs

29+-- other-modules: Control.AutoUpdateSpec

30+-- Control.ReaperSpec

31+-- hs-source-dirs: test

32+-- type: exitcode-stdio-1.0

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

34+-- default-language: Haskell2010

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

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

11module Control.AutoUpdateSpec (spec) where

22

3−import Control.AutoUpdate

4−import Control.Concurrent (threadDelay)

5−import Control.Monad (replicateM_, forM_)

6−import Data.IORef

73import Test.Hspec

84import Test.Hspec.QuickCheck

5+import Data.IORef

6+import Control.Concurrent (threadDelay)

7+import Control.Monad (replicateM_, forM_)

8+import Control.AutoUpdate

99

1010spec :: 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− -- }

11+spec = do

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

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

14+ ref <- newIORef 0

15+ next <- mkAutoUpdate defaultUpdateSettings

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

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

18+ , updateSpawnThreshold = st

19+ , updateFreq = 10000

20+ }

2221

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

24− -- j <- next

25− -- j `shouldBe` i

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

23+ j <- next

24+ j `shouldBe` i

2625

27− -- replicateM_ 50 $ do

28− -- i <- next

29− -- i `shouldBe` st + 2

26+ replicateM_ 50 $ do

27+ i <- next

28+ i `shouldBe` st + 2

3029

31− -- threadDelay 60000

32− -- last1 <- readIORef ref

33− -- threadDelay 20000

34− -- last2 <- readIORef ref

35− -- last2 `shouldBe` last1

30+ threadDelay 60000

31+ last1 <- readIORef ref

32+ threadDelay 20000

33+ last2 <- readIORef ref

34+ last2 `shouldBe` last1

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

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

1−{-# LANGUAGE ScopedTypeVariables #-}

2−module Control.DebounceSpec (spec) where

3−

4−import Control.Concurrent

5−import Control.Debounce

6−import qualified Control.Debounce.Internal as DI

7−import Control.Monad

8−import Control.Monad.Catch

9−import Control.Retry

10−import Data.IORef

11−import Test.HUnit.Lang

12−import Test.Hspec

13−

14−spec :: Spec

15−spec = describe "mkDebounce" $ do

16− describe "Leading edge" $ do

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

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

19−

20− debounced

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

22−

23− returnFromWait

24− pause

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

26−

27− -- Try another round

28− debounced

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

30−

31− returnFromWait

32− pause

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

34−

35− it "works for multiple events" $ do

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

37−

38− debounced

39− waitForBatonToBeTaken baton

40− debounced

41− pause

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

43−

44− returnFromWait

45− pause

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

47−

48− describe "Trailing edge" $ do

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

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

51−

52− debounced

53− pause

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

55−

56− returnFromWait

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

58−

59− -- Try another round

60− debounced

61− pause

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

63−

64− returnFromWait

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

66−

67− it "works for multiple events" $ do

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

69−

70− debounced

71− waitForBatonToBeTaken baton

72− debounced

73− pause

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

75−

76− returnFromWait

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

78−

79−

80−-- | Make a controllable delay function

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

82−getWaitAction = do

83− waitVar <- newEmptyMVar

84− let waitAction _ = takeMVar waitVar

85− let returnFromWait = putMVar waitVar ()

86− return (waitAction, returnFromWait)

87−

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

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

90−getDebounce edge = do

91− ref :: IORef Int <- newIORef 0

92− let action = modifyIORef ref (+ 1)

93−

94− (waitAction, returnFromWait) <- getWaitAction

95−

96− baton <- newEmptyMVar

97−

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

99− debounceFreq = 5000000 -- unused

100− , debounceAction = action

101− , debounceEdge = edge

102− }

103−

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

105−

106−-- | Pause briefly (100ms)

107−pause :: IO ()

108−pause = threadDelay 100000

109−

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

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

112−

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

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

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

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

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

118−

119−main :: IO ()

120−main = hspec spec

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

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

11module Control.ReaperSpec (spec) where

22

3−import Control.Concurrent

43import Control.Reaper

5−import Data.IORef

4+import Control.Concurrent

65import Test.Hspec

76import Test.Hspec.QuickCheck

7+import Data.IORef

88

9+type Item = (Int, IORef Int)

910

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

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

12+ modifyIORef ref succ

13+ return $ if i > 1

14+ then Just (pred i, ref)

15+ else Nothing

2416

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 ()

17+spec :: Spec

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

19+ reaper <- mkReaper defaultReaperSettings

20+ { reaperAction = action

21+ , reaperDelay = 1000

22+ }

3223

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

24+ let mkTestCase i = do

25+ ref <- newIORef 0

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

27+ reaperAdd reaper (expected, ref)

28+ return (expected, ref)

29+ testCases <- mapM mkTestCase is

3430

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

36−-- modifyIORef ref succ

37−-- return $ if i > 1

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

39−-- else Nothing

31+ let test (expected, ref) = do

32+ actual <- readIORef ref

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

34+ threadDelay 100000

35+ mapM_ test testCases

36+ [] <- reaperRead reaper

37+ return ()

mime-types/ChangeLog.md−12

@@ -1,15 +1,3 @@

1−## 0.1.0.9

2−

3−* Add mjs mime type

4−

5−## 0.1.0.8

6−

7−* Add wasm mime type

8−

9−## 0.1.0.7

10−

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

12−

131## 0.1.0.6

142

153* Add woff2 mime type [#350](https://github.com/yesodweb/wai/pull/350)

mime-types/Network/Mime.hs−7

@@ -468,11 +468,6 @@ defaultMimeMap = Map.fromAscList [

468468 , ("lbd", "application/vnd.llamagraphics.life-balance.desktop")

469469 , ("lbe", "application/vnd.llamagraphics.life-balance.exchange+xml")

470470 , ("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−

476471 , ("lha", "application/x-lzh-compressed")

477472 , ("link66", "application/vnd.route66.link66+xml")

478473 , ("list", "text/plain")

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

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

532527 , ("mj2", "video/mj2")

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

11name: mime-types

2−version: 0.1.0.9

2+version: 0.1.0.6

33synopsis: Basic mime-type handling types and functions

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

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

sources.txtnew file+11

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

1+./wai

2+./wai-extra

3+./warp

4+./warp-tls

5+./wai-app-static

6+./wai-handler-fastcgi

7+./wai-handler-launch

8+./wai-websockets

9+./wai-conduit

10+./mime-types

11+./auto-update

stack-lts-11.yamldeleted−27

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

1−resolver: lts-11.21

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−extra-deps:

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

18−- http2-2.0.0

19−- network-byte-order-0.1.1.0

20−- tls-1.5.3

21−- tls-session-manager-0.0.4

22−- x509-1.7.5

23−nix:

24− enable: false

25− packages:

26− - fcgi

27− - zlib

stack-lts-12.yamldeleted−26

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

1−resolver: lts-12.6

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−nix:

17− enable: false

18− packages:

19− - fcgi

20− - zlib

21−extra-deps:

22−- http2-2.0.0

23−- network-byte-order-0.1.1.0

24−- tls-1.5.3

25−- tls-session-manager-0.0.4

26−- x509-1.7.5

stack-nightly.yamldeleted−20

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

1−resolver: nightly-2020-01-08

2−packages:

3−- ./auto-update

4−- ./mime-types

5−- ./wai

6−- ./wai-extra

7−- ./warp

8−- ./warp-tls

9−- ./wai-app-static

10−- ./wai-websockets

11−- ./wai-conduit

12−- ./time-manager

13−flags:

14− wai-extra:

15− build-example: true

16−nix:

17− enable: false

18− packages:

19− - fcgi

20− - zlib

stack.yaml+7−16

@@ -1,25 +1,16 @@

1−resolver: lts-14.22

1+resolver: lts-2.9

22packages:

3−- ./auto-update

4−- ./mime-types

53- ./wai

64- ./wai-extra

75- ./warp

86- ./warp-tls

97- ./wai-app-static

8+- ./wai-handler-fastcgi

9+- ./wai-handler-launch

1010- ./wai-websockets

1111- ./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

12+- ./mime-types

13+- ./auto-update

2114extra-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

15+- fast-logger-2.3.1

16+- wai-logger-2.2.4

time-manager/time-manager.cabaldeleted−19

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

1−Name: time-manager

2−Version: 0.0.0

3−Synopsis: Scalable timer

4−License: MIT

5−License-file: LICENSE

6−Author: Michael Snoyman and Kazu Yamamoto

7−Maintainer: kazu@iij.ad.jp

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

9−Category: System

10−Build-Type: Simple

11−Cabal-Version: >=1.8

12−Stability: Stable

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

14−

15−Library

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

17− , auto-update

18− Exposed-modules: System.TimeManager

19− Ghc-Options: -Wall

wai-app-static/ChangeLog.md−53

@@ -1,56 +1,3 @@

1−# wai-app-static changelog

2−

3−## 3.1.7.1

4−

5−* Update the test suite too

6−

7−## 3.1.7

8−

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

10−

11−## 3.1.6.3

12−

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

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

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

16−

17−## 3.1.6.2

18−

19−* Drop dependency on blaze-builder

20−

21−## 3.1.6.1

22−

23−* Add `<>` import

24−

25−## 3.1.6

26−

27−* Make ssAddTrailingSlash work in combination with ssIndices [#569](https://github.com/yesodweb/wai/pull/569)

28−* Make ssIndices work with ssLookupFile and trailing slashes [#570](https://github.com/yesodweb/wai/pull/570)

29−

30−## 3.1.5

31−

32−* Switch to cryponite

33−

34−## 3.1.4.1

35−

36−* Support wai/warp 3.2

37−

38−## 3.1.4

39−

40−* Reinstate redirectToIndex

41−

42−## 3.1.3

43−

44−* Add 404 handler [#467](https://github.com/yesodweb/wai/pull/467)

45−

46−## 3.1.2

47−

48−* Honor ssIndices when used with defaultWebAppSettings [#460](https://github.com/yesodweb/wai/pull/460)

49−

50−## 3.1.1

51−

52−* Make adding a trailing slash optional [#327](https://github.com/yesodweb/wai/issues/327) [yesod#988](https://github.com/yesodweb/yesod/issues/988)

53−

541## 3.1.0

552

563* Drop system-filepath

wai-app-static/Network/Wai/Application/Static.hs+65−82

@@ -21,8 +21,6 @@ module Network.Wai.Application.Static

2121 , ssIndices

2222 , ssMaxAge

2323 , ssRedirectToIndex

24− , ssAddTrailingSlash

25− , ss404Handler

2624 ) where

2725

2826import Prelude hiding (FilePath)

@@ -34,15 +32,16 @@ import qualified Data.ByteString.Lazy as L

3432import Data.ByteString.Lazy.Char8 ()

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

3634

37−import Data.ByteString.Builder (toLazyByteString)

35+import Blaze.ByteString.Builder (toByteString)

3836

3937import Data.FileEmbed (embedFile)

4038

4139import Data.Text (Text)

4240import qualified Data.Text as T

43−import qualified Data.Text.Encoding as TE

4441

42+import Data.Either (rights)

4543import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)

44+import Data.Monoid (First (First, getFirst), mconcat)

4645

4746import WaiAppStatic.Types

4847import Util

@@ -74,27 +73,55 @@ filterButLast f (x:xs)

7473

7574-- | Serve an appropriate response for a folder request.

7675serveFolder :: 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 '/'

76+serveFolder ss@StaticSettings {..} pieces req folder@Folder {..} =

77+ -- first check if there is an index file in this folder

78+ case getFirst $ mconcat $ map (findIndex $ rights folderContents) ssIndices of

79+ Just index ->

80+ let pieces' = setLast pieces index in

81+ case () of

82+ () | ssRedirectToIndex -> return $ Redirect pieces' Nothing

83+ | Just path <- addTrailingSlash req ->

84+ return $ RawRedirect path

85+ | otherwise ->

86+ -- start the checking process over, with a new set

87+ checkPieces ss pieces' req

88+ Nothing ->

89+ case ssListing of

90+ Just _ | Just path <- addTrailingSlash req ->

91+ return $ RawRedirect path

92+ Just listing -> do

93+ -- directory listings turned on, display it

94+ builder <- listing pieces folder

95+ return $ WaiResponse $ W.responseBuilder H.status200

96+ [ ("Content-Type", "text/html; charset=utf-8")

97+ ] builder

98+ Nothing -> return $ WaiResponse $ W.responseLBS H.status403

99+ [ ("Content-Type", "text/plain")

100+ ] "Directory listings disabled"

96101 where

97− rp = W.rawPathInfo req

102+ setLast :: Pieces -> Piece -> Pieces

103+ setLast [] x = [x]

104+ setLast [t] x

105+ | fromPiece t == "" = [x]

106+ setLast (a:b) x = a : setLast b x

107+

108+ addTrailingSlash :: W.Request -> Maybe ByteString

109+ addTrailingSlash req

110+ | S8.null rp = Just "/"

111+ | S8.last rp == '/' = Nothing

112+ | otherwise = Just $ S8.snoc rp '/'

113+ where

114+ rp = W.rawPathInfo req

115+

116+ noTrailingSlash :: Pieces -> Bool

117+ noTrailingSlash [] = False

118+ noTrailingSlash [x] = fromPiece x /= ""

119+ noTrailingSlash (_:xs) = noTrailingSlash xs

120+

121+ findIndex :: [File] -> Piece -> First Piece

122+ findIndex files index

123+ | index `elem` map fileName files = First $ Just index

124+ | otherwise = First Nothing

98125

99126checkPieces :: StaticSettings

100127 -> Pieces -- ^ parsed request

@@ -106,51 +133,11 @@ checkPieces _ pieces _ | any (T.null . fromPiece) $ safeInit pieces =

106133 return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing

107134

108135checkPieces ss@StaticSettings {..} pieces req = do

109− res <- lookupResult

136+ res <- ssLookupFile pieces

110137 case res of

111− Left location -> return $ RawRedirect location

112− Right LRNotFound -> return NotFound

113− Right (LRFile file) -> serveFile ss req file

114− Right (LRFolder folder) -> serveFolder ss pieces req folder

115− where

116− lookupResult :: IO (Either ByteString LookupResult)

117− lookupResult = do

118− nonIndexResult <- ssLookupFile pieces

119− case nonIndexResult of

120− LRFile{} -> return $ Right nonIndexResult

121− _ -> do

122− eIndexResult <- lookupIndices (map (\ index -> dropLastIfNull pieces ++ [index]) ssIndices)

123− return $ case eIndexResult of

124− Left redirect -> Left redirect

125− Right indexResult -> case indexResult of

126− LRNotFound -> Right nonIndexResult

127− LRFile file | ssRedirectToIndex ->

128− let relPath =

129− case reverse pieces of

130− -- Served at root

131− [] -> fromPiece $ fileName file

132− lastSegment:_ ->

133− case fromPiece lastSegment of

134− -- Ends with a trailing slash

135− "" -> fromPiece $ fileName file

136− -- Lacks a trailing slash

137− lastSegment' -> T.concat

138− [ lastSegment'

139− , "/"

140− , fromPiece $ fileName file

141− ]

142− in Left $ TE.encodeUtf8 relPath

143− _ -> Right indexResult

144−

145− lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult)

146− lookupIndices (x : xs) = do

147− res <- ssLookupFile x

148− case res of

149− LRNotFound -> lookupIndices xs

150− _ -> return $ case (ssAddTrailingSlash, addTrailingSlash req) of

151− (True, Just redirect) -> Left redirect

152− _ -> Right res

153− lookupIndices [] = return $ Right LRNotFound

138+ LRNotFound -> return NotFound

139+ LRFile file -> serveFile ss req file

140+ LRFolder folder -> serveFolder ss pieces req folder

154141

155142serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse

156143serveFile StaticSettings {..} req file

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

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

165152 -- with an ETag header.

166153 --

167− -- RFC7232 (HTTP 1.1):

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

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

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

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

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

173− -- > If-None-Match.

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

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

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

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

158+ -- new file being sent anyway.

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

175160

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

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

245230 response :: StaticResponse -> IO W.ResponseReceived

246231 response (FileResponse file ch) = do

247232 mimetype <- ssGetMimeType ss file

248− -- let filesize = fileGetSize file

233+ let filesize = fileGetSize file

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

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

251236 -- range requests into account

@@ -264,25 +249,23 @@ staticAppPieces ss rawPieces req sendResponse = liftIO $ do

264249 ] lbs

265250

266251 response (Redirect pieces' mHash) = do

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

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

268253 let qString = case mHash of

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

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

271256

272− sendResponse $ W.responseLBS H.status302

257+ sendResponse $ W.responseLBS H.status301

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

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

275260 ] "Redirect"

276261

277262 response (RawRedirect path) =

278− sendResponse $ W.responseLBS H.status302

263+ sendResponse $ W.responseLBS H.status301

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

280265 , ("Location", path)

281266 ] "Redirect"

282267

283− response NotFound = case (ss404Handler ss) of

284− Just app -> app req sendResponse

285− Nothing -> sendResponse $ W.responseLBS H.status404

268+ response NotFound = sendResponse $ W.responseLBS H.status404

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

287270 ] "File not found"

288271

wai-app-static/Util.hs+1−8

@@ -1,10 +1,9 @@

1−{-# LANGUAGE OverloadedStrings, ViewPatterns #-}

1+{-# LANGUAGE OverloadedStrings #-}

22module Util

33 ( relativeDirFromPieces

44 , defaultMkRedirect

55 , replace

66 , remove

7− , dropLastIfNull

87 ) where

98

109import WaiAppStatic.Types

@@ -37,9 +36,3 @@ defaultMkRedirect pieces newPath

3736 | otherwise = relDir `S8.append` S8.tail newPath

3837 where

3938 relDir = TE.encodeUtf8 (relativeDirFromPieces pieces)

40−

41−dropLastIfNull :: [Piece] -> [Piece]

42−dropLastIfNull pieces = case pieces of

43− [fromPiece -> ""] -> []

44− (a : r) -> a : dropLastIfNull r

45− [] -> []

wai-app-static/WaiAppStatic/CmdLine.hs+6−15

@@ -8,7 +8,7 @@ module WaiAppStatic.CmdLine

88import Network.Wai (Middleware)

99import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)

1010import Network.Wai.Handler.Warp

11− ( runSettings, defaultSettings, setHost, setPort

11+ ( runSettings, defaultSettings, settingsHost, settingsPort

1212 )

1313import Options.Applicative

1414import Text.Printf (printf)

@@ -25,7 +25,6 @@ import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType)

2525import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)

2626import Data.Maybe (mapMaybe)

2727import Control.Arrow (second)

28−import Data.Monoid ((<>))

2928

3029data Args = Args

3130 { docroot :: FilePath

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

3938 }

4039

4140#if MIN_VERSION_optparse_applicative(0, 10, 0)

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

4341option' = option auto

4442#else

4543option' = option

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

9492-- Since 2.0.1

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

9694runCommandLine middleware = do

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

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

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

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

10098 docroot' <- canonicalizePath docroot

@@ -102,17 +100,10 @@ runCommandLine middleware = do

102100 let middle = gzip def { gzipFiles = GzipCompress }

103101 . (if verbose then logStdout else id)

104102 . (middleware args)

105− runSettings

106− ( setPort port

107− $ setHost (fromString host)

108− defaultSettings

109− )

110− $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)

103+ runSettings defaultSettings

104+ { settingsPort = port

105+ , settingsHost = fromString host

106+ } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)

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

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

113109 }

114− where

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

116− helperOption =

117− abortOption ShowHelpText $

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

wai-app-static/WaiAppStatic/Listing.hs+14−28

@@ -22,7 +22,7 @@ import qualified Text.Blaze.Html.Renderer.Utf8 as HU

2222

2323-- | Provides a default directory listing, suitable for most apps.

2424--

25−-- Code below taken from Happstack: <https://github.com/Happstack/happstack-server/blob/87e6c01a65c687d06c61345430a112fc9a444a95/src/Happstack/Server/FileServe/BuildingBlocks.hs>

25+-- Code below taken from Happstack: <http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs>

2626defaultListing :: Listing

2727defaultListing pieces (Folder contents) = do

2828 let isTop = null pieces || map Just pieces == [toPiece ""]

@@ -49,12 +49,8 @@ defaultListing pieces (Folder contents) = do

4949 , "a { text-decoration: none }"

5050 ]

5151 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''

52+ H.h1 $ showFolder' $ filter (not . T.null . fromPiece) pieces

53+ renderDirectoryContentsTable haskellSrc folderSrc fps''

5854 where

5955 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]

6056 folderSrc = image "folder"

@@ -63,20 +59,17 @@ defaultListing pieces (Folder contents) = do

6359 showName x = x

6460

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

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

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

62+ showFolder' :: Pieces -> H.Html

63+ showFolder' pieces = showFolder (unsafeToPiece "root" : pieces)

6864

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

65+ showFolder :: Pieces -> H.Html

66+ showFolder [] = "/" -- won't happen

67+ showFolder [x] = H.toHtml $ showName $ fromPiece x

68+ showFolder (x:xs) = do

69+ let href = concat $ replicate (length xs) "../" :: String

7770 H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x

7871 " / " :: H.Html

79− showFolder hasTrailingSlash xs

72+ showFolder xs

8073

8174-- | a function to generate an HTML table showing the contents of a directory on the disk

8275--

@@ -86,12 +79,11 @@ defaultListing pieces (Folder contents) = do

8679-- a new page template to wrap around this HTML.

8780--

8881-- see also: 'getMetaData', 'renderDirectoryContents'

89−renderDirectoryContentsTable :: [T.Text] -- ^ requested path info

90− -> String

82+renderDirectoryContentsTable :: String

9183 -> String

9284 -> [Either FolderName File]

9385 -> H.Html

94−renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps =

86+renderDirectoryContentsTable haskellSrc folderSrc fps =

9587 H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc)

9688 H.th "Name"

9789 H.th "Modified"

@@ -118,13 +110,7 @@ renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps =

118110 (fromPiece -> "") -> unsafeToPiece ".."

119111 x -> x

120112 let isFile = either (const False) (const True) md

121− href = addCurrentDir $ fromPiece name

122− addCurrentDir x =

123− case reverse pathInfo' of

124− "":_ -> x -- has a trailing slash

125− [] -> x -- at the root

126− currentDir:_ -> T.concat [currentDir, "/", x]

127− H.td (H.a ! A.href (H.toValue href) $ H.toHtml $ fromPiece name)

113+ H.td (H.a ! A.href (H.toValue $ fromPiece name `T.append` if isFile then "" else "/") $ H.toHtml $ fromPiece name)

128114 H.td ! A.class_ "date" $ H.toHtml $

129115 case md of

130116 Right File { fileGetModified = Just t } ->

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

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

88import Data.ByteString (ByteString)

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

1010import Data.List

11−import Data.ByteString.Builder (byteString)

11+import Blaze.ByteString.Builder (fromByteString)

1212import qualified Network.Wai as W

1313import qualified Data.Map as Map

1414import Data.Function (on)

@@ -16,7 +16,8 @@ import qualified Data.Text as T

1616import Data.Ord

1717import qualified Data.ByteString as S

1818import Crypto.Hash (hash, MD5, Digest)

19−import Data.ByteArray.Encoding

19+import Data.Byteable (toBytes)

20+import qualified Data.ByteString.Base64 as B64

2021import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)

2122import System.FilePath (isPathSeparator)

2223

@@ -49,8 +50,8 @@ embeddedLookup root pieces =

4950toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File

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

5152toEntry (name, EEFile bs) = Right File

52− { fileGetSize = fromIntegral $ S.length bs

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

53+ { fileGetSize = S.length bs

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

5455 , fileName = name

5556 , fileGetHash = return $ Just $ runHash bs

5657 , fileGetModified = Nothing

@@ -86,12 +87,12 @@ toEmbedded fps =

8687

8788bsToFile :: Piece -> ByteString -> File

8889bsToFile name bs = File

89− { fileGetSize = fromIntegral $ S.length bs

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

90+ { fileGetSize = S.length bs

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

9192 , fileName = name

9293 , fileGetHash = return $ Just $ runHash bs

9394 , fileGetModified = Nothing

9495 }

9596

9697runHash :: ByteString -> ByteString

97−runHash = convertToBase Base64 . (hash :: S.ByteString -> Digest MD5)

98+runHash = B64.encode . toBytes . (hash :: S.ByteString -> Digest MD5)

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

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

55 , mkSettings

66) where

77

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

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

99import Codec.Compression.GZip (compress)

10+import Control.Applicative

1011import Data.ByteString.Unsafe (unsafePackAddressLen)

1112import Data.Either (lefts, rights)

1213import GHC.Exts (Int(..))

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

129130 let h' = if embCompressed entry

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

131132 else h

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

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

133134

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

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

wai-app-static/WaiAppStatic/Storage/Filesystem.hs+7−13

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

11{-# LANGUAGE ScopedTypeVariables #-}

22{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE BangPatterns #-}

43-- | Access files on the filesystem.

54module WaiAppStatic.Storage.Filesystem

65 ( -- * Types

@@ -13,7 +12,6 @@ module WaiAppStatic.Storage.Filesystem

1312

1413import WaiAppStatic.Types

1514import System.FilePath ((</>))

16−import System.IO (withBinaryFile, IOMode(..))

1715import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)

1816import Data.List (foldl')

1917import Control.Monad (forM)

@@ -25,9 +23,10 @@ import WaiAppStatic.Listing

2523import Network.Mime

2624import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRegularFile)

2725import Data.Maybe (catMaybes)

28−import Data.ByteArray.Encoding

29−import Crypto.Hash (hashlazy, MD5, Digest)

30−import qualified Data.ByteString.Lazy as BL (hGetContents)

26+import qualified Crypto.Hash.Conduit (hashFile)

27+import Data.Byteable (toBytes)

28+import Crypto.Hash (MD5, Digest)

29+import qualified Data.ByteString.Base64 as B64

3130import qualified Data.Text as T

3231

3332-- | Construct a new path from a root and some @Pieces@.

@@ -47,8 +46,6 @@ defaultWebAppSettings root = StaticSettings

4746 , ssIndices = []

4847 , ssRedirectToIndex = False

4948 , ssUseHash = True

50− , ssAddTrailingSlash = False

51− , ss404Handler = Nothing

5249 }

5350

5451-- | Settings optimized for a file server. More conservative caching will be

@@ -64,8 +61,6 @@ defaultFileServerSettings root = StaticSettings

6461 , ssIndices = map unsafeToPiece ["index.html", "index.htm"]

6562 , ssRedirectToIndex = False

6663 , ssUseHash = False

67− , ssAddTrailingSlash = False

68− , ss404Handler = Nothing

6964 }

7065

7166-- | Same as @defaultWebAppSettings@, but additionally uses a specialized

@@ -120,10 +115,9 @@ webAppLookup hashFunc prefix pieces =

120115-- | MD5 hash and base64-encode the file contents. Does not check if the file

121116-- exists.

122117hashFile :: 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

118+hashFile fp = do

119+ h <- Crypto.Hash.Conduit.hashFile fp

120+ return $ B64.encode $ toBytes (h :: Digest MD5)

127121

128122hashFileIfExists :: ETagLookup

129123hashFileIfExists fp = do

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

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

1+{-# LANGUAGE OverloadedStrings #-}

12module WaiAppStatic.Types

23 ( -- * Pieces

34 Piece

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

2425import Data.ByteString (ByteString)

2526import System.Posix.Types (EpochTime)

2627import qualified Data.Text as T

27−import Data.ByteString.Builder (Builder)

28+import Blaze.ByteString.Builder (Builder)

2829import Network.Mime (MimeType)

2930

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

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

5960toPieces = mapM toPiece

6061

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

62−--

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

6463type Pieces = [Piece]

6564

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

@@ -80,7 +79,7 @@ data Folder = Folder

8079-- | Information on an individual file.

8180data File = File

8281 { -- | Size of file in bytes

83− fileGetSize :: Integer

82+ fileGetSize :: Int

8483 -- | How to construct a WAI response for this file. Some files are stored

8584 -- on the filesystem and can use @ResponseFile@, while others are stored

8685 -- in memory and should use @ResponseBuilder@.

@@ -142,12 +141,4 @@ data StaticSettings = StaticSettings

142141

143142 -- | Prefer usage of etag caching to last-modified caching.

144143 , 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

153144 }

wai-app-static/test/EmbeddedTestEntries.hs−10

@@ -42,14 +42,4 @@ mkEntries = return

4242 , EmbeddableEntry "e6.txt"

4343 "text/plain"

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

5545 ]

wai-app-static/test/WaiAppEmbeddedTest.hs+5−21

@@ -8,15 +8,16 @@ import Network.Wai.Application.Static (staticApp)

88import Network.Wai.Test

99import Test.Hspec

1010import WaiAppStatic.Storage.Embedded

11−import WaiAppStatic.Types

11+

12+embApp :: Application

13+embApp = staticApp $(mkSettings mkEntries)

1214

1315defRequest :: Request

1416defRequest = defaultRequest

1517

1618embSpec :: Spec

1719embSpec = do

18− let embedSettings settings = flip runSession (staticApp settings)

19− let embed = embedSettings $(mkSettings mkEntries)

20+ let embed = flip runSession embApp

2021 describe "embedded, compressed entry" $ do

2122 it "served correctly" $ embed $ do

2223 req <- request (setRawPathInfo defRequest "e1.txt")

@@ -32,24 +33,6 @@ embSpec = do

3233 { requestHeaders = [("If-None-Match", "Etag 1")] }

3334 assertStatus 304 req

3435

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−

5336 describe "embedded, uncompressed entry" $ do

5437 it "too short" $ embed $ do

5538 req <- request (setRawPathInfo defRequest "e2.txt")

@@ -92,3 +75,4 @@ embSpec = do

9275 assertNoHeader "Content-Encoding" req

9376 assertNoHeader "ETag" req

9477 assertBody (body 1000 'W') req

78+

wai-app-static/test/WaiAppStaticTest.hs+10−51

@@ -2,15 +2,11 @@

22module WaiAppStaticTest (spec) where

33

44import Network.Wai.Application.Static

5−import WaiAppStatic.Types

65

76import Test.Hspec

8−import Test.Mockery.Directory

97import qualified Data.ByteString.Char8 as S8

108-- import qualified Data.ByteString.Lazy.Char8 as L8

119import System.PosixCompat.Files (getFileStatus, modificationTime)

12−import System.FilePath

13−import System.IO.Temp

1410

1511import Network.HTTP.Date

1612import Network.HTTP.Types (status500)

@@ -29,10 +25,7 @@ defRequest = defaultRequest

2925spec :: Spec

3026spec = do

3127 let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"

32− let fileServerAppWithSettings settings = flip runSession $ staticApp settings

33− let fileServerApp = fileServerAppWithSettings (defaultFileServerSettings "test")

34− { ssAddTrailingSlash = True

35− }

28+ let fileServerApp = flip runSession $ staticApp $ defaultFileServerSettings "test"

3629

3730 let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="

3831 let file = "a/b"

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

5750 assertStatus 200 =<<

5851 request (setRawPathInfo defRequest path)

5952

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

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

6154 assertStatus 404 =<<

6255 request (setRawPathInfo defRequest "doesNotExist")

6356

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

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

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

66− assertStatus 302 req

59+ assertStatus 301 req

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

6861

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

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

7164 }

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

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

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

7467 req <- request (setRawPathInfo defRequest path)

75− assertStatus 302 req

68+ assertStatus 301 req

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

7770

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

@@ -131,54 +124,20 @@ spec = do

131124 assertStatus 304 req

132125 assertNoHeader "Cache-Control" req

133126

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

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

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

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

137− assertStatus 302 req

130+ assertStatus 301 req

138131 assertHeader "Location" "/a/" req

139132

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−

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

151134 case pathInfo req of

152135 "subPath":rest ->

153136 let req' = req { pathInfo = rest }

154− in (staticApp (defaultFileServerSettings "test")

155− { ssAddTrailingSlash = True

156− }) req' send

137+ in (staticApp $ defaultFileServerSettings "test") req' send

157138 _ -> send $ responseLBS status500 []

158139 "urlMapApp: only works at subPath"

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

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

161− assertStatus 302 req

142+ assertStatus 301 req

162143 assertHeader "Location" "/subPath/" req

163−

164− context "with defaultWebAppSettings" $ do

165− it "ssIndices works" $ do

166− withSystemTempDirectory "wai-app-static-test" $ \ dir -> do

167− writeFile (dir </> "index.html") "foo"

168− let testSettings = (defaultWebAppSettings dir) {

169− ssIndices = [unsafeToPiece "index.html"]

170− }

171− fileServerAppWithSettings testSettings $ do

172− resp <- request (setRawPathInfo defRequest "/")

173− assertStatus 200 resp

174− assertBody "foo" resp

175−

176− context "with defaultFileServerSettings" $ do

177− it "prefers ssIndices over ssListing" $ do

178− withSystemTempDirectory "wai-app-static-test" $ \ dir -> do

179− writeFile (dir </> "index.html") "foo"

180− let testSettings = defaultFileServerSettings dir

181− fileServerAppWithSettings testSettings $ do

182− resp <- request (setRawPathInfo defRequest "/")

183− assertStatus 200 resp

184− assertBody "foo" resp

wai-app-static/wai-app-static.cabal+12−11

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

11name: wai-app-static

2−version: 3.1.7.1

2+version: 3.1.0

33license: MIT

44license-file: LICENSE

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

@@ -26,8 +26,8 @@ Flag print

2626

2727library

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

29− , wai >= 3.0 && < 3.3

30− , bytestring >= 0.10.4

29+ , wai >= 3.0 && < 3.1

30+ , bytestring >= 0.9.1.4

3131 , http-types >= 0.7

3232 , transformers >= 0.2.2

3333 , unix-compat >= 0.2

@@ -37,8 +37,10 @@ library

3737 , old-locale >= 1.0.0.2

3838 , file-embed >= 0.0.3.1

3939 , text >= 0.7

40− , cryptonite >= 0.6

41− , memory >= 0.7

40+ , blaze-builder >= 0.2.1.4

41+ , base64-bytestring >= 0.1

42+ , byteable

43+ , cryptohash >= 0.11

4244 , http-date

4345 , blaze-html >= 0.5

4446 , blaze-markup >= 0.5.1

@@ -49,7 +51,9 @@ library

4951 , filepath

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

5153 , optparse-applicative >= 0.7

52− , warp >= 3.0.11 && < 3.4

54+ , warp >= 3.0.11 && < 3.1

55+ -- Used exclusively for hashFile function

56+ , cryptohash-conduit

5357

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

5559 WaiAppStatic.Storage.Filesystem

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

7377 , wai-app-static

7478 , directory >= 1.0

7579 , containers >= 0.2

76− , bytestring >= 0.10.4

80+ , bytestring >= 0.9.1.4

7781 , text >= 0.7

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

7983

@@ -98,11 +102,8 @@ test-suite runtests

98102 , transformers

99103 , mime-types

100104 , zlib

101− , filepath

102− , temporary

103− , mockery

104105 -- , containers

105− ghc-options: -Wall

106+ ghc-options: -Wall

106107

107108source-repository head

108109 type: git

wai-conduit/ChangeLog.md+1−7

@@ -1,7 +1 @@

1−## 3.0.0.4

2−

3−* Drop dependency on blaze-builder

4−

5−## 3.0.0.3

6−

7−* Support wai 3.2

1+No changes logged yet.

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

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

1616import qualified Data.ByteString as S

1717import Control.Monad (unless)

1818import Network.HTTP.Types

19−import Data.ByteString.Builder (Builder)

19+import Blaze.ByteString.Builder (Builder)

20+import Data.IORef

2021import qualified Data.Conduit.List as CL

2122

2223-- | Stream the request body.

2324--

2425-- Since 3.0.0

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

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

2627sourceRequestBody req =

2728 loop

2829 where

29− go = liftIO (getRequestBodyChunk req)

30+ go = liftIO (requestBody req)

3031

3132 loop = do

3233 bs <- go

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

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

3839--

3940-- Since 3.0.0

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

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

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

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

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

4344 case mbuilder of

4445 Chunk b -> send b

4546 Flush -> flush)

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

4950--

5051-- Since 3.0.0

5152responseRawSource :: (MonadIO m, MonadIO n)

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

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

5354 -> Response

5455 -> Response

5556responseRawSource app =

wai-conduit/example/Main.hsdeleted−19

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

1−#!/usr/bin/env stack

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

3−import Network.Wai

4−import Network.Wai.Handler.Warp

5−import Network.Wai.Conduit

6−import Network.HTTP.Types

7−import Conduit

8−import Data.ByteString.Builder (byteString)

9−import Control.Monad.Trans.Resource

10−

11−main :: IO ()

12−main = run 3000 app

13−

14−app :: Application

15−app _req respond =

16− runResourceT $ withInternalState $ \is ->

17− respond $ responseSource status200 [] $

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

19− mapC (Chunk . byteString)

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

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

11name: wai-conduit

2−version: 3.0.0.4

2+version: 3.0.0.2

33synopsis: conduit wrappers for WAI

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

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

@@ -15,9 +15,10 @@ extra-source-files: README.md ChangeLog.md

1515library

1616 exposed-modules: Network.Wai.Conduit

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

18− , wai >= 3.0 && < 3.3

18+ , wai >= 3.0 && < 3.1

1919 , conduit

2020 , transformers

21− , bytestring >= 0.10.4

21+ , bytestring

2222 , http-types

23+ , blaze-builder

2324 default-language: Haskell2010

wai-extra/ChangeLog.md−162

@@ -1,165 +1,3 @@

1−# Changelog for wai-extra

2−

3−## 3.0.29.1

4−

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

6−

7−## 3.0.29

8−

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

10−

11−## 3.0.28

12−

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

14−

15−## 3.0.27

16−

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

18−

19−## 3.0.26.1

20−

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

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

23−

24−## 3.0.26

25−

26−* Throw 413 for too large payload

27−* Throw 431 for too large headers

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

29−

30−## 3.0.25

31−

32−* Supporting `network` version 3.0.

33−

34−## 3.0.24.3

35−

36−* Drop unnecessary `lifted-base` dependency

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

38−

39−## 3.0.24.2

40−

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

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

43−

44−## 3.0.24.1

45−

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

47−

48−## 3.0.24.0

49−

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

51−

52−## 3.0.23.0

53−

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

55−

56−## 3.0.22.1

57−

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

59−

60−## 3.0.22.0

61−

62−* Support for streaming-commons 0.2

63−* Support for resourcet 1.2

64−

65−## 3.0.21.0

66−

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

68−

69−## 3.0.20.2

70−

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

72−

73−## 3.0.20.1

74−

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

76−

77−## 3.0.20.0

78−

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

80−

81−## 3.0.19.1

82−

83−* All loggers follow the autoFlush setting [#604](https://github.com/yesodweb/wai/pull/604)

84−

85−## 3.0.19

86−

87−* Add a new function basicAuth', which passes request to the CheckCreds argument.

88−

89−## 3.0.18

90−

91−* ForceSSL: preserve port number when redirecting to https. [#582](https://github.com/yesodweb/wai/pull/582)

92−

93−## 3.0.17

94−

95−* Gzip pre compressed [#580](https://github.com/yesodweb/wai/pull/580)

96−

97−## 3.0.16.1

98−

99−* Fix the way the header length is checked (for limiting the max header length)

100−

101−## 3.0.16.0

102−

103−* Add a new function "parseRequestBodyEx" that allows various size limits to be set.

104−

105−## 3.0.15.3

106−

107−* Allow wai-logger 2.3

108−

109−## 3.0.15.2

110−

111−* Doc improvements

112−

113−## 3.0.15.1

114−

115−* don't use deprecated CRT functions on Windows [#544](https://github.com/yesodweb/wai/pull/544)

116−

117−## 3.0.15

118−

119−* add requestSizeCheck [#525](https://github.com/yesodweb/wai/pull/525)

120−

121−## 3.0.14.3

122−

123−* Add missing `requestHeaderReferer` and `requestHeaderUserAgent` fields to CGI [yesod#1186](https://github.com/yesodweb/yesod/issues/1186)

124−

125−## 3.0.14.2

126−

127−* Case insensitive multipart request header lookup [#518](https://github.com/yesodweb/wai/pull/518)

128−

129−## 3.0.14.1

130−

131−* Doc update for logStdout and logStdoutDev [#515](https://github.com/yesodweb/wai/issues/515)

132−

133−## 3.0.14

134−

135−* Middleware to force domain names. [#506](https://github.com/yesodweb/wai/issues/506) [#507](https://github.com/yesodweb/wai/pull/507)

136−

137−## 3.0.13.1

138−

139−* Support wai 3.2

140−

141−## 3.0.13

142−

143−* Autoflush handle [#466](https://github.com/yesodweb/wai/pull/466)

144−

145−## 3.0.12

146−

147−* Add Network.Wai.Header.contentLength to read the Content-Length header of a response

148−* The gzip middleware no longer zips responses smaller than 860 bytes

149−

150−## 3.0.11

151−

152−* Add constructor for more detailed custom output formats for RequestLogger

153−* Add JSON output formatter for RequestLogger

154−

155−## 3.0.10

156−

157−* Adding Request Body to RequestLogger [#401](https://github.com/yesodweb/wai/pull/401)

158−

159−## 3.0.9

160−

161−* Network.Wai.Middleware.Routed module added

162−

1631## 3.0.7

1642

1653* Add appearsSecure: check if a request appears to be using SSL even in the

wai-extra/Network/Wai/EventSource.hs+6−27

@@ -1,25 +1,19 @@

1+{-# LANGUAGE OverloadedStrings #-}

12{-|

23 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.

104-}

115module Network.Wai.EventSource (

126 ServerEvent(..),

137 eventSourceAppChan,

14− eventSourceAppIO,

15− eventStreamAppRaw

8+ eventSourceAppIO

169 ) where

1710

11+import Blaze.ByteString.Builder (Builder)

1812import Data.Function (fix)

1913import Control.Concurrent.Chan (Chan, dupChan, readChan)

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

21−import Network.HTTP.Types (status200, hContentType)

22−import Network.Wai (Application, responseStream)

15+import Network.HTTP.Types (status200)

16+import Network.Wai (Application, Response, responseStream)

2317

2418import Network.Wai.EventSource.EventStream

2519

@@ -36,24 +30,9 @@ eventSourceAppIO :: IO ServerEvent -> Application

3630eventSourceAppIO src _ sendResponse =

3731 sendResponse $ responseStream

3832 status200

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

33+ [("Content-Type", "text/event-stream")]

4034 $ \sendChunk flush -> fix $ \loop -> do

4135 se <- src

4236 case eventToBuilder se of

4337 Nothing -> return ()

4438 Just b -> sendChunk b >> flush >> loop

45−

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

47−--

48−-- @since 3.0.28

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

50−eventStreamAppRaw handler _ sendResponse =

51− sendResponse $ responseStream

52− status200

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

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

55− where

56− sendEvent sendChunk event =

57− case eventToBuilder event of

58− Nothing -> return ()

59− Just b -> sendChunk b

wai-extra/Network/Wai/EventSource/EventStream.hs+11−12

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

1−{-# LANGUAGE CPP #-}

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

1+{-# LANGUAGE OverloadedStrings #-}

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

33

44{-|

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

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

99 eventToBuilder

1010 ) where

1111

12−import Data.ByteString.Builder

13−#if __GLASGOW_HASKELL__ < 710

12+import Blaze.ByteString.Builder

13+import Blaze.ByteString.Builder.Char8

1414import Data.Monoid

15−#endif

1615

1716{-|

1817 Type representing a communication over an event stream. This can be an

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

3837 Newline as a Builder.

3938-}

4039nl :: Builder

41−nl = char7 '\n'

40+nl = fromChar '\n'

4241

4342

4443{-|

4544 Field names as Builder

4645-}

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

48−nameField = string7 "event:"

49−idField = string7 "id:"

50−dataField = string7 "data:"

51−retryField = string7 "retry:"

52−commentField = char7 ':'

47+nameField = fromString "event:"

48+idField = fromString "id:"

49+dataField = fromString "data:"

50+retryField = fromString "retry:"

51+commentField = fromChar ':'

5352

5453

5554{-|

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

6564-}

6665eventToBuilder :: ServerEvent -> Maybe Builder

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

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

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

6968eventToBuilder (CloseEvent) = Nothing

7069eventToBuilder (ServerEvent n i d)= Just $

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

wai-extra/Network/Wai/Handler/CGI.hs+27−31

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

1−{-# LANGUAGE RankNTypes, CPP #-}

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE CPP #-}

24-- | Backend for Common Gateway Interface. Almost all users should use the

35-- 'run' function.

46module Network.Wai.Handler.CGI

@@ -19,18 +21,16 @@ import Control.Arrow ((***))

1921import Data.Char (toLower)

2022import qualified System.IO

2123import qualified Data.String as String

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

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

24+import Data.Monoid (mconcat, mempty)

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

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

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

2528import System.IO (Handle)

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

29+import Network.HTTP.Types (Status (..))

2730import qualified Network.HTTP.Types as H

2831import qualified Data.CaseInsensitive as CI

29−#if __GLASGOW_HASKELL__ < 710

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

31−#endif

32−

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

32+import Data.Monoid (mappend)

33+import qualified Data.Streaming.Blaze as Blaze

3434import Data.Function (fix)

3535import Control.Monad (unless, void)

3636

@@ -118,11 +118,7 @@ runGeneric vars inputH outputH xsendfile app = do

118118 , vault = mempty

119119 , requestBodyLength = KnownLength $ fromIntegral contentLength

120120 , 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

121+ , requestHeaderRange = lookup "range" reqHeaders

126122 }

127123 void $ app env $ \res ->

128124 case (xsendfile, res) of

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

131127 return ResponseReceived

132128 _ -> do

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

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

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

135131 wb $ \b -> do

136132 let sendBuilder builder = do

137133 popper <- blazeRecv builder

@@ -140,39 +136,39 @@ runGeneric vars inputH outputH xsendfile app = do

140136 unless (B.null bs) $ do

141137 outputH bs

142138 loop

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

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

144140 b sendBuilder (sendBuilder flush)

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

146142 return ResponseReceived

147143 where

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

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

150− [ string8 $ show i

151− , char7 ' '

152− , byteString m

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

146+ [ fromString $ show i

147+ , fromChar ' '

148+ , fromByteString m

153149 ])

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

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

155151 header (x, y) = mconcat

156152 [ x

157− , byteString ": "

153+ , fromByteString ": "

158154 , y

159− , char7 '\n'

155+ , fromChar '\n'

160156 ]

161157 sfBuilder s hs sf fp = mconcat

162158 [ headers s hs

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

164− , char7 '\n'

165− , byteString sf

166− , byteString " not supported"

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

160+ , fromChar '\n'

161+ , fromByteString sf

162+ , fromByteString " not supported"

167163 ]

168164 fixHeaders h =

169− case lookup hContentType h of

170− Nothing -> (hContentType, "text/html; charset=utf-8") : h

165+ case lookup "content-type" h of

166+ Nothing -> ("Content-Type", "text/html; charset=utf-8") : h

171167 Just _ -> h

172168

173169cleanupVarName :: String -> CI.CI B.ByteString

174−cleanupVarName "CONTENT_TYPE" = hContentType

175−cleanupVarName "CONTENT_LENGTH" = hContentLength

170+cleanupVarName "CONTENT_TYPE" = "Content-Type"

171+cleanupVarName "CONTENT_LENGTH" = "Content-Length"

176172cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"

177173cleanupVarName s =

178174 case s of

wai-extra/Network/Wai/Handler/SCGI.hs+1−12

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

1−{-# LANGUAGE CPP, ForeignFunctionInterface #-}

1+{-# LANGUAGE ForeignFunctionInterface #-}

22module Network.Wai.Handler.SCGI

33 ( run

44 , runSendfile

@@ -86,16 +86,6 @@ readByteString socket len = do

8686foreign import ccall unsafe "accept"

8787 c'accept :: CInt -> Ptr a -> Ptr a -> IO CInt

8888

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

9989foreign import ccall unsafe "close"

10090 c'close :: CInt -> IO CInt

10191

@@ -104,4 +94,3 @@ foreign import ccall unsafe "write"

10494

10595foreign import ccall unsafe "read"

10696 c'read :: CInt -> Ptr CChar -> CInt -> IO CInt

107−#endif

wai-extra/Network/Wai/Header.hsdeleted−18

@@ -1,18 +0,0 @@

1−-- | Some helpers for dealing with WAI 'Header's.

2−

3−module Network.Wai.Header

4− ( contentLength

5− ) where

6−

7−import qualified Data.ByteString.Char8 as S8

8−import Network.HTTP.Types as H

9−

10−-- | More useful for a response. A Wai Request already has a requestBodyLength

11−contentLength :: [(HeaderName, S8.ByteString)] -> Maybe Integer

12−contentLength hdrs = lookup H.hContentLength hdrs >>= readInt

13−

14−readInt :: S8.ByteString -> Maybe Integer

15−readInt bs =

16− case S8.readInteger bs of

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

18− _ -> Nothing

wai-extra/Network/Wai/Middleware/AcceptOverride.hs+2

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

1+{-# LANGUAGE OverloadedStrings #-}

2+

13module Network.Wai.Middleware.AcceptOverride

24 ( acceptOverride

35 ) where

wai-extra/Network/Wai/Middleware/AddHeaders.hs+10−4

@@ -5,8 +5,8 @@ module Network.Wai.Middleware.AddHeaders

55 ( addHeaders

66 ) where

77

8−import Network.HTTP.Types (Header)

9−import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)

8+import Network.HTTP.Types (ResponseHeaders, Header)

9+import Network.Wai (Middleware)

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

1111import Data.ByteString (ByteString)

1212

@@ -18,7 +18,13 @@ addHeaders :: [(ByteString, ByteString)] -> Middleware

1818--

1919-- Since 3.0.3

2020

21−addHeaders h = modifyResponse $ addHeaders' (map (first CI.mk) h)

21+addHeaders h app req respond = app req $ respond . addHeaders' (map (first CI.mk) h)

22+

23+mapHeader :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response

24+mapHeader f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2

25+mapHeader f (ResponseBuilder s h b) = ResponseBuilder s (f h) b

26+mapHeader f (ResponseStream s h b) = ResponseStream s (f h) b

27+mapHeader _ r@(ResponseRaw _ _) = r

2228

2329addHeaders' :: [Header] -> Response -> Response

24−addHeaders' h = mapResponseHeaders (\hs -> h ++ hs)

30+addHeaders' h = mapHeader (\hs -> h ++ hs)

wai-extra/Network/Wai/Middleware/Approot.hs+4−2

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

11{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE OverloadedStrings #-}

23-- | Middleware for establishing the root of the application.

34--

45-- Many application need the ability to create URLs referring back to the

@@ -28,12 +29,13 @@ module Network.Wai.Middleware.Approot

2829

2930import Control.Exception (Exception, throw)

3031import Data.ByteString (ByteString)

32+import qualified Data.ByteString as S

3133import qualified Data.ByteString.Char8 as S8

3234import Data.Maybe (fromMaybe)

3335import Data.Typeable (Typeable)

3436import qualified Data.Vault.Lazy as V

35−import Network.Wai (Request, vault, Middleware)

36−import Network.Wai.Request (guessApproot)

37+import Network.Wai (Request, vault, Middleware, requestHeaderHost)

38+import Network.Wai.Request (appearsSecure, guessApproot)

3739import System.Environment (getEnvironment)

3840import System.IO.Unsafe (unsafePerformIO)

3941

wai-extra/Network/Wai/Middleware/Autohead.hs+1−3

@@ -1,12 +1,10 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE OverloadedStrings #-}

22-- | Automatically produce responses to HEAD requests based on the underlying

33-- applications GET response.

44module Network.Wai.Middleware.Autohead (autohead) where

55

66import Network.Wai

7−#if __GLASGOW_HASKELL__ < 710

87import Data.Monoid (mempty)

9−#endif

108

119autohead :: Middleware

1210autohead app req sendResponse

wai-extra/Network/Wai/Middleware/CleanPath.hs+3−5

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE OverloadedStrings #-}

22module Network.Wai.Middleware.CleanPath

33 ( cleanPath

44 ) where

@@ -6,11 +6,9 @@ module Network.Wai.Middleware.CleanPath

66import Network.Wai

77import qualified Data.ByteString.Char8 as B

88import qualified Data.ByteString.Lazy as L

9−import Network.HTTP.Types (status301, hLocation)

9+import Network.HTTP.Types (status301)

1010import Data.Text (Text)

11−#if __GLASGOW_HASKELL__ < 710

1211import Data.Monoid (mconcat)

13−#endif

1412

1513cleanPath :: ([Text] -> Either B.ByteString [Text])

1614 -> B.ByteString

@@ -21,7 +19,7 @@ cleanPath splitter prefix app env sendResponse =

2119 Right pieces -> app pieces env sendResponse

2220 Left p -> sendResponse

2321 $ responseLBS status301

24− [(hLocation, mconcat [prefix, p, suffix])]

22+ [("Location", mconcat [prefix, p, suffix])]

2523 $ L.empty

2624 where

2725 -- include the query string if present

wai-extra/Network/Wai/Middleware/ForceDomain.hsdeleted−38

@@ -1,38 +0,0 @@

1−-- |

2−--

3−-- @since 3.0.14

4−module Network.Wai.Middleware.ForceDomain where

5−

6−import Data.ByteString (ByteString)

7−import Data.Monoid ((<>), mempty)

8−import Network.HTTP.Types (hLocation, methodGet, status301, status307)

9−import Prelude

10−

11−import Network.Wai

12−import Network.Wai.Request

13−

14−-- | Force a domain by redirecting.

15−-- The `checkDomain` function takes the current domain and checks whether it is correct.

16−-- It should return `Nothing` if the domain is correct, or `Just "domain.com"` if it is incorrect.

17−--

18−-- @since 3.0.14

19−forceDomain :: (ByteString -> Maybe ByteString) -> Middleware

20−forceDomain checkDomain app req sendResponse =

21− case requestHeaderHost req >>= checkDomain of

22− Nothing ->

23− app req sendResponse

24− Just domain ->

25− sendResponse $ redirectResponse domain

26−

27− where

28− -- From: Network.Wai.Middleware.ForceSSL

29− redirectResponse domain =

30− responseBuilder status [(hLocation, location domain)] mempty

31−

32− location h =

33− let p = if appearsSecure req then "https://" else "http://" in

34− p <> h <> rawPathInfo req <> rawQueryString req

35−

36− status

37− | requestMethod req == methodGet = status301

38− | otherwise = status307

wai-extra/Network/Wai/Middleware/ForceSSL.hs+9−2

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

23-- | Redirect non-SSL requests to https

34--

45-- Since 3.0.7

@@ -17,6 +18,9 @@ import Data.Monoid (mempty)

1718import Data.Monoid ((<>))

1819import Network.HTTP.Types (hLocation, methodGet, status301, status307)

1920

21+import qualified Data.ByteString as S

22+import Data.Word8 (_colon)

23+

2024-- | For requests that don't appear secure, redirect to https

2125--

2226-- Since 3.0.7

@@ -28,10 +32,13 @@ forceSSL app req sendResponse =

2832

2933redirectResponse :: Request -> Maybe Response

3034redirectResponse req = do

31− host <- requestHeaderHost req

32− return $ responseBuilder status [(hLocation, location host)] mempty

35+ (host, _) <- S.break (== _colon) <$> requestHeaderHost req

36+

37+ return $ responseBuilder status [(hLocation, location host)] mempty

38+

3339 where

3440 location h = "https://" <> h <> rawPathInfo req <> rawQueryString req

41+

3542 status

3643 | requestMethod req == methodGet = status301

3744 | otherwise = status307

wai-extra/Network/Wai/Middleware/Gzip.hs+31−67

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

1−{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}

1+{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE OverloadedStrings #-}

24---------------------------------------------------------

35-- |

46-- Module : Network.Wai.Middleware.Gzip

@@ -27,60 +29,43 @@ import Data.Maybe (fromMaybe, isJust)

2729import qualified Data.ByteString.Char8 as S8

2830import qualified Data.ByteString as S

2931import Data.Default.Class

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

31− , hContentType, hContentLength)

32+import Network.HTTP.Types (Status, Header)

33+import Control.Monad.IO.Class (liftIO)

34+import Control.Monad.Trans.Resource (runResourceT)

3235import System.Directory (doesFileExist, createDirectoryIfMissing)

33−import Data.ByteString.Builder (byteString)

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

36+import Blaze.ByteString.Builder (fromByteString)

3537import Control.Exception (try, SomeException)

3638import qualified Data.Set as Set

37−import Network.Wai.Header

3839import Network.Wai.Internal

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

40+import qualified Data.Streaming.Blaze as B

4041import qualified Data.Streaming.Zlib as Z

42+import qualified Blaze.ByteString.Builder as Blaze

4143import Control.Monad (unless)

4244import Data.Function (fix)

4345import Control.Exception (throwIO)

4446import qualified System.IO as IO

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

46−import Data.Word8 (_semicolon)

4748

4849data GzipSettings = GzipSettings

4950 { gzipFiles :: GzipFiles

5051 , gzipCheckMime :: S.ByteString -> Bool

5152 }

5253

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

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

54+data GzipFiles = GzipIgnore | GzipCompress | GzipCacheFolder FilePath

6555 deriving (Show, Eq, Read)

6656

67−-- | Use default MIME settings; /do not/ compress files.

6857instance Default GzipSettings where

6958 def = GzipSettings GzipIgnore defaultCheckMime

7059

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

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

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

7460defaultCheckMime :: S.ByteString -> Bool

7561defaultCheckMime bs =

7662 S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress

7763 where

78− bs' = fst $ S.break (== _semicolon) bs

64+ bs' = fst $ S.breakByte 59 bs -- semicolon

7965 toCompress = Set.fromList

8066 [ "application/json"

8167 , "application/javascript"

8268 , "application/ecmascript"

83− , "image/x-icon"

8469 ]

8570

8671-- | Use gzip to compress the body of the response.

@@ -88,51 +73,30 @@ defaultCheckMime bs =

8873-- Analyzes the \"Accept-Encoding\" header from the client to determine

8974-- if gzip is supported.

9075--

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

76+-- Possible future enhancements:

9277--

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

94−-- behavior, see 'defaultCheckMime'.

78+-- * Only compress if the response is above a certain size.

9579gzip :: GzipSettings -> Middleware

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

9781 case res of

9882 ResponseRaw{} -> sendResponse res

9983 ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res

100− _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res)

84+ _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)

10185 then

102− let runAction x = case x 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) ->

112− case lookup hContentType hs of

113− Just m

114− | gzipCheckMime set m -> compressFile s hs file cache sendResponse

115− _ -> sendResponse res

116− (ResponseFile {}, GzipIgnore) -> sendResponse res

117− _ -> compressE set res sendResponse

118− in runAction (res, gzipFiles set)

86+ case (res, gzipFiles set) of

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

88+ case lookup "content-type" hs of

89+ Just m

90+ | gzipCheckMime set m -> compressFile s hs file cache sendResponse

91+ _ -> sendResponse res

92+ _ -> compressE set res sendResponse

11993 else sendResponse res

12094 where

12195 enc = fromMaybe [] $ (splitCommas . S8.unpack)

12296 `fmap` lookup "Accept-Encoding" (requestHeaders env)

123− ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env

97+ ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env

12498 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

99+ isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res

136100

137101compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a

138102compressFile s hs file cache sendResponse = do

@@ -154,7 +118,7 @@ compressFile s hs file cache sendResponse = do

154118 Z.PRNext bs -> do

155119 S.hPut outH bs

156120 loop

157− Z.PRError ex -> throwIO ex

121+ Z.PRError e -> throwIO e

158122 fix $ \loop -> do

159123 bs <- S.hGetSome inH defaultChunkSize

160124 unless (S.null bs) $ do

@@ -181,11 +145,11 @@ compressE :: GzipSettings

181145 -> (Response -> IO a)

182146 -> IO a

183147compressE set res sendResponse =

184− case lookup hContentType hs of

148+ case lookup "content-type" hs of

185149 Just m | gzipCheckMime set m ->

186150 let hs' = fixHeaders hs

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

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

152+ (blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy

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

190154 let sendBuilder builder = do

191155 popper <- blazeRecv builder

@@ -200,11 +164,11 @@ compressE set res sendResponse =

200164 deflatePopper $ Z.flushDeflate deflate

201165 flush

202166 deflatePopper popper = fix $ \loop -> do

203− result <- popper

204− case result of

167+ res <- popper

168+ case res of

205169 Z.PRDone -> return ()

206170 Z.PRNext bs' -> do

207− sendChunk $ byteString bs'

171+ sendChunk $ fromByteString bs'

208172 loop

209173 Z.PRError e -> throwIO e

210174

@@ -219,9 +183,9 @@ compressE set res sendResponse =

219183-- different length after gzip compression.

220184fixHeaders :: [Header] -> [Header]

221185fixHeaders =

222− ((hContentEncoding, "gzip") :) . filter notLength

186+ (("Content-Encoding", "gzip") :) . filter notLength

223187 where

224− notLength (x, _) = x /= hContentLength

188+ notLength (x, _) = x /= "content-length"

225189

226190splitCommas :: String -> [String]

227191splitCommas [] = []

wai-extra/Network/Wai/Middleware/HttpAuth.hs+16−25

@@ -1,11 +1,10 @@

1−{-# LANGUAGE RecordWildCards, TupleSections, CPP #-}

1+{-# LANGUAGE RecordWildCards, OverloadedStrings, TupleSections #-}

22-- | Implements HTTP Basic Authentication.

33--

44-- This module may add digest authentication in the future.

55module Network.Wai.Middleware.HttpAuth

66 ( -- * Middleware

77 basicAuth

8− , basicAuth'

98 , CheckCreds

109 , AuthSettings

1110 , authRealm

@@ -15,14 +14,13 @@ module Network.Wai.Middleware.HttpAuth

1514 , extractBasicAuth

1615 , extractBearerAuth

1716 ) where

18−#if __GLASGOW_HASKELL__ < 710

17+

1918import Control.Applicative

20−#endif

2119import Data.ByteString (ByteString)

2220import Data.ByteString.Base64 (decodeLenient)

2321import Data.String (IsString (..))

2422import Data.Word8 (isSpace, _colon, toLower)

25−import Network.HTTP.Types (status401, hContentType, hAuthorization)

23+import Network.HTTP.Types (status401)

2624import Network.Wai

2725

2826import qualified Data.ByteString as S

@@ -37,19 +35,11 @@ type CheckCreds = ByteString

3735--

3836-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"

3937--

40−-- @since 1.3.4

38+-- Since 1.3.4

4139basicAuth :: CheckCreds

4240 -> AuthSettings

4341 -> Middleware

44−basicAuth checkCreds = basicAuth' (\_ -> checkCreds)

45−

46−-- | Like 'basicAuth', but also passes a request to the authentication function.

47−--

48−-- @since 3.0.19

49−basicAuth' :: (Request -> CheckCreds)

50− -> AuthSettings

51− -> Middleware

52−basicAuth' checkCreds AuthSettings {..} app req sendResponse = do

42+basicAuth checkCreds AuthSettings {..} app req sendResponse = do

5343 isProtected <- authIsProtected req

5444 allowed <- if isProtected then check else return True

5545 if allowed

@@ -57,10 +47,11 @@ basicAuth' checkCreds AuthSettings {..} app req sendResponse = do

5747 else authOnNoAuth authRealm req sendResponse

5848 where

5949 check =

60− case (lookup hAuthorization $ requestHeaders req)

50+ case (lookup "Authorization" $ requestHeaders req)

6151 >>= extractBasicAuth of

6252 Nothing -> return False

63− Just (username, password) -> checkCreds req username password

53+ Just (username, password) -> checkCreds username password

54+

6455

6556-- | Basic authentication settings. This value is an instance of

6657-- @IsString@, so the recommended approach to create a value is to

@@ -69,23 +60,23 @@ basicAuth' checkCreds AuthSettings {..} app req sendResponse = do

6960--

7061-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings

7162--

72−-- @since 1.3.4

63+-- Since 1.3.4

7364data AuthSettings = AuthSettings

7465 { authRealm :: !ByteString

7566 -- ^

7667 --

77− -- @since 1.3.4

68+ -- Since 1.3.4

7869 , authOnNoAuth :: !(ByteString -> Application)

7970 -- ^ Takes the realm and returns an appropriate 401 response when

8071 -- authentication is not provided.

8172 --

82− -- @since 1.3.4

73+ -- Since 1.3.4

8374 , authIsProtected :: !(Request -> IO Bool)

8475 -- ^ Determine if access to the requested resource is restricted.

8576 --

8677 -- Default: always returns @True@.

8778 --

88− -- @since 1.3.4

79+ -- Since 1.3.4

8980 }

9081

9182instance IsString AuthSettings where

@@ -93,7 +84,7 @@ instance IsString AuthSettings where

9384 { authRealm = fromString s

9485 , authOnNoAuth = \realm _req f -> f $ responseLBS

9586 status401

96− [ (hContentType, "text/plain")

87+ [ ("Content-Type", "text/plain")

9788 , ("WWW-Authenticate", S.concat

9889 [ "Basic realm=\""

9990 , realm

@@ -107,7 +98,7 @@ instance IsString AuthSettings where

10798-- | Extract basic authentication data from usually __Authorization__

10899-- header value. Returns username and password

109100--

110−-- @since 3.0.5

101+-- Since 3.0.5

111102extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)

112103extractBasicAuth bs =

113104 let (x, y) = S.break isSpace bs

@@ -117,13 +108,13 @@ extractBasicAuth bs =

117108 where

118109 extract encoded =

119110 let raw = decodeLenient encoded

120− (username, password') = S.break (== _colon) raw

111+ (username, password') = S.breakByte _colon raw

121112 in ((username,) . snd) <$> S.uncons password'

122113

123114-- | Extract bearer authentication data from __Authorization__ header

124115-- value. Returns bearer token

125116--

126−-- @since 3.0.5

117+-- Since 3.0.5

127118extractBearerAuth :: ByteString -> Maybe ByteString

128119extractBearerAuth bs =

129120 let (x, y) = S.break isSpace bs

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

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

1−{-# LANGUAGE RankNTypes, CPP #-}

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE RankNTypes #-}

23---------------------------------------------------------

34-- |

45-- Module : Network.Wai.Middleware.Jsonp

@@ -18,15 +19,14 @@ import Network.Wai

1819import Network.Wai.Internal

1920import Data.ByteString (ByteString)

2021import qualified Data.ByteString.Char8 as B8

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

22−import Data.ByteString.Builder (char7)

23−#if __GLASGOW_HASKELL__ < 710

22+import Blaze.ByteString.Builder (Builder, copyByteString)

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

2424import Data.Monoid (mappend)

25−#endif

2625import Control.Monad (join)

2726import Data.Maybe (fromMaybe)

2827import qualified Data.ByteString as S

29−import Network.HTTP.Types (hAccept, hContentType)

28+import Data.CaseInsensitive (CI)

29+import Network.HTTP.Types (Status)

3030

3131-- | Wrap json responses in a jsonp callback.

3232--

@@ -37,7 +37,7 @@ import Network.HTTP.Types (hAccept, hContentType)

3737-- callback function.

3838jsonp :: Middleware

3939jsonp app env sendResponse = do

40− let accept = fromMaybe B8.empty $ lookup hAccept $ requestHeaders env

40+ let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env

4141 let callback :: Maybe B8.ByteString

4242 callback =

4343 if B8.pack "text/javascript" `B8.isInfixOf` accept

@@ -47,7 +47,7 @@ jsonp app env sendResponse = do

4747 case callback of

4848 Nothing -> env

4949 Just _ -> env

50− { requestHeaders = changeVal hAccept

50+ { requestHeaders = changeVal "Accept"

5151 "application/json"

5252 $ requestHeaders env

5353 }

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

6060 sendResponse $ case checkJSON hs of

6161 Nothing -> r

6262 Just hs' -> responseBuilder s hs' $

63− byteStringCopy c

64− `mappend` char7 '('

63+ copyByteString c

64+ `mappend` fromChar '('

6565 `mappend` b

66− `mappend` char7 ')'

66+ `mappend` fromChar ')'

6767 go c r =

6868 case checkJSON hs of

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

@@ -72,18 +72,18 @@ jsonp app env sendResponse = do

7272 (s, hs, wb) = responseToStream r

7373

7474 checkJSON hs =

75− case lookup hContentType hs of

75+ case lookup "Content-Type" hs of

7676 Just x

7777 | B8.pack "application/json" `S.isPrefixOf` x ->

7878 Just $ fixHeaders hs

7979 _ -> Nothing

80− fixHeaders = changeVal hContentType "text/javascript"

80+ fixHeaders = changeVal "Content-Type" "text/javascript"

8181

8282 addCallback cb s hs wb =

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

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

85− _ <- body sendChunk flush

86− sendChunk $ char7 ')'

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

85+ body sendChunk flush

86+ sendChunk $ fromChar ')'

8787

8888changeVal :: Eq a

8989 => a

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

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE OverloadedStrings, CPP #-}

22-- | Only allow local connections.

33--

44module Network.Wai.Middleware.Local

wai-extra/Network/Wai/Middleware/MethodOverride.hs+6−4

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

1+{-# LANGUAGE OverloadedStrings #-}

12module Network.Wai.Middleware.MethodOverride

23 ( methodOverride

34 ) where

@@ -5,11 +6,12 @@ module Network.Wai.Middleware.MethodOverride

56import Network.Wai

67import Control.Monad (join)

78

8−-- | Overriding of HTTP request method via `_method` query string parameter.

9+-- | Allows overriding of the HTTP request method via the _method query string

10+-- parameter.

911--

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.

12+-- This middleware only applies when the initial request method is POST. This

13+-- allow submitting of normal HTML forms, without worries of semantics

14+-- mismatches in the HTTP spec.

1315methodOverride :: Middleware

1416methodOverride app req =

1517 app req'

wai-extra/Network/Wai/Middleware/MethodOverridePost.hs+3−6

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE OverloadedStrings #-}

22-----------------------------------------------------------------

33-- | Module : Network.Wai.Middleware.MethodOverridePost

44--

@@ -9,11 +9,8 @@ module Network.Wai.Middleware.MethodOverridePost

99 ) where

1010

1111import Network.Wai

12−import Network.HTTP.Types (parseQuery, hContentType)

13−

14−#if __GLASGOW_HASKELL__ < 710

12+import Network.HTTP.Types (parseQuery)

1513import Data.Monoid (mconcat, mempty)

16−#endif

1714import Data.IORef

1815import Data.ByteString.Lazy (toChunks)

1916

@@ -30,7 +27,7 @@ import Data.ByteString.Lazy (toChunks)

3027--

3128methodOverridePost :: Middleware

3229methodOverridePost app req send =

33− case (requestMethod req, lookup hContentType (requestHeaders req)) of

30+ case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of

3431 ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send

3532 _ -> app req send

3633

wai-extra/Network/Wai/Middleware/RequestLogger.hs+66−150

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

1+{-# LANGUAGE OverloadedStrings #-}

12{-# LANGUAGE RecordWildCards #-}

3+

24-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should

35-- not use CPP.

46module Network.Wai.Middleware.RequestLogger

@@ -13,80 +15,42 @@ module Network.Wai.Middleware.RequestLogger

1315 , destination

1416 , OutputFormat (..)

1517 , OutputFormatter

16− , OutputFormatterWithDetails

17− , OutputFormatterWithDetailsAndHeaders

1818 , Destination (..)

1919 , Callback

2020 , IPAddrSource (..)

2121 ) where

2222

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

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

23+import System.IO (Handle, stdout)

2524import qualified Data.ByteString as BS

26−import Data.ByteString.Char8 (pack)

27−import Control.Monad (when)

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

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

29−import Network.Wai

30− ( Request(..), requestBodyLength, RequestBodyLength(..)

31− , Middleware

32− , Response, responseStatus, responseHeaders

33− )

27+import Network.Wai (Request(..), Middleware, responseStatus, Response, responseHeaders)

3428import System.Log.FastLogger

3529import Network.HTTP.Types as H

3630import Data.Maybe (fromMaybe)

3731import Data.Monoid (mconcat, (<>))

38−import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)

39−import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File

40− , getRequestBodyType)

32+import Data.Time (getCurrentTime, diffUTCTime)

33+

34+import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)

4135import qualified Data.ByteString.Lazy as LBS

4236import qualified Data.ByteString.Char8 as S8

37+

4338import System.Console.ANSI

44−import Data.IORef

39+import Data.IORef.Lifted

4540import System.IO.Unsafe

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

41+import Control.Monad (unless)

42+import Network.Wai.Internal (Response (ResponseRaw))

43+

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

4845import Network.Wai.Logger

4946import Network.Wai.Middleware.RequestLogger.Internal

50−import Network.Wai.Header (contentLength)

51−import Data.Text.Encoding (decodeUtf8')

5247

53−data OutputFormat

54− = Apache IPAddrSource

55− | Detailed Bool -- ^ use colors?

56− | CustomOutputFormat OutputFormatter

57− | CustomOutputFormatWithDetails OutputFormatterWithDetails

58− | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

48+data OutputFormat = Apache IPAddrSource

49+ | Detailed Bool -- ^ use colors?

50+ | CustomOutputFormat OutputFormatter

5951

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

6153

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−

9054data Destination = Handle Handle

9155 | Logger LoggerSet

9256 | Callback Callback

@@ -121,85 +85,48 @@ mkRequestLogger :: RequestLoggerSettings -> IO Middleware

12185mkRequestLogger RequestLoggerSettings{..} = do

12286 let (callback, flusher) =

12387 case destination of

124− Handle h -> (BS.hPutStr h . logToByteString, when autoFlush (hFlush h))

125− Logger l -> (pushLogStr l, when autoFlush (flushLogStr l))

88+ Handle h -> (BS.hPutStr h . logToByteString, return ())

89+ Logger l -> (pushLogStr l, flushLogStr l)

12690 Callback c -> (c, return ())

127− callbackAndFlush str = callback str >> flusher

12891 case outputFormat of

12992 Apache ipsrc -> do

13093 getdate <- getDateGetter flusher

131− apache <- initLogger ipsrc (LogCallback callback flusher) getdate

94+ apache <- initLogger ipsrc (LogCallback callback (return ())) getdate

13295 return $ apacheMiddleware apache

133− Detailed useColors -> detailedMiddleware callbackAndFlush useColors

96+ Detailed useColors -> detailedMiddleware

97+ (\str -> callback str >> flusher)

98+ useColors

13499 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

141100 getdate <- getDateGetter flusher

142− return $ customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate formatter

101+ return $ customMiddleware callback getdate formatter

143102

144103apacheMiddleware :: ApacheLoggerActions -> Middleware

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

146− let msize = contentLength (responseHeaders res)

105+ let msize = lookup "content-length" (responseHeaders res) >>= readInt'

106+ readInt' bs =

107+ case S8.readInteger bs of

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

109+ _ -> Nothing

147110 apacheLogger ala req (responseStatus res) msize

148111 sendResponse res

149112

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

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

152115 date <- liftIO getdate

153− let msize = contentLength (responseHeaders res)

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

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

117+ liftIO $ cb $ formatter date req (responseStatus res) Nothing

155118 sendResponse res

156119

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

158−customMiddlewareWithDetails cb getdate formatter app req sendResponse = do

159− (req', reqBody) <- getRequestBody req

160− t0 <- getCurrentTime

161− app req' $ \res -> do

162− t1 <- getCurrentTime

163− date <- liftIO getdate

164− let msize = contentLength (responseHeaders res)

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

166− res' <- recordChunks builderIO res

167− rspRcv <- sendResponse res'

168− _ <- liftIO . cb .

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

170− readIORef builderIO

171− return rspRcv

172−

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

174−customMiddlewareWithDetailsAndHeaders cb getdate formatter app req sendResponse = do

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

176− t0 <- getCurrentTime

177− app req' $ \res -> do

178− t1 <- getCurrentTime

179− date <- liftIO getdate

180− let msize = contentLength (responseHeaders res)

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

182− res' <- recordChunks builderIO res

183− rspRcv <- sendResponse res'

184− _ <- do

185− rawResponse <- readIORef builderIO

186− let status = responseStatus res'

187− duration = t1 `diffUTCTime` t0

188− resHeaders = responseHeaders res'

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

190− return rspRcv

191120-- | Production request logger middleware.

192−--

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 #-}

121+-- Implemented on top of "logCallback", but prints to 'stdout'

196122logStdout :: Middleware

197123logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }

198124

199125-- | Development request logger middleware.

126+-- Implemented on top of "logCallbackDev", but prints to 'stdout'

200127--

201−-- This uses the 'Detailed' 'True' logging format and logs to 'stdout'.

202−{-# NOINLINE logStdoutDev #-}

128+-- Flushes 'stdout' on each request, which would be inefficient in production use.

129+-- Use "logStdout" in production.

203130logStdoutDev :: Middleware

204131logStdoutDev = unsafePerformIO $ mkRequestLogger def

205132

@@ -259,63 +186,49 @@ ansiStatusCode' c t = case S8.take 1 c of

259186 "5" -> ansiColor' Magenta t

260187 _ -> ansiColor' Blue t

261188

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−

296189detailedMiddleware' :: Callback

297190 -> (Color -> BS.ByteString -> [BS.ByteString])

298191 -> (BS.ByteString -> [BS.ByteString])

299192 -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])

300193 -> Middleware

301194detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do

195+ let mlen = lookup "content-length" (requestHeaders req) >>= readInt

302196 (req', body) <-

303− -- second tuple item should not be necessary, but a test runner might mess it up

304− case (requestBodyLength req, contentLength (requestHeaders req)) of

197+ case mlen of

305198 -- log the request body if it is small

306− (KnownLength len, _) | len <= 2048 -> getRequestBody req

307− (_, Just len) | len <= 2048 -> getRequestBody req

199+ Just len | len <= 2048 -> do

200+ let loop front = do

201+ bs <- requestBody req

202+ if S8.null bs

203+ then return $ front []

204+ else loop $ front . (bs:)

205+ body <- loop id

206+ -- logging the body here consumes it, so fill it back up

207+ -- obviously not efficient, but this is the development logger

208+ --

209+ -- Note: previously, we simply used CL.sourceList. However,

210+ -- that meant that you could read the request body in twice.

211+ -- While that in itself is not a problem, the issue is that,

212+ -- in production, you wouldn't be able to do this, and

213+ -- therefore some bugs wouldn't show up during testing. This

214+ -- implementation ensures that each chunk is only returned

215+ -- once.

216+ ichunks <- newIORef body

217+ let rbody = atomicModifyIORef ichunks $ \chunks ->

218+ case chunks of

219+ [] -> ([], S8.empty)

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

221+ let req' = req { requestBody = rbody }

222+ return (req', body)

308223 _ -> return (req, [])

309224

310− let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"]

311− reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body

312225 postParams <- if requestMethod req `elem` ["GET", "HEAD"]

313226 then return []

314227 else do postParams <- liftIO $ allPostParams body

315228 return $ collectPostParams postParams

316229

317230 let getParams = map emptyGetParam $ queryString req

318− accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req

231+ accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req

319232 params = let par | not $ null postParams = [pack (show postParams)]

320233 | not $ null getParams = [pack (show getParams)]

321234 | otherwise = []

@@ -334,7 +247,7 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse

334247 -- log the status of the response

335248 cb $ mconcat $ map toLogStr $

336249 ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++

337− params ++ reqbody ++

250+ params ++

338251 ansiColor White " Accept: " ++ [accept, "\n"] ++

339252 if isRaw then [] else

340253 ansiColor White " Status: " ++

@@ -362,7 +275,10 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse

362275 collectPostParams (postParams, files) = postParams ++

363276 map (\(k,v) -> (k, "FILE: " <> fileName v)) files

364277

365−

278+ readInt bs =

279+ case reads $ unpack bs of

280+ (i, _):_ -> Just (i :: Int)

281+ [] -> Nothing

366282

367283statusBS :: Response -> BS.ByteString

368284statusBS = pack . show . statusCode . responseStatus

wai-extra/Network/Wai/Middleware/RequestLogger/Internal.hs+2−6

@@ -8,10 +8,9 @@ module Network.Wai.Middleware.RequestLogger.Internal

88

99import Data.ByteString (ByteString)

1010import Network.Wai.Logger (clockDateCacher)

11−#if !MIN_VERSION_wai_logger(2, 2, 0)

1211import Control.Concurrent (forkIO, threadDelay)

1312import Control.Monad (forever)

14−#endif

13+

1514import System.Log.FastLogger (LogStr, fromLogStr)

1615

1716logToByteString :: LogStr -> ByteString

@@ -19,15 +18,12 @@ logToByteString = fromLogStr

1918

2019getDateGetter :: IO () -- ^ flusher

2120 -> IO (IO ByteString)

22−#if !MIN_VERSION_wai_logger(2, 2, 0)

2321getDateGetter flusher = do

2422 (getter, updater) <- clockDateCacher

23+#if !MIN_VERSION_wai_logger(2, 2, 0)

2524 _ <- forkIO $ forever $ do

2625 threadDelay 1000000

2726 updater

2827 flusher

29−#else

30−getDateGetter _ = do

31− (getter, _) <- clockDateCacher

3228#endif

3329 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 #-}

2−{-# LANGUAGE CPP #-}

3−

1+{-# LANGUAGE OverloadedStrings #-}

42module 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

35−

36− -- * Operating on 'Request's

37−

38− , rewriteRequest

39− , rewriteRequestPure

3+ ( rewrite, rewritePure

404 ) where

415

426import Network.Wai

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

448import Data.Text (Text)

45−import Data.Functor.Identity (Identity(..))

469import qualified Data.Text.Encoding as TE

4710import qualified Data.Text as T

4811import Network.HTTP.Types as H

4912

50−-- GHC ≤ 7.10 does not export Applicative functions from the prelude.

51−#if __GLASGOW_HASKELL__ <= 710

52−import Control.Applicative

53−#endif

54−

55−-- $howto

56−-- This module provides 'Middleware' to rewrite URL paths. It also provides

57−-- functions that will convert a 'Request' to a modified 'Request'.

58−-- Both operations require a function that takes URL parameters and

59−-- headers, and returns new URL parameters. Parameters are pieces of URL

60−-- paths and query parameters.

61−--

62−-- If you are a new user of the library, use 'rewriteWithQueries' or

63−-- 'rewritePureWithQueries' for middleware. For modifying 'Request's

64−-- directly, use 'rewriteRequest' or 'rewriteRequestPure'.

6513

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

14+-- | rewrite based on your own conversion rules

15+rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware

16+rewrite convert app req sendResponse = do

17+ newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)

18+ let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo

19+ app req { pathInfo = newPathInfo, rawPathInfo = rawPInfo } sendResponse

9920

100−-- $takeover

101−-- Let’s say we want to replace a website written in PHP with one written

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

21+-- | rewrite based on your own conversion rules

22+-- Example convert function:

16023

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]

177−-- 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

24+-- staticConvert :: [Text] -> H.RequestHeaders -> [Text]

25+-- staticConvert pieces _ = piecesConvert pieces

18826-- where

18927-- piecesConvert [] = ["static", "html", "pages.html"]

19028-- 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.

24129rewritePure :: ([Text] -> H.RequestHeaders -> [Text]) -> Middleware

24230rewritePure 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)

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

324− pure newReq { 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 #-}

31+ let pInfo = convert (pathInfo req) (requestHeaders req)

32+ rawPInfo = TE.encodeUtf8 $ T.intercalate "/" pInfo

33+ in app req { pathInfo = pInfo, rawPathInfo = rawPInfo }

wai-extra/Network/Wai/Middleware/Routed.hsdeleted−39

@@ -1,39 +0,0 @@

1−-- |

2−--

3−-- Since 3.0.9

4−module Network.Wai.Middleware.Routed

5− ( routedMiddleware

6− , hostedMiddleware

7− ) where

8−

9−import Network.Wai

10−import Data.ByteString (ByteString)

11−import Data.Text (Text)

12−

13−-- | Apply a middleware based on a test of pathInfo

14−--

15−-- example:

16−--

17−-- > let corsify = routedMiddleWare ("static" `elem`) addCorsHeaders

18−--

19−-- Since 3.0.9

20−routedMiddleware :: ([Text] -> Bool) -- ^ Only use middleware if this pathInfo test returns True

21− -> Middleware -- ^ middleware to apply the path prefix guard to

22− -> Middleware -- ^ modified middleware

23−routedMiddleware pathCheck middle app req

24− | pathCheck (pathInfo req) = middle app req

25− | otherwise = app req

26−

27−-- | Only apply the middleware to certain hosts

28−--

29−-- Since 3.0.9

30−hostedMiddleware :: ByteString -- ^ Domain the middleware applies to

31− -> Middleware -- ^ middleware to apply the path prefix guard to

32− -> Middleware -- ^ modified middleware

33−hostedMiddleware domain middle app req

34− | hasDomain domain req = middle app req

35− | otherwise = app req

36−

37−hasDomain :: ByteString -> Request -> Bool

38−hasDomain domain req = maybe False (== domain) mHost

39− where mHost = requestHeaderHost req

wai-extra/Network/Wai/Middleware/StreamFile.hs+3−2

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

1+{-# LANGUAGE OverloadedStrings #-}

2+

13-- |

24--

35-- Since 3.0.4

@@ -9,7 +11,6 @@ import Network.Wai.Internal

911import Network.Wai (Middleware, responseToStream)

1012import qualified Data.ByteString.Char8 as S8

1113import System.PosixCompat (getFileStatus, fileSize, FileOffset)

12−import Network.HTTP.Types (hContentLength)

1314

1415-- |Convert ResponseFile type responses into ResponseStream type

1516--

@@ -33,7 +34,7 @@ streamFile app env sendResponse = app env $ \res ->

3334 sendBody :: StreamingBody -> IO ResponseReceived

3435 sendBody body = do

3536 len <- getFileSize fp

36− let hs' = (hContentLength, (S8.pack (show len))) : hs

37+ let hs' = ("Content-Length", (S8.pack (show len))) : hs

3738 sendResponse $ responseStream s hs' body

3839 _ -> sendResponse res

3940

wai-extra/Network/Wai/Middleware/StripHeaders.hsdeleted−45

@@ -1,45 +0,0 @@

1−-- This was written for one specific use case and then generalized.

2−

3−-- The specific use case was a JSON API with a consumer that would choke on the

4−-- "Set-Cookie" response header. The solution was to test for the API's

5−-- `pathInfo` in the Request and if it matched, filter the response headers.

6−

7−-- When using this, care should be taken not to strip out headers that are

8−-- required for correct operation of the client (eg Content-Type).

9−

10−module Network.Wai.Middleware.StripHeaders

11− ( stripHeader

12− , stripHeaders

13− , stripHeaderIf

14− , stripHeadersIf

15− ) where

16−

17−import Network.Wai (Middleware, Request, modifyResponse, mapResponseHeaders, ifRequest)

18−import Network.Wai.Internal (Response)

19−import Data.ByteString (ByteString)

20−

21−import qualified Data.CaseInsensitive as CI

22−

23−stripHeader :: ByteString -> (Response -> Response)

24−stripHeader h = mapResponseHeaders (filter (\ hdr -> fst hdr /= CI.mk h))

25−

26−stripHeaders :: [ByteString] -> (Response -> Response)

27−stripHeaders hs =

28− let hnames = map CI.mk hs

29− in mapResponseHeaders (filter (\ hdr -> fst hdr `notElem` hnames))

30−

31−-- | If the request satisifes the provided predicate, strip headers matching

32−-- the provided header name.

33−--

34−-- Since 3.0.8

35−stripHeaderIf :: ByteString -> (Request -> Bool) -> Middleware

36−stripHeaderIf h rpred =

37− ifRequest rpred (modifyResponse $ stripHeader h)

38−

39−-- | If the request satisifes the provided predicate, strip all headers whose

40−-- header name is in the list of provided header names.

41−--

42−-- Since 3.0.8

43−stripHeadersIf :: [ByteString] -> (Request -> Bool) -> Middleware

44−stripHeadersIf hs rpred

45− = ifRequest rpred (modifyResponse $ stripHeaders hs)

wai-extra/Network/Wai/Middleware/Timeout.hsdeleted−33

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

1−-- | Timeout requests

2−module Network.Wai.Middleware.Timeout

3− ( timeout

4− , timeoutStatus

5− , timeoutAs

6− ) where

7−

8−import Network.HTTP.Types (Status, status503)

9−import Network.Wai

10−import qualified System.Timeout as Timeout

11−

12−-- | Time out the request after the given number of seconds

13−--

14−-- Timeouts respond with @'status503'@. See @'timeoutStatus'@ or @'timeoutAs'@

15−-- to customize the behavior of the timed-out case.

16−--

17−-- @since 3.0.24.0@

18−timeout :: Int -> Middleware

19−timeout = timeoutStatus status503

20−

21−-- | Time out with the given @'Status'@

22−--

23−-- @since 3.0.24.0@

24−timeoutStatus :: Status -> Int -> Middleware

25−timeoutStatus status = timeoutAs $ responseLBS status [] ""

26−

27−-- | Time out with the given @'Response'@

28−--

29−-- @since 3.0.24.0@

30−timeoutAs :: Response -> Int -> Middleware

31−timeoutAs timeoutReponse seconds app req respond =

32− maybe (respond timeoutReponse) pure

33− =<< Timeout.timeout (seconds * 1000000) (app req respond)

wai-extra/Network/Wai/Middleware/Vhost.hs+3−5

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

1−{-# LANGUAGE CPP #-}

2− module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where

1+{-# LANGUAGE OverloadedStrings #-}

2+module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where

33

44import Network.Wai

55

@@ -7,9 +7,7 @@ import Network.HTTP.Types as H

77import qualified Data.Text.Encoding as TE

88import Data.Text (Text)

99import qualified Data.ByteString as BS

10−#if __GLASGOW_HASKELL__ < 710

1110import Data.Monoid (mappend)

12−#endif

1311

1412vhost :: [(Request -> Bool, Application)] -> Application -> Application

1513vhost vhosts def req =

@@ -29,7 +27,7 @@ redirectIf home cond app req sendResponse =

2927

3028redirectTo :: BS.ByteString -> Response

3129redirectTo location = responseLBS H.status301

32− [ (H.hContentType, "text/plain") , (H.hLocation, location) ] "Redirect"

30+ [ ("Content-Type", "text/plain") , ("Location", location) ] "Redirect"

3331

3432redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response

3533redirectToLogged logger loc = do

wai-extra/Network/Wai/Parse.hs+86−368

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

23{-# LANGUAGE ExistentialQuantification #-}

34{-# LANGUAGE PatternGuards #-}

45{-# LANGUAGE TypeFamilies #-}

@@ -11,7 +12,6 @@ module Network.Wai.Parse

1112 , RequestBodyType (..)

1213 , getRequestBodyType

1314 , sinkRequestBody

14− , sinkRequestBodyEx

1515 , BackEnd

1616 , lbsBackEnd

1717 , tempFileBackEnd

@@ -20,24 +20,6 @@ module Network.Wai.Parse

2020 , File

2121 , FileInfo (..)

2222 , parseContentType

23− , ParseRequestBodyOptions

24− , defaultParseRequestBodyOptions

25− , noLimitParseRequestBodyOptions

26− , parseRequestBodyEx

27− , setMaxRequestKeyLength

28− , clearMaxRequestKeyLength

29− , setMaxRequestNumFiles

30− , clearMaxRequestNumFiles

31− , setMaxRequestFileSize

32− , clearMaxRequestFileSize

33− , setMaxRequestFilesSize

34− , clearMaxRequestFilesSize

35− , setMaxRequestParmsSize

36− , clearMaxRequestParmsSize

37− , setMaxHeaderLines

38− , clearMaxHeaderLines

39− , setMaxHeaderLineLength

40− , clearMaxHeaderLineLength

4123#if TEST

4224 , Bound (..)

4325 , findBound

@@ -48,30 +30,21 @@ module Network.Wai.Parse

4830#endif

4931 ) where

5032

51−import qualified Control.Exception as E

33+import qualified Data.ByteString.Search as Search

5234import qualified Data.ByteString as S

5335import qualified Data.ByteString.Lazy as L

5436import qualified Data.ByteString.Char8 as S8

5537import Data.Word (Word8)

56−import Data.Int (Int64)

57−import Data.Maybe (catMaybes, fromMaybe)

38+import Data.Maybe (fromMaybe)

5839import Data.List (sortBy)

5940import Data.Function (on, fix)

6041import System.Directory (removeFile, getTemporaryDirectory)

6142import System.IO (hClose, openBinaryTempFile)

62−import System.IO.Error (isDoesNotExistError)

6343import Network.Wai

6444import qualified Network.HTTP.Types as H

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

66−import Control.Exception (catchJust)

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

45+import Control.Monad (when, unless)

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

6947import Data.IORef

70−import Network.HTTP.Types (hContentType)

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

72−import Data.CaseInsensitive (mk)

73−

74−import Prelude hiding (lines)

7548

7649breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

7750breakDiscard w s =

@@ -121,7 +94,7 @@ lbsBackEnd _ _ popper =

12194tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath

12295tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

12396

124−-- | Same as 'tempFileBackEnd', but use configurable temp folders and patterns.

97+-- | Same as 'tempFileSink', but use configurable temp folders and patterns.

12598tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory

12699 -> String -- ^ filename pattern

127100 -> InternalState

@@ -129,9 +102,11 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory

129102 -> ignored2

130103 -> IO S.ByteString

131104 -> 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

105+tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do

106+ (key, (fp, h)) <- flip runInternalState internalState $ allocate (do

107+ tempDir <- getTmpDir

108+ openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)

109+ _ <- runInternalState (register $ removeFile fp) internalState

135110 fix $ \loop -> do

136111 bs <- popper

137112 unless (S.null bs) $ do

@@ -139,150 +114,6 @@ tempFileBackEndOpts getTmpDir pattrn internalState _ _ popper = do

139114 loop

140115 release key

141116 return fp

142− where

143− it = do

144− tempDir <- getTmpDir

145− openBinaryTempFile tempDir pattrn

146− removeFileQuiet fp = catchJust (guard . isDoesNotExistError)

147− (removeFile fp)

148− (const $ return ())

149−

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

151−-- the parseRequestBodyEx function.

152−--

153−-- @since 3.0.16.0

154−data ParseRequestBodyOptions = ParseRequestBodyOptions

155− { -- | The maximum length of a filename

156− prboKeyLength :: Maybe Int

157− , -- | The maximum number of files.

158− prboMaxNumFiles :: Maybe Int

159− , -- | The maximum filesize per file.

160− prboMaxFileSize :: Maybe Int64

161− , -- | The maximum total filesize.

162− prboMaxFilesSize :: Maybe Int64

163− , -- | The maximum size of the sum of all parameters

164− prboMaxParmsSize :: Maybe Int

165− , -- | The maximum header lines per mime/multipart entry

166− prboMaxHeaderLines :: Maybe Int

167− , -- | The maximum header line length per mime/multipart entry

168− prboMaxHeaderLineLength :: Maybe Int }

169−

170−-- | Set the maximum length of a filename.

171−--

172−-- @since 3.0.16.0

173−setMaxRequestKeyLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions

174−setMaxRequestKeyLength l p = p { prboKeyLength=Just l }

175−

176−-- | Do not limit the length of filenames.

177−--

178−-- @since 3.0.16.0

179−clearMaxRequestKeyLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions

180−clearMaxRequestKeyLength p = p { prboKeyLength=Nothing }

181−

182−-- | Set the maximum number of files per request.

183−--

184−-- @since 3.0.16.0

185−setMaxRequestNumFiles :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions

186−setMaxRequestNumFiles l p = p { prboMaxNumFiles=Just l }

187−

188−-- | Do not limit the maximum number of files per request.

189−--

190−-- @since 3.0.16.0

191−clearMaxRequestNumFiles :: ParseRequestBodyOptions -> ParseRequestBodyOptions

192−clearMaxRequestNumFiles p = p { prboMaxNumFiles=Nothing }

193−

194−-- | Set the maximum filesize per file (in bytes).

195−--

196−-- @since 3.0.16.0

197−setMaxRequestFileSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions

198−setMaxRequestFileSize l p = p { prboMaxFileSize=Just l }

199−

200−-- | Do not limit the maximum filesize per file.

201−--

202−-- @since 3.0.16.0

203−clearMaxRequestFileSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions

204−clearMaxRequestFileSize p = p { prboMaxFileSize=Nothing }

205−

206−-- | Set the maximum size of all files per request.

207−--

208−-- @since 3.0.16.0

209−setMaxRequestFilesSize :: Int64 -> ParseRequestBodyOptions -> ParseRequestBodyOptions

210−setMaxRequestFilesSize l p = p { prboMaxFilesSize=Just l }

211−

212−-- | Do not limit the maximum size of all files per request.

213−--

214−-- @since 3.0.16.0

215−clearMaxRequestFilesSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions

216−clearMaxRequestFilesSize p = p { prboMaxFilesSize=Nothing }

217−

218−-- | Set the maximum size of the sum of all parameters.

219−--

220−-- @since 3.0.16.0

221−setMaxRequestParmsSize :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions

222−setMaxRequestParmsSize l p = p { prboMaxParmsSize=Just l }

223−

224−-- | Do not limit the maximum size of the sum of all parameters.

225−--

226−-- @since 3.0.16.0

227−clearMaxRequestParmsSize :: ParseRequestBodyOptions -> ParseRequestBodyOptions

228−clearMaxRequestParmsSize p = p { prboMaxParmsSize=Nothing }

229−

230−-- | Set the maximum header lines per mime/multipart entry.

231−--

232−-- @since 3.0.16.0

233−setMaxHeaderLines :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions

234−setMaxHeaderLines l p = p { prboMaxHeaderLines=Just l }

235−

236−-- | Do not limit the maximum header lines per mime/multipart entry.

237−--

238−-- @since 3.0.16.0

239−clearMaxHeaderLines:: ParseRequestBodyOptions -> ParseRequestBodyOptions

240−clearMaxHeaderLines p = p { prboMaxHeaderLines=Nothing }

241−

242−-- | Set the maximum header line length per mime/multipart entry.

243−--

244−-- @since 3.0.16.0

245−setMaxHeaderLineLength :: Int -> ParseRequestBodyOptions -> ParseRequestBodyOptions

246−setMaxHeaderLineLength l p = p { prboMaxHeaderLineLength=Just l }

247−

248−-- | Do not limit the maximum header lines per mime/multipart entry.

249−--

250−-- @since 3.0.16.0

251−clearMaxHeaderLineLength :: ParseRequestBodyOptions -> ParseRequestBodyOptions

252−clearMaxHeaderLineLength p = p { prboMaxHeaderLineLength=Nothing }

253−

254−-- | A reasonable default set of parsing options.

255−-- Maximum key/filename length: 32 bytes;

256−-- maximum files: 10; filesize unlimited; maximum

257−-- size for parameters: 64kbytes; maximum number of header

258−-- lines: 32 bytes (applies only to headers of a mime/multipart message);

259−-- maximum header line length: Apache's default for that is 8190 bytes

260−-- (http://httpd.apache.org/docs/2.2/mod/core.html#limitrequestline)

261−-- so we're using that here as well.

262−--

263−-- @since 3.0.16.0

264−defaultParseRequestBodyOptions :: ParseRequestBodyOptions

265−defaultParseRequestBodyOptions = ParseRequestBodyOptions

266− { prboKeyLength=Just 32

267− , prboMaxNumFiles=Just 10

268− , prboMaxFileSize=Nothing

269− , prboMaxFilesSize=Nothing

270− , prboMaxParmsSize=Just 65336

271− , prboMaxHeaderLines=Just 32

272− , prboMaxHeaderLineLength=Just 8190 }

273−

274−-- | Do not impose any memory limits.

275−--

276−-- @since 3.0.21.0

277−noLimitParseRequestBodyOptions :: ParseRequestBodyOptions

278−noLimitParseRequestBodyOptions = ParseRequestBodyOptions

279− { prboKeyLength=Nothing

280− , prboMaxNumFiles=Nothing

281− , prboMaxFileSize=Nothing

282− , prboMaxFilesSize=Nothing

283− , prboMaxParmsSize=Nothing

284− , prboMaxHeaderLines=Nothing

285− , prboMaxHeaderLineLength=Nothing }

286117

287118-- | Information on an uploaded file.

288119data FileInfo c = FileInfo

@@ -305,19 +136,11 @@ type BackEnd a = S.ByteString -- ^ parameter name

305136 -> IO S.ByteString

306137 -> IO a

307138

308−-- | The mimetype of the http body.

309−-- Depending on whether just parameters or parameters and files

310−-- are passed, one or the other mimetype should be used.

311−data RequestBodyType

312− = -- | application/x-www-form-urlencoded (parameters only)

313− UrlEncoded

314− | -- | multipart/form-data (parameters and files)

315− Multipart S.ByteString

139+data RequestBodyType = UrlEncoded | Multipart S.ByteString

316140

317−-- | Get the mimetype of the body of an http request.

318141getRequestBodyType :: Request -> Maybe RequestBodyType

319142getRequestBodyType req = do

320− ctype' <- lookup hContentType $ requestHeaders req

143+ ctype' <- lookup "Content-Type" $ requestHeaders req

321144 let (ctype, attrs) = parseContentType ctype'

322145 case ctype of

323146 "application/x-www-form-urlencoded" -> return UrlEncoded

@@ -327,7 +150,7 @@ getRequestBodyType req = do

327150-- | Parse a content type value, turning a single @ByteString@ into the actual

328151-- content type and a list of pairs of attributes.

329152--

330−-- @since 1.3.2

153+-- Since 1.3.2

331154parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)])

332155parseContentType a = do

333156 let (ctype, b) = S.break (== semicolon) a

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

337160 semicolon = 59

338161 equals = 61

339162 space = 32

340− dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote

341− then S.tail $ S.init s

342− else s

343163 goAttrs front bs

344164 | S.null bs = front []

345165 | otherwise =

@@ -348,140 +168,79 @@ parseContentType a = do

348168 goAttr bs =

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

350170 v = S.drop 1 v'

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

171+ in (strip k, strip v)

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

353173

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.

360174parseRequestBody :: BackEnd y

361175 -> Request

362176 -> IO ([Param], [File y])

363−parseRequestBody = parseRequestBodyEx noLimitParseRequestBodyOptions

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 =

177+parseRequestBody s r =

376178 case getRequestBodyType r of

377179 Nothing -> return ([], [])

378− Just rbt -> sinkRequestBodyEx o s rbt (requestBody r)

180+ Just rbt -> sinkRequestBody s rbt (requestBody r)

379181

380182sinkRequestBody :: BackEnd y

381183 -> RequestBodyType

382184 -> IO S.ByteString

383185 -> IO ([Param], [File y])

384−sinkRequestBody = sinkRequestBodyEx noLimitParseRequestBodyOptions

385−

386−-- |

387−--

388−-- @since 3.0.16.0

389−sinkRequestBodyEx :: ParseRequestBodyOptions

390− -> BackEnd y

391− -> RequestBodyType

392− -> IO S.ByteString

393− -> IO ([Param], [File y])

394−sinkRequestBodyEx o s r body = do

395− ref <- newIORef ([], [])

186+sinkRequestBody s r body = do

187+ ref <- newIORef (id, id)

396188 let add x = atomicModifyIORef ref $ \(y, z) ->

397189 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 ())

408− -> IO ()

409−conduitRequestBodyEx o _ UrlEncoded rbody add = do

190+ Left y' -> ((y . (y':), z), ())

191+ Right z' -> ((y, z . (z':)), ())

192+ conduitRequestBody s r body add

193+ (x, y) <- readIORef ref

194+ return (x [], y [])

195+

196+conduitRequestBody :: BackEnd y

197+ -> RequestBodyType

198+ -> IO S.ByteString

199+ -> (Either Param (File y) -> IO ())

200+ -> IO ()

201+conduitRequestBody _ UrlEncoded rbody add = do

410202 -- NOTE: in general, url-encoded data will be in a single chunk.

411203 -- Therefore, I'm optimizing for the usual case by sticking with

412204 -- strict byte strings here.

413− let loop size front = do

205+ let loop front = do

414206 bs <- rbody

415207 if S.null bs

416208 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

209+ else loop $ front . (bs:)

210+ bs <- loop id

425211 mapM_ (add . Left) $ H.parseSimpleQuery bs

426−conduitRequestBodyEx o backend (Multipart bound) rbody add =

427− parsePiecesEx o backend (S8.pack "--" `S.append` bound) rbody add

428−

212+conduitRequestBody backend (Multipart bound) rbody add =

213+ parsePieces backend (S8.pack "--" `S.append` bound) rbody add

429214

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)

434−takeLine maxlen src =

435− go ""

215+takeLine :: Source -> IO (Maybe S.ByteString)

216+takeLine src =

217+ go id

436218 where

437219 go front = do

438220 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 ()

444221 if S.null bs

445222 then close front

446223 else push front bs

447224

448− close front = leftover src front >> return Nothing

225+ close front = leftover src (front S.empty) >> return Nothing

449226 push front bs = do

450− let (x, y) = S.break (== 10) bs -- LF

227+ let (x, y) = S.break (== 10) $ front bs -- LF

451228 in if S.null y

452− then go $ front `S.append` x

229+ then go $ S.append x

453230 else do

454231 when (S.length y > 1) $ leftover src $ S.drop 1 y

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

462−

463−takeLines' :: Maybe Int -> Maybe Int -> Source -> IO [S.ByteString]

464−takeLines' lineLength maxLines source =

465− reverse <$> takeLines'' [] lineLength maxLines source

466−

467−takeLines''

468− :: [S.ByteString]

469− -> Maybe Int

470− -> Maybe Int

471− -> Source

472− -> IO [S.ByteString]

473−takeLines'' lines lineLength maxLines src = do

474− case maxLines of

475− Just maxLines' ->

476− when (length lines > maxLines') $

477− error "Too many lines in mime/multipart header"

478− Nothing -> return ()

479− res <- takeLine lineLength src

232+ return $ Just $ killCR x

233+

234+takeLines :: Source -> IO [S.ByteString]

235+takeLines src = do

236+ res <- takeLine src

480237 case res of

481− Nothing -> return lines

238+ Nothing -> return []

482239 Just l

483− | S.null l -> return lines

484− | otherwise -> takeLines'' (l:lines) lineLength maxLines src

240+ | S.null l -> return []

241+ | otherwise -> do

242+ ls <- takeLines src

243+ return $ l : ls

485244

486245data Source = Source (IO S.ByteString) (IORef S.ByteString)

487246

@@ -500,20 +259,17 @@ readSource (Source f ref) = do

500259leftover :: Source -> S.ByteString -> IO ()

501260leftover (Source _ ref) bs = writeIORef ref bs

502261

503−parsePiecesEx :: ParseRequestBodyOptions

504− -> BackEnd y

505− -> S.ByteString

506− -> IO S.ByteString

507− -> (Either Param (File y) -> IO ())

508− -> IO ()

509−parsePiecesEx o sink bound rbody add =

510− mkSource rbody >>= loop 0 0 0 0

262+parsePieces :: BackEnd y

263+ -> S.ByteString

264+ -> IO S.ByteString

265+ -> (Either Param (File y) -> IO ())

266+ -> IO ()

267+parsePieces sink bound rbody add =

268+ mkSource rbody >>= loop

511269 where

512− loop :: Int -> Int -> Int -> Int64 -> Source -> IO ()

513− loop numParms numFiles parmSize filesSize src = do

514− _boundLine <- takeLine (prboMaxHeaderLineLength o) src

515− res' <- takeLines' (prboMaxHeaderLineLength o)

516− (prboMaxHeaderLines o) src

270+ loop src = do

271+ _boundLine <- takeLine src

272+ res' <- takeLines src

517273 unless (null res') $ do

518274 let ls' = map parsePair res'

519275 let x = do

@@ -524,57 +280,31 @@ parsePiecesEx o sink bound rbody add =

524280 return (ct, name, lookup "filename" attrs)

525281 case x of

526282 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 ()

536283 let ct = fromMaybe "application/octet-stream" mct

537284 fi0 = FileInfo filename ct ()

538− fs = catMaybes [ prboMaxFileSize o

539− , subtract filesSize <$> prboMaxFilesSize o ]

540− mfs = if fs == [] then Nothing else Just $ minimum fs

541− ((wasFound, fileSize), y) <- sinkTillBound' bound name fi0 sink src mfs

542− let newFilesSize = filesSize + fileSize

285+ (wasFound, y) <- sinkTillBound' bound name fi0 sink src

543286 add $ Right (name, fi0 { fileContent = y })

544− when wasFound $ loop numParms (numFiles + 1) parmSize newFilesSize src

287+ when wasFound (loop src)

545288 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 ()

551289 let seed = id

552290 let iter front bs = return $ front . (:) bs

553− ((wasFound, _fileSize), front) <- sinkTillBound bound iter seed src

554− (fromIntegral <$> prboMaxParmsSize o)

291+ (wasFound, front) <- sinkTillBound bound iter seed src

555292 let bs = S.concat $ front []

556293 let x' = (name, bs)

557− let newParmSize = parmSize + S.length name + S.length bs

558− case prboMaxParmsSize o of

559− Just maxParmSize -> when (newParmSize > maxParmSize) $

560− error "Maximum size of parameters exceeded"

561− Nothing -> return ()

562294 add $ Left x'

563− when wasFound $ loop (numParms + 1) numFiles

564− newParmSize filesSize src

295+ when wasFound (loop src)

565296 _ -> do

566297 -- ignore this part

567298 let seed = ()

568299 iter () _ = return ()

569− ((wasFound, _fileSize), ()) <- sinkTillBound bound iter seed src Nothing

570− when wasFound $ loop numParms numFiles parmSize filesSize src

300+ (wasFound, ()) <- sinkTillBound bound iter seed src

301+ when wasFound (loop src)

571302 where

572− contDisp = mk $ S8.pack "Content-Disposition"

573− contType = mk $ S8.pack "Content-Type"

303+ contDisp = S8.pack "Content-Disposition"

304+ contType = S8.pack "Content-Type"

574305 parsePair s =

575306 let (x, y) = breakDiscard 58 s -- colon

576− in (mk $ x, S.dropWhile (== 32) y) -- space

577−

307+ in (x, S.dropWhile (== 32) y) -- space

578308

579309data Bound = FoundBound S.ByteString S.ByteString

580310 | NoBound

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

582312 deriving (Eq, Show)

583313

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

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

315+findBound b bs = handleBreak $ Search.breakOn b bs

586316 where

587317 handleBreak (h, t)

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

@@ -609,10 +339,9 @@ sinkTillBound' :: S.ByteString

609339 -> FileInfo ()

610340 -> BackEnd y

611341 -> 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'

342+ -> IO (Bool, y)

343+sinkTillBound' bound name fi sink src = do

344+ (next, final) <- wrapTillBound bound src

616345 y <- sink name fi next

617346 b <- final

618347 return (b, y)

@@ -621,40 +350,30 @@ data WTB = WTBWorking (S.ByteString -> S.ByteString)

621350 | WTBDone Bool

622351wrapTillBound :: S.ByteString -- ^ bound

623352 -> 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

353+ -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found

354+wrapTillBound bound src = do

627355 ref <- newIORef $ WTBWorking id

628− sref <- newIORef (0 :: Int64)

629− return (go ref sref, final ref sref)

356+ return (go ref, final ref)

630357 where

631− final ref sref = do

358+ final ref = do

632359 x <- readIORef ref

633360 case x of

634361 WTBWorking _ -> error "wrapTillBound did not finish"

635− WTBDone y -> do

636− siz <- readIORef sref

637− return (y, siz)

362+ WTBDone y -> return y

638363

639− go ref sref = do

364+ go ref = do

640365 state <- readIORef ref

641366 case state of

642367 WTBDone _ -> return S.empty

643368 WTBWorking front -> do

644369 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 ()

651370 if S.null bs

652371 then do

653372 writeIORef ref $ WTBDone False

654373 return $ front bs

655374 else push $ front bs

656375 where

657− push bs = do

376+ push bs =

658377 case findBound bound bs of

659378 FoundBound before after -> do

660379 let before' = killCRLF before

@@ -670,20 +389,19 @@ wrapTillBound bound src max' = do

670389 else (bs, id)

671390 writeIORef ref $ WTBWorking front'

672391 if S.null toEmit

673− then go ref sref

392+ then go ref

674393 else return toEmit

675394 PartialBound -> do

676395 writeIORef ref $ WTBWorking $ S.append bs

677− go ref sref

396+ go ref

678397

679398sinkTillBound :: S.ByteString

680399 -> (x -> S.ByteString -> IO x)

681400 -> x

682401 -> Source

683− -> Maybe Int64

684− -> IO ((Bool, Int64), x)

685−sinkTillBound bound iter seed0 src max' = do

686− (next, final) <- wrapTillBound bound src max'

402+ -> IO (Bool, x)

403+sinkTillBound bound iter seed0 src = do

404+ (next, final) <- wrapTillBound bound src

687405 let loop seed = do

688406 bs <- next

689407 if S.null bs

wai-extra/Network/Wai/Request.hs+4−54

@@ -1,25 +1,18 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

1+{-# LANGUAGE OverloadedStrings #-}

22-- | Some helpers for interrogating a WAI 'Request'.

33

44module Network.Wai.Request

55 ( appearsSecure

66 , guessApproot

7− , RequestSizeException(..)

8− , requestSizeCheck

97 ) where

108

119import Data.ByteString (ByteString)

1210import Data.Maybe (fromMaybe)

1311import Network.HTTP.Types (HeaderName)

14−import Network.Wai

12+import Network.Wai (Request, isSecure, requestHeaders, requestHeaderHost)

1513

1614import qualified Data.ByteString as S

1715import 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−

2316

2417-- | Does this request appear to have been made over an SSL connection?

2518--

@@ -32,14 +25,13 @@ import Data.IORef (atomicModifyIORef', newIORef)

3225-- force a non-SSL request to SSL by redirect. One can safely choose not to

3326-- redirect when the request /appears/ secure, even if it's actually not.

3427--

35−-- @since 3.0.7

28+-- Since 3.0.7

3629appearsSecure :: Request -> Bool

3730appearsSecure request = isSecure request || any (uncurry matchHeader)

3831 [ ("HTTPS" , (== "on"))

3932 , ("HTTP_X_FORWARDED_SSL" , (== "on"))

4033 , ("HTTP_X_FORWARDED_SCHEME", (== "https"))

4134 , ("HTTP_X_FORWARDED_PROTO" , ((== ["https"]) . take 1 . C.split ','))

42− , ("X-Forwarded-Proto" , (== "https")) -- Used by Nginx and AWS ELB.

4335 ]

4436

4537 where

@@ -52,50 +44,8 @@ appearsSecure request = isSecure request || any (uncurry matchHeader)

5244-- application. For more information and relevant caveats, please see

5345-- "Network.Wai.Middleware.Approot".

5446--

55−-- @since 3.0.7

47+-- Since 3.0.7

5648guessApproot :: Request -> ByteString

5749guessApproot req =

5850 (if appearsSecure req then "https://" else "http://") `S.append`

5951 (fromMaybe "localhost" $ requestHeaderHost req)

60−

61−-- | see 'requestSizeCheck'

62−--

63−-- @since 3.0.15

64−data RequestSizeException

65− = RequestSizeException Word64

66− deriving (Eq, Ord, Typeable)

67−

68−instance Exception RequestSizeException

69−

70−instance Show RequestSizeException where

71− showsPrec p (RequestSizeException limit) =

72− showString ("Request Body is larger than ") . showsPrec p limit . showString " bytes."

73−

74−-- | Check request body size to avoid server crash when request is too large.

75−--

76−-- This function first checks @'requestBodyLength'@, if content-length is known

77−-- but larger than limit, or it's unknown but we have received too many chunks,

78−-- a 'RequestSizeException' are thrown when user use @'requestBody'@ to extract

79−-- request body inside IO.

80−--

81−-- @since 3.0.15

82−requestSizeCheck :: Word64 -> Request -> IO Request

83−requestSizeCheck maxSize req =

84− case requestBodyLength req of

85− KnownLength len ->

86− if len > maxSize

87− then return $ req { requestBody = throwIO (RequestSizeException maxSize) }

88− else return req

89− ChunkedBody -> do

90− currentSize <- newIORef 0

91− return $ req

92− { requestBody = do

93− bs <- requestBody req

94− total <-

95− atomicModifyIORef' currentSize $ \sz ->

96− let nextSize = sz + fromIntegral (S.length bs)

97− in (nextSize, nextSize)

98− if total > maxSize

99− then throwIO (RequestSizeException maxSize)

100− else return bs

101− }

wai-extra/Network/Wai/Test.hs+35−28

@@ -39,20 +39,21 @@ import Data.Monoid (mempty, mappend)

3939

4040import Network.Wai

4141import Network.Wai.Internal (ResponseReceived (ResponseReceived))

42−import Network.Wai.Test.Internal

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

4443import Control.Monad.Trans.Class (lift)

4544import qualified Control.Monad.Trans.State as ST

46−import Control.Monad.Trans.Reader (runReaderT, ask)

45+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)

4746import Control.Monad (unless)

4847import Control.DeepSeq (deepseq)

4948import Control.Exception (throwIO, Exception)

5049import Data.Typeable (Typeable)

50+import Data.Map (Map)

5151import qualified Data.Map as Map

5252import qualified Web.Cookie as Cookie

5353import Data.ByteString (ByteString)

5454import qualified Data.ByteString.Char8 as S8

55−import Data.ByteString.Builder (toLazyByteString)

55+import Blaze.ByteString.Builder (toLazyByteString, toByteString)

56+import qualified Blaze.ByteString.Builder as B

5657import qualified Data.ByteString.Lazy as L

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

5859import qualified Network.HTTP.Types as H

@@ -63,6 +64,17 @@ import qualified Data.Text.Encoding as TE

6364import Data.IORef

6465import Data.Time.Clock (getCurrentTime)

6566

67+type Session = ReaderT Application (ST.StateT ClientState IO)

68+

69+-- |

70+--

71+-- Since 3.0.6

72+type ClientCookies = Map ByteString Cookie.SetCookie

73+

74+data ClientState = ClientState

75+ { clientCookies :: ClientCookies

76+ }

77+

6678-- |

6779--

6880-- Since 3.0.6

@@ -92,17 +104,15 @@ deleteClientCookie cookieName =

92104 modifyClientCookies

93105 (Map.delete cookieName)

94106

95−-- | See also: 'runSessionWith'.

107+initState :: ClientState

108+initState = ClientState Map.empty

109+

96110runSession :: Session a -> Application -> IO a

97111runSession session app = ST.evalStateT (runReaderT session app) initState

98112

99113data SRequest = SRequest

100114 { simpleRequest :: Request

101115 , 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'.

106116 }

107117data SResponse = SResponse

108118 { simpleStatus :: H.Status

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

110120 , simpleBody :: L.ByteString

111121 }

112122 deriving (Show, Eq)

113−

114123request :: 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

124+request = srequest . flip SRequest L.empty

123125

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

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

126128setPath req path = req {

127129 pathInfo = segments

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

130+ , rawPathInfo = B.toByteString (H.encodePathSegments segments)

129131 , queryString = query

130132 , rawQueryString = (H.renderQuery True query)

131133 }

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

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

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

156158 ]

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

159+ let cookieValue = toByteString $ Cookie.renderCookies cookiePairs

158160 addCookieHeader rest

159161 | null cookiePairs = rest

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

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

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

179181 return response

180182

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

182−-- 'L.ByteString'.

183183srequest :: SRequest -> Session SResponse

184184srequest (SRequest req bod) = do

185+ app <- ask

185186 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− }

187+ let req' = req

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

189+ case bss of

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

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

192+ }

193+ req'' <- addCookiesToRequest req'

194+ response <- liftIO $ do

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

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

197+ readIORef ref

198+ extractSetCookieFromSResponse response

193199

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

195201runResponse ref res = do

@@ -331,3 +337,4 @@ assertClientCookieValue s cookieName cookieValue = do

331337 ]

332338 )

333339 (Cookie.setCookieValue c == cookieValue)

340+

wai-extra/Network/Wai/Test/Internal.hsdeleted−35

@@ -1,35 +0,0 @@

1−module Network.Wai.Test.Internal where

2−

3−import Network.Wai

4−import qualified Control.Monad.Trans.State as ST

5−import Control.Monad.Trans.Reader (ReaderT, runReaderT)

6−import Data.Map (Map)

7−import qualified Data.Map as Map

8−import qualified Web.Cookie as Cookie

9−import Data.ByteString (ByteString)

10−

11−type Session = ReaderT Application (ST.StateT ClientState IO)

12−

13−-- |

14−--

15−-- Since 3.0.6

16−type ClientCookies = Map ByteString Cookie.SetCookie

17−

18−data ClientState = ClientState

19− { clientCookies :: ClientCookies

20− }

21−

22−-- |

23−--

24−-- Since 3.0.20.0

25−initState :: ClientState

26−initState = ClientState Map.empty

27−

28−-- | Like 'runSession', but if allows you to hand in cookies and get

29−-- the updated cookies back. One use case for this is writing tests

30−-- that address the application under test alternatingly through rest

31−-- api and through db handle.

32−--

33−-- Since 3.0.20.0

34−runSessionWith :: ClientState -> Session a -> Application -> IO (a, ClientState)

35−runSessionWith st session app = ST.runStateT (runReaderT session app) st

wai-extra/Network/Wai/UrlMap.hs+2−2

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

1−{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

1+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}

22{-# LANGUAGE ExistentialQuantification #-}

33{- | This module gives you a way to mount applications under sub-URIs.

44For example:

@@ -93,7 +93,7 @@ instance ToApplication UrlMap where

9393 Nothing ->

9494 sendResponse $ responseLBS

9595 status404

96− [(hContentType, "text/plain")]

96+ [("content-type", "text/plain")]

9797 "Not found\n"

9898

9999 where

wai-extra/README.md+1−14

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

1−# wai-extra

1+## wai-extra

22

33The goal here is to provide common features without many dependencies.

4−

5−

6−## Example using Server-Sent Events ##

7−

8−There is a small example using Server-Sent Events (SSE) in the

9−`./example` directory.

10−

11−Run the commands below to start the server on http://localhost:8080

12−

13−```

14−$ stack build .

15−$ stack exec example

16−```

wai-extra/app/Main.hsnew file+55

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

1+{-# LANGUAGE OverloadedStrings #-}

2+module Main where

3+

4+import Control.Monad

5+import Control.Concurrent (forkIO, threadDelay)

6+import Control.Monad.Trans (liftIO)

7+import Control.Concurrent.Chan

8+import Network.Wai.Handler.Warp (run)

9+import Network.Wai.Middleware.Gzip (gzip, def)

10+import Network.Wai

11+import Network.HTTP.Types (status200)

12+import Data.Time.Clock.POSIX

13+import Blaze.ByteString.Builder.Char.Utf8 (fromString)

14+import qualified Data.Conduit as C

15+

16+import Network.Wai.EventSource

17+

18+app :: Chan ServerEvent -> Application

19+app chan req =

20+ case pathInfo req of

21+ [] -> return $ ResponseFile status200 [("Content-Type", "text/html")] "static/index.html" Nothing

22+ ["esold"] -> eventSourceAppChan chan req

23+ ["eschan"] -> eventSourceAppChan chan req

24+ ["esio"] -> eventSourceAppIO eventIO req

25+ ["essrc"] -> eventSourceAppSource eventSource req

26+ _ -> error "unexpected pathInfo"

27+

28+eventChan :: Chan ServerEvent -> IO ()

29+eventChan chan = forever $ do

30+ threadDelay 1000000

31+ time <- getPOSIXTime

32+ writeChan chan (ServerEvent Nothing Nothing [fromString . show $ time])

33+

34+eventIO :: IO ServerEvent

35+eventIO = do

36+ threadDelay 1000000

37+ time <- getPOSIXTime

38+ return $ ServerEvent (Just $ fromString "io")

39+ Nothing

40+ [fromString . show $ time]

41+

42+eventSource :: C.Source (C.ResourceT IO) ServerEvent

43+eventSource = forever $ do

44+ time <- liftIO $ do

45+ threadDelay 1000000

46+ getPOSIXTime

47+ C.yield $ ServerEvent (Just $ fromString "source")

48+ Nothing

49+ [fromString . show $ time]

50+

51+main = do

52+ chan <- newChan

53+ _ <- forkIO . eventChan $ chan

54+ run 8080 (gzip def $ app chan)

55+

wai-extra/example/index.html → wai-extra/app/index.htmlrenamed+2−3

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

11<!doctype html>

22<head>

3− <title>Example</title>

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

3+ <title>Hello</title>

54</head>

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

5+<h1>Testing</h1>

76

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

98

wai-extra/example/Main.hsdeleted−62

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

1−{-# LANGUAGE OverloadedStrings #-}

2−module Main where

3−

4−import Data.ByteString.Builder (string8)

5−import Control.Concurrent (forkIO, threadDelay)

6−import Control.Concurrent.Chan

7−import Control.Monad

8−import Data.Time.Clock.POSIX (getPOSIXTime)

9−import Network.HTTP.Types (status200)

10−import Network.Wai (Application, Middleware, pathInfo, responseFile)

11−import Network.Wai.EventSource (ServerEvent(..), eventSourceAppChan, eventSourceAppIO)

12−import Network.Wai.Handler.Warp (run)

13−import Network.Wai.Middleware.AddHeaders (addHeaders)

14−import Network.Wai.Middleware.Gzip (gzip, def)

15−

16−

17−app :: Chan ServerEvent -> Application

18−app chan req respond =

19− case pathInfo req of

20− [] -> respond $ responseFile status200 [("Content-Type", "text/html")] "example/index.html" Nothing

21− ["esold"] -> eventSourceAppChan chan req respond

22− ["eschan"] -> eventSourceAppChan chan req respond

23− ["esio"] -> eventSourceAppIO eventIO req respond

24− _ -> error "unexpected pathInfo"

25−

26−eventChan :: Chan ServerEvent -> IO ()

27−eventChan chan = forever $ do

28− threadDelay 1000000

29− time <- getPOSIXTime

30− writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time])

31−

32−eventIO :: IO ServerEvent

33−eventIO = do

34− threadDelay 1000000

35− time <- getPOSIXTime

36− return $ ServerEvent (Just $ string8 "io")

37− Nothing

38− [string8 . show $ time]

39−

40−eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO ()

41−eventRaw = handle 0

42− where

43− handle counter emit flush = do

44− threadDelay 1000000

45− _ <- emit $ ServerEvent (Just $ string8 "raw")

46− Nothing

47− [string8 . show $ counter]

48− _ <- flush

49− handle (counter + 1) emit flush

50−

51−main :: IO ()

52−main = do

53− chan <- newChan

54− _ <- forkIO . eventChan $ chan

55− run 8080 (gzip def $ headers $ app chan)

56− where

57− -- headers required for SSE to work through nginx

58− -- not required if using warp directly

59− headers :: Middleware

60− headers = addHeaders [ ("X-Accel-Buffering", "no")

61− , ("Cache-Control", "no-cache")

62− ]

wai-extra/test/Network/Wai/Middleware/ForceSSLSpec.hs+5−9

@@ -8,7 +8,6 @@ import Test.Hspec

88

99import Network.Wai.Middleware.ForceSSL

1010

11−import Control.Monad

1211import Data.ByteString (ByteString)

1312import Data.Monoid ((<>))

1413import Network.HTTP.Types (methodPost, status200, status301, status307)

@@ -19,12 +18,8 @@ main :: IO ()

1918main = hspec spec

2019

2120spec :: 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

21+spec = describe "forceSSL" $ do

22+ let host = "example.com"

2823

2924 it "redirects non-https requests to https" $ do

3025 resp <- runApp host forceSSL defaultRequest

@@ -44,7 +39,7 @@ hostSpec host = describe ("forceSSL on host " <> show host <> "") $ do

4439

4540 simpleStatus resp `shouldBe` status200

4641

47− it "preserves the original host, path, and query string" $ do

42+ it "preserves the original path and query string" $ do

4843 resp <- runApp host forceSSL defaultRequest

4944 { rawPathInfo = "/foo/bar"

5045 , rawQueryString = "?baz=bat"

@@ -55,6 +50,7 @@ hostSpec host = describe ("forceSSL on host " <> show host <> "") $ do

5550

5651runApp :: ByteString -> Middleware -> Request -> IO SResponse

5752runApp host mw req = runSession

58− (request req { requestHeaderHost = Just host }) $ mw app

53+ (request req { requestHeaderHost = Just $ host <> ":80" }) $ mw app

54+

5955 where

6056 app _ respond = respond $ responseLBS status200 [] ""

wai-extra/test/Network/Wai/Middleware/RoutedSpec.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Network.Wai.Middleware.RoutedSpec

3− ( main

4− , spec

5− ) where

6−

7−import Test.Hspec

8−

9−import Network.Wai.Middleware.Routed

10−import Network.Wai.Middleware.ForceSSL (forceSSL)

11−

12−import Network.HTTP.Types (hContentType, status200)

13−import Network.Wai

14−import Network.Wai.Test

15−import Data.ByteString (ByteString)

16−import Data.String (IsString)

17−

18−main :: IO ()

19−main = hspec spec

20−

21−spec :: Spec

22−spec = describe "forceSSL" $ do

23− it "routed middleware" $ do

24− let destination = "https://example.com/d/"

25− let routedSslJsonApp prefix = routedMiddleware (checkPrefix prefix) forceSSL jsonApp

26− checkPrefix p (p1:_) = p == p1

27− checkPrefix _ _ = False

28−

29− flip runSession (routedSslJsonApp "r") $ do

30− res <- testDPath "http"

31− assertNoHeader location res

32− assertStatus 200 res

33− assertBody "{\"foo\":\"bar\"}" res

34−

35− flip runSession (routedSslJsonApp "d") $ do

36− res2 <- testDPath "http"

37− assertHeader location destination res2

38− assertStatus 301 res2

39−

40−jsonApp :: Application

41−jsonApp _req cps = cps $ responseLBS status200

42− [(hContentType, "application/json")]

43− "{\"foo\":\"bar\"}"

44−

45−testDPath :: ByteString -> Session SResponse

46−testDPath proto =

47− request $ flip setRawPathInfo "/d/" defaultRequest

48− { requestHeaders = [("X-Forwarded-Proto", proto)]

49− , requestHeaderHost = Just "example.com"

50− }

51−

52−location :: IsString ci => ci

53−location = "Location"

wai-extra/test/Network/Wai/Middleware/StripHeadersSpec.hsdeleted−58

@@ -1,58 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Network.Wai.Middleware.StripHeadersSpec

3− ( main

4− , spec

5− ) where

6−

7−import Test.Hspec

8−

9−import Network.Wai.Middleware.AddHeaders

10−import Network.Wai.Middleware.StripHeaders

11−

12−import Control.Arrow (first)

13−import Data.ByteString (ByteString)

14−import Data.Monoid ((<>))

15−import Network.HTTP.Types (status200)

16−import Network.Wai

17−import Network.Wai.Test

18−

19−import qualified Data.CaseInsensitive as CI

20−

21−

22−main :: IO ()

23−main = hspec spec

24−

25−

26−spec :: Spec

27−spec = describe "stripHeader" $ do

28− let host = "example.com"

29− let ciTestHeaders = map (first CI.mk) testHeaders

30−

31− it "strips a specific header" $ do

32− resp1 <- runApp host (addHeaders testHeaders) defaultRequest

33− resp2 <- runApp host (stripHeaderIf "Foo" (const False) . addHeaders testHeaders) defaultRequest

34− resp3 <- runApp host (stripHeaderIf "Foo" (const True) . addHeaders testHeaders) defaultRequest

35−

36− simpleHeaders resp1 `shouldBe` ciTestHeaders

37− simpleHeaders resp2 `shouldBe` ciTestHeaders

38− simpleHeaders resp3 `shouldBe` tail ciTestHeaders

39−

40− it "strips specific set of headers" $ do

41− resp1 <- runApp host (addHeaders testHeaders) defaultRequest

42− resp2 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const False) . addHeaders testHeaders) defaultRequest

43− resp3 <- runApp host (stripHeadersIf ["Bar", "Foo"] (const True) . addHeaders testHeaders) defaultRequest

44−

45− simpleHeaders resp1 `shouldBe` ciTestHeaders

46− simpleHeaders resp2 `shouldBe` ciTestHeaders

47− simpleHeaders resp3 `shouldBe` [last ciTestHeaders]

48−

49−

50−testHeaders :: [(ByteString, ByteString)]

51−testHeaders = [("Foo", "fooey"), ("Bar", "barbican"), ("Baz", "bazooka")]

52−

53−

54−runApp :: ByteString -> Middleware -> Request -> IO SResponse

55−runApp host mw req = runSession

56− (request req { requestHeaderHost = Just $ host <> ":80" }) $ mw app

57− where

58− app _ respond = respond $ responseLBS status200 [] ""

wai-extra/test/Network/Wai/Middleware/TimeoutSpec.hsdeleted−57

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module Network.Wai.Middleware.TimeoutSpec

4− ( spec

5− ) where

6−

7−import Test.Hspec

8−

9−import Control.Concurrent (threadDelay)

10−import Network.HTTP.Types (status200, status503, status504)

11−import Network.Wai

12−import Network.Wai.Middleware.Timeout

13−import Network.Wai.Test

14−

15−spec :: Spec

16−spec = do

17− describe "timeout" $ do

18− it "times out slow requests with 503" $ do

19− let app _req respond = do

20− threadDelay $ 2 * 1000000

21− respond $ responseLBS status200 [] ""

22−

23− resp <- runApp $ timeout 1 app

24−

25− simpleStatus resp `shouldBe` status503

26−

27− it "does not time out fast requests" $ do

28− let app _req respond = respond $ responseLBS status200 [] ""

29−

30− resp <- runApp $ timeout 3 app

31−

32− simpleStatus resp `shouldBe` status200

33−

34− describe "timeoutStatus" $ do

35− it "allows customizing the timeout response status" $ do

36− let app _req respond = do

37− threadDelay $ 2 * 1000000

38− respond $ responseLBS status200 [] ""

39−

40− resp <- runApp $ timeoutStatus status504 1 app

41−

42− simpleStatus resp `shouldBe` status504

43−

44− describe "timeoutAs" $ do

45− it "allows customizing the timeout response" $ do

46− let app _req respond = do

47− threadDelay $ 2 * 1000000

48− respond $ responseLBS status200 [] ""

49− timeoutResponse = responseLBS status503 [("X-Timeout", "1")] ""

50−

51− resp <- runApp $ timeoutAs timeoutResponse 1 app

52−

53− simpleStatus resp `shouldBe` status503

54− simpleHeaders resp `shouldBe` [("X-Timeout", "1")]

55−

56−runApp :: Application -> IO SResponse

57−runApp = runSession $ request defaultRequest

wai-extra/test/Network/Wai/ParseSpec.hs−94

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

1313import qualified Data.Text as TS

1414import qualified Data.Text.Encoding as TE

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

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

1716

1817import Network.Wai

1918import Network.Wai.Test

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

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

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

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

3533 ]

3634 it "parseHttpAccept" caseParseHttpAccept

3735 describe "parseRequestBody" $ do

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

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

9694 let expected3 = (expectedsmap3, expectedfile3)

9795

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

99− unknownErrorException _ _ = False

100−

101−

102− let def = defaultParseRequestBodyOptions

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

10497 result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3

10598 result3 `shouldBe` expected3

@@ -107,61 +100,6 @@ caseParseRequestBody = do

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

108101 result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3

109102 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−

165103 where

166104 content2 =

167105 "--AaB03x\n"

@@ -185,27 +123,6 @@ caseParseRequestBody = do

185123 <> "Content-Type: application/octet-stream\r\n\r\n"

186124 <> "Photo blog using Hack.\n\r\n"

187125 <> "------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"

209126

210127caseMultipartPlus :: Assertion

211128caseMultipartPlus = do

@@ -281,14 +198,3 @@ toRequest' :: S8.ByteString -> S8.ByteString -> SRequest

281198toRequest' ctype content = SRequest defaultRequest

282199 { requestHeaders = [("Content-Type", ctype)]

283200 } (L.fromChunks $ map S.singleton $ S.unpack content)

284−

285−toRequest'' :: S8.ByteString -> S8.ByteString -> IO SRequest

286−toRequest'' ctype content = mkRB content >>= \b -> return $ SRequest defaultRequest

287− { requestHeaders = [("Content-Type", ctype)], requestBody = b

288− } (L.fromChunks $ map S.singleton $ S.unpack content)

289−

290−mkRB :: S8.ByteString -> IO (IO S8.ByteString)

291−mkRB content = do

292− r <- I.newIORef content

293− return $

294− I.atomicModifyIORef r $ \a -> (S8.empty, a)

wai-extra/test/Network/Wai/RequestSpec.hs+39−69

@@ -8,82 +8,52 @@ import Test.Hspec

88

99import Data.ByteString (ByteString)

1010import Network.HTTP.Types (HeaderName)

11−import Network.Wai (Request(..), defaultRequest, RequestBodyLength(..))

11+import Network.Wai (Request(..), defaultRequest)

1212

1313import Network.Wai.Request

14−import Control.Exception (try)

15−import Control.Monad (forever)

1614

1715main :: IO ()

1816main = hspec spec

1917

2018spec :: 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

19+spec = describe "appearsSecure" $ do

20+ let insecureRequest = defaultRequest

21+ { isSecure = False

22+ , requestHeaders =

23+ [ ("HTTPS", "off")

24+ , ("HTTP_X_FORWARDED_SSL", "off")

25+ , ("HTTP_X_FORWARDED_SCHEME", "http")

26+ , ("HTTP_X_FORWARDED_PROTO", "http,xyz")

27+ ]

28+ }

29+

30+ it "returns False for an insecure request" $

31+ insecureRequest `shouldSatisfy` not . appearsSecure

32+

33+ it "checks if the Request is actually secure" $ do

34+ let req = insecureRequest { isSecure = True }

35+

36+ req `shouldSatisfy` appearsSecure

37+

38+ it "checks for HTTP: on" $ do

39+ let req = addHeader "HTTPS" "on" insecureRequest

40+

41+ req `shouldSatisfy` appearsSecure

42+

43+ it "checks for HTTP_X_FORWARDED_SSL: on" $ do

44+ let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest

45+

46+ req `shouldSatisfy` appearsSecure

47+

48+ it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do

49+ let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest

50+

51+ req `shouldSatisfy` appearsSecure

52+

53+ it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do

54+ let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest

55+

56+ req `shouldSatisfy` appearsSecure

8757

8858addHeader :: HeaderName -> ByteString -> Request -> Request

8959addHeader name value req = req

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

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

33

44import Control.Monad (void)

55

6−import qualified Data.IORef as IORef

7−

86import qualified Data.Text.Encoding as TE

97

108import Data.Time.Calendar (fromGregorian)

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

1816import Network.HTTP.Types (status200)

1917

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

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

22−import Data.ByteString (ByteString)

19+import Blaze.ByteString.Builder (toByteString)

2320

2421import qualified Web.Cookie as Cookie

2522

2623main :: IO ()

2724main = hspec spec

2825

29−toByteString :: Builder -> ByteString

30−toByteString = L8.toStrict . toLazyByteString

31−

3226spec :: Spec

3327spec = do

3428 describe "setPath" $ do

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

5549 it "sets rawQueryString to empty string" $ do

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

5751

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−

7452 describe "request" $ do

7553

76− let echoApp req respond = do

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

78− let reqHeaders = requestHeaders req

54+ let simpleApp _req respond =

7955 respond $

8056 responseLBS

8157 status200

82− reqHeaders

83− reqBody

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

59+ "simple"

8460

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

86− sresp <- runSession (request defaultRequest) echoApp

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

62+ sresp <- runSession (request defaultRequest) simpleApp

8763 simpleStatus sresp `shouldBe` status200

8864

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− }

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

66+ sresp <- runSession (request defaultRequest) simpleApp

67+ simpleBody sresp `shouldBe` "simple"

68+

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

70+ sresp <- runSession (request defaultRequest) simpleApp

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

10672

10773 let cookieApp req respond =

wai-extra/test/WaiExtraSpec.hs+3−1

@@ -341,8 +341,10 @@ caseDebugRequestBody = do

341341 }

342342 where

343343 params = [("foo", "bar"), ("baz", "bin")]

344+ -- FIXME change back once we include post parameter output in logging

345+ -- postOutput = T.pack $ "POST \nAccept: \n Params: " ++ (show params)

344346 -- the time cannot be known, so match around it

345− postOutput = (T.pack $ "POST /\n Params: " ++ (show params), "s\n")

347+ postOutput = ("POST /\n Accept: \n Status: 200 OK 0", "s\n")

346348 getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n")

347349

348350 debugApp (beginning, ending) req send = do

wai-extra/wai-extra.cabal+15−52

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

11Name: wai-extra

2−Version: 3.0.29.1

2+Version: 3.0.7.1

33Synopsis: Provides some basic WAI handlers and middleware.

44description:

55 Provides basic WAI handler and middleware functionality:

@@ -71,7 +71,7 @@ Maintainer: michael@snoyman.com

7171Homepage: http://github.com/yesodweb/wai

7272Category: Web

7373Build-Type: Simple

74−Cabal-Version: >=1.10

74+Cabal-Version: >=1.8

7575Stability: Stable

7676extra-source-files:

7777 test/requests/dalvik-request

@@ -81,52 +81,43 @@ extra-source-files:

8181 ChangeLog.md

8282 README.md

8383

84−flag build-example

85− description: Build example executable.

86− manual: True

87− default: False

88−

8984Library

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

91− , bytestring >= 0.10.4

92− , wai >= 3.0.3.0 && < 3.3

85+ Build-Depends: base >= 4 && < 5

86+ , bytestring >= 0.9.1.4

87+ , wai >= 3.0 && < 3.1

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

9489 , time >= 1.1.4

95− , network >= 2.6.1.0

90+ , network >= 2.2.1.5

9691 , directory >= 1.0.1

9792 , transformers >= 0.2.2

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

9894 , http-types >= 0.7

9995 , text >= 0.7

10096 , case-insensitive >= 0.2

10197 , data-default-class

102− , fast-logger >= 2.4.5

103− , wai-logger >= 2.3.2

98+ , fast-logger >= 2.1 && < 2.4

99+ , wai-logger >= 2.0 && < 2.3

104100 , ansi-terminal

105− , resourcet >= 0.4.6 && < 1.3

101+ , resourcet >= 0.4.6 && < 1.2

106102 , void >= 0.5

103+ , stringsearch >= 0.3 && < 0.4

107104 , containers

108105 , base64-bytestring

109106 , word8

107+ , lifted-base >= 0.1.2

110108 , deepseq

111− , streaming-commons >= 0.2

109+ , streaming-commons

112110 , unix-compat

113111 , cookie

114112 , vault

115− , zlib

116− , aeson

117− , iproute

118− , http2

119113

120114 if os(windows)

121115 cpp-options: -DWINDOWS

122116 else

123117 build-depends: unix

124118

125− default-extensions: OverloadedStrings

126−

127119 Exposed-modules: Network.Wai.Handler.CGI

128120 Network.Wai.Handler.SCGI

129− Network.Wai.Header

130121 Network.Wai.Middleware.AcceptOverride

131122 Network.Wai.Middleware.AddHeaders

132123 Network.Wai.Middleware.Approot

@@ -134,47 +125,24 @@ Library

134125 Network.Wai.Middleware.CleanPath

135126 Network.Wai.Middleware.Local

136127 Network.Wai.Middleware.RequestLogger

137− Network.Wai.Middleware.RequestLogger.JSON

138128 Network.Wai.Middleware.Gzip

139129 Network.Wai.Middleware.Jsonp

140130 Network.Wai.Middleware.MethodOverride

141131 Network.Wai.Middleware.MethodOverridePost

142132 Network.Wai.Middleware.Rewrite

143− Network.Wai.Middleware.StripHeaders

144133 Network.Wai.Middleware.Vhost

145134 Network.Wai.Middleware.HttpAuth

146135 Network.Wai.Middleware.StreamFile

147− Network.Wai.Middleware.ForceDomain

148136 Network.Wai.Middleware.ForceSSL

149− Network.Wai.Middleware.Routed

150− Network.Wai.Middleware.Timeout

151137 Network.Wai.Parse

152138 Network.Wai.Request

153139 Network.Wai.UrlMap

154140 Network.Wai.Test

155− Network.Wai.Test.Internal

156141 Network.Wai.EventSource

157142 Network.Wai.EventSource.EventStream

158143 other-modules: Network.Wai.Middleware.RequestLogger.Internal

159− default-language: Haskell2010

160144 ghc-options: -Wall

161145

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−

178146test-suite spec

179147 type: exitcode-stdio-1.0

180148 hs-source-dirs: test

@@ -184,9 +152,6 @@ test-suite spec

184152 Network.Wai.RequestSpec

185153 Network.Wai.Middleware.ApprootSpec

186154 Network.Wai.Middleware.ForceSSLSpec

187− Network.Wai.Middleware.RoutedSpec

188− Network.Wai.Middleware.StripHeadersSpec

189− Network.Wai.Middleware.TimeoutSpec

190155 WaiExtraSpec

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

192157 , wai-extra

@@ -200,12 +165,10 @@ test-suite spec

200165 , resourcet

201166 , bytestring

202167 , HUnit

168+ , blaze-builder

203169 , cookie

204170 , time

205− , case-insensitive

206− , http2

207− ghc-options: -Wall

208− default-language: Haskell2010

171+ ghc-options: -Wall -Werror

209172

210173source-repository head

211174 type: git

wai-frontend-monadcgi/ChangeLog.md+1−7

@@ -1,7 +1 @@

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

1+No changes logged yet.

wai-frontend-monadcgi/Network/Wai/Frontend/MonadCGI.hs+1−4

@@ -64,8 +64,5 @@ getCgiVars :: Request -> [(String, String)]

6464getCgiVars e =

6565 [ ("PATH_INFO", S8.unpack $ rawPathInfo e)

6666 , ("REQUEST_METHOD", show $ requestMethod e)

67− , ("QUERY_STRING",

68− case S8.unpack $ rawQueryString e of

69− '?':rest -> rest

70− x -> x)

67+ , ("QUERY_STRING", S8.unpack $ rawQueryString e)

7168 ]

wai-frontend-monadcgi/wai-frontend-monadcgi.cabal+2−2

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

11name: wai-frontend-monadcgi

2−version: 3.0.0.3

2+version: 3.0.0.1

33license: MIT

44license-file: LICENSE

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

@@ -20,7 +20,7 @@ library

2020 , http-types

2121 , transformers

2222 , case-insensitive

23− , wai >= 3.0 && < 3.3

23+ , wai >= 3.0 && < 3.1

2424 exposed-modules: Network.Wai.Frontend.MonadCGI

2525 ghc-options: -Wall

2626

wai-handler-fastcgi/.gitignorenew file+4

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

1+/dist/

2+*.swp

3+*.hi

4+*.o

wai-handler-fastcgi/ChangeLog.mdnew file+1

@@ -0,0 +1 @@

1+No changes logged yet.

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

The content is the same.

wai-handler-fastcgi/Network/Wai/Handler/FastCGI.hscnew file+192

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

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+{-# LANGUAGE EmptyDataDecls #-}

3+{-# LANGUAGE CPP #-}

4+-----------------------------------------------------------------------------

5+-- |

6+-- Module : Network.Wai.Handler.FastCGI

7+-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006, (c) Michael Snoyman 2010

8+-- License : BSD-style (see the file libraries/network/LICENSE)

9+--

10+-- Maintainer : michael@snoyman.com

11+-- Stability : experimental

12+-- Portability : non-portable (uses FFI)

13+--

14+-- Interface for FastCGI <http://fastcgi.com/>, using the fcgiapp API.

15+-- Totally ripped off by Michael Snoyman to work with Hack, then WAI.

16+--

17+-----------------------------------------------------------------------------

18+module Network.Wai.Handler.FastCGI

19+ ( run

20+ , runSendfile

21+ , runFork

22+ ) where

23+

24+import Control.Monad ( liftM, forever )

25+import Data.Word (Word8)

26+import Foreign ( Ptr, castPtr, nullPtr, peekArray0

27+ , throwIfNeg_, mallocBytes, free )

28+#ifdef GHC_7_4

29+import Foreign.C (CInt(..), CString, CStringLen)

30+#else

31+import Foreign.C (CInt, CString, CStringLen)

32+#endif

33+import Control.Exception (finally)

34+import Foreign.Storable ( Storable (..) )

35+

36+import qualified Network.Wai as W

37+import qualified Network.Wai.Handler.CGI as CGI

38+

39+import qualified Data.ByteString as S

40+import qualified Data.ByteString.Char8 as S8

41+import qualified Data.ByteString as BS

42+import qualified Data.ByteString.Internal as BSB

43+import qualified Data.ByteString.Unsafe as BSB

44+

45+import Control.Arrow ((***))

46+

47+#include <fcgiapp.h>

48+

49+------------------------------------------------------------------------

50+

51+data FCGX_Stream

52+type StreamPtr = Ptr FCGX_Stream

53+type Environ = Ptr CString

54+

55+------------------------------------------------------------------------

56+

57+foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr

58+ :: CString -> CInt -> StreamPtr -> IO CInt

59+

60+foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr

61+ :: CString -> CInt -> StreamPtr -> IO CInt

62+

63+

64+------------------------------------------------------------------------

65+

66+foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init

67+ :: IO CInt

68+

69+runFork :: Maybe S.ByteString -> (IO () -> IO a) -> Int -> W.Application -> IO ()

70+runFork sf fork threads app = do

71+ testReturn "FCGX_Init" $ fcgx_init

72+ let oneThread = forever $ oneRequest app sf

73+ mapM_ fork $ replicate (threads - 1) oneThread

74+ oneThread

75+

76+-- | Handle FastCGI requests in an infinite loop.

77+run :: W.Application -> IO ()

78+run = runFork Nothing id 1

79+

80+-- | Handle FastCGI requests in an infinite loop. For a server which supports

81+-- the X-Sendfile header.

82+runSendfile :: S.ByteString -> W.Application -> IO ()

83+runSendfile sf = runFork (Just sf) id 1

84+

85+oneRequest :: W.Application

86+ -> Maybe S.ByteString -- X-Sendfile

87+ -> IO ()

88+oneRequest app xsendfile = withRequest $ \r -> do

89+ putStrLn "Received 1 request"

90+ env <- peekEnvp r

91+ ins <- peekIn r

92+ outs <- peekOut r

93+ handleRequest app ins outs env xsendfile

94+

95+peekIn, peekOut :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)

96+peekIn = (#peek FCGX_Request, in)

97+peekOut = (#peek FCGX_Request, out)

98+

99+peekEnvp :: Ptr FCGX_Request -> IO Environ

100+peekEnvp = (#peek FCGX_Request, envp)

101+

102+foreign import ccall unsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest

103+ :: Ptr FCGX_Request -> CInt -> CInt -> IO CInt

104+

105+foreign import ccall safe "fcgiapp.h FCGX_Accept_r" fcgx_accept_r

106+ :: Ptr FCGX_Request -> IO CInt

107+

108+acceptRequest :: IO (Ptr FCGX_Request)

109+acceptRequest = do

110+ reqp <- mallocBytes (#size FCGX_Request)

111+ initAndAccept reqp

112+ return reqp

113+ where initAndAccept reqp = do

114+ testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0

115+ testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp

116+

117+withRequest :: (Ptr FCGX_Request -> IO ()) -> IO ()

118+withRequest f = do

119+ req <- acceptRequest

120+ f req `finally` finishRequest req

121+

122+foreign import ccall unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r

123+ :: Ptr FCGX_Request -> IO ()

124+

125+finishRequest :: Ptr FCGX_Request -> IO ()

126+finishRequest reqp = do

127+ fcgx_finish_r reqp

128+ free reqp

129+

130+handleRequest :: W.Application

131+ -> StreamPtr

132+ -> StreamPtr

133+ -> Environ

134+ -> Maybe S.ByteString -- sendfile

135+ -> IO ()

136+handleRequest f ins outs env xsendfile = do

137+ vars <- environToTable env

138+ let vars' = map (S8.unpack *** S8.unpack) vars

139+ let input = const $ sRead ins

140+ let hPut = sPutStr' outs

141+ CGI.runGeneric vars' (CGI.requestBodyFunc input) hPut xsendfile f

142+

143+data FCGX_Request

144+

145+--

146+-- * Stream IO

147+--

148+

149+sPutStr' :: StreamPtr -> BS.ByteString -> IO ()

150+sPutStr' h str =

151+ BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h

152+

153+fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO ()

154+fcgxPutCStringLen h (cs,len) =

155+ testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h

156+

157+sRead :: StreamPtr -> IO (Maybe BS.ByteString)

158+sRead h = buildByteString (fcgxGetBuf h) 4096

159+

160+fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int

161+fcgxGetBuf h p c =

162+ liftM fromIntegral $ fcgx_getStr (castPtr p) (fromIntegral c) h

163+

164+--

165+-- * ByteString utilities

166+--

167+

168+-- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary

169+-- reading functions.

170+buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO (Maybe BS.ByteString)

171+buildByteString f k = do

172+ ps <- BSB.createAndTrim k $ \p -> f p k

173+ case BS.length ps of

174+ 0 -> return Nothing

175+ _ -> return $ Just ps

176+

177+--

178+-- * Utilities

179+--

180+

181+testReturn :: String -> IO CInt -> IO ()

182+testReturn e = throwIfNeg_ (\n -> e ++ " failed with error code: "++ show n)

183+

184+environToTable :: Environ -> IO [(S.ByteString, S.ByteString)]

185+environToTable arr = do

186+ css <- peekArray0 nullPtr arr

187+ ss <- mapM S.packCString css

188+ return $ map splitEq ss

189+ where

190+ splitEq s =

191+ let (a, b) = S.breakByte 61 s

192+ in (a, S.drop 1 b)

wai-handler-fastcgi/READMEnew file

No changes to the content.

wai-handler-fastcgi/README.mdnew file+3

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

1+## wai-handler-fastcgi

2+

3+Calls out to the libfcgi C library.

wai-handler-fastcgi/Setup.lhsnew file+7

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-fastcgi/configurenew file+9

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

1+#!/bin/sh

2+#

3+

4+# subst standard header path variables

5+if test -n "$CPPFLAGS" ; then

6+ echo "Found CPPFLAGS in environment: '$CPPFLAGS'"

7+ sed 's,@CPPFLAGS@,'"$CPPFLAGS"',g;s,@LDFLAGS@,'"$LDFLAGS"',g' \

8+ < fastcgi.buildinfo.in > fastcgi.buildinfo

9+fi

wai-handler-fastcgi/fastcgi.buildinfo.innew file+3

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

1+ghc-options: -optc@CPPFLAGS@

2+cc-options: @CPPFLAGS@

3+ld-options: @LDFLAGS@

wai-handler-fastcgi/lighttpd.confnew file+19

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

1+# Run with lighttpd -D -f lighttpd.conf

2+server.port = 3000

3+server.document-root = "."

4+server.modules = ("mod_fastcgi", "mod_rewrite")

5+

6+url.rewrite-once = (

7+ "(.*)" => "/app/$1"

8+)

9+

10+fastcgi.server = (

11+ "/app" => ((

12+ "socket" => "/tmp/test.fastcgi.socket",

13+ "check-local" => "disable",

14+ "bin-path" => "./test",

15+ "min-procs" => 1,

16+ "max-procs" => 12,

17+ "idle-timeout" => 30

18+ ))

19+)

wai-handler-fastcgi/test.hsnew file+19

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.FastCGI

4+import Control.Monad.IO.Class

5+import qualified Data.ByteString.Lazy as L

6+import qualified Data.ByteString.Lazy.Char8 as L8

7+import qualified Data.Enumerator as E

8+

9+main = run app

10+

11+app req

12+ | pathInfo req == "/" = return $ responseLBS status200 [("Content-Type", "text/html")] "<form method='post' action='/post'><input type='text' name='name'><input type='submit'></form>"

13+app req = do

14+ bss <- E.consume

15+ return $ responseLBS status200 [("Content-Type", "text/plain")] $ L.concat

16+ [ L8.pack $ show $ requestHeaders req

17+ , "\n"

18+ , L.fromChunks bss

19+ ]

wai-handler-fastcgi/wai-handler-fastcgi.cabalnew file+31

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

1+name: wai-handler-fastcgi

2+version: 3.0.0.1

3+license: MIT

4+license-file: LICENSE

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

6+maintainer: Michael Snoyman <michael@snoyman.com>

7+synopsis: Wai handler to fastcgi

8+description: API docs and the README are available at <http://www.stackage.org/package/wai-handler-fastcgi>.

9+category: Web

10+stability: stable

11+cabal-version: >= 1.6

12+build-type: Configure

13+extra-source-files: configure fastcgi.buildinfo.in README.md ChangeLog.md

14+homepage: http://www.yesodweb.com/book/web-application-interface

15+

16+library

17+ build-depends: base >= 4 && < 5

18+ , wai >= 3.0 && < 3.1

19+ , wai-extra >= 3.0 && < 3.1

20+ , bytestring >= 0.9.1.4

21+ exposed-modules: Network.Wai.Handler.FastCGI

22+ ghc-options: -Wall

23+ includes: fcgiapp.h

24+ extra-libraries: fcgi

25+

26+ if impl(ghc >= 7.4)

27+ cpp-options: -DGHC_7_4

28+

29+source-repository head

30+ type: git

31+ location: git://github.com/yesodweb/wai.git

wai-handler-launch/.gitignorenew file+2

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

1+dist/

2+*.swp

wai-handler-launch/ChangeLog.mdnew file+7

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

1+## 3.0.0.3

2+

3+Allow blaze-builder 0.4

4+

5+## 3.0.0.2

6+

7+* Support for Win64

wai-http2-extra/LICENSE → wai-handler-launch/LICENSErenamed+1−1

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

22

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

44a copy of this software and associated documentation files (the

wai-handler-launch/Network/Wai/Handler/Launch.hsnew file+206

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

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ForeignFunctionInterface #-}

3+{-# LANGUAGE CPP #-}

4+module Network.Wai.Handler.Launch

5+ ( run

6+ , runUrl

7+ , runUrlPort

8+ ) where

9+

10+import Network.Wai

11+import Network.Wai.Internal

12+import Network.HTTP.Types

13+import qualified Network.Wai.Handler.Warp as Warp

14+import Data.IORef

15+import Data.Monoid (mappend)

16+import Control.Concurrent (forkIO, threadDelay)

17+import Control.Monad.IO.Class (liftIO)

18+import Control.Monad (unless)

19+import Control.Exception (throwIO)

20+import Data.Function (fix)

21+import qualified Data.ByteString as S

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

23+import qualified Blaze.ByteString.Builder as Blaze

24+#if WINDOWS

25+import Foreign

26+import Foreign.C.String

27+#else

28+import System.Process (rawSystem)

29+#endif

30+import Data.Streaming.Blaze (newBlazeRecv, defaultStrategy)

31+import qualified Data.Streaming.Zlib as Z

32+

33+ping :: IORef Bool -> Middleware

34+ping var app req sendResponse

35+ | pathInfo req == ["_ping"] = do

36+ liftIO $ writeIORef var True

37+ sendResponse $ responseLBS status200 [] ""

38+ | otherwise = app req $ \res -> do

39+ let isHtml hs =

40+ case lookup "content-type" hs of

41+ Just ct -> "text/html" `S.isPrefixOf` ct

42+ Nothing -> False

43+ if isHtml $ responseHeaders res

44+ then do

45+ let (s, hs, withBody) = responseToStream res

46+ (isEnc, headers') = fixHeaders id hs

47+ headers'' = filter (\(x, _) -> x /= "content-length") headers'

48+ withBody $ \body ->

49+ sendResponse $ responseStream s headers'' $ \sendChunk flush ->

50+ addInsideHead sendChunk flush $ \sendChunk' flush' ->

51+ if isEnc

52+ then decode sendChunk' flush' body

53+ else body sendChunk' flush'

54+ else sendResponse res

55+

56+decode :: (Builder -> IO ()) -> IO ()

57+ -> StreamingBody

58+ -> IO ()

59+decode sendInner flushInner streamingBody = do

60+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

61+ inflate <- Z.initInflate $ Z.WindowBits 31

62+ let send builder = blazeRecv builder >>= goBuilderPopper

63+ goBuilderPopper popper = fix $ \loop -> do

64+ bs <- popper

65+ unless (S.null bs) $ do

66+ Z.feedInflate inflate bs >>= goZlibPopper

67+ loop

68+ goZlibPopper popper = fix $ \loop -> do

69+ res <- popper

70+ case res of

71+ Z.PRDone -> return ()

72+ Z.PRNext bs -> do

73+ sendInner $ fromByteString bs

74+ loop

75+ Z.PRError e -> throwIO e

76+ streamingBody send (send flush)

77+ mbs <- blazeFinish

78+ case mbs of

79+ Nothing -> return ()

80+ Just bs -> Z.feedInflate inflate bs >>= goZlibPopper

81+ Z.finishInflate inflate >>= sendInner . fromByteString

82+

83+toInsert :: S.ByteString

84+toInsert = "<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping\",false);x.send();},60000)</script>"

85+

86+addInsideHead :: (Builder -> IO ())

87+ -> IO ()

88+ -> StreamingBody

89+ -> IO ()

90+addInsideHead sendInner flushInner streamingBody = do

91+ (blazeRecv, blazeFinish) <- newBlazeRecv defaultStrategy

92+ ref <- newIORef $ Just (S.empty, whole)

93+ streamingBody (inner blazeRecv ref) (flush blazeRecv ref)

94+ state <- readIORef ref

95+ mbs <- blazeFinish

96+ held <- case mbs of

97+ Nothing -> return state

98+ Just bs -> push state bs

99+ case state of

100+ Nothing -> return ()

101+ Just (held, _) -> sendInner $ fromByteString held `mappend` fromByteString toInsert

102+ where

103+ whole = "<head>"

104+

105+ flush blazeRecv ref = inner blazeRecv ref Blaze.flush

106+

107+ inner blazeRecv ref builder = do

108+ state0 <- readIORef ref

109+ popper <- blazeRecv builder

110+ let loop state = do

111+ bs <- popper

112+ if S.null bs

113+ then writeIORef ref state

114+ else push state bs >>= loop

115+ loop state0

116+

117+ push Nothing x = sendInner (fromByteString x) >> return Nothing

118+ push (Just (held, atFront)) x

119+ | atFront `S.isPrefixOf` x = do

120+ let y = S.drop (S.length atFront) x

121+ sendInner $ fromByteString held

122+ `mappend` fromByteString atFront

123+ `mappend` fromByteString toInsert

124+ `mappend` fromByteString y

125+ return Nothing

126+ | whole `S.isInfixOf` x = do

127+ let (before, rest) = S.breakSubstring whole x

128+ let after = S.drop (S.length whole) rest

129+ sendInner $ fromByteString held

130+ `mappend` fromByteString before

131+ `mappend` fromByteString whole

132+ `mappend` fromByteString toInsert

133+ `mappend` fromByteString after

134+ return Nothing

135+ | x `S.isPrefixOf` atFront = do

136+ let held' = held `S.append` x

137+ atFront' = S.drop (S.length x) atFront

138+ return $ Just (held', atFront')

139+ | otherwise = do

140+ let (held', atFront', x') = getOverlap whole x

141+ sendInner $ fromByteString held `mappend` fromByteString x'

142+ return $ Just (held', atFront')

143+

144+getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)

145+getOverlap whole x =

146+ go whole

147+ where

148+ go piece

149+ | S.null piece = ("", whole, x)

150+ | piece `S.isSuffixOf` x =

151+ let x' = S.take (S.length x - S.length piece) x

152+ atFront = S.drop (S.length piece) whole

153+ in (piece, atFront, x')

154+ | otherwise = go $ S.init piece

155+

156+fixHeaders :: ([Header] -> [Header])

157+ -> [Header]

158+ -> (Bool, [Header])

159+fixHeaders front [] = (False, front [])

160+fixHeaders front (("content-encoding", "gzip"):rest) = (True, front rest)

161+fixHeaders front (x:xs) = fixHeaders (front . (:) x) xs

162+

163+#if WINDOWS

164+foreign import ccall "launch"

165+ launch' :: Int -> CString -> IO ()

166+#endif

167+

168+launch :: Int -> String -> IO ()

169+

170+#if WINDOWS

171+launch port s = withCString s $ launch' port

172+#else

173+launch port s = forkIO (rawSystem

174+#if MAC

175+ "open"

176+#else

177+ "xdg-open"

178+#endif

179+ ["http://127.0.0.1:" ++ show port ++ "/" ++ s] >> return ()) >> return ()

180+#endif

181+

182+run :: Application -> IO ()

183+run = runUrl ""

184+

185+runUrl :: String -> Application -> IO ()

186+runUrl = runUrlPort 4587

187+

188+runUrlPort :: Int -> String -> Application -> IO ()

189+runUrlPort port url app = do

190+ x <- newIORef True

191+ _ <- forkIO $ Warp.runSettings

192+ ( Warp.setPort port

193+ $ Warp.setOnException (\_ _ -> return ())

194+ $ Warp.setHost "*4" Warp.defaultSettings)

195+ $ ping x app

196+ launch port url

197+ loop x

198+

199+loop :: IORef Bool -> IO ()

200+loop x = do

201+ let seconds = 120

202+ threadDelay $ 1000000 * seconds

203+ b <- readIORef x

204+ if b

205+ then writeIORef x False >> loop x

206+ else return ()

wai-handler-launch/READMEnew file

No changes to the content.

wai-handler-launch/README.mdnew file+4

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

1+## wai-handler-launch

2+

3+This handles cross-platform launching and inserts Javascript code to ping the

4+server. When the server no longer receives pings, it shuts down.

wai-handler-launch/Setup.lhsnew file+7

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-launch/runtests.hsnew file+22

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai.Handler.Launch (insideHead)

3+import Test.Hspec

4+import Test.Hspec.HUnit

5+import Data.Enumerator hiding (map)

6+import Test.HUnit

7+import qualified Data.ByteString as S

8+

9+main :: IO ()

10+main = hspec $ describe "insideHead"

11+ [ it "handles single chunks" $ helper "bar<head>foobaz" ["bar<head>baz"]

12+ , it "handles single chunks, no <head>" $ helper "barfoo" ["bar"]

13+ , it "handles whole chunks" $ helper "bar<head>foobaz" ["bar", "<head>", "baz"]

14+ , it "handles split chunks" $ helper "bar<head>foobaz" ["bar", "<he", "ad>", "baz"]

15+ , it "handles many chunks" $ helper "bar<head>foobaz1234567890" ["bar", "<he", "ad>", "baz", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"]

16+ , it "handles many pieces" $ helper "bar<head>foobaz" $ map S.singleton $ S.unpack "bar<head>baz"

17+ ]

18+

19+helper :: S.ByteString -> [S.ByteString] -> Assertion

20+helper res pieces = do

21+ x <- run_ $ enumList 1 pieces $$ joinI $ insideHead "foo" $$ consume

22+ S.concat x @?= res

wai-handler-launch/test.hsnew file+7

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

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.HTTP.Types

4+import Network.Wai.Handler.Launch

5+import Network.Wai.Middleware.Gzip

6+

7+main = runUrl "FIXME" $ gzip def $ \_ f -> f $ responseLBS status200 [("Content-Type", "text/html; charset=utf8")] "<html><head></head><body>HELLO THERE"

wai-handler-launch/wai-handler-launch.cabalnew file+36

@@ -0,0 +1,36 @@

1+Name: wai-handler-launch

2+Version: 3.0.0.3

3+Synopsis: Launch a web app in the default browser.

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

5+License: MIT

6+License-file: LICENSE

7+Author: Michael Snoyman

8+Maintainer: michael@snoyman.com

9+Category: Web

10+Build-type: Simple

11+Cabal-version: >=1.6

12+extra-source-files: README.md ChangeLog.md

13+

14+Library

15+ Exposed-modules: Network.Wai.Handler.Launch

16+ build-depends: base >= 4 && < 5

17+ , wai >= 3.0 && < 3.1

18+ , warp >= 3.0 && < 3.1

19+ , http-types >= 0.7

20+ , transformers >= 0.2.2

21+ , bytestring >= 0.9.1.4

22+ , blaze-builder >= 0.2.1.4 && < 0.5

23+ , streaming-commons

24+

25+ if os(windows)

26+ c-sources: windows.c

27+ cpp-options: -DWINDOWS

28+ extra-libraries: Shell32 msvcrt

29+ else

30+ build-depends: process >= 1.0 && < 1.3

31+ if os(darwin)

32+ cpp-options: -DMAC

33+

34+source-repository head

35+ type: git

36+ location: git://github.com/yesodweb/wai.git

wai-handler-launch/windows.cnew file+12

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

1+#include <windows.h>

2+#include <shellapi.h>

3+#include <stdio.h>

4+

5+void launch(int port, char *s)

6+{

7+ int len = 8 + strlen("http://127.0.0.1:") + strlen(s);

8+ char *buff = malloc(len);

9+ _snprintf(buff, len, "http://127.0.0.1:%d/%s", port, s);

10+ ShellExecute(NULL, "open", buff, NULL, NULL, SW_SHOWNORMAL);

11+ free(buff);

12+}

wai-handler-webkit/.gitignorenew file+2

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

1+dist

2+*.swp

wai-handler-webkit/ChangeLog.mdnew file+1

@@ -0,0 +1 @@

1+No changes logged yet

wai-handler-webkit/LICENSEnew file+20

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

2+

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

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

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

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

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

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

9+the following conditions:

10+

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

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

13+

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

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

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

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

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

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

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

wai-handler-webkit/Network/Wai/Handler/Webkit.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+module Network.Wai.Handler.Webkit (run) where

3+

4+import Network.Wai (Application)

5+import qualified Network.Wai.Handler.Warp as S

6+import Control.Concurrent (forkOS)

7+import Control.Concurrent.MVar

8+import Foreign.C.String (CString, withCString)

9+import Control.Exception (finally)

10+

11+run :: String -- ^ Title to show in titlebar

12+ -> Application -> IO ()

13+run title app = do

14+ mvar <- newEmptyMVar

15+ _ <- forkOS $ finally (S.run 3000 app) (putMVar mvar ())

16+ _ <- forkOS $ finally (withCString title startBrowser) (putMVar mvar ())

17+ _ <- takeMVar mvar

18+ return ()

19+

20+foreign import ccall "start_browser"

21+ startBrowser :: CString -> IO ()

wai-handler-webkit/README.mdnew file+53

@@ -0,0 +1,53 @@

1+wai-handler-webkit

2+==================

3+

4+Turn WAI applications into standalone GUIs using Qt WebKit.

5+

6+

7+Linux

8+-----

9+

10+You'll need the appropriate system libraries, on Ubuntu:

11+

12+ apt-get install libqtwebkit-dev

13+

14+On Lucid, this required adding a PPA:

15+

16+ sudo add-apt-repository ppa:kubuntu-ppa/backports

17+

18+

19+Windows

20+-------

21+

22+Install the Qt SDK from <http://qt.nokia.com/downloads/>

23+

24+Your application's Cabal file will require certain options for Windows,

25+shown below. In particular, we need to link with `g++`, so make sure

26+it's in your `PATH`. The option `-optl-mwindows` ensures that the

27+application does not open a terminal.

28+

29+ if os(windows)

30+ ghc-options: -Wall -threaded -pgml g++ -optl-static -optl-mwindows

31+ else

32+ ghc-options: -Wall

33+

34+Run `cabal-install` with the Qt `include` and `lib` directories.

35+

36+ export QT_PATH=c:/QtSDK/Desktop/Qt/4.7.3/mingw

37+

38+ cabal-dev install \

39+ --extra-include-dirs=$QT_PATH/include \

40+ --extra-include-dirs=$QT_PATH/include/QtCore \

41+ --extra-include-dirs=$QT_PATH/include/QtNetwork \

42+ --extra-include-dirs=$QT_PATH/include/QtGui \

43+ --extra-include-dirs=$QT_PATH/include/QtWebKit \

44+ --extra-lib-dirs=$QT_PATH/lib

45+

46+You'll need to include these DLLs with your application:

47+

48+ phonon4.dll

49+ libgcc_s_dw2-1.dll

50+ QtCore4.dll

51+ QtGui4.dll

52+ QtNetwork4.dll

53+ QtWebKit4.dll

wai-handler-webkit/Setup.lhsnew file+7

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

1+#!/usr/bin/env runhaskell

2+

3+> module Main where

4+> import Distribution.Simple

5+

6+> main :: IO ()

7+> main = defaultMain

wai-handler-webkit/sample.hsnew file+10

@@ -0,0 +1,10 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+import Network.Wai

3+import Network.Wai.Handler.Webkit

4+import Network.HTTP.Types

5+

6+main :: IO ()

7+main = run "Sample App" app

8+

9+app :: Application

10+app _ response = response $ responseLBS status200 [("Content-Type", "text/html")] "<h1>Hello World!</h1>"

wai-handler-webkit/wai-handler-webkit.cabalnew file+30

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

1+name: wai-handler-webkit

2+version: 3.0.0.1

3+license: MIT

4+license-file: LICENSE

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

6+maintainer: Michael Snoyman <michael@snoyman.com>

7+synopsis: Turn WAI applications into standalone GUIs using QtWebkit.

8+description: API docs and the README are available at <http://www.stackage.org/package/wai-handler-webkit>.

9+category: Web

10+stability: unstable

11+cabal-version: >= 1.6

12+build-type: Simple

13+homepage: https://github.com/yesodweb/wai/tree/master/wai-handler-webkit

14+extra-source-files: README.md ChangeLog.md

15+

16+library

17+ build-depends: base >= 4 && < 5

18+ , wai >= 3.0 && < 3.1

19+ , warp >= 3.0 && < 3.1

20+ ghc-options: -Wall

21+ exposed-modules: Network.Wai.Handler.Webkit

22+ c-sources: webkit.cpp

23+ if os(windows)

24+ extra-libraries: QtCore4, QtGui4, QtNetwork4, QtWebKit4

25+ else

26+ pkgconfig-depends: QtWebKit

27+

28+source-repository head

29+ type: git

30+ location: git://github.com/yesodweb/wai.git

wai-handler-webkit/webkit.cppnew file+19

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

1+#include <QApplication>

2+#include <QPushButton>

3+#include <QtWebKit>

4+

5+extern "C" {

6+ int start_browser(char *title)

7+ {

8+ char *argv[1];

9+ argv[0] = title;

10+ int argc = 1;

11+

12+ QApplication app(argc, argv);

13+ QWebView *view = new QWebView();

14+ view->load(QUrl("http://localhost:3000/"));

15+ view->show();

16+

17+ return app.exec();

18+ }

19+}

wai-http2-extra/Network/Wai/Middleware/Push/Referer.hsdeleted−236

@@ -1,236 +0,0 @@

1−{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}

2−

3−-- | Middleware for server push learning dependency based on Referer:.

4−module Network.Wai.Middleware.Push.Referer (

5− -- * Middleware

6− pushOnReferer

7− -- * Making push promise

8− , URLPath

9− , MakePushPromise

10− , defaultMakePushPromise

11− -- * Settings

12− , Settings

13− , defaultSettings

14− , makePushPromise

15− , duration

16− , keyLimit

17− , valueLimit

18− ) where

19−

20−import Control.Monad (when, unless)

21−import Control.Reaper

22−import Data.ByteString (ByteString)

23−import qualified Data.ByteString as BS

24−import Data.ByteString.Internal (ByteString(..), memchr)

25−import Data.IORef

26−import Data.Maybe (isNothing)

27−import Data.Word (Word8)

28−import Data.Word8

29−import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)

30−import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

31−import Foreign.Storable (peek)

32−import Network.HTTP.Types (Status(..))

33−import Network.Wai

34−import Network.Wai.Handler.Warp hiding (Settings, defaultSettings)

35−import Network.Wai.Internal (Response(..))

36−import System.IO.Unsafe (unsafePerformIO)

37−

38−import qualified Network.Wai.Middleware.Push.Referer.LimitMultiMap as M

39−

40−-- $setup

41−-- >>> :set -XOverloadedStrings

42−

43−-- | Making a push promise based on Referer:,

44−-- path to be pushed and file to be pushed.

45−-- If the middleware should push this file in the next time when

46−-- the page of Referer: is accessed,

47−-- this function should return 'Just'.

48−-- If 'Nothing' is returned,

49−-- the middleware learns nothing.

50−type MakePushPromise = URLPath -- ^ path in referer (key: /index.html)

51− -> URLPath -- ^ path to be pushed (value: /style.css)

52− -> FilePath -- ^ file to be pushed (file_path/style.css)

53− -> IO (Maybe PushPromise)

54−

55−-- | Type for URL path.

56−type URLPath = ByteString

57−

58−type Cache = M.LimitMultiMap URLPath PushPromise

59−

60−initialized :: IORef Bool

61−initialized = unsafePerformIO $ newIORef False

62−{-# NOINLINE initialized #-}

63−

64−cacheReaper :: IORef (Maybe (Reaper Cache (URLPath,PushPromise)))

65−cacheReaper = unsafePerformIO $ newIORef Nothing

66−{-# NOINLINE cacheReaper #-}

67−

68−-- | Settings for server push based on Referer:.

69−data Settings = Settings {

70− makePushPromise :: MakePushPromise -- ^ Default: 'defaultMakePushPromise'

71− , duration :: Int -- ^ Duration (in micro seconds) to keep the learning information. The information completely cleared every this duration. Default: 30000000

72− , keyLimit :: Int -- ^ Max number of keys (e.g. index.html) in the learning information. Default: 20

73− , valueLimit :: Int -- ^ Max number of values (e.g. style.css) in the learning information. Default: 20

74− }

75−

76−-- | Default settings.

77−defaultSettings :: Settings

78−defaultSettings = Settings {

79− makePushPromise = defaultMakePushPromise

80− , duration = 30000000

81− , keyLimit = 20

82− , valueLimit = 20

83− }

84−

85−tryInitialize :: Settings -> IO ()

86−tryInitialize Settings{..} = do

87− isInitialized <- atomicModifyIORef' initialized $ \x -> (True, x)

88− unless isInitialized $ do

89− reaper <- mkReaper settings

90− writeIORef cacheReaper (Just reaper)

91− where

92− emptyCache = M.empty keyLimit valueLimit

93− settings :: ReaperSettings Cache (URLPath,PushPromise)

94− settings = defaultReaperSettings {

95− reaperAction = \_ -> return (\_ -> emptyCache)

96− , reaperCons = M.insert

97− , reaperNull = M.isEmpty

98− , reaperEmpty = emptyCache

99− , reaperDelay = duration

100− }

101−

102−-- | The middleware to push files based on Referer:.

103−-- Learning strategy is implemented in the first argument.

104−pushOnReferer :: Settings -> Middleware

105−pushOnReferer settings@Settings{..} app req sendResponse = do

106− tryInitialize settings

107− mreaper <- readIORef cacheReaper

108− case mreaper of

109− Nothing -> app req sendResponse

110− Just reaper -> app req (push reaper)

111− where

112− push reaper res@(ResponseFile (Status 200 "OK") _ file Nothing) = do

113− let !path = rawPathInfo req

114− m <- reaperRead reaper

115− case M.lookup path m of

116− [] -> case requestHeaderReferer req of

117− Nothing -> return ()

118− Just referer -> do

119− (mauth,refPath) <- parseUrl referer

120− when (isNothing mauth

121− || requestHeaderHost req == mauth) $ do

122− when (path /= refPath) $ do -- just in case

123− let !path' = BS.copy path

124− !refPath' = BS.copy refPath

125− mpp <- makePushPromise refPath' path' file

126− case mpp of

127− Nothing -> return ()

128− Just pp -> reaperAdd reaper (refPath',pp)

129− ps -> do

130− let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}

131− setHTTP2Data req (Just h2d)

132− sendResponse res

133− push _ res = sendResponse res

134−

135−

136−-- | Learn if the file to be pushed is CSS (.css) or JavaScript (.js) file

137−-- AND the Referer: ends with \"/\" or \".html\" or \".htm\".

138−defaultMakePushPromise :: MakePushPromise

139−defaultMakePushPromise refPath path file

140− | isHTML refPath = case getCT path of

141− Nothing -> return Nothing

142− Just ct -> do

143− let pp = defaultPushPromise {

144− promisedPath = path

145− , promisedFile = file

146− , promisedResponseHeaders = [("content-type", ct)

147− ,("x-http2-push", refPath)]

148− }

149− return $ Just pp

150− | otherwise = return Nothing

151−

152−getCT :: URLPath -> Maybe ByteString

153−getCT p

154− | ".js" `BS.isSuffixOf` p = Just "application/javascript"

155− | ".css" `BS.isSuffixOf` p = Just "text/css"

156− | otherwise = Nothing

157−

158−isHTML :: URLPath -> Bool

159−isHTML p = ("/" `BS.isSuffixOf` p)

160− || (".html" `BS.isSuffixOf` p)

161− || (".htm" `BS.isSuffixOf` p)

162−

163−-- |

164−--

165−-- >>> parseUrl ""

166−-- (Nothing,"")

167−-- >>> parseUrl "/"

168−-- (Nothing,"/")

169−-- >>> parseUrl "ht"

170−-- (Nothing,"")

171−-- >>> parseUrl "http://example.com/foo/bar/"

172−-- (Just "example.com","/foo/bar/")

173−-- >>> parseUrl "https://www.example.com/path/to/dir/"

174−-- (Just "www.example.com","/path/to/dir/")

175−-- >>> parseUrl "http://www.example.com:8080/path/to/dir/"

176−-- (Just "www.example.com:8080","/path/to/dir/")

177−-- >>> parseUrl "//www.example.com:8080/path/to/dir/"

178−-- (Just "www.example.com:8080","/path/to/dir/")

179−-- >>> parseUrl "/path/to/dir/"

180−-- (Nothing,"/path/to/dir/")

181−

182−parseUrl :: ByteString -> IO (Maybe ByteString, URLPath)

183−parseUrl bs@(PS fptr0 off len)

184− | len == 0 = return (Nothing, "")

185− | len == 1 = return (Nothing, bs)

186− | otherwise = withForeignPtr fptr0 $ \ptr0 -> do

187− let begptr = ptr0 `plusPtr` off

188− limptr = begptr `plusPtr` len

189− parseUrl' fptr0 ptr0 begptr limptr len

190−

191−parseUrl' :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int

192− -> IO (Maybe ByteString, URLPath)

193−parseUrl' fptr0 ptr0 begptr limptr len0 = do

194− w0 <- peek begptr

195− if w0 == _slash then do

196− w1 <- peek $ begptr `plusPtr` 1

197− if w1 == _slash then

198− doubleSlashed begptr len0

199− else

200− slashed begptr len0 Nothing

201− else do

202− colonptr <- memchr begptr _colon $ fromIntegral len0

203− if colonptr == nullPtr then

204− return (Nothing, "")

205− else do

206− let !authptr = colonptr `plusPtr` 1

207− doubleSlashed authptr (limptr `minusPtr` authptr)

208− where

209− -- // / ?

210− doubleSlashed :: Ptr Word8 -> Int -> IO (Maybe ByteString, URLPath)

211− doubleSlashed ptr len

212− | len < 2 = return (Nothing, "")

213− | otherwise = do

214− let ptr1 = ptr `plusPtr` 2

215− pathptr <- memchr ptr1 _slash $ fromIntegral len

216− if pathptr == nullPtr then

217− return (Nothing, "")

218− else do

219− let !auth = bs ptr0 ptr1 pathptr

220− slashed pathptr (limptr `minusPtr` pathptr) (Just auth)

221−

222− -- / ?

223− slashed :: Ptr Word8 -> Int -> Maybe ByteString -> IO (Maybe ByteString, URLPath)

224− slashed ptr len mauth = do

225− questionptr <- memchr ptr _question $ fromIntegral len

226− if questionptr == nullPtr then do

227− let !path = bs ptr0 ptr limptr

228− return (mauth, path)

229− else do

230− let !path = bs ptr0 ptr questionptr

231− return (mauth, path)

232− bs p0 p1 p2 = path

233− where

234− !off = p1 `minusPtr` p0

235− !siz = p2 `minusPtr` p1

236− !path = PS fptr0 off siz

wai-http2-extra/Network/Wai/Middleware/Push/Referer/LimitMultiMap.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3−module Network.Wai.Middleware.Push.Referer.LimitMultiMap where

4−

5−import Data.Map (Map)

6−import qualified Data.Map.Strict as M

7−import Data.Set (Set)

8−import qualified Data.Set as S

9−

10−data LimitMultiMap k v = LimitMultiMap {

11− limitKey :: !Int

12− , limitVal :: !Int

13− , multiMap :: !(Map k (Set v))

14− } deriving (Eq, Show)

15−

16−isEmpty :: LimitMultiMap k t -> Bool

17−isEmpty (LimitMultiMap _ _ m) = M.null m

18−

19−empty :: Int -> Int -> LimitMultiMap k v

20−empty lk lv = LimitMultiMap lk lv M.empty

21−

22−insert :: (Ord k, Ord v) => (k,v) -> LimitMultiMap k v -> LimitMultiMap k v

23−insert (k,v) (LimitMultiMap lk lv m)

24− | siz < lk = let !m' = M.alter alt k m in LimitMultiMap lk lv m'

25− | siz == lk = let !m' = M.adjust adj k m in LimitMultiMap lk lv m'

26− | otherwise = error "insert"

27− where

28− siz = M.size m

29− alt Nothing = Just $ S.singleton v

30− alt s@(Just set)

31− | S.size set == lv = s

32− | otherwise = Just $ S.insert v set

33− adj set

34− | S.size set == lv = set

35− | otherwise = S.insert v set

36−

37−lookup :: Ord k => k -> LimitMultiMap k v -> [v]

38−lookup k (LimitMultiMap _ _ m) = case M.lookup k m of

39− Nothing -> []

40− Just set -> S.toList set

wai-http2-extra/test/doctests.hsdeleted−4

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

1−import Test.DocTest

2−

3−main :: IO ()

4−main = doctest ["Network"]

wai-http2-extra/wai-http2-extra.cabaldeleted−44

@@ -1,44 +0,0 @@

1−Name: wai-http2-extra

2−Version: 0.1.2

3−Synopsis: WAI utilities for HTTP/2

4−License: MIT

5−License-file: LICENSE

6−Author: Kazu Yamamoto

7−Maintainer: kazu@iij.ad.jp

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

9−Category: Web

10−Build-Type: Simple

11−Cabal-Version: >=1.10

12−Stability: Stable

13−Description: WAI utilities for HTTP/2

14−

15−Library

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

17− , auto-update >= 0.1.3 && < 0.2

18− , bytestring

19− , containers

20− , http-types

21− , wai

22− , warp

23− , word8

24− Exposed-modules: Network.Wai.Middleware.Push.Referer

25− Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap

26− Ghc-Options: -Wall

27− if impl(ghc >= 8)

28− default-extensions: Strict StrictData

29− default-language: Haskell2010

30−

31−Test-Suite doctest

32− Type: exitcode-stdio-1.0

33− HS-Source-Dirs: test

34− Ghc-Options: -threaded -Wall

35− Main-Is: doctests.hs

36− Build-Depends: base

37− , doctest >= 0.10.1

38− if impl(ghc >= 8)

39− default-extensions: Strict StrictData

40− default-language: Haskell2010

41−

42−Source-Repository head

43− Type: git

44− Location: git://github.com/yesodweb/wai.git

wai-websockets/ChangeLog.md−24

@@ -1,27 +1,3 @@

1−## 3.0.1.2

2−

3−* Drop unused dependency on blaze-builder

4−

5−## 3.0.1.1

6−

7−* Doc improvement

8−

9−## 3.0.1

10−

11−* Improved connection close logic

12−

13−## 3.0.0.9

14−

15−* Clean up stream resources when websockets completes [#549](https://github.com/yesodweb/wai/pull/549)

16−

17−## 3.0.0.8

18−

19−* Support wai 3.2

20−

21−## 3.0.0.7

22−

23−* Improved documentation [#471](https://github.com/yesodweb/wai/pull/471)

24−

251## 3.0.0.5

262

273Allow blaze-builder 0.4

wai-websockets/Network/Wai/Handler/WebSockets.hs+19−56

@@ -1,13 +1,12 @@

11{-# LANGUAGE OverloadedStrings #-}

22module Network.Wai.Handler.WebSockets

3− ( websocketsOr

4− , websocketsApp

3+ ( websocketsApp

4+ , websocketsOr

55 , isWebSocketsReq

66 , getRequestHead

77 , runWebSockets

88 ) where

99

10−import Control.Exception (bracket, tryJust)

1110import Data.ByteString (ByteString)

1211import qualified Data.ByteString.Char8 as BC

1312import qualified Data.ByteString.Lazy as BL

@@ -19,38 +18,11 @@ import qualified Network.WebSockets.Connection as WS

1918import qualified Network.WebSockets.Stream as WS

2019

2120--------------------------------------------------------------------------------

22−-- | Returns whether or not the given 'Wai.Request' is a WebSocket request.

2321isWebSocketsReq :: Wai.Request -> Bool

2422isWebSocketsReq req =

2523 fmap CI.mk (lookup "upgrade" $ Wai.requestHeaders req) == Just "websocket"

2624

2725--------------------------------------------------------------------------------

28−-- | Upgrade a @websockets@ 'WS.ServerApp' to a @wai@ 'Wai.Application'. Uses

29−-- the given backup 'Wai.Application' to handle 'Wai.Request's that are not

30−-- WebSocket requests.

31−--

32−-- @

33−-- websocketsOr opts ws_app backup_app = \\req respond ->

34−-- __case__ 'websocketsApp' opts ws_app req __of__

35−-- 'Nothing' -> backup_app req send_response

36−-- 'Just' res -> respond res

37−-- @

38−--

39−-- For example, below is an 'Wai.Application' that sends @"Hello, client!"@ to

40−-- each connected client.

41−--

42−-- @

43−-- app :: 'Wai.Application'

44−-- app = 'websocketsOr' 'WS.defaultConnectionOptions' wsApp backupApp

45−-- __where__

46−-- wsApp :: 'WS.ServerApp'

47−-- wsApp pending_conn = do

48−-- conn <- 'WS.acceptRequest' pending_conn

49−-- 'WS.sendTextData' conn ("Hello, client!" :: 'Data.Text.Text')

50−--

51−-- backupApp :: 'Wai.Application'

52−-- backupApp _ respond = respond $ 'Wai.responseLBS' 'Network.HTTP.Types.status400' [] "Not a WebSocket request"

53−-- @

5426websocketsOr :: WS.ConnectionOptions

5527 -> WS.ServerApp

5628 -> Wai.Application

@@ -61,11 +33,6 @@ websocketsOr opts app backup req sendResponse =

6133 Just res -> sendResponse res

6234

6335--------------------------------------------------------------------------------

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.

6936websocketsApp :: WS.ConnectionOptions

7037 -> WS.ServerApp

7138 -> Wai.Request

@@ -88,31 +55,27 @@ getRequestHead req = WS.RequestHead

8855 (Wai.isSecure req)

8956

9057--------------------------------------------------------------------------------

91−-- | Internal function to run the WebSocket io-streams using the conduit library.

58+---- | Internal function to run the WebSocket io-streams using the conduit library

9259runWebSockets :: WS.ConnectionOptions

9360 -> WS.RequestHead

9461 -> (WS.PendingConnection -> IO a)

9562 -> IO ByteString

9663 -> (ByteString -> IO ())

9764 -> IO a

98−runWebSockets opts req app src sink = bracket mkStream ensureClose (app . pc)

99− where

100− ensureClose = tryJust onConnectionException . WS.close

101− onConnectionException :: WS.ConnectionException -> Maybe ()

102− onConnectionException WS.ConnectionClosed = Just ()

103− onConnectionException _ = Nothing

104− mkStream =

105− WS.makeStream

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))

65+runWebSockets opts req app src sink = do

66+ stream <- WS.makeStream

67+ (do

68+ bs <- src

69+ return $ if BC.null bs then Nothing else Just bs)

70+ (\mbBl -> case mbBl of

71+ Nothing -> return ()

72+ Just bl -> mapM_ sink (BL.toChunks bl))

73+

74+ let pc = WS.PendingConnection

75+ { WS.pendingOptions = opts

76+ , WS.pendingRequest = req

77+ , WS.pendingOnAccept = \_ -> return ()

78+ , WS.pendingStream = stream

79+ }

11280

113− pc stream = WS.PendingConnection

114− { WS.pendingOptions = opts

115− , WS.pendingRequest = req

116− , WS.pendingOnAccept = \_ -> return ()

117− , WS.pendingStream = stream

118− }

81+ app pc

wai-websockets/server.lhs+6−12

@@ -8,14 +8,12 @@ this example, keep the [reference](http://jaspervdj.be/websockets/reference)

88nearby to check out the functions we use.

99

1010> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}

11−> {-# LANGUAGE CPP #-}

12−> {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- for numClients

1311> import Data.Char (isPunctuation, isSpace)

1412> import Data.Monoid (mappend)

1513> import Data.Text (Text)

16−> import Control.Exception (finally)

14+> import Control.Exception (finally)

1715> import Control.Monad (forM_, forever)

18−> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, modifyMVar)

16+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO, modifyMVar)

1917> import Control.Monad.IO.Class (liftIO)

2018> import qualified Data.Text as T

2119> import qualified Data.Text.IO as T

@@ -78,9 +76,9 @@ actual server.

7876> main = do

7977> putStrLn "http://localhost:9160/client.html"

8078> state <- newMVar newServerState

81−> Warp.runSettings

82−> (Warp.setPort 9160 Warp.defaultSettings)

83−> $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp

79+> Warp.runSettings Warp.defaultSettings

80+> { Warp.settingsPort = 9160

81+> } $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp

8482

8583> staticApp :: Network.Wai.Application

8684> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")

@@ -101,13 +99,9 @@ stays alive on some browsers.

10199

102100> application state pending = do

103101> conn <- WS.acceptRequest pending

104−#if __GLASGOW_HASKELL__ >= 806

105−> WS.withPingThread conn 30 (return ()) $ do

106−#else

107102> WS.forkPingThread conn 30

108−#endif

109103

110−When a client is successfully connected, we read the first message. This should

104+When a client is succesfully connected, we read the first message. This should

111105be in the format of "Hi! I am Jasper", where Jasper is the requested username.

112106

113107> msg <- WS.receiveData conn

wai-websockets/wai-websockets.cabal+4−3

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

11Name: wai-websockets

2−Version: 3.0.1.2

2+Version: 3.0.0.5

33Synopsis: Provide a bridge between WAI and the websockets package.

44License: MIT

55License-file: LICENSE

@@ -20,7 +20,8 @@ flag example

2020Library

2121 Build-Depends: base >= 3 && < 5

2222 , bytestring >= 0.9.1.4

23− , wai >= 3.0 && < 3.3

23+ , wai >= 3.0 && < 3.1

24+ , blaze-builder >= 0.2.1.4 && < 0.5

2425 , case-insensitive >= 0.2

2526 , network >= 2.2.1.5

2627 , transformers >= 0.2

@@ -40,12 +41,12 @@ Executable wai-websockets-example

4041 , wai-app-static

4142 , bytestring

4243 , case-insensitive

44+ , blaze-builder

4345 , transformers

4446 , network

4547 , text

4648 , file-embed

4749 , http-types

48− other-modules: Network.Wai.Handler.WebSockets

4950 else

5051 buildable: False

5152

wai/ChangeLog.md+1−49

@@ -1,54 +1,6 @@

1−# ChangeLog for wai

2−

3−## 3.2.2.1

4−

5−* Fix missing reexport of `getRequestBodyChunk` [#753](https://github.com/yesodweb/wai/issues/753)

6−

7−## 3.2.2

8−

9−* Deprecate `requestBody` in favor of the more clearly named `getRequestBodyChunk`. [#726](https://github.com/yesodweb/wai/pull/726)

10−

11−## 3.2.1.2

12−

13−* Remove dependency on blaze-builder [#683](https://github.com/yesodweb/wai/pull/683)

14−

15−## 3.2.1.1

16−

17−* Relax upper bound on bytestring-builder

18−

19−## 3.2.1

20−

21−* add mapResponseStatus [#532](https://github.com/yesodweb/wai/pull/532)

22−

23−## 3.2.0.1

24−

25−* Add missing changelog entry

26−

27−## 3.2.0

28−

29−* Major version up due to breaking changes. We chose 3.2.0, not 3.1.0

30− for consistency with Warp 3.2.0.

31−* The Network.Wai.HTTP2 module was removed.

32−* tryGetFileSize, hContentRange, hAcceptRanges, contentRangeHeader and

33− chooseFilePart, adjustForFilePart and parseByteRanges were removed

34− from the Network.Wai.Internal module.

35−* New fields for Request: requestHeaderReferer and requestHeaderUserAgent.

36−

37−## 3.0.5.0

38−

39−* Avoid using the IsString Builder instance

40−

41−## 3.0.4.0

42−

43−* A new module Network.Wai.HTTP2 is exported.

44−

45−## 3.0.3.0

46−

47−* mapResponseHeaders, ifRequest and modifyResponse are exported.

48−

491## 3.0.2.3

502

51−* Allow blaze-builder 0.4

3+Allow blaze-builder 0.4

524

535## 3.0.2.2

546

wai/Network/Wai.hs+37−75

@@ -1,14 +1,15 @@

1+{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE CPP #-}

13{-|

24

35This module defines a generic web application interface. It is a common

46protocol between web servers and web applications.

57

68The overriding design principles here are performance and generality. To

7−address performance, this library uses a streaming interface for request and

8−response bodies, paired with bytestring's 'Builder' type. The advantages of a

9−streaming API over lazy IO have been debated elsewhere and so will not be

10−addressed here. However, helper functions like 'responseLBS' allow you to

11−continue using lazy IO if you so desire.

9+address performance, this library is built on top of the conduit and

10+blaze-builder packages. The advantages of conduits over lazy IO have been

11+debated elsewhere and so will not be addressed here. However, helper functions

12+like 'responseLBS' allow you to continue using lazy IO if you so desire.

1213

1314Generality is achieved by removing many variables commonly found in similar

1415projects that are not universal to all servers. The goal is that the 'Request'

@@ -30,9 +31,9 @@ include:

3031

3132[wai-extra] <http://hackage.haskell.org/package/wai-extra>

3233

34+[wai-test] <http://hackage.haskell.org/package/wai-test>

35+

3336-}

34−-- Ignore deprecations, because this module needs to use the deprecated requestBody to construct a response.

35−{-# OPTIONS_GHC -fno-warn-deprecations #-}

3637module Network.Wai

3738 (

3839 -- * Types

@@ -53,14 +54,11 @@ module Network.Wai

5354 , remoteHost

5455 , pathInfo

5556 , queryString

56− , getRequestBodyChunk

5757 , requestBody

5858 , vault

5959 , requestBodyLength

6060 , requestHeaderHost

6161 , requestHeaderRange

62− , requestHeaderReferer

63− , requestHeaderUserAgent

6462 , strictRequestBody

6563 , lazyRequestBody

6664 -- * Response

@@ -73,20 +71,14 @@ module Network.Wai

7371 , responseLBS

7472 , responseStream

7573 , responseRaw

76− -- ** Response accessors

74+ -- * Response accessors

7775 , responseStatus

7876 , responseHeaders

79− -- ** Response modifiers

8077 , responseToStream

81− , mapResponseHeaders

82− , mapResponseStatus

83− -- * Middleware composition

84− , ifRequest

85− , modifyResponse

8678 ) where

8779

88−import Data.ByteString.Builder (Builder, lazyByteString)

89−import Data.ByteString.Builder (byteString)

80+import Blaze.ByteString.Builder (Builder, fromLazyByteString)

81+import Blaze.ByteString.Builder (fromByteString)

9082import Control.Monad (unless)

9183import qualified Data.ByteString as B

9284import qualified Data.ByteString.Lazy as L

@@ -94,6 +86,7 @@ import qualified Data.ByteString.Lazy.Internal as LI

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

9587import Data.ByteString.Lazy.Char8 ()

9688import Data.Function (fix)

89+import Data.Monoid (mempty)

9790import qualified Network.HTTP.Types as H

9891import Network.Socket (SockAddr (SockAddrInet))

9992import Network.Wai.Internal

@@ -121,13 +114,13 @@ responseFile = ResponseFile

121114--

122115-- A2. No. If the ByteStrings are small, then they will be copied into a larger

123116-- buffer, which should be a performance gain overall (less system calls). If

124−-- they are already large, then an insert operation is used

125−-- to avoid copying.

117+-- they are already large, then blaze-builder uses an InsertByteString

118+-- instruction to avoid copying.

126119--

127120-- Q3. Doesn't this prevent us from creating comet-style servers, since data

128121-- will be cached?

129122--

130−-- A3. You can force a Builder to output a ByteString before it is an

123+-- A3. You can force blaze-builder to output a ByteString before it is an

131124-- optimal size by sending a flush command.

132125responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response

133126responseBuilder = ResponseBuilder

@@ -135,7 +128,7 @@ responseBuilder = ResponseBuilder

135128-- | Creating 'Response' from 'L.ByteString'. This is a wrapper for

136129-- 'responseBuilder'.

137130responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

138−responseLBS s h = ResponseBuilder s h . lazyByteString

131+responseLBS s h = ResponseBuilder s h . fromLazyByteString

139132

140133-- | Creating 'Response' from a stream of values.

141134--

@@ -149,9 +142,9 @@ responseLBS s h = ResponseBuilder s h . lazyByteString

149142-- (putStrLn \"Allocating scarce resource\")

150143-- (putStrLn \"Cleaning up\")

151144-- $ respond $ responseStream status200 [] $ \\write flush -> do

152−-- write $ byteString \"Hello\\n\"

145+-- write $ fromByteString \"Hello\\n\"

153146-- flush

154−-- write $ byteString \"World\\n\"

147+-- write $ fromByteString \"World\\n\"

155148-- @

156149--

157150-- Note that in some cases you can use @bracket@ from inside @responseStream@

@@ -214,7 +207,7 @@ responseToStream (ResponseFile s h fp (Just part)) =

214207 bs <- B.hGetSome handle defaultChunkSize

215208 unless (B.null bs) $ do

216209 let x = B.take remaining bs

217− sendChunk $ byteString x

210+ sendChunk $ fromByteString x

218211 loop $ remaining - B.length x

219212 loop $ fromIntegral $ filePartByteCount part

220213 )

@@ -225,27 +218,13 @@ responseToStream (ResponseFile s h fp Nothing) =

225218 withBody $ \sendChunk _flush -> fix $ \loop -> do

226219 bs <- B.hGetSome handle defaultChunkSize

227220 unless (B.null bs) $ do

228− sendChunk $ byteString bs

221+ sendChunk $ fromByteString bs

229222 loop

230223 )

231224responseToStream (ResponseBuilder s h b) =

232225 (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b)

233226responseToStream (ResponseRaw _ res) = responseToStream res

234227

235−-- | Apply the provided function to the response header list of the Response.

236−mapResponseHeaders :: (H.ResponseHeaders -> H.ResponseHeaders) -> Response -> Response

237−mapResponseHeaders f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2

238−mapResponseHeaders f (ResponseBuilder s h b) = ResponseBuilder s (f h) b

239−mapResponseHeaders f (ResponseStream s h b) = ResponseStream s (f h) b

240−mapResponseHeaders _ r@(ResponseRaw _ _) = r

241−

242−-- | Apply the provided function to the response status of the Response.

243−mapResponseStatus :: (H.Status -> H.Status) -> Response -> Response

244−mapResponseStatus f (ResponseFile s h b1 b2) = ResponseFile (f s) h b1 b2

245−mapResponseStatus f (ResponseBuilder s h b) = ResponseBuilder (f s) h b

246−mapResponseStatus f (ResponseStream s h b) = ResponseStream (f s) h b

247−mapResponseStatus _ r@(ResponseRaw _ _) = r

248−

249228----------------------------------------------------------------

250229

251230-- | The WAI application.

@@ -263,6 +242,21 @@ mapResponseStatus _ r@(ResponseRaw _ _) = r

263242-- @

264243type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived

265244

245+-- | Middleware is a component that sits between the server and application. It

246+-- can do such tasks as GZIP encoding or response caching. What follows is the

247+-- general definition of middleware, though a middleware author should feel

248+-- free to modify this.

249+--

250+-- As an example of an alternate type for middleware, suppose you write a

251+-- function to load up session information. The session information is simply a

252+-- string map \[(String, String)\]. A logical type signature for this middleware

253+-- might be:

254+--

255+-- @ loadSession :: ([(String, String)] -> Application) -> Application @

256+--

257+-- Here, instead of taking a standard 'Application' as its first argument, the

258+-- middleware takes a function which consumes the session information as well.

259+type Middleware = Application -> Application

266260

267261-- | A default, blank request.

268262--

@@ -283,40 +277,8 @@ defaultRequest = Request

283277 , requestBodyLength = KnownLength 0

284278 , requestHeaderHost = Nothing

285279 , requestHeaderRange = Nothing

286− , requestHeaderReferer = Nothing

287− , requestHeaderUserAgent = Nothing

288280 }

289281

290−

291−-- | Middleware is a component that sits between the server and application. It

292−-- can do such tasks as GZIP encoding or response caching. What follows is the

293−-- general definition of middleware, though a middleware author should feel

294−-- free to modify this.

295−--

296−-- As an example of an alternate type for middleware, suppose you write a

297−-- function to load up session information. The session information is simply a

298−-- string map \[(String, String)\]. A logical type signature for this middleware

299−-- might be:

300−--

301−-- @ loadSession :: ([(String, String)] -> Application) -> Application @

302−--

303−-- Here, instead of taking a standard 'Application' as its first argument, the

304−-- middleware takes a function which consumes the session information as well.

305−type Middleware = Application -> Application

306−

307−

308−-- | apply a function that modifies a response as a 'Middleware'

309−modifyResponse :: (Response -> Response) -> Middleware

310−modifyResponse f app req respond = app req $ respond . f

311−

312−

313−-- | conditionally apply a 'Middleware'

314−ifRequest :: (Request -> Bool) -> Middleware -> Middleware

315−ifRequest rpred middle app req | rpred req = middle app req

316− | otherwise = app req

317−

318−

319−

320282-- | Get the request body as a lazy ByteString. However, do /not/ use any lazy

321283-- I\/O, instead reading the entire body into memory strictly.

322284--

@@ -326,7 +288,7 @@ strictRequestBody req =

326288 loop id

327289 where

328290 loop front = do

329− bs <- getRequestBodyChunk req

291+ bs <- requestBody req

330292 if B.null bs

331293 then return $ front LI.Empty

332294 else loop (front . LI.Chunk bs)

@@ -340,7 +302,7 @@ lazyRequestBody req =

340302 loop

341303 where

342304 loop = unsafeInterleaveIO $ do

343− bs <- getRequestBodyChunk req

305+ bs <- requestBody req

344306 if B.null bs

345307 then return LI.Empty

346308 else do

wai/Network/Wai/Internal.hs+6−20

@@ -1,15 +1,17 @@

11{-# OPTIONS_HADDOCK not-home #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

23{-# LANGUAGE CPP #-}

4+{-# LANGUAGE RankNTypes #-}

35{-# LANGUAGE RecordWildCards #-}

46-- | Internal constructors and helper functions. Note that no guarantees are

57-- given for stability of these interfaces.

68module Network.Wai.Internal where

79

8−import Data.ByteString.Builder (Builder)

9−import qualified Data.ByteString as B hiding (pack)

10+import Blaze.ByteString.Builder (Builder)

11+import qualified Data.ByteString as B

1012import Data.Text (Text)

1113import Data.Typeable (Typeable)

12−import Data.Vault.Lazy (Vault)

14+import Data.Vault.Lazy (Vault)

1315import Data.Word (Word64)

1416import qualified Network.HTTP.Types as H

1517import Network.Socket (SockAddr)

@@ -17,7 +19,6 @@ import Data.List (intercalate)

1719

1820-- | Information on the request sent by the client. This abstracts away the

1921-- 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." #-}

2122data Request = Request {

2223 -- | Request method such as GET.

2324 requestMethod :: H.Method

@@ -63,7 +64,7 @@ data Request = Request {

6364 -- | Parsed query string information.

6465 , queryString :: H.Query

6566 -- | Get the next chunk of the body. Returns 'B.empty' when the

66− -- body is fully consumed. Since 3.2.2, this is deprecated in favor of 'getRequestBodyChunk'.

67+ -- body is fully consumed.

6768 , requestBody :: IO B.ByteString

6869 -- | A location for arbitrary data to be shared by applications and middleware.

6970 , vault :: Vault

@@ -80,24 +81,9 @@ data Request = Request {

8081 --

8182 -- Since 2.0.0

8283 , 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

9184 }

9285 deriving (Typeable)

9386

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−

10187instance Show Request where

10288 show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}"

10389 where

wai/README.md+1−1

@@ -67,7 +67,7 @@ Basic dispatching

6767An `Application` maps `Request`s to `Response`s:

6868

6969 ghci> :info Application

70− type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived

70+ type Application = Request -> IO Response

7171

7272Depending on the path info provided with each `Request` we can serve different `Response`s:

7373

wai/test/Network/WaiSpec.hs+9−7

@@ -3,10 +3,12 @@ module Network.WaiSpec (spec) where

33import Test.Hspec

44import Test.Hspec.QuickCheck (prop)

55import Network.Wai

6+import Network.Wai.Internal (Request (Request))

67import Data.IORef

8+import Data.Monoid

79import qualified Data.ByteString as S

810import qualified Data.ByteString.Lazy as L

9−import Data.ByteString.Builder (Builder, toLazyByteString, word8)

11+import Blaze.ByteString.Builder (toByteString, Builder, fromWord8)

1012import Control.Monad (forM_)

1113

1214spec :: Spec

@@ -22,17 +24,17 @@ spec = do

2224 flush :: IO ()

2325 flush = return ()

2426 streamingBody add flush

25− fmap (L.toStrict . toLazyByteString) $ readIORef builderRef

27+ fmap toByteString $ readIORef builderRef

2628 prop "responseLBS" $ \bytes -> do

2729 body <- getBody $ responseLBS undefined undefined $ L.pack bytes

2830 body `shouldBe` S.pack bytes

2931 prop "responseBuilder" $ \bytes -> do

3032 body <- getBody $ responseBuilder undefined undefined

31− $ mconcat $ map word8 bytes

33+ $ mconcat $ map fromWord8 bytes

3234 body `shouldBe` S.pack bytes

3335 prop "responseStream" $ \chunks -> do

3436 body <- getBody $ responseStream undefined undefined $ \sendChunk _ ->

35− forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk

37+ forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk

3638 body `shouldBe` S.concat (map S.pack chunks)

3739 it "responseFile total" $ do

3840 let fp = "wai.cabal"

@@ -55,7 +57,7 @@ spec = do

5557 describe "lazyRequestBody" $ do

5658 prop "works" $ \chunks -> do

5759 ref <- newIORef $ map S.pack $ filter (not . null) chunks

58− let req = defaultRequest

60+ let req = Request

5961 { requestBody = atomicModifyIORef ref $ \bss ->

6062 case bss of

6163 [] -> ([], S.empty)

@@ -64,7 +66,7 @@ spec = do

6466 body <- lazyRequestBody req

6567 body `shouldBe` L.fromChunks (map S.pack chunks)

6668 it "is lazy" $ do

67− let req = defaultRequest

69+ let req = Request

6870 { requestBody = error "requestBody"

6971 }

7072 _ <- lazyRequestBody req

@@ -72,7 +74,7 @@ spec = do

7274 describe "strictRequestBody" $ do

7375 prop "works" $ \chunks -> do

7476 ref <- newIORef $ map S.pack $ filter (not . null) chunks

75− let req = defaultRequest

77+ let req = Request

7678 { requestBody = atomicModifyIORef ref $ \bss ->

7779 case bss of

7880 [] -> ([], S.empty)

wai/wai.cabal+8−8

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

11Name: wai

2−Version: 3.2.2.1

2+Version: 3.0.2.3

33Synopsis: Web Application Interface.

44Description: Provides a common protocol for communication between web applications and web servers.

5− .

6− API docs and the README are available at <http://www.stackage.org/package/wai>.

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

76License: MIT

87License-file: LICENSE

98Author: Michael Snoyman

@@ -20,8 +19,9 @@ Source-repository head

2019 location: git://github.com/yesodweb/wai.git

2120

2221Library

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

24− , bytestring >= 0.10.4

22+ Build-Depends: base >= 4 && < 5

23+ , bytestring >= 0.9.1.4

24+ , blaze-builder >= 0.2.1.4 && < 0.5

2525 , network >= 2.2.1.5

2626 , http-types >= 0.7

2727 , text >= 0.7

@@ -34,14 +34,14 @@ test-suite test

3434 hs-source-dirs: test

3535 main-is: Spec.hs

3636 type: exitcode-stdio-1.0

37− ghc-options: -threaded -Wall

37+ ghc-options: -threaded

3838 cpp-options: -DTEST

39− build-depends: base >= 4.8 && < 5

39+ build-depends: base

4040 , wai

4141 , hspec

42+ , blaze-builder

4243 , bytestring

4344 other-modules: Network.WaiSpec

44− build-tool-depends: hspec-discover:hspec-discover

4545

4646source-repository head

4747 type: git

wai/webkit-sample/webkit-sample.hs+2−2

@@ -5,7 +5,7 @@ import Network.Wai.Handler.Webkit

55import Data.ByteString (ByteString)

66import qualified Data.ByteString.Lazy as L

77import Data.Enumerator (consume, Iteratee)

8−import Data.ByteString.Builder (lazyByteString)

8+import Blaze.ByteString.Builder (fromLazyByteString)

99

1010main :: IO ()

1111main = putStrLn "http://localhost:3000/" >> run "Webkit Sample" app

@@ -27,4 +27,4 @@ postResponse :: L.ByteString -> Iteratee ByteString IO Response

2727postResponse lbs = return $ ResponseBuilder

2828 status200

2929 [("Content-Type", "text/plain")]

30− (lazyByteString lbs)

30+ (fromLazyByteString lbs)

warp-tls/ChangeLog.md−86

@@ -1,89 +1,3 @@

1−## 3.2.11

2−

3−* Ignoring an exception from shutdown (gracefulClose).

4−

5−## 3.2.10

6−

7−* Passing client certificate, if any, to Warp

8− [#783](https://github.com/yesodweb/wai/pull/783)

9−

10−## 3.2.9

11−

12−* Cooperating setGracefulCloseTimeout1 and setGracefulCloseTimeout2 of Warp.

13− [#782](https://github.com/yesodweb/wai/pull/782)

14−

15−## 3.2.8

16−

17−* Using gracefullClose of network 3.1.1 or later if available.

18−

19−## 3.2.7

20−

21−* Relaxing version constraint.

22−

23−## 3.2.6

24−

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

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

27−

28−## 3.2.5

29−

30−* When tls 1.5.0 is available, TLS 1.3 is automatically supported.

31−

32−## 3.2.4.3

33−

34−* Using warp >= 3.2.17.

35−

36−## 3.2.4.2

37−

38−* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640)

39−

40−## 3.2.4

41−

42−* Using tls-session-manager.

43−

44−## 3.2.3

45−

46−* Stop using obsoleted APIs of network.

47−

48−## 3.2.2

49−

50−* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556)

51−* Preventing socket leakage [#559](https://github.com/yesodweb/wai/pull/559)

52−

53−## 3.2.1

54−

55−* Removing dependency to cprng-aes.

56−

57−## 3.2.0

58−

59−* Major version up due to breaking changes.

60−* runHTTP2TLS and runHTTP2TLSSocket were removed.

61−

62−## 3.1.4

63−

64−* Add an option to disable HTTP2 [#450](https://github.com/yesodweb/wai/pull/450)

65−

66−## 3.1.3

67−

68−* Removing SHA 512 and SHA 384 from supportedCiphers to rescue Safari and golang. [#429](https://github.com/yesodweb/wai/issues/429)

69−

70−## 3.1.2

71−

72−* [Getting Rating A from the SSL Server Test](http://www.yesodweb.com/blog/2015/08/ssl-server-test)

73−

74−## 3.1.1

75−

76−* Converting "send: resource vanished (Broken pipe)" to ConnectionClosedByPeer. [#421](https://github.com/yesodweb/wai/issues/421)

77−

78−## 3.1.0

79−

80−* Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399)

81−* Removing RC4 [#400](https://github.com/yesodweb/wai/issues/400)

82−

83−## 3.0.4.2

84−

85−* tls 1.3 support [#390](https://github.com/yesodweb/wai/issues/390)

86−

871## 3.0.4.1

882

893* Fix for leaked FDs [#378](https://github.com/yesodweb/wai/issues/378)

warp-tls/Network/Wai/Handler/WarpTLS.hs+139−263

@@ -1,74 +1,62 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE OverloadedStrings #-}

32{-# LANGUAGE RankNTypes #-}

43{-# LANGUAGE RecordWildCards #-}

54{-# LANGUAGE DeriveDataTypeable #-}

65{-# LANGUAGE PatternGuards #-}

6+{-# LANGUAGE CPP #-}

77

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.

8+-- | HTTP over SSL/TLS support for Warp via the TLS package.

149

1510module Network.Wai.Handler.WarpTLS (

1611 -- * Settings

1712 TLSSettings

18− , defaultTlsSettings

19− -- * Smart constructors

20− , tlsSettings

21− , tlsSettingsMemory

22− , tlsSettingsChain

23− , tlsSettingsChainMemory

24− -- * Accessors

2513 , certFile

2614 , keyFile

15+ , onInsecure

2716 , tlsLogging

2817 , tlsAllowedVersions

2918 , tlsCiphers

3019 , tlsWantClientCert

3120 , tlsServerHooks

32− , tlsServerDHEParams

33− , tlsSessionManagerConfig

34− , onInsecure

21+ , defaultTlsSettings

22+ , tlsSettings

23+ , tlsSettingsMemory

24+ , tlsSettingsChain

25+ , tlsSettingsChainMemory

3526 , OnInsecure (..)

3627 -- * Runner

3728 , runTLS

3829 , runTLSSocket

3930 -- * Exception

4031 , WarpTLSException (..)

41− , DH.Params

42− , DH.generateParams

4332 ) where

4433

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)

34+#if __GLASGOW_HASKELL__ < 709

35+import Control.Applicative ((<$>))

36+#endif

37+import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException)

38+import Control.Monad (unless, void)

39+import qualified Crypto.Random.AESCtr

40+import qualified Data.ByteString as B

4941import qualified Data.ByteString as S

5042import qualified Data.ByteString.Lazy as L

43+import Data.ByteString.Lazy.Internal (defaultChunkSize)

5144import Data.Default.Class (def)

5245import qualified Data.IORef as I

5346import Data.Streaming.Network (bindPortTCP, safeRecv)

5447import 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

48+import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept)

5949import Network.Socket.ByteString (sendAll)

6050import qualified Network.TLS as TLS

61−import qualified Crypto.PubKey.DH as DH

6251import qualified Network.TLS.Extra as TLSExtra

63−import qualified Network.TLS.SessionManager as SM

6452import Network.Wai (Application)

6553import Network.Wai.Handler.Warp

66−import Network.Wai.Handler.Warp.Internal

54+import Network.Wai.Handler.Warp.Buffer (allocateBuffer, bufferSize, freeBuffer)

55+import qualified System.IO as IO

6756import System.IO.Error (isEOFError)

6857

6958----------------------------------------------------------------

7059

71−-- | Settings for WarpTLS.

7260data TLSSettings = TLSSettings {

7361 certFile :: FilePath

7462 -- ^ File containing the certificate.

@@ -80,10 +68,8 @@ data TLSSettings = TLSSettings {

8068 , chainCertsMemory :: [S.ByteString]

8169 , keyMemory :: Maybe S.ByteString

8270 , 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."

71+ -- ^ Do we allow insecure connections with this server as well? Default

72+ -- is a simple text response stating that a secure connection is required.

8773 --

8874 -- Since 1.4.0

8975 , tlsLogging :: TLS.Logging

@@ -93,44 +79,23 @@ data TLSSettings = TLSSettings {

9379 --

9480 -- Since 1.4.0

9581 , 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

10482 -- ^ The TLS versions this server accepts.

10583 --

106− -- >>> tlsAllowedVersions defaultTlsSettings

107− -- [TLS12,TLS11,TLS10]

84+ -- Default: '[TLS.TLS10,TLS.TLS11,TLS.TLS12]'.

10885 --

10986 -- Since 1.4.2

110−#endif

11187 , 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

12088 -- ^ The TLS ciphers this server accepts.

12189 --

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]

90+ -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSEtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'

12491 --

12592 -- Since 1.4.2

126−#endif

12793 , tlsWantClientCert :: Bool

12894 -- ^ Whether or not to demand a certificate from the client. If this

12995 -- is set to True, you must handle received certificates in a server hook

13096 -- or all connections will fail.

13197 --

132− -- >>> tlsWantClientCert defaultTlsSettings

133− -- False

98+ -- Default: False

13499 --

135100 -- Since 3.0.2

136101 , tlsServerHooks :: TLS.ServerHooks

@@ -141,25 +106,9 @@ data TLSSettings = TLSSettings {

141106 -- Default: def

142107 --

143108 -- 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

160109 }

161110

162−-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors).

111+-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name.

163112defaultTlsSettings :: TLSSettings

164113defaultTlsSettings = TLSSettings {

165114 certFile = "certificate.pem"

@@ -170,32 +119,39 @@ defaultTlsSettings = TLSSettings {

170119 , keyMemory = Nothing

171120 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

172121 , 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

122+ , tlsAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12]

178123 , tlsCiphers = ciphers

179124 , tlsWantClientCert = False

180125 , tlsServerHooks = def

181− , tlsServerDHEParams = Nothing

182− , tlsSessionManagerConfig = Nothing

183126 }

184127

185128-- taken from stunnel example in tls-extra

186129ciphers :: [TLS.Cipher]

187−ciphers = TLSExtra.ciphersuite_strong

130+ciphers =

131+ [ TLSExtra.cipher_ECDHE_RSA_AES128GCM_SHA256

132+ , TLSExtra.cipher_DHE_RSA_AES128GCM_SHA256

133+ , TLSExtra.cipher_DHE_RSA_AES256_SHA256

134+ , TLSExtra.cipher_DHE_RSA_AES128_SHA256

135+ , TLSExtra.cipher_DHE_RSA_AES256_SHA1

136+ , TLSExtra.cipher_DHE_RSA_AES128_SHA1

137+ , TLSExtra.cipher_DHE_DSS_AES128_SHA1

138+ , TLSExtra.cipher_DHE_DSS_AES256_SHA1

139+ , TLSExtra.cipher_DHE_DSS_RC4_SHA1

140+ , TLSExtra.cipher_AES128_SHA1

141+ , TLSExtra.cipher_AES256_SHA1

142+ , TLSExtra.cipher_RC4_128_MD5

143+ , TLSExtra.cipher_RC4_128_SHA1

144+ ]

188145

189146----------------------------------------------------------------

190147

191148-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.

192149data OnInsecure = DenyInsecure L.ByteString

193150 | AllowInsecure

194− deriving (Show)

195151

196152----------------------------------------------------------------

197153

198−-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.

154+-- | A smart constructor for 'TLSSettings'.

199155tlsSettings :: FilePath -- ^ Certificate file

200156 -> FilePath -- ^ Key file

201157 -> TLSSettings

@@ -205,7 +161,7 @@ tlsSettings cert key = defaultTlsSettings {

205161 }

206162

207163-- | A smart constructor for 'TLSSettings' that allows specifying

208−-- chain certificates based on 'defaultTlsSettings'.

164+-- chain certificates.

209165--

210166-- Since 3.0.3

211167tlsSettingsChain

@@ -220,7 +176,7 @@ tlsSettingsChain cert chainCerts key = defaultTlsSettings {

220176 }

221177

222178-- | A smart constructor for 'TLSSettings', but uses in-memory representations

223−-- of the certificate and key based on 'defaultTlsSettings'.

179+-- of the certificate and key

224180--

225181-- Since 3.0.1

226182tlsSettingsMemory

@@ -233,7 +189,7 @@ tlsSettingsMemory cert key = defaultTlsSettings

233189 }

234190

235191-- | A smart constructor for 'TLSSettings', but uses in-memory representations

236−-- of the certificate and key based on 'defaultTlsSettings'.

192+-- of the certificate and key

237193--

238194-- Since 3.0.3

239195tlsSettingsChainMemory

@@ -249,12 +205,13 @@ tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings

249205

250206----------------------------------------------------------------

251207

208+

252209-- | Running 'Application' with 'TLSSettings' and 'Settings'.

253210runTLS :: TLSSettings -> Settings -> Application -> IO ()

254211runTLS tset set app = withSocketsDo $

255212 bracket

256213 (bindPortTCP (getPort set) (getHost set))

257− close

214+ sClose

258215 (\sock -> runTLSSocket tset set sock app)

259216

260217----------------------------------------------------------------

@@ -272,186 +229,104 @@ runTLSSocket tlsset@TLSSettings{..} set sock app = do

272229 key <- maybe (S.readFile keyFile) return mkey

273230 either error return $

274231 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

232+ runTLSSocket' tlsset set credential sock app

279233

280−runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager -> Socket -> Application -> IO ()

281−runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =

234+runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO ()

235+runTLSSocket' tlsset@TLSSettings{..} set credential sock app =

282236 runSettingsConnectionMakerSecure set get app

283237 where

284− get = getter tlsset set sock params

285− params = def { -- TLS.ServerParams

238+ get = getter tlsset sock params

239+ params = def {

286240 TLS.serverWantClientCert = tlsWantClientCert

287− , TLS.serverCACertificates = []

288− , TLS.serverDHEParams = tlsServerDHEParams

289− , TLS.serverHooks = hooks

290− , TLS.serverShared = shared

291− , TLS.serverSupported = supported

292−#if MIN_VERSION_tls(1,5,0)

293− , TLS.serverEarlyDataSize = 2018

294−#endif

295− }

296− -- Adding alpn to user's tlsServerHooks.

297− hooks = tlsServerHooks {

298− TLS.onALPNClientSuggest = TLS.onALPNClientSuggest tlsServerHooks <|>

299− (if settingsHTTP2Enabled set then Just alpn else Nothing)

241+ , TLS.serverSupported = def {

242+ TLS.supportedVersions = tlsAllowedVersions

243+ , TLS.supportedCiphers = tlsCiphers

244+ }

245+ , TLS.serverShared = def {

246+ TLS.sharedCredentials = TLS.Credentials [credential]

247+ }

248+ , TLS.serverHooks = tlsServerHooks

300249 }

301− shared = def {

302− TLS.sharedCredentials = TLS.Credentials [credential]

303− , TLS.sharedSessionManager = mgr

304− }

305− supported = def { -- TLS.Supported

306− TLS.supportedVersions = tlsAllowedVersions

307− , TLS.supportedCiphers = tlsCiphers

308− , TLS.supportedCompressions = [TLS.nullCompression]

309− , TLS.supportedSecureRenegotiation = True

310− , TLS.supportedClientInitiatedRenegotiation = False

311− , TLS.supportedSession = True

312− , TLS.supportedFallbackScsv = True

313−#if MIN_VERSION_tls(1,5,0)

314− , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]

315−#endif

316− }

317−

318−alpn :: [S.ByteString] -> IO S.ByteString

319−alpn xs

320− | "h2" `elem` xs = return "h2"

321− | otherwise = return "http/1.1"

322250

323251----------------------------------------------------------------

324252

325−getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

326−getter tlsset@TLSSettings{..} set sock params = do

327−#if WINDOWS

328− (s, sa) <- windowsThreadBlockHack $ accept sock

329−#else

253+getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

254+getter tlsset@TLSSettings{..} sock params = do

330255 (s, sa) <- accept sock

331−#endif

332− setSocketCloseOnExec s

333− return (mkConn tlsset set s params, sa)

256+ return (mkConn tlsset s params, sa)

334257

335−mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)

336−mkConn tlsset set s params = switch `onException` close s

337− where

338− switch = do

339− firstBS <- safeRecv s 4096

340− if not (S.null firstBS) && S.head firstBS == 0x16 then

341− httpOverTls tlsset set s firstBS params

342− else

343− plainHTTP tlsset set s firstBS

258+mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)

259+mkConn tlsset s params = do

260+ firstBS <- safeRecv s 4096

261+ cachedRef <- I.newIORef firstBS

262+ (if not (B.null firstBS) && B.head firstBS == 0x16 then

263+ httpOverTls tlsset s cachedRef params

264+ else

265+ plainHTTP tlsset s cachedRef) `onException` sClose s

344266

345267----------------------------------------------------------------

346268

347−httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)

348−httpOverTls TLSSettings{..} _set s bs0 params = do

349− recvN <- makePlainReceiveN s bs0

350− ctx <- TLS.contextNew (backend recvN) params

269+httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport)

270+httpOverTls TLSSettings{..} s cachedRef params = do

271+ gen <- Crypto.Random.AESCtr.makeSystem

272+ ctx <- TLS.contextNew backend params gen

351273 TLS.contextHookSetLogging ctx tlsLogging

352274 TLS.handshake ctx

353− h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx

354− isH2 <- I.newIORef h2

275+ readBuf <- allocateBuffer bufferSize

355276 writeBuf <- allocateBuffer bufferSize

356− -- Creating a cache for leftover input data.

357− ref <- I.newIORef ""

358277 tls <- getTLSinfo ctx

359− return (conn ctx writeBuf ref isH2, tls)

278+ return (conn ctx readBuf writeBuf, tls)

360279 where

361− backend recvN = TLS.Backend {

280+ backend = TLS.Backend {

362281 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

282+ , TLS.backendClose = sClose s

283+ , TLS.backendSend = sendAll s

284+ , TLS.backendRecv = recvTLS cachedRef s

370285 }

371− sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->

372− throwIO ConnectionClosedByPeer

373− conn ctx writeBuf ref isH2 = Connection {

286+ conn ctx readBuf writeBuf = Connection {

374287 connSendMany = TLS.sendData ctx . L.fromChunks

375− , connSendAll = sendall

288+ , connSendAll = TLS.sendData ctx . L.fromChunks . return

376289 , connSendFile = sendfile

377− , connClose = close'

378− , connFree = freeBuffer writeBuf

379− , connRecv = recv ref

380− , connRecvBuf = recvBuf ref

290+ , connClose = close

291+ , connRecv = recv

292+ , connSendFileOverride = NotOverride

293+ , connReadBuffer = readBuf

381294 , connWriteBuffer = writeBuf

382295 , connBufferSize = bufferSize

383− , connHTTP2 = isH2

384296 }

385297 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

298+ sendfile fp offset len tickle' headers = do

299+ TLS.sendData ctx $ L.fromChunks headers

300+ IO.withBinaryFile fp IO.ReadMode $ \h -> do

301+ IO.hSeek h IO.AbsoluteSeek offset

302+ loop h $ fromIntegral len

303+ where

304+ loop _ remaining | remaining <= 0 = return ()

305+ loop h remaining = do

306+ bs <- B.hGetSome h defaultChunkSize

307+ unless (B.null bs) $ do

308+ let x = B.take remaining bs

309+ TLS.sendData ctx $ L.fromChunks [x]

310+ void $ tickle' -- This tickles the Timer. It MUST be called per chunk.

311+ loop h $ remaining - B.length x

312+

313+ close = freeBuffer readBuf `finally`

314+ freeBuffer writeBuf `finally`

315+ void (tryIO $ TLS.bye ctx) `finally`

316+ TLS.contextClose ctx

317+

318+ recv = handle onEOF go

413319 where

414320 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

321+ | Just TLS.Error_EOF <- fromException e = return B.empty

322+ | Just ioe <- fromException e, isEOFError ioe = return B.empty | otherwise = throwIO e

417323 go = do

418324 x <- TLS.recvData ctx

419− if S.null x then

325+ if B.null x then

420326 go

421327 else

422328 return x

423329

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−

455330getTLSinfo :: TLS.Context -> IO Transport

456331getTLSinfo ctx = do

457332 proto <- TLS.getNegotiatedProtocol ctx

@@ -465,16 +340,11 @@ getTLSinfo ctx = do

465340 TLS.TLS10 -> (3,1)

466341 TLS.TLS11 -> (3,2)

467342 TLS.TLS12 -> (3,3)

468−#if MIN_VERSION_tls(1,5,0)

469− TLS.TLS13 -> (3,4)

470−#endif

471− clientCert <- TLS.getClientCertificateChain ctx

472343 return TLS {

473344 tlsMajorVersion = major

474345 , tlsMinorVersion = minor

475346 , tlsNegotiatedProtocol = proto

476347 , tlsChiperID = TLS.cipherID infoCipher

477− , tlsClientCertificate = clientCert

478348 }

479349

480350tryIO :: IO a -> IO (Either IOException a)

@@ -482,46 +352,52 @@ tryIO = try

482352

483353----------------------------------------------------------------

484354

485−plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)

486−plainHTTP TLSSettings{..} set s bs0 = case onInsecure of

355+plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport)

356+plainHTTP TLSSettings{..} s cachedRef = case onInsecure of

487357 AllowInsecure -> do

488− conn' <- socketConnection set s

489− cachedRef <- I.newIORef bs0

358+ conn' <- socketConnection s

490359 let conn'' = conn'

491360 { connRecv = recvPlain cachedRef (connRecv conn')

492361 }

493362 return (conn'', TCP)

494363 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"

364+ sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"

509365 mapM_ (sendAll s) $ L.toChunks lbs

510− close s

366+ sClose s

511367 throwIO InsecureConnectionDenied

512368

513369----------------------------------------------------------------

514370

371+recvTLS :: I.IORef B.ByteString -> Socket -> Int -> IO B.ByteString

372+recvTLS cachedRef s size = do

373+ cached <- I.readIORef cachedRef

374+ loop cached

375+ where

376+ loop bs | B.length bs >= size = do

377+ let (x, y) = B.splitAt size bs

378+ I.writeIORef cachedRef y

379+ return x

380+ loop bs1 = do

381+ bs2 <- safeRecv s 4096

382+ if B.null bs2 then do

383+ -- FIXME does this deserve an exception being thrown?

384+ I.writeIORef cachedRef B.empty

385+ return bs1

386+ else

387+ loop $ B.append bs1 bs2

388+

389+----------------------------------------------------------------

390+

515391-- | Modify the given receive function to first check the given @IORef@ for a

516392-- chunk of data. If present, takes the chunk of data from the @IORef@ and

517393-- empties out the @IORef@. Otherwise, calls the supplied receive function.

518−recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString

394+recvPlain :: I.IORef B.ByteString -> IO B.ByteString -> IO B.ByteString

519395recvPlain ref fallback = do

520396 bs <- I.readIORef ref

521− if S.null bs

397+ if B.null bs

522398 then fallback

523399 else do

524− I.writeIORef ref S.empty

400+ I.writeIORef ref B.empty

525401 return bs

526402

527403----------------------------------------------------------------

warp-tls/warp-tls.cabal+9−20

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

11Name: warp-tls

2−Version: 3.2.11

3−Synopsis: HTTP over TLS support for Warp via the TLS package

2+Version: 3.0.4.1

3+Synopsis: HTTP over SSL/TLS support for Warp via the TLS package

44License: MIT

55License-file: LICENSE

66Author: Michael Snoyman

@@ -8,34 +8,23 @@ Maintainer: michael@snoyman.com

88Homepage: http://github.com/yesodweb/wai

99Category: Web, Yesod

1010Build-Type: Simple

11−Cabal-Version: >= 1.10

11+Cabal-Version: >=1.6

1212Stability: Stable

13−description: SSLv1 and SSLv2 are obsoleted by IETF.

14− We should use TLS 1.2 (or TLS 1.1 or TLS 1.0 if necessary).

15− HTTP/2 can be negotiated by ALPN.

16− API docs and the README are available at

17− <http://www.stackage.org/package/warp-tls>.

13+description: API docs and the README are available at <http://www.stackage.org/package/warp-tls>.

1814extra-source-files: ChangeLog.md README.md

1915

2016Library

21− Build-Depends: base >= 4.10 && < 5

17+ Build-Depends: base >= 4 && < 5

2218 , bytestring >= 0.9

23− , wai >= 3.2 && < 3.3

24− , warp >= 3.3.6 && < 3.4

19+ , wai >= 3.0 && < 3.1

20+ , warp >= 3.0.8 && < 3.1

2521 , data-default-class >= 0.0.1

26− , tls >= 1.5.3

27− , cryptonite >= 0.12

22+ , tls >= 1.2.16

2823 , network >= 2.2.1

24+ , cprng-aes >= 0.5.0

2925 , streaming-commons

30− , tls-session-manager >= 0.0.4

3126 Exposed-modules: Network.Wai.Handler.WarpTLS

3227 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−

3928

4029source-repository head

4130 type: git

warp/.ghci+1−1

@@ -1 +1 @@

1−:set -itest -idist/build/autogen -i.stack-work/dist/x86_64-linux/Cabal-1.22.5.0/build/autogen

1+:set -itest -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h

warp/ChangeLog.md−298

@@ -1,301 +1,3 @@

1−## 3.3.9

2−

3−* Don't insert Last-Modified: if exists.

4− [#791](https://github.com/yesodweb/wai/pull/791)

5−

6−## 3.3.8

7−

8−* Maximum header size is configurable.

9− [#781](https://github.com/yesodweb/wai/pull/781)

10−* Ignoring an exception from shutdown (gracefulClose).

11−

12−## 3.3.7

13−

14−* InvalidArgument (Bad file descriptor) is ignored in `receive`.

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

16−

17−## 3.3.6

18−

19−* Fixing a bug of thread killed in the case of event source with

20− HTTP/2 (fixing #692 and #785)

21−* New APIs: clientCertificate to get client's certificate

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

23−

24−## 3.3.5

25−

26−* New APIs: setGracefulCloseTimeout1 and setGracefulCloseTimeout2.

27− For HTTP/1.x, connections are closed immediately by default.

28− gracefullClose is used for HTTP/2 by default.

29− [#782](https://github.com/yesodweb/wai/pull/782)

30−

31−## 3.3.4

32−

33−* Setting isSecure of HTTP/2 correctly.

34−

35−## 3.3.3

36−

37−* Calling setOnException in HTTP/2.

38− [#771](https://github.com/yesodweb/wai/pull/771)

39−

40−## 3.3.2

41−

42−* Fixing a bug of HTTP/2 without fd cache.

43−

44−## 3.3.1

45−

46−* Using gracefullClose of network 3.1.1 or later if available.

47−* If the first line of an HTTP request is really invalid,

48− don't send an error response

49−

50−## 3.3.0

51−

52−* Switching from the original implementation to HTTP/2 server library.

53− [#754](https://github.com/yesodweb/wai/pull/754)

54−* Breaking change: The type of `http2dataTrailers` is now

55− `HTTP2Data -> TrailersMaker`.

56−

57−## 3.2.28

58−

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

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

61−* System.TimeManager is now in a separate package: time-manager.

62− [#750](https://github.com/yesodweb/wai/pull/750)

63−* Fixing a bug of ALPN.

64−* Introducing the half closed state for HTTP/2.

65− [#717](https://github.com/yesodweb/wai/pull/717)

66−

67−## 3.2.27

68−

69−* Internally, use `lookupEnv` instead of `getEnvironment` to get the

70− value of the `PORT` environment variable

71− [#736](https://github.com/yesodweb/wai/pull/736)

72−* Throw 413 for too large payload

73−* Throw 431 for too large headers

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

75−* Use exception response handler in HTTP/2 & improve connection preservation

76− in HTTP/1.x if uncaught exceptions are thrown in an `Application`.

77− [#738](https://github.com/yesodweb/wai/pull/738)

78−

79−## 3.2.26

80−

81−* Support network package version 3

82−

83−## 3.2.25

84−

85−* Removing Connection: and Transfer-Encoding: from HTTP/2

86− response header

87− [#707](https://github.com/yesodweb/wai/pull/707)

88−

89−## 3.2.24

90−

91−* Fix HTTP2 unwanted GoAways on late WindowUpdate frames.

92− [#711](https://github.com/yesodweb/wai/pull/711)

93−

94−## 3.2.23

95−

96−* Log real requsts when an app throws an error.

97− [#698](https://github.com/yesodweb/wai/pull/698)

98−

99−## 3.2.22

100−

101−* Fixing large request body in HTTP/2.

102−

103−## 3.2.21

104−

105−* Fixing HTTP/2's timeout handler in request's vault.

106−

107−## 3.2.20

108−

109−* Fixing large request body in HTTP/2

110− [#593](https://github.com/yesodweb/wai/issues/593)

111−

112−## 3.2.19

113−

114−* Fixing 0-byte request body in HTTP/2

115− [#597](https://github.com/yesodweb/wai/issues/597)

116− [#679](https://github.com/yesodweb/wai/issues/679)

117−

118−## 3.2.18.2

119−

120−* Replace dependency on `blaze-builder` with `bsb-http-chunked`

121−

122−## 3.2.18.1

123−

124−* Fix benchmark compilation [#681](https://github.com/yesodweb/wai/issues/681)

125−

126−## 3.2.18

127−

128−* Make `testWithApplicationSettings` actually use the settings passed.

129− [#677](https://github.com/yesodweb/wai/pull/677).

130−

131−## 3.2.17

132−* Add support for windows thread block hack and closeOnExec to TLS.

133− [#674](https://github.com/yesodweb/wai/pull/674).

134−

135−## 3.2.16

136−

137−* In `testWithApplication`, don't `throwTo` ignorable exceptions

138− [#671](https://github.com/yesodweb/wai/issues/671), and

139− reuse `bindRandomPortTCP`

140−

141−## 3.2.15

142−

143−* Address space leak from exception handlers

144− [#649](https://github.com/yesodweb/wai/issues/649)

145−

146−## 3.2.14

147−

148−* Support streaming-commons 0.2

149−* Warnings cleanup

150−

151−## 3.2.13

152−

153−* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)

154−* Guarantee atomicity of WINDOW_UPDATE increments [622](https://github.com/yesodweb/wai/pull/622)

155−* Relax HTTP2 headers check [621](https://github.com/yesodweb/wai/pull/621)

156−

157−## 3.2.12

158−

159−* If an empty string is set by setServerName, the Server header is not included in response headers [#619](https://github.com/yesodweb/wai/issues/619)

160−

161−## 3.2.11.2

162−

163−* Don't throw exceptions when closing a keep-alive connection

164− [#618](https://github.com/yesodweb/wai/issues/618)

165−

166−## 3.2.11.1

167−

168−* Move exception handling to top of thread (fixes

169− [#613](https://github.com/yesodweb/wai/issues/613))

170−

171−## 3.2.11

172−

173−* Fixing 10 HTTP2 bugs pointed out by h2spec v2.

174−

175−## 3.2.10

176−

177−* Add `connFree` to `Connection`. Close socket connections on timeout triggered. Timeout exceptions extend from `SomeAsyncException`. [#602](https://github.com/yesodweb/wai/pull/602) [#605](https://github.com/yesodweb/wai/pull/605)

178−

179−## 3.2.9

180−

181−* Fixing a space leak. [#586](https://github.com/yesodweb/wai/pull/586)

182−

183−## 3.2.8

184−

185−* Fixing HTTP2 requestBodyLength. [#573](https://github.com/yesodweb/wai/pull/573)

186−* Making HTTP/2 :path optional for the CONNECT method. [#572](https://github.com/yesodweb/wai/pull/572)

187−* Adding new APIs for HTTP/2 trailers: http2dataTrailers and modifyHTTP2Data [#566](https://github.com/yesodweb/wai/pull/566)

188−

189−## 3.2.7

190−

191−* Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data [#510](https://github.com/yesodweb/wai/pull/510)

192−* Better accept(2) error handling [#553](https://github.com/yesodweb/wai/pull/553)

193−* Adding getGracefulShutdownTimeout.

194−* Add {test,}withApplicationSettings [#531](https://github.com/yesodweb/wai/pull/531)

195−

196−## 3.2.6

197−

198−* Using token based APIs of http2 1.6.

199−

200−## 3.2.5

201−

202−* Ignoring errors from setSocketOption. [#526](https://github.com/yesodweb/wai/issues/526).

203−

204−## 3.2.4

205−

206−* Added `withApplication`, `testWithApplication`, and `openFreePort`

207−* Fixing reaper delay value of file info cache.

208−

209−## 3.2.3

210−

211−* Using http2 v1.5.x which much improves the performance of HTTP/2.

212−* To get rid of the bottleneck of ByteString's (==), a new logic to

213− compare header names is introduced.

214−

215−## 3.2.2

216−

217−* Throwing errno for pread [#499](https://github.com/yesodweb/wai/issues/499).

218−* Makeing compilable on Windows [#505](https://github.com/yesodweb/wai/issues/505).

219−

220−## 3.2.1

221−

222−* Add back `warpVersion`

223−

224−## 3.2.0

225−

226−* Major version up due to breaking changes. This is because the HTTP/2 code

227− was started over with Warp 3.1.3 due to performance issue [#470](https://github.com/yesodweb/wai/issues/470).

228−* runHTTP2, runHTTP2Env, runHTTP2Settings and runHTTP2SettingsSocket were removed from the Network.Wai.Handler.Warp module.

229−* The performance of HTTP/2 was drastically improved. Now the performance of HTTP/2 is almost the same as that of HTTP/1.1.

230−* The logic to handle files in HTTP/2 is now identical to that in HTTP/1.1.

231−* Internal stuff was removed from the Network.Wai.Handler.Warp module according to [the plan](http://www.yesodweb.com/blog/2015/06/cleaning-up-warp-apis).

232−

233−## 3.1.12

234−

235−* Setting lower bound for auto-update [#495](https://github.com/yesodweb/wai/issues/495)

236−

237−## 3.1.11

238−

239−* Providing a new API: killManager.

240−* Preventing space leaks due to Weak ThreadId [#488](https://github.com/yesodweb/wai/issues/488)

241−* Setting upper bound for http2.

242−

243−## 3.1.10

244−

245−* `setFileInfoCacheDuration`

246−* `setLogger`

247−* `FileInfo`/`getFileInfo`

248−* Fix: warp-tls strips out the Host request header [#478](https://github.com/yesodweb/wai/issues/478)

249−

250−## 3.1.9

251−

252−* Using the new priority queue based on PSQ provided by http2 lib again.

253−

254−## 3.1.8

255−

256−* Using the new priority queue based on PSQ provided by http2 lib.

257−

258−## 3.1.7

259−

260−* A concatenated Cookie header is prepended to the headers to ensure that it flows pseudo headers. [#454](https://github.com/yesodweb/wai/pull/454)

261−* Providing a new settings: `setHTTP2Disabled` [#450](https://github.com/yesodweb/wai/pull/450)

262−

263−## 3.1.6

264−

265−* Adding back http-types 0.8 support [#449](https://github.com/yesodweb/wai/pull/449)

266−

267−## 3.1.5

268−

269−* Using http-types v0.9.

270−* Fixing build on OpenBSD. [#428](https://github.com/yesodweb/wai/pull/428) [#440](https://github.com/yesodweb/wai/pull/440)

271−* Fixing build on Windows. [#438](https://github.com/yesodweb/wai/pull/438)

272−

273−## 3.1.4

274−

275−* Using newer http2 library to prevent change table size attacks.

276−* API for HTTP/2 server push and trailers. [#426](https://github.com/yesodweb/wai/pull/426)

277−* Preventing response splitting attacks. [#435](https://github.com/yesodweb/wai/pull/435)

278−* Concatenating multiple Cookie: headers in HTTP/2.

279−

280−## 3.1.3

281−

282−* Warp now supports blaze-builder v0.4 or later only.

283−* HTTP/2 code was improved: dynamic priority change, efficient queuing and sender loop continuation. [#423](https://github.com/yesodweb/wai/pull/423) [#424](https://github.com/yesodweb/wai/pull/424)

284−

285−## 3.1.2

286−

287−* Configurable Slowloris size [#418](https://github.com/yesodweb/wai/pull/418)

288−

289−## 3.1.1

290−

291−* Fixing a bug of HTTP/2 when no FD cache is used [#411](https://github.com/yesodweb/wai/pull/411)

292−* Fixing a buffer-pool bug [#406](https://github.com/yesodweb/wai/pull/406) [#407](https://github.com/yesodweb/wai/pull/407)

293−

294−## 3.1.0

295−

296−* Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399)

297−* Cleaning up APIs [#387](https://github.com/yesodweb/wai/issues/387)

298−

2991## 3.0.13.1

3002

3013* Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375)

warp/Network/Wai/Handler/Warp.hs+63−247

@@ -19,9 +19,6 @@

1919

2020-- | A fast, light-weight HTTP server handler for WAI.

2121--

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

2522-- Note on slowloris timeouts: to prevent slowloris attacks, timeouts are used

2623-- at various points in request receiving and response sending. One interesting

2724-- corner case is partial request body consumption; in that case, Warp's

@@ -38,12 +35,13 @@

3835--

3936module Network.Wai.Handler.Warp (

4037 -- * Run a Warp server

41− -- | All of these automatically serve the same 'Application' over HTTP\/1,

42− -- HTTP\/1.1, and HTTP\/2.

4338 run

4439 , runEnv

4540 , runSettings

4641 , runSettingsSocket

42+ , runSettingsConnection

43+ , runSettingsConnectionMaker

44+ , runSettingsConnectionMakerSecure

4745 -- * Settings

4846 , Settings

4947 , defaultSettings

@@ -57,7 +55,6 @@ module Network.Wai.Handler.Warp (

5755 , setTimeout

5856 , setManager

5957 , setFdCacheDuration

60− , setFileInfoCacheDuration

6158 , setBeforeMainLoop

6259 , setNoParsePath

6360 , setInstallShutdownHandler

@@ -67,87 +64,76 @@ module Network.Wai.Handler.Warp (

6764 , setProxyProtocolNone

6865 , setProxyProtocolRequired

6966 , setProxyProtocolOptional

70− , setSlowlorisSize

71− , setHTTP2Disabled

72− , setLogger

73− , setServerPushLogger

74− , setGracefulShutdownTimeout

75− , setGracefulCloseTimeout1

76− , setGracefulCloseTimeout2

77− , setMaxTotalHeaderLength

7867 -- ** Getters

7968 , getPort

8069 , 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

70+ -- ** Accessors

71+ -- | Note: these accessors are deprecated, please use the @set@ versions instead.

72+ , settingsPort

73+ , settingsHost

74+ , settingsOnException

75+ , settingsOnExceptionResponse

76+ , settingsOnOpen

77+ , settingsOnClose

78+ , settingsTimeout

79+ , settingsManager

80+ , settingsFdCacheDuration

81+ , settingsBeforeMainLoop

82+ , settingsNoParsePath

83+ -- ** Debugging

9284 , exceptionResponseForDebug

85+ , defaultShouldDisplayException

9386 -- * Data types

94− , HostPreference

87+ , Transport (..)

88+ , HostPreference (..)

9589 , Port

9690 , InvalidRequest (..)

97− -- * Utilities

91+ , ConnSendFileOverride (..)

92+ -- * Per-request utilities

9893 , pauseTimeout

99− , FileInfo(..)

100− , getFileInfo

101− , clientCertificate

102− , withApplication

103− , withApplicationSettings

104− , testWithApplication

105− , testWithApplicationSettings

106− , openFreePort

107− -- * Version

94+ -- * Connection

95+ , Connection (..)

96+ , socketConnection

97+ -- * Internal

98+ -- ** Version

10899 , warpVersion

109− -- * HTTP/2

110− -- ** HTTP2 data

111− , HTTP2Data

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

100+ -- ** Data types

101+ , InternalInfo (..)

102+ , HeaderValue

103+ , IndexedHeader

104+ , requestMaxIndex

105+ -- ** Time out manager

106+ , module Network.Wai.Handler.Warp.Timeout

107+ -- ** File descriptor cache

108+ , module Network.Wai.Handler.Warp.FdCache

109+ -- ** Date

110+ , module Network.Wai.Handler.Warp.Date

111+ -- ** Request and response

112+ , recvRequest

113+ , sendResponse

125114 ) where

126115

127−import Control.Exception (SomeException, throwIO)

128−import Data.Streaming.Network (HostPreference)

129−import qualified Data.Vault.Lazy as Vault

130−import Data.X509

131−import qualified Network.HTTP.Types as H

132−import Network.Socket (SockAddr)

133−import Network.Wai (Request, Response, vault)

134−import System.TimeManager

135−

136−import Network.Wai.Handler.Warp.FileInfoCache

137−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

138−import Network.Wai.Handler.Warp.HTTP2.Types

139−import Network.Wai.Handler.Warp.Imports

116+import Network.Wai.Handler.Warp.Date

117+import Network.Wai.Handler.Warp.FdCache

118+import Network.Wai.Handler.Warp.Header

140119import Network.Wai.Handler.Warp.Request

141−import Network.Wai.Handler.Warp.Response (warpVersion)

120+import Network.Wai.Handler.Warp.Response

142121import Network.Wai.Handler.Warp.Run

143122import Network.Wai.Handler.Warp.Settings

144−import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

145−import Network.Wai.Handler.Warp.WithApplication

123+import Network.Wai.Handler.Warp.Timeout

124+import Network.Wai.Handler.Warp.Types

125+import Control.Exception (SomeException)

126+import Network.Wai (Request, Response, vault)

127+import Network.Socket (SockAddr)

128+import Data.Streaming.Network (HostPreference)

129+import Data.ByteString (ByteString)

130+import qualified Data.Vault.Lazy as Vault

131+import Data.Maybe (fromMaybe)

146132

147133-- | Port to listen on. Default value: 3000

148134--

149135-- Since 2.1.0

150−setPort :: Port -> Settings -> Settings

136+setPort :: Int -> Settings -> Settings

151137setPort x y = y { settingsPort = x }

152138

153139-- | Interface to bind to. Default value: HostIPv4

@@ -157,24 +143,16 @@ setHost :: HostPreference -> Settings -> Settings

157143setHost x y = y { settingsHost = x }

158144

159145-- | What to do with exceptions thrown by either the application or server.

160−-- Default: 'defaultOnException'

146+-- Default: ignore server-generated exceptions (see 'InvalidRequest') and print

147+-- application-generated exceptions to stderr.

161148--

162149-- Since 2.1.0

163150setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings

164151setOnException x y = y { settingsOnException = x }

165152

166153-- | A function to create a `Response` when an exception occurs.

167−-- Default: 'defaultOnExceptionResponse'

168−--

169−-- Note that an application can handle its own exceptions without interfering with Warp:

170154--

171−-- > myApp :: Application

172−-- > myApp request respond = innerApp `catch` onError

173−-- > where

174−-- > onError = respond . response500 request

175−-- >

176−-- > response500 :: Request -> SomeException -> Response

177−-- > response500 req someEx = responseLBS status500 -- ...

155+-- Default: 500, text/plain, \"Something went wrong\"

178156--

179157-- Since 2.1.0

180158setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings

@@ -217,26 +195,10 @@ setManager x y = y { settingsManager = Just x }

217195-- Enabling this cache results in drastic performance improvement for file

218196-- transfers.

219197--

220−-- Default value: 0, was previously 10

221−--

222−-- Since 3.0.13

198+-- Default value: since 3.0.13, default value is 0, was previously 10

223199setFdCacheDuration :: Int -> Settings -> Settings

224200setFdCacheDuration x y = y { settingsFdCacheDuration = x }

225201

226−-- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used.

227−--

228−-- The file information cache is an optimization that is useful for servers dealing with

229−-- static files. However, if files are being modified, it can cause incorrect

230−-- results in some cases. Therefore, we disable it by default. If you know that

231−-- your files will be static or you prefer performance to file consistency,

232−-- it's recommended to turn this on; a reasonable value for those cases is 10.

233−-- Enabling this cache results in drastic performance improvement for file

234−-- transfers.

235−--

236−-- Default value: 0

237−setFileInfoCacheDuration :: Int -> Settings -> Settings

238−setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }

239−

240202-- | Code to run after the listening socket is ready but before entering

241203-- the main event loop. Useful for signaling to tests that they can start

242204-- running, or to drop permissions after binding to a restricted port.

@@ -260,7 +222,7 @@ setNoParsePath x y = y { settingsNoParsePath = x }

260222-- | Get the listening port.

261223--

262224-- Since 2.1.1

263−getPort :: Settings -> Port

225+getPort :: Settings -> Int

264226getPort = settingsPort

265227

266228-- | Get the interface to bind to.

@@ -269,51 +231,11 @@ getPort = settingsPort

269231getHost :: Settings -> HostPreference

270232getHost = settingsHost

271233

272−-- | Get the action on opening connection.

273−getOnOpen :: Settings -> SockAddr -> IO Bool

274−getOnOpen = settingsOnOpen

275−

276−-- | Get the action on closeing connection.

277−getOnClose :: Settings -> SockAddr -> IO ()

278−getOnClose = settingsOnClose

279−

280−-- | Get the exception handler.

281−getOnException :: Settings -> Maybe Request -> SomeException -> IO ()

282−getOnException = settingsOnException

283−

284−-- | Get the graceful shutdown timeout

285−--

286−-- Since 3.2.8

287−getGracefulShutdownTimeout :: Settings -> Maybe Int

288−getGracefulShutdownTimeout = settingsGracefulShutdownTimeout

289−

290234-- | A code to install shutdown handler.

291235--

292236-- For instance, this code should set up a UNIX signal

293237-- handler. The handler should call the first argument,

294−-- which closes the listen socket, at shutdown.

295−--

296−-- Example usage:

297−--

298−-- @

299−-- settings :: IO () -> 'Settings'

300−-- settings shutdownAction = 'setInstallShutdownHandler' shutdownHandler 'defaultSettings'

301−-- __where__

302−-- shutdownHandler closeSocket =

303−-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'

304−-- @

305−--

306−-- Note that by default, the graceful shutdown mode lasts indefinitely

307−-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,

308−-- upon receiving that signal, the custon shutdown action will run /and/ all

309−-- outstanding requests will be handled.

310−--

311−-- You may instead prefer to do one or both of the following:

312−--

313−-- * Only wait a finite amount of time for outstanding requests to complete,

314−-- using 'setGracefulShutdownTimeout'.

315−-- * Only catch one signal, so the second hard-kills the Warp server, using

316−-- 'System.Posix.Signals.CatchOnce'.

238+-- which close the listen socket, at shutdown.

317239--

318240-- Default: does not install any code.

319241--

@@ -321,10 +243,7 @@ getGracefulShutdownTimeout = settingsGracefulShutdownTimeout

321243setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings

322244setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }

323245

324−-- | Default server name to be sent as the \"Server:\" header

325−-- if an application does not set one.

326−-- If an empty string is set, the \"Server:\" header is not sent.

327−-- This is true even if an application set one.

246+-- | Default server name if application does not set one.

328247--

329248-- Since 3.0.2

330249setServerName :: ByteString -> Settings -> Settings

@@ -385,7 +304,7 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }

385304--

386305-- WARNING: This is contrary to the PROXY protocol specification and

387306-- using it can indicate a security problem with your

388−-- architecture if the web server is directly accessible

307+-- architecture if the web server is directly accessable

389308-- to the public, since it would allow easy IP address

390309-- spoofing. However, it can be useful in some cases,

391310-- such as if a load balancer health check uses regular

@@ -396,54 +315,6 @@ setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }

396315setProxyProtocolOptional :: Settings -> Settings

397316setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional }

398317

399−-- | Size in bytes read to prevent Slowloris attacks. Default value: 2048

400−--

401−-- Since 3.1.2

402−setSlowlorisSize :: Int -> Settings -> Settings

403−setSlowlorisSize x y = y { settingsSlowlorisSize = x }

404−

405−-- | Disable HTTP2.

406−--

407−-- Since 3.1.7

408−setHTTP2Disabled :: Settings -> Settings

409−setHTTP2Disabled y = y { settingsHTTP2Enabled = False }

410−

411−-- | Setting a log function.

412−--

413−-- Since 3.X.X

414−setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -- ^ request, status, maybe file-size

415− -> Settings

416− -> Settings

417−setLogger lgr y = y { settingsLogger = lgr }

418−

419−-- | Setting a log function for HTTP/2 server push.

420−--

421−-- Since: 3.2.7

422−setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size

423− -> Settings

424− -> Settings

425−setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }

426−

427−-- | Set the graceful shutdown timeout. A timeout of `Nothing' will

428−-- wait indefinitely, and a number, if provided, will be treated as seconds

429−-- to wait for requests to finish, before shutting down the server entirely.

430−--

431−-- Graceful shutdown mode is entered when the server socket is closed; see

432−-- 'setInstallShutdownHandler' for an example of how this could be done in

433−-- response to a UNIX signal.

434−--

435−-- Since 3.2.8

436−setGracefulShutdownTimeout :: Maybe Int

437− -> Settings -> Settings

438−setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

439−

440−-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.

441−--

442−-- Since 3.3.8

443−setMaxTotalHeaderLength :: Int -> Settings -> Settings

444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446−

447318-- | Explicitly pause the slowloris timeout.

448319--

449320-- This is useful for cases where you partially consume a request body. For

@@ -452,58 +323,3 @@ setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

452323-- Since 3.0.10

453324pauseTimeout :: Request -> IO ()

454325pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

455−

456−-- | Getting file information of the target file.

457−--

458−-- This function first uses a stat(2) or similar system call

459−-- to obtain information of the target file, then registers

460−-- it into the internal cache.

461−-- From the next time, the information is obtained

462−-- from the cache. This reduces the overhead to call the system call.

463−-- The internal cache is refreshed every duration specified by

464−-- 'setFileInfoCacheDuration'.

465−--

466−-- This function throws an 'IO' exception if the information is not

467−-- available. For instance, the target file does not exist.

468−-- If this function is used an a Request generated by a WAI

469−-- backend besides Warp, it also throws an 'IO' exception.

470−--

471−-- Since 3.1.10

472−getFileInfo :: Request -> FilePath -> IO FileInfo

473−getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

474−

475−-- | A timeout to limit the time (in milliseconds) waiting for

476−-- FIN for HTTP/1.x. 0 means uses immediate close.

477−-- Default: 0.

478−--

479−-- Since 3.3.5

480−setGracefulCloseTimeout1 :: Int -> Settings -> Settings

481−setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x }

482−

483−-- | A timeout to limit the time (in milliseconds) waiting for

484−-- FIN for HTTP/1.x. 0 means uses immediate close.

485−--

486−-- Since 3.3.5

487−getGracefulCloseTimeout1 :: Settings -> Int

488−getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1

489−

490−-- | A timeout to limit the time (in milliseconds) waiting for

491−-- FIN for HTTP/2. 0 means uses immediate close.

492−-- Default: 2000.

493−--

494−-- Since 3.3.5

495−setGracefulCloseTimeout2 :: Int -> Settings -> Settings

496−setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x }

497−

498−-- | A timeout to limit the time (in milliseconds) waiting for

499−-- FIN for HTTP/2. 0 means uses immediate close.

500−--

501−-- Since 3.3.5

502−getGracefulCloseTimeout2 :: Settings -> Int

503−getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2

504−

505−-- | Getting information of client certificate.

506−--

507−-- Since 3.3.5

508−clientCertificate :: Request -> Maybe CertificateChain

509−clientCertificate = join . Vault.lookup getClientCertificateKey . vault

warp/Network/Wai/Handler/Warp/Buffer.hs+41−71

@@ -1,83 +1,58 @@

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)

1+module Network.Wai.Handler.Warp.Buffer where

2+

3+import Control.Monad (when)

194import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))

20−import Foreign.ForeignPtr

5+import Data.Word (Word8)

6+import Data.IORef (IORef, newIORef, readIORef, writeIORef)

7+import Data.ByteString (ByteString, empty, length)

8+import Data.ByteString.Internal (ByteString(PS), mallocByteString)

9+import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)

10+import Foreign.ForeignPtr (newForeignPtr, newForeignPtr_, withForeignPtr)

2111import 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−----------------------------------------------------------------

12+import Foreign.Ptr (Ptr, castPtr, plusPtr)

4513

4614largeBufferSize :: Int

4715largeBufferSize = 16384

48−

4916minBufferSize :: Int

5017minBufferSize = 2048

5118

19+type BufferPool = IORef ByteString

20+

5221newBufferPool :: IO BufferPool

53−newBufferPool = newIORef BS.empty

22+newBufferPool = newIORef Data.ByteString.empty

5423

55−mallocBS :: Int -> IO ByteString

56−mallocBS size = do

57− ptr <- allocateBuffer size

24+mallocBuffer :: Int -> IO ByteString

25+mallocBuffer size = do

26+ ptr <- mallocBytes size

5827 fptr <- newForeignPtr finalizerFree ptr

28+ return $! PS fptr 0 size

29+{-# INLINE mallocBuffer #-}

30+

31+createBuffer :: Int -> IO ByteString

32+createBuffer size = do

33+ fptr <- mallocByteString size

5934 return $! PS fptr 0 size

60−{-# INLINE mallocBS #-}

35+{-# INLINE createBuffer #-}

6136

6237usefulBuffer :: ByteString -> Bool

63−usefulBuffer buffer = BS.length buffer >= minBufferSize

38+usefulBuffer buffer = Data.ByteString.length buffer >= minBufferSize

6439{-# INLINE usefulBuffer #-}

6540

6641getBuffer :: BufferPool -> IO ByteString

6742getBuffer pool = do

6843 buffer <- readIORef pool

69− if usefulBuffer buffer then return buffer else mallocBS largeBufferSize

44+ if usefulBuffer buffer then return buffer else mallocBuffer largeBufferSize

7045{-# INLINE getBuffer #-}

7146

7247putBuffer :: BufferPool -> ByteString -> IO ()

73−putBuffer pool buffer = writeIORef pool buffer

48+putBuffer pool buffer = when (usefulBuffer buffer) $ writeIORef pool buffer

7449{-# INLINE putBuffer #-}

7550

76−withForeignBuffer :: ByteString -> ((Buffer, BufSize) -> IO Int) -> IO Int

51+withForeignBuffer :: ByteString -> ((Ptr Word8, Int) -> IO Int) -> IO Int

7752withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s, l)

7853{-# INLINE withForeignBuffer #-}

7954

80−withBufferPool :: BufferPool -> ((Buffer, BufSize) -> IO Int) -> IO ByteString

55+withBufferPool :: BufferPool -> ((Ptr Word8, Int) -> IO Int) -> IO ByteString

8156withBufferPool pool f = do

8257 buffer <- getBuffer pool

8358 consumed <- withForeignBuffer buffer f

@@ -85,25 +60,20 @@ withBufferPool pool f = do

8560 return $! unsafeTake consumed buffer

8661{-# INLINE withBufferPool #-}

8762

88−----------------------------------------------------------------

89−--

90−-- Utilities

91−--

63+type Buffer = Ptr Word8

64+type BufSize = Int

9265

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)

66+-- FIXME come up with good values here

67+bufferSize :: BufSize

68+bufferSize = 4096

9769

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 #-}

70+allocateBuffer :: Int -> IO Buffer

71+allocateBuffer = mallocBytes

72+

73+freeBuffer :: Buffer -> IO ()

74+freeBuffer = free

10575

106−bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO ()

107−bufferIO ptr siz io = do

76+toBlazeBuffer :: Buffer -> BufSize -> IO B.Buffer

77+toBlazeBuffer ptr size = do

10878 fptr <- newForeignPtr_ ptr

109− io $ PS fptr 0 siz

79+ return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)

warp/Network/Wai/Handler/Warp/Conduit.hs+16−2

@@ -3,10 +3,16 @@

33module Network.Wai.Handler.Warp.Conduit where

44

55import Control.Exception

6+import Control.Monad (when, unless)

7+import Data.ByteString (ByteString)

8+import Data.ByteString.Lazy.Char8 (pack)

69import qualified Data.ByteString as S

10+import qualified Data.ByteString.Lazy as L

711import qualified Data.IORef as I

8−

9−import Network.Wai.Handler.Warp.Imports

12+#if __GLASGOW_HASKELL__ < 709

13+import Data.Word (Word)

14+#endif

15+import Data.Word (Word8)

1016import Network.Wai.Handler.Warp.Types

1117

1218----------------------------------------------------------------

@@ -60,6 +66,11 @@ readISource (ISource src ref) = do

6066 assert (count' == 0) $ I.writeIORef ref count'

6167 return x

6268

69+-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not

70+-- perform any more isolation.

71+isourceDone :: ISource -> Source

72+isourceDone (ISource src _) = src

73+

6374----------------------------------------------------------------

6475

6576data CSource = CSource !Source !(I.IORef ChunkState)

@@ -70,6 +81,9 @@ data ChunkState = NeedLen

7081 | DoneChunking

7182 deriving Show

7283

84+bsCRLF :: L.ByteString

85+bsCRLF = pack "\r\n"

86+

7387mkCSource :: Source -> IO CSource

7488mkCSource src = do

7589 ref <- I.newIORef NeedLen

warp/Network/Wai/Handler/Warp/Counter.hs+4−3

@@ -8,10 +8,11 @@ module Network.Wai.Handler.Warp.Counter (

88 , decrease

99 ) where

1010

11+#if __GLASGOW_HASKELL__ < 709

12+import Control.Applicative ((<$>))

13+#endif

1114import Control.Concurrent.STM

12−

13−import Network.Wai.Handler.Warp.Imports

14−

15+import Control.Monad (unless)

1516

1617newtype Counter = Counter (TVar Int)

1718

warp/Network/Wai/Handler/Warp/Date.hs+28−17

@@ -2,40 +2,51 @@

22

33module Network.Wai.Handler.Warp.Date (

44 withDateCache

5+ , getDate

6+ , DateCache

57 , GMTDate

68 ) where

79

10+#if __GLASGOW_HASKELL__ < 709

11+import Control.Applicative

12+#endif

813import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

9−import Data.ByteString

10−import Network.HTTP.Date

14+import Data.ByteString.Char8

1115

1216#if WINDOWS

13−import Data.Time (UTCTime, getCurrentTime)

14−import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)

15−import Foreign.C.Types (CTime(..))

17+import Data.Time (formatTime, getCurrentTime)

18+# if MIN_VERSION_time(1,5,0)

19+import Data.Time (defaultTimeLocale)

20+# else

21+import System.Locale (defaultTimeLocale)

22+# endif

1623#else

24+import Network.HTTP.Date

1725import System.Posix (epochTime)

1826#endif

1927

2028-- | The type of the Date header value.

2129type GMTDate = ByteString

2230

31+-- | The type of the cache of the Date header value.

32+type DateCache = IO GMTDate

33+

2334-- | Creating 'DateCache' and executing the action.

24−withDateCache :: (IO GMTDate -> IO a) -> IO a

35+withDateCache :: (DateCache -> IO a) -> IO a

2536withDateCache action = initialize >>= action

2637

27−initialize :: IO (IO GMTDate)

28−initialize = mkAutoUpdate defaultUpdateSettings {

29− updateAction = formatHTTPDate <$> getCurrentHTTPDate

30− }

38+initialize :: IO DateCache

39+initialize = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentGMTDate }

3140

32−#ifdef WINDOWS

33−uToH :: UTCTime -> HTTPDate

34−uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds

41+-- | Getting 'GMTDate' based on 'DateCache'.

42+getDate :: DateCache -> IO GMTDate

43+getDate = id

3544

36−getCurrentHTTPDate :: IO HTTPDate

37−getCurrentHTTPDate = uToH <$> getCurrentTime

45+getCurrentGMTDate :: IO GMTDate

46+#ifdef WINDOWS

47+getCurrentGMTDate = formatDate <$> getCurrentTime

48+ where

49+ formatDate = pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"

3850#else

39−getCurrentHTTPDate :: IO HTTPDate

40−getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime

51+getCurrentGMTDate = formatHTTPDate . epochTimeToHTTPDate <$> epochTime

4152#endif

warp/Network/Wai/Handler/Warp/FdCache.hs+90−78

@@ -2,46 +2,36 @@

22

33-- | File descriptor cache to avoid locks in kernel.

44

5+#ifndef SENDFILEFD

56module Network.Wai.Handler.Warp.FdCache (

67 withFdCache

7− , Fd

8+ , MutableFdCache

89 , Refresh

9−#ifndef WINDOWS

10− , openFile

11− , closeFile

12− , setFileCloseOnExec

13−#endif

1410 ) where

1511

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.

2812type Refresh = IO ()

13+data MutableFdCache = MutableFdCache

2914

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

15+withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a

16+withFdCache _ f = f Nothing

4017#else

41−withFdCache 0 action = action getFdNothing

42−withFdCache duration action = bracket (initialize duration)

43− terminate

44− (action . getFd)

18+module Network.Wai.Handler.Warp.FdCache (

19+ withFdCache

20+ , getFd

21+ , MutableFdCache

22+ , Refresh

23+ ) where

24+

25+#if __GLASGOW_HASKELL__ < 709

26+import Control.Applicative ((<$>), (<*>))

27+#endif

28+import Control.Exception (bracket)

29+import Data.Hashable (hash)

30+import Network.Wai.Handler.Warp.IORef

31+import Network.Wai.Handler.Warp.MultiMap

32+import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)

33+import System.Posix.Types (Fd)

34+import Control.Reaper

4535

4636----------------------------------------------------------------

4737

@@ -49,6 +39,9 @@ data Status = Active | Inactive

4939

5040newtype MutableStatus = MutableStatus (IORef Status)

5141

42+-- | An action to activate a Fd cache entry.

43+type Refresh = IO ()

44+

5245status :: MutableStatus -> IO Status

5346status (MutableStatus ref) = readIORef ref

5447

@@ -63,80 +56,99 @@ inactive (MutableStatus ref) = writeIORef ref Inactive

6356

6457----------------------------------------------------------------

6558

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

59+data FdEntry = FdEntry !FilePath !Fd !MutableStatus

7660

7761newFdEntry :: FilePath -> IO FdEntry

78−newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus

79−

80−setFileCloseOnExec :: Fd -> IO ()

81−setFileCloseOnExec fd = setFdOption fd CloseOnExec True

62+newFdEntry path = FdEntry path

63+ <$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}

64+ <*> newActiveStatus

8265

8366----------------------------------------------------------------

8467

85−type FdCache = MultiMap FdEntry

68+type Hash = Int

69+type FdCache = MMap Hash FdEntry

8670

8771-- | Mutable Fd cacher.

88−newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))

72+type MutableFdCache = Reaper FdCache (Hash, FdEntry)

8973

9074fdCache :: MutableFdCache -> IO FdCache

91−fdCache (MutableFdCache reaper) = reaperRead reaper

75+fdCache mfc = reaperRead mfc

9276

93−look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)

94−look mfc path = MM.lookup path <$> fdCache mfc

77+look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)

78+look mfc path key = searchWith key check <$> fdCache mfc

79+ where

80+ check (One ent@(FdEntry path' _ _))

81+ | path == path' = Just ent

82+ | otherwise = Nothing

83+ check (Tom ent@(FdEntry path' _ _) vs)

84+ | path == path' = Just ent

85+ | otherwise = check vs

86+

87+----------------------------------------------------------------

88+

89+-- | Creating 'MutableFdCache' and executing the action in the second

90+-- argument. The first argument is a cache duration in second.

91+withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a

92+withFdCache duration action = bracket (initialize duration)

93+ terminate

94+ action

9595

9696----------------------------------------------------------------

9797

9898-- 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− }

99+initialize :: Int -> IO (Maybe MutableFdCache)

100+initialize 0 = return Nothing

101+initialize duration = Just <$> mkReaper defaultReaperSettings

102+ { reaperAction = clean

103+ , reaperDelay = duration

104+ , reaperCons = uncurry insert

105+ , reaperNull = isEmpty

106+ , reaperEmpty = empty

107+ }

109108

110109clean :: FdCache -> IO (FdCache -> FdCache)

111110clean old = do

112111 new <- pruneWith old prune

113112 return $ merge new

113+

114+prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]

115+prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'

116+ where

117+ prune' Active = inactive mst >> return [(k,v)]

118+ prune' Inactive = closeFd fd >> return []

119+prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'

114120 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

121+ prune' Active = do

122+ inactive mst

123+ zs <- prune k vs

124+ case zs of

125+ [] -> return [(k,One ent)]

126+ [(_,zvs)] -> return [(k,Tom ent zvs)]

127+ _ -> error "prune"

128+ prune' Inactive = closeFd fd >> prune k vs

119129

120130----------------------------------------------------------------

121131

122−terminate :: MutableFdCache -> IO ()

123−terminate (MutableFdCache reaper) = do

124− !t <- reaperStop reaper

125− mapM_ (closeIt . snd) $ toList t

132+terminate :: Maybe MutableFdCache -> IO ()

133+terminate Nothing = return ()

134+terminate (Just mfc) = do

135+ !t <- reaperStop mfc

136+ mapM_ closeIt $ toList t

126137 where

127− closeIt (FdEntry fd _) = closeFd fd

138+ closeIt (_, FdEntry _ fd _) = closeFd fd

128139

129140----------------------------------------------------------------

130141

131142-- | 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

143+getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)

144+getFd mfc path = look mfc path key >>= getFd'

134145 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

146+ key = hash path

147+ getFd' Nothing = do

148+ ent@(FdEntry _ fd mst) <- newFdEntry path

149+ reaperAdd mfc (key, ent)

150+ return (fd, refresh mst)

151+ getFd' (Just (FdEntry _ fd mst)) = do

140152 refresh mst

141− return (Just fd, refresh mst)

153+ return (fd, refresh mst)

142154#endif

warp/Network/Wai/Handler/Warp/File.hsdeleted−152

@@ -1,152 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE BangPatterns #-}

4−

5−module Network.Wai.Handler.Warp.File (

6− RspFileInfo(..)

7− , conditionalRequest

8− , addContentHeadersForFilePart

9− , H.parseByteRanges

10− ) where

11−

12−import Data.Array ((!))

13−import qualified Data.ByteString.Char8 as C8 (pack)

14−import Network.HTTP.Date

15−import qualified Network.HTTP.Types as H

16−import qualified Network.HTTP.Types.Header as H

17−import Network.Wai

18−

19−import qualified Network.Wai.Handler.Warp.FileInfoCache as I

20−import Network.Wai.Handler.Warp.Header

21−import Network.Wai.Handler.Warp.Imports

22−import Network.Wai.Handler.Warp.PackInt

23−

24−

25−-- $setup

26−-- >>> import Test.QuickCheck

27−

28−----------------------------------------------------------------

29−

30−data RspFileInfo = WithoutBody H.Status

31− | WithBody H.Status H.ResponseHeaders Integer Integer

32− deriving (Eq,Show)

33−

34−----------------------------------------------------------------

35−

36−conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders

38− -> IndexedHeader -- ^ Response

39− -> IndexedHeader -- ^ Request

40− -> RspFileInfo

41−conditionalRequest finfo hs0 rspidx reqidx = case condition of

42− nobody@(WithoutBody _) -> nobody

43− WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size

44− !hasLM = isJust $ rspidx ! fromEnum ResLastModified

45− !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1

46− in WithBody s hs off len

47− where

48− !mtime = I.fileInfoTime finfo

49− !size = I.fileInfoSize finfo

50− !date = I.fileInfoDate finfo

51− !mcondition = ifmodified reqidx size mtime

52− <|> ifunmodified reqidx size mtime

53− <|> ifrange reqidx size mtime

54− !condition = fromMaybe (unconditional reqidx size) mcondition

55−

56−----------------------------------------------------------------

57−

58−ifModifiedSince :: IndexedHeader -> Maybe HTTPDate

59−ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate

60−

61−ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate

62−ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate

63−

64−ifRange :: IndexedHeader -> Maybe HTTPDate

65−ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate

66−

67−----------------------------------------------------------------

68−

69−ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo

70−ifmodified reqidx size mtime = do

71− date <- ifModifiedSince reqidx

72− return $ if date /= mtime

73− then unconditional reqidx size

74− else WithoutBody H.notModified304

75−

76−ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo

77−ifunmodified reqidx size mtime = do

78− date <- ifUnmodifiedSince reqidx

79− return $ if date == mtime

80− then unconditional reqidx size

81− else WithoutBody H.preconditionFailed412

82−

83−ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo

84−ifrange reqidx size mtime = do

85− date <- ifRange reqidx

86− rng <- reqidx ! fromEnum ReqRange

87− return $ if date == mtime

88− then parseRange rng size

89− else WithBody H.ok200 [] 0 size

90−

91−unconditional :: IndexedHeader -> Integer -> RspFileInfo

92−unconditional reqidx size = case reqidx ! fromEnum ReqRange of

93− Nothing -> WithBody H.ok200 [] 0 size

94− Just rng -> parseRange rng size

95−

96−----------------------------------------------------------------

97−

98−parseRange :: ByteString -> Integer -> RspFileInfo

99−parseRange rng size = case H.parseByteRanges rng of

100− Nothing -> WithoutBody H.requestedRangeNotSatisfiable416

101− Just [] -> WithoutBody H.requestedRangeNotSatisfiable416

102− Just (r:_) -> let (!beg, !end) = checkRange r size

103− !len = end - beg + 1

104− s = if beg == 0 && end == size - 1 then

105− H.ok200

106− else

107− H.partialContent206

108− in WithBody s [] beg len

109−

110−checkRange :: H.ByteRange -> Integer -> (Integer, Integer)

111−checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)

112−checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)

113−checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)

114−

115−----------------------------------------------------------------

116−

117−-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'

118−-- for the range specified.

119−contentRangeHeader :: Integer -> Integer -> Integer -> H.Header

120−contentRangeHeader beg end total = (H.hContentRange, range)

121− where

122− range = C8.pack

123− -- building with ShowS

124− $ 'b' : 'y': 't' : 'e' : 's' : ' '

125− : (if beg > end then ('*':) else

126− showInt beg

127− . ('-' :)

128− . showInt end)

129− ( '/'

130− : showInt total "")

131−

132−addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders

133−addContentHeaders hs off len size

134− | len == size = hs'

135− | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size

136− in ctrng:hs'

137− where

138− !lengthBS = packIntegral len

139− !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges,"bytes") : hs

140−

141−-- |

142−--

143−-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)

144−-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]

145−-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)

146−-- [("Content-Length","16"),("Accept-Ranges","bytes")]

147−addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders

148−addContentHeadersForFilePart hs part = addContentHeaders hs off len size

149− where

150− off = filePartOffset part

151− len = filePartByteCount part

152− size = filePartFileSize part

warp/Network/Wai/Handler/Warp/FileInfoCache.hsdeleted−108

@@ -1,108 +0,0 @@

1−{-# LANGUAGE RecordWildCards, CPP #-}

2−

3−module Network.Wai.Handler.Warp.FileInfoCache (

4− FileInfo(..)

5− , withFileInfoCache

6− , getInfo -- test purpose only

7− ) where

8−

9−import Control.Exception as E

10−import Control.Reaper

11−import Network.HTTP.Date

12−import System.PosixCompat.Files

13−

14−import Network.Wai.Handler.Warp.HashMap (HashMap)

15−import qualified Network.Wai.Handler.Warp.HashMap as M

16−import Network.Wai.Handler.Warp.Imports

17−

18−----------------------------------------------------------------

19−

20−-- | File information.

21−data FileInfo = FileInfo {

22− fileInfoName :: !FilePath

23− , fileInfoSize :: !Integer

24− , fileInfoTime :: HTTPDate -- ^ Modification time

25− , fileInfoDate :: ByteString -- ^ Modification time in the GMT format

26− } deriving (Eq, Show)

27−

28−data Entry = Negative | Positive FileInfo

29−type Cache = HashMap Entry

30−type FileInfoCache = Reaper Cache (FilePath,Entry)

31−

32−----------------------------------------------------------------

33−

34−-- | Getting the file information corresponding to the file.

35−getInfo :: FilePath -> IO FileInfo

36−getInfo path = do

37− fs <- getFileStatus path -- file access

38− let regular = not (isDirectory fs)

39− readable = fileMode fs `intersectFileModes` ownerReadMode /= 0

40− if regular && readable then do

41− let time = epochTimeToHTTPDate $ modificationTime fs

42− date = formatHTTPDate time

43− size = fromIntegral $ fileSize fs

44− info = FileInfo {

45− fileInfoName = path

46− , fileInfoSize = size

47− , fileInfoTime = time

48− , fileInfoDate = date

49− }

50− return info

51− else

52− throwIO (userError "FileInfoCache:getInfo")

53−

54−getInfoNaive :: FilePath -> IO FileInfo

55−getInfoNaive = getInfo

56−

57−----------------------------------------------------------------

58−

59−getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo

60−getAndRegisterInfo reaper@Reaper{..} path = do

61− cache <- reaperRead

62− case M.lookup path cache of

63− Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

64− Just (Positive x) -> return x

65− Nothing -> positive reaper path

66− `E.onException` negative reaper path

67−

68−positive :: FileInfoCache -> FilePath -> IO FileInfo

69−positive Reaper{..} path = do

70− info <- getInfo path

71− reaperAdd (path, Positive info)

72− return info

73−

74−negative :: FileInfoCache -> FilePath -> IO FileInfo

75−negative Reaper{..} path = do

76− reaperAdd (path, Negative)

77− throwIO (userError "FileInfoCache:negative")

78−

79−----------------------------------------------------------------

80−

81−-- | Creating a file information cache

82−-- and executing the action in the second argument.

83−-- The first argument is a cache duration in second.

84−withFileInfoCache :: Int

85− -> ((FilePath -> IO FileInfo) -> IO a)

86− -> IO a

87−withFileInfoCache 0 action = action getInfoNaive

88−withFileInfoCache duration action =

89− E.bracket (initialize duration)

90− terminate

91− (action . getAndRegisterInfo)

92−

93−initialize :: Int -> IO FileInfoCache

94−initialize duration = mkReaper settings

95− where

96− settings = defaultReaperSettings {

97− reaperAction = override

98− , reaperDelay = duration

99− , reaperCons = \(path,v) -> M.insert path v

100− , reaperNull = M.isEmpty

101− , reaperEmpty = M.empty

102− }

103−

104−override :: Cache -> IO (Cache -> Cache)

105−override _ = return $ const M.empty

106−

107−terminate :: FileInfoCache -> IO ()

108−terminate x = void $ reaperStop x

warp/Network/Wai/Handler/Warp/HTTP2.hsdeleted−85

@@ -1,85 +0,0 @@

1−{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE PatternGuards #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−

7−module Network.Wai.Handler.Warp.HTTP2 (http2) where

8−

9−import qualified Data.IORef as I

10−import qualified Control.Exception as E

11−import qualified Network.HTTP2.Server as H2

12−import Network.Socket (SockAddr)

13−import Network.Wai

14−import Network.Wai.Internal (ResponseReceived(..))

15−import qualified System.TimeManager as T

16−

17−import Network.Wai.Handler.Warp.HTTP2.File

18−import Network.Wai.Handler.Warp.HTTP2.PushPromise

19−import Network.Wai.Handler.Warp.HTTP2.Request

20−import Network.Wai.Handler.Warp.HTTP2.Response

21−import Network.Wai.Handler.Warp.Imports

22−import qualified Network.Wai.Handler.Warp.Settings as S

23−import Network.Wai.Handler.Warp.Types

24−

25−----------------------------------------------------------------

26−

27−http2 :: Connection -> Transport -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> (ByteString -> IO ()) -> Application -> IO ()

28−http2 conn transport ii addr settings readN send app =

29− H2.run conf http2server

30− where

31− conf = H2.Config {

32− confWriteBuffer = connWriteBuffer conn

33− , confBufferSize = connBufferSize conn

34− , confSendAll = send

35− , confReadN = readN

36− , confPositionReadMaker = pReadMaker ii

37− }

38−

39− http2server h2req aux response = do

40− req <- toWAIRequest h2req aux

41− ref <- I.newIORef Nothing

42− eResponseReceived <- E.try $ app req $ \rsp -> do

43− h2rsp <- fromResponse settings ii req rsp

44− pps <- fromPushPromises ii req

45− I.writeIORef ref $ Just (h2rsp, pps)

46− _ <- response h2rsp pps

47− return ResponseReceived

48− case eResponseReceived of

49− Right ResponseReceived -> do

50− Just (h2rsp, pps) <- I.readIORef ref

51− logResponse h2rsp req

52− mapM_ (logPushPromise req) pps

53− Left e@(E.SomeException _)

54− -- killed by the local worker manager

55− | Just E.ThreadKilled <- E.fromException e -> return ()

56− -- killed by the local timeout manager

57− | Just T.TimeoutThread <- E.fromException e -> return ()

58− | otherwise -> do

59− S.settingsOnException settings (Just req) e

60− let ersp = S.settingsOnExceptionResponse settings e

61− h2rsp' <- fromResponse settings ii req ersp

62− _ <- response h2rsp' []

63− logResponse h2rsp' req

64− return ()

65−

66− toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport

67− where

68− !hdr = H2.requestHeaders h2req

69− !bdy = H2.getRequestBodyChunk h2req

70− !bdylen = H2.requestBodySize h2req

71− !th = H2.auxTimeHandle aux

72−

73− logResponse h2rsp req = logger req st msiz

74− where

75− !logger = S.settingsLogger settings

76− !st = H2.responseStatus h2rsp

77− !msiz = fromIntegral <$> H2.responseBodySize h2rsp

78−

79− logPushPromise req pp = logger req path siz

80− where

81− !logger = S.settingsServerPushLogger settings

82− !path = H2.promiseRequestPath pp

83− !siz = case H2.responseBodySize $ H2.promiseResponse pp of

84− Nothing -> 0

85− Just s -> fromIntegral s

warp/Network/Wai/Handler/Warp/HTTP2/File.hsdeleted−30

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

1−{-# LANGUAGE CPP #-}

2−

3−module Network.Wai.Handler.Warp.HTTP2.File where

4−

5−import Network.HTTP2.Server

6−

7−import Network.Wai.Handler.Warp.Types

8−

9−#ifdef WINDOWS

10−pReadMaker :: InternalInfo -> PositionReadMaker

11−pReadMaker _ = defaultPositionReadMaker

12−#else

13−import Network.Wai.Handler.Warp.FdCache

14−import Network.Wai.Handler.Warp.SendFile (positionRead)

15−

16−pReadMaker :: InternalInfo -> PositionReadMaker

17−pReadMaker ii path = do

18− (mfd, refresh) <- getFd ii path

19− case mfd of

20− Just fd -> return (pread fd, Refresher refresh)

21− Nothing -> do

22− fd <- openFile path

23− return (pread fd, Closer $ closeFile fd)

24− where

25− pread :: Fd -> PositionRead

26− pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'

27− where

28− bytes' = fromIntegral bytes

29− off' = fromIntegral off

30−#endif

warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hsdeleted−36

@@ -1,36 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Network.Wai.Handler.Warp.HTTP2.PushPromise where

6−

7−import qualified Control.Exception as E

8−import qualified Network.HTTP.Types as H

9−import qualified Network.HTTP2.Server as H2

10−

11−import Network.Wai

12−import Network.Wai.Handler.Warp.FileInfoCache

13−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

14−import Network.Wai.Handler.Warp.HTTP2.Types

15−import Network.Wai.Handler.Warp.Imports

16−import Network.Wai.Handler.Warp.Types

17−

18−fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]

19−fromPushPromises ii req = do

20− mh2data <- getHTTP2Data req

21− let pp = case mh2data of

22− Nothing -> []

23− Just h2data -> http2dataPushPromise h2data

24− catMaybes <$> mapM (fromPushPromise ii) pp

25−

26−fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)

27−fromPushPromise ii (PushPromise path file rsphdr w) = do

28− efinfo <- E.try $ getFileInfo ii file

29− case efinfo of

30− Left (_ex :: E.IOException) -> return Nothing

31− Right finfo -> do

32− let !siz = fromIntegral $ fileInfoSize finfo

33− !fileSpec = H2.FileSpec file 0 siz

34− !rsp = H2.responseFile H.ok200 rsphdr fileSpec

35− !pp = H2.pushPromise path rsp w

36− return $ Just pp

warp/Network/Wai/Handler/Warp/HTTP2/Request.hsdeleted−126

@@ -1,126 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3−module Network.Wai.Handler.Warp.HTTP2.Request (

4− toRequest

5− , getHTTP2Data

6− , setHTTP2Data

7− , modifyHTTP2Data

8− ) where

9−

10−import Control.Arrow (first)

11−import qualified Data.ByteString.Char8 as C8

12−import Data.IORef

13−import qualified Data.Vault.Lazy as Vault

14−import Network.HPACK

15−import Network.HPACK.Token

16−import qualified Network.HTTP.Types as H

17−import Network.Socket (SockAddr)

18−import Network.Wai

19−import Network.Wai.Internal (Request(..))

20−import System.IO.Unsafe (unsafePerformIO)

21−import qualified System.TimeManager as T

22−

23−import Network.Wai.Handler.Warp.HTTP2.Types

24−import Network.Wai.Handler.Warp.Imports

25−import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey, getClientCertificateKey)

26−import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

27−import Network.Wai.Handler.Warp.Types

28−

29−type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request

30−

31−----------------------------------------------------------------

32−

33−toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq

34−toRequest ii settings addr ht bodylen body th transport = do

35− ref <- newIORef Nothing

36− toRequest' ii settings addr ref ht bodylen body th transport

37−

38−toRequest' :: InternalInfo -> S.Settings -> SockAddr

39− -> IORef (Maybe HTTP2Data)

40− -> ToReq

41−toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req

42− where

43− !req = Request {

44− requestMethod = colonMethod

45− , httpVersion = H.http20

46− , rawPathInfo = rawPath

47− , pathInfo = H.decodePathSegments path

48− , rawQueryString = query

49− , queryString = H.parseQuery query

50− , requestHeaders = headers

51− , isSecure = isTransportSecure transport

52− , remoteHost = addr

53− , requestBody = body

54− , vault = vaultValue

55− , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen

56− , requestHeaderHost = mHost <|> mAuth

57− , requestHeaderRange = mRange

58− , requestHeaderReferer = mReferer

59− , requestHeaderUserAgent = mUserAgent

60− }

61− headers = map (first tokenKey) ths

62− where

63− ths = case mHost of

64− Just _ -> reqths

65− Nothing -> case mAuth of

66− Just auth -> (tokenHost, auth) : reqths

67− _ -> reqths

68− !mPath = getHeaderValue tokenPath reqvt -- SHOULD

69− !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST

70− !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD

71− !mHost = getHeaderValue tokenHost reqvt

72− !mRange = getHeaderValue tokenRange reqvt

73− !mReferer = getHeaderValue tokenReferer reqvt

74− !mUserAgent = getHeaderValue tokenUserAgent reqvt

75− -- CONNECT request will have ":path" omitted, use ":authority" as unparsed

76− -- path instead so that it will have consistent behavior compare to HTTP 1.0

77− (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)

78− !path = H.extractPath unparsedPath

79− !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

80− -- fixme: pauseTimeout. th is not available here.

81− !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)

82− $ Vault.insert getHTTP2DataKey (readIORef ref)

83− $ Vault.insert setHTTP2DataKey (writeIORef ref)

84− $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)

85− $ Vault.insert pauseTimeoutKey (T.pause th)

86− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

87− Vault.empty

88−

89−getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))

90−getHTTP2DataKey = unsafePerformIO Vault.newKey

91−{-# NOINLINE getHTTP2DataKey #-}

92−

93−-- | Getting 'HTTP2Data' through vault of the request.

94−-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.

95−--

96−-- Since: 3.2.7

97−getHTTP2Data :: Request -> IO (Maybe HTTP2Data)

98−getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of

99− Nothing -> return Nothing

100− Just getter -> getter

101−

102−setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())

103−setHTTP2DataKey = unsafePerformIO Vault.newKey

104−{-# NOINLINE setHTTP2DataKey #-}

105−

106−-- | Setting 'HTTP2Data' through vault of the request.

107−-- 'Application' or 'Middleware' should use this.

108−--

109−-- Since: 3.2.7

110−setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()

111−setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of

112− Nothing -> return ()

113− Just setter -> setter mh2d

114−

115−modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())

116−modifyHTTP2DataKey = unsafePerformIO Vault.newKey

117−{-# NOINLINE modifyHTTP2DataKey #-}

118−

119−-- | Modifying 'HTTP2Data' through vault of the request.

120−-- 'Application' or 'Middleware' should use this.

121−--

122−-- Since: 3.2.8

123−modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()

124−modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of

125− Nothing -> return ()

126− Just modify -> modify func

warp/Network/Wai/Handler/Warp/HTTP2/Response.hsdeleted−127

@@ -1,127 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE BangPatterns #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−

6−module Network.Wai.Handler.Warp.HTTP2.Response (

7− fromResponse

8− ) where

9−

10−import qualified Control.Exception as E

11−import qualified Data.ByteString.Builder as BB

12−import qualified Network.HTTP.Types as H

13−import qualified Network.HTTP2.Server as H2

14−import Network.Wai hiding (responseFile, responseBuilder, responseStream)

15−import Network.Wai.Internal (Response(..))

16−

17−import Network.Wai.Handler.Warp.File

18−import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)

19−import Network.Wai.Handler.Warp.HTTP2.Types

20−import Network.Wai.Handler.Warp.Header

21−import qualified Network.Wai.Handler.Warp.Response as R

22−import qualified Network.Wai.Handler.Warp.Settings as S

23−import Network.Wai.Handler.Warp.Types

24−

25−----------------------------------------------------------------

26−

27−fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response

28−fromResponse settings ii req rsp = do

29− date <- getDate ii

30− h2rsp <- case rsp of

31− ResponseFile st rsphdr path mpart -> do

32− let rsphdr' = add date svr rsphdr

33− responseFile st rsphdr' isHead path mpart ii reqhdr

34− ResponseBuilder st rsphdr builder -> do

35− let rsphdr' = add date svr rsphdr

36− return $ responseBuilder st rsphdr' isHead builder

37− ResponseStream st rsphdr strmbdy -> do

38− let rsphdr' = add date svr rsphdr

39− return $ responseStream st rsphdr' isHead strmbdy

40− _ -> error "ResponseRaw is not supported in HTTP/2"

41− mh2data <- getHTTP2Data req

42− case mh2data of

43− Nothing -> return h2rsp

44− Just h2data -> do

45− let !trailers = http2dataTrailers h2data

46− return $ H2.setResponseTrailersMaker h2rsp trailers

47− where

48− !isHead = requestMethod req == H.methodHead

49− !reqhdr = requestHeaders req

50− !svr = S.settingsServerName settings

51− add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr

52− -- fixme: not adding svr if already exists

53−

54−----------------------------------------------------------------

55−

56−responseFile :: H.Status -> H.ResponseHeaders -> Bool

57− -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders

58− -> IO H2.Response

59−responseFile st rsphdr _ _ _ _ _

60− | noBody st = return $ responseNoBody st rsphdr

61−

62−responseFile st rsphdr isHead path (Just fp) _ _ =

63− return $ responseFile2XX st rsphdr isHead fileSpec

64− where

65− !off' = fromIntegral $ filePartOffset fp

66− !bytes' = fromIntegral $ filePartByteCount fp

67− !fileSpec = H2.FileSpec path off' bytes'

68−

69−responseFile _ rsphdr isHead path Nothing ii reqhdr = do

70− efinfo <- E.try $ getFileInfo ii path

71− case efinfo of

72− Left (_ex :: E.IOException) -> return $ response404 rsphdr

73− Right finfo -> do

74− let reqidx = indexRequestHeader reqhdr

75− rspidx = indexResponseHeader rsphdr

76− case conditionalRequest finfo rsphdr rspidx reqidx of

77− WithoutBody s -> return $ responseNoBody s rsphdr

78− WithBody s rsphdr' off bytes -> do

79− let !off' = fromIntegral off

80− !bytes' = fromIntegral bytes

81− !fileSpec = H2.FileSpec path off' bytes'

82− return $ responseFile2XX s rsphdr' isHead fileSpec

83−

84−----------------------------------------------------------------

85−

86−responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response

87−responseFile2XX st rsphdr isHead fileSpec

88− | isHead = responseNoBody st rsphdr

89− | otherwise = H2.responseFile st rsphdr fileSpec

90−

91−----------------------------------------------------------------

92−

93−responseBuilder :: H.Status -> H.ResponseHeaders -> Bool

94− -> BB.Builder

95− -> H2.Response

96−responseBuilder st rsphdr isHead builder

97− | noBody st = responseNoBody st rsphdr

98− | isHead = responseNoBody st rsphdr

99− | otherwise = H2.responseBuilder st rsphdr builder

100−

101−----------------------------------------------------------------

102−

103−responseStream :: H.Status -> H.ResponseHeaders -> Bool

104− -> StreamingBody

105− -> H2.Response

106−responseStream st rsphdr isHead strmbdy

107− | noBody st = responseNoBody st rsphdr

108− | isHead = responseNoBody st rsphdr

109− | otherwise = H2.responseStreaming st rsphdr strmbdy

110−

111−----------------------------------------------------------------

112−

113−responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response

114−responseNoBody st rsphdr = H2.responseNoBody st rsphdr

115−

116−----------------------------------------------------------------

117−

118−response404 :: H.ResponseHeaders -> H2.Response

119−response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body

120− where

121− !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr

122− !body = BB.byteString "File not found"

123−

124−----------------------------------------------------------------

125−

126−noBody :: H.Status -> Bool

127−noBody = not . R.hasBody

warp/Network/Wai/Handler/Warp/HTTP2/Types.hsdeleted−81

@@ -1,81 +0,0 @@

1−{-# LANGUAGE NamedFieldPuns #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

4−

5−module Network.Wai.Handler.Warp.HTTP2.Types where

6−

7−import qualified Data.ByteString as BS

8−import qualified Network.HTTP.Types as H

9−import Network.HTTP2

10−import qualified Network.HTTP2.Server as H2

11−

12−import Network.Wai.Handler.Warp.Imports

13−import Network.Wai.Handler.Warp.Types

14−

15−----------------------------------------------------------------

16−

17−isHTTP2 :: Transport -> Bool

18−isHTTP2 TCP = False

19−isHTTP2 tls = useHTTP2

20− where

21− useHTTP2 = case tlsNegotiatedProtocol tls of

22− Nothing -> False

23− Just proto -> "h2" `BS.isPrefixOf` proto

24−

25−----------------------------------------------------------------

26−

27−-- | HTTP/2 specific data.

28−--

29−-- Since: 3.2.7

30−data HTTP2Data = HTTP2Data {

31− -- | Accessor for 'PushPromise' in 'HTTP2Data'.

32− --

33− -- Since: 3.2.7

34− http2dataPushPromise :: [PushPromise]

35− -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.

36− --

37− -- Since: 3.2.8 but the type changed in 3.3.0

38− , http2dataTrailers :: H2.TrailersMaker

39− }

40−

41−-- | Default HTTP/2 specific data.

42−--

43−-- Since: 3.2.7

44−defaultHTTP2Data :: HTTP2Data

45−defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker

46−

47−-- | HTTP/2 push promise or sever push.

48−-- This allows files only for backward-compatibility

49−-- while the HTTP/2 library supports other types.

50−--

51−-- Since: 3.2.7

52−data PushPromise = PushPromise {

53− -- | Accessor for a URL path in 'PushPromise'.

54− -- E.g. \"\/style\/default.css\".

55− --

56− -- Since: 3.2.7

57− promisedPath :: ByteString

58− -- | Accessor for 'FilePath' in 'PushPromise'.

59− -- E.g. \"FILE_PATH/default.css\".

60− --

61− -- Since: 3.2.7

62− , promisedFile :: FilePath

63− -- | Accessor for 'H.ResponseHeaders' in 'PushPromise'

64− -- \"content-type\" must be specified.

65− -- Default value: [].

66− --

67− --

68− -- Since: 3.2.7

69− , promisedResponseHeaders :: H.ResponseHeaders

70− -- | Accessor for 'Weight' in 'PushPromise'.

71− -- Default value: 16.

72− --

73− -- Since: 3.2.7

74− , promisedWeight :: Weight

75− } deriving (Eq,Ord,Show)

76−

77−-- | Default push promise.

78−--

79−-- Since: 3.2.7

80−defaultPushPromise :: PushPromise

81−defaultPushPromise = PushPromise "" "" [] 16

warp/Network/Wai/Handler/Warp/HashMap.hsdeleted−42

@@ -1,42 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3−module Network.Wai.Handler.Warp.HashMap where

4−

5−import Data.Hashable (hash)

6−import Data.IntMap.Strict (IntMap)

7−import qualified Data.IntMap.Strict as I

8−import Data.Map.Strict (Map)

9−import qualified Data.Map.Strict as M

10−import Prelude hiding (lookup)

11−

12−----------------------------------------------------------------

13−

14−-- | 'HashMap' is used for cache of file information.

15−-- Hash values of file pathes are used as outer keys.

16−-- Because negative entries are also contained,

17−-- a bad guy can intentionally cause the hash collison.

18−-- So, 'Map' is used internally to prevent

19−-- the hash collision attack.

20−newtype HashMap v = HashMap (IntMap (Map FilePath v))

21−

22−----------------------------------------------------------------

23−

24−empty :: HashMap v

25−empty = HashMap I.empty

26−

27−isEmpty :: HashMap v -> Bool

28−isEmpty (HashMap hm) = I.null hm

29−

30−----------------------------------------------------------------

31−

32−insert :: FilePath -> v -> HashMap v -> HashMap v

33−insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm

34− where

35− !h = hash path

36− !m = M.singleton path v

37− f = M.union -- fimxe

38−

39−lookup :: FilePath -> HashMap v -> Maybe v

40−lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path

41− where

42− !h = hash path

warp/Network/Wai/Handler/Warp/Header.hs+26−48

@@ -4,10 +4,7 @@ module Network.Wai.Handler.Warp.Header where

44

55import Data.Array

66import Data.Array.ST

7−import qualified Data.ByteString as BS

8−import Data.CaseInsensitive (foldedCase)

97import Network.HTTP.Types

10−

118import Network.Wai.Handler.Warp.Types

129

1310----------------------------------------------------------------

@@ -20,43 +17,29 @@ type IndexedHeader = Array Int (Maybe HeaderValue)

2017indexRequestHeader :: RequestHeaders -> IndexedHeader

2118indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex

2219

23−data RequestHeaderIndex = ReqContentLength

24− | ReqTransferEncoding

25− | ReqExpect

26− | ReqConnection

27− | ReqRange

28− | ReqHost

29− | ReqIfModifiedSince

30− | ReqIfUnmodifiedSince

31− | ReqIfRange

32− | ReqReferer

33− | ReqUserAgent

34− deriving (Enum,Bounded)

20+idxContentLength,idxTransferEncoding,idxExpect :: Int

21+idxConnection,idxRange,idxHost :: Int

22+idxContentLength = 0

23+idxTransferEncoding = 1

24+idxExpect = 2

25+idxConnection = 3

26+idxRange = 4

27+idxHost = 5

3528

3629-- | The size for 'IndexedHeader' for HTTP Request.

3730-- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",

38−-- \"Expect\", \"Connection\", \"Range\", \"Host\",

39−-- \"If-Modified-Since\", \"If-Unmodified-Since\" and \"If-Range\".

31+-- \"Expect\", \"Connection\", \"Range\", and \"Host\".

4032requestMaxIndex :: Int

41−requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex)

33+requestMaxIndex = 5

4234

4335requestKeyIndex :: HeaderName -> Int

44−requestKeyIndex hn = case BS.length bs of

45− 4 -> if bs == "host" then fromEnum ReqHost else -1

46− 5 -> if bs == "range" then fromEnum ReqRange else -1

47− 6 -> if bs == "expect" then fromEnum ReqExpect else -1

48− 7 -> if bs == "referer" then fromEnum ReqReferer else -1

49− 8 -> if bs == "if-range" then fromEnum ReqIfRange else -1

50− 10 -> if bs == "user-agent" then fromEnum ReqUserAgent else

51− if bs == "connection" then fromEnum ReqConnection else -1

52− 14 -> if bs == "content-length" then fromEnum ReqContentLength else -1

53− 17 -> if bs == "transfer-encoding" then fromEnum ReqTransferEncoding else

54− if bs == "if-modified-since" then fromEnum ReqIfModifiedSince

55− else -1

56− 19 -> if bs == "if-unmodified-since" then fromEnum ReqIfUnmodifiedSince else -1

57− _ -> -1

58− where

59− bs = foldedCase hn

36+requestKeyIndex "content-length" = idxContentLength

37+requestKeyIndex "transfer-encoding" = idxTransferEncoding

38+requestKeyIndex "expect" = idxExpect

39+requestKeyIndex "connection" = idxConnection

40+requestKeyIndex "range" = idxRange

41+requestKeyIndex "host" = idxHost

42+requestKeyIndex _ = -1

6043

6144defaultIndexRequestHeader :: IndexedHeader

6245defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]

@@ -66,25 +49,20 @@ defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..reques

6649indexResponseHeader :: ResponseHeaders -> IndexedHeader

6750indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex

6851

69−data ResponseHeaderIndex = ResContentLength

70− | ResServer

71− | ResDate

72− | ResLastModified

73− deriving (Enum,Bounded)

52+idxServer, idxDate :: Int

53+--idxContentLength = 0

54+idxServer = 1

55+idxDate = 2

7456

7557-- | The size for 'IndexedHeader' for HTTP Response.

7658responseMaxIndex :: Int

77−responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex)

59+responseMaxIndex = 2

7860

7961responseKeyIndex :: HeaderName -> Int

80−responseKeyIndex hn = case BS.length bs of

81− 4 -> if bs == "date" then fromEnum ResDate else -1

82− 6 -> if bs == "server" then fromEnum ResServer else -1

83− 13 -> if bs == "last-modified" then fromEnum ResLastModified else -1

84− 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

85− _ -> -1

86− where

87− bs = foldedCase hn

62+responseKeyIndex "content-length" = idxContentLength

63+responseKeyIndex "server" = idxServer

64+responseKeyIndex "date" = idxDate

65+responseKeyIndex _ = -1

8866

8967----------------------------------------------------------------

9068

warp/Network/Wai/Handler/Warp/IO.hs+46−6

@@ -3,18 +3,25 @@

33

44module Network.Wai.Handler.Warp.IO where

55

6−import Data.ByteString.Builder (Builder)

7−import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

8−

6+import Data.ByteString.Internal (ByteString(..))

7+import Foreign.ForeignPtr (newForeignPtr_)

98import Network.Wai.Handler.Warp.Buffer

10−import Network.Wai.Handler.Warp.Imports

11−import Network.Wai.Handler.Warp.Types

9+

10+-- Support for doctest, where cabal macros are not available

11+#ifndef MIN_VERSION_blaze_builder

12+#define MIN_VERSION_blaze_builder(x, y, z) 1

13+#endif

14+

15+#if MIN_VERSION_blaze_builder(0,4,0)

16+

17+import Blaze.ByteString.Builder (Builder)

18+import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))

1219

1320toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

1421toBufIOWith buf !size io builder = loop firstWriter

1522 where

1623 firstWriter = runBuilder builder

17− runIO len = bufferIO buf len io

24+ runIO len = toBS buf len >>= io

1825 loop writer = do

1926 (len, signal) <- writer buf size

2027 case signal of

@@ -28,3 +35,36 @@ toBufIOWith buf !size io builder = loop firstWriter

2835 runIO len

2936 io bs

3037 loop next

38+

39+#else /* !MIN_VERSION_blaze_builder(0,4,0) */

40+

41+import Blaze.ByteString.Builder.Internal.Types (Builder(..), BuildSignal(..), BufRange(..), runBuildStep, buildStep)

42+import Foreign.Ptr (plusPtr, minusPtr)

43+

44+toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()

45+toBufIOWith buf !size io (Builder build) = loop firstStep

46+ where

47+ firstStep = build (buildStep finalStep)

48+ finalStep (BufRange p _) = return $ Done p ()

49+ bufRange = BufRange buf (buf `plusPtr` size)

50+ runIO ptr = toBS buf (ptr `minusPtr` buf) >>= io

51+ loop step = do

52+ signal <- runBuildStep step bufRange

53+ case signal of

54+ Done ptr _ -> runIO ptr

55+ BufferFull minSize ptr next

56+ | size < minSize -> error "toBufIOWith: BufferFull: minSize"

57+ | otherwise -> do

58+ runIO ptr

59+ loop next

60+ InsertByteString ptr bs next -> do

61+ runIO ptr

62+ io bs

63+ loop next

64+

65+#endif /* !MIN_VERSION_blaze_builder(0,4,0) */

66+

67+toBS :: Buffer -> Int -> IO ByteString

68+toBS ptr siz = do

69+ fptr <- newForeignPtr_ ptr

70+ return $ PS fptr 0 siz

warp/Network/Wai/Handler/Warp/IORef.hsnew file+26

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

1+{-# LANGUAGE CPP #-}

2+

3+#ifndef MIN_VERSION_base

4+#define MIN_VERSION_base(x,y,z) 1

5+#endif

6+

7+module Network.Wai.Handler.Warp.IORef (

8+ module Data.IORef

9+#if !MIN_VERSION_base(4,6,0)

10+ , atomicModifyIORef'

11+#endif

12+ ) where

13+

14+import Data.IORef

15+

16+#if !MIN_VERSION_base(4,6,0)

17+-- | Strict version of 'atomicModifyIORef'. This forces both the value stored

18+-- in the 'IORef' as well as the value returned.

19+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b

20+atomicModifyIORef' ref f = do

21+ c <- atomicModifyIORef ref

22+ (\x -> let (a, b) = f x -- Lazy application of "f"

23+ in (a, a `seq` b)) -- Lazy application of "seq"

24+ -- The following forces "a `seq` b", so it also forces "f x".

25+ c `seq` return c

26+#endif

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

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

1−module Network.Wai.Handler.Warp.Imports (

2− ByteString(..)

3− , NonEmpty(..)

4− , module Control.Applicative

5− , module Control.Monad

6− , module Data.Bits

7− , module Data.List

8− , module Data.Int

9− , module Data.Monoid

10− , module Data.Ord

11− , module Data.Word

12− , module Data.Maybe

13− , module Numeric

14− ) where

15−

16−import Control.Applicative

17−import Control.Monad

18−import Data.Bits

19−import Data.ByteString.Internal (ByteString(..))

20−import Data.Int

21−import Data.List

22−import Data.List.NonEmpty (NonEmpty(..))

23−import Data.Maybe

24−import Data.Monoid

25−import Data.Ord

26−import Data.Word

27−import Numeric

warp/Network/Wai/Handler/Warp/Internal.hs+17−82

@@ -1,86 +1,21 @@

11{-# OPTIONS_GHC -fno-warn-deprecations #-}

2+module Network.Wai.Handler.Warp.Internal

3+ ( Settings (..)

4+ , getOnOpen

5+ , getOnClose

6+ , getOnException

7+ ) where

28

3−module Network.Wai.Handler.Warp.Internal (

4− -- * Settings

5− Settings (..)

6− , ProxyProtocol(..)

7− -- * Low level run functions

8− , runSettingsConnection

9− , runSettingsConnectionMaker

10− , runSettingsConnectionMakerSecure

11− , Transport (..)

12− -- * Connection

13− , Connection (..)

14− , socketConnection

15− -- ** Receive

16− , Recv

17− , RecvBuf

18− , makePlainReceiveN

19− -- ** Buffer

20− , Buffer

21− , BufSize

22− , bufferSize

23− , allocateBuffer

24− , freeBuffer

25− , copy

26− -- ** Sendfile

27− , FileId (..)

28− , SendFile

29− , sendFile

30− , readSendFile

31− -- * Version

32− , warpVersion

33− -- * Data types

34− , InternalInfo (..)

35− , HeaderValue

36− , IndexedHeader

37− , requestMaxIndex

38− -- * Time out manager

39− -- |

40− --

41− -- In order to provide slowloris protection, Warp provides timeout handlers. We

42− -- follow these rules:

43− --

44− -- * A timeout is created when a connection is opened.

45− --

46− -- * When all request headers are read, the timeout is tickled.

47− --

48− -- * Every time at least the slowloris size settings number of bytes of the request

49− -- body are read, the timeout is tickled.

50− --

51− -- * The timeout is paused while executing user code. This will apply to both

52− -- the application itself, and a ResponseSource response. The timeout is

53− -- resumed as soon as we return from user code.

54− --

55− -- * Every time data is successfully sent to the client, the timeout is tickled.

56− , module System.TimeManager

57− -- * File descriptor cache

58− , module Network.Wai.Handler.Warp.FdCache

59− -- * File information cache

60− , module Network.Wai.Handler.Warp.FileInfoCache

61− -- * Date

62− , module Network.Wai.Handler.Warp.Date

63− -- * Request and response

64− , Source

65− , recvRequest

66− , sendResponse

67− -- * Platform dependent helper functions

68− , setSocketCloseOnExec

69− , windowsThreadBlockHack

70− ) where

9+import Network.Wai.Handler.Warp.Settings (Settings (..))

10+import Network.Socket (SockAddr)

11+import Network.Wai (Request)

12+import Control.Exception (SomeException)

7113

72−import System.TimeManager

14+getOnOpen :: Settings -> SockAddr -> IO Bool

15+getOnOpen = settingsOnOpen

7316

74−import Network.Wai.Handler.Warp.Buffer

75−import Network.Wai.Handler.Warp.Date

76−import Network.Wai.Handler.Warp.FdCache

77−import Network.Wai.Handler.Warp.FileInfoCache

78−import Network.Wai.Handler.Warp.Header

79−import Network.Wai.Handler.Warp.Recv

80−import Network.Wai.Handler.Warp.Request

81−import Network.Wai.Handler.Warp.Response

82−import Network.Wai.Handler.Warp.Run

83−import Network.Wai.Handler.Warp.SendFile

84−import Network.Wai.Handler.Warp.Settings

85−import Network.Wai.Handler.Warp.Types

86−import Network.Wai.Handler.Warp.Windows

17+getOnClose :: Settings -> SockAddr -> IO ()

18+getOnClose = settingsOnClose

19+

20+getOnException :: Settings -> Maybe Request -> SomeException -> IO ()

21+getOnException = settingsOnException

warp/Network/Wai/Handler/Warp/MultiMap.hs+194−65

@@ -1,111 +1,240 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE CPP #-}

22

33module Network.Wai.Handler.Warp.MultiMap (

4− MultiMap

5− , isEmpty

4+ MMap

5+ , Some(..)

66 , empty

77 , singleton

88 , insert

9− , Network.Wai.Handler.Warp.MultiMap.lookup

9+ , search

10+ , searchWith

11+ , isEmpty

12+ , valid

1013 , pruneWith

14+ , fromList

1115 , toList

16+ , fromSortedList

17+ , toSortedList

1218 , merge

1319 ) where

1420

15−import Data.Hashable (hash)

16−import Data.IntMap.Strict (IntMap)

17−import qualified Data.IntMap.Strict as I

18−import Data.Semigroup

19−import Prelude -- Silence redundant import warnings

21+#if __GLASGOW_HASKELL__ < 709

22+import Control.Applicative ((<$>))

23+#endif

24+import Data.List (foldl')

2025

2126----------------------------------------------------------------

2227

23−-- | 'MultiMap' is used for cache of file descriptors.

24−-- Since multiple threads would open file descriptors for

25−-- the same file simultaneously, multiple entries must

26−-- be contained for the file.

27−-- Since hash values of file pathes are used as outer keys,

28−-- collison would happen for multiple file pathes.

29−-- Becase only positive entries are contained,

30−-- a bad guy cannot be cause the hash collision intentinally.

31−-- So, lists are good enough.

32−newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])

28+-- | One ore more list to implement multimap.

29+data Some a = One !a

30+ | Tom !a !(Some a) -- Two or more

31+ deriving (Eq,Show)

32+

33+-- This is slow but assuming rarely used.

34+snoc :: Some a -> a -> Some a

35+snoc (One x) y = Tom x (One y)

36+snoc (Tom x xs) y = Tom x (snoc xs y)

37+

38+top :: Some a -> a

39+top (One x) = x

40+top (Tom x _) = x

41+

42+----------------------------------------------------------------

43+

44+-- | Red black tree as multimap.

45+data MMap k v = Leaf -- color is Black

46+ | Node Color !(MMap k v) !k !(Some v) !(MMap k v)

47+ deriving (Show)

48+

49+data Color = B -- ^ Black

50+ | R -- ^ Red

51+ deriving (Eq, Show)

52+

53+----------------------------------------------------------------

54+

55+instance (Eq k, Eq v) => Eq (MMap k v) where

56+ t1 == t2 = toSortedList t1 == toSortedList t2

57+

58+----------------------------------------------------------------

59+

60+-- | O(log N)

61+search :: Ord k => k -> MMap k v -> Maybe v

62+search _ Leaf = Nothing

63+search xk (Node _ l k v r) = case compare xk k of

64+ LT -> search xk l

65+ GT -> search xk r

66+ EQ -> Just $ top v

67+

68+-- | O(log N)

69+searchWith :: Ord k => k -> (Some v -> Maybe v) -> MMap k v -> Maybe v

70+searchWith _ _ Leaf = Nothing

71+searchWith xk f (Node _ l k v r) = case compare xk k of

72+ LT -> searchWith xk f l

73+ GT -> searchWith xk f r

74+ EQ -> f v

3375

3476----------------------------------------------------------------

3577

3678-- | O(1)

37−empty :: MultiMap v

38−empty = MultiMap $ I.empty

79+isEmpty :: MMap k v -> Bool

80+isEmpty Leaf = True

81+isEmpty _ = False

3982

4083-- | O(1)

41−isEmpty :: MultiMap v -> Bool

42−isEmpty (MultiMap mm) = I.null mm

84+empty :: MMap k v

85+empty = Leaf

4386

4487----------------------------------------------------------------

4588

4689-- | O(1)

47−singleton :: FilePath -> v -> MultiMap v

48−singleton path v = MultiMap mm

49− where

50− !h = hash path

51− !mm = I.singleton h [(path,v)]

90+singleton :: Ord k => k -> v -> MMap k v

91+singleton k v = Node B Leaf k (One v) Leaf

92+

93+----------------------------------------------------------------

94+

95+-- | O(log N)

96+insert :: Ord k => k -> v -> MMap k v -> MMap k v

97+insert kx kv t = turnB (insert' kx kv t)

98+

99+insert' :: Ord k => k -> v -> MMap k v -> MMap k v

100+insert' xk xv Leaf = Node R Leaf xk (One xv) Leaf

101+insert' xk xv (Node B l k v r) = case compare xk k of

102+ LT -> balanceL' (insert' xk xv l) k v r

103+ GT -> balanceR' l k v (insert' xk xv r)

104+ EQ -> Node B l k (snoc v xv) r

105+insert' xk xv (Node R l k v r) = case compare xk k of

106+ LT -> Node R (insert' xk xv l) k v r

107+ GT -> Node R l k v (insert' xk xv r)

108+ EQ -> Node R l k (snoc v xv) r

109+

110+balanceL' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v

111+balanceL' (Node R (Node R a xk xv b) yk yv c) zk zv d =

112+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)

113+balanceL' (Node R a xk xv (Node R b yk yv c)) zk zv d =

114+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)

115+balanceL' l k v r = Node B l k v r

116+

117+balanceR' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v

118+balanceR' a xk xv (Node R b yk yv (Node R c zk zv d)) =

119+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)

120+balanceR' a xk xv (Node R (Node R b yk yv c) zk zv d) =

121+ Node R (Node B a xk xv b) yk yv (Node B c zk zv d)

122+balanceR' l xk xv r = Node B l xk xv r

123+

124+turnB :: MMap k v -> MMap k v

125+turnB Leaf = error "turnB"

126+turnB (Node _ l k v r) = Node B l k v r

52127

53128----------------------------------------------------------------

54129

130+-- | O(N log N)

131+fromList :: Ord k => [(k,v)] -> MMap k v

132+fromList = foldl' (\t (k,v) -> insert k v t) empty

133+

55134-- | O(N)

56−lookup :: FilePath -> MultiMap v -> Maybe v

57−lookup path (MultiMap mm) = case I.lookup h mm of

58− Nothing -> Nothing

59− Just s -> Prelude.lookup path s

135+toList :: MMap k v -> [(k,v)]

136+toList t = inorder t []

60137 where

61− !h = hash path

138+ inorder Leaf xs = xs

139+ inorder (Node _ l k v r) xs = inorder l (pairs k v ++ inorder r xs)

140+ pairs k (One v) = [(k,v)]

141+ pairs k (Tom v vs) = (k,v) : pairs k vs

62142

63143----------------------------------------------------------------

64144

65−-- | O(log n)

66−insert :: FilePath -> v -> MultiMap v -> MultiMap v

67−insert path v (MultiMap mm) = MultiMap mm'

68− where

69− !h = hash path

70− !mm' = I.insertWith (<>) h [(path,v)] mm

145+-- | O(N)

146+-- "Constructing Red-Black Trees" by Ralf Hinze

147+fromSortedList :: Ord k => [(k,Some v)] -> MMap k v

148+fromSortedList = linkAll . foldr add []

149+

150+data Digit k v = Uno k (Some v) (MMap k v)

151+ | Due k (Some v) (MMap k v) k (Some v) (MMap k v)

152+ deriving (Eq,Show)

153+

154+incr :: Digit k v -> [Digit k v] -> [Digit k v]

155+incr (Uno k v t) [] = [Uno k v t]

156+incr (Uno k1 v1 t1) (Uno k2 v2 t2 : ps) = Due k1 v1 t1 k2 v2 t2 : ps

157+incr (Uno k1 v1 t1) (Due k2 v2 t2 k3 v3 t3 : ps) = Uno k1 v1 t1 : incr (Uno k2 v2 (Node B t2 k3 v3 t3)) ps

158+incr _ _ = error "incr"

159+

160+add :: (k,Some v) -> [Digit k v] -> [Digit k v]

161+add (k,v) ps = incr (Uno k v Leaf) ps

162+

163+linkAll :: [Digit k v] -> MMap k v

164+linkAll = foldl' link Leaf

165+

166+link :: MMap k v -> Digit k v -> MMap k v

167+link l (Uno k v t) = Node B l k v t

168+--link l (Due k1 v1 t1 k2 v2 t2) = Node B (Node R l k1 v1 t1) k2 v2 t2

169+link l (Due k1 v1 t1 k2 v2 t2) = Node B l k1 v1 (Node R t1 k2 v2 t2)

71170

72171----------------------------------------------------------------

73172

74−-- | O(n)

75−toList :: MultiMap v -> [(FilePath,v)]

76−toList (MultiMap mm) = concatMap snd $ I.toAscList mm

173+-- | O(N)

174+toSortedList :: MMap k v -> [(k,Some v)]

175+toSortedList t = inorder t []

176+ where

177+ inorder Leaf xs = xs

178+ inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs)

77179

78180----------------------------------------------------------------

79181

80−-- | O(n)

81−pruneWith :: MultiMap v

82− -> ((FilePath,v) -> IO Bool)

83− -> IO (MultiMap v)

84−pruneWith (MultiMap mm) action = MultiMap <$> mm'

182+-- | O(N)

183+pruneWith :: Ord k =>

184+ MMap k v

185+ -> (k -> Some v -> IO [(k, Some v)])

186+ -> IO (MMap k v)

187+pruneWith t run = fromSortedList <$> inorder t []

85188 where

86− !mm' = I.fromAscList <$> go (I.toDescList mm) []

87− go [] !acc = return acc

88− go ((h,s):kss) !acc = do

89− rs <- prune action s

90− case rs of

91− [] -> go kss acc

92− _ -> go kss ((h,rs) : acc)

189+ inorder Leaf xs = return xs

190+ inorder (Node _ l k v r) xs = do

191+ ys <- run k v

192+ zs <- inorder r xs

193+ inorder l (ys ++ zs)

93194

94195----------------------------------------------------------------

95196

96−-- O(n + m) where N is the size of the second argument

97−merge :: MultiMap v -> MultiMap v -> MultiMap v

98−merge (MultiMap m1) (MultiMap m2) = MultiMap mm

197+-- O(N log N) where N is the size of the second argument

198+merge :: Ord k => MMap k v -> MMap k v -> MMap k v

199+merge base m = foldl' ins base xs

99200 where

100− !mm = I.unionWith (<>) m1 m2

201+ ins t (k,v) = insert k v t

202+ xs = toList m

101203

102204----------------------------------------------------------------

205+-- for testing

206+

207+valid :: Ord k => MMap k v -> Bool

208+valid t = isBalanced t && isOrdered t

103209

104−prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]

105−prune action xs0 = go xs0

210+isBalanced :: MMap k v -> Bool

211+isBalanced t = isBlackSame t && isRedSeparate t

212+

213+isBlackSame :: MMap k v -> Bool

214+isBlackSame t = all (n==) ns

215+ where

216+ n:ns = blacks t

217+

218+blacks :: MMap k v -> [Int]

219+blacks = blacks' 0

220+ where

221+ blacks' n Leaf = [n+1]

222+ blacks' n (Node R l _ _ r) = blacks' n l ++ blacks' n r

223+ blacks' n (Node B l _ _ r) = blacks' n' l ++ blacks' n' r

224+ where

225+ n' = n + 1

226+

227+isRedSeparate :: MMap k v -> Bool

228+isRedSeparate = reds B

229+

230+reds :: Color -> MMap k v -> Bool

231+reds _ Leaf = True

232+reds R (Node R _ _ _ _) = False

233+reds _ (Node c l _ _ r) = reds c l && reds c r

234+

235+isOrdered :: Ord k => MMap k v -> Bool

236+isOrdered t = ordered $ toSortedList t

106237 where

107− go [] = return []

108− go (x:xs) = do

109− keep <- action x

110− rs <- go xs

111− return $ if keep then x:rs else rs

238+ ordered [] = True

239+ ordered [_] = True

240+ ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)

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

@@ -1,56 +0,0 @@

1−{-# LANGUAGE OverloadedStrings, BangPatterns #-}

2−

3−module Network.Wai.Handler.Warp.PackInt where

4−

5−import Data.ByteString.Internal (unsafeCreate)

6−import Foreign.Ptr (Ptr, plusPtr)

7−import Foreign.Storable (poke)

8−import qualified Network.HTTP.Types as H

9−

10−import Network.Wai.Handler.Warp.Imports

11−

12−-- $setup

13−-- >>> import Data.ByteString.Char8 as C8

14−-- >>> import Test.QuickCheck (Large(..))

15−

16−-- |

17−--

18−-- prop> packIntegral (abs n) == C8.pack (show (abs n))

19−-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.pack (show n')

20−

21−packIntegral :: Integral a => a -> ByteString

22−packIntegral 0 = "0"

23−packIntegral n | n < 0 = error "packIntegral"

24−packIntegral n = unsafeCreate len go0

25− where

26− n' = fromIntegral n + 1 :: Double

27− len = ceiling $ logBase 10 n'

28− go0 p = go n $ p `plusPtr` (len - 1)

29− go :: Integral a => a -> Ptr Word8 -> IO ()

30− go i p = do

31− let (d,r) = i `divMod` 10

32− poke p (48 + fromIntegral r)

33− when (d /= 0) $ go d (p `plusPtr` (-1))

34−

35−{-# SPECIALIZE packIntegral :: Int -> ByteString #-}

36−{-# SPECIALIZE packIntegral :: Integer -> ByteString #-}

37−

38−-- |

39−--

40−-- >>> packStatus H.status200

41−-- "200"

42−-- >>> packStatus H.preconditionFailed412

43−-- "412"

44−

45−packStatus :: H.Status -> ByteString

46−packStatus status = unsafeCreate 3 $ \p -> do

47− poke p (toW8 r2)

48− poke (p `plusPtr` 1) (toW8 r1)

49− poke (p `plusPtr` 2) (toW8 r0)

50− where

51− toW8 :: Int -> Word8

52− toW8 n = 48 + fromIntegral n

53− !s = fromIntegral $ H.statusCode status

54− (!q0,!r0) = s `divMod` 10

55− (!q1,!r1) = q0 `divMod` 10

56− !r2 = q1 `mod` 10

warp/Network/Wai/Handler/Warp/ReadInt.hs+2−2

@@ -13,13 +13,13 @@ module Network.Wai.Handler.Warp.ReadInt (

1313-- This function lives in its own file because the MagicHash pragma interacts

1414-- poorly with the CPP pragma.

1515

16+import Data.ByteString (ByteString)

1617import qualified Data.ByteString as S

18+import Data.Int (Int64)

1719import GHC.Prim

1820import GHC.Types

1921import GHC.Word

2022

21−import Network.Wai.Handler.Warp.Imports hiding (readInt)

22−

2323{-# INLINE readInt #-}

2424readInt :: Integral a => ByteString -> a

2525readInt bs = fromIntegral $ readInt64 bs

warp/Network/Wai/Handler/Warp/Recv.hs+16−122

@@ -1,35 +1,22 @@

1−{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}

1+{-# LANGUAGE ForeignFunctionInterface #-}

22{-# LANGUAGE CPP #-}

33

44module Network.Wai.Handler.Warp.Recv (

55 receive

6− , receiveBuf

7− , makeReceiveN

8− , makePlainReceiveN

9− , spell

106 ) where

117

12−import qualified Control.Exception as E

13−import qualified Data.ByteString as BS

14−import Data.IORef

8+#if __GLASGOW_HASKELL__ < 709

9+import Control.Applicative ((<$>))

10+#endif

11+import Data.ByteString (ByteString)

12+import Data.Word (Word8)

1513import Foreign.C.Error (eAGAIN, getErrno, throwErrno)

1614import Foreign.C.Types

17−import Foreign.ForeignPtr (withForeignPtr)

18−import Foreign.Ptr (Ptr, castPtr, plusPtr)

15+import Foreign.Ptr (Ptr, castPtr)

1916import GHC.Conc (threadWaitRead)

20−import qualified GHC.IO.Exception as E

21−import Network.Socket (Socket)

22−import qualified System.IO.Error as E

23−#if MIN_VERSION_network(3,1,0)

24−import Network.Socket (withFdSocket)

25−#else

26−import Network.Socket (fdSocket)

27−#endif

28−import System.Posix.Types (Fd(..))

29−

17+import Network.Socket (Socket, fdSocket)

3018import Network.Wai.Handler.Warp.Buffer

31−import Network.Wai.Handler.Warp.Imports

32−import Network.Wai.Handler.Warp.Types

19+import System.Posix.Types (Fd(..))

3320

3421#ifdef mingw32_HOST_OS

3522import GHC.IO.FD (FD(..), readRawBufferPtr)

@@ -38,108 +25,17 @@ import Network.Wai.Handler.Warp.Windows

3825

3926----------------------------------------------------------------

4027

41−makeReceiveN :: ByteString -> Recv -> RecvBuf -> IO (BufSize -> IO ByteString)

42−makeReceiveN bs0 recv recvBuf = do

43− ref <- newIORef bs0

44− return $ receiveN ref recv recvBuf

45−

46−-- | This function returns a receiving function

47−-- based on two receiving functions.

48−-- The returned function efficiently manages received data

49−-- which is initialized by the first argument.

50−-- The returned function may allocate a byte string with malloc().

51−makePlainReceiveN :: Socket -> ByteString -> IO (BufSize -> IO ByteString)

52−makePlainReceiveN s bs0 = do

53− ref <- newIORef bs0

54− pool <- newBufferPool

55− return $ receiveN ref (receive s pool) (receiveBuf s)

56−

57−receiveN :: IORef ByteString -> Recv -> RecvBuf -> BufSize -> IO ByteString

58−receiveN ref recv recvBuf size = E.handle handler $ do

59− cached <- readIORef ref

60− (bs, leftover) <- spell cached size recv recvBuf

61− writeIORef ref leftover

62− return bs

63− where

64− handler :: E.SomeException -> IO ByteString

65− handler _ = return ""

66−

67−----------------------------------------------------------------

68−

69−spell :: ByteString -> BufSize -> IO ByteString -> RecvBuf -> IO (ByteString, ByteString)

70−spell init0 siz0 recv recvBuf

71− | siz0 <= len0 = return $ BS.splitAt siz0 init0

72− -- fixme: hard coding 4096

73− | siz0 <= 4096 = loop [init0] (siz0 - len0)

74− | otherwise = do

75− bs@(PS fptr _ _) <- mallocBS siz0

76− withForeignPtr fptr $ \ptr -> do

77− ptr' <- copy ptr init0

78− full <- recvBuf ptr' (siz0 - len0)

79− if full then

80− return (bs, "")

81− else

82− return ("", "") -- fixme

83− where

84− len0 = BS.length init0

85− loop bss siz = do

86− bs <- recv

87− let len = BS.length bs

88− if len == 0 then

89− return ("", "")

90− else if len >= siz then do

91− let (consume, leftover) = BS.splitAt siz bs

92− ret = BS.concat $ reverse (consume : bss)

93− return (ret, leftover)

94− else do

95− let bss' = bs : bss

96− siz' = siz - len

97− loop bss' siz'

98−

99−-- The timeout manager may close the socket.

100−-- In that case, an error of "Bad file descriptor" occurs.

101−-- We ignores it because we expect TimeoutThread.

102−receive :: Socket -> BufferPool -> Recv

103−receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do

104−#if MIN_VERSION_network(3,1,0)

105− withFdSocket sock $ \fd -> do

106−#elif MIN_VERSION_network(3,0,0)

107− fd <- fdSocket sock

108−#else

109− let fd = fdSocket sock

110−#endif

111− let size' = fromIntegral size

112− fromIntegral <$> receiveloop fd ptr size'

113− where

114− handler :: E.IOException -> IO ByteString

115− handler e

116− | E.ioeGetErrorType e == E.InvalidArgument = return ""

117− | otherwise = E.throwIO e

118−

119−receiveBuf :: Socket -> RecvBuf

120−receiveBuf sock buf0 siz0 = do

121−#if MIN_VERSION_network(3,1,0)

122− withFdSocket sock $ \fd -> do

123−#elif MIN_VERSION_network(3,0,0)

124− fd <- fdSocket sock

125−#else

126− let fd = fdSocket sock

127−#endif

128− loop fd buf0 siz0

129− where

130− loop _ _ 0 = return True

131− loop fd buf siz = do

132− n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)

133− -- fixme: what should we do in the case of n == 0

134− if n == 0 then

135− return False

136− else

137− loop fd (buf `plusPtr` n) (siz - n)

28+receive :: Socket -> BufferPool -> IO ByteString

29+receive sock pool = withBufferPool pool $ \ (ptr, size) -> do

30+ let sock' = fdSocket sock

31+ size' = fromIntegral size

32+ received <- fromIntegral <$> receiveloop sock' ptr size'

33+ return received

13834

13935receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt

14036receiveloop sock ptr size = do

14137#ifdef mingw32_HOST_OS

142− bytes <- windowsThreadBlockHack $ fromIntegral <$> readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size

38+ bytes <- windowsThreadBlockHack $ fmap fromIntegral $ readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size

14339#else

14440 bytes <- c_recv sock (castPtr ptr) size 0

14541#endif

@@ -153,8 +49,6 @@ receiveloop sock ptr size = do

15349 else

15450 return bytes

15551

156−#ifndef mingw32_HOST_OS

15752-- fixme: the type of the return value

15853foreign import ccall unsafe "recv"

15954 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

160−#endif

warp/Network/Wai/Handler/Warp/Request.hs+40−63

@@ -1,57 +1,53 @@

11{-# LANGUAGE BangPatterns #-}

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE CPP #-}

4−{-# LANGUAGE DeriveDataTypeable #-}

54{-# OPTIONS_GHC -fno-warn-deprecations #-}

65

76module Network.Wai.Handler.Warp.Request (

87 recvRequest

98 , headerLines

109 , pauseTimeoutKey

11− , getFileInfoKey

12− , getClientCertificateKey

13− , NoKeepAliveRequest (..)

1410 ) where

1511

1612import qualified Control.Concurrent as Conc (yield)

17−import Control.Exception (throwIO, Exception)

13+import Control.Exception (throwIO)

1814import Data.Array ((!))

15+import Data.ByteString (ByteString)

1916import qualified Data.ByteString as S

2017import qualified Data.ByteString.Unsafe as SU

2118import qualified Data.CaseInsensitive as CI

2219import qualified Data.IORef as I

23−import Data.Typeable (Typeable)

24−import qualified Data.Vault.Lazy as Vault

25−import Data.X509

2620import qualified Network.HTTP.Types as H

2721import Network.Socket (SockAddr)

2822import Network.Wai

23+import Network.Wai.Handler.Warp.Conduit

24+import Network.Wai.Handler.Warp.Header

25+import Network.Wai.Handler.Warp.ReadInt

26+import Network.Wai.Handler.Warp.RequestHeader

27+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)

28+import qualified Network.Wai.Handler.Warp.Timeout as Timeout

2929import Network.Wai.Handler.Warp.Types

3030import Network.Wai.Internal

3131import Prelude hiding (lines)

32+import Control.Monad (when)

33+import qualified Data.Vault.Lazy as Vault

3234import System.IO.Unsafe (unsafePerformIO)

33−import qualified System.TimeManager as Timeout

3435

35−import Network.Wai.Handler.Warp.Conduit

36−import Network.Wai.Handler.Warp.FileInfoCache

37−import Network.Wai.Handler.Warp.Header

38−import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

39−import Network.Wai.Handler.Warp.ReadInt

40−import Network.Wai.Handler.Warp.RequestHeader

41−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)

36+----------------------------------------------------------------

37+

38+-- FIXME come up with good values here

39+maxTotalHeaderLength :: Int

40+maxTotalHeaderLength = 50 * 1024

4241

4342----------------------------------------------------------------

4443

4544-- | Receiving a HTTP request from 'Connection' and parsing its header

4645-- to create 'Request'.

47−recvRequest :: Bool -- ^ first request on this connection?

48− -> Settings

46+recvRequest :: Settings

4947 -> Connection

5048 -> InternalInfo

51− -> Timeout.Handle

5249 -> SockAddr -- ^ Peer's address.

5350 -> Source -- ^ Where HTTP request comes from.

54− -> Transport

5551 -> IO (Request

5652 ,Maybe (I.IORef Int)

5753 ,IndexedHeader

@@ -61,19 +57,14 @@ recvRequest :: Bool -- ^ first request on this connection?

6157 -- 'IndexedHeader' of HTTP request for internal use,

6258 -- Body producing action used for flushing the request body

6359

64−recvRequest firstRequest settings conn ii th addr src transport = do

65− hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src

60+recvRequest settings conn ii addr src = do

61+ hdrlines <- headerLines src

6662 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

6763 let idxhdr = indexRequestHeader hdr

68− expect = idxhdr ! fromEnum ReqExpect

69− cl = idxhdr ! fromEnum ReqContentLength

70− te = idxhdr ! fromEnum ReqTransferEncoding

64+ expect = idxhdr ! idxExpect

65+ cl = idxhdr ! idxContentLength

66+ te = idxhdr ! idxTransferEncoding

7167 handle100Continue = handleExpect conn httpversion expect

72− rawPath = if settingsNoParsePath settings then unparsedPath else path

73− vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

74− $ Vault.insert getFileInfoKey (getFileInfo ii)

75− $ Vault.insert getClientCertificateKey (tlsClientCertificate transport)

76− Vault.empty

7768 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te

7869 -- body producing function which will produce '100-continue', if needed

7970 rbody' <- timeoutBody remainingRef th rbody handle100Continue

@@ -83,38 +74,32 @@ recvRequest firstRequest settings conn ii th addr src transport = do

8374 requestMethod = method

8475 , httpVersion = httpversion

8576 , pathInfo = H.decodePathSegments path

86− , rawPathInfo = rawPath

77+ , rawPathInfo = if settingsNoParsePath settings then unparsedPath else path

8778 , rawQueryString = query

8879 , queryString = H.parseQuery query

8980 , requestHeaders = hdr

90− , isSecure = isTransportSecure transport

81+ , isSecure = False

9182 , remoteHost = addr

9283 , requestBody = rbody'

93− , vault = vaultValue

84+ , vault = Vault.insert pauseTimeoutKey

85+ (Timeout.pause th)

86+ Vault.empty

9487 , requestBodyLength = bodyLength

95− , requestHeaderHost = idxhdr ! fromEnum ReqHost

96− , requestHeaderRange = idxhdr ! fromEnum ReqRange

97− , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

98− , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

88+ , requestHeaderHost = idxhdr ! idxHost

89+ , requestHeaderRange = idxhdr ! idxRange

9990 }

10091 return (req, remainingRef, idxhdr, rbodyFlush)

92+ where

93+ th = threadHandle ii

10194

10295----------------------------------------------------------------

10396

104−headerLines :: Int -> Bool -> Source -> IO [ByteString]

105−headerLines maxTotalHeaderLength firstRequest src = do

97+headerLines :: Source -> IO [ByteString]

98+headerLines src = do

10699 bs <- readSource src

107100 if S.null bs

108− -- When we're working on a keep-alive connection and trying to

109− -- get the second or later request, we don't want to treat the

110− -- lack of data as a real exception. See the http1 function in

111− -- the Run module for more details.

112− then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

113− else push maxTotalHeaderLength src (THStatus 0 id id) bs

114−

115−data NoKeepAliveRequest = NoKeepAliveRequest

116− deriving (Show, Typeable)

117−instance Exception NoKeepAliveRequest

101+ then throwIO $ NotEnoughLines []

102+ else push src (THStatus 0 id id) bs

118103

119104----------------------------------------------------------------

120105

@@ -220,8 +205,8 @@ close :: Sink ByteString IO a

220205close = throwIO IncompleteHeaders

221206-}

222207

223−push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]

224−push maxTotalHeaderLength src (THStatus len lines prepend) bs'

208+push :: Source -> THStatus -> ByteString -> IO [ByteString]

209+push src (THStatus len lines prepend) bs'

225210 -- Too many bytes

226211 | len > maxTotalHeaderLength = throwIO OverLargeHeader

227212 | otherwise = push' mnl

@@ -249,13 +234,13 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'

249234 push' Nothing = do

250235 bst <- readSource' src

251236 when (S.null bst) $ throwIO IncompleteHeaders

252− push maxTotalHeaderLength src status bst

237+ push src status bst

253238 where

254239 len' = len + bsLen

255240 prepend' = S.append bs

256241 status = THStatus len' lines prepend'

257242 -- Found a newline, but next line continues as a multiline header

258− push' (Just (end, True)) = push maxTotalHeaderLength src status rest

243+ push' (Just (end, True)) = push src status rest

259244 where

260245 rest = S.drop (end + 1) bs

261246 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

@@ -274,12 +259,12 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'

274259 in if start < bsLen then

275260 -- more bytes in this chunk, push again

276261 let bs'' = SU.unsafeDrop start bs

277− in push maxTotalHeaderLength src status bs''

262+ in push src status bs''

278263 else do

279264 -- no more bytes in this chunk, ask for more

280265 bst <- readSource' src

281266 when (S.null bs) $ throwIO IncompleteHeaders

282− push maxTotalHeaderLength src status bst

267+ push src status bst

283268 where

284269 start = end + 1 -- start of next chunk

285270 line = SU.unsafeTake (checkCR bs end) bs

@@ -293,11 +278,3 @@ checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR

293278pauseTimeoutKey :: Vault.Key (IO ())

294279pauseTimeoutKey = unsafePerformIO Vault.newKey

295280{-# NOINLINE pauseTimeoutKey #-}

296−

297−getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

298−getFileInfoKey = unsafePerformIO Vault.newKey

299−{-# NOINLINE getFileInfoKey #-}

300−

301−getClientCertificateKey :: Vault.Key (Maybe CertificateChain)

302−getClientCertificateKey = unsafePerformIO Vault.newKey

303−{-# NOINLINE getClientCertificateKey #-}

warp/Network/Wai/Handler/Warp/RequestHeader.hs+40−15

@@ -1,22 +1,24 @@

1+{-# LANGUAGE OverloadedStrings #-}

12{-# LANGUAGE BangPatterns #-}

23

34module Network.Wai.Handler.Warp.RequestHeader (

45 parseHeaderLines

6+ , parseByteRanges

57 ) where

68

79import Control.Exception (throwIO)

10+import Control.Monad (when)

811import qualified Data.ByteString as S

9−import qualified Data.ByteString.Char8 as C8 (unpack)

10−import Data.ByteString.Internal (memchr)

12+import qualified Data.ByteString.Char8 as B (unpack, readInteger)

13+import Data.ByteString.Internal (ByteString(..), memchr)

1114import qualified Data.CaseInsensitive as CI

15+import Data.Word (Word8)

1216import Foreign.ForeignPtr (withForeignPtr)

1317import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)

1418import Foreign.Storable (peek)

1519import qualified Network.HTTP.Types as H

16−

17−import Network.Wai.Handler.Warp.Imports

1820import Network.Wai.Handler.Warp.Types

19−

21+import qualified Network.HTTP.Types.Header as HH

2022-- $setup

2123-- >>> :set -XOverloadedStrings

2224

@@ -49,8 +51,6 @@ parseHeaderLines (firstLine:otherLines) = do

4951-- *** Exception: Warp: Invalid first line of request: "GET "

5052-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"

5153-- *** Exception: Warp: Request line specified a non-HTTP request

52−-- >>> parseRequestLine "PRI * HTTP/2.0"

53−-- ("PRI","*","",HTTP/2.0)

5454parseRequestLine :: ByteString

5555 -> IO (H.Method

5656 ,ByteString -- Path

@@ -88,7 +88,7 @@ parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> d

8888

8989 return (method,path,query,hv)

9090 where

91− baderr = BadFirstLine $ C8.unpack requestLine

91+ baderr = BadFirstLine $ B.unpack requestLine

9292 check :: Ptr Word8 -> Int -> Word8 -> IO ()

9393 check p n w = do

9494 w0 <- peek $ p `plusPtr` n

@@ -101,13 +101,12 @@ parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> d

101101 check httpptr 4 47 -- '/'

102102 check httpptr 6 46 -- '.'

103103 httpVersion httpptr = do

104− major <- peek (httpptr `plusPtr` 5) :: IO Word8

105− minor <- peek (httpptr `plusPtr` 7) :: IO Word8

106− let version

107− | major == 49 = if minor == 49 then H.http11 else H.http10

108− | major == 50 && minor == 48 = H.HttpVersion 2 0

109− | otherwise = H.http10

110− return version

104+ major <- peek $ httpptr `plusPtr` 5

105+ minor <- peek $ httpptr `plusPtr` 7

106+ return $ if major == (49 :: Word8) && minor == (49 :: Word8) then

107+ H.http11

108+ else

109+ H.http10

111110 bs ptr p0 p1 = PS fptr o l

112111 where

113112 o = p0 `minusPtr` ptr

@@ -131,3 +130,29 @@ parseHeader s =

131130 let (k, rest) = S.break (== 58) s -- ':'

132131 rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest

133132 in (CI.mk k, rest')

133+

134+parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges

135+parseByteRanges bs1 = do

136+ bs2 <- stripPrefix "bytes=" bs1

137+ (r, bs3) <- range bs2

138+ ranges (r:) bs3

139+ where

140+ range bs2 = do

141+ (i, bs3) <- B.readInteger bs2

142+ if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")

143+ then Just (HH.ByteRangeSuffix (negate i), bs3)

144+ else do

145+ bs4 <- stripPrefix "-" bs3

146+ case B.readInteger bs4 of

147+ Just (j, bs5) | j >= i -> Just (HH.ByteRangeFromTo i j, bs5)

148+ _ -> Just (HH.ByteRangeFrom i, bs4)

149+ ranges front bs3

150+ | S.null bs3 = Just (front [])

151+ | otherwise = do

152+ bs4 <- stripPrefix "," bs3

153+ (r, bs5) <- range bs4

154+ ranges (front . (r:)) bs5

155+

156+ stripPrefix x y

157+ | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)

158+ | otherwise = Nothing

warp/Network/Wai/Handler/Warp/Response.hs+203−195

@@ -1,60 +1,136 @@

11{-# LANGUAGE OverloadedStrings #-}

22{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE TupleSections #-}

34{-# LANGUAGE RankNTypes #-}

45{-# LANGUAGE CPP #-}

5−{-# LANGUAGE BangPatterns #-}

66

77module Network.Wai.Handler.Warp.Response (

88 sendResponse

9− , sanitizeHeaderValue -- for testing

9+ , fileRange -- for testing

1010 , warpVersion

11− , hasBody

12− , replaceHeader

13− , addServer -- testing

11+ , defaultServerValue

1412 ) where

1513

16−import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)

17−import qualified Control.Exception as E

14+#ifndef MIN_VERSION_base

15+#define MIN_VERSION_base(x,y,z) 1

16+#endif

17+

18+import Blaze.ByteString.Builder (fromByteString, Builder, flush)

19+import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)

20+#if __GLASGOW_HASKELL__ < 709

21+import Control.Applicative

22+#endif

23+import Control.Exception

1824import Data.Array ((!))

25+import Data.ByteString (ByteString)

26+import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)

1927import qualified Data.ByteString as S

20−import Data.ByteString.Builder (byteString, Builder)

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

22−import qualified Data.ByteString.Char8 as C8

28+import Control.Monad (unless, when)

29+import qualified Data.ByteString.Char8 as B (pack)

2330import qualified Data.CaseInsensitive as CI

2431import Data.Function (on)

25−import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)

32+import Data.List (deleteBy)

33+import Data.Maybe (isJust, listToMaybe)

34+#if MIN_VERSION_base(4,5,0)

35+# if __GLASGOW_HASKELL__ < 709

36+import Data.Monoid (mempty)

37+# endif

38+import Data.Monoid ((<>))

39+#else

40+import Data.Monoid (mappend, mempty)

41+#endif

2642import Data.Version (showVersion)

27−import Data.Word8 (_cr, _lf)

2843import qualified Network.HTTP.Types as H

29−import qualified Network.HTTP.Types.Header as H

3044import Network.Wai

31−import Network.Wai.Internal

32−import qualified Paths_warp

33−import qualified System.TimeManager as T

34−

35−import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

3645import qualified Network.Wai.Handler.Warp.Date as D

37−import Network.Wai.Handler.Warp.File

46+import Network.Wai.Handler.Warp.Buffer (toBlazeBuffer)

3847import Network.Wai.Handler.Warp.Header

3948import Network.Wai.Handler.Warp.IO (toBufIOWith)

40−import Network.Wai.Handler.Warp.Imports

4149import Network.Wai.Handler.Warp.ResponseHeader

42−import Network.Wai.Handler.Warp.Settings

50+import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)

51+import qualified Network.Wai.Handler.Warp.Timeout as T

4352import Network.Wai.Handler.Warp.Types

53+import Network.Wai.Internal

54+import Numeric (showInt)

55+import qualified Paths_warp

56+import qualified System.PosixCompat.Files as P

57+

58+#if !MIN_VERSION_base(4,5,0)

59+(<>) :: Monoid m => m -> m -> m

60+(<>) = mappend

61+#endif

4462

4563-- $setup

4664-- >>> :set -XOverloadedStrings

4765

66+mapRight :: (b -> c) -> Either a b -> Either a c

67+mapRight f eith = case eith of

68+ Right x -> Right (f x)

69+ Left l -> Left l

70+

71+----------------------------------------------------------------

72+

73+fileRange :: H.Status -> H.ResponseHeaders -> FilePath

74+ -> Maybe FilePart -> Maybe HeaderValue

75+ -> IO (Either IOException

76+ (H.Status, H.ResponseHeaders, Integer, Integer))

77+fileRange s0 hs0 path Nothing mRange =

78+ mapRight (fileRangeSized s0 hs0 Nothing mRange . fromIntegral . P.fileSize) <$>

79+ try (P.getFileStatus path)

80+fileRange s0 hs0 _ mPart@(Just part) mRange =

81+ return . Right $ fileRangeSized s0 hs0 mPart mRange size

82+ where

83+ size = filePartFileSize part

84+

85+fileRangeSized :: H.Status -> H.ResponseHeaders

86+ -> Maybe FilePart -> Maybe HeaderValue -> Integer

87+ -> (H.Status, H.ResponseHeaders, Integer, Integer)

88+fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)

89+ where

90+ (beg, end, len, isEntire) = checkPartRange fileSize mPart mRange

91+ hs1 = addContentLength len hs0

92+ hs | isEntire = hs1

93+ | otherwise = addContentRange beg end fileSize hs1

94+ s | isEntire = s0

95+ | otherwise = H.status206

96+

97+checkPartRange :: Integer -> Maybe FilePart -> Maybe HeaderValue

98+ -> (Integer, Integer, Integer, Bool)

99+checkPartRange fileSize = checkPart

100+ where

101+ checkPart Nothing Nothing = (0, fileSize - 1, fileSize, True)

102+ checkPart Nothing (Just range) = case parseByteRanges range >>= listToMaybe of

103+ -- Range is broken

104+ Nothing -> (0, fileSize - 1, fileSize, True)

105+ Just hrange -> checkRange hrange

106+ -- Ignore Range if FilePart is specified.

107+ -- We assume that an application handled Range and specified

108+ -- FilePart.

109+ checkPart (Just part) _ = (beg, end, len, isEntire)

110+ where

111+ beg = filePartOffset part

112+ len = filePartByteCount part

113+ end = beg + len - 1

114+ isEntire = beg == 0 && len == fileSize

115+

116+ checkRange (H.ByteRangeFrom beg) = fromRange beg (fileSize - 1)

117+ checkRange (H.ByteRangeFromTo beg end) = fromRange beg (min (fileSize - 1) end)

118+ checkRange (H.ByteRangeSuffix count) = fromRange (max 0 (fileSize - count)) (fileSize - 1)

119+

120+ fromRange beg end = (beg, end, len, isEntire)

121+ where

122+ len = end - beg + 1

123+ isEntire = beg == 0 && len == fileSize

124+

48125----------------------------------------------------------------

49126

50127-- | Sending a HTTP response to 'Connection' according to 'Response'.

51128--

52−-- Applications/middlewares MUST provide a proper 'H.ResponseHeaders'.

129+-- Applications/middlewares MUST specify a proper 'H.ResponseHeaders'.

53130-- so that inconsistency does not happen.

54131-- No header is deleted by this function.

55132--

56−-- Especially, Applications/middlewares MUST provide a proper

57−-- Content-Type. They MUST NOT provide

133+-- Especially, Applications/middlewares MUST take care of

58134-- Content-Length, Content-Range, and Transfer-Encoding

59135-- because they are inserted, when necessary,

60136-- regardless they already exist.

@@ -66,6 +142,22 @@ import Network.Wai.Handler.Warp.Types

66142--

67143-- There are three basic APIs to create 'Response':

68144--

145+-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']

146+-- HTTP response body is sent by sendfile() for GET method.

147+-- HTTP response body is not sent by HEAD method.

148+-- Applications are categorized into simple and sophisticated.

149+-- Simple applications should specify 'Nothing' to

150+-- 'Maybe' 'FilePart'. The size of the specified file is obtained

151+-- by disk access. Then Range is handled.

152+-- Sophisticated applications should specify 'Just' to

153+-- 'Maybe' 'FilePart'. They should treat Range (and If-Range) by

154+-- themselves. In both cases,

155+-- Content-Length and Content-Range (if necessary) are automatically

156+-- added into the HTTP response header.

157+-- If Content-Length and Content-Range exist in the HTTP response header,

158+-- they would cause inconsistency.

159+-- Status is also changed to 206 (Partial Content) if necessary.

160+--

69161-- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']

70162-- HTTP response body is created from 'Builder'.

71163-- Transfer-Encoding: chunked is used in HTTP/1.1.

@@ -76,81 +168,45 @@ import Network.Wai.Handler.Warp.Types

76168--

77169-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']

78170-- No header is added and no Transfer-Encoding: is applied.

79−--

80−-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']

81−-- HTTP response body is sent (by sendfile(), if possible) for GET method.

82−-- HTTP response body is not sent by HEAD method.

83−-- Content-Length and Content-Range are automatically

84−-- added into the HTTP response header if necessary.

85−-- If Content-Length and Content-Range exist in the HTTP response header,

86−-- they would cause inconsistency.

87−-- \"Accept-Ranges: bytes\" is also inserted.

88−--

89−-- Applications are categorized into simple and sophisticated.

90−-- Sophisticated applications should specify 'Just' to

91−-- 'Maybe' 'FilePart'. They should treat the conditional request

92−-- by themselves. A proper 'Status' (200 or 206) must be provided.

93−--

94−-- Simple applications should specify 'Nothing' to

95−-- 'Maybe' 'FilePart'. The size of the specified file is obtained

96−-- by disk access or from the file infor cache.

97−-- If-Modified-Since, If-Unmodified-Since, If-Range and Range

98−-- are processed. Since a proper status is chosen, 'Status' is

99−-- ignored. Last-Modified is inserted.

100171

101−sendResponse :: Settings

172+sendResponse :: ByteString -- ^ default server value

102173 -> Connection

103174 -> InternalInfo

104− -> T.Handle

105175 -> Request -- ^ HTTP request.

106176 -> IndexedHeader -- ^ Indexed header of HTTP request.

107177 -> IO ByteString -- ^ source from client, for raw response

108178 -> Response -- ^ HTTP response including status code and response header.

109179 -> IO Bool -- ^ Returing True if the connection is persistent.

110−sendResponse settings conn ii th req reqidxhdr src response = do

180+sendResponse defServer conn ii req reqidxhdr src response = do

111181 hs <- addServerAndDate hs0

112182 if hasBody s then do

113− -- The response to HEAD does not have body.

114− -- But to handle the conditional requests defined RFC 7232 and

115− -- to generate appropriate content-length, content-range,

116− -- and status, the response to HEAD is processed here.

117− --

118− -- See definition of rsp below for proper body stripping.

119− (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp

120− case ms of

121− Nothing -> return ()

122− Just realStatus -> logger req realStatus mlen

183+ -- HEAD comes here even if it does not have body.

184+ sendRsp conn ver s hs rsp

123185 T.tickle th

124186 return ret

125187 else do

126− _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody

127− logger req s Nothing

188+ sendResponseNoBody conn ver s hs

128189 T.tickle th

129190 return isPersist

130191 where

131− defServer = settingsServerName settings

132− logger = settingsLogger settings

133192 ver = httpVersion req

134193 s = responseStatus response

135− hs0 = sanitizeHeaders $ responseHeaders response

194+ hs0 = responseHeaders response

136195 rspidxhdr = indexResponseHeader hs0

137− getdate = getDate ii

138− addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

196+ th = threadHandle ii

197+ dc = dateCacher ii

198+ addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

199+ mRange = reqidxhdr ! idxRange

139200 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

140− isChunked = not isHead && isChunked0

201+ isChunked = if isHead then False else isChunked0

141202 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)

142203 isHead = requestMethod req == H.methodHead

143204 rsp = case response of

144− ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)

145− ResponseBuilder _ _ b

146− | isHead -> RspNoBody

147− | otherwise -> RspBuilder b needsChunked

148− ResponseStream _ _ fb

149− | isHead -> RspNoBody

150− | otherwise -> RspStream fb needsChunked th

205+ ResponseFile _ _ path mPart -> RspFile path mPart mRange isHead (T.tickle th)

206+ ResponseBuilder _ _ b -> RspBuilder b needsChunked

207+ ResponseStream _ _ fb -> RspStream fb needsChunked th

151208 ResponseRaw raw _ -> RspRaw raw src (T.tickle th)

152− -- Make sure we don't hang on to 'response' (avoid space leak)

153− !ret = case response of

209+ ret = case response of

154210 ResponseFile {} -> isPersist

155211 ResponseBuilder {} -> isKeepAlive

156212 ResponseStream {} -> isKeepAlive

@@ -158,33 +214,7 @@ sendResponse settings conn ii th req reqidxhdr src response = do

158214

159215----------------------------------------------------------------

160216

161−sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders

162−sanitizeHeaders = map (sanitize <$>)

163− where

164− sanitize v

165− | containsNewlines v = sanitizeHeaderValue v -- slow path

166− | otherwise = v -- fast path

167−

168−{-# INLINE containsNewlines #-}

169−containsNewlines :: ByteString -> Bool

170−containsNewlines = S.any (\w -> w == _cr || w == _lf)

171−

172−{-# INLINE sanitizeHeaderValue #-}

173−sanitizeHeaderValue :: ByteString -> ByteString

174−sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of

175− [] -> ""

176− x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)

177− where

178− addSpaceIfMissing line = case C8.uncons line of

179− Nothing -> Nothing

180− Just (first, _)

181− | first == ' ' || first == '\t' -> Just line

182− | otherwise -> Just $ " " <> line

183−

184−----------------------------------------------------------------

185−

186−data Rsp = RspNoBody

187− | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ())

217+data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) Bool (IO ())

188218 | RspBuilder Builder Bool

189219 | RspStream StreamingBody Bool T.Handle

190220 | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())

@@ -192,25 +222,39 @@ data Rsp = RspNoBody

192222----------------------------------------------------------------

193223

194224sendRsp :: Connection

195− -> InternalInfo

196225 -> H.HttpVersion

197226 -> H.Status

198227 -> H.ResponseHeaders

199− -> IndexedHeader -- Response

200228 -> Rsp

201− -> IO (Maybe H.Status, Maybe Integer)

202−

203−----------------------------------------------------------------

204−

205−sendRsp conn _ ver s hs _ RspNoBody = do

206− -- Not adding Content-Length.

207− -- User agents treats it as Content-Length: 0.

208− composeHeader ver s hs >>= connSendAll conn

209− return (Just s, Nothing)

229+ -> IO ()

230+sendRsp conn ver s0 hs0 (RspFile path mPart mRange isHead hook) = do

231+ ex <- fileRange s0 hs path mPart mRange

232+ case ex of

233+ Left _ex ->

234+#ifdef WARP_DEBUG

235+ print _ex >>

236+#endif

237+ sendRsp conn ver s2 hs2 (RspBuilder body True)

238+ Right (s, hs1, beg, len)

239+ | len >= 0 ->

240+ if isHead then

241+ sendRsp conn ver s hs1 (RspBuilder mempty False)

242+ else do

243+ lheader <- composeHeader ver s hs1

244+ connSendFile conn path beg len hook [lheader]

245+ | otherwise -> do

246+ sendRsp conn ver H.status416

247+ (filter (\(k, _) -> k /= "content-length") hs1)

248+ (RspBuilder mempty True)

249+ where

250+ hs = addAcceptRanges hs0

251+ s2 = H.status404

252+ hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

253+ body = fromByteString "File not found"

210254

211255----------------------------------------------------------------

212256

213−sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

257+sendRsp conn ver s hs (RspBuilder body needsChunked) = do

214258 header <- composeHeaderBuilder ver s hs needsChunked

215259 let hdrBdy

216260 | needsChunked = header <> chunkedTransferEncoding body

@@ -219,14 +263,13 @@ sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

219263 buffer = connWriteBuffer conn

220264 size = connBufferSize conn

221265 toBufIOWith buffer size (connSendAll conn) hdrBdy

222− return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?

223266

224267----------------------------------------------------------------

225268

226−sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

269+sendRsp conn ver s hs (RspStream streamingBody needsChunked th) = do

227270 header <- composeHeaderBuilder ver s hs needsChunked

228− (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

229− $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

271+ (recv, finish) <- newBlazeRecv $ reuseBufferStrategy

272+ $ toBlazeBuffer (connWriteBuffer conn) (connBufferSize conn)

230273 let send builder = do

231274 popper <- recv builder

232275 let loop = do

@@ -243,13 +286,11 @@ sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

243286 when needsChunked $ send chunkedTransferTerminator

244287 mbs <- finish

245288 maybe (return ()) (sendFragment conn th) mbs

246− return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?

247289

248290----------------------------------------------------------------

249291

250−sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

292+sendRsp conn _ _ _ (RspRaw withApp src tickle) =

251293 withApp recv send

252− return (Nothing, Nothing)

253294 where

254295 recv = do

255296 bs <- src

@@ -259,66 +300,12 @@ sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

259300

260301----------------------------------------------------------------

261302

262−-- Sophisticated WAI applications.

263−-- We respect s0. s0 MUST be a proper value.

264−sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

265− sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook

266− where

267− beg = filePartOffset part

268− len = filePartByteCount part

269− hs = addContentHeadersForFilePart hs0 part

270−

271−----------------------------------------------------------------

272−

273−-- Simple WAI applications.

274−-- Status is ignored

275−sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do

276− efinfo <- E.try $ getFileInfo ii path

277− case efinfo of

278− Left (_ex :: E.IOException) ->

279−#ifdef WARP_DEBUG

280− print _ex >>

281−#endif

282− sendRspFile404 conn ii ver hs0 rspidxhdr

283− Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of

284− WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody

285− WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

286−

287−----------------------------------------------------------------

288−

289−sendRspFile2XX :: Connection

290− -> InternalInfo

291− -> H.HttpVersion

292− -> H.Status

293− -> H.ResponseHeaders

294− -> IndexedHeader

295− -> FilePath

296− -> Integer

297− -> Integer

298− -> Bool

299− -> IO ()

300− -> IO (Maybe H.Status, Maybe Integer)

301−sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

302− | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody

303− | otherwise = do

304− lheader <- composeHeader ver s hs

305− (mfd, fresher) <- getFd ii path

306− let fid = FileId path mfd

307− hook' = hook >> fresher

308− connSendFile conn fid beg len hook' [lheader]

309− return (Just s, Just len)

310−

311−sendRspFile404 :: Connection

312− -> InternalInfo

313− -> H.HttpVersion

314− -> H.ResponseHeaders

315− -> IndexedHeader

316− -> IO (Maybe H.Status, Maybe Integer)

317−sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)

318− where

319− s = H.notFound404

320− hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

321− body = byteString "File not found"

303+sendResponseNoBody :: Connection

304+ -> H.HttpVersion

305+ -> H.Status

306+ -> H.ResponseHeaders

307+ -> IO ()

308+sendResponseNoBody conn ver s hs = composeHeader ver s hs >>= connSendAll conn

322309

323310----------------------------------------------------------------

324311----------------------------------------------------------------

@@ -346,7 +333,7 @@ checkPersist req reqidxhdr

346333 | otherwise = checkPersist10 conn

347334 where

348335 ver = httpVersion req

349− conn = reqidxhdr ! fromEnum ReqConnection

336+ conn = reqidxhdr ! idxConnection

350337 checkPersist11 (Just x)

351338 | CI.foldCase x == "close" = False

352339 checkPersist11 _ = True

@@ -371,7 +358,7 @@ infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked)

371358 where

372359 needsChunked = isChunked && not hasLength

373360 isKeepAlive = isPersist && (isChunked || hasLength)

374− hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength

361+ hasLength = isJust $ rspidxhdr ! idxContentLength

375362

376363----------------------------------------------------------------

377364

@@ -384,13 +371,35 @@ hasBody s = sc /= 204

384371

385372----------------------------------------------------------------

386373

374+addAcceptRanges :: H.ResponseHeaders -> H.ResponseHeaders

375+addAcceptRanges hdrs = (hAcceptRanges, "bytes") : hdrs

376+

387377addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders

388−addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs

378+addTransferEncoding hdrs = (hTransferEncoding, "chunked") : hdrs

389379

390−addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders

391−addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of

380+addContentLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders

381+addContentLength cl hdrs = (H.hContentLength, len) : hdrs

382+ where

383+ len = B.pack $ show cl

384+

385+addContentRange :: Integer -> Integer -> Integer

386+ -> H.ResponseHeaders -> H.ResponseHeaders

387+addContentRange beg end total hdrs = (hContentRange, range) : hdrs

388+ where

389+ range = B.pack

390+ -- building with ShowS

391+ $ 'b' : 'y': 't' : 'e' : 's' : ' '

392+ : (if beg > end then ('*':) else

393+ (showInt beg)

394+ . ('-' :)

395+ . (showInt end))

396+ ( '/'

397+ : showInt total "")

398+

399+addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders

400+addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of

392401 Nothing -> do

393− gmtdate <- getdate

402+ gmtdate <- D.getDate dc

394403 return $ (H.hDate, gmtdate) : hdrs

395404 Just _ -> return hdrs

396405

@@ -400,13 +409,12 @@ addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of

400409warpVersion :: String

401410warpVersion = showVersion Paths_warp.version

402411

403−{-# INLINE addServer #-}

412+defaultServerValue :: HeaderValue

413+defaultServerValue = B.pack $ "Warp/" ++ warpVersion

414+

404415addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders

405−addServer "" rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of

406− Nothing -> hdrs

407− _ -> filter ((/= H.hServer) . fst) hdrs

408−addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of

409− Nothing -> (H.hServer, serverName) : hdrs

416+addServer defaultServerValue' rspidxhdr hdrs = case rspidxhdr ! idxServer of

417+ Nothing -> (hServer, defaultServerValue') : hdrs

410418 _ -> hdrs

411419

412420----------------------------------------------------------------

@@ -422,6 +430,6 @@ replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs

422430

423431composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder

424432composeHeaderBuilder ver s hs True =

425− byteString <$> composeHeader ver s (addTransferEncoding hs)

433+ fromByteString <$> composeHeader ver s (addTransferEncoding hs)

426434composeHeaderBuilder ver s hs False =

427− byteString <$> composeHeader ver s hs

435+ fromByteString <$> composeHeader ver s hs

warp/Network/Wai/Handler/Warp/ResponseHeader.hs+15−5

@@ -3,16 +3,18 @@

33

44module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where

55

6+import Control.Monad

7+import Data.ByteString (ByteString)

68import qualified Data.ByteString as S

7−import Data.ByteString.Internal (create)

9+import Data.ByteString.Internal (ByteString(..), create, memcpy)

810import qualified Data.CaseInsensitive as CI

11+import Data.List (foldl')

12+import Data.Word (Word8)

13+import Foreign.ForeignPtr

914import Foreign.Ptr

1015import GHC.Storable

1116import qualified Network.HTTP.Types as H

1217

13−import Network.Wai.Handler.Warp.Buffer (copy)

14−import Network.Wai.Handler.Warp.Imports

15−

1618----------------------------------------------------------------

1719

1820composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString

@@ -22,9 +24,15 @@ composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do

2224 void $ copyCRLF ptr2

2325 where

2426 !len = 17 + slen + foldl' fieldLength 0 responseHeaders

25− fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4

27+ fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4

2628 !slen = S.length $ H.statusMessage status

2729

30+{-# INLINE copy #-}

31+copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)

32+copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do

33+ memcpy ptr (p `plusPtr` o) (fromIntegral l)

34+ return $! ptr `plusPtr` l

35+

2836httpVer11 :: ByteString

2937httpVer11 = "HTTP/1.1 "

3038

@@ -82,3 +90,5 @@ cr :: Word8

8290cr = 13

8391lf :: Word8

8492lf = 10

93+

94+

warp/Network/Wai/Handler/Warp/Run.hs+133−249

@@ -1,97 +1,74 @@

1−{-# LANGUAGE BangPatterns #-}

21{-# LANGUAGE CPP #-}

32{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE PackageImports #-}

5−{-# LANGUAGE PatternGuards #-}

6−{-# LANGUAGE RecordWildCards #-}

73{-# LANGUAGE ScopedTypeVariables #-}

84{-# LANGUAGE TupleSections #-}

9−{-# LANGUAGE ViewPatterns #-}

105{-# OPTIONS_GHC -fno-warn-deprecations #-}

116

127module Network.Wai.Handler.Warp.Run where

138

14−import "iproute" Data.IP (toHostAddress, toHostAddress6)

159import Control.Arrow (first)

10+import Control.Concurrent (threadDelay)

1611import qualified Control.Concurrent as Conc (yield)

1712import Control.Exception as E

13+import Control.Monad (when, unless, void)

14+import Data.ByteString (ByteString)

1815import qualified Data.ByteString as S

1916import Data.Char (chr)

17+import Data.IP (toHostAddress, toHostAddress6)

2018import Data.IORef (IORef, newIORef, readIORef, writeIORef)

2119import Data.Streaming.Network (bindPortTCP)

22−import Foreign.C.Error (Errno(..), eCONNABORTED)

23−import GHC.IO.Exception (IOException(..))

24−import qualified Network.HTTP2 as H2

25−import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

26−#if MIN_VERSION_network(3,1,1)

27−import Network.Socket (gracefulClose)

28−#endif

20+import Network (sClose, Socket)

21+import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6))

2922import qualified Network.Socket.ByteString as Sock

3023import Network.Wai

31−import Network.Wai.Internal (ResponseReceived (ResponseReceived))

32−import System.Environment (lookupEnv)

33−import qualified System.TimeManager as T

34−import System.Timeout (timeout)

35−

3624import Network.Wai.Handler.Warp.Buffer

3725import Network.Wai.Handler.Warp.Counter

3826import qualified Network.Wai.Handler.Warp.Date as D

3927import qualified Network.Wai.Handler.Warp.FdCache as F

40−import qualified Network.Wai.Handler.Warp.FileInfoCache as I

41−import Network.Wai.Handler.Warp.HTTP2 (http2)

42−import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)

4328import Network.Wai.Handler.Warp.Header

44−import Network.Wai.Handler.Warp.Imports hiding (readInt)

4529import Network.Wai.Handler.Warp.ReadInt

4630import Network.Wai.Handler.Warp.Recv

4731import Network.Wai.Handler.Warp.Request

4832import Network.Wai.Handler.Warp.Response

4933import Network.Wai.Handler.Warp.SendFile

5034import Network.Wai.Handler.Warp.Settings

35+import qualified Network.Wai.Handler.Warp.Timeout as T

5136import Network.Wai.Handler.Warp.Types

52−

37+import Network.Wai.Internal (ResponseReceived (ResponseReceived))

38+import System.Environment (getEnvironment)

39+import System.IO.Error (isFullErrorType, ioeGetErrorType)

5340

5441#if WINDOWS

5542import Network.Wai.Handler.Warp.Windows

5643#else

44+import System.Posix.IO (FdOption(CloseOnExec), setFdOption)

5745import Network.Socket (fdSocket)

5846#endif

5947

60−-- | Creating 'Connection' for plain HTTP based on a given socket.

61−socketConnection :: Settings -> Socket -> IO Connection

62−#if MIN_VERSION_network(3,1,1)

63−socketConnection set s = do

64−#else

65−socketConnection _ s = do

66−#endif

48+-- | Default action value for 'Connection'.

49+socketConnection :: Socket -> IO Connection

50+socketConnection s = do

6751 bufferPool <- newBufferPool

52+ readBuf <- allocateBuffer 0 -- kept for backward compatibility

6853 writeBuf <- allocateBuffer bufferSize

69− let sendall = Sock.sendAll s

70− isH2 <- newIORef False -- HTTP/1.x

7154 return Connection {

7255 connSendMany = Sock.sendMany s

73− , connSendAll = sendall

74− , connSendFile = sendFile s writeBuf bufferSize sendall

75−#if MIN_VERSION_network(3,1,1)

76− , connClose = do

77− h2 <- readIORef isH2

78− let tm = if h2 then settingsGracefulCloseTimeout2 set

79− else settingsGracefulCloseTimeout1 set

80− if tm == 0 then

81− close s

82− else

83− gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()

84−#else

85− , connClose = close s

86−#endif

87− , connFree = freeBuffer writeBuf

56+ , connSendAll = Sock.sendAll s

57+ , connSendFile = defaultSendFile s

58+ , connClose = sClose s >> freeBuffer writeBuf

8859 , connRecv = receive s bufferPool

89− , connRecvBuf = receiveBuf s

60+ , connBufferPool = bufferPool

61+ , connReadBuffer = readBuf

9062 , connWriteBuffer = writeBuf

9163 , connBufferSize = bufferSize

92− , connHTTP2 = isH2

64+ , connSendFileOverride = Override s

9365 }

9466

67+#if __GLASGOW_HASKELL__ < 702

68+allowInterrupt :: IO ()

69+allowInterrupt = unblock $ return ()

70+#endif

71+

9572-- | Run an 'Application' on the given port.

9673-- This calls 'runSettings' with 'defaultSettings'.

9774run :: Port -> Application -> IO ()

@@ -104,7 +81,7 @@ run p = runSettings defaultSettings { settingsPort = p }

10481-- Since 3.0.9

10582runEnv :: Port -> Application -> IO ()

10683runEnv p app = do

107− mp <- lookupEnv "PORT"

84+ mp <- fmap (lookup "PORT") getEnvironment

10885

10986 maybe (run p app) runReadPort mp

11087

@@ -121,7 +98,7 @@ runSettings :: Settings -> Application -> IO ()

12198runSettings set app = withSocketsDo $

12299 bracket

123100 (bindPortTCP (settingsPort set) (settingsHost set))

124− close

101+ sClose

125102 (\socket -> do

126103 setSocketCloseOnExec socket

127104 runSettingsSocket set socket app)

@@ -149,12 +126,10 @@ runSettingsSocket set socket app = do

149126 (s, sa) <- accept socket

150127#endif

151128 setSocketCloseOnExec s

152− -- NoDelay causes an error for AF_UNIX.

153− setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()

154− conn <- socketConnection set s

129+ conn <- socketConnection s

155130 return (conn, sa)

156131

157− closeListenSocket = close socket

132+ closeListenSocket = sClose socket

158133

159134-- | The connection setup action would be expensive. A good example

160135-- is initialization of TLS.

@@ -176,9 +151,9 @@ runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMa

176151-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.

177152runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()

178153runSettingsConnectionMaker x y =

179− runSettingsConnectionMakerSecure x (toTCP <$> y)

154+ runSettingsConnectionMakerSecure x (go y)

180155 where

181− toTCP = first ((, TCP) <$>)

156+ go = fmap (first (fmap (, TCP)))

182157

183158----------------------------------------------------------------

184159

@@ -192,26 +167,25 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),

192167runSettingsConnectionMakerSecure set getConnMaker app = do

193168 settingsBeforeMainLoop set

194169 counter <- newCounter

195− withII $ acceptConnection set getConnMaker app counter

170+

171+ D.withDateCache $ \dc ->

172+ F.withFdCache fdCacheDurationInSeconds $ \fc ->

173+ withTimeoutManager $ \tm ->

174+ acceptConnection set getConnMaker app dc fc tm counter

196175 where

197− withII action =

198− withTimeoutManager $ \tm ->

199− D.withDateCache $ \dc ->

200− F.withFdCache fdCacheDurationInSeconds $ \fdc ->

201− I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

202− let ii = InternalInfo tm dc fdc fic

203− action ii

204−

205− !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

206− !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

207− !timeoutInSeconds = settingsTimeout set * 1000000

176+ fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

208177 withTimeoutManager f = case settingsManager set of

209178 Just tm -> f tm

210179 Nothing -> bracket

211− (T.initialize timeoutInSeconds)

180+ (T.initialize $ settingsTimeout set * 1000000)

212181 T.stopManager

213182 f

214183

184+onE :: Settings -> Maybe Request -> SomeException -> IO ()

185+onE set mreq e = case fromException e of

186+ Just (NotEnoughLines []) -> return ()

187+ _ -> settingsOnException set mreq e

188+

215189-- Note that there is a thorough discussion of the exception safety of the

216190-- following code at: https://github.com/yesodweb/wai/issues/146

217191--

@@ -228,20 +202,17 @@ runSettingsConnectionMakerSecure set getConnMaker app = do

228202acceptConnection :: Settings

229203 -> IO (IO (Connection, Transport), SockAddr)

230204 -> Application

205+ -> D.DateCache

206+ -> Maybe F.MutableFdCache

207+ -> T.Manager

231208 -> Counter

232− -> InternalInfo

233209 -> IO ()

234−acceptConnection set getConnMaker app counter ii = do

210+acceptConnection set getConnMaker app dc fc tm counter = do

235211 -- First mask all exceptions in acceptLoop. This is necessary to

236212 -- ensure that no async exception is throw between the call to

237213 -- acceptNewConnection and the registering of connClose.

238− --

239− -- acceptLoop can be broken by closing the listing socket.

240− void $ mask_ acceptLoop

241− -- In some cases, we want to stop Warp here without graceful shutdown.

242− -- So, async exceptions are allowed here.

243− -- That's why `finally` is not used.

244− gracefulShutdown set counter

214+ void $ mask_ $ acceptLoop

215+ gracefulShutdown counter

245216 where

246217 acceptLoop = do

247218 -- Allow async exceptions before receiving the next connection maker.

@@ -258,21 +229,24 @@ acceptConnection set getConnMaker app counter ii = do

258229 case mx of

259230 Nothing -> return ()

260231 Just (mkConn, addr) -> do

261− fork set mkConn addr app counter ii

232+ fork set mkConn addr app dc fc tm counter

262233 acceptLoop

263234

264235 acceptNewConnection = do

265236 ex <- try getConnMaker

266237 case ex of

267238 Right x -> return $ Just x

268− Left e -> do

269− let eConnAborted = getErrno eCONNABORTED

270− getErrno (Errno cInt) = cInt

271− if ioe_errno e == Just eConnAborted

272− then acceptNewConnection

273− else do

274− settingsOnException set Nothing $ toException e

275− return Nothing

239+ Left e -> do

240+ onE set Nothing $ toException e

241+ if isFullErrorType (ioeGetErrorType e) then do

242+ -- "resource exhausted (Too many open files)" may

243+ -- happen by accept(). Wait a second hoping that

244+ -- resource will be available.

245+ threadDelay 1000000

246+ acceptNewConnection

247+ else

248+ -- Assuming the listen socket is closed.

249+ return Nothing

276250

277251-- Fork a new worker thread for this connection maker, and ask for a

278252-- function to unmask (i.e., allow async exceptions to be thrown).

@@ -280,97 +254,64 @@ fork :: Settings

280254 -> IO (Connection, Transport)

281255 -> SockAddr

282256 -> Application

257+ -> D.DateCache

258+ -> Maybe F.MutableFdCache

259+ -> T.Manager

283260 -> Counter

284− -> InternalInfo

285261 -> IO ()

286−fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

287− -- Call the user-supplied on exception code if any

288− -- exceptions are thrown.

289− handle (settingsOnException set Nothing) $

290− -- Run the connection maker to get a new connection, and ensure

291− -- that the connection is closed. If the mkConn call throws an

292− -- exception, we will leak the connection. If the mkConn call is

293− -- vulnerable to attacks (e.g., Slowloris), we do nothing to

294− -- protect the server. It is therefore vital that mkConn is well

295− -- vetted.

296− --

297− -- We grab the connection before registering timeouts since the

298− -- timeouts will be useless during connection creation, due to the

299− -- fact that async exceptions are still masked.

300− bracket mkConn cleanUp (serve unmask)

301− where

302− cleanUp (conn, _) = connClose conn `finally` connFree conn

262+fork set mkConn addr app dc fc tm counter = settingsFork set $ \ unmask ->

263+ -- Run the connection maker to get a new connection, and ensure

264+ -- that the connection is closed. If the mkConn call throws an

265+ -- exception, we will leak the connection. If the mkConn call is

266+ -- vulnerable to attacks (e.g., Slowloris), we do nothing to

267+ -- protect the server. It is therefore vital that mkConn is well

268+ -- vetted.

269+ --

270+ -- We grab the connection before registering timeouts since the

271+ -- timeouts will be useless during connection creation, due to the

272+ -- fact that async exceptions are still masked.

273+ bracket mkConn closeConn $ \(conn0, transport) ->

303274

304275 -- We need to register a timeout handler for this thread, and

305276 -- cancel that handler as soon as we exit.

306− serve unmask (conn, transport) = bracket register cancel $ \th -> do

307− -- We now have fully registered a connection close handler in

308− -- the case of all exceptions, so it is safe to once again

309− -- allow async exceptions.

310− unmask .

311− -- Call the user-supplied code for connection open and

312− -- close events

313− bracket (onOpen addr) (onClose addr) $ \goingon ->

314− -- Actually serve this connection. bracket with closeConn

315− -- above ensures the connection is closed.

316− when goingon $ serveConnection conn ii th addr transport set app

317− where

318− register = T.registerKillThread (timeoutManager ii) (connClose conn)

319− cancel = T.cancel

277+ bracket (T.registerKillThread tm) T.cancel $ \th ->

278+

279+ let ii = InternalInfo th fc dc

280+ conn = setSendFile conn0 fc

281+ -- We now have fully registered a connection close handler

282+ -- in the case of all exceptions, so it is safe to one

283+ -- again allow async exceptions.

284+ in unmask .

285+ -- Call the user-supplied on exception code if any

286+ -- exceptions are thrown.

287+ handle (onE set Nothing) .

288+

289+ -- Call the user-supplied code for connection open and close events

290+ bracket (onOpen addr) (onClose addr) $ \goingon ->

291+

292+ -- Actually serve this connection.

293+ -- bracket with closeConn above ensures the connection is closed.

294+ when goingon $ serveConnection conn ii addr transport set app

295+ where

296+ closeConn (conn, _transport) = connClose conn

320297

321298 onOpen adr = increase counter >> settingsOnOpen set adr

322299 onClose adr _ = decrease counter >> settingsOnClose set adr

323300

324301serveConnection :: Connection

325302 -> InternalInfo

326− -> T.Handle

327303 -> SockAddr

328304 -> Transport

329305 -> Settings

330306 -> Application

331307 -> IO ()

332−serveConnection conn ii th origAddr transport settings app = do

333− -- fixme: Upgrading to HTTP/2 should be supported.

334− (h2,bs) <- if isHTTP2 transport then

335− return (True, "")

336− else do

337− bs0 <- connRecv conn

338− if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0 then

339− return (True, bs0)

340− else

341− return (False, bs0)

308+serveConnection conn ii origAddr transport settings app = do

342309 istatus <- newIORef False

343− if settingsHTTP2Enabled settings && h2 then do

344− rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

345− -- This thread becomes the sender in http2 library.

346− -- In the case of event source, one request comes and one

347− -- worker gets busy. But it is likely that the receiver does

348− -- not receive any data at all while the sender is sending

349− -- output data from the worker. It's not good enough to tickle

350− -- the time handler in the receiver only. So, we should tickle

351− -- the time handler in both the receiver and the sender.

352− let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

353− sendBS x = connSendAll conn x >> T.tickle th

354− -- fixme: origAddr

355− checkTLS

356− setConnHTTP2 conn True

357− http2 conn transport ii origAddr settings recvN sendBS app

358− else do

359− src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

360− writeIORef istatus True

361− leftoverSource src bs

362− addr <- getProxyProtocolAddr src

363− http1 True addr istatus src `E.catch` \e ->

364− case () of

365− ()

366− -- See comment below referencing

367− -- https://github.com/yesodweb/wai/issues/618

368− | Just NoKeepAliveRequest <- fromException e -> return ()

369− -- No valid request

370− | Just (BadFirstLine _) <- fromException e -> return ()

371− | otherwise -> do

372− _ <- sendErrorResponse (dummyreq addr) istatus e

373− throwIO e

310+ src <- mkSource (connSource conn th istatus)

311+ addr <- getProxyProtocolAddr src

312+ http1 addr istatus src `E.catch` \e -> do

313+ sendErrorResponse addr istatus e

314+ throwIO (e :: SomeException)

374315

375316 where

376317 getProxyProtocolAddr src =

@@ -413,38 +354,30 @@ serveConnection conn ii th origAddr transport settings app = do

413354

414355 decodeAscii = map (chr . fromEnum) . S.unpack

415356

416− shouldSendErrorResponse se

417− | Just ConnectionClosedByPeer <- fromException se = False

418− | otherwise = True

357+ th = threadHandle ii

419358

420− sendErrorResponse req istatus e = do

359+ sendErrorResponse addr istatus e = do

421360 status <- readIORef istatus

422− if shouldSendErrorResponse e && status

423− then do

424− sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

425− else return False

361+ when status $ void $

362+ sendResponse

363+ (settingsServerName settings)

364+ conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)

426365

427366 dummyreq addr = defaultRequest { remoteHost = addr }

428367

429368 errorResponse e = settingsOnExceptionResponse settings e

430369

431− http1 firstRequest addr istatus src = do

432− (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport

370+ http1 addr istatus src = do

371+ (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest settings conn ii addr src

372+ let req = req' { isSecure = isTransportSecure transport }

433373 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

434374 `E.catch` \e -> do

435− settingsOnException settings (Just req) e

436− -- Don't throw the error again to prevent calling settingsOnException twice.

375+ -- Call the user-supplied exception handlers, passing the request.

376+ sendErrorResponse addr istatus e

377+ onE settings (Just req) e

378+ -- Don't throw the error again to prevent calling onE twice.

437379 return False

438−

439− -- When doing a keep-alive connection, the other side may just

440− -- close the connection. We don't want to treat that as an

441− -- exceptional situation, so we pass in False to http1 (which

442− -- in turn passes in False to recvRequest), indicating that

443− -- this is not the first request. If, when trying to read the

444− -- request headers, no data is available, recvRequest will

445− -- throw a NoKeepAliveRequest exception, which we catch here

446− -- and ignore. See: https://github.com/yesodweb/wai/issues/618

447− when keepAlive $ http1 False addr istatus src

380+ when keepAlive $ http1 addr istatus src

448381

449382 processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

450383 -- Let the application run for as long as it wants

@@ -454,38 +387,32 @@ serveConnection conn ii th origAddr transport settings app = do

454387 -- creating the request, we need to make sure that we don't get

455388 -- an async exception before calling the ResponseSource.

456389 keepAliveRef <- newIORef $ error "keepAliveRef not filled"

457− r <- E.try $ app req $ \res -> do

390+ _ <- app req $ \res -> do

458391 T.resume th

459392 -- FIXME consider forcing evaluation of the res here to

460393 -- send more meaningful error messages to the user.

461394 -- However, it may affect performance.

462395 writeIORef istatus False

463− keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

396+ keepAlive <- sendResponse

397+ (settingsServerName settings)

398+ conn ii req idxhdr (readSource src) res

464399 writeIORef keepAliveRef keepAlive

465400 return ResponseReceived

466− case r of

467− Right ResponseReceived -> return ()

468− Left e@(SomeException _)

469− | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'

470− | otherwise -> do

471− keepAlive <- sendErrorResponse req istatus e

472− settingsOnException settings (Just req) e

473− writeIORef keepAliveRef keepAlive

474−

475401 keepAlive <- readIORef keepAliveRef

476402

477403 -- We just send a Response and it takes a time to

478404 -- receive a Request again. If we immediately call recv,

479− -- it is likely to fail and cause the IO manager to do some work.

480− -- It is very costly, so we yield to another Haskell

405+ -- it is likely to fail and the IO manager works.

406+ -- It is very costly. So, we yield to another Haskell

481407 -- thread hoping that the next Request will arrive

482408 -- when this Haskell thread will be re-scheduled.

483409 -- This improves performance at least when

484410 -- the number of cores is small.

485411 Conc.yield

486412

487− if keepAlive

488− then

413+ if not keepAlive then

414+ return False

415+ else do

489416 -- If there is an unknown or large amount of data to still be read

490417 -- from the request body, simple drop this connection instead of

491418 -- reading it all in to satisfy a keep-alive request.

@@ -511,21 +438,6 @@ serveConnection conn ii th origAddr transport settings app = do

511438 else

512439 return False

513440 Nothing -> tryKeepAlive

514− else

515− return False

516−

517− checkTLS = case transport of

518− TCP -> return () -- direct

519− tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"

520− tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

521−

522−-- connClose must not be called here since Run:fork calls it

523−goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()

524−goaway Connection{..} etype debugmsg = connSendAll bytestream

525− where

526− einfo = H2.encodeInfo id 0

527− frame = H2.GoAwayFrame 0 etype debugmsg

528− bytestream = H2.encodeFrame einfo frame

529441

530442flushEntireBody :: IO ByteString -> IO ()

531443flushEntireBody src =

@@ -550,50 +462,22 @@ flushBody src =

550462 | toRead' >= 0 -> loop toRead'

551463 | otherwise -> return False

552464

553−wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString

554−wrappedRecv Connection { connRecv = recv } th istatus slowlorisSize = do

465+connSource :: Connection -> T.Handle -> IORef Bool -> IO ByteString

466+connSource Connection { connRecv = recv } th istatus = do

555467 bs <- recv

556468 unless (S.null bs) $ do

557469 writeIORef istatus True

558− when (S.length bs >= slowlorisSize) $ T.tickle th

470+ when (S.length bs >= 2048) $ T.tickle th

559471 return bs

560472

561−wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)

562−wrappedRecvN th istatus slowlorisSize readN bufsize = do

563− bs <- readN bufsize

564− unless (S.null bs) $ do

565− writeIORef istatus True

566− -- TODO: think about the slowloris protection in HTTP2: current code

567− -- might open a slow-loris attack vector. Rather than timing we should

568− -- consider limiting the per-client connections assuming that in HTTP2

569− -- we should allow only few connections per host (real-world

570− -- deployments with large NATs may be trickier).

571− when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th

572− return bs

573−

574−-- | Set flag FileCloseOnExec flag on a socket (on Unix)

575−--

576473-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs

577−--

578−-- @since 3.2.17

579474setSocketCloseOnExec :: Socket -> IO ()

580475#if WINDOWS

581476setSocketCloseOnExec _ = return ()

582477#else

583−setSocketCloseOnExec socket = do

584−#if MIN_VERSION_network(3,0,0)

585− fd <- fdSocket socket

586−#else

587− let fd = fdSocket socket

588−#endif

589− F.setFileCloseOnExec $ fromIntegral fd

478+setSocketCloseOnExec socket =

479+ setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True

590480#endif

591481

592−gracefulShutdown :: Settings -> Counter -> IO ()

593−gracefulShutdown set counter =

594− case settingsGracefulShutdownTimeout set of

595− Nothing ->

596− waitForZero counter

597− (Just seconds) ->

598− void (timeout (seconds * microsPerSecond) (waitForZero counter))

599− where microsPerSecond = 1000000

482+gracefulShutdown :: Counter -> IO ()

483+gracefulShutdown counter = waitForZero counter

warp/Network/Wai/Handler/Warp/SendFile.hs+19−139

@@ -1,149 +1,29 @@

1−{-# LANGUAGE CPP, ForeignFunctionInterface #-}

1+{-# LANGUAGE CPP #-}

22

3−module Network.Wai.Handler.Warp.SendFile (

4− sendFile

5− , readSendFile

6− , packHeader -- for testing

7−#ifndef WINDOWS

8− , positionRead

9−#endif

10− ) where

11−

12−import qualified Data.ByteString as BS

13−import Network.Socket (Socket)

3+module Network.Wai.Handler.Warp.SendFile where

144

15−#ifdef WINDOWS

16−import Foreign.ForeignPtr (newForeignPtr_)

17−import Foreign.Ptr (plusPtr)

18−import qualified System.IO as IO

19−#else

20−import Control.Exception

21−import Foreign.C.Error (throwErrno)

22−import Foreign.C.Types

23−import Foreign.Ptr (Ptr, castPtr, plusPtr)

5+import Data.ByteString (ByteString)

246import Network.Sendfile

25−import Network.Wai.Handler.Warp.FdCache (openFile, closeFile)

26−import System.Posix.Types

27−#endif

28−

29−import Network.Wai.Handler.Warp.Buffer

30−import Network.Wai.Handler.Warp.Imports

7+import Network.Socket (Socket)

8+import qualified Network.Wai.Handler.Warp.FdCache as F

319import Network.Wai.Handler.Warp.Types

3210

33−----------------------------------------------------------------

11+defaultSendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO ()

12+defaultSendFile s path off len act hdr = sendfileWithHeader s path (PartOfFile off len) act hdr

3413

35−-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.

36−-- This makes use of the file descriptor cache.

37−-- For other OSes, this is identical to 'readSendFile'.

38−--

39−-- Since: 3.1.0

40−sendFile :: Socket -> Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile

41−#ifdef SENDFILEFD

42−sendFile s _ _ _ fid off len act hdr = case mfid of

43− -- settingsFdCacheDuration is 0

44− Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr

45− Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr

46− where

47− mfid = fileIdFd fid

48− path = fileIdPath fid

49−#else

50−sendFile _ = readSendFile

51−#endif

52−

53−----------------------------------------------------------------

5414

55−packHeader :: Buffer -> BufSize -> (ByteString -> IO ())

56− -> IO () -> [ByteString]

57− -> Int

58− -> IO Int

59−packHeader _ _ _ _ [] n = return n

60−packHeader buf siz send hook (bs:bss) n

61− | len < room = do

62− let dst = buf `plusPtr` n

63− void $ copy dst bs

64− packHeader buf siz send hook bss (n + len)

65− | otherwise = do

66− let dst = buf `plusPtr` n

67− (bs1, bs2) = BS.splitAt room bs

68− void $ copy dst bs1

69− bufferIO buf siz send

70− hook

71− packHeader buf siz send hook (bs2:bss) 0

72− where

73− len = BS.length bs

74− room = siz - n

15+#if SENDFILEFD

16+setSendFile :: Connection -> Maybe F.MutableFdCache -> Connection

17+setSendFile conn Nothing = conn

18+setSendFile conn (Just fdcs) = case connSendFileOverride conn of

19+ NotOverride -> conn

20+ Override s -> conn { connSendFile = sendFile fdcs s }

7521

76−mini :: Int -> Integer -> Int

77−mini i n

78− | fromIntegral i < n = i

79− | otherwise = fromIntegral n

80−

81−-- | Function to send a file based on pread()\/send() for Unix.

82−-- This makes use of the file descriptor cache.

83−-- For Windows, this is emulated by 'Handle'.

84−--

85−-- Since: 3.1.0

86−#ifdef WINDOWS

87−readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile

88−readSendFile buf siz send fid off0 len0 hook headers = do

89− hn <- packHeader buf siz send hook headers 0

90− let room = siz - hn

91− buf' = buf `plusPtr` hn

92− IO.withBinaryFile path IO.ReadMode $ \h -> do

93− IO.hSeek h IO.AbsoluteSeek off0

94− n <- IO.hGetBufSome h buf' (mini room len0)

95− bufferIO buf (hn + n) send

96− hook

97− let n' = fromIntegral n

98− fptr <- newForeignPtr_ buf

99− loop h fptr (len0 - n')

100− where

101− path = fileIdPath fid

102− loop h fptr len

103− | len <= 0 = return ()

104− | otherwise = do

105− n <- IO.hGetBufSome h buf (mini siz len)

106− when (n /= 0) $ do

107− let bs = PS fptr 0 n

108− n' = fromIntegral n

109− send bs

110− hook

111− loop h fptr (len - n')

22+sendFile :: F.MutableFdCache -> Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO ()

23+sendFile fdcs s path off len act hdr = do

24+ (fd, fresher) <- F.getFd fdcs path

25+ sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr

11226#else

113−readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile

114−readSendFile buf siz send fid off0 len0 hook headers =

115− bracket setup teardown $ \fd -> do

116− hn <- packHeader buf siz send hook headers 0

117− let room = siz - hn

118− buf' = buf `plusPtr` hn

119− n <- positionRead fd buf' (mini room len0) off0

120− bufferIO buf (hn + n) send

121− hook

122− let n' = fromIntegral n

123− loop fd (len0 - n') (off0 + n')

124− where

125− path = fileIdPath fid

126− setup = case fileIdFd fid of

127− Just fd -> return fd

128− Nothing -> openFile path

129− teardown fd = case fileIdFd fid of

130− Just _ -> return ()

131− Nothing -> closeFile fd

132− loop fd len off

133− | len <= 0 = return ()

134− | otherwise = do

135− n <- positionRead fd buf (mini siz len) off

136− bufferIO buf n send

137− let n' = fromIntegral n

138− hook

139− loop fd (len - n') (off + n')

140−

141−positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int

142−positionRead fd buf siz off = do

143− bytes <- fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)

144− when (bytes < 0) $ throwErrno "positionRead"

145− return bytes

146−

147−foreign import ccall unsafe "pread"

148− c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize

27+setSendFile :: Connection -> Maybe F.MutableFdCache -> Connection

28+setSendFile conn _ = conn

14929#endif

warp/Network/Wai/Handler/Warp/Settings.hs+36−110

@@ -1,30 +1,29 @@

11{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}

22{-# LANGUAGE PatternGuards, RankNTypes #-}

3−{-# LANGUAGE ImpredicativeTypes, CPP #-}

3+{-# LANGUAGE ImpredicativeTypes #-}

44

55module Network.Wai.Handler.Warp.Settings where

66

7−import Control.Concurrent (forkIOWithUnmask)

87import Control.Exception

9−import Data.ByteString.Builder (byteString)

10−import qualified Data.ByteString.Char8 as C8

11−import Data.ByteString.Lazy (fromStrict)

12−import Data.Streaming.Network (HostPreference)

8+import Control.Monad (when, void)

9+import Control.Concurrent (forkIOWithUnmask)

1310import qualified Data.Text as T

1411import qualified Data.Text.IO as TIO

15−import Data.Version (showVersion)

12+import Data.Streaming.Network (HostPreference)

1613import GHC.IO.Exception (IOErrorType(..))

1714import qualified Network.HTTP.Types as H

18−import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )

1915import Network.Socket (SockAddr)

2016import Network.Wai

21−import qualified Paths_warp

17+import Network.Wai.Handler.Warp.Timeout

18+import Network.Wai.Handler.Warp.Types

2219import System.IO (stderr)

2320import System.IO.Error (ioeGetErrorType)

24−import System.TimeManager

25−

26−import Network.Wai.Handler.Warp.Imports

27−import Network.Wai.Handler.Warp.Types

21+import qualified Data.Text.Lazy as TL

22+import qualified Data.Text.Lazy.Encoding as TLE

23+import Data.ByteString (ByteString)

24+import qualified Data.ByteString.Char8 as S8

25+import Data.Version (showVersion)

26+import qualified Paths_warp

2827

2928-- | Various Warp server settings. This is purposely kept as an abstract data

3029-- type so that new settings can be added without breaking backwards

@@ -33,7 +32,7 @@ import Network.Wai.Handler.Warp.Types

3332--

3433-- > setTimeout 20 defaultSettings

3534data Settings = Settings

36− { settingsPort :: Port -- ^ Port to listen on. Default value: 3000

35+ { settingsPort :: Int -- ^ Port to listen on. Default value: 3000

3736 , settingsHost :: HostPreference -- ^ Default value: HostIPv4

3837 , settingsOnException :: Maybe Request -> 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.

3938 , settingsOnExceptionResponse :: SomeException -> Response

@@ -47,7 +46,6 @@ data Settings = Settings

4746 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30

4847 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'

4948 , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0

50− , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0

5149 , settingsBeforeMainLoop :: IO ()

5250 -- ^ Code to run after the listening socket is ready but before entering

5351 -- the main event loop. Useful for signaling to tests that they can start

@@ -76,13 +74,6 @@ data Settings = Settings

7674 --

7775 -- Since 2.0.3

7876 , settingsInstallShutdownHandler :: IO () -> IO ()

79− -- ^ An action to install a handler (e.g. Unix signal handler)

80− -- to close a listen socket.

81− -- The first argument is an action to close the listen socket.

82− --

83− -- Default: no action

84− --

85− -- Since 3.0.1

8677 , settingsServerName :: ByteString

8778 -- ^ Default server name if application does not set one.

8879 --

@@ -94,44 +85,7 @@ data Settings = Settings

9485 , settingsProxyProtocol :: ProxyProtocol

9586 -- ^ Specify usage of the PROXY protocol.

9687 --

97− -- Since 3.0.5

98− , settingsSlowlorisSize :: Int

99− -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048

100− --

101− -- Since 3.1.2

102− , settingsHTTP2Enabled :: Bool

103− -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

104− --

105− -- Since 3.1.7

106− , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

107− -- ^ A log function. Default: no action.

108− --

109− -- Since 3.1.10

110− , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()

111− -- ^ A HTTP/2 server push log function. Default: no action.

112− --

113− -- Since 3.2.7

114− , settingsGracefulShutdownTimeout :: Maybe Int

115− -- ^ An optional timeout to limit the time (in seconds) waiting for

116− -- a graceful shutdown of the web server.

117− --

118− -- Since 3.2.8

119− , settingsGracefulCloseTimeout1 :: Int

120− -- ^ A timeout to limit the time (in milliseconds) waiting for

121− -- FIN for HTTP/1.x. 0 means uses immediate close.

122− -- Default: 0.

123− --

124− -- Since 3.3.5

125− , settingsGracefulCloseTimeout2 :: Int

126− -- ^ A timeout to limit the time (in milliseconds) waiting for

127− -- FIN for HTTP/2. 0 means uses immediate close.

128− -- Default: 2000.

129− --

130− -- Since 3.3.5

131− , settingsMaxTotalHeaderLength :: Int

132− -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.

133− --

134− -- Since 3.3.8

88+ -- Since 3.0.5.

13589 }

13690

13791-- | Specify usage of the PROXY protocol.

@@ -148,32 +102,23 @@ defaultSettings :: Settings

148102defaultSettings = Settings

149103 { settingsPort = 3000

150104 , settingsHost = "*4"

151− , settingsOnException = defaultOnException

152− , settingsOnExceptionResponse = defaultOnExceptionResponse

105+ , settingsOnException = defaultExceptionHandler

106+ , settingsOnExceptionResponse = defaultExceptionResponse

153107 , settingsOnOpen = const $ return True

154108 , settingsOnClose = const $ return ()

155109 , settingsTimeout = 30

156110 , settingsManager = Nothing

157111 , settingsFdCacheDuration = 0

158− , settingsFileInfoCacheDuration = 0

159112 , settingsBeforeMainLoop = return ()

160113 , settingsFork = void . forkIOWithUnmask

161114 , settingsNoParsePath = False

162115 , settingsInstallShutdownHandler = const $ return ()

163− , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version

116+ , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version

164117 , settingsMaximumBodyFlush = Just 8192

165118 , settingsProxyProtocol = ProxyProtocolNone

166− , settingsSlowlorisSize = 2048

167− , settingsHTTP2Enabled = True

168− , settingsLogger = \_ _ _ -> return ()

169− , settingsServerPushLogger = \_ _ _ -> return ()

170− , settingsGracefulShutdownTimeout = Nothing

171− , settingsGracefulCloseTimeout1 = 0

172− , settingsGracefulCloseTimeout2 = 2000

173− , settingsMaxTotalHeaderLength = 50 * 1024

174119 }

175120

176−-- | Apply the logic provided by 'defaultOnException' to determine if an

121+-- | Apply the logic provided by 'defaultExceptionHandler' to determine if an

177122-- exception should be shown or not. The goal is to hide exceptions which occur

178123-- under the normal course of the web server running.

179124--

@@ -187,45 +132,26 @@ defaultShouldDisplayException se

187132 | Just TimeoutThread <- fromException se = False

188133 | otherwise = True

189134

190−-- | Printing an exception to standard error

191−-- if `defaultShouldDisplayException` returns `True`.

192−--

193−-- Since: 3.1.0

194−defaultOnException :: Maybe Request -> SomeException -> IO ()

195−defaultOnException _ e =

135+defaultExceptionHandler :: Maybe Request -> SomeException -> IO ()

136+defaultExceptionHandler _ e =

196137 when (defaultShouldDisplayException e)

197138 $ TIO.hPutStrLn stderr $ T.pack $ show e

198139

199−-- | Sending 400 for bad requests.

200−-- Sending 500 for internal server errors.

201−-- Since: 3.1.0

202−-- Sending 413 for too large payload.

203−-- Sending 431 for too large headers.

204−-- Since 3.2.27

205−defaultOnExceptionResponse :: SomeException -> Response

206−defaultOnExceptionResponse e

207− | Just (_ :: InvalidRequest) <-

208− fromException e = responseLBS H.badRequest400

209− [(H.hContentType, "text/plain; charset=utf-8")]

210− "Bad Request"

211− | Just (ConnectionError (UnknownErrorCode 413) t) <-

212− fromException e = responseLBS H.status413

213− [(H.hContentType, "text/plain; charset=utf-8")]

214− (fromStrict t)

215− | Just (ConnectionError (UnknownErrorCode 431) t) <-

216− fromException e = responseLBS H.status431

217− [(H.hContentType, "text/plain; charset=utf-8")]

218− (fromStrict t)

219− | otherwise = responseLBS H.internalServerError500

220− [(H.hContentType, "text/plain; charset=utf-8")]

221− "Something went wrong"

140+defaultExceptionResponse :: SomeException -> Response

141+defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"

222142

223−-- | Exception handler for the debugging purpose.

224−-- 500, text/plain, a showed exception.

225−--

226−-- Since: 2.0.3.2

143+-- | Default implementation of 'settingsOnExceptionResponse' for the debugging purpose. 500, text/plain, a showed exception.

227144exceptionResponseForDebug :: SomeException -> Response

228−exceptionResponseForDebug e =

229− responseBuilder H.internalServerError500

230− [(H.hContentType, "text/plain; charset=utf-8")]

231− $ byteString . C8.pack $ "Exception: " ++ show e

145+exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] (TLE.encodeUtf8 $ TL.pack $ "Exception: " ++ show e)

146+

147+{-# DEPRECATED settingsPort "Use setPort instead" #-}

148+{-# DEPRECATED settingsHost "Use setHost instead" #-}

149+{-# DEPRECATED settingsOnException "Use setOnException instead" #-}

150+{-# DEPRECATED settingsOnExceptionResponse "Use setOnExceptionResponse instead" #-}

151+{-# DEPRECATED settingsOnOpen "Use setOnOpen instead" #-}

152+{-# DEPRECATED settingsOnClose "Use setOnClose instead" #-}

153+{-# DEPRECATED settingsTimeout "Use setTimeout instead" #-}

154+{-# DEPRECATED settingsManager "Use setManager instead" #-}

155+{-# DEPRECATED settingsFdCacheDuration "Use setFdCacheDuration instead" #-}

156+{-# DEPRECATED settingsBeforeMainLoop "Use setBeforeMainLoop instead" #-}

157+{-# DEPRECATED settingsNoParsePath "Use setNoParsePath instead" #-}

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

@@ -1,33 +1,66 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DeriveDataTypeable #-}

2−

3−module System.TimeManager (

4− -- ** Types

3+{-# LANGUAGE MagicHash #-}

4+{-# LANGUAGE UnboxedTuples #-} -- for GHC 7.4 or earlier

5+

6+-- |

7+--

8+-- In order to provide slowloris protection, Warp provides timeout handlers. We

9+-- follow these rules:

10+--

11+-- * A timeout is created when a connection is opened.

12+--

13+-- * When all request headers are read, the timeout is tickled.

14+--

15+-- * Every time at least 2048 bytes of the request body are read, the timeout

16+-- is tickled.

17+--

18+-- * The timeout is paused while executing user code. This will apply to both

19+-- the application itself, and a ResponseSource response. The timeout is

20+-- resumed as soon as we return from user code.

21+--

22+-- * Every time data is successfully sent to the client, the timeout is tickled.

23+

24+module Network.Wai.Handler.Warp.Timeout (

25+ -- * Types

526 Manager

627 , TimeoutAction

728 , Handle

8− -- ** Manager

29+ -- * Manager

930 , initialize

1031 , stopManager

11− , killManager

1232 , withManager

13− -- ** Registration

33+ -- * Registration

1434 , register

1535 , registerKillThread

16− -- ** Control

36+ -- * Control

1737 , tickle

1838 , cancel

1939 , pause

2040 , resume

21− -- ** Exceptions

41+ -- * Exceptions

2242 , TimeoutThread (..)

2343 ) where

2444

45+#ifndef MIN_VERSION_base

46+#define MIN_VERSION_base(x,y,z) 1

47+#endif

48+

49+#if MIN_VERSION_base(4,6,0)

50+import Control.Concurrent (mkWeakThreadId, ThreadId)

51+#else

52+import GHC.Conc (ThreadId(..))

53+import GHC.Exts (mkWeak#)

54+import GHC.IO (IO (IO))

55+#endif

2556import Control.Concurrent (myThreadId)

2657import qualified Control.Exception as E

27−import Control.Reaper

58+import GHC.Weak (Weak (..))

59+import Network.Wai.Handler.Warp.IORef (IORef)

60+import qualified Network.Wai.Handler.Warp.IORef as I

61+import System.Mem.Weak (deRefWeak)

2862import Data.Typeable (Typeable)

29−import Data.IORef (IORef)

30−import qualified Data.IORef as I

63+import Control.Reaper

3164

3265----------------------------------------------------------------

3366

@@ -38,7 +71,7 @@ type Manager = Reaper [Handle] Handle

3871type TimeoutAction = IO ()

3972

4073-- | A handle used by 'Manager'

41−data Handle = Handle !(IORef TimeoutAction) !(IORef State)

74+data Handle = Handle TimeoutAction (IORef State)

4275

4376data State = Active -- Manager turns it to Inactive.

4477 | Inactive -- Manager removes it with timeout action.

@@ -55,11 +88,10 @@ initialize timeout = mkReaper defaultReaperSettings

5588 , reaperDelay = timeout

5689 }

5790 where

58− prune m@(Handle actionRef stateRef) = do

59− state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x))

91+ prune m@(Handle onTimeout iactive) = do

92+ state <- I.atomicModifyIORef' iactive (\x -> (inactivate x, x))

6093 case state of

6194 Inactive -> do

62− onTimeout <- I.readIORef actionRef

6395 onTimeout `E.catch` ignoreAll

6496 return Nothing

6597 Canceled -> return Nothing

@@ -70,70 +102,68 @@ initialize timeout = mkReaper defaultReaperSettings

70102

71103----------------------------------------------------------------

72104

73−-- | Stopping timeout manager with onTimeout fired.

105+-- | Stopping timeout manager.

74106stopManager :: Manager -> IO ()

75107stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)

76108 where

77− fire (Handle actionRef _) = do

78− onTimeout <- I.readIORef actionRef

79− onTimeout `E.catch` ignoreAll

109+ fire (Handle onTimeout _) = onTimeout `E.catch` ignoreAll

80110

81111ignoreAll :: E.SomeException -> IO ()

82112ignoreAll _ = return ()

83113

84−-- | Killing timeout manager immediately without firing onTimeout.

85−killManager :: Manager -> IO ()

86−killManager = reaperKill

87−

88114----------------------------------------------------------------

89115

90116-- | Registering a timeout action.

91117register :: Manager -> TimeoutAction -> IO Handle

92118register mgr onTimeout = do

93− actionRef <- I.newIORef onTimeout

94− stateRef <- I.newIORef Active

95− let h = Handle actionRef stateRef

119+ iactive <- I.newIORef Active

120+ let h = Handle onTimeout iactive

96121 reaperAdd mgr h

97122 return h

98123

99124-- | 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

125+registerKillThread :: Manager -> IO Handle

126+registerKillThread m = do

127+ wtid <- myThreadId >>= mkWeakThreadId

128+ register m $ killIfExist wtid

129+

130+-- If ThreadId is hold referred by a strong reference,

131+-- it leaks even after the thread is killed.

132+-- So, let's use a weak reference so that CG can throw ThreadId away.

133+-- deRefWeak checks if ThreadId referenced by the weak reference

134+-- exists. If exists, it means that the thread is alive.

135+killIfExist :: Weak ThreadId -> TimeoutAction

136+killIfExist wtid = deRefWeak wtid >>= maybe (return ()) (`E.throwTo` TimeoutThread)

110137

111138data TimeoutThread = TimeoutThread

112139 deriving Typeable

113−instance E.Exception TimeoutThread where

114− toException = E.asyncExceptionToException

115− fromException = E.asyncExceptionFromException

140+instance E.Exception TimeoutThread

116141instance Show TimeoutThread where

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

142+ show TimeoutThread = "Thread killed by Warp's timeout reaper"

143+

144+#if !MIN_VERSION_base(4,6,0)

145+mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)

146+mkWeakThreadId t@(ThreadId t#) = IO $ \s ->

147+ case mkWeak# t# t Nothing s of

148+ (# s1, w #) -> (# s1, Weak w #)

149+#endif

118150

119151----------------------------------------------------------------

120152

121153-- | Setting the state to active.

122154-- 'Manager' turns active to inactive repeatedly.

123155tickle :: Handle -> IO ()

124−tickle (Handle _ stateRef) = I.writeIORef stateRef Active

156+tickle (Handle _ iactive) = I.writeIORef iactive Active

125157

126158-- | Setting the state to canceled.

127159-- 'Manager' eventually removes this without timeout action.

128160cancel :: Handle -> IO ()

129−cancel (Handle actionRef stateRef) = do

130− I.writeIORef actionRef (return ()) -- ensuring to release ThreadId

131− I.writeIORef stateRef Canceled

161+cancel (Handle _ iactive) = I.writeIORef iactive Canceled

132162

133163-- | Setting the state to paused.

134164-- 'Manager' does not change the value.

135165pause :: Handle -> IO ()

136−pause (Handle _ stateRef) = I.writeIORef stateRef Paused

166+pause (Handle _ iactive) = I.writeIORef iactive Paused

137167

138168-- | Setting the paused state to active.

139169-- This is an alias to 'tickle'.

warp/Network/Wai/Handler/Warp/Types.hs+39−87

@@ -5,18 +5,17 @@

55module Network.Wai.Handler.Warp.Types where

66

77import Control.Exception

8+import Data.ByteString (ByteString)

89import qualified Data.ByteString as S

910import Data.IORef (IORef, readIORef, writeIORef, newIORef)

1011import Data.Typeable (Typeable)

11−import Data.X509

12−import Foreign.Ptr (Ptr)

13−import System.Posix.Types (Fd)

14−import qualified System.TimeManager as T

15−

12+import Data.Word (Word16)

13+import Network.HTTP.Types.Header

14+import Network.Socket (Socket)

15+import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize,BufferPool)

1616import qualified Network.Wai.Handler.Warp.Date as D

1717import qualified Network.Wai.Handler.Warp.FdCache as F

18−import qualified Network.Wai.Handler.Warp.FileInfoCache as I

19−import Network.Wai.Handler.Warp.Imports

18+import qualified Network.Wai.Handler.Warp.Timeout as T

2019

2120----------------------------------------------------------------

2221

@@ -28,6 +27,18 @@ type Port = Int

2827-- | The type for header value used with 'HeaderName'.

2928type HeaderValue = ByteString

3029

30+hTransferEncoding :: HeaderName

31+hTransferEncoding = "Transfer-Encoding"

32+

33+hContentRange :: HeaderName

34+hContentRange = "Content-Range"

35+

36+hAcceptRanges :: HeaderName

37+hAcceptRanges = "Accept-Ranges"

38+

39+hServer :: HeaderName

40+hServer = "Server"

41+

3142----------------------------------------------------------------

3243

3344-- | Error types for bad 'Request'.

@@ -53,98 +64,40 @@ instance Exception InvalidRequest

5364

5465----------------------------------------------------------------

5566

56−-- | Exception thrown if something goes wrong while in the midst of

57−-- sending a response, since the status code can't be altered at that

58−-- point.

59−--

60−-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe

61−-- or irrecoverable.

62−

63−newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException

64− deriving (Show, Typeable)

65−

66−instance Exception ExceptionInsideResponseBody

67+-- | Whether or not 'ConnSendFileOverride' in 'Connection' can be

68+-- overridden. This is a kind of hack to keep the signature of

69+-- 'Connection' clean.

70+data ConnSendFileOverride = NotOverride -- ^ Don't override

71+ | Override Socket -- ^ Override with this 'Socket'

6772

6873----------------------------------------------------------------

6974

70−-- | Data type to abstract file identifiers.

71−-- On Unix, a file descriptor would be specified to make use of

72−-- the file descriptor cache.

73−--

74−-- Since: 3.1.0

75−data FileId = FileId {

76− fileIdPath :: FilePath

77− , fileIdFd :: Maybe Fd

78− }

79−

80−-- | fileid, offset, length, hook action, HTTP headers

81−--

82−-- Since: 3.1.0

83−type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO ()

84−

85−-- | Type for read buffer pool

86−type BufferPool = IORef ByteString

87−

88−-- | Type for buffer

89−type Buffer = Ptr Word8

90−

91−-- | Type for buffer size

92−type BufSize = Int

93−

94−-- | Type for the action to receive input data

95−type Recv = IO ByteString

96−

97−-- | Type for the action to receive input data with a buffer.

98−-- The result boolean indicates whether or not the buffer is fully filled.

99−type RecvBuf = Buffer -> BufSize -> IO Bool

100−

10175-- | Data type to manipulate IO actions for connections.

102−-- This is used to abstract IO actions for plain HTTP and HTTP over TLS.

103−data Connection = Connection {

104− -- | This is not used at this moment.

105− connSendMany :: [ByteString] -> IO ()

106− -- | The sending function.

107− , connSendAll :: ByteString -> IO ()

108− -- | The sending function for files in HTTP/1.1.

109− , connSendFile :: SendFile

110− -- | The connection closing function. Warp guarantees it will only be

111− -- called once. Other functions (like 'connRecv') may be called after

112− -- 'connClose' is called.

113− , connClose :: IO ()

114− -- | Free any buffers allocated. Warp guarantees it will only be

115− -- called once, and no other functions will be called after it.

116− , connFree :: IO ()

117− -- | The connection receiving function. This returns "" for EOF.

118− , connRecv :: Recv

119− -- | The connection receiving function. This tries to fill the buffer.

120− -- This returns when the buffer is filled or reaches EOF.

121− , connRecvBuf :: RecvBuf

122− -- | The write buffer.

123− , connWriteBuffer :: Buffer

124− -- | The size of the write buffer.

125− , connBufferSize :: BufSize

126− -- | Is this connection HTTP/2?

127− , connHTTP2 :: IORef Bool

76+data Connection = Connection

77+ { connSendMany :: [ByteString] -> IO ()

78+ , connSendAll :: ByteString -> IO ()

79+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ filepath, offset, length, hook action, HTTP headers

80+ , connClose :: IO ()

81+ , connRecv :: IO ByteString

82+ , connBufferPool :: BufferPool

83+ , connReadBuffer :: Buffer

84+ -- ^ NOTE: This is kept just for backwards compatibility, and is no longer used at all.

85+ , connWriteBuffer :: Buffer

86+ , connBufferSize :: BufSize

87+ , connSendFileOverride :: ConnSendFileOverride

12888 }

12989

130−getConnHTTP2 :: Connection -> IO Bool

131−getConnHTTP2 conn = readIORef (connHTTP2 conn)

132−

133−setConnHTTP2 :: Connection -> Bool -> IO ()

134−setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b

135−

13690----------------------------------------------------------------

13791

92+-- | Internal information.

13893data InternalInfo = InternalInfo {

139− timeoutManager :: T.Manager

140− , getDate :: IO D.GMTDate

141− , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

142− , getFileInfo :: FilePath -> IO I.FileInfo

94+ threadHandle :: T.Handle

95+ , fdCacher :: Maybe F.MutableFdCache

96+ , dateCacher :: D.DateCache

14397 }

14498

14599----------------------------------------------------------------

146100

147−-- | Type for input streaming.

148101data Source = Source !(IORef ByteString) !(IO ByteString)

149102

150103mkSource :: IO ByteString -> IO Source

@@ -180,7 +133,6 @@ data Transport = TCP -- ^ Plain channel: TCP

180133 , tlsMinorVersion :: Int

181134 , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

182135 , tlsChiperID :: Word16

183− , tlsClientCertificate :: Maybe CertificateChain

184136 } -- ^ Encrypted channel: TLS or SSL

185137

186138isTransportSecure :: Transport -> Bool

warp/Network/Wai/Handler/Warp/Windows.hs+1−5

@@ -7,12 +7,8 @@ module Network.Wai.Handler.Warp.Windows

77import Control.Exception

88import Control.Concurrent.MVar

99import Control.Concurrent

10+import Control.Monad

1011

11−import Network.Wai.Handler.Warp.Imports

12−

13−-- | Allow main socket listening thread to be interrupted on Windows platform

14−--

15−-- @since 3.2.17

1612windowsThreadBlockHack :: IO a -> IO a

1713windowsThreadBlockHack act = do

1814 var <- newEmptyMVar :: IO (MVar (Either SomeException a))

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

@@ -1,104 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Network.Wai.Handler.Warp.WithApplication (

3− withApplication,

4− withApplicationSettings,

5− testWithApplication,

6− testWithApplicationSettings,

7− openFreePort,

8− withFreePort,

9−) where

10−

11−import Control.Concurrent

12−import Control.Concurrent.Async

13−import Control.Exception

14−import Control.Monad (when)

15−import Data.Streaming.Network (bindRandomPortTCP)

16−import Network.Socket

17−import Network.Wai

18−import Network.Wai.Handler.Warp.Run

19−import Network.Wai.Handler.Warp.Settings

20−import Network.Wai.Handler.Warp.Types

21−

22−-- | Runs the given 'Application' on a free port. Passes the port to the given

23−-- operation and executes it, while the 'Application' is running. Shuts down the

24−-- server before returning.

25−--

26−-- @since 3.2.4

27−withApplication :: IO Application -> (Port -> IO a) -> IO a

28−withApplication = withApplicationSettings defaultSettings

29−

30−-- | 'withApplication' with given 'Settings'. This will ignore the port value

31−-- set by 'setPort' in 'Settings'.

32−--

33−-- @since 3.2.7

34−withApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

35−withApplicationSettings settings' mkApp action = do

36− app <- mkApp

37− withFreePort $ \ (port, sock) -> do

38− started <- mkWaiter

39− let settings =

40− settings' {

41− settingsBeforeMainLoop

42− = notify started () >> settingsBeforeMainLoop settings'

43− }

44− result <- race

45− (runSettingsSocket settings sock app)

46− (waitFor started >> action port)

47− case result of

48− Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"

49− Right x -> return x

50−

51−-- | Same as 'withApplication' but with different exception handling: If the

52−-- given 'Application' throws an exception, 'testWithApplication' will re-throw

53−-- the exception to the calling thread, possibly interrupting the execution of

54−-- the given operation.

55−--

56−-- This is handy for running tests against an 'Application' over a real network

57−-- port. When running tests, it's useful to let exceptions thrown by your

58−-- 'Application' propagate to the main thread of the test-suite.

59−--

60−-- __The exception handling makes this function unsuitable for use in production.__

61−-- Use 'withApplication' instead.

62−--

63−-- @since 3.2.4

64−testWithApplication :: IO Application -> (Port -> IO a) -> IO a

65−testWithApplication = testWithApplicationSettings defaultSettings

66−

67−-- | 'testWithApplication' with given 'Settings'.

68−--

69−-- @since 3.2.7

70−testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a

71−testWithApplicationSettings settings mkApp action = do

72− callingThread <- myThreadId

73− app <- mkApp

74− let wrappedApp request respond =

75− app request respond `catch` \ e -> do

76− when

77− (defaultShouldDisplayException e)

78− (throwTo callingThread e)

79− throwIO e

80− withApplicationSettings settings (return wrappedApp) action

81−

82−data Waiter a

83− = Waiter {

84− notify :: a -> IO (),

85− waitFor :: IO a

86− }

87−

88−mkWaiter :: IO (Waiter a)

89−mkWaiter = do

90− mvar <- newEmptyMVar

91− return Waiter {

92− notify = putMVar mvar,

93− waitFor = readMVar mvar

94− }

95−

96−-- | Opens a socket on a free port and returns both port and socket.

97−--

98−-- @since 3.2.4

99−openFreePort :: IO (Port, Socket)

100−openFreePort = bindRandomPortTCP "127.0.0.1"

101−

102−-- | Like 'openFreePort' but closes the socket before exiting.

103−withFreePort :: ((Port, Socket) -> IO a) -> IO a

104−withFreePort = bracket openFreePort (close . snd)

warp/README.md+3−2

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

1−# Warp

1+## warp

22

3−Warp is a server library for HTTP/1.x and HTTP/2 based WAI(Web Application Interface in Haskell). For more information, see [Warp](http://www.aosabook.org/en/posa/warp.html).

3+The premier WAI handler. For more information, see [Warp: A Haskell Web

4+Server](http://steve.vinoski.net/blog/2011/05/01/warp-a-haskell-web-server/).

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

@@ -12,7 +12,7 @@ import Network.Wai (responseLBS)

1212import Network.HTTP.Types (status200)

1313import Data.Enumerator (($$), run_)

1414

15−app = const $ return $ responseLBS status200 [("Content-type", "text/plain")] "This is not kept alive under any circumstances"

15+app = const $ return $ responseLBS status200 [("Content-type", "text/plain")] "This is not kept alive under any circumtances"

1616

1717main = withManager 30000000 $ \man -> bracket

1818 (bindPort (settingsPort set) (settingsHost set))

warp/bench/Parser.hs+16−21

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE OverloadedStrings #-}

32{-# LANGUAGE BangPatterns #-}

43

@@ -19,11 +18,7 @@ import Foreign.ForeignPtr

1918import Foreign.Ptr

2019import Foreign.Storable

2120

22−#if MIN_VERSION_gauge(0, 2, 0)

23−import Gauge

24−#else

25−import Gauge.Main

26−#endif

21+import Criterion.Main

2722

2823-- $setup

2924-- >>> :set -XOverloadedStrings

@@ -37,15 +32,15 @@ main = do

3732 defaultMain [

3833 bgroup "requestLine1" [

3934 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1

40− , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1

41− , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1

42− , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1

35+ , bench "parseRequestLine2" $ parseRequestLine2 requestLine1

36+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine1

37+ , bench "parseRequestLine0" $ parseRequestLine0 requestLine1

4338 ]

4439 , bgroup "requestLine2" [

4540 bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2

46− , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2

47− , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2

48− , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2

41+ , bench "parseRequestLine2" $ parseRequestLine2 requestLine2

42+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine2

43+ , bench "parseRequestLine0" $ parseRequestLine0 requestLine2

4944 ]

5045 ]

5146

@@ -68,15 +63,15 @@ parseRequestLine3 :: ByteString

6863 ,H.HttpVersion)

6964parseRequestLine3 requestLine = ret

7065 where

71− (!method,!rest) = S.break (== 32) requestLine -- ' '

66+ (!method,!rest) = S.breakByte 32 requestLine -- ' '

7267 (!pathQuery,!httpVer')

7368 | rest == "" = throw badmsg

74− | otherwise = S.break (== 32) (S.drop 1 rest) -- ' '

75− (!path,!query) = S.break (== 63) pathQuery -- '?'

69+ | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' '

70+ (!path,!query) = S.breakByte 63 pathQuery -- '?'

7671 !httpVer = S.drop 1 httpVer'

7772 (!http,!ver)

7873 | httpVer == "" = throw badmsg

79− | otherwise = S.break (== 47) httpVer -- '/'

74+ | otherwise = S.breakByte 47 httpVer -- '/'

8075 !hv | http /= "HTTP" = throw NonHttp

8176 | ver == "/1.1" = H.http11

8277 | otherwise = H.http10

@@ -174,13 +169,13 @@ parseRequestLine1 :: ByteString

174169 ,ByteString -- Query

175170 ,H.HttpVersion)

176171parseRequestLine1 requestLine = do

177− let (!method,!rest) = S.break (== 32) requestLine -- ' '

178− (!pathQuery,!httpVer') = S.break (== 32) (S.drop 1 rest) -- ' '

172+ let (!method,!rest) = S.breakByte 32 requestLine -- ' '

173+ (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' '

179174 !httpVer = S.drop 1 httpVer'

180175 when (rest == "" || httpVer == "") $

181176 throwIO $ BadFirstLine $ B.unpack requestLine

182− let (!path,!query) = S.break (== 63) pathQuery -- '?'

183− (!http,!ver) = S.break (== 47) httpVer -- '/'

177+ let (!path,!query) = S.breakByte 63 pathQuery -- '?'

178+ (!http,!ver) = S.breakByte 47 httpVer -- '/'

184179 when (http /= "HTTP") $ throwIO NonHttp

185180 let !hv | ver == "/1.1" = H.http11

186181 | otherwise = H.http10

@@ -210,7 +205,7 @@ parseRequestLine0 s =

210205 !http' = S.concat http''

211206 (!hfirst, !hsecond) = S.splitAt 5 http'

212207 if hfirst == "HTTP/"

213− then let (!rpath, !qstring) = S.break (== 63) query -- '?'

208+ then let (!rpath, !qstring) = S.breakByte 63 query -- '?'

214209 !hv =

215210 case hsecond of

216211 "1.1" -> H.http11

warp/test/BufferPoolSpec.hsdeleted−47

@@ -1,47 +0,0 @@

1−module BufferPoolSpec where

2−

3−import qualified Data.ByteString as B

4−import qualified Data.ByteString.Internal as B (ByteString(PS))

5−import Foreign.ForeignPtr (withForeignPtr)

6−import Foreign.Marshal.Utils (copyBytes)

7−import Foreign.Ptr (plusPtr)

8−

9−import Test.Hspec (Spec, hspec, shouldBe, describe, it)

10−

11−import Network.Wai.Handler.Warp.Buffer

12− ( bufferSize

13− , newBufferPool

14− , withBufferPool

15− )

16−import Network.Wai.Handler.Warp.Types (Buffer, BufSize)

17−

18−main :: IO ()

19−main = hspec spec

20−

21−-- Two ByteStrings each big enough to fill a 'bufferSize' buffer (16K).

22−wantData, otherData :: B.ByteString

23−wantData = B.replicate bufferSize 0xac

24−otherData = B.replicate bufferSize 0x77

25−

26−spec :: Spec

27−spec = describe "withBufferPool" $ do

28− it "does not clobber buffers" $ do

29− pool <- newBufferPool

30− -- 'pool' contains B.empty; prime it to contain a real buffer.

31− _ <- withBufferPool pool $ const $ return 0

32− -- 'pool' contains a 16K buffer; fill it with \xac and keep the result.

33− got <- withBufferPool pool $ blitBuffer wantData

34− got `shouldBe` wantData

35− -- 'pool' should now be empty and reallocate, rather than clobber the

36− -- previous buffer.

37− _ <- withBufferPool pool $ blitBuffer otherData

38− got `shouldBe` wantData

39−

40−-- Fill the Buffer with the contents of the ByteString and return the number of

41−-- bytes written. To be used with 'withBufferPool'.

42−blitBuffer :: B.ByteString -> (Buffer, BufSize) -> IO Int

43−blitBuffer (B.PS fp off len) (dst, len') = withForeignPtr fp $ \ptr -> do

44− let src = ptr `plusPtr` off

45− n = min len len'

46− copyBytes dst src n

47− return n

warp/test/ExceptionSpec.hs+30−15

@@ -6,17 +6,17 @@ module ExceptionSpec (main, spec) where

66import Control.Applicative

77#endif

88import Control.Monad

9+import Network.HTTP

10+import Network.Stream

911import Network.HTTP.Types hiding (Header)

10−import Network.Wai hiding (Response, responseStatus)

12+import Network.Wai hiding (Response)

1113import Network.Wai.Internal (Request(..))

1214import Network.Wai.Handler.Warp

1315import Test.Hspec

1416import Control.Exception

1517import qualified Data.Streaming.Network as N

1618import Control.Concurrent.Async (withAsync)

17−import Network.Socket (close)

18−

19−import HTTP

19+import Network.Socket (sClose)

2020

2121main :: IO ()

2222main = hspec spec

@@ -24,7 +24,7 @@ main = hspec spec

2424withTestServer :: (Int -> IO a) -> IO a

2525withTestServer inner = bracket

2626 (N.bindRandomPortTCP "127.0.0.1")

27− (close . snd)

27+ (sClose . snd)

2828 $ \(prt, lsocket) -> do

2929 withAsync (runSettingsSocket defaultSettings lsocket testApp)

3030 $ \_ -> inner prt

@@ -49,18 +49,33 @@ spec :: Spec

4949spec = describe "responds even if there is an exception" $ do

5050 {- Disabling these tests. We can consider forcing evaluation in Warp.

5151 it "statusError" $ do

52− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"

53− sc `shouldBe` internalServerError500

52+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError"

53+ sc `shouldBe` (5,0,0)

5454 it "headersError" $ do

55− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"

56− sc `shouldBe` internalServerError500

55+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError"

56+ sc `shouldBe` (5,0,0)

5757 it "headerError" $ do

58− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"

59− sc `shouldBe` internalServerError500

58+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError"

59+ sc `shouldBe` (5,0,0)

6060 it "bodyError" $ do

61− sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"

62− sc `shouldBe` internalServerError500

61+ sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError"

62+ sc `shouldBe` (5,0,0)

6363 -}

6464 it "ioException" $ withTestServer $ \prt -> do

65− sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

66− sc `shouldBe` internalServerError500

65+ sc <- rspCode <$> sendGET (concat $ ["http://127.0.0.1:", show prt, "/ioException"])

66+ sc `shouldBe` (5,0,0)

67+

68+----------------------------------------------------------------

69+

70+sendGET :: String -> IO (Response String)

71+sendGET url = sendGETwH url []

72+

73+sendGETwH :: String -> [Header] -> IO (Response String)

74+sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }

75+

76+unResult :: IO (Result (Response String)) -> IO (Response String)

77+unResult action = do

78+ res <- action

79+ case res of

80+ Right rsp -> return rsp

81+ Left _ -> error "Connection error"

warp/test/FdCacheSpec.hs+3−3

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

33module FdCacheSpec where

44

55import Test.Hspec

6−#ifndef WINDOWS

6+#ifdef SENDFILEFD

77import Data.IORef

88import Network.Wai.Handler.Warp.FdCache

99import System.Posix.IO (fdRead)

@@ -16,8 +16,8 @@ spec :: Spec

1616spec = describe "withFdCache" $ do

1717 it "clean up Fd" $ do

1818 ref <- newIORef (Fd (-1))

19− withFdCache 30000000 $ \getFd -> do

20− (Just fd,_) <- getFd "warp.cabal"

19+ withFdCache 30000000 $ \(Just mfc) -> do

20+ (fd,_) <- getFd mfc "warp.cabal"

2121 writeIORef ref fd

2222 nfd <- readIORef ref

2323 fdRead nfd 1 `shouldThrow` anyIOException

warp/test/FileSpec.hsdeleted−45

@@ -1,45 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module FileSpec (main, spec) where

4−

5−import Network.HTTP.Types

6−import Network.Wai.Handler.Warp.File

7−import Network.Wai.Handler.Warp.FileInfoCache

8−import Network.Wai.Handler.Warp.Header

9−

10−import Test.Hspec

11−

12−main :: IO ()

13−main = hspec spec

14−

15−testFileRange :: String

16− -> RequestHeaders -> FilePath

17− -> RspFileInfo

18− -> Spec

19−testFileRange desc reqhs file ans = it desc $ do

20− finfo <- getInfo file

21− let WithBody s hs off len = ans

22− hs' = ("Last-Modified",fileInfoDate finfo) : hs

23− ans' = WithBody s hs' off len

24− conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans'

25−

26−spec :: Spec

27−spec = do

28− describe "conditionalRequest" $ do

29− testFileRange

30− "gets a file size from file system"

31− [] "attic/hex"

32− $ WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16

33− testFileRange

34− "gets a file size from file system and handles Range and returns Partical Content"

35− [("Range","bytes=2-14")] "attic/hex"

36− $ WithBody status206 [("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")] 2 13

37− testFileRange

38− "truncates end point of range to file size"

39− [("Range","bytes=10-20")] "attic/hex"

40− $ WithBody status206 [("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")] 10 6

41− testFileRange

42− "gets a file size from file system and handles Range and returns OK if Range means the entire"

43− [("Range:","bytes=0-15")] "attic/hex"

44− $ WithBody status200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16

45−

warp/test/HTTP.hsdeleted−41

@@ -1,41 +0,0 @@

1−module HTTP (

2− sendGET

3− , sendGETwH

4− , sendHEAD

5− , sendHEADwH

6− , responseBody

7− , responseStatus

8− , responseHeaders

9− , getHeaderValue

10− , HeaderName

11− ) where

12−

13−import Network.HTTP.Client

14−import Network.HTTP.Types

15−import Data.ByteString

16−import qualified Data.ByteString.Lazy as BL

17−

18−sendGET :: String -> IO (Response BL.ByteString)

19−sendGET url = sendGETwH url []

20−

21−sendGETwH :: String -> [Header] -> IO (Response BL.ByteString)

22−sendGETwH url hdr = do

23− manager <- newManager defaultManagerSettings

24− request <- parseRequest url

25− let request' = request { requestHeaders = hdr }

26− response <- httpLbs request' manager

27− return response

28−

29−sendHEAD :: String -> IO (Response BL.ByteString)

30−sendHEAD url = sendHEADwH url []

31−

32−sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString)

33−sendHEADwH url hdr = do

34− manager <- newManager defaultManagerSettings

35− request <- parseRequest url

36− let request' = request { requestHeaders = hdr, method = methodHead }

37− response <- httpLbs request' manager

38− return response

39−

40−getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString

41−getHeaderValue = lookup

warp/test/MultiMapSpec.hsnew file+30

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

1+module MultiMapSpec where

2+

3+import Network.Wai.Handler.Warp.MultiMap

4+import Test.Hspec

5+import Test.QuickCheck (property)

6+

7+type Alist = [(Int,Char)]

8+

9+spec :: Spec

10+spec = do

11+ describe "fromList" $ do

12+ it "generates a valid tree" $ property $ \xs ->

13+ valid $ fromList (xs :: Alist)

14+ describe "toSortedList" $ do

15+ it "generated a sorted list" $ property $ \xs ->

16+ ordered $ toSortedList $ fromList (xs :: Alist)

17+ describe "search" $ do

18+ it "acts as the list model" $ property $ \x xs ->

19+ search x (fromList xs) == lookup x (xs :: Alist)

20+ describe "fromSortedList" $ do

21+ it "generates a valid tree" $ property $ \xs ->

22+ valid . fromSortedList . toSortedList . fromList $ (xs :: Alist)

23+ it "maintains the tree with toSortedList" $ property $ \xs ->

24+ let t1 = fromList (xs :: Alist)

25+ t2 = fromSortedList $ toSortedList t1

26+ in t1 == t2

27+

28+ordered :: Ord a => [(a, b)] -> Bool

29+ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)

30+ordered _ = True

warp/test/RequestSpec.hs+8−12

@@ -4,10 +4,9 @@

44

55module RequestSpec (main, spec) where

66

7−import Network.Wai.Handler.Warp.File (parseByteRanges)

87import Network.Wai.Handler.Warp.Request

8+import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)

99import Network.Wai.Handler.Warp.Types

10−import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings)

1110import Test.Hspec

1211import Test.Hspec.QuickCheck

1312import qualified Data.ByteString as S

@@ -18,9 +17,6 @@ import Data.IORef

1817main :: IO ()

1918main = hspec spec

2019

21−defaultMaxTotalHeaderLength :: Int

22−defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23−

2420spec :: Spec

2521spec = do

2622 describe "headerLines" $ do

@@ -67,29 +63,29 @@ spec = do

6763 describe "headerLines" $ do

6864 it "can handle a nomarl case" $ do

6965 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

70− x <- headerLines defaultMaxTotalHeaderLength True src

66+ x <- headerLines src

7167 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

7268

7369 it "can handle a nasty case (1)" $ do

7470 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

75− x <- headerLines defaultMaxTotalHeaderLength True src

71+ x <- headerLines src

7672 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

7773

7874 it "can handle a nasty case (1)" $ do

7975 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

80− x <- headerLines defaultMaxTotalHeaderLength True src

76+ x <- headerLines src

8177 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

8278

8379 it "can handle a nasty case (1)" $ do

8480 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

85− x <- headerLines defaultMaxTotalHeaderLength True src

81+ x <- headerLines src

8682 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

8783

8884 it "can handle an illegal case (1)" $ do

8985 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

90− x <- headerLines defaultMaxTotalHeaderLength True src

86+ x <- headerLines src

9187 x `shouldBe` []

92− y <- headerLines defaultMaxTotalHeaderLength True src

88+ y <- headerLines src

9389 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

9490

9591 where

@@ -115,7 +111,7 @@ headerLinesList' orig = do

115111 writeIORef ref z

116112 return y

117113 src' <- mkSource src

118− res <- headerLines defaultMaxTotalHeaderLength True src'

114+ res <- headerLines src'

119115 return (res, src')

120116

121117consumeLen :: Int -> Source -> IO S8.ByteString

warp/test/ResponseHeaderSpec.hs+5−25

@@ -5,44 +5,24 @@ module ResponseHeaderSpec (main, spec) where

55import Data.ByteString

66import qualified Network.HTTP.Types as H

77import Network.Wai.Handler.Warp.ResponseHeader

8−import Network.Wai.Handler.Warp.Response

9−import Network.Wai.Handler.Warp.Header

108import Test.Hspec

119

1210main :: IO ()

1311main = hspec spec

1412

1513spec :: Spec

16−spec = do

17− describe "composeHeader" $ do

18− it "composes a HTTP header" $

19− composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader

20− describe "addServer" $ do

21− it "adds Server if not exist" $ do

22− let hdrs = []

23− rspidxhdr = indexResponseHeader hdrs

24− addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server","MyServer")]

25− it "does not add Server if exists" $ do

26− let hdrs = [("Server","MyServer")]

27− rspidxhdr = indexResponseHeader hdrs

28− addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs

29− it "does not add Server if empty" $ do

30− let hdrs = []

31− rspidxhdr = indexResponseHeader hdrs

32− addServer "" rspidxhdr hdrs `shouldBe` hdrs

33− it "deletes Server " $ do

34− let hdrs = [("Server","MyServer")]

35− rspidxhdr = indexResponseHeader hdrs

36− addServer "" rspidxhdr hdrs `shouldBe` []

14+spec = describe "composeHeader" $ do

15+ it "composes a HTTP header" $

16+ composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader

3717

3818headers :: H.ResponseHeaders

3919headers = [

4020 ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")

41− , ("Content-Length", "151")

21+ , ("Content-Lenght", "151")

4222 , ("Server", "Mighttpd/2.5.8")

4323 , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")

4424 , ("Content-Type", "text/html")

4525 ]

4626

4727composedHeader :: ByteString

48−composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

28+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"

warp/test/ResponseSpec.hs+65−42

@@ -1,16 +1,17 @@

11{-# LANGUAGE OverloadedStrings #-}

2−

32module ResponseSpec (main, spec) where

43

54import Control.Concurrent (threadDelay)

65import qualified Data.ByteString as S

76import qualified Data.ByteString.Char8 as S8

87import Data.Maybe (mapMaybe)

8+import Network (connectTo, PortID (PortNumber))

99import Network.HTTP.Types

10−import Network.Wai hiding (responseHeaders)

10+import Network.Wai

1111import Network.Wai.Handler.Warp

1212import Network.Wai.Handler.Warp.Response

13−import RunSpec (withApp, msWrite, msRead, withMySocket)

13+import RunSpec (withApp)

14+import System.IO (hClose, hFlush)

1415import Test.Hspec

1516

1617main :: IO ()

@@ -20,13 +21,16 @@ testRange :: S.ByteString -- ^ range value

2021 -> String -- ^ expected output

2122 -> Maybe String -- ^ expected content-range value

2223 -> Spec

23−testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

24− msWrite ms "GET / HTTP/1.0\r\n"

25− msWrite ms "Range: bytes="

26− msWrite ms range

27− msWrite ms "\r\n\r\n"

24+testRange range out crange = it title $ withApp defaultSettings app $ \port -> do

25+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

26+ S.hPutStr handle "GET / HTTP/1.0\r\n"

27+ S.hPutStr handle "Range: bytes="

28+ S.hPutStr handle range

29+ S.hPutStr handle "\r\n\r\n"

30+ hFlush handle

2831 threadDelay 10000

29− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

32+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

33+ hClose handle

3034 last bss `shouldBe` out

3135 let hs = mapMaybe toHeader bss

3236 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange

@@ -44,10 +48,13 @@ testPartial :: Integer -- ^ file size

4448 -> Integer -- ^ byte count

4549 -> String -- ^ expected output

4650 -> Spec

47−testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do

48− msWrite ms "GET / HTTP/1.0\r\n\r\n"

51+testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do

52+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

53+ S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"

54+ hFlush handle

4955 threadDelay 10000

50− bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024

56+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024

57+ hClose handle

5158 out `shouldBe` last bss

5259 let hs = mapMaybe toHeader bss

5360 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)

@@ -61,38 +68,20 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ wit

6168 _ -> Nothing

6269 range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size

6370

71+testFileRange :: String

72+ -> Status -> ResponseHeaders -> FilePath

73+ -> Maybe FilePart -> Maybe HeaderValue

74+ -> Either String (Status, ResponseHeaders, Integer, Integer)

75+ -> Spec

76+testFileRange desc s rsphdr file mPart mRange ans = it desc $ do

77+ eres <- fileRange s rsphdr file mPart mRange

78+ let res = case eres of

79+ Left e -> Left $ show e

80+ Right r -> Right r

81+ res `shouldBe` ans

82+

6483spec :: Spec

6584spec = do

66−{- http-client does not support this.

67− describe "preventing response splitting attack" $ do

68− it "sanitizes header values" $ do

69− let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

70− withApp defaultSettings app $ \port -> do

71− res <- sendGET $ "http://127.0.0.1:" ++ show port

72− getHeaderValue "foo" (responseHeaders res) `shouldBe`

73− Just "foo bar" -- HTTP inserts two spaces for \r\n.

74−-}

75−

76− describe "sanitizeHeaderValue" $ do

77− it "doesn't alter valid multiline header values" $ do

78− sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar"

79−

80− it "adds missing spaces after \r\n" $ do

81− sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar"

82−

83− it "discards empty lines" $ do

84− sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"

85−

86− context "when sanitizing single occurrences of \n" $ do

87− it "replaces \n with \r\n" $ do

88− sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"

89−

90− it "adds missing spaces after \n" $ do

91− sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar"

92−

93− it "discards single occurrences of \r" $ do

94− sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar"

95−

9685 describe "range requests" $ do

9786 testRange "2-3" "23" $ Just "2-3/16"

9887 testRange "5-" "56789abcdef" $ Just "5-15/16"

@@ -105,3 +94,37 @@ spec = do

10594 testPartial 16 2 2 "23"

10695 testPartial 16 0 2 "01"

10796 testPartial 16 3 8 "3456789a"

97+

98+ describe "fileRange" $ do

99+ testFileRange

100+ "gets a file size from file system"

101+ status200 [] "attic/hex" Nothing Nothing

102+ $ Right (status200,[("Content-Length","16")],0,16)

103+ testFileRange

104+ "gets an error if a file does not exist"

105+ status200 [] "attic/nonexist" Nothing Nothing

106+ $ Left "attic/nonexist: getFileStatus: does not exist (No such file or directory)"

107+ testFileRange

108+ "changes status if FileParts is specified"

109+ status200 [] "attic/hex" (Just (FilePart 2 10 16)) Nothing

110+ $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10")],2,10)

111+ testFileRange

112+ "does not change status and does not add Content-Range if FileParts means the entire"

113+ status200 [] "attic/hex" (Just (FilePart 0 16 16)) Nothing

114+ $ Right (status200,[("Content-Length","16")],0,16)

115+ testFileRange

116+ "gets a file size from file system and handles Range and returns Partical Content"

117+ status200 [] "attic/hex" Nothing (Just "bytes=2-14")

118+ $ Right (status206,[("Content-Range","bytes 2-14/16"),("Content-Length","13")],2,13)

119+ testFileRange

120+ "truncates end point of range to file size"

121+ status200 [] "attic/hex" Nothing (Just "bytes=10-20")

122+ $ Right (status206,[("Content-Range","bytes 10-15/16"),("Content-Length","6")],10,6)

123+ testFileRange

124+ "gets a file size from file system and handles Range and returns OK if Range means the entire"

125+ status200 [] "attic/hex" Nothing (Just "bytes=0-15")

126+ $ Right (status200,[("Content-Length","16")],0,16)

127+ testFileRange

128+ "igores Range if FilePart is specified"

129+ status200 [] "attic/hex" (Just (FilePart 2 10 16)) (Just "bytes=8-9")

130+ $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10")],2,10)

warp/test/RunSpec.hs+95−169

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE OverloadedStrings #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34

4−module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where

5+module RunSpec (main, spec, withApp) where

56

67import Control.Concurrent (forkIO, killThread, threadDelay)

7−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

8−import Control.Concurrent.STM

9−import qualified Control.Exception as E

10−import Control.Exception.Lifted (bracket, try, IOException, onException)

118import Control.Monad (forM_, replicateM_, unless)

9+import System.Timeout (timeout)

1210import Control.Monad.IO.Class (MonadIO, liftIO)

13−import Data.ByteString (ByteString)

11+import Data.ByteString (ByteString, hPutStr, hGetSome)

12+import qualified Control.Exception as E

1413import qualified Data.ByteString as S

15−import Data.ByteString.Builder (byteString)

1614import qualified Data.ByteString.Char8 as S8

1715import qualified Data.ByteString.Lazy as L

1816import qualified Data.IORef as I

19−import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

17+import Network (connectTo, PortID (PortNumber))

2018import Network.HTTP.Types

21−import Network.Socket

22−import Network.Socket.ByteString (sendAll)

23−import Network.Wai hiding (responseHeaders)

24−import Network.Wai.Internal (getRequestBodyChunk)

19+import Network.Wai

2520import Network.Wai.Handler.Warp

21+import System.IO (hFlush, hClose)

2622import System.IO.Unsafe (unsafePerformIO)

27−import System.Timeout (timeout)

2823import Test.Hspec

29−

30−import HTTP

24+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

25+import Control.Exception.Lifted (bracket, try, IOException, onException)

26+import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

27+import Network.Socket (sClose)

28+import qualified Network.HTTP as HTTP

29+import Blaze.ByteString.Builder (fromByteString)

30+import Network.Socket.ByteString (sendAll)

3131

3232main :: IO ()

3333main = hspec spec

@@ -35,52 +35,6 @@ main = hspec spec

3535type Counter = I.IORef (Either String Int)

3636type CounterApplication = Counter -> Application

3737

38−data MySocket = MySocket

39− { msSocket :: !Socket

40− , msBuffer :: !(I.IORef ByteString)

41− }

42−

43−msWrite :: MySocket -> ByteString -> IO ()

44−msWrite ms bs = sendAll (msSocket ms) bs

45−

46−msRead :: MySocket -> Int -> IO ByteString

47−msRead (MySocket s ref) expected = do

48− bs <- I.readIORef ref

49− inner (bs:) (S.length bs)

50− where

51− inner front total =

52− case compare total expected of

53− EQ -> do

54− I.writeIORef ref mempty

55− pure $ S.concat $ front []

56− GT -> do

57− let bs = S.concat $ front []

58− (x, y) = S.splitAt expected bs

59− I.writeIORef ref y

60− pure x

61− LT -> do

62− bs <- safeRecv s 4096

63− if S.null bs

64− then do

65− I.writeIORef ref mempty

66− pure $ S.concat $ front []

67− else inner (front . (bs:)) (total + S.length bs)

68−

69−msClose :: MySocket -> IO ()

70−msClose = Network.Socket.close . msSocket

71−

72−connectTo :: Int -> IO MySocket

73−connectTo port = do

74− s <- fst <$> getSocketTCP "127.0.0.1" port

75− ref <- I.newIORef mempty

76− return MySocket {

77− msSocket = s

78− , msBuffer = ref

79− }

80−

81−withMySocket :: (MySocket -> IO a) -> Int -> IO a

82−withMySocket body port = bracket (connectTo port) msClose body

83−

8438incr :: MonadIO m => Counter -> m ()

8539incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

8640 ((case ecount of

@@ -92,7 +46,7 @@ err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg

9246

9347readBody :: CounterApplication

9448readBody icount req f = do

95− body <- consumeBody $ getRequestBodyChunk req

49+ body <- consumeBody $ requestBody req

9650 case () of

9751 ()

9852 | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"

@@ -113,8 +67,8 @@ ignoreBody icount req f = do

11367

11468doubleConnect :: CounterApplication

11569doubleConnect icount req f = do

116− _ <- consumeBody $ getRequestBodyChunk req

117− _ <- consumeBody $ getRequestBodyChunk req

70+ _ <- consumeBody $ requestBody req

71+ _ <- consumeBody $ requestBody req

11872 incr icount

11973 f $ responseLBS status200 [] "double connect"

12074

@@ -128,8 +82,8 @@ getPort = do

12882 esocket <- try $ bindPortTCP port "127.0.0.1"

12983 case esocket of

13084 Left (_ :: IOException) -> RunSpec.getPort

131− Right sock -> do

132− close sock

85+ Right socket -> do

86+ sClose socket

13387 return port

13488

13589withApp :: Settings -> Application -> (Int -> IO a) -> IO a

@@ -143,13 +97,7 @@ withApp settings app f = do

14397 bracket

14498 (forkIO $ runSettings settings' app `onException` putMVar baton ())

14599 killThread

146− (const $ do

147− takeMVar baton

148− -- use timeout to make sure we don't take too long

149− mres <- timeout (60 * 1000 * 1000) (f port)

150− case mres of

151− Nothing -> error "Timeout triggered, too slow!"

152− Just a -> pure a)

100+ (const $ takeMVar baton >> f port)

153101

154102runTest :: Int -- ^ expected number of requests

155103 -> CounterApplication

@@ -157,9 +105,10 @@ runTest :: Int -- ^ expected number of requests

157105 -> IO ()

158106runTest expected app chunks = do

159107 ref <- I.newIORef (Right 0)

160− withApp defaultSettings (app ref) $ withMySocket $ \ms -> do

161− forM_ chunks $ \chunk -> msWrite ms chunk

162− _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096

108+ withApp defaultSettings (app ref) $ \port -> do

109+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

110+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle

111+ _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096

163112 res <- I.readIORef ref

164113 case res of

165114 Left s -> error s

@@ -174,9 +123,11 @@ runTerminateTest :: InvalidRequest

174123runTerminateTest expected input = do

175124 ref <- I.newIORef Nothing

176125 let onExc _ = I.writeIORef ref . Just

177− withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do

178− msWrite ms input

179− msClose ms -- explicitly

126+ withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

127+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

128+ hPutStr handle input

129+ hFlush handle

130+ hClose handle

180131 threadDelay 1000

181132 res <- I.readIORef ref

182133 show res `shouldBe` show (Just expected)

@@ -247,11 +198,14 @@ spec = do

247198 let app req f = do

248199 liftIO $ I.writeIORef iheaders $ requestHeaders req

249200 f $ responseLBS status200 [] ""

250− withApp defaultSettings app $ withMySocket $ \ms -> do

201+ withApp defaultSettings app $ \port -> do

202+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

251203 let input = S.concat

252204 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

253205 ]

254− msWrite ms input

206+ hPutStr handle input

207+ hFlush handle

208+ hClose handle

255209 threadDelay 1000

256210 headers <- I.readIORef iheaders

257211 headers `shouldBe`

@@ -262,11 +216,14 @@ spec = do

262216 let app req f = do

263217 liftIO $ I.writeIORef iheaders $ requestHeaders req

264218 f $ responseLBS status200 [] ""

265− withApp defaultSettings app $ withMySocket $ \ms -> do

219+ withApp defaultSettings app $ \port -> do

220+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

266221 let input = S.concat

267222 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

268223 ]

269− msWrite ms input

224+ hPutStr handle input

225+ hFlush handle

226+ hClose handle

270227 threadDelay 1000

271228 headers <- I.readIORef iheaders

272229 headers `shouldBe`

@@ -275,24 +232,23 @@ spec = do

275232

276233 describe "chunked bodies" $ do

277234 it "works" $ do

278− countVar <- newTVarIO (0 :: Int)

279235 ifront <- I.newIORef id

280236 let app req f = do

281− bss <- consumeBody $ getRequestBodyChunk req

237+ bss <- consumeBody $ requestBody req

282238 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

283− atomically $ modifyTVar countVar (+ 1)

284239 f $ responseLBS status200 [] ""

285− withApp defaultSettings app $ withMySocket $ \ms -> do

240+ withApp defaultSettings app $ \port -> do

241+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

286242 let input = S.concat

287243 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

288244 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

289245 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

290246 , "b\r\nHello World\r\n0\r\n\r\n"

291247 ]

292− msWrite ms input

293− atomically $ do

294− count <- readTVar countVar

295− check $ count == 2

248+ hPutStr handle input

249+ hFlush handle

250+ hClose handle

251+ threadDelay 1000

296252 front <- I.readIORef ifront

297253 front [] `shouldBe`

298254 [ "Hello World\nBye"

@@ -300,44 +256,38 @@ spec = do

300256 ]

301257 it "lots of chunks" $ do

302258 ifront <- I.newIORef id

303− countVar <- newTVarIO (0 :: Int)

304259 let app req f = do

305− bss <- consumeBody $ getRequestBodyChunk req

260+ bss <- consumeBody $ requestBody req

306261 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

307− atomically $ modifyTVar countVar (+ 1)

308262 f $ responseLBS status200 [] ""

309− withApp defaultSettings app $ withMySocket $ \ms -> do

263+ withApp defaultSettings app $ \port -> do

264+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

310265 let input = concat $ replicate 2 $

311266 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

312267 (replicate 50 "5\r\n12345\r\n") ++

313268 ["0\r\n\r\n"]

314− mapM_ (msWrite ms) input

315− atomically $ do

316− count <- readTVar countVar

317− check $ count == 2

269+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input

270+ hClose handle

271+ threadDelay 100000 -- FIXME why does this delay need to be so high?

318272 front <- I.readIORef ifront

319273 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")

320−-- For some reason, the following test on Windows causes the socket

321−-- to be killed prematurely. Worth investigating in the future if possible.

322274 it "in chunks" $ do

323275 ifront <- I.newIORef id

324− countVar <- newTVarIO (0 :: Int)

325276 let app req f = do

326− bss <- consumeBody $ getRequestBodyChunk req

277+ bss <- consumeBody $ requestBody req

327278 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

328− atomically $ modifyTVar countVar (+ 1)

329279 f $ responseLBS status200 [] ""

330− withApp defaultSettings app $ withMySocket $ \ms -> do

280+ withApp defaultSettings app $ \port -> do

281+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

331282 let input = S.concat

332283 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

333284 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

334285 , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

335286 , "b\r\nHello World\r\n0\r\n\r\n"

336287 ]

337− mapM_ (msWrite ms) $ map S.singleton $ S.unpack input

338− atomically $ do

339− count <- readTVar countVar

340− check $ count == 2

288+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input

289+ hClose handle

290+ threadDelay 1000

341291 front <- I.readIORef ifront

342292 front [] `shouldBe`

343293 [ "Hello World\nBye"

@@ -346,7 +296,7 @@ spec = do

346296 it "timeout in request body" $ do

347297 ifront <- I.newIORef id

348298 let app req f = do

349− bss <- (consumeBody $ getRequestBodyChunk req) `onException`

299+ bss <- (consumeBody $ requestBody req) `onException`

350300 liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))

351301 liftIO $ threadDelay 4000000 `E.catch` \e -> do

352302 I.atomicModifyIORef ifront (\front ->

@@ -355,18 +305,20 @@ spec = do

355305 E.throwIO (e :: E.SomeException)

356306 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

357307 f $ responseLBS status200 [] ""

358− withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do

308+ withApp (setTimeout 1 defaultSettings) app $ \port -> do

359309 let bs1 = S.replicate 2048 88

360310 bs2 = "This is short"

361311 bs = S.append bs1 bs2

362− msWrite ms "POST / HTTP/1.1\r\n"

363− msWrite ms "content-length: "

364− msWrite ms $ S8.pack $ show $ S.length bs

365− msWrite ms "\r\n\r\n"

312+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

313+ hPutStr handle "POST / HTTP/1.1\r\n"

314+ hPutStr handle "content-length: "

315+ hPutStr handle $ S8.pack $ show $ S.length bs

316+ hPutStr handle "\r\n\r\n"

366317 threadDelay 100000

367− msWrite ms bs1

318+ hPutStr handle bs1

368319 threadDelay 100000

369− msWrite ms bs2

320+ hPutStr handle bs2

321+ hClose handle

370322 threadDelay 5000000

371323 front <- I.readIORef ifront

372324 S.concat (front []) `shouldBe` bs

@@ -382,75 +334,49 @@ spec = do

382334 loop

383335 loop

384336 doubleBS = S.concatMap $ \w -> S.pack [w, w]

385− withApp defaultSettings app $ withMySocket $ \ms -> do

386− msWrite ms "POST / HTTP/1.1\r\n\r\n12345"

387− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")

388− msWrite ms "67890"

389− timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")

337+ withApp defaultSettings app $ \port -> do

338+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

339+ hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"

340+ hFlush handle

341+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")

342+ hPutStr handle "67890"

343+ hFlush handle

344+ timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")

345+

390346 it "only one date and server header" $ do

391347 let app _ f = f $ responseLBS status200

392348 [ ("server", "server")

393349 , ("date", "date")

394350 ] ""

395− getValues key = map snd

396− . filter (\(key', _) -> key == key')

397− . responseHeaders

398351 withApp defaultSettings app $ \port -> do

399− res <- sendGET $ "http://127.0.0.1:" ++ show port

400− getValues hServer res `shouldBe` ["server"]

401− getValues hDate res `shouldBe` ["date"]

352+ Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)

353+ map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrServer res)

354+ `shouldBe` ["server"]

355+ map HTTP.hdrValue (HTTP.retrieveHeaders HTTP.HdrDate res)

356+ `shouldBe` ["date"]

402357

403358 it "streaming echo #249" $ do

404− countVar <- newTVarIO (0 :: Int)

405359 let app req f = f $ responseStream status200 [] $ \write _ -> do

406− let loop = do

407− bs <- getRequestBodyChunk req

360+ let loop = do

361+ bs <- requestBody req

408362 unless (S.null bs) $ do

409− write $ byteString bs

410− atomically $ modifyTVar countVar (+ 1)

363+ write $ fromByteString bs

411364 loop

412− loop

413− withApp defaultSettings app $ withMySocket $ \ms -> do

414− msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

365+ loop

366+ withApp defaultSettings app $ \port -> do

367+ (socket, _addr) <- getSocketTCP "127.0.0.1" port

368+ sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

415369 threadDelay 10000

416− msWrite ms "5\r\nhello\r\n0\r\n\r\n"

417− atomically $ do

418− count <- readTVar countVar

419− check $ count >= 1

420− bs <- safeRecv (msSocket ms) 4096 -- must not use msRead

370+ sendAll socket "5\r\nhello\r\n0\r\n\r\n"

371+ bs <- safeRecv socket 4096

421372 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

422373

423374 it "streaming response with length" $ do

424375 let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do

425− replicateM_ 4 $ write $ byteString "Hello"

376+ replicateM_ 4 $ write $ fromByteString "Hello"

426377 withApp defaultSettings app $ \port -> do

427− res <- sendGET $ "http://127.0.0.1:" ++ show port

428− responseBody res `shouldBe` "HelloHelloHelloHello"

429−

430− describe "head requests" $ do

431− let fp = "test/head-response"

432− let app req f =

433− f $ case pathInfo req of

434− ["builder"] -> responseBuilder status200 [] $ error "should never be evaluated"

435− ["streaming"] -> responseStream status200 [] $ \write _ ->

436− write $ error "should never be evaluated"

437− ["file"] -> responseFile status200 [] fp Nothing

438− _ -> error "invalid path"

439− it "builder" $ withApp defaultSettings app $ \port -> do

440− res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

441− responseBody res `shouldBe` ""

442− it "streaming" $ withApp defaultSettings app $ \port -> do

443− res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

444− responseBody res `shouldBe` ""

445− it "file, no range" $ withApp defaultSettings app $ \port -> do

446− bs <- S.readFile fp

447− res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

448− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs)

449− it "file, with range" $ withApp defaultSettings app $ \port -> do

450− res <- sendHEADwH

451− (concat ["http://127.0.0.1:", show port, "/file"])

452− [(hRange, "bytes=0-1")]

453− getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2"

378+ Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port)

379+ HTTP.rspBody res `shouldBe` "HelloHelloHelloHello"

454380

455381consumeBody :: IO ByteString -> IO [ByteString]

456382consumeBody body =

warp/test/SendFileSpec.hsdeleted−116

@@ -1,116 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module SendFileSpec where

4−

5−import Control.Exception

6−import Control.Monad (when)

7−import Data.ByteString (ByteString)

8−import qualified Data.ByteString as BS

9−import Network.Wai.Handler.Warp.Buffer

10−import Network.Wai.Handler.Warp.SendFile

11−import Network.Wai.Handler.Warp.Types

12−import System.Directory

13−import System.Exit

14−import qualified System.IO as IO

15−import System.Process (system)

16−import Test.Hspec

17−

18−main :: IO ()

19−main = hspec spec

20−

21−spec :: Spec

22−spec = do

23− describe "packHeader" $ do

24− it "returns how much the buffer is consumed (1)" $

25− tryPackHeader 10 ["foo"] `shouldReturn` 3

26− it "returns how much the buffer is consumed (2)" $

27− tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6

28− it "returns how much the buffer is consumed (3)" $

29− tryPackHeader 10 ["0123456789"] `shouldReturn` 0

30− it "returns how much the buffer is consumed (4)" $

31− tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0

32− it "returns how much the buffer is consumed (5)" $

33− tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3

34− it "returns how much the buffer is consumed (6)" $

35− tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5

36−

37− it "sends headers correctly (1)" $

38− tryPackHeader2 10 ["foo"] "" `shouldReturn` True

39− it "sends headers correctly (2)" $

40− tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True

41− it "sends headers correctly (3)" $

42− tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True

43− it "sends headers correctly (4)" $

44− tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True

45− it "sends headers correctly (5)" $

46− tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True

47− it "sends headers correctly (6)" $

48− tryPackHeader2 10 ["012345678901234567890123456789012", "34"] "012345678901234567890123456789" `shouldReturn` True

49−

50− describe "readSendFile" $ do

51− it "sends a file correctly (1)" $

52− tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess

53− it "sends a file correctly (2)" $

54− tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess

55− it "sends a file correctly (3)" $

56− tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess

57−

58−tryPackHeader :: Int -> [ByteString] -> IO Int

59−tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf ->

60− packHeader buf siz send hook hdrs 0

61− where

62− send _ = return ()

63− hook = return ()

64−

65−tryPackHeader2 :: Int -> [ByteString] -> ByteString -> IO Bool

66−tryPackHeader2 siz hdrs ans = bracket setup teardown $ \buf -> do

67− _ <- packHeader buf siz send hook hdrs 0

68− checkFile outputFile ans

69− where

70− setup = allocateBuffer siz

71− teardown buf = freeBuffer buf >> removeFileIfExists outputFile

72− outputFile = "tempfile"

73− send = BS.appendFile outputFile

74− hook = return ()

75−

76−tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO ExitCode

77−tryReadSendFile siz off len hdrs = bracket setup teardown $ \buf -> do

78− mapM_ (BS.appendFile expectedFile) hdrs

79− copyfile inputFile expectedFile off len

80− readSendFile buf siz send fid off len hook hdrs

81− compareFiles expectedFile outputFile

82− where

83− hook = return ()

84− setup = allocateBuffer siz

85− teardown buf = do

86− freeBuffer buf

87− removeFileIfExists outputFile

88− removeFileIfExists expectedFile

89− inputFile = "test/inputFile"

90− outputFile = "outputFile"

91− expectedFile = "expectedFile"

92− fid = FileId inputFile Nothing

93− send = BS.appendFile outputFile

94−

95−checkFile :: FilePath -> ByteString -> IO Bool

96−checkFile path bs = do

97− exist <- doesFileExist path

98− if exist then do

99− bs' <- BS.readFile path

100− return $ bs == bs'

101− else

102− return $ bs == ""

103−

104−compareFiles :: FilePath -> FilePath -> IO ExitCode

105−compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2

106−

107−copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO ()

108−copyfile src dst off len =

109− IO.withBinaryFile src IO.ReadMode $ \h -> do

110− IO.hSeek h IO.AbsoluteSeek off

111− BS.hGet h (fromIntegral len) >>= BS.appendFile dst

112−

113−removeFileIfExists :: FilePath -> IO ()

114−removeFileIfExists file = do

115− exist <- doesFileExist file

116− when exist $ removeFile file

warp/test/WithApplicationSpec.hsdeleted−45

@@ -1,45 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module WithApplicationSpec where

4−

5−import Control.Exception

6−import Network.HTTP.Types

7−import Network.Wai

8−import System.Environment

9−import System.Process

10−import Test.Hspec

11−

12−import Network.Wai.Handler.Warp.WithApplication

13−

14−spec :: Spec

15−spec = do

16− runIO $ do

17− unsetEnv "http_proxy"

18− unsetEnv "https_proxy"

19− describe "withApplication" $ do

20− it "runs a wai Application while executing the given action" $ do

21− let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"

22− withApplication mkApp $ \ port -> do

23− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

24− output `shouldBe` "foo"

25−

26− it "does not propagate exceptions from the server to the executing thread" $ do

27− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

28− withApplication mkApp $ \ port -> do

29− output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""

30− output `shouldContain` "Something went wron"

31−

32− describe "testWithApplication" $ do

33− it "propagates exceptions from the server to the executing thread" $ do

34− let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"

35− (testWithApplication mkApp $ \ port -> do

36− readProcess "curl" ["-s", "localhost:" ++ show port] "")

37− `shouldThrow` (errorCall "foo")

38−

39−{- The future netwrok library will not export MkSocket.

40− describe "withFreePort" $ do

41− it "closes the socket before exiting" $ do

42− MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

43− return sock

44− readMVar statusMVar `shouldReturn` Closed

45−-}

warp/test/doctests.hs+8−1

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

1+module Main where

2+

13import Test.DocTest

24

35main :: IO ()

4−main = doctest ["Network"]

6+main = doctest [

7+ "-idist/build/autogen/"

8+ , "-optP-include"

9+ , "-optPdist/build/autogen/cabal_macros.h"

10+ , "Network/Wai/Handler/Warp.hs"

11+ ]

warp/test/head-responsedeleted−1

@@ -1 +0,0 @@

1−This is the body

warp/test/inputFiledeleted−100

@@ -1,100 +0,0 @@

1−A acid

2−abacus major

3−abacus pythagoricus

4−A battery

5−abbey counter

6−abbey laird

7−abbey lands

8−abbey lubber

9−abbot cloth

10−Abbott papyrus

11−abb wool

12−A-b-c book

13−A-b-c method

14−abdomino-uterotomy

15−Abdul-baha

16−a-be

17−aberrant duct

18−aberration constant

19−abiding place

20−able-bodied

21−able-bodiedness

22−able-minded

23−able-mindedness

24−able seaman

25−aboli fruit

26−A bond

27−Abor-miri

28−a-borning

29−about-face

30−about ship

31−about-sledge

32−above-cited

33−above-found

34−above-given

35−above-mentioned

36−above-named

37−above-quoted

38−above-reported

39−above-said

40−above-water

41−above-written

42−Abraham-man

43−abraum salts

44−abraxas stone

45−Abri audit culture

46−abruptly acuminate

47−abruptly pinnate

48−absciss layer

49−absence state

50−absentee voting

51−absent-minded

52−absent-mindedly

53−absent-mindedness

54−absent treatment

55−absent voter

56−Absent voting

57−absinthe green

58−absinthe oil

59−absorption bands

60−absorption circuit

61−absorption coefficient

62−absorption current

63−absorption dynamometer

64−absorption factor

65−absorption lines

66−absorption pipette

67−absorption screen

68−absorption spectrum

69−absorption system

70−A b station

71−abstinence theory

72−abstract group

73−Abt system

74−abundance declaree

75−aburachan seed

76−abutment arch

77−abutment pier

78−abutting joint

79−acacia veld

80−academy blue

81−academy board

82−academy figure

83−acajou balsam

84−acanthosis nigricans

85−acanthus family

86−acanthus leaf

87−acaroid resin

88−Acca larentia

89−acceleration note

90−accelerator nerve

91−accent mark

92−acceptance bill

93−acceptance house

94−acceptance supra protest

95−acceptor supra protest

96−accession book

97−accession number

98−accession service

99−access road

100−accident insurance

warp/warp.cabal+59−154

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

11Name: warp

2−Version: 3.3.9

2+Version: 3.0.13.1

33Synopsis: A fast, light-weight web server for WAI applications.

44License: MIT

55License-file: LICENSE

@@ -8,18 +8,12 @@ Maintainer: michael@snoyman.com

88Homepage: http://github.com/yesodweb/wai

99Category: Web, Yesod

1010Build-Type: Simple

11−Cabal-Version: >= 1.10

11+Cabal-Version: >=1.8

1212Stability: Stable

13−description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.

14− For HTTP\/2, Warp supports direct and ALPN (in TLS)

15− but not upgrade.

16− API docs and the README are available at

17− <http://www.stackage.org/package/warp>.

13+description: API docs and the README are available at <http://www.stackage.org/package/warp>.

1814extra-source-files: attic/hex

1915 ChangeLog.md

2016 README.md

21− test/head-response

22− test/inputFile

2317

2418Flag network-bytestring

2519 Default: False

@@ -32,58 +26,48 @@ Flag warp-debug

3226 Description: print debug output. not suitable for production

3327 Default: False

3428

29+Flag use-bytestring-builder

30+ description: Use bytestring-builder package

31+ default: False

32+

3533Library

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

34+ Build-Depends: base >= 3 && < 5

3735 , array

38− , async

39− , auto-update >= 0.1.3 && < 0.2

40− , bsb-http-chunked < 0.1

36+ , auto-update >= 0.1.1 && < 0.2

37+ , blaze-builder >= 0.3.3 && < 0.5

4138 , bytestring >= 0.9.1.4

4239 , case-insensitive >= 0.2

43− , containers

4440 , ghc-prim

45− , hashable

46− , http-date

47− , http-types >= 0.12

48− , http2 >= 2.0 && < 2.1

41+ , http-types >= 0.8.5

4942 , iproute >= 1.3.1

5043 , simple-sendfile >= 0.2.7 && < 0.3

51− , stm >= 2.3

52− , streaming-commons >= 0.1.10

53− , text

54− , time-manager

5544 , unix-compat >= 0.2

45+ , wai >= 3.0 && < 3.1

46+ , text

47+ , streaming-commons >= 0.1.10

5648 , vault >= 0.3

57− , wai >= 3.2 && < 3.3

58− , word8

59− , x509

60− if impl(ghc < 8)

61− Build-Depends: semigroups

49+ , stm >= 2.3

6250 if flag(network-bytestring)

6351 Build-Depends: network >= 2.2.1.5 && < 2.2.3

6452 , network-bytestring >= 0.1.3 && < 0.1.4

6553 else

6654 Build-Depends: network >= 2.3

55+ if flag(use-bytestring-builder)

56+ Build-Depends: bytestring < 0.10.2.0

57+ , bytestring-builder

58+ else

59+ Build-Depends: bytestring >= 0.10.2.0

6760 Exposed-modules: Network.Wai.Handler.Warp

61+ Network.Wai.Handler.Warp.Buffer

62+ Network.Wai.Handler.Warp.Timeout

6863 Network.Wai.Handler.Warp.Internal

69− Other-modules: Network.Wai.Handler.Warp.Buffer

70− Network.Wai.Handler.Warp.Conduit

64+ Other-modules: Network.Wai.Handler.Warp.Conduit

7165 Network.Wai.Handler.Warp.Counter

7266 Network.Wai.Handler.Warp.Date

7367 Network.Wai.Handler.Warp.FdCache

74− Network.Wai.Handler.Warp.File

75− Network.Wai.Handler.Warp.FileInfoCache

76− Network.Wai.Handler.Warp.HashMap

77− Network.Wai.Handler.Warp.HTTP2

78− Network.Wai.Handler.Warp.HTTP2.File

79− Network.Wai.Handler.Warp.HTTP2.PushPromise

80− Network.Wai.Handler.Warp.HTTP2.Request

81− Network.Wai.Handler.Warp.HTTP2.Response

82− Network.Wai.Handler.Warp.HTTP2.Types

8368 Network.Wai.Handler.Warp.Header

8469 Network.Wai.Handler.Warp.IO

85− Network.Wai.Handler.Warp.Imports

86− Network.Wai.Handler.Warp.PackInt

70+ Network.Wai.Handler.Warp.IORef

8771 Network.Wai.Handler.Warp.ReadInt

8872 Network.Wai.Handler.Warp.Recv

8973 Network.Wai.Handler.Warp.Request

@@ -95,7 +79,6 @@ Library

9579 Network.Wai.Handler.Warp.Settings

9680 Network.Wai.Handler.Warp.Types

9781 Network.Wai.Handler.Warp.Windows

98− Network.Wai.Handler.Warp.WithApplication

9982 Paths_warp

10083 Ghc-Options: -Wall

10184

@@ -103,167 +86,89 @@ Library

10386 Cpp-Options: -DWARP_DEBUG

10487 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

10588 Cpp-Options: -DSENDFILEFD

89+ Build-Depends: hashable

90+ Other-modules: Network.Wai.Handler.Warp.MultiMap

10691 if os(windows)

10792 Cpp-Options: -DWINDOWS

10893 Build-Depends: time

94+ , old-locale

10995 else

11096 Build-Depends: unix

111− Other-modules: Network.Wai.Handler.Warp.MultiMap

112− if impl(ghc >= 8)

113− Default-Extensions: Strict StrictData

114− Default-Language: Haskell2010

97+ , http-date

11598

11699Test-Suite doctest

117− buildable: False

118100 Type: exitcode-stdio-1.0

119101 HS-Source-Dirs: test

120102 Ghc-Options: -threaded -Wall

121103 Main-Is: doctests.hs

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

123− , doctest >= 0.10.1

124− if os(windows)

125− Buildable: False

126− if impl(ghc >= 8)

127− Default-Extensions: Strict StrictData

128− Default-Language: Haskell2010

104+ Build-Depends: base

105+ , doctest >= 0.9.3

129106

130107Test-Suite spec

131108 Main-Is: Spec.hs

132− Other-modules: BufferPoolSpec

133− ConduitSpec

109+ Other-modules: ConduitSpec

134110 ExceptionSpec

135111 FdCacheSpec

136− FileSpec

112+ MultiMapSpec

137113 ReadIntSpec

138114 RequestSpec

139115 ResponseHeaderSpec

140116 ResponseSpec

141117 RunSpec

142− SendFileSpec

143− WithApplicationSpec

144− HTTP

145− Network.Wai.Handler.Warp

146− Network.Wai.Handler.Warp.Buffer

147− Network.Wai.Handler.Warp.Conduit

148− Network.Wai.Handler.Warp.Counter

149− Network.Wai.Handler.Warp.Date

150− Network.Wai.Handler.Warp.FdCache

151− Network.Wai.Handler.Warp.File

152− Network.Wai.Handler.Warp.FileInfoCache

153− Network.Wai.Handler.Warp.HTTP2

154− Network.Wai.Handler.Warp.HTTP2.File

155− Network.Wai.Handler.Warp.HTTP2.PushPromise

156− Network.Wai.Handler.Warp.HTTP2.Request

157− Network.Wai.Handler.Warp.HTTP2.Response

158− Network.Wai.Handler.Warp.HTTP2.Types

159− Network.Wai.Handler.Warp.HashMap

160− Network.Wai.Handler.Warp.Header

161− Network.Wai.Handler.Warp.IO

162− Network.Wai.Handler.Warp.Imports

163− Network.Wai.Handler.Warp.MultiMap

164− Network.Wai.Handler.Warp.PackInt

165− Network.Wai.Handler.Warp.ReadInt

166− Network.Wai.Handler.Warp.Recv

167− Network.Wai.Handler.Warp.Request

168− Network.Wai.Handler.Warp.RequestHeader

169− Network.Wai.Handler.Warp.Response

170− Network.Wai.Handler.Warp.ResponseHeader

171− Network.Wai.Handler.Warp.Run

172− Network.Wai.Handler.Warp.SendFile

173− Network.Wai.Handler.Warp.Settings

174− Network.Wai.Handler.Warp.Types

175− Network.Wai.Handler.Warp.Windows

176− Network.Wai.Handler.Warp.WithApplication

177− Paths_warp

178−

179118 Hs-Source-Dirs: test, .

180119 Type: exitcode-stdio-1.0

181120

182− Ghc-Options: -Wall -threaded

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

184− , HUnit

185− , QuickCheck

121+ Ghc-Options: -Wall

122+ Build-Depends: base >= 4 && < 5

186123 , array

187− , async

188124 , auto-update

189− , bsb-http-chunked < 0.1

125+ , blaze-builder >= 0.3.3 && < 0.5

190126 , bytestring >= 0.9.1.4

191127 , case-insensitive >= 0.2

192− , containers

193− , directory

194128 , ghc-prim

195− , hashable

196− , hspec >= 1.3

197− , http-client

198− , http-date

199− , http-types >= 0.12

200− , http2 >= 2.0 && < 2.1

129+ , HTTP

130+ , http-types >= 0.8.4

201131 , iproute >= 1.3.1

202132 , lifted-base >= 0.1

203− , network

204− , process

205133 , simple-sendfile >= 0.2.4 && < 0.3

206− , stm >= 2.3

207− , streaming-commons >= 0.1.10

208− , text

209− , time

210− , time-manager

134+ , transformers >= 0.2.2

211135 , unix-compat >= 0.2

136+ , wai

137+ , network

138+ , HUnit

139+ , QuickCheck

140+ , hspec >= 1.3

141+ , time

142+ , old-locale

143+ , text

144+ , streaming-commons >= 0.1.10

145+ , async

212146 , vault

213− , wai >= 3.2 && < 3.3

214− , word8

215− , x509

216− -- Build-Tool-Depends: hspec-discover:hspec-discover

217− if impl(ghc < 8)

218− Build-Depends: semigroups

219− , transformers

147+ , stm >= 2.3

148+ if flag(use-bytestring-builder)

149+ Build-Depends: bytestring < 0.10.2.0

150+ , bytestring-builder

151+ else

152+ Build-Depends: bytestring >= 0.10.2.0

220153

221154 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

222155 Cpp-Options: -DSENDFILEFD

223156 Build-Depends: unix

157+ , hashable

158+ , http-date

224159 if os(windows)

225− Cpp-Options: -DWINDOWS

226− Build-Depends: time

227− if impl(ghc >= 8)

228− Default-Extensions: Strict StrictData

229− Default-Language: Haskell2010

160+ Cpp-Options: -DWINDOWS

230161

231162Benchmark parser

232163 Type: exitcode-stdio-1.0

233164 Main-Is: Parser.hs

234− other-modules: Network.Wai.Handler.Warp.Date

235− Network.Wai.Handler.Warp.FdCache

236− Network.Wai.Handler.Warp.FileInfoCache

237− Network.Wai.Handler.Warp.HashMap

238− Network.Wai.Handler.Warp.Imports

239− Network.Wai.Handler.Warp.MultiMap

240− Network.Wai.Handler.Warp.Types

241165 HS-Source-Dirs: bench .

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

243− , auto-update

166+ Build-Depends: base

244167 , bytestring

245− , containers

246− , gauge

247− , hashable

248− , http-date

168+ , criterion

249169 , http-types

250170 , network

251171 , network

252− , time-manager

253− , unix-compat

254− , x509

255− if impl(ghc < 8)

256− Build-Depends: semigroups

257−

258− if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

259− Cpp-Options: -DSENDFILEFD

260− Build-Depends: unix

261− if os(windows)

262− Cpp-Options: -DWINDOWS

263− Build-Depends: time

264− if impl(ghc >= 8)

265− Default-Extensions: Strict StrictData

266− Default-Language: Haskell2010

267172

268173Source-Repository head

269174 Type: git