warp 1.1.0.1 → 3.4.15
raw patch · 64 files changed
Files
- ChangeLog.md +652/−0
- LICENSE +17/−22
- Network/Wai/Handler/Warp.hs +620/−782
- Network/Wai/Handler/Warp/Buffer.hs +59/−0
- Network/Wai/Handler/Warp/Conduit.hs +172/−0
- Network/Wai/Handler/Warp/Counter.hs +58/−0
- Network/Wai/Handler/Warp/Date.hs +49/−0
- Network/Wai/Handler/Warp/FdCache.hs +158/−0
- Network/Wai/Handler/Warp/File.hs +212/−0
- Network/Wai/Handler/Warp/FileInfoCache.hs +122/−0
- Network/Wai/Handler/Warp/HTTP1.hs +306/−0
- Network/Wai/Handler/Warp/HTTP2.hs +172/−0
- Network/Wai/Handler/Warp/HTTP2/File.hs +33/−0
- Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +33/−0
- Network/Wai/Handler/Warp/HTTP2/Request.hs +149/−0
- Network/Wai/Handler/Warp/HTTP2/Response.hs +152/−0
- Network/Wai/Handler/Warp/HTTP2/Types.hs +81/−0
- Network/Wai/Handler/Warp/HashMap.hs +36/−0
- Network/Wai/Handler/Warp/Header.hs +122/−0
- Network/Wai/Handler/Warp/IO.hs +51/−0
- Network/Wai/Handler/Warp/Imports.hs +39/−0
- Network/Wai/Handler/Warp/Internal.hs +143/−0
- Network/Wai/Handler/Warp/MultiMap.hs +91/−0
- Network/Wai/Handler/Warp/PackInt.hs +47/−0
- Network/Wai/Handler/Warp/ReadInt.hs +35/−0
- Network/Wai/Handler/Warp/Request.hs +343/−0
- Network/Wai/Handler/Warp/RequestHeader.hs +138/−0
- Network/Wai/Handler/Warp/Response.hs +579/−0
- Network/Wai/Handler/Warp/ResponseHeader.hs +75/−0
- Network/Wai/Handler/Warp/Run.hs +538/−0
- Network/Wai/Handler/Warp/SendFile.hs +156/−0
- Network/Wai/Handler/Warp/Settings.hs +463/−0
- Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
- Network/Wai/Handler/Warp/Types.hs +222/−0
- Network/Wai/Handler/Warp/Windows.hs +30/−0
- Network/Wai/Handler/Warp/WithApplication.hs +107/−0
- README.md +3/−0
- Timeout.hs +0/−66
- attic/hex +1/−0
- bench/Parser.hs +300/−0
- test/BufferSpec.hs +38/−0
- test/ConduitSpec.hs +69/−0
- test/ConnectionSpec.hs +81/−0
- test/EarlyHintsSpec.hs +72/−0
- test/ExceptionSpec.hs +68/−0
- test/FdCacheSpec.hs +27/−0
- test/FileSpec.hs +132/−0
- test/GracefulShutdownSpec.hs +83/−0
- test/HTTP.hs +41/−0
- test/PackIntSpec.hs +14/−0
- test/ReadIntSpec.hs +28/−0
- test/RequestSpec.hs +169/−0
- test/ResponseHeaderSpec.hs +49/−0
- test/ResponseSpec.hs +97/−0
- test/RunSpec.hs +518/−0
- test/SendFileSpec.hs +120/−0
- test/ServerStateSpec.hs +58/−0
- test/Spec.hs +1/−0
- test/WithApplicationSpec.hs +52/−0
- test/doctests.hs +4/−0
- test/head-response +1/−0
- test/inputFile +100/−0
- test/main.hs +0/−121
- warp.cabal +362/−59
+ ChangeLog.md view
@@ -0,0 +1,652 @@+# ChangeLog for warp++## 3.4.15++* Support `103 Early Hints` over HTTP/2: the HTTP/2 handler installs+ `requestSendEarlyHints`, so a WAI application can emit informational responses+ ahead of the final response.+ [#1085](https://github.com/yesodweb/wai/pull/1085).+* Rework keep alive logic for HTTP/1.X so connections won't be automatically+ closed on HEAD requests anymore. Should conform more to spec in general.+ Should also reliably close connection when user created `Response` headers+ contain a `Connection: close` entry (HTTP/1.1).+ [#1086](https://github.com/yesodweb/wai/pull/1086)+* Replace multiline header value support with sanitizing newlines and NUL bytes+ with spaces. (as per RFC 9110 section 5.5)+ [#1086](https://github.com/yesodweb/wai/pull/1086)+* Size for responses in `Maybe Integer` argument of `settingsLogger` now+ consistently and always gives amount of bytes of the sent raw __message body__.+ It will only be `Nothing` when using `responseRaw` (mostly used for websockets)+ [#1086](https://github.com/yesodweb/wai/pull/1086)+ * `responseFile`: no change, gives size of file (part)+ * `responseBuilder/responseLBS`:+ * included the status and header lines, now fixed+ * large `ByteString` chunks would not get counted, now fixed+ * `responseStream`: now counts bytes of body sent+ * `responseRaw`: will always be `Nothing`+* Rework internal indexed headers to records for performance and to remove+ dependencies on `array`.+ [#1092](https://github.com/yesodweb/wai/pull/1092) [#1093](https://github.com/yesodweb/wai/pull/1093)++## 3.4.14++* Important bugfix to not deadlock on empty file descriptors if the cause of+ the file descriptor exhaustion is outside of the server's control.+ (i.e. the server does not have any running connections and can't use a file+ descriptor to create the next connection)+ [#1084](https://github.com/yesodweb/wai/pull/1084)++## 3.4.13.1++* Bugfix to fall back to "blocking `recv`" when on Windows systems and when+ using `network < 3.2.2`.+ [#1077](https://github.com/yesodweb/wai/pull/1077)++## 3.4.13++* Change graceful shutdown logic to stop accepting data from idle connections,+ but to wait for busy `Application`s, adding `Connection: close` headers to+ responses if the server is shutting down.+ This should make sure the server doesn't wait for idle keep-alive connections.+* Expose a broader way to access internal state like the open connection `Counter`+ and whether the server is currently `ShuttingDown` or not.+ Users can use `makeSettingsAndServerState` to get a `ServerState` while+ making `defaultSettings`.+ [#1071](https://github.com/yesodweb/wai/pull/1071)++## 3.4.12++* Respond with `Connection: close` header if connection is to be closed after a request.+ [#958](https://github.com/yesodweb/wai/pull/958)++## 3.4.11++* Expose a way to access the open connection `Counter` with `makeSettingsAndCounter`,+ and `getCount` to be able to monitor the current open connections.+* Added getter function to get the open connection counter from the `Settings` with+ `getOpenConnectionCounter`.+ [#1050](https://github.com/yesodweb/wai/pull/1050)++## 3.4.10++* Using newest dependencies++## 3.4.9++* New flag `include-warp-version` can be disabled to remove dependency on `Paths_warp`.+ [#1044](https://github.com/yesodweb/wai/pull/1044)++## 3.4.8++* Label the internal hack thread on Windows used to make socket+ listening interruptible.++## 3.4.7++* Using time-manager >= 0.2.++## 3.4.6++* Using `withHandle` of time-manager.++## 3.4.5++* Rethrowing asynchronous exceptions and preventing callsing+ `connClose` twice.+ [#1013](https://github.com/yesodweb/wai/pull/1013)++## 3.4.4++* Removing `unliftio`.++## 3.4.3++* Waiting untill the number of FDs desreases on EMFILE.+ [#1009](https://github.com/yesodweb/wai/pull/1009)++## 3.4.2++* serveConnection is re-exported from the Internal module.+ [#1007](https://github.com/yesodweb/wai/pull/1007)++## 3.4.1++* Using time-manager v0.1.0, and auto-update v0.2.0.+ [#986](https://github.com/yesodweb/wai/pull/986)++## 3.4.0++* Reworked request lines (`CRLF`) parsing: [#968](https://github.com/yesodweb/wai/pulls)+ * We do not accept multiline headers anymore.+ ([`RFC 7230`](https://www.rfc-editor.org/rfc/rfc7230#section-3.2.4) deprecated it 10 years ago)+ * Reworked request lines (`CRLF`) parsing to not unnecessarily copy bytestrings.+* Using http2 v5.1.0.+* `fourmolu` is used as an official formatter.++## 3.3.31++* Supporting http2 v5.0.++## 3.3.30++* Length of `ResponseBuilder` responses will now also be passed to the logger.+ [#946](https://github.com/yesodweb/wai/pull/946)+* Using `If-(None-)Match` headers simultaneously with `If-(Un)Modified-Since` headers now+ follow the RFC 9110 standard. So `If-(Un)Modified-Since` headers will be correctly ignored+ if their respective `-Match` counterpart is also present in the request headers.+ [#945](https://github.com/yesodweb/wai/pull/945)+* Fixed adding superfluous `Server` header when using HTTP/2.0 if response already has it.+ [#943](https://github.com/yesodweb/wai/pull/943)++## 3.3.29++* Preparing coming "http2" v4.2.0.++## 3.3.28++* Fix for the "-x509" flag+ [#935](https://github.com/yesodweb/wai/pull/935)++## 3.3.27++* Fixing busy loop due to eMFILE+ [#933](https://github.com/yesodweb/wai/pull/933)++## 3.3.26++* Using crypton instead of cryptonite.+ [#931](https://github.com/yesodweb/wai/pull/931)++## 3.3.25++* Catching up the signature change of openFd in the unix package v2.8.+ [#926](https://github.com/yesodweb/wai/pull/926)++## 3.3.24++* Switching the version of the "recv" package from 0.0.x to 0.1.x.++## 3.3.23++* Add `setAccept` for hooking the socket `accept` call.+ [#912](https://github.com/yesodweb/wai/pull/912)+* Removed some package dependencies from test suite+ [#902](https://github.com/yesodweb/wai/pull/902)+* Factored out `Network.Wai.Handler.Warp.Recv` to its own package `recv`.+ [#899](https://github.com/yesodweb/wai/pull/899)++## 3.3.22++* Creating a bigger buffer when the current one is too small to fit the Builder+ [#895](https://github.com/yesodweb/wai/pull/895)+* Using InvalidRequest instead of HTTP2Error+ [#890](https://github.com/yesodweb/wai/pull/890)++## 3.3.21++* Support GHC 9.4 [#889](https://github.com/yesodweb/wai/pull/889)++## 3.3.20++* Adding "x509" flag.+ [#871](https://github.com/yesodweb/wai/pull/871)++## 3.3.19++* Allowing the eMFILE exception in acceptNewConnection.+ [#831](https://github.com/yesodweb/wai/pull/831)++## 3.3.18++* Tidy up HashMap and MultiMap [#864](https://github.com/yesodweb/wai/pull/864)+* Support GHC 9.2 [#863](https://github.com/yesodweb/wai/pull/863)++## 3.3.17++* Modify exception handling to swallow async exceptions in forked thread [#850](https://github.com/yesodweb/wai/issues/850)+* Switch default forking function to not install the global exception handler (minor optimization) [#851](https://github.com/yesodweb/wai/pull/851)++## 3.3.16++* Move exception handling over to `unliftio` for better async exception support [#845](https://github.com/yesodweb/wai/issues/845)++## 3.3.15++* Using http2 v3.++## 3.3.14++* Drop support for GHC < 8.2.+* Fix header length calculation for `settingsMaxTotalHeaderLength`+ [#838](https://github.com/yesodweb/wai/pull/838)+* UTF-8 encoding in `exceptionResponseForDebug`.+ [#836](https://github.com/yesodweb/wai/pull/836)++## 3.3.13++* pReadMaker is exported from the Internal module.++## 3.3.12++* Fixing HTTP/2 logging relating to status and push.+* Adding QUIC constructor to Transport.++## 3.3.11++* Adding setAltSvc.+ [#801](https://github.com/yesodweb/wai/pull/801)+* Fixing timeout of builder for HTTP/1.1.+ [#800](https://github.com/yesodweb/wai/pull/800)+* `http2server` and `withII` are exported from `Internal` module.++## 3.3.10++* Convert ResourceVanished error to ConnectionClosedByPeer exception+ [#795](https://github.com/yesodweb/wai/pull/795)+* Expand the documentation for `setTimeout`.+ [#796](https://github.com/yesodweb/wai/pull/796)++## 3.3.9++* Don't insert Last-Modified: if exists.+ [#791](https://github.com/yesodweb/wai/pull/791)++## 3.3.8++* Maximum header size is configurable.+ [#781](https://github.com/yesodweb/wai/pull/781)+* Ignoring an exception from shutdown (gracefulClose).++## 3.3.7++* InvalidArgument (Bad file descriptor) is ignored in `receive`.+ [#787](https://github.com/yesodweb/wai/pull/787)++## 3.3.6++* Fixing a bug of thread killed in the case of event source with+ HTTP/2 (fixing #692 and #785)+* New APIs: clientCertificate to get client's certificate+ [#783](https://github.com/yesodweb/wai/pull/783)++## 3.3.5++* New APIs: setGracefulCloseTimeout1 and setGracefulCloseTimeout2.+ For HTTP/1.x, connections are closed immediately by default.+ gracefullClose is used for HTTP/2 by default.+ [#782](https://github.com/yesodweb/wai/pull/782)++## 3.3.4++* Setting isSecure of HTTP/2 correctly.++## 3.3.3++* Calling setOnException in HTTP/2.+ [#771](https://github.com/yesodweb/wai/pull/771)++## 3.3.2++* Fixing a bug of HTTP/2 without fd cache.++## 3.3.1++* Using gracefullClose of network 3.1.1 or later if available.+* If the first line of an HTTP request is really invalid,+ don't send an error response++## 3.3.0++* Switching from the original implementation to HTTP/2 server library.+ [#754](https://github.com/yesodweb/wai/pull/754)+* Breaking change: The type of `http2dataTrailers` is now+ `HTTP2Data -> TrailersMaker`.++## 3.2.28++* Using the Strict and StrictData language extensions for GHC >8.+ [#752](https://github.com/yesodweb/wai/pull/752)+* System.TimeManager is now in a separate package: time-manager.+ [#750](https://github.com/yesodweb/wai/pull/750)+* Fixing a bug of ALPN.+* Introducing the half closed state for HTTP/2.+ [#717](https://github.com/yesodweb/wai/pull/717)++## 3.2.27++* Internally, use `lookupEnv` instead of `getEnvironment` to get the+ value of the `PORT` environment variable+ [#736](https://github.com/yesodweb/wai/pull/736)+* Throw 413 for too large payload+* Throw 431 for too large headers+ [#741](https://github.com/yesodweb/wai/pull/741)+* Use exception response handler in HTTP/2 & improve connection preservation+ in HTTP/1.x if uncaught exceptions are thrown in an `Application`.+ [#738](https://github.com/yesodweb/wai/pull/738)++## 3.2.26++* Support network package version 3++## 3.2.25++* Removing Connection: and Transfer-Encoding: from HTTP/2+ response header+ [#707](https://github.com/yesodweb/wai/pull/707)++## 3.2.24++* Fix HTTP2 unwanted GoAways on late WindowUpdate frames.+ [#711](https://github.com/yesodweb/wai/pull/711)++## 3.2.23++* Log real requsts when an app throws an error.+ [#698](https://github.com/yesodweb/wai/pull/698)++## 3.2.22++* Fixing large request body in HTTP/2.++## 3.2.21++* Fixing HTTP/2's timeout handler in request's vault.++## 3.2.20++* Fixing large request body in HTTP/2+ [#593](https://github.com/yesodweb/wai/issues/593)++## 3.2.19++* Fixing 0-byte request body in HTTP/2+ [#597](https://github.com/yesodweb/wai/issues/597)+ [#679](https://github.com/yesodweb/wai/issues/679)++## 3.2.18.2++* Replace dependency on `blaze-builder` with `bsb-http-chunked`++## 3.2.18.1++* Fix benchmark compilation [#681](https://github.com/yesodweb/wai/issues/681)++## 3.2.18++* Make `testWithApplicationSettings` actually use the settings passed.+ [#677](https://github.com/yesodweb/wai/pull/677).++## 3.2.17+* Add support for windows thread block hack and closeOnExec to TLS.+ [#674](https://github.com/yesodweb/wai/pull/674).++## 3.2.16++* In `testWithApplication`, don't `throwTo` ignorable exceptions+ [#671](https://github.com/yesodweb/wai/issues/671), and+ reuse `bindRandomPortTCP`++## 3.2.15++* Address space leak from exception handlers+ [#649](https://github.com/yesodweb/wai/issues/649)++## 3.2.14++* Support streaming-commons 0.2+* Warnings cleanup++## 3.2.13++* Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624)+* Guarantee atomicity of WINDOW_UPDATE increments [622](https://github.com/yesodweb/wai/pull/622)+* Relax HTTP2 headers check [621](https://github.com/yesodweb/wai/pull/621)++## 3.2.12++* 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)++## 3.2.11.2++* Don't throw exceptions when closing a keep-alive connection+ [#618](https://github.com/yesodweb/wai/issues/618)++## 3.2.11.1++* Move exception handling to top of thread (fixes+ [#613](https://github.com/yesodweb/wai/issues/613))++## 3.2.11++* Fixing 10 HTTP2 bugs pointed out by h2spec v2.++## 3.2.10++* 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)++## 3.2.9++* Fixing a space leak. [#586](https://github.com/yesodweb/wai/pull/586)++## 3.2.8++* Fixing HTTP2 requestBodyLength. [#573](https://github.com/yesodweb/wai/pull/573)+* Making HTTP/2 :path optional for the CONNECT method. [#572](https://github.com/yesodweb/wai/pull/572)+* Adding new APIs for HTTP/2 trailers: http2dataTrailers and modifyHTTP2Data [#566](https://github.com/yesodweb/wai/pull/566)++## 3.2.7++* Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data [#510](https://github.com/yesodweb/wai/pull/510)+* Better accept(2) error handling [#553](https://github.com/yesodweb/wai/pull/553)+* Adding getGracefulShutdownTimeout.+* Add {test,}withApplicationSettings [#531](https://github.com/yesodweb/wai/pull/531)++## 3.2.6++* Using token based APIs of http2 1.6.++## 3.2.5++* Ignoring errors from setSocketOption. [#526](https://github.com/yesodweb/wai/issues/526).++## 3.2.4++* Added `withApplication`, `testWithApplication`, and `openFreePort`+* Fixing reaper delay value of file info cache.++## 3.2.3++* Using http2 v1.5.x which much improves the performance of HTTP/2.+* To get rid of the bottleneck of ByteString's (==), a new logic to+ compare header names is introduced.++## 3.2.2++* Throwing errno for pread [#499](https://github.com/yesodweb/wai/issues/499).+* Makeing compilable on Windows [#505](https://github.com/yesodweb/wai/issues/505).++## 3.2.1++* Add back `warpVersion`++## 3.2.0++* Major version up due to breaking changes. This is because the HTTP/2 code+ was started over with Warp 3.1.3 due to performance issue [#470](https://github.com/yesodweb/wai/issues/470).+* runHTTP2, runHTTP2Env, runHTTP2Settings and runHTTP2SettingsSocket were removed from the Network.Wai.Handler.Warp module.+* The performance of HTTP/2 was drastically improved. Now the performance of HTTP/2 is almost the same as that of HTTP/1.1.+* The logic to handle files in HTTP/2 is now identical to that in HTTP/1.1.+* 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).++## 3.1.12++* Setting lower bound for auto-update [#495](https://github.com/yesodweb/wai/issues/495)++## 3.1.11++* Providing a new API: killManager.+* Preventing space leaks due to Weak ThreadId [#488](https://github.com/yesodweb/wai/issues/488)+* Setting upper bound for http2.++## 3.1.10++* `setFileInfoCacheDuration`+* `setLogger`+* `FileInfo`/`getFileInfo`+* Fix: warp-tls strips out the Host request header [#478](https://github.com/yesodweb/wai/issues/478)++## 3.1.9++* Using the new priority queue based on PSQ provided by http2 lib again.++## 3.1.8++* Using the new priority queue based on PSQ provided by http2 lib.++## 3.1.7++* A concatenated Cookie header is prepended to the headers to ensure that it flows pseudo headers. [#454](https://github.com/yesodweb/wai/pull/454)+* Providing a new settings: `setHTTP2Disabled` [#450](https://github.com/yesodweb/wai/pull/450)++## 3.1.6++* Adding back http-types 0.8 support [#449](https://github.com/yesodweb/wai/pull/449)++## 3.1.5++* Using http-types v0.9.+* Fixing build on OpenBSD. [#428](https://github.com/yesodweb/wai/pull/428) [#440](https://github.com/yesodweb/wai/pull/440)+* Fixing build on Windows. [#438](https://github.com/yesodweb/wai/pull/438)++## 3.1.4++* Using newer http2 library to prevent change table size attacks.+* API for HTTP/2 server push and trailers. [#426](https://github.com/yesodweb/wai/pull/426)+* Preventing response splitting attacks. [#435](https://github.com/yesodweb/wai/pull/435)+* Concatenating multiple Cookie: headers in HTTP/2.++## 3.1.3++* Warp now supports blaze-builder v0.4 or later only.+* 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)++## 3.1.2++* Configurable Slowloris size [#418](https://github.com/yesodweb/wai/pull/418)++## 3.1.1++* Fixing a bug of HTTP/2 when no FD cache is used [#411](https://github.com/yesodweb/wai/pull/411)+* Fixing a buffer-pool bug [#406](https://github.com/yesodweb/wai/pull/406) [#407](https://github.com/yesodweb/wai/pull/407)++## 3.1.0++* Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399)+* Cleaning up APIs [#387](https://github.com/yesodweb/wai/issues/387)++## 3.0.13.1++* Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375)++## 3.0.13++* Turn off file descriptor cache by default [#371](https://github.com/yesodweb/wai/issues/371)++## 3.0.12.1++* Fix for: HEAD requests returning non-empty entity body [#369](https://github.com/yesodweb/wai/issues/369)++## 3.0.12++* Only conditionally produce HTTP 100 Continue++## 3.0.11++* Better HEAD support for files [#357](https://github.com/yesodweb/wai/pull/357)++## 3.0.10++* Fix [missing `IORef` tweak](https://github.com/yesodweb/wai/issues/351)+* Disable timeouts as soon as request body is fully consumed. This addresses+ the common case of a non-chunked request body. Previously, we would wait+ until a zero-length `ByteString` is returned, but that is suboptimal for some+ cases. For more information, see [issue+ 351](https://github.com/yesodweb/wai/issues/351).+* Add `pauseTimeout` function++## 3.0.9.3++* Don't serve a 416 status code for 0-length files [keter issue #75](https://github.com/snoyberg/keter/issues/75)+* Don't serve content-length for 416 responses [#346](https://github.com/yesodweb/wai/issues/346)++## 3.0.9.2++Fix support for old versions of bytestring++## 3.0.9.1++Add support for blaze-builder 0.4++## 3.0.9++* Add runEnv: like run but uses $PORT [#334](https://github.com/yesodweb/wai/pull/334)++## 3.0.5.2++* [Pass the Request to settingsOnException handlers when available. #326](https://github.com/yesodweb/wai/pull/326)++## 3.0.5++Support for PROXY protocol, such as used by Amazon ELB TCP. This is useful+since, for example, Amazon ELB HTTP does *not* have support for Websockets.+More information on the protocol [is available from+Amazon](http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol).++## 3.0.4++Added `setFork`.++## 3.0.3++Modify flushing of request bodies. Previously, regardless of the size of the+request body, the entire body would be flushed. When uploading large files to a+web app that does not accept such files (e.g., returns a 413 too large status),+browsers would still send the entire request body and the servers will still+receive it.++The new behavior is to detect if there is a large amount of data still to be+consumed and, if so, immediately terminate the connection. In the case of+chunked request bodies, up to a maximum number of bytes is consumed before the+connection is terminated.++This is controlled by the new setting `setMaximumBodyFlush`. A value of+@Nothing@ will return the original behavior of flushing the entire body.++## 3.0.0++WAI no longer uses conduit for its streaming interface.++## 2.1.0++The `onOpen` and `onClose` settings now provide the `SockAddr` of the client,+and `onOpen` can return a `Bool` which will close the connection. The+`responseRaw` response has been added, which provides a more elegant way to+handle WebSockets than the previous `settingsIntercept`. The old settings+accessors have been deprecated in favor of new setters, which will allow+settings changes to be made in the future without breaking backwards+compatibility.++## 2.0.0++ResourceT is not used anymore. Request and Response is now abstract data types.+To use their constructors, Internal module should be imported.++## 1.3.9++Support for byte range requests.++## 1.3.7++Sockets now have `FD_CLOEXEC` set on them. This behavior is more secure, and+the change should not affect the vast majority of use cases. However, it+appeared that this is buggy and is fixed in 2.0.0.
LICENSE view
@@ -1,25 +1,20 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2010, Suite Solutions. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Network/Wai/Handler/Warp.hs view
@@ -1,782 +1,620 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------- Module : Network.Wai.Handler.Warp--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ A fast, light-weight HTTP server handler for WAI.----------------------------------------------------------------- | A fast, light-weight HTTP server handler for WAI.-module Network.Wai.Handler.Warp- ( -- * Run a Warp server- run- , runSettings- , runSettingsSocket- -- * Settings- , Settings- , defaultSettings- , settingsPort- , settingsHost- , settingsOnException- , settingsTimeout- , settingsIntercept- , settingsManager- -- ** Data types- , HostPreference (..)- -- * Connection- , Connection (..)- , runSettingsConnection- -- * Datatypes- , Port- , InvalidRequest (..)- -- * Internal- , Manager- , withManager- , parseRequest- , sendResponse- , registerKillThread- , bindPort- , pause- , resume- , T.cancel- , T.register- , T.initialize-#if TEST- , takeHeaders-#endif- ) where--import Prelude hiding (catch, lines)-import Network.Wai--import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as SU-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as L-import Network (sClose, Socket)-import Network.Socket- ( accept, Family (..)- , SocketType (Stream), listen, bindSocket, setSocketOption, maxListenQueue- , SockAddr, SocketOption (ReuseAddr)- , AddrInfo(..), AddrInfoFlag(..), defaultHints, getAddrInfo- )-import qualified Network.Socket-import qualified Network.Socket.ByteString as Sock-import Control.Exception- ( bracket, finally, Exception, SomeException, catch- , fromException, AsyncException (ThreadKilled)- , bracketOnError- , IOException- , try- )-import Control.Concurrent (forkIO)-import Data.Maybe (fromMaybe, isJust)--import Data.Typeable (Typeable)--import Control.Monad.Trans.Resource (ResourceT, runResourceT)-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import Data.Conduit.Blaze (builderToByteString)-import Control.Exception.Lifted (throwIO)-import Blaze.ByteString.Builder.HTTP- (chunkedTransferEncoding, chunkedTransferTerminator)-import Blaze.ByteString.Builder- (copyByteString, Builder, toLazyByteString, toByteStringIO, flush)-import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)-import Data.Monoid (mappend, mempty)-import Network.Sendfile--import qualified System.PosixCompat.Files as P--import Control.Monad.IO.Class (liftIO)-import qualified Timeout as T-import Timeout (Manager, registerKillThread, pause, resume)-import Data.Word (Word8)-import Data.List (foldl')-import Control.Monad (forever, when)-import qualified Network.HTTP.Types as H-import qualified Data.CaseInsensitive as CI-import System.IO (hPrint, stderr)-import qualified Data.IORef as I-import Data.String (IsString (..))-import qualified Data.ByteString.Lex.Integral as LI--#if WINDOWS-import Control.Concurrent (threadDelay)-import qualified Control.Concurrent.MVar as MV-import Network.Socket (withSocketsDo)-#endif--import Data.Version (showVersion)-import qualified Paths_warp--warpVersion :: String-warpVersion = showVersion Paths_warp.version---- |------ In order to provide slowloris protection, Warp provides timeout handlers. We--- follow these rules:------ * A timeout is created when a connection is opened.------ * When all request headers are read, the timeout is tickled.------ * Every time at least 2048 bytes of the request body are read, the timeout--- is tickled.------ * The timeout is paused while executing user code. This will apply to both--- the application itself, and a ResponseSource response. The timeout is--- resumed as soon as we return from user code.------ * Every time data is successfully sent to the client, the timeout is tickled.-data Connection = Connection- { connSendMany :: [B.ByteString] -> IO ()- , connSendAll :: B.ByteString -> IO ()- , connSendFile :: FilePath -> Integer -> Integer -> IO () -> IO () -- ^ offset, length- , connClose :: IO ()- , connRecv :: IO B.ByteString- }--socketConnection :: Socket -> Connection-socketConnection s = Connection- { connSendMany = Sock.sendMany s- , connSendAll = Sock.sendAll s- , connSendFile = \fp off len act -> sendfile s fp (PartOfFile off len) act- , connClose = sClose s- , connRecv = Sock.recv s bytesPerRead- }---bindPort :: Int -> HostPreference -> IO Socket-bindPort p s = do- let hints = defaultHints { addrFlags = [AI_PASSIVE- , AI_NUMERICSERV- , AI_NUMERICHOST]- , addrSocketType = Stream }- host =- case s of- Host s' -> Just s'- _ -> Nothing- port = Just . show $ p- addrs <- getAddrInfo (Just hints) host port- -- Choose an IPv6 socket if exists. This ensures the socket can- -- handle both IPv4 and IPv6 if v6only is false.- let addrs4 = filter (\x -> addrFamily x /= AF_INET6) addrs- addrs6 = filter (\x -> addrFamily x == AF_INET6) addrs- addrs' =- case s of- HostIPv4 -> addrs4 ++ addrs6- HostIPv6 -> addrs6 ++ addrs4- _ -> addrs-- tryAddrs (addr1:rest@(_:_)) = - catch- (theBody addr1) - (\(_ :: IOException) -> tryAddrs rest)- tryAddrs (addr1:[]) = theBody addr1- tryAddrs _ = error "bindPort: addrs is empty"- theBody addr = - bracketOnError- (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))- sClose- (\sock -> do- setSocketOption sock ReuseAddr 1- bindSocket sock (addrAddress addr)- listen sock maxListenQueue- return sock- )- tryAddrs addrs'---- | Run an 'Application' on the given port. This calls 'runSettings' with--- 'defaultSettings'.-run :: Port -> Application -> IO ()-run p = runSettings defaultSettings { settingsPort = p }---- | Run a Warp server with the given settings.-runSettings :: Settings -> Application -> IO ()-#if WINDOWS-runSettings set app = withSocketsDo $ do- var <- MV.newMVar Nothing- let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing- _ <- forkIO $ bracket- (bindPort (settingsPort set) (settingsHost set))- (const clean)- (\s -> do- MV.modifyMVar_ var (\_ -> return $ Just s)- runSettingsSocket set s app)- forever (threadDelay maxBound) `finally` clean-#else-runSettings set =- bracket- (bindPort (settingsPort set) (settingsHost set))- sClose .- flip (runSettingsSocket set)-#endif--type Port = Int---- | Same as 'runSettings', but uses a user-supplied socket instead of opening--- one. This allows the user to provide, for example, Unix named socket, which--- can be used when reverse HTTP proxying into your application.------ Note that the 'settingsPort' will still be passed to 'Application's via the--- 'serverPort' record.-runSettingsSocket :: Settings -> Socket -> Application -> IO ()-runSettingsSocket set socket app =- runSettingsConnection set getter app- where- getter = do- (conn, sa) <- accept socket- return (socketConnection conn, sa)--runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()-runSettingsConnection set getConn app = do- let onE = settingsOnException set- port = settingsPort set- tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return- $ settingsManager set- forever $ do- (conn, addr) <- getConn- _ <- forkIO $ do- th <- T.registerKillThread tm- serveConnection set th onE port app conn addr- T.cancel th- return ()--serveConnection :: Settings- -> T.Handle- -> (SomeException -> IO ())- -> Port -> Application -> Connection -> SockAddr -> IO ()-serveConnection settings th onException port app conn remoteHost' =- catch- (finally- (runResourceT serveConnection')- (connClose conn))- onException- where- serveConnection' :: ResourceT IO ()- serveConnection' = do- fromClient <- C.bufferSource $ connSource conn th- serveConnection'' fromClient-- serveConnection'' fromClient = do- env <- parseRequest conn port remoteHost' fromClient- case settingsIntercept settings env of- Nothing -> do- -- Let the application run for as long as it wants- liftIO $ T.pause th- res <- app env-- -- flush the rest of the request body- requestBody env C.$$ CL.sinkNull-- liftIO $ T.resume th- keepAlive <- sendResponse th env conn res- when keepAlive $ serveConnection'' fromClient- Just intercept -> do- liftIO $ T.pause th- intercept fromClient conn--parseRequest :: Connection -> Port -> SockAddr- -> C.BufferedSource IO S.ByteString- -> ResourceT IO Request-parseRequest conn port remoteHost' src = do- headers' <- src C.$$ takeHeaders- parseRequest' conn port headers' remoteHost' src---- FIXME come up with good values here-bytesPerRead, maxTotalHeaderLength :: Int-bytesPerRead = 4096-maxTotalHeaderLength = 50 * 1024--data InvalidRequest =- NotEnoughLines [String]- | BadFirstLine String- | NonHttp- | IncompleteHeaders- | OverLargeHeader- deriving (Show, Typeable, Eq)-instance Exception InvalidRequest--handleExpect :: Connection- -> H.HttpVersion- -> ([H.Header] -> [H.Header])- -> [H.Header]- -> IO [H.Header]-handleExpect _ _ front [] = return $ front []-handleExpect conn hv front (("expect", "100-continue"):rest) = do- connSendAll conn $- if hv == H.http11- then "HTTP/1.1 100 Continue\r\n\r\n"- else "HTTP/1.0 100 Continue\r\n\r\n"- return $ front rest-handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs---- | Parse a set of header lines and body into a 'Request'.-parseRequest' :: Connection- -> Port- -> [ByteString]- -> SockAddr- -> C.BufferedSource IO S.ByteString- -> ResourceT IO Request-parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []-parseRequest' conn port (firstLine:otherLines) remoteHost' src = do- (method, rpath', gets, httpversion) <- parseFirst firstLine- let (host',rpath)- | S.null rpath' = ("", "/")- | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'- | otherwise = ("", rpath')- heads <- liftIO- $ handleExpect conn httpversion id- (map parseHeaderNoAttr otherLines)- let host = fromMaybe host' $ lookup "host" heads- let len0 =- case lookup "content-length" heads of- Nothing -> 0- Just bs -> LI.readDecimal_ bs- let serverName' = takeUntil 58 host -- ':'- rbody <-- if len0 == 0- then return mempty- else do- -- We can't use the standard isolate, as its counter is not- -- kept in a mutable variable.- lenRef <- liftIO $ I.newIORef len0- let isolate = C.Conduit push close- push bs = do- len <- liftIO $ I.readIORef lenRef- let (a, b) = S.splitAt len bs- len' = len - S.length a- liftIO $ I.writeIORef lenRef len'- return $ if len' == 0- then C.Finished (if S.null b then Nothing else Just b) (if S.null a then [] else [a])- else C.Producing isolate [a]- close = return []-- -- Make sure that we don't connect to the source after the- -- isolate conduit closes.- --- -- Here's the issue: we fuse our buffered request body with- -- an isolate conduit which ensures no more than X bytes- -- are read. Suppose we read all X bytes, and then we call- -- requestBody again. What happens?- --- -- Previously, we would try to read one more chunk from the- -- buffered source. This is inherent to conduit: we- -- wouldn't know that the isolate Conduit isn't accepting- -- more data until after we've pushed some data to it. This- -- results in hanging, since there's no data available on- -- the wire.- --- -- Instead, we add a wrapper that checks if the request- -- body has already been depleted before making that first- -- pull.- --- -- Possible optimization: do away with the Conduit- -- entirely. However, this may be less efficient overall,- -- as we'd now have to check the BufferedSource status on- -- each call. Worth looking into.-- wrap src' = C.Source- { C.sourcePull = do- len <- liftIO $ I.readIORef lenRef- if len <= 0- then return C.Closed- else C.sourcePull src'- , C.sourceClose = return ()- }- return $ wrap $ src C.$= isolate- return Request- { requestMethod = method- , httpVersion = httpversion- , pathInfo = H.decodePathSegments rpath- , rawPathInfo = rpath- , rawQueryString = gets- , queryString = H.parseQuery gets- , serverName = serverName'- , serverPort = port- , requestHeaders = heads- , isSecure = False- , remoteHost = remoteHost'- , requestBody = rbody- , vault = mempty- }---takeUntil :: Word8 -> ByteString -> ByteString-takeUntil c bs =- case S.elemIndex c bs of- Just !idx -> SU.unsafeTake idx bs- Nothing -> bs-{-# INLINE takeUntil #-}--parseFirst :: ByteString- -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)-parseFirst s =- case S.split 32 s of -- ' '- [method, query, http'] -> do- let (hfirst, hsecond) = B.splitAt 5 http'- if hfirst == "HTTP/"- then let (rpath, qstring) = S.breakByte 63 query -- '?'- hv =- case hsecond of- "1.1" -> H.http11- _ -> H.http10- in return (method, rpath, qstring, hv)- else throwIO NonHttp- _ -> throwIO $ BadFirstLine $ B.unpack s-{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported--httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder- , colonSpaceBuilder :: Builder-httpBuilder = copyByteString "HTTP/"-spaceBuilder = fromChar ' '-newlineBuilder = copyByteString "\r\n"-transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"-colonSpaceBuilder = copyByteString ": "--headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder-headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}- let !start = httpBuilder- `mappend` copyByteString- (case httpversion of- H.HttpVersion 1 1 -> "1.1"- _ -> "1.0")- `mappend` spaceBuilder- `mappend` fromShow (H.statusCode status)- `mappend` spaceBuilder- `mappend` copyByteString (H.statusMessage status)- `mappend` newlineBuilder- !start' = foldl' responseHeaderToBuilder start (serverHeader responseHeaders)- !end = if isChunked'- then transferEncodingBuilder- else newlineBuilder- in start' `mappend` end--responseHeaderToBuilder :: Builder -> H.Header -> Builder-responseHeaderToBuilder b (x, y) = b- `mappend` copyByteString (CI.original x)- `mappend` colonSpaceBuilder- `mappend` copyByteString y- `mappend` newlineBuilder--checkPersist :: Request -> Bool-checkPersist req- | ver == H.http11 = checkPersist11 conn- | otherwise = checkPersist10 conn- where- ver = httpVersion req- conn = lookup "connection" $ requestHeaders req- checkPersist11 (Just x)- | CI.foldCase x == "close" = False- checkPersist11 _ = True- checkPersist10 (Just x)- | CI.foldCase x == "keep-alive" = True- checkPersist10 _ = False--isChunked :: H.HttpVersion -> Bool-isChunked = (==) H.http11--hasBody :: H.Status -> Request -> Bool-hasBody s req = s /= H.Status 204 "" && s /= H.status304 &&- H.statusCode s >= 200 && requestMethod req /= "HEAD"--sendResponse :: T.Handle- -> Request -> Connection -> Response -> ResourceT IO Bool-sendResponse th req conn r = sendResponse' r- where- version = httpVersion req- isPersist = checkPersist req- isChunked' = isChunked version- needsChunked hs = isChunked' && not (hasLength hs)- isKeepAlive hs = isPersist && (isChunked' || hasLength hs)- hasLength hs = isJust $ lookup "content-length" hs- sendHeader = connSendMany conn . L.toChunks . toLazyByteString-- sendResponse' :: Response -> ResourceT IO Bool- sendResponse' (ResponseFile s hs fp mpart) = do- eres <-- case (LI.readDecimal_ `fmap` lookup "content-length" hs, mpart) of- (Just cl, _) -> return $ Right (hs, cl)- (Nothing, Nothing) -> liftIO $ try $ do- cl <- P.fileSize `fmap` P.getFileStatus fp- return $ addClToHeaders cl- (Nothing, Just part) -> do- let cl = filePartByteCount part- return $ Right $ addClToHeaders cl- case eres of- Left (_ :: SomeException) -> sendResponse' $ responseLBS- H.status404- [("Content-Type", "text/plain")]- "File not found"- Right (lengthyHeaders, cl) -> liftIO $ do- let headers' = headers version s lengthyHeaders- sendHeader $ headers' False- T.tickle th- if hasBody s req then do- case mpart of- Nothing -> connSendFile conn fp 0 cl (T.tickle th)- Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th)- T.tickle th- return isPersist- else- return isPersist- where- addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)-- sendResponse' (ResponseBuilder s hs b)- | hasBody s req = liftIO $ do- toByteStringIO (\bs -> do- connSendAll conn bs- T.tickle th) body- return (isKeepAlive hs)- | otherwise = liftIO $ do- sendHeader $ headers' False- T.tickle th- return isPersist- where- headers' = headers version s hs- needsChunked' = needsChunked hs- body = if needsChunked'- then headers' needsChunked'- `mappend` chunkedTransferEncoding b- `mappend` chunkedTransferTerminator- else headers' False `mappend` b-- sendResponse' (ResponseSource s hs bodyFlush)- | hasBody s req = do- let src = CL.sourceList [headers' needsChunked'] `mappend`- (if needsChunked' then body C.$= chunk else body)- src C.$$ builderToByteString C.=$ connSink conn th- return $ isKeepAlive hs- | otherwise = liftIO $ do- sendHeader $ headers' False- T.tickle th- return isPersist- where- body = fmap (\x -> case x of- C.Flush -> flush- C.Chunk builder -> builder) bodyFlush- headers' = headers version s hs- -- FIXME perhaps alloca a buffer per thread and reuse that in all- -- functions below. Should lessen greatly the GC burden (I hope)- needsChunked' = needsChunked hs- chunk :: C.Conduit Builder IO Builder- chunk = C.Conduit- { C.conduitPush = push- , C.conduitClose = close- }- conduit = C.Conduit push close- push x = return $ C.Producing conduit [chunkedTransferEncoding x]- close = return [chunkedTransferTerminator]--parseHeaderNoAttr :: ByteString -> H.Header-parseHeaderNoAttr s =- let (k, rest) = S.breakByte 58 s -- ':'- restLen = S.length rest- -- FIXME check for colon without following space?- rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": "- then SU.unsafeDrop 2 rest- else rest- in (CI.mk k, rest')--connSource :: Connection -> T.Handle -> C.Source IO ByteString-connSource Connection { connRecv = recv } th =- src- where- src = C.Source- { C.sourcePull = do- bs <- liftIO recv- if S.null bs- then return C.Closed- else do- when (S.length bs >= 2048) $ liftIO $ T.tickle th- return (C.Open src bs)- , C.sourceClose = return ()- }---- | Use 'connSendAll' to send this data while respecting timeout rules.-connSink :: Connection -> T.Handle -> C.Sink B.ByteString IO ()-connSink Connection { connSendAll = send } th =- C.SinkData push close- where- close = liftIO (T.resume th)- push x = do- liftIO $ do- T.resume th- send x- T.pause th- return (C.Processing push close)- -- We pause timeouts before passing control back to user code. This ensures- -- that a timeout will only ever be executed when Warp is in control. We- -- also make sure to resume the timeout after the completion of user code- -- so that we can kill idle connections.-------- The functions below are not warp-specific and could be split out into a---separate package.---- | Various Warp server settings. This is purposely kept as an abstract data--- type so that new settings can be added without breaking backwards--- compatibility. In order to create a 'Settings' value, use 'defaultSettings'--- and record syntax to modify individual records. For example:------ > defaultSettings { settingsTimeout = 20 }-data Settings = Settings- { settingsPort :: Int -- ^ Port to listen on. Default value: 3000- , settingsHost :: HostPreference -- ^ Default value: HostIPv4- , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.- , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30- , settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Connection -> ResourceT IO ())- , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'- }---- | Which host to bind.------ Note: The @IsString@ instance recognizes the following special values:------ * @*@ means @HostAny@------ * @*4@ means @HostIPv4@------ * @*6@ means @HostIPv6@-data HostPreference =- HostAny- | HostIPv4- | HostIPv6- | Host String- deriving (Show, Eq, Ord)--instance IsString HostPreference where- -- The funny code coming up is to get around some irritating warnings from- -- GHC. I should be able to just write:- {-- fromString "*" = HostAny- fromString "*4" = HostIPv4- fromString "*6" = HostIPv6- -}- fromString s'@('*':s) =- case s of- [] -> HostAny- ['4'] -> HostIPv4- ['6'] -> HostIPv6- _ -> Host s'- fromString s = Host s---- | The default settings for the Warp server. See the individual settings for--- the default value.-defaultSettings :: Settings-defaultSettings = Settings- { settingsPort = 3000- , settingsHost = HostIPv4- , settingsOnException = \e ->- case fromException e of- Just x -> go x- Nothing ->- when (go' $ fromException e) $- hPrint stderr e- , settingsTimeout = 30- , settingsIntercept = const Nothing- , settingsManager = Nothing- }- where- go :: InvalidRequest -> IO ()- go _ = return ()- go' (Just ThreadKilled) = False- go' _ = True--type BSEndo = ByteString -> ByteString-type BSEndoList = [ByteString] -> [ByteString]--data THStatus = THStatus- {-# UNPACK #-} !Int -- running total byte count- BSEndoList -- previously parsed lines- BSEndo -- bytestrings to be prepended--takeHeaders :: C.Sink ByteString IO [ByteString]-takeHeaders =- C.sinkState (THStatus 0 id id) takeHeadersPush close- where- close _ = throwIO IncompleteHeaders-{-# INLINE takeHeaders #-}--takeHeadersPush :: THStatus- -> ByteString- -> ResourceT IO (C.SinkStateResult THStatus ByteString [ByteString])-takeHeadersPush (THStatus len _ _ ) _- | len > maxTotalHeaderLength = throwIO OverLargeHeader-takeHeadersPush (THStatus len lines prepend) bs =- case mnl of- -- no newline. prepend entire bs to next line- Nothing -> do- let len' = len + bsLen- return $ C.StateProcessing $ THStatus len' lines (prepend . S.append bs)- Just nl -> do- let end = nl- start = nl + 1- line = prepend (if end > 0- then SU.unsafeTake (checkCR bs end) bs- else S.empty)- if S.null line- -- no more headers- then do- let lines' = lines []- if start < bsLen- then do- let rest = SU.unsafeDrop start bs- return $ C.StateDone (Just rest) lines'- else return $ C.StateDone Nothing lines'- -- more headers- else do- let len' = len + start- lines' = lines . (:) line- if start < bsLen- then do- let more = SU.unsafeDrop start bs- takeHeadersPush (THStatus len' lines' id) more- else return $ C.StateProcessing $ THStatus len' lines' id- where- bsLen = S.length bs- mnl = S.elemIndex 10 bs-{-# INLINE takeHeadersPush #-}--checkCR :: ByteString -> Int -> Int-checkCR bs pos =- let !p = pos - 1- in if '\r' == B.index bs p- then p- else pos-{-# INLINE checkCR #-}---- | Call the inner function with a timeout manager.-withManager :: Int -- ^ timeout in microseconds- -> (Manager -> IO a)- -> IO a-withManager timeout f = do- -- FIXME when stopManager is available, use it- man <- T.initialize timeout- f man--serverHeader :: H.RequestHeaders -> H.RequestHeaders-serverHeader hdrs = case lookup key hdrs of- Nothing -> server : hdrs- Just _ -> hdrs- where- key = "Server"- ver = B.pack $ "Warp/" ++ warpVersion- server = (key, ver)+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++---------------------------------------------------------+--+-- Module : Network.Wai.Handler.Warp+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- A fast, light-weight HTTP server handler for WAI.+--+---------------------------------------------------------++-- | A fast, light-weight HTTP server handler for WAI.+--+-- HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2,+-- Warp supports direct and ALPN (in TLS) but not upgrade.+--+-- Note on slowloris timeouts: to prevent slowloris attacks, timeouts are used+-- at various points in request receiving and response sending. One interesting+-- corner case is partial request body consumption; in that case, Warp's+-- timeout handling is still in effect, and the timeout will not be triggered+-- again. Therefore, it is recommended that once you start consuming the+-- request body, you either:+--+-- * consume the entire body promptly+--+-- * call the 'pauseTimeout' function+--+-- For more information, see <https://github.com/yesodweb/wai/issues/351>.+module Network.Wai.Handler.Warp (+ -- * Run a Warp server++ -- | All of these automatically serve the same 'Application' over HTTP\/1,+ -- HTTP\/1.1, and HTTP\/2.+ run,+ runEnv,+ runSettings,+ runSettingsSocket,++ -- * Settings+ Settings,+ defaultSettings,++ -- ** Setters+ setPort,+ setHost,+ setOnException,+ setOnExceptionResponse,+ setOnOpen,+ setOnClose,+ setTimeout,+ setManager,+ setFdCacheDuration,+ setFileInfoCacheDuration,+ setBeforeMainLoop,+ setNoParsePath,+ setInstallShutdownHandler,+ setServerName,+ setMaximumBodyFlush,+ setFork,+ setAccept,+ setProxyProtocolNone,+ setProxyProtocolRequired,+ setProxyProtocolOptional,+ setSlowlorisSize,+ setHTTP2Disabled,+ setLogger,+ setServerPushLogger,+ setGracefulShutdownTimeout,+ setGracefulCloseTimeout1,+ setGracefulCloseTimeout2,+ setMaxTotalHeaderLength,+ setAltSvc,+ setMaxBuilderResponseBufferSize,++ -- ** Getters+ getPort,+ getHost,+ getOnOpen,+ getOnClose,+ getOnException,+ getGracefulShutdownTimeout,+ getGracefulCloseTimeout1,+ getGracefulCloseTimeout2,+ getOpenConnectionCounter,+ getServerState,++ -- ** Internal server state+ --+ -- Creating 'Settings' with insight into the internal state of the server.+ --+ -- When using 'makeSettingsAndServerState', you will receive the 'ServerState'+ -- that will be used by @warp@ so that you can query things like the+ -- 'currentOpenConnections', and 'currentShuttingDownState'.+ ServerState,+ makeSettingsAndServerState,+ currentOpenConnections,+ currentShuttingDownState,++ -- *** STM versions+ currentOpenConnectionsSTM,+ currentShuttingDownStateSTM,++ -- ** Connection counter+ --+ -- /Deprecated in favor of 'ServerState'/+ makeSettingsAndCounter,+ Counter,+ getCount,++ -- ** Exception handler+ defaultOnException,+ defaultShouldDisplayException,++ -- ** Exception response handler+ defaultOnExceptionResponse,+ exceptionResponseForDebug,++ -- * Data types+ HostPreference,+ Port,+ InvalidRequest (..),++ -- * Utilities+ pauseTimeout,+ FileInfo (..),+ getFileInfo,+#ifdef MIN_VERSION_crypton_x509+ clientCertificate,+#endif+ withApplication,+ withApplicationSettings,+ testWithApplication,+ testWithApplicationSettings,+ openFreePort,++ -- * Version+ warpVersion,++ -- * HTTP/2++ -- ** HTTP2 data+ HTTP2Data,+ http2dataPushPromise,+ http2dataTrailers,+ defaultHTTP2Data,+ getHTTP2Data,+ setHTTP2Data,+ modifyHTTP2Data,++ -- ** Push promise+ PushPromise,+ promisedPath,+ promisedFile,+ promisedResponseHeaders,+ promisedWeight,+ defaultPushPromise,+) where++import Data.Streaming.Network (HostPreference)+import qualified Data.Vault.Lazy as Vault+import Control.Exception (SomeException, throwIO)+#ifdef MIN_VERSION_crypton_x509+import Data.X509+#endif+import qualified Network.HTTP.Types as H+import Network.Socket (SockAddr, Socket)+import Network.Wai (Request, Response, vault)+import System.TimeManager++import Network.Wai.Handler.Warp.Counter (Counter, getCount)+import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.HTTP2.Request (+ getHTTP2Data,+ modifyHTTP2Data,+ setHTTP2Data,+ )+import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Run+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types hiding (getFileInfo)+import Network.Wai.Handler.Warp.WithApplication++-- | Port to listen on. Default value: 3000+--+-- Since 2.1.0+setPort :: Port -> Settings -> Settings+setPort x y = y{settingsPort = x}++-- | Interface to bind to. Default value: HostIPv4+--+-- Since 2.1.0+setHost :: HostPreference -> Settings -> Settings+setHost x y = y{settingsHost = x}++-- | What to do with exceptions thrown by either the application or server.+-- Default: 'defaultOnException'+--+-- Since 2.1.0+setOnException+ :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings+setOnException x y = y{settingsOnException = x}++-- | A function to create a `Response` when an exception occurs.+-- Default: 'defaultOnExceptionResponse'+--+-- Note that an application can handle its own exceptions without interfering with Warp:+--+-- > myApp :: Application+-- > myApp request respond = innerApp `catch` onError+-- > where+-- > onError = respond . response500 request+-- >+-- > response500 :: Request -> SomeException -> Response+-- > response500 req someEx = responseLBS status500 -- ...+--+-- Since 2.1.0+setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings+setOnExceptionResponse x y = y{settingsOnExceptionResponse = x}++-- | What to do when a connection is opened. When 'False' is returned, the+-- connection is closed immediately. Otherwise, the connection is going on.+-- Default: always returns 'True'.+--+-- Since 2.1.0+setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings+setOnOpen x y = y{settingsOnOpen = x}++-- | What to do when a connection is closed. Default: do nothing.+--+-- Since 2.1.0+setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings+setOnClose x y = y{settingsOnClose = x}++-- | "Slow-loris" timeout lower-bound value in seconds. Connections where+-- network progress is made less frequently than this may be closed. In+-- practice many connections may be allowed to go without progress for up to+-- twice this amount of time. Note that this timeout is not applied to+-- application code, only network progress.+--+-- Default value: 30+--+-- Since 2.1.0+setTimeout :: Int -> Settings -> Settings+setTimeout x y = y{settingsTimeout = x}++-- | Use an existing timeout manager instead of spawning a new one. If used,+-- 'settingsTimeout' is ignored.+--+-- Since 2.1.0+setManager :: Manager -> Settings -> Settings+setManager x y = y{settingsManager = Just x}++-- | Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used.+--+-- The FD cache is an optimization that is useful for servers dealing with+-- static files. However, if files are being modified, it can cause incorrect+-- results in some cases. Therefore, we disable it by default. If you know that+-- your files will be static or you prefer performance to file consistency,+-- it's recommended to turn this on; a reasonable value for those cases is 10.+-- Enabling this cache results in drastic performance improvement for file+-- transfers.+--+-- Default value: 0, was previously 10+--+-- Since 3.0.13+setFdCacheDuration :: Int -> Settings -> Settings+setFdCacheDuration x y = y{settingsFdCacheDuration = x}++-- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used.+--+-- The file information cache is an optimization that is useful for servers dealing with+-- static files. However, if files are being modified, it can cause incorrect+-- results in some cases. Therefore, we disable it by default. If you know that+-- your files will be static or you prefer performance to file consistency,+-- it's recommended to turn this on; a reasonable value for those cases is 10.+-- Enabling this cache results in drastic performance improvement for file+-- transfers.+--+-- Default value: 0+setFileInfoCacheDuration :: Int -> Settings -> Settings+setFileInfoCacheDuration x y = y{settingsFileInfoCacheDuration = x}++-- | Code to run after the listening socket is ready but before entering+-- the main event loop. Useful for signaling to tests that they can start+-- running, or to drop permissions after binding to a restricted port.+--+-- Default: do nothing.+--+-- Since 2.1.0+setBeforeMainLoop :: IO () -> Settings -> Settings+setBeforeMainLoop x y = y{settingsBeforeMainLoop = x}++-- | Perform no parsing on the rawPathInfo.+--+-- This is useful for writing HTTP proxies.+--+-- Default: False+--+-- Since 2.1.0+setNoParsePath :: Bool -> Settings -> Settings+setNoParsePath x y = y{settingsNoParsePath = x}++-- | Get the listening port.+--+-- Since 2.1.1+getPort :: Settings -> Port+getPort = settingsPort++-- | Get the interface to bind to.+--+-- Since 2.1.1+getHost :: Settings -> HostPreference+getHost = settingsHost++-- | Get the action on opening connection.+getOnOpen :: Settings -> SockAddr -> IO Bool+getOnOpen = settingsOnOpen++-- | Get the action on closeing connection.+getOnClose :: Settings -> SockAddr -> IO ()+getOnClose = settingsOnClose++-- | Get the exception handler.+getOnException :: Settings -> Maybe Request -> SomeException -> IO ()+getOnException = settingsOnException++-- | Get the graceful shutdown timeout+--+-- Since 3.2.8+getGracefulShutdownTimeout :: Settings -> Maybe Int+getGracefulShutdownTimeout = settingsGracefulShutdownTimeout++-- | A code to install shutdown handler.+--+-- For instance, this code should set up a UNIX signal+-- handler. The handler should call the first argument,+-- which closes the listen socket, at shutdown.+--+-- Example usage:+--+-- @+-- settings :: IO () -> 'Settings'+-- settings shutdownAction = 'setInstallShutdownHandler' shutdownHandler 'defaultSettings'+-- __where__+-- shutdownHandler closeSocket =+-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing'+-- @+--+-- Note that by default, the graceful shutdown mode lasts indefinitely+-- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above,+-- upon receiving that signal, the custom shutdown action will run /and/ all+-- outstanding requests will be handled.+--+-- You may instead prefer to do one or both of the following:+--+-- * Only wait a finite amount of time for outstanding requests to complete,+-- using 'setGracefulShutdownTimeout'.+-- * Only catch one signal, so the second hard-kills the Warp server, using+-- 'System.Posix.Signals.CatchOnce'.+--+-- Default: does not install any code.+--+-- Since 3.0.1+setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings+setInstallShutdownHandler x y = y{settingsInstallShutdownHandler = x}++-- | Default server name to be sent as the \"Server:\" header+-- if an application does not set one.+-- If an empty string is set, the \"Server:\" header is not sent.+-- This is true even if an application set one.+--+-- Since 3.0.2+setServerName :: ByteString -> Settings -> Settings+setServerName x y = y{settingsServerName = x}++-- | The maximum number of bytes to flush from an unconsumed request body.+--+-- By default, Warp does not flush the request body so that, if a large body is+-- present, the connection is simply terminated instead of wasting time and+-- bandwidth on transmitting it. However, some clients do not deal with that+-- situation well. You can either change this setting to @Nothing@ to flush the+-- entire body in all cases, or in your application ensure that you always+-- consume the entire request body.+--+-- Default: 8192 bytes.+--+-- Since 3.0.3+setMaximumBodyFlush :: Maybe Int -> Settings -> Settings+setMaximumBodyFlush x y+ | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive"+ | otherwise = y{settingsMaximumBodyFlush = x}++-- | Code to fork a new thread to accept a connection.+--+-- This may be useful if you need OS bound threads, or if+-- you wish to develop an alternative threading model.+--+-- Default: void . forkIOWithUnmask+--+-- Since 3.0.4+setFork+ :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings+setFork fork' s = s{settingsFork = fork'}++-- | Code to accept a new connection.+--+-- Useful if you need to provide connected sockets from something other+-- than a standard accept call.+--+-- Default: 'defaultAccept'+--+-- Since 3.3.24+setAccept :: (Socket -> IO (Socket, SockAddr)) -> Settings -> Settings+setAccept accept' s = s{settingsAccept = accept'}++-- | Do not use the PROXY protocol.+--+-- Since 3.0.5+setProxyProtocolNone :: Settings -> Settings+setProxyProtocolNone y = y{settingsProxyProtocol = ProxyProtocolNone}++-- | Require PROXY header.+--+-- This is for cases where a "dumb" TCP/SSL proxy is being used, which cannot+-- add an @X-Forwarded-For@ HTTP header field but has enabled support for the+-- PROXY protocol.+--+-- See <http://www.haproxy.org/download/1.5/doc/proxy-protocol.txt> and+-- <http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol>.+--+-- Only the human-readable header format (version 1) is supported. The binary+-- header format (version 2) is /not/ supported.+--+-- Since 3.0.5+setProxyProtocolRequired :: Settings -> Settings+setProxyProtocolRequired y = y{settingsProxyProtocol = ProxyProtocolRequired}++-- | Use the PROXY header if it exists, but also accept+-- connections without the header. See 'setProxyProtocolRequired'.+--+-- WARNING: This is contrary to the PROXY protocol specification and+-- using it can indicate a security problem with your+-- architecture if the web server is directly accessible+-- to the public, since it would allow easy IP address+-- spoofing. However, it can be useful in some cases,+-- such as if a load balancer health check uses regular+-- HTTP without the PROXY header, but proxied+-- connections /do/ include the PROXY header.+--+-- Since 3.0.5+setProxyProtocolOptional :: Settings -> Settings+setProxyProtocolOptional y = y{settingsProxyProtocol = ProxyProtocolOptional}++-- | Size in bytes read to prevent Slowloris attacks. Default value: 2048+--+-- Since 3.1.2+setSlowlorisSize :: Int -> Settings -> Settings+setSlowlorisSize x y = y{settingsSlowlorisSize = x}++-- | Disable HTTP2.+--+-- Since 3.1.7+setHTTP2Disabled :: Settings -> Settings+setHTTP2Disabled y = y{settingsHTTP2Enabled = False}++-- | Setting a log function.+--+-- Since 3.X.X+setLogger+ :: (Request -> H.Status -> Maybe Integer -> IO ())+ -- ^ request, status, maybe file-size+ -> Settings+ -> Settings+setLogger lgr y = y{settingsLogger = lgr}++-- | Setting a log function for HTTP/2 server push.+--+-- Since: 3.2.7+setServerPushLogger+ :: (Request -> ByteString -> Integer -> IO ())+ -- ^ request, path, file-size+ -> Settings+ -> Settings+setServerPushLogger lgr y = y{settingsServerPushLogger = lgr}++-- | Set the graceful shutdown timeout. A timeout of `Nothing' will+-- wait indefinitely, and a number, if provided, will be treated as seconds+-- to wait for requests to finish, before shutting down the server entirely.+--+-- Graceful shutdown mode is entered when the server socket is closed; see+-- 'setInstallShutdownHandler' for an example of how this could be done in+-- response to a UNIX signal.+--+-- Since 3.2.8+setGracefulShutdownTimeout+ :: Maybe Int+ -> Settings+ -> Settings+setGracefulShutdownTimeout time y = y{settingsGracefulShutdownTimeout = time}++-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.+--+-- Since 3.3.8+setMaxTotalHeaderLength :: Int -> Settings -> Settings+setMaxTotalHeaderLength maxTotalHeaderLength settings =+ settings+ { settingsMaxTotalHeaderLength = maxTotalHeaderLength+ }++-- | Setting the header value of Alternative Services (AltSvc:).+--+-- Since 3.3.11+setAltSvc :: ByteString -> Settings -> Settings+setAltSvc altsvc settings = settings{settingsAltSvc = Just altsvc}++-- | Set the maximum buffer size for sending `Builder` responses.+--+-- Since 3.3.22+setMaxBuilderResponseBufferSize :: Int -> Settings -> Settings+setMaxBuilderResponseBufferSize maxRspBufSize settings = settings{settingsMaxBuilderResponseBufferSize = maxRspBufSize}++-- | Explicitly pause the slowloris timeout.+--+-- This is useful for cases where you partially consume a request body. For+-- more information, see <https://github.com/yesodweb/wai/issues/351>+--+-- Since 3.0.10+pauseTimeout :: Request -> IO ()+pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault++-- | Getting file information of the target file.+--+-- This function first uses a stat(2) or similar system call+-- to obtain information of the target file, then registers+-- it into the internal cache.+-- From the next time, the information is obtained+-- from the cache. This reduces the overhead to call the system call.+-- The internal cache is refreshed every duration specified by+-- 'setFileInfoCacheDuration'.+--+-- This function throws an 'IO' exception if the information is not+-- available. For instance, the target file does not exist.+-- If this function is used an a Request generated by a WAI+-- backend besides Warp, it also throws an 'IO' exception.+--+-- Since 3.1.10+getFileInfo :: Request -> FilePath -> IO FileInfo+getFileInfo =+ fromMaybe (\_ -> throwIO (userError "getFileInfo"))+ . Vault.lookup getFileInfoKey+ . vault++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/1.x. 0 means uses immediate close.+-- Default: 0.+--+-- Since 3.3.5+setGracefulCloseTimeout1 :: Int -> Settings -> Settings+setGracefulCloseTimeout1 x y = y{settingsGracefulCloseTimeout1 = x}++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/1.x. 0 means uses immediate close.+--+-- Since 3.3.5+getGracefulCloseTimeout1 :: Settings -> Int+getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/2. 0 means uses immediate close.+-- Default: 2000.+--+-- Since 3.3.5+setGracefulCloseTimeout2 :: Int -> Settings -> Settings+setGracefulCloseTimeout2 x y = y{settingsGracefulCloseTimeout2 = x}++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/2. 0 means uses immediate close.+--+-- Since 3.3.5+getGracefulCloseTimeout2 :: Settings -> Int+getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2++-- | Get the connection counter, if one was configured.+-- Use 'getCount' on the returned 'Counter' to read the current value.+--+-- See 'makeSettingsAndCounter' to create settings with a counter.+--+-- /DEPRECATED in favor of 'getServerState'/+--+-- Since 3.4.11+getOpenConnectionCounter :: Settings -> Maybe Counter+getOpenConnectionCounter = settingsConnectionCounter++-- | Get the 'ServerState', if one was configured.+-- Use things like 'currentOpenConnections' and 'currentShuttingDownState' to+-- query information about the current state of the server.+--+-- See 'makeSettingsAndServerState' to create 'Settings' with a 'ServerState'.+--+-- Since 3.4.12+getServerState :: Settings -> Maybe ServerState+getServerState = settingsServerState++#ifdef MIN_VERSION_crypton_x509+-- | Getting information of client certificate.+--+-- Since 3.3.5+clientCertificate :: Request -> Maybe CertificateChain+clientCertificate = join . Vault.lookup getClientCertificateKey . vault+#endif
+ Network/Wai/Handler/Warp/Buffer.hs view
@@ -0,0 +1,59 @@+module Network.Wai.Handler.Warp.Buffer (+ createWriteBuffer,+ allocateBuffer,+ freeBuffer,+ toBuilderBuffer,+ bufferIO,+) where++import Data.IORef (IORef, readIORef)+import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..))+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc (free, mallocBytes)+import Foreign.Ptr (plusPtr)+import Network.Socket.BufferPool++import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++-- | Allocate a buffer of the given size and wrap it in a 'WriteBuffer'+-- containing that size and a finalizer.+createWriteBuffer :: BufSize -> IO WriteBuffer+createWriteBuffer size = do+ bytes <- allocateBuffer size+ return+ WriteBuffer+ { bufBuffer = bytes+ , bufSize = size+ , bufFree = freeBuffer bytes+ }++----------------------------------------------------------------++-- | Allocating a buffer with malloc().+allocateBuffer :: Int -> IO Buffer+allocateBuffer = mallocBytes++-- | Releasing a buffer with free().+freeBuffer :: Buffer -> IO ()+freeBuffer = free++----------------------------------------------------------------+--+-- Utilities+--++toBuilderBuffer :: IORef WriteBuffer -> IO B.Buffer+toBuilderBuffer writeBufferRef = do+ writeBuffer <- readIORef writeBufferRef+ let ptr = bufBuffer writeBuffer+ size = bufSize writeBuffer+ fptr <- newForeignPtr_ ptr+ return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)++bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO ()+bufferIO ptr siz io = do+ fptr <- newForeignPtr_ ptr+ io $ PS fptr 0 siz
+ Network/Wai/Handler/Warp/Conduit.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.Conduit where++import Control.Exception (assert, throwIO)+import qualified Data.ByteString as S+import qualified Data.IORef as I+import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf)++import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++-- | Contains a @Source@ and a byte count that is still to be read in.+data ISource = ISource !Source !(I.IORef Int)++mkISource :: Source -> Int -> IO ISource+mkISource src cnt = do+ ref <- I.newIORef cnt+ return $! ISource src ref++-- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the+-- specified number of bytes to be passed downstream. All leftovers should be+-- retained within the @Source@. If there are not enough bytes available,+-- throws a @ConnectionClosedByPeer@ exception.+readISource :: ISource -> IO ByteString+readISource (ISource src ref) = do+ count <- I.readIORef ref+ if count == 0+ then return S.empty+ else do+ bs <- readSource src++ -- If no chunk available, then there aren't enough bytes in the+ -- stream. Throw a ConnectionClosedByPeer+ when (S.null bs) $ throwIO ConnectionClosedByPeer++ let -- How many of the bytes in this chunk to send downstream+ toSend = min count (S.length bs)+ -- How many bytes will still remain to be sent downstream+ count' = count - toSend++ I.writeIORef ref count'++ if count' > 0+ then -- The expected count is greater than the size of the+ -- chunk we just read. Send the entire chunk+ -- downstream, and then loop on this function for the+ -- next chunk.+ return bs+ else do+ -- Some of the bytes in this chunk should not be sent+ -- downstream. Split up the chunk into the sent and+ -- not-sent parts, add the not-sent parts onto the new+ -- source, and send the rest of the chunk downstream.+ let (x, y) = S.splitAt toSend bs+ leftoverSource src y+ assert (count' == 0) $ return x++----------------------------------------------------------------++data CSource = CSource !Source !(I.IORef ChunkState)++data ChunkState+ = NeedLen+ | NeedLenNewline+ | HaveLen Word+ | DoneChunking+ deriving (Show)++mkCSource :: Source -> IO CSource+mkCSource src = do+ ref <- I.newIORef NeedLen+ return $! CSource src ref++readCSource :: CSource -> IO ByteString+readCSource (CSource src ref) = do+ mlen <- I.readIORef ref+ go mlen+ where+ withLen 0 bs = do+ leftoverSource src bs+ dropCRLF+ yield' S.empty DoneChunking+ withLen len bs+ | S.null bs = do+ -- FIXME should this throw an exception if len > 0?+ I.writeIORef ref DoneChunking+ return S.empty+ | otherwise =+ case S.length bs `compare` fromIntegral len of+ EQ -> yield' bs NeedLenNewline+ LT -> yield' bs $ HaveLen $ len - fromIntegral (S.length bs)+ GT -> do+ let (x, y) = S.splitAt (fromIntegral len) bs+ leftoverSource src y+ yield' x NeedLenNewline++ yield' bs mlen = do+ I.writeIORef ref mlen+ return bs++ dropCRLF = do+ bs <- readSource src+ case S.uncons bs of+ Nothing -> return ()+ Just (w8, bs')+ | w8 == _cr -> dropLF bs'+ | w8 == _lf -> leftoverSource src bs'+ | otherwise -> leftoverSource src bs++ dropLF bs =+ case S.uncons bs of+ Nothing -> do+ bs2 <- readSource' src+ unless (S.null bs2) $ dropLF bs2+ Just (w8, bs') ->+ leftoverSource src $+ if w8 == _lf then bs' else bs++ go NeedLen = getLen+ go NeedLenNewline = dropCRLF >> getLen+ go (HaveLen 0) = do+ -- Drop the final CRLF+ dropCRLF+ I.writeIORef ref DoneChunking+ return S.empty+ go (HaveLen len) = do+ bs <- readSource src+ withLen len bs+ go DoneChunking = return S.empty++ -- Get the length from the source, and then pass off control to withLen+ getLen = do+ bs <- readSource src+ if S.null bs+ then do+ I.writeIORef ref $ assert False $ HaveLen 0+ return S.empty+ else do+ (x, y) <-+ case S.break (== _lf) bs of+ (x, y)+ | S.null y -> do+ bs2 <- readSource' src+ return $+ if S.null bs2+ then (x, y)+ else S.break (== _lf) $ bs `S.append` bs2+ | otherwise -> return (x, y)+ let w =+ S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $+ S.takeWhile isHexDigit x++ let y' = S.drop 1 y+ y'' <-+ if S.null y'+ then readSource src+ else return y'+ withLen w y''++ hexToWord w+ | w <= _9 = w - _0+ | w <= _F = w - 55+ | otherwise = w - 87++isHexDigit :: Word8 -> Bool+isHexDigit w =+ w >= _0 && w <= _9+ || w >= _A && w <= _F+ || w >= _a && w <= _f
+ Network/Wai/Handler/Warp/Counter.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.Counter (+ Counter,+ newCounter,+ HasDecreased (..),+ waitForZero,+ increase,+ decrease,+ waitForDecreased,+ getCount,+ getCountSTM,+) where++import Control.Concurrent.STM++import Network.Wai.Handler.Warp.Imports++newtype Counter = Counter (TVar Int)++newCounter :: IO Counter+newCounter = Counter <$> newTVarIO 0++waitForZero :: Counter -> IO ()+waitForZero (Counter var) = atomically $ do+ x <- readTVar var+ when (x > 0) retry++data HasDecreased = HasDecreased | NoConnections+ deriving (Eq, Show)++waitForDecreased :: Counter -> IO HasDecreased+waitForDecreased (Counter var) = do+ n0 <- atomically $ readTVar var+ if n0 <= 0+ then pure NoConnections+ else atomically $ do+ n <- readTVar var+ check (n < n0)+ pure HasDecreased++increase :: Counter -> IO ()+increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1++decrease :: Counter -> IO ()+decrease (Counter var) = atomically $ modifyTVar' var $ \x -> x - 1++-- | Get the current count of open connections.+--+-- Since 3.4.11+getCount :: Counter -> IO Int+getCount (Counter var) = readTVarIO var++-- | Get the current count in an 'STM' transaction.+--+-- Since 3.4.13+getCountSTM :: Counter -> STM Int+getCountSTM (Counter tvar) = readTVar tvar
+ Network/Wai/Handler/Warp/Date.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.Date (+ withDateCache,+ GMTDate,+) where++import Control.AutoUpdate (+ defaultUpdateSettings,+ mkAutoUpdate,+ updateAction,+ updateThreadName,+ )+import Data.ByteString+import Network.HTTP.Date++#if WINDOWS+import Data.Time (UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Foreign.C.Types (CTime(..))+#else+import System.Posix (epochTime)+#endif++-- | The type of the Date header value.+type GMTDate = ByteString++-- | Creating 'DateCache' and executing the action.+withDateCache :: (IO GMTDate -> IO a) -> IO a+withDateCache action = initialize >>= action++initialize :: IO (IO GMTDate)+initialize =+ mkAutoUpdate+ defaultUpdateSettings+ { updateAction = formatHTTPDate <$> getCurrentHTTPDate+ , updateThreadName = "Date cacher (AutoUpdate)"+ }++#ifdef WINDOWS+uToH :: UTCTime -> HTTPDate+uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds++getCurrentHTTPDate :: IO HTTPDate+getCurrentHTTPDate = uToH <$> getCurrentTime+#else+getCurrentHTTPDate :: IO HTTPDate+getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime+#endif
+ Network/Wai/Handler/Warp/FdCache.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++-- | File descriptor cache to avoid locks in kernel.+module Network.Wai.Handler.Warp.FdCache (+ withFdCache,+ Fd,+ Refresh,+#ifndef WINDOWS+ closeFile,+ openFile,+ setFileCloseOnExec,+#endif+) where++#ifndef WINDOWS+import Control.Reaper+import Data.IORef+import Network.Wai.Handler.Warp.MultiMap as MM+import System.Posix.IO (+ FdOption (CloseOnExec),+ OpenFileFlags (..),+ OpenMode (ReadOnly),+ closeFd,+ defaultFileFlags,+ openFd,+ setFdOption,+ )+import Control.Exception (bracket)+#endif+import System.Posix.Types (Fd)++----------------------------------------------------------------++-- | An action to activate a Fd cache entry.+type Refresh = IO ()++getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)+getFdNothing _ = return (Nothing, return ())++----------------------------------------------------------------++-- | Creating 'MutableFdCache' and executing the action in the second+-- argument. The first argument is a cache duration in microseconds.+withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a+#ifdef WINDOWS+withFdCache _ action = action getFdNothing+#else+withFdCache 0 action = action getFdNothing+withFdCache duration action =+ bracket+ (initialize duration)+ terminate+ (action . getFd)++----------------------------------------------------------------++data Status = Active | Inactive++newtype MutableStatus = MutableStatus (IORef Status)++status :: MutableStatus -> IO Status+status (MutableStatus ref) = readIORef ref++newActiveStatus :: IO MutableStatus+newActiveStatus = MutableStatus <$> newIORef Active++refresh :: MutableStatus -> Refresh+refresh (MutableStatus ref) = writeIORef ref Active++inactive :: MutableStatus -> IO ()+inactive (MutableStatus ref) = writeIORef ref Inactive++----------------------------------------------------------------++data FdEntry = FdEntry !Fd !MutableStatus++openFile :: FilePath -> IO Fd+openFile path = do+#if MIN_VERSION_unix(2,8,0)+ fd <- openFd path ReadOnly defaultFileFlags{nonBlock = False}+#else+ fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock = False}+#endif+ setFileCloseOnExec fd+ return fd++closeFile :: Fd -> IO ()+closeFile = closeFd++newFdEntry :: FilePath -> IO FdEntry+newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus++setFileCloseOnExec :: Fd -> IO ()+setFileCloseOnExec fd = setFdOption fd CloseOnExec True++----------------------------------------------------------------++type FdCache = MultiMap FdEntry++-- | Mutable Fd cacher.+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath, FdEntry))++fdCache :: MutableFdCache -> IO FdCache+fdCache (MutableFdCache reaper) = reaperRead reaper++look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)+look mfc path = MM.lookup path <$> fdCache mfc++----------------------------------------------------------------++-- The first argument is a cache duration in microseconds.+initialize :: Int -> IO MutableFdCache+initialize duration = MutableFdCache <$> mkReaper settings+ where+ settings =+ defaultReaperSettings+ { reaperAction = clean+ , reaperDelay = duration+ , reaperCons = uncurry insert+ , reaperNull = isEmpty+ , reaperEmpty = empty+ , reaperThreadName = "Fd cacher (Reaper) "+ }++clean :: FdCache -> IO (FdCache -> FdCache)+clean old = do+ new <- pruneWith old prune+ return $ merge new+ where+ prune (_, FdEntry fd mst) = status mst >>= act+ where+ act Active = inactive mst >> return True+ act Inactive = closeFd fd >> return False++----------------------------------------------------------------++terminate :: MutableFdCache -> IO ()+terminate (MutableFdCache reaper) = do+ !t <- reaperStop reaper+ mapM_ (closeIt . snd) $ toList t+ where+ closeIt (FdEntry fd _) = closeFd fd++----------------------------------------------------------------++-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.+getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)+getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get+ where+ get Nothing = do+ ent@(FdEntry fd mst) <- newFdEntry path+ reaperAdd reaper (path, ent)+ return (Just fd, refresh mst)+ get (Just (FdEntry fd mst)) = do+ refresh mst+ return (Just fd, refresh mst)+#endif
+ Network/Wai/Handler/Warp/File.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.File (+ RspFileInfo (..),+ conditionalRequest,+ addContentHeadersForFilePart,+ H.parseByteRanges,+) where++import qualified Data.ByteString.Char8 as C8 (pack)+import Network.HTTP.Date (HTTPDate, parseHTTPDate)+import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as Header+import Network.Wai (FilePart (..))++import qualified Network.Wai.Handler.Warp.FileInfoCache as I+import Network.Wai.Handler.Warp.Header (+ IndexedRequestHeader (..),+ ResponseHeaderPresence (..),+ )+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.PackInt (packIntegral)++----------------------------------------------------------------++data RspFileInfo+ = WithoutBody H.Status+ | WithBody H.Status H.ResponseHeaders Integer Integer+ deriving (Eq, Show)++----------------------------------------------------------------++conditionalRequest+ :: I.FileInfo+ -> H.ResponseHeaders+ -> H.Method+ -> ResponseHeaderPresence+ -> IndexedRequestHeader+ -> RspFileInfo+conditionalRequest finfo hs0 method rspidx reqidx = case condition of+ nobody@(WithoutBody _) -> nobody+ WithBody s _ off len ->+ let !hs1 = addContentHeaders hs0 off len size+ !hs+ | hasLastModified rspidx = hs1+ | otherwise = (H.hLastModified, date) : hs1+ in WithBody s hs off len+ where+ !mtime = I.fileInfoTime finfo+ !size = I.fileInfoSize finfo+ !date = I.fileInfoDate finfo+ -- According to RFC 9110:+ -- "A recipient cache or origin server MUST evaluate the request+ -- preconditions defined by this specification in the following order:+ -- - If-Match+ -- - If-Unmodified-Since+ -- - If-None-Match+ -- - If-Modified-Since+ -- - If-Range+ --+ -- We don't actually implement the If-(None-)Match logic, but+ -- we also don't want to block middleware or applications from+ -- using ETags. And sending If-(None-)Match headers in a request+ -- to a server that doesn't use them is requester's problem.+ !mcondition =+ ifunmodified reqidx mtime+ <|> ifmodified reqidx mtime method+ <|> ifrange reqidx mtime method size+ !condition = fromMaybe (unconditional reqidx size) mcondition++----------------------------------------------------------------++ifModifiedSince :: IndexedRequestHeader -> Maybe HTTPDate+ifModifiedSince reqidx = reqidxIfModifiedSince reqidx >>= parseHTTPDate++ifUnmodifiedSince :: IndexedRequestHeader -> Maybe HTTPDate+ifUnmodifiedSince reqidx = reqidxIfUnmodifiedSince reqidx >>= parseHTTPDate++ifRange :: IndexedRequestHeader -> Maybe HTTPDate+ifRange reqidx = reqidxIfRange reqidx >>= parseHTTPDate++----------------------------------------------------------------++ifmodified+ :: IndexedRequestHeader+ -> HTTPDate+ -> H.Method+ -> Maybe RspFileInfo+ifmodified reqidx mtime method = do+ date <- ifModifiedSince reqidx+ -- According to RFC 9110:+ -- "A recipient MUST ignore If-Modified-Since if the request+ -- contains an If-None-Match header field; [...]"+ guard . isNothing $ reqidxIfNoneMatch reqidx+ -- "A recipient MUST ignore the If-Modified-Since header field+ -- if [...] the request method is neither GET nor HEAD."+ guard $ method == H.methodGet || method == H.methodHead+ guard $ date == mtime || date > mtime+ Just $ WithoutBody H.notModified304++ifunmodified+ :: IndexedRequestHeader -> HTTPDate -> Maybe RspFileInfo+ifunmodified reqidx mtime = do+ date <- ifUnmodifiedSince reqidx+ -- According to RFC 9110:+ -- "A recipient MUST ignore If-Unmodified-Since if the request+ -- contains an If-Match header field; [...]"+ guard . isNothing $ reqidxIfMatch reqidx+ guard $ date /= mtime && date < mtime+ Just $ WithoutBody H.preconditionFailed412++-- TODO: Should technically also strongly match on ETags.+ifrange+ :: IndexedRequestHeader+ -> HTTPDate+ -> H.Method+ -> Integer+ -> Maybe RspFileInfo+ifrange reqidx mtime method size = do+ -- According to RFC 9110:+ -- "When the method is GET and both Range and If-Range are+ -- present, evaluate the If-Range precondition:"+ date <- ifRange reqidx+ rng <- reqidxRange reqidx+ guard $ method == H.methodGet+ return $+ if date == mtime+ then parseRange rng size+ else WithBody H.ok200 [] 0 size++unconditional :: IndexedRequestHeader -> Integer -> RspFileInfo+unconditional reqidx =+ case reqidxRange reqidx of+ Nothing -> WithBody H.ok200 [] 0+ Just rng -> parseRange rng++----------------------------------------------------------------++parseRange :: ByteString -> Integer -> RspFileInfo+parseRange rng size = case H.parseByteRanges rng of+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416+ Just (r : _) ->+ let (!beg, !end) = checkRange r size+ !len = end - beg + 1+ s =+ if beg == 0 && end == size - 1+ then H.ok200+ else H.partialContent206+ in WithBody s [] beg len++checkRange :: H.ByteRange -> Integer -> (Integer, Integer)+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)++----------------------------------------------------------------++-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'+-- for the range specified.+contentRangeHeader :: Integer -> Integer -> Integer -> H.Header+contentRangeHeader beg end total = (Header.hContentRange, range)+ where+ range =+ C8.pack+ -- building with ShowS+ $+ 'b'+ : 'y'+ : 't'+ : 'e'+ : 's'+ : ' '+ : ( if beg > end+ then ('*' :)+ else+ showInt beg+ . ('-' :)+ . showInt end+ )+ ( '/'+ : showInt total ""+ )++addContentHeaders+ :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders+addContentHeaders hs off len size+ | len == size = hs'+ | otherwise =+ let !ctrng = contentRangeHeader off (off + len - 1) size+ in ctrng : hs'+ where+ !lengthBS = packIntegral len+ !hs' =+ (Header.hContentLength, lengthBS)+ : (Header.hAcceptRanges, "bytes")+ : filter (\(h, _) -> h /= Header.hContentLength && h /= Header.hAcceptRanges) hs++-- |+--+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)+-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)+-- [("Content-Length","16"),("Accept-Ranges","bytes")]+addContentHeadersForFilePart+ :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders+addContentHeadersForFilePart hs part = addContentHeaders hs off len size+ where+ off = filePartOffset part+ len = filePartByteCount part+ size = filePartFileSize part
+ Network/Wai/Handler/Warp/FileInfoCache.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module Network.Wai.Handler.Warp.FileInfoCache (+ FileInfo (..),+ withFileInfoCache,+ getInfo, -- test purpose only+) where++import Control.Exception (bracket, onException, throwIO)+import Control.Reaper+import Network.HTTP.Date+#if WINDOWS+import System.PosixCompat.Files+#else+import System.Posix.Files+#endif++import Network.Wai.Handler.Warp.HashMap (HashMap)+import qualified Network.Wai.Handler.Warp.HashMap as M+import Network.Wai.Handler.Warp.Imports++----------------------------------------------------------------++-- | File information.+data FileInfo = FileInfo+ { fileInfoName :: !FilePath+ , fileInfoSize :: !Integer+ , fileInfoTime :: HTTPDate+ -- ^ Modification time+ , fileInfoDate :: ByteString+ -- ^ Modification time in the GMT format+ }+ deriving (Eq, Show)++data Entry = Negative | Positive FileInfo+type Cache = HashMap Entry+type FileInfoCache = Reaper Cache (FilePath, Entry)++----------------------------------------------------------------++-- | Getting the file information corresponding to the file.+getInfo :: FilePath -> IO FileInfo+getInfo path = do+ fs <- getFileStatus path -- file access+ let regular = not (isDirectory fs)+ readable = fileMode fs `intersectFileModes` ownerReadMode /= 0+ if regular && readable+ then do+ let time = epochTimeToHTTPDate $ modificationTime fs+ date = formatHTTPDate time+ size = fromIntegral $ fileSize fs+ info =+ FileInfo+ { fileInfoName = path+ , fileInfoSize = size+ , fileInfoTime = time+ , fileInfoDate = date+ }+ return info+ else throwIO (userError "FileInfoCache:getInfo")++getInfoNaive :: FilePath -> IO FileInfo+getInfoNaive = getInfo++----------------------------------------------------------------++getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo+getAndRegisterInfo reaper path = do+ cache <- reaperRead reaper+ case M.lookup path cache of+ Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")+ Just (Positive x) -> return x+ Nothing ->+ positive reaper path+ `onException` negative reaper path++positive :: FileInfoCache -> FilePath -> IO FileInfo+positive reaper path = do+ info <- getInfo path+ reaperAdd reaper (path, Positive info)+ return info++negative :: FileInfoCache -> FilePath -> IO FileInfo+negative reaper path = do+ reaperAdd reaper (path, Negative)+ throwIO (userError "FileInfoCache:negative")++----------------------------------------------------------------++-- | Creating a file information cache+-- and executing the action in the second argument.+-- The first argument is a cache duration in microseconds.+withFileInfoCache+ :: Int+ -> ((FilePath -> IO FileInfo) -> IO a)+ -> IO a+withFileInfoCache 0 action = action getInfoNaive+withFileInfoCache duration action =+ bracket+ (initialize duration)+ terminate+ (action . getAndRegisterInfo)++initialize :: Int -> IO FileInfoCache+initialize duration = mkReaper settings+ where+ settings =+ defaultReaperSettings+ { reaperAction = override+ , reaperDelay = duration+ , reaperCons = \(path, v) -> M.insert path v+ , reaperNull = M.isEmpty+ , reaperEmpty = M.empty+ , reaperThreadName = "File info cacher (Reaper)"+ }++override :: Cache -> IO (Cache -> Cache)+override _ = return $ const M.empty++terminate :: FileInfoCache -> IO ()+terminate x = void $ reaperStop x
+ Network/Wai/Handler/Warp/HTTP1.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP1 (+ http1,+) where++import qualified Control.Concurrent as Conc (yield)+import Control.Exception (SomeException, catch, fromException, throwIO, try)+import qualified Data.ByteString as BS+import Data.Char (chr)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Word8 (_cr, _space)+import Network.Socket (SockAddr (SockAddrInet, SockAddrInet6))+import Network.Wai+import Network.Wai.Internal (ResponseReceived (ResponseReceived))+import qualified System.TimeManager as T+import "iproute" Data.IP (toHostAddress, toHostAddress6)++import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Imports hiding (readInt)+import Network.Wai.Handler.Warp.ReadInt+import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types++http1+ :: Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> ByteString+ -> IO ()+http1 settings ii conn transport app origAddr th bs0 = do+ istatus <- newIORef True+ src <- mkSource (wrappedRecv conn istatus (settingsSlowlorisSize settings))+ leftoverSource src bs0+ addr <- getProxyProtocolAddr src+ http1server settings ii conn transport app addr th istatus src+ where+ wrappedRecv Connection{connRecv = recv} istatus slowlorisSize = do+ bs <- recv+ unless (BS.null bs) $ do+ writeIORef istatus True+ when (BS.length bs >= slowlorisSize) $ T.tickle th+ return bs++ getProxyProtocolAddr src =+ case settingsProxyProtocol settings of+ ProxyProtocolNone ->+ return origAddr+ ProxyProtocolRequired -> do+ seg <- readSource src+ parseProxyProtocolHeader src seg+ ProxyProtocolOptional -> do+ seg <- readSource src+ if BS.isPrefixOf "PROXY " seg+ then parseProxyProtocolHeader src seg+ else do+ leftoverSource src seg+ return origAddr++ parseProxyProtocolHeader src seg = do+ let (header, seg') = BS.break (== _cr) seg+ maybeAddr = case BS.split _space header of+ ["PROXY", "TCP4", clientAddr, _, clientPort, _] ->+ case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of+ [a] ->+ Just+ ( SockAddrInet+ (readInt clientPort)+ (toHostAddress a)+ )+ _ -> Nothing+ ["PROXY", "TCP6", clientAddr, _, clientPort, _] ->+ case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of+ [a] ->+ Just+ ( SockAddrInet6+ (readInt clientPort)+ 0+ (toHostAddress6 a)+ 0+ )+ _ -> Nothing+ ("PROXY" : "UNKNOWN" : _) ->+ Just origAddr+ _ ->+ Nothing+ case maybeAddr of+ Nothing -> throwIO (BadProxyHeader (decodeAscii header))+ Just a -> do+ leftoverSource src (BS.drop 2 seg') -- drop CRLF+ return a++ decodeAscii = map (chr . fromEnum) . BS.unpack++http1server+ :: Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> IORef Bool+ -> Source+ -> IO ()+http1server settings ii conn transport app addr th istatus src =+ loop FirstRequest `catch` handler+ where+ handler e+ -- See comment below referencing+ -- https://github.com/yesodweb/wai/issues/618+ | Just NoKeepAliveRequest <- fromException e = return ()+ -- No valid request+ | Just (BadFirstLine _) <- fromException e = return ()+ | isAsyncException e = throwIO e+ | otherwise = do+ _ <-+ sendErrorResponse+ settings+ ii+ conn+ th+ istatus+ defaultRequest{remoteHost = addr}+ e+ throwIO e++ loop firstRequest = do+ (req, mremainingRef, idxhdr, nextBodyFlush) <-+ recvRequest firstRequest settings conn ii th addr src transport+ keepAlive <-+ processRequest+ settings+ ii+ conn+ app+ th+ istatus+ src+ req+ mremainingRef+ idxhdr+ nextBodyFlush+ `catch` \e -> do+ settingsOnException settings (Just req) e+ -- Don't throw the error again to prevent calling settingsOnException twice.+ return CloseConnection++ -- When doing a keep-alive connection, the other side may just+ -- close the connection. We don't want to treat that as an+ -- exceptional situation, so we pass in SubsequentRequest to http1 (which+ -- in turn passes in SubsequentRequest to recvRequest), indicating that+ -- this is not the first request. If, when trying to read the+ -- request headers, no data is available, recvRequest will+ -- throw a NoKeepAliveRequest exception, which we catch here+ -- and ignore. See: https://github.com/yesodweb/wai/issues/618++ case keepAlive of+ ReuseConnection -> loop SubsequentRequest+ CloseConnection -> return ()++data ReuseConnection = ReuseConnection | CloseConnection++processRequest+ :: Settings+ -> InternalInfo+ -> Connection+ -> Application+ -> T.Handle+ -> IORef Bool+ -> Source+ -> Request+ -> Maybe (IORef Int)+ -> IndexedRequestHeader+ -> IO ByteString+ -> IO ReuseConnection+processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush = do+ -- Let the application run for as long as it wants+ T.pause th++ -- In the event that some scarce resource was acquired during+ -- creating the request, we need to make sure that we don't get+ -- an async exception before calling the ResponseSource.+ keepAliveRef <- newIORef $ error "keepAliveRef not filled"+ r <- try $ app req $ \res -> do+ T.resume th+ -- FIXME consider forcing evaluation of the res here to+ -- send more meaningful error messages to the user.+ -- However, it may affect performance.+ writeIORef istatus False+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res+ writeIORef keepAliveRef keepAlive+ return ResponseReceived+ case r of+ Right ResponseReceived -> return ()+ Left (e :: SomeException)+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'+ | isAsyncException e -> throwIO e+ | otherwise -> do+ keepAlive <- sendErrorResponse settings ii conn th istatus req e+ settingsOnException settings (Just req) e+ writeIORef keepAliveRef keepAlive++ keepAlive <- readIORef keepAliveRef++ -- We just send a Response and it takes a time to+ -- receive a Request again. If we immediately call recv,+ -- it is likely to fail and cause the IO manager to do some work.+ -- It is very costly, so we yield to another Haskell+ -- thread hoping that the next Request will arrive+ -- when this Haskell thread will be re-scheduled.+ -- This improves performance at least when+ -- the number of cores is small.+ Conc.yield++ if keepAlive+ then -- If there is an unknown or large amount of data to still be read+ -- from the request body, simple drop this connection instead of+ -- reading it all in to satisfy a keep-alive request.+ case settingsMaximumBodyFlush settings of+ Nothing -> do+ flushEntireBody nextBodyFlush+ T.resume th+ return ReuseConnection+ Just maxToRead -> do+ let tryKeepAlive = do+ -- flush the rest of the request body+ isComplete <- flushBody nextBodyFlush maxToRead+ if isComplete+ then do+ T.resume th+ return ReuseConnection+ else return CloseConnection+ case mremainingRef of+ Just ref -> do+ remaining <- readIORef ref+ if remaining <= maxToRead+ then tryKeepAlive+ else return CloseConnection+ Nothing -> tryKeepAlive+ else return CloseConnection++sendErrorResponse+ :: Settings+ -> InternalInfo+ -> Connection+ -> T.Handle+ -> IORef Bool+ -> Request+ -> SomeException+ -> IO Bool+sendErrorResponse settings ii conn th istatus req e = do+ status <- readIORef istatus+ if shouldSendErrorResponse e && status+ then+ sendResponse+ settings+ conn+ ii+ th+ req+ defaultIndexRequestHeader+ (return BS.empty)+ errorResponse+ else return False+ where+ shouldSendErrorResponse se+ | Just ConnectionClosedByPeer <- fromException se = False+ | otherwise = True+ errorResponse = settingsOnExceptionResponse settings e++flushEntireBody :: IO ByteString -> IO ()+flushEntireBody src =+ loop+ where+ loop = do+ bs <- src+ unless (BS.null bs) loop++flushBody+ :: IO ByteString+ -- ^ get next chunk+ -> Int+ -- ^ maximum to flush+ -> IO Bool+ -- ^ True == flushed the entire body, False == we didn't+flushBody src = loop+ where+ loop toRead = do+ bs <- src+ let toRead' = toRead - BS.length bs+ case () of+ ()+ | BS.null bs -> return True+ | toRead' >= 0 -> loop toRead'+ | otherwise -> return False
+ Network/Wai/Handler/Warp/HTTP2.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP2 (+ http2,+ http2server,+) where++import qualified Control.Exception as E+import qualified Data.ByteString as BS+import Data.IORef (readIORef)+import qualified Data.IORef as I+import GHC.Conc.Sync (labelThread, myThreadId)+import qualified Network.HTTP2.Frame as H2+import qualified Network.HTTP2.Server as H2+import Network.Socket (SockAddr)+import Network.Socket.BufferPool+import Network.Wai+import Network.Wai.Internal (ResponseReceived (..))+import qualified System.TimeManager as T++import Network.Wai.Handler.Warp.HTTP2.File+import Network.Wai.Handler.Warp.HTTP2.PushPromise+import Network.Wai.Handler.Warp.HTTP2.Request+import Network.Wai.Handler.Warp.HTTP2.Response+import Network.Wai.Handler.Warp.Imports+import qualified Network.Wai.Handler.Warp.Settings as S+import Network.Wai.Handler.Warp.Types++-- Early Hints wiring needs both the http-semantics 'auxSendInformational' field+-- (0.4.1) and the http2 sender support that actually emits it (5.4.2).+#define HAS_EARLY_HINTS_SUPPORT (MIN_VERSION_http_semantics(0,4,1) && MIN_VERSION_http2(5,4,2))++#if HAS_EARLY_HINTS_SUPPORT+import qualified Network.HTTP.Types as H+#endif++----------------------------------------------------------------++http2+ :: S.Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> ByteString+ -> IO ()+http2 settings ii conn transport app peersa th bs = do+ rawRecvN <- makeRecvN bs $ connRecv conn+ writeBuffer <- readIORef $ connWriteBuffer conn+ -- This thread becomes the sender in http2 library.+ -- In the case of event source, one request comes and one+ -- worker gets busy. But it is likely that the receiver does+ -- not receive any data at all while the sender is sending+ -- output data from the worker. It's not good enough to tickle+ -- the time handler in the receiver only. So, we should tickle+ -- the time handler in both the receiver and the sender.+ let recvN = wrappedRecvN th (S.settingsSlowlorisSize settings) rawRecvN+ sendBS x = connSendAll conn x >> T.tickle th+ conf =+ H2.defaultConfig+ { H2.confWriteBuffer = bufBuffer writeBuffer+ , H2.confBufferSize = bufSize writeBuffer+ , H2.confSendAll = sendBS+ , H2.confReadN = recvN+ , H2.confPositionReadMaker = pReadMaker ii+ , H2.confTimeoutManager = timeoutManager ii+ , H2.confMySockAddr = connMySockAddr conn+ , H2.confPeerSockAddr = peersa+ , H2.confReadNTimeout = True+ }+ checkTLS+ setConnHTTP2 conn True+ H2.run H2.defaultServerConfig conf $+ http2server "Warp HTTP/2" settings ii transport peersa app+ where+ checkTLS = case transport of+ TCP -> return () -- direct+ tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3++-- | Converting WAI application to the server type of http2 library.+--+-- Since 3.3.11+http2server+ :: String+ -> S.Settings+ -> InternalInfo+ -> Transport+ -> SockAddr+ -> Application+ -> H2.Server+http2server label settings ii transport addr app h2req0 aux0 response = do+ tid <- myThreadId+ labelThread tid (label ++ " http2server " ++ show addr)+ req0 <- toWAIRequest h2req0 aux0+#if HAS_EARLY_HINTS_SUPPORT+ let req = req0{requestSendEarlyHints = H2.auxSendInformational aux0 (H.mkStatus 103 "Early Hints")}+#else+ let req = req0+#endif+ ref <- I.newIORef Nothing+ eResponseReceived <- E.try $ app req $ \rsp -> do+ (h2rsp, st, hasBody) <- fromResponse settings ii req rsp+ pps <- if hasBody then fromPushPromises ii req else return []+ I.writeIORef ref $ Just (h2rsp, pps, st)+ _ <- response h2rsp pps+ return ResponseReceived+ case eResponseReceived of+ Right ResponseReceived -> do+ Just (h2rsp, pps, st) <- I.readIORef ref+ let msiz = fromIntegral <$> H2.responseBodySize h2rsp+ logResponse req st msiz+ mapM_ (logPushPromise req) pps+ Left e+ | isAsyncException e -> E.throwIO e+ | otherwise -> do+ S.settingsOnException settings (Just req) e+ let ersp = S.settingsOnExceptionResponse settings e+ st = responseStatus ersp+ (h2rsp', _, _) <- fromResponse settings ii req ersp+ let msiz = fromIntegral <$> H2.responseBodySize h2rsp'+ _ <- response h2rsp' []+ logResponse req st msiz+ return ()+ where+ toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport+ where+ !hdr = H2.requestHeaders h2req+ !bdy = H2.getRequestBodyChunk h2req+ !bdylen = H2.requestBodySize h2req+ !th = H2.auxTimeHandle aux++ logResponse = S.settingsLogger settings++ logPushPromise req pp = logger req path siz+ where+ !logger = S.settingsServerPushLogger settings+ !path = H2.promiseRequestPath pp+ !siz = case H2.responseBodySize $ H2.promiseResponse pp of+ Nothing -> 0+ Just s -> fromIntegral s++wrappedRecvN+ :: T.Handle -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)+wrappedRecvN th slowlorisSize readN bufsize = do+ bs <- E.handle handler $ readN bufsize+ -- TODO: think about the slowloris protection in HTTP2: current code+ -- might open a slow-loris attack vector. Rather than timing we should+ -- consider limiting the per-client connections assuming that in HTTP2+ -- we should allow only few connections per host (real-world+ -- deployments with large NATs may be trickier).+ when+ (BS.length bs > 0 && BS.length bs >= slowlorisSize || bufsize <= slowlorisSize)+ $ T.tickle th+ return bs+ where+ handler :: E.SomeException -> IO ByteString+ handler = throughAsync (return "")++-- connClose must not be called here since Run:fork calls it+goaway :: Connection -> H2.ErrorCode -> ByteString -> IO ()+goaway Connection{..} etype debugmsg = connSendAll bytestream+ where+ einfo = H2.encodeInfo id 0+ frame = H2.GoAwayFrame 0 etype debugmsg+ bytestream = H2.encodeFrame einfo frame
+ Network/Wai/Handler/Warp/HTTP2/File.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.HTTP2.File where++import Network.HTTP2.Server++import Network.Wai.Handler.Warp.Types++#ifdef WINDOWS+pReadMaker :: InternalInfo -> PositionReadMaker+pReadMaker _ = defaultPositionReadMaker+#else+import Network.Wai.Handler.Warp.FdCache+import Network.Wai.Handler.Warp.SendFile (positionRead)++-- | 'PositionReadMaker' based on file descriptor cache.+--+-- Since 3.3.13+pReadMaker :: InternalInfo -> PositionReadMaker+pReadMaker ii path = do+ (mfd, refresh) <- getFd ii path+ case mfd of+ Just fd -> return (pread fd, Refresher refresh)+ Nothing -> do+ fd <- openFile path+ return (pread fd, Closer $ closeFile fd)+ where+ pread :: Fd -> PositionRead+ pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'+ where+ bytes' = fromIntegral bytes+ off' = fromIntegral off+#endif
+ Network/Wai/Handler/Warp/HTTP2/PushPromise.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP2.PushPromise where++import qualified Control.Exception as E+import qualified Network.HTTP.Types as H+import qualified Network.HTTP2.Server as H2++import Network.Wai+import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)+import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]+fromPushPromises ii req = do+ mh2data <- getHTTP2Data req+ let pp = maybe [] http2dataPushPromise mh2data+ catMaybes <$> mapM (fromPushPromise ii) pp++fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)+fromPushPromise ii (PushPromise path file rsphdr w) = do+ efinfo <- E.try $ getFileInfo ii file+ case efinfo of+ Left (_ex :: E.IOException) -> return Nothing+ Right finfo -> do+ let !siz = fromIntegral $ fileInfoSize finfo+ !fileSpec = H2.FileSpec file 0 siz+ !rsp = H2.responseFile H.ok200 rsphdr fileSpec+ !pp = H2.pushPromise path rsp w+ return $ Just pp
+ Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.HTTP2.Request (+ toRequest,+ getHTTP2Data,+ setHTTP2Data,+ modifyHTTP2Data,+) where++import Control.Arrow (first)+import qualified Data.ByteString.Char8 as C8+import Data.IORef+import qualified Data.Vault.Lazy as Vault+import Network.HPACK+import Network.HPACK.Token+import qualified Network.HTTP.Types as H+import Network.Socket (SockAddr)+import Network.Wai+import System.IO.Unsafe (unsafePerformIO)+import qualified System.TimeManager as T++import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey)+#ifdef MIN_VERSION_crypton_x509+import Network.Wai.Handler.Warp.Request (getClientCertificateKey)+#endif+import qualified Network.Wai.Handler.Warp.Settings as S (+ Settings,+ settingsNoParsePath,+ )+import Network.Wai.Handler.Warp.Types++type ToReq =+ (TokenHeaderList, ValueTable)+ -> Maybe Int+ -> IO ByteString+ -> T.Handle+ -> Transport+ -> IO Request++----------------------------------------------------------------++http30 :: H.HttpVersion+http30 = H.HttpVersion 3 0++toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq+toRequest ii settings addr ht bodylen body th transport = do+ ref <- newIORef Nothing+ toRequest' ii settings addr ref ht bodylen body th transport++toRequest'+ :: InternalInfo+ -> S.Settings+ -> SockAddr+ -> IORef (Maybe HTTP2Data)+ -> ToReq+toRequest' ii settings addr ref (reqths, reqvt) bodylen body th transport =+ -- setting 'requestBody' with 'setRequestBodyChunks' to avoid warnings+ return $! setRequestBodyChunks body req+ where+ !req =+ defaultRequest+ { requestMethod = colonMethod+ , httpVersion = if isTransportQUIC transport then http30 else H.http20+ , rawPathInfo = rawPath+ , pathInfo = H.decodePathSegments path+ , rawQueryString = query+ , queryString = H.parseQuery query+ , requestHeaders = headers+ , isSecure = isTransportSecure transport+ , remoteHost = addr+ , vault = vaultValue+ , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen+ , requestHeaderHost = mHost <|> mAuth+ , requestHeaderRange = mRange+ , requestHeaderReferer = mReferer+ , requestHeaderUserAgent = mUserAgent+ }+ headers = map (first tokenKey) ths+ where+ ths = case mHost of+ Just _ -> reqths+ Nothing -> case mAuth of+ Just auth -> (tokenHost, auth) : reqths+ _ -> reqths+ !mPath = getFieldValue tokenPath reqvt -- SHOULD+ !colonMethod = fromJust $ getFieldValue tokenMethod reqvt -- MUST+ !mAuth = getFieldValue tokenAuthority reqvt -- SHOULD+ !mHost = getFieldValue tokenHost reqvt+ !mRange = getFieldValue tokenRange reqvt+ !mReferer = getFieldValue tokenReferer reqvt+ !mUserAgent = getFieldValue tokenUserAgent reqvt+ -- CONNECT request will have ":path" omitted, use ":authority" as unparsed+ -- path instead so that it will have consistent behavior compare to HTTP 1.0+ (unparsedPath, query) = C8.break (== '?') $ fromJust (mPath <|> mAuth)+ !path = H.extractPath unparsedPath+ !rawPath = if S.settingsNoParsePath settings then unparsedPath else path+ -- fixme: pauseTimeout. th is not available here.+ !vaultValue =+ Vault.insert getFileInfoKey (getFileInfo ii)+ . Vault.insert getHTTP2DataKey (readIORef ref)+ . Vault.insert setHTTP2DataKey (writeIORef ref)+ . Vault.insert modifyHTTP2DataKey (modifyIORef' ref)+ . Vault.insert pauseTimeoutKey (T.pause th)+#ifdef MIN_VERSION_crypton_x509+ . Vault.insert getClientCertificateKey (getTransportClientCertificate transport)+#endif+ $ Vault.empty++getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))+getHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE getHTTP2DataKey #-}++-- | Getting 'HTTP2Data' through vault of the request.+-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.+--+-- Since: 3.2.7+getHTTP2Data :: Request -> IO (Maybe HTTP2Data)+getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of+ Nothing -> return Nothing+ Just getter -> getter++setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())+setHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE setHTTP2DataKey #-}++-- | Setting 'HTTP2Data' through vault of the request.+-- 'Application' or 'Middleware' should use this.+--+-- Since: 3.2.7+setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()+setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of+ Nothing -> return ()+ Just setter -> setter mh2d++modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())+modifyHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE modifyHTTP2DataKey #-}++-- | Modifying 'HTTP2Data' through vault of the request.+-- 'Application' or 'Middleware' should use this.+--+-- Since: 3.2.8+modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()+modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of+ Nothing -> return ()+ Just modify -> modify func
+ Network/Wai/Handler/Warp/HTTP2/Response.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP2.Response (+ fromResponse,+) where++import qualified Control.Exception as E+import qualified Data.ByteString.Builder as BB+import qualified Data.List as L (find)+import qualified Network.HTTP.Types as H+import qualified Network.HTTP2.Server as H2+import Network.Wai hiding (responseBuilder, responseFile, responseStream)+import Network.Wai.Internal (Response (..))++import Network.Wai.Handler.Warp.File+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)+import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.Header+import qualified Network.Wai.Handler.Warp.Response as R+import qualified Network.Wai.Handler.Warp.Settings as S+import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++fromResponse+ :: S.Settings+ -> InternalInfo+ -> Request+ -> Response+ -> IO (H2.Response, H.Status, Bool)+fromResponse settings ii req rsp = do+ date <- getDate ii+ rspst@(h2rsp, st, hasBody) <- case rsp of+ ResponseFile st rsphdr path mpart -> do+ let rsphdr' = add date rsphdr+ responseFile st rsphdr' method path mpart ii reqhdr+ ResponseBuilder st rsphdr builder -> do+ let rsphdr' = add date rsphdr+ return $ responseBuilder st rsphdr' method builder+ ResponseStream st rsphdr strmbdy -> do+ let rsphdr' = add date rsphdr+ return $ responseStream st rsphdr' method strmbdy+ _ -> error "ResponseRaw is not supported in HTTP/2"+ mh2data <- getHTTP2Data req+ case mh2data of+ Nothing -> return rspst+ Just h2data -> do+ let !trailers = http2dataTrailers h2data+ !h2rsp' = H2.setResponseTrailersMaker h2rsp trailers+ return (h2rsp', st, hasBody)+ where+ !method = requestMethod req+ !reqhdr = requestHeaders req+ !server = S.settingsServerName settings+ add date rsphdr =+ let hasServerHdr = L.find ((== H.hServer) . fst) rsphdr+ addSVR =+ maybe ((H.hServer, server) :) (const id) hasServerHdr+ in R.addAltSvc settings $+ (H.hDate, date) : addSVR rsphdr++----------------------------------------------------------------++responseFile+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> FilePath+ -> Maybe FilePart+ -> InternalInfo+ -> H.RequestHeaders+ -> IO (H2.Response, H.Status, Bool)+responseFile st rsphdr _ _ _ _ _+ | noBody st = return $ responseNoBody st rsphdr+responseFile st rsphdr method path (Just fp) _ _ =+ return $ responseFile2XX st rsphdr method fileSpec+ where+ !off' = fromIntegral $ filePartOffset fp+ !bytes' = fromIntegral $ filePartByteCount fp+ !fileSpec = H2.FileSpec path off' bytes'+responseFile _ rsphdr method path Nothing ii reqhdr = do+ efinfo <- E.try $ getFileInfo ii path+ case efinfo of+ Left (_ex :: E.IOException) -> return $ response404 rsphdr+ Right finfo -> do+ let reqidx = indexRequestHeader reqhdr+ rspidx = indexResponseHeader rsphdr+ case conditionalRequest finfo rsphdr method rspidx reqidx of+ WithoutBody s -> return $ responseNoBody s rsphdr+ WithBody s rsphdr' off bytes -> do+ let !off' = fromIntegral off+ !bytes' = fromIntegral bytes+ !fileSpec = H2.FileSpec path off' bytes'+ return $ responseFile2XX s rsphdr' method fileSpec++----------------------------------------------------------------++responseFile2XX+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> H2.FileSpec+ -> (H2.Response, H.Status, Bool)+responseFile2XX st rsphdr method fileSpec+ | method == H.methodHead = responseNoBody st rsphdr+ | otherwise = (H2.responseFile st rsphdr fileSpec, st, True)++----------------------------------------------------------------++responseBuilder+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> BB.Builder+ -> (H2.Response, H.Status, Bool)+responseBuilder st rsphdr method builder+ | method == H.methodHead || noBody st = responseNoBody st rsphdr+ | otherwise = (H2.responseBuilder st rsphdr builder, st, True)++----------------------------------------------------------------++responseStream+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> StreamingBody+ -> (H2.Response, H.Status, Bool)+responseStream st rsphdr method strmbdy+ | method == H.methodHead || noBody st = responseNoBody st rsphdr+ | otherwise = (H2.responseStreaming st rsphdr strmbdy, st, True)++----------------------------------------------------------------++responseNoBody :: H.Status -> H.ResponseHeaders -> (H2.Response, H.Status, Bool)+responseNoBody st rsphdr = (H2.responseNoBody st rsphdr, st, False)++----------------------------------------------------------------++response404 :: H.ResponseHeaders -> (H2.Response, H.Status, Bool)+response404 rsphdr = (h2rsp, st, True)+ where+ h2rsp = H2.responseBuilder st rsphdr' body+ st = H.notFound404+ !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr+ !body = BB.byteString "File not found"++----------------------------------------------------------------++noBody :: H.Status -> Bool+noBody = not . R.hasBody
+ Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.HTTP2.Types where++import qualified Data.ByteString as BS+import qualified Network.HTTP.Types as H+import Network.HTTP2.Frame+import qualified Network.HTTP2.Server as H2++import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++isHTTP2 :: Transport -> Bool+isHTTP2 TCP = False+isHTTP2 tls = useHTTP2+ where+ useHTTP2 = case tlsNegotiatedProtocol tls of+ Nothing -> False+ Just proto -> "h2" `BS.isPrefixOf` proto++----------------------------------------------------------------++-- | HTTP/2 specific data.+--+-- Since: 3.2.7+data HTTP2Data = HTTP2Data+ { http2dataPushPromise :: [PushPromise]+ -- ^ Accessor for 'PushPromise' in 'HTTP2Data'.+ --+ -- Since: 3.2.7+ , http2dataTrailers :: H2.TrailersMaker+ -- ^ Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.+ --+ -- Since: 3.2.8 but the type changed in 3.3.0+ }++-- | Default HTTP/2 specific data.+--+-- Since: 3.2.7+defaultHTTP2Data :: HTTP2Data+defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker++-- | HTTP/2 push promise or sever push.+-- This allows files only for backward-compatibility+-- while the HTTP/2 library supports other types.+--+-- Since: 3.2.7+data PushPromise = PushPromise+ { promisedPath :: ByteString+ -- ^ Accessor for a URL path in 'PushPromise'.+ -- E.g. \"\/style\/default.css\".+ --+ -- Since: 3.2.7+ , promisedFile :: FilePath+ -- ^ Accessor for 'FilePath' in 'PushPromise'.+ -- E.g. \"FILE_PATH/default.css\".+ --+ -- Since: 3.2.7+ , promisedResponseHeaders :: H.ResponseHeaders+ -- ^ Accessor for 'H.ResponseHeaders' in 'PushPromise'+ -- \"content-type\" must be specified.+ -- Default value: [].+ --+ --+ -- Since: 3.2.7+ , promisedWeight :: Weight+ -- ^ Accessor for 'Weight' in 'PushPromise'.+ -- Default value: 16.+ --+ -- Since: 3.2.7+ }+ deriving (Eq, Ord, Show)++-- | Default push promise.+--+-- Since: 3.2.7+defaultPushPromise :: PushPromise+defaultPushPromise = PushPromise "" "" [] 16
+ Network/Wai/Handler/Warp/HashMap.hs view
@@ -0,0 +1,36 @@+module Network.Wai.Handler.Warp.HashMap where++import Data.Hashable (hash)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as I+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Prelude hiding (lookup)++----------------------------------------------------------------++-- | 'HashMap' is used for cache of file information.+-- Hash values of file pathes are used as outer keys.+-- Because negative entries are also contained,+-- a bad guy can intentionally cause the hash collison.+-- So, 'Map' is used internally to prevent+-- the hash collision attack.+newtype HashMap v = HashMap (IntMap (Map FilePath v))++----------------------------------------------------------------++empty :: HashMap v+empty = HashMap I.empty++isEmpty :: HashMap v -> Bool+isEmpty (HashMap hm) = I.null hm++----------------------------------------------------------------++insert :: FilePath -> v -> HashMap v -> HashMap v+insert path v (HashMap hm) =+ HashMap $+ I.insertWith M.union (hash path) (M.singleton path v) hm++lookup :: FilePath -> HashMap v -> Maybe v+lookup path (HashMap hm) = I.lookup (hash path) hm >>= M.lookup path
+ Network/Wai/Handler/Warp/Header.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.Header (+ IndexedRequestHeader (..),+ ResponseHeaderPresence (..),+ indexRequestHeader,+ defaultIndexRequestHeader,+ indexResponseHeader,+) where++import qualified Data.ByteString as BS+import Data.CaseInsensitive (foldedCase)+import Data.List as L (foldl')+import Network.HTTP.Types++import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++-- | Strict record of the request headers that Warp inspects,+-- one field per header.+data IndexedRequestHeader = IndexedRequestHeader+ { reqidxContentLength :: Maybe HeaderValue+ , reqidxTransferEncoding :: Maybe HeaderValue+ , reqidxExpect :: Maybe HeaderValue+ , reqidxConnection :: Maybe HeaderValue+ , reqidxRange :: Maybe HeaderValue+ , reqidxHost :: Maybe HeaderValue+ , reqidxIfModifiedSince :: Maybe HeaderValue+ , reqidxIfUnmodifiedSince :: Maybe HeaderValue+ , reqidxIfRange :: Maybe HeaderValue+ , reqidxReferer :: Maybe HeaderValue+ , reqidxUserAgent :: Maybe HeaderValue+ , reqidxIfMatch :: Maybe HeaderValue+ , reqidxIfNoneMatch :: Maybe HeaderValue+ }++indexRequestHeader :: RequestHeaders -> IndexedRequestHeader+indexRequestHeader = L.foldl' insert defaultIndexRequestHeader+ where+ insert ix (key, val) = case BS.length bs of+ 4 | bs == "host" -> ix{reqidxHost = Just val}+ 5 | bs == "range" -> ix{reqidxRange = Just val}+ 6 | bs == "expect" -> ix{reqidxExpect = Just val}+ 7 | bs == "referer" -> ix{reqidxReferer = Just val}+ 8+ | bs == "if-range" -> ix{reqidxIfRange = Just val}+ | bs == "if-match" -> ix{reqidxIfMatch = Just val}+ 10+ | bs == "user-agent" -> ix{reqidxUserAgent = Just val}+ | bs == "connection" -> ix{reqidxConnection = Just val}+ 13 | bs == "if-none-match" -> ix{reqidxIfNoneMatch = Just val}+ 14 | bs == "content-length" -> ix{reqidxContentLength = Just val}+ 17+ | bs == "transfer-encoding" -> ix{reqidxTransferEncoding = Just val}+ | bs == "if-modified-since" -> ix{reqidxIfModifiedSince = Just val}+ 19 | bs == "if-unmodified-since" -> ix{reqidxIfUnmodifiedSince = Just val}+ _ -> ix+ where+ bs = foldedCase key++-- | 'IndexedRequestHeader' with no headers set.+defaultIndexRequestHeader :: IndexedRequestHeader+defaultIndexRequestHeader =+ IndexedRequestHeader+ { reqidxContentLength = Nothing+ , reqidxTransferEncoding = Nothing+ , reqidxExpect = Nothing+ , reqidxConnection = Nothing+ , reqidxRange = Nothing+ , reqidxHost = Nothing+ , reqidxIfModifiedSince = Nothing+ , reqidxIfUnmodifiedSince = Nothing+ , reqidxIfRange = Nothing+ , reqidxReferer = Nothing+ , reqidxUserAgent = Nothing+ , reqidxIfMatch = Nothing+ , reqidxIfNoneMatch = Nothing+ }++----------------------------------------------------------------++-- | Presence of the response headers Warp itself consults.+-- Only these four headers are ever looked up on the response side, and+-- only their presence, never their value, so a flat record of strict+-- 'Bool's built in a single traversal beats a boxed array.+data ResponseHeaderPresence = ResponseHeaderPresence+ { hasContentLength :: Bool+ , hasServer :: Bool+ , hasDate :: Bool+ , hasLastModified :: Bool+ , hasTransferEncoding :: Maybe HeaderValue+ , hasConnection :: Maybe HeaderValue+ }++indexResponseHeader :: ResponseHeaders -> ResponseHeaderPresence+indexResponseHeader = go emptyResponseHeaderPresence+ where+ go ix [] = ix+ go ix (tup : rest) = go (insert ix tup) rest+ insert ix (key, val) = case BS.length bs of+ 4 | bs == "date" -> ix{hasDate = True}+ 6 | bs == "server" -> ix{hasServer = True}+ 10 | bs == "connection" -> ix{hasConnection = Just val}+ 13 | bs == "last-modified" -> ix{hasLastModified = True}+ 14 | bs == "content-length" -> ix{hasContentLength = True}+ 17 | bs == "transfer-encoding" -> ix{hasTransferEncoding = Just val}+ _ -> ix+ where+ bs = foldedCase key++emptyResponseHeaderPresence :: ResponseHeaderPresence+emptyResponseHeaderPresence =+ ResponseHeaderPresence+ { hasContentLength = False+ , hasServer = False+ , hasDate = False+ , hasLastModified = False+ , hasTransferEncoding = Nothing+ , hasConnection = Nothing+ }
+ Network/Wai/Handler/Warp/IO.hs view
@@ -0,0 +1,51 @@+module Network.Wai.Handler.Warp.IO where++import Control.Exception (mask_)+import qualified Data.ByteString as B (length)+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder.Extra (Next (Chunk, Done, More), runBuilder)+import Data.IORef (IORef, readIORef, writeIORef)+import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++toBufIOWith+ :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer+toBufIOWith maxRspBufSize writeBufferRef io builder = do+ writeBuffer <- readIORef writeBufferRef+ loop writeBuffer firstWriter 0+ where+ firstWriter = runBuilder builder+ loop writeBuffer writer bytesSent = do+ let buf = bufBuffer writeBuffer+ size = bufSize writeBuffer+ (len, signal) <- writer buf size+ bufferIO buf len io+ let totalBytesSent = toInteger len + bytesSent+ case signal of+ Done -> return totalBytesSent+ More minSize next+ | size < minSize -> do+ when (minSize > maxRspBufSize) $+ error $+ "Sending a Builder response required a buffer of size "+ ++ show minSize+ ++ " which is bigger than the specified maximum of "+ ++ show maxRspBufSize+ ++ "!"+ -- The current WriteBuffer is too small to fit the next+ -- batch of bytes from the Builder so we free it and+ -- create a new bigger one. Freeing the current buffer,+ -- creating a new one and writing it to the IORef need+ -- to be performed atomically to prevent both double+ -- frees and missed frees. So we mask async exceptions:+ biggerWriteBuffer <- mask_ $ do+ bufFree writeBuffer+ biggerWriteBuffer <- createWriteBuffer minSize+ writeIORef writeBufferRef biggerWriteBuffer+ return biggerWriteBuffer+ loop biggerWriteBuffer next totalBytesSent+ | otherwise -> loop writeBuffer next totalBytesSent+ Chunk bs next -> do+ io bs+ loop writeBuffer next $ totalBytesSent + fromIntegral (B.length bs)
+ Network/Wai/Handler/Warp/Imports.hs view
@@ -0,0 +1,39 @@+module Network.Wai.Handler.Warp.Imports (+ ByteString (..),+ NonEmpty (..),+ module Control.Applicative,+ module Control.Monad,+ module Data.Bits,+ module Data.Int,+ module Data.Monoid,+ module Data.Ord,+ module Data.Word,+ module Data.Maybe,+ module Numeric,+ throughAsync,+ isAsyncException,+) where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Bits+import Data.ByteString.Internal (ByteString (..))+import Data.Int+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe+import Data.Monoid+import Data.Ord+import Data.Word+import Numeric++isAsyncException :: Exception e => e -> Bool+isAsyncException e =+ case fromException (toException e) of+ Just (SomeAsyncException _) -> True+ Nothing -> False++throughAsync :: IO a -> SomeException -> IO a+throughAsync action (SomeException e)+ | isAsyncException e = throwIO e+ | otherwise = action
+ Network/Wai/Handler/Warp/Internal.hs view
@@ -0,0 +1,143 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- |+-- __IMPORTANT NOTICE__+--+-- This module exports internals mainly to provide the @warp-tls@ package+-- with tools to implement what it needs to. This module\/API should /NOT/ be+-- expected to remain stable at all, even between minor releases.+--+-- If you see a use case for these functions or types for other purposes,+-- please create an issue in the repository so that we might add it to the+-- main 'Network.Wai.Handler.Warp' API.+module Network.Wai.Handler.Warp.Internal (+ -- * Settings+ Settings (..),+ ProxyProtocol (..),+ makeSettingsAndCounter,+ makeSettingsAndServerState,++ -- ** Connection counter+ Counter,+ getCount,++ -- ** Server state+ ServerState,+ makeServerState,++ -- * Low level run functions+ runSettingsConnection,+ runSettingsConnectionMaker,+ runSettingsConnectionMakerSecure,+ Transport (..),++ -- * Connection+ Connection (..),+ socketConnection,++ -- ** Receive+ Recv,+ makeGracefulRecv,+ RecvBuf,++ -- ** Buffer+ Buffer,+ BufSize,+ WriteBuffer (..),+ createWriteBuffer,+ allocateBuffer,+ freeBuffer,+ copy,++ -- ** Sendfile+ FileId (..),+ SendFile,+ sendFile,+ readSendFile,++ -- * Version+ warpVersion,++ -- * Data types++ -- |+ --+ -- The internals of 'IndexedHeader' have changed since @3.4.15@, so we+ -- keep exporting it as a type synonym, but it is now a record instead of+ -- an array.+ -- As such there's no more 'requestMaxIndex', but we provide a blank+ -- 'defaultIndexRequestHeader'.+ InternalInfo (..),+ HeaderValue,+ IndexedHeader,+ -- I assume 'requestMaxIndex' was used in case anyone wanted to create+ -- an empty array, so we replace it with 'defaultIndexRequestHeader'.+ defaultIndexRequestHeader,++ -- * Time out manager++ -- |+ --+ -- In order to provide slowloris protection, Warp provides timeout handlers. We+ -- follow these rules:+ --+ -- * A timeout is created when a connection is opened.+ --+ -- * When all request headers are read, the timeout is tickled.+ --+ -- * Every time at least the slowloris size settings number of bytes of the request+ -- body are read, the timeout is tickled.+ --+ -- * The timeout is paused while executing user code. This will apply to both+ -- the application itself, and a ResponseSource response. The timeout is+ -- resumed as soon as we return from user code.+ --+ -- * Every time data is successfully sent to the client, the timeout is tickled.+ module System.TimeManager,++ -- * File descriptor cache+ module Network.Wai.Handler.Warp.FdCache,++ -- * File information cache+ module Network.Wai.Handler.Warp.FileInfoCache,++ -- * Date+ module Network.Wai.Handler.Warp.Date,++ -- * Request and response+ Source,+ FirstRequest (..),+ recvRequest,+ sendResponse,++ -- * Platform dependent helper functions+ setSocketCloseOnExec,+ windowsThreadBlockHack,++ -- * Misc+ http2server,+ withII,+ serveConnection,+ pReadMaker,+) where++import Network.Socket.BufferPool+import System.TimeManager++import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Counter (Counter, getCount)+import Network.Wai.Handler.Warp.Date+import Network.Wai.Handler.Warp.FdCache+import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.HTTP2+import Network.Wai.Handler.Warp.HTTP2.File+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.Run+import Network.Wai.Handler.Warp.SendFile+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types+import Network.Wai.Handler.Warp.Windows++type IndexedHeader = IndexedRequestHeader
+ Network/Wai/Handler/Warp/MultiMap.hs view
@@ -0,0 +1,91 @@+module Network.Wai.Handler.Warp.MultiMap (+ MultiMap,+ isEmpty,+ empty,+ singleton,+ insert,+ Network.Wai.Handler.Warp.MultiMap.lookup,+ pruneWith,+ toList,+ merge,+) where++import Control.Monad (filterM)+import Data.Hashable (hash)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as I+import Data.Semigroup+import Prelude -- Silence redundant import warnings++----------------------------------------------------------------++-- | 'MultiMap' is used as a cache of file descriptors.+-- Since multiple threads could open file descriptors for+-- the same file simultaneously, there could be multiple entries+-- for one file.+-- Since hash values of file paths are used as outer keys,+-- collison would happen for multiple file paths.+-- Because only positive entries are stored,+-- Malicious attack cannot cause the inner list to blow up.+-- So, lists are good enough.+newtype MultiMap v = MultiMap (IntMap [(FilePath, v)])++----------------------------------------------------------------++-- | O(1)+empty :: MultiMap v+empty = MultiMap I.empty++-- | O(1)+isEmpty :: MultiMap v -> Bool+isEmpty (MultiMap mm) = I.null mm++----------------------------------------------------------------++-- | O(1)+singleton :: FilePath -> v -> MultiMap v+singleton path v = MultiMap $ I.singleton (hash path) [(path, v)]++----------------------------------------------------------------++-- | O(M) where M is the number of entries per file+lookup :: FilePath -> MultiMap v -> Maybe v+lookup path (MultiMap mm) = case I.lookup (hash path) mm of+ Nothing -> Nothing+ Just s -> Prelude.lookup path s++----------------------------------------------------------------++-- | O(log n)+insert :: FilePath -> v -> MultiMap v -> MultiMap v+insert path v (MultiMap mm) =+ MultiMap $+ I.insertWith (<>) (hash path) [(path, v)] mm++----------------------------------------------------------------++-- | O(n)+toList :: MultiMap v -> [(FilePath, v)]+toList (MultiMap mm) = concatMap snd $ I.toAscList mm++----------------------------------------------------------------++-- | O(n)+pruneWith+ :: MultiMap v+ -> ((FilePath, v) -> IO Bool)+ -> IO (MultiMap v)+pruneWith (MultiMap mm) action =+ I.foldrWithKey go (pure . MultiMap) mm I.empty+ where+ go h s cont acc = do+ rs <- filterM action s+ case rs of+ [] -> cont acc+ _ -> cont $! I.insert h rs acc++----------------------------------------------------------------++-- O(n + m) where N is the size of the second argument+merge :: MultiMap v -> MultiMap v -> MultiMap v+merge (MultiMap m1) (MultiMap m2) = MultiMap $ I.unionWith (<>) m1 m2
+ Network/Wai/Handler/Warp/PackInt.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.PackInt where++import Data.ByteString.Internal (unsafeCreate)+import Data.Word8 (_0)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (poke)+import qualified Network.HTTP.Types as H++import Network.Wai.Handler.Warp.Imports++packIntegral :: Integral a => a -> ByteString+packIntegral 0 = "0"+packIntegral n | n < 0 = error "packIntegral"+packIntegral n = unsafeCreate len go0+ where+ n' = fromIntegral n + 1 :: Double+ len = ceiling $ logBase 10 n'+ go0 p = go n $ p `plusPtr` (len - 1)+ go :: Integral a => a -> Ptr Word8 -> IO ()+ go i p = do+ let (d, r) = i `divMod` 10+ poke p (_0 + fromIntegral r)+ when (d /= 0) $ go d (p `plusPtr` (-1))+{-# SPECIALIZE packIntegral :: Int -> ByteString #-}+{-# SPECIALIZE packIntegral :: Integer -> ByteString #-}++-- |+--+-- >>> packStatus H.status200+-- "200"+-- >>> packStatus H.preconditionFailed412+-- "412"+packStatus :: H.Status -> ByteString+packStatus status = unsafeCreate 3 $ \p -> do+ poke p (toW8 r2)+ poke (p `plusPtr` 1) (toW8 r1)+ poke (p `plusPtr` 2) (toW8 r0)+ where+ toW8 :: Int -> Word8+ toW8 n = _0 + fromIntegral n+ !s = fromIntegral $ H.statusCode status+ (!q0, !r0) = s `divMod` 10+ (!q1, !r1) = q0 `divMod` 10+ !r2 = q1 `mod` 10
+ Network/Wai/Handler/Warp/ReadInt.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3++module Network.Wai.Handler.Warp.ReadInt (+ readInt,+ readInt64,+) where++import qualified Data.ByteString as S+import Data.Word8 (isDigit, _0)++import Network.Wai.Handler.Warp.Imports hiding (readInt)++{-# INLINE readInt #-}++-- | Will 'takeWhile isDigit' and return the parsed 'Integral'.+readInt :: Integral a => ByteString -> a+readInt bs = fromIntegral $ readInt64 bs++-- This function is used to parse the Content-Length field of HTTP headers and+-- is a performance hot spot. It should only be replaced with something+-- significantly and provably faster.+--+-- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we+-- use Int64 here and then make a generic 'readInt' that allows conversion to+-- Int and Integer.++{-# NOINLINE readInt64 #-}+readInt64 :: ByteString -> Int64+readInt64 bs =+ S.foldl' (\ !i !c -> i * 10 + fromIntegral (c - _0)) 0 $+ S.takeWhile isDigit bs
+ Network/Wai/Handler/Warp/Request.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Network.Wai.Handler.Warp.Request (+ FirstRequest(..),+ recvRequest,+ headerLines,+ pauseTimeoutKey,+ getFileInfoKey,+#ifdef MIN_VERSION_crypton_x509+ getClientCertificateKey,+#endif+ NoKeepAliveRequest (..),+) where++import qualified Control.Concurrent as Conc (yield)+import qualified Data.ByteString as S+import qualified Data.ByteString.Unsafe as SU+import qualified Data.CaseInsensitive as CI+import qualified Data.IORef as I+import qualified Data.Vault.Lazy as Vault+import Data.Word8 (_cr, _lf)+#ifdef MIN_VERSION_crypton_x509+import Data.X509+#endif+import Control.Exception (Exception, throwIO)+import qualified Network.HTTP.Types as H+import Network.Socket (SockAddr)+import Network.Wai+import Network.Wai.Handler.Warp.Types+import Network.Wai.Internal+import System.IO.Unsafe (unsafePerformIO)+import qualified System.TimeManager as Timeout+import Prelude hiding (lines)++import Network.Wai.Handler.Warp.Conduit+import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Imports hiding (readInt)+import Network.Wai.Handler.Warp.ReadInt+import Network.Wai.Handler.Warp.RequestHeader+import Network.Wai.Handler.Warp.Settings (+ Settings,+ settingsMaxTotalHeaderLength,+ settingsNoParsePath,+ )++----------------------------------------------------------------++-- | first request on this connection?+data FirstRequest = FirstRequest | SubsequentRequest++-- | Receiving a HTTP request from 'Connection' and parsing its header+-- to create 'Request'.+recvRequest+ :: FirstRequest+ -> Settings+ -> Connection+ -> InternalInfo+ -> Timeout.Handle+ -> SockAddr+ -- ^ Peer's address.+ -> Source+ -- ^ Where HTTP request comes from.+ -> Transport+ -> IO+ ( Request+ , Maybe (I.IORef Int)+ , IndexedRequestHeader+ , IO ByteString+ )+ -- ^+ -- 'Request' passed to 'Application',+ -- how many bytes remain to be consumed, if known+ -- 'IndexedHeader' of HTTP request for internal use,+ -- Body producing action used for flushing the request body+recvRequest firstRequest settings conn ii th addr src transport = do+ hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src+ (method, unparsedPath, path, query, httpversion, hdr) <-+ parseHeaderLines hdrlines+ let idxhdr = indexRequestHeader hdr+ expect = reqidxExpect idxhdr+ handle100Continue = handleExpect conn httpversion expect+ (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr+ -- body producing function which will produce '100-continue', if needed+ rbody' <- timeoutBody remainingRef th rbody handle100Continue+ -- body producing function which will never produce 100-continue+ rbodyFlush <- timeoutBody remainingRef th rbody (return ())+ let rawPath = if settingsNoParsePath settings then unparsedPath else path+ vaultValue =+ Vault.insert pauseTimeoutKey (Timeout.pause th)+ . Vault.insert getFileInfoKey (getFileInfo ii)+#ifdef MIN_VERSION_crypton_x509+ . Vault.insert getClientCertificateKey (getTransportClientCertificate transport)+#endif+ $ Vault.empty+ req =+ Request+ { requestMethod = method+ , httpVersion = httpversion+ , pathInfo = H.decodePathSegments path+ , rawPathInfo = rawPath+ , rawQueryString = query+ , queryString = H.parseQuery query+ , requestHeaders = hdr+ , isSecure = isTransportSecure transport+ , remoteHost = addr+ , requestBody = rbody'+ , vault = vaultValue+ , requestBodyLength = bodyLength+ , requestHeaderHost = reqidxHost idxhdr+ , requestHeaderRange = reqidxRange idxhdr+ , requestHeaderReferer = reqidxReferer idxhdr+ , requestHeaderUserAgent = reqidxUserAgent idxhdr+ , requestSendEarlyHints = \_ -> pure ()+ }+ return (req, remainingRef, idxhdr, rbodyFlush)++----------------------------------------------------------------++headerLines :: Int -> FirstRequest -> Source -> IO [ByteString]+headerLines maxTotalHeaderLength firstRequest src = do+ bs <- readSource src+ if S.null bs+ then -- When we're working on a keep-alive connection and trying to+ -- get the second or later request, we don't want to treat the+ -- lack of data as a real exception. See the http1 function in+ -- the Run module for more details.++ case firstRequest of+ FirstRequest -> throwIO ConnectionClosedByPeer+ SubsequentRequest -> throwIO NoKeepAliveRequest+ else push maxTotalHeaderLength src (THStatus 0 0 id id) bs++data NoKeepAliveRequest = NoKeepAliveRequest+ deriving (Show)+instance Exception NoKeepAliveRequest++----------------------------------------------------------------++handleExpect+ :: Connection+ -> H.HttpVersion+ -> Maybe HeaderValue+ -> IO ()+handleExpect conn ver (Just "100-continue") = do+ connSendAll conn continue+ Conc.yield+ where+ continue+ | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n"+ | otherwise = "HTTP/1.0 100 Continue\r\n\r\n"+handleExpect _ _ _ = return ()++----------------------------------------------------------------++bodyAndSource+ :: Source+ -> IndexedRequestHeader+ -> IO+ ( IO ByteString+ , Maybe (I.IORef Int)+ , RequestBodyLength+ )+bodyAndSource src idxhdr+ | chunked = do+ csrc <- mkCSource src+ return (readCSource csrc, Nothing, ChunkedBody)+ | otherwise = do+ let len = toLength $ reqidxContentLength idxhdr+ bodyLen = KnownLength $ fromIntegral len+ isrc@(ISource _ remaining) <- mkISource src len+ return (readISource isrc, Just remaining, bodyLen)+ where+ chunked = isChunked $ reqidxTransferEncoding idxhdr++toLength :: Maybe HeaderValue -> Int+toLength Nothing = 0+toLength (Just bs) = readInt bs++isChunked :: Maybe HeaderValue -> Bool+isChunked (Just bs) = CI.foldCase bs == "chunked"+isChunked _ = False++----------------------------------------------------------------++timeoutBody+ :: Maybe (I.IORef Int)+ -- ^ remaining+ -> Timeout.Handle+ -> IO ByteString+ -> IO ()+ -> IO (IO ByteString)+timeoutBody remainingRef timeoutHandle rbody handle100Continue = do+ isFirstRef <- I.newIORef True++ let checkEmpty =+ case remainingRef of+ Nothing -> return . S.null+ Just ref -> \bs ->+ if S.null bs+ then return True+ else do+ x <- I.readIORef ref+ return $! x <= 0++ return $ do+ isFirst <- I.readIORef isFirstRef++ when isFirst $ do+ -- Only check if we need to produce the 100 Continue status+ -- when asking for the first chunk of the body+ handle100Continue+ -- Timeout handling was paused after receiving the full request+ -- headers. Now we need to resume it to avoid a slowloris+ -- attack during request body sending.+ Timeout.resume timeoutHandle+ I.writeIORef isFirstRef False++ bs <- rbody++ -- As soon as we finish receiving the request body, whether+ -- because the application is not interested in more bytes, or+ -- because there is no more data available, pause the timeout+ -- handler again.+ isEmpty <- checkEmpty bs+ when isEmpty (Timeout.pause timeoutHandle)++ return bs++----------------------------------------------------------------++type BSEndo = S.ByteString -> S.ByteString+type BSEndoList = [ByteString] -> [ByteString]++data THStatus+ = THStatus+ Int -- running total byte count (excluding current header chunk)+ Int -- current header chunk byte count+ BSEndoList -- previously parsed lines+ BSEndo -- bytestrings to be prepended++----------------------------------------------------------------++{- FIXME+close :: Sink ByteString IO a+close = throwIO IncompleteHeaders+-}++-- | Assumes the 'ByteString' is never 'S.null'+push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]+push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs+ -- Newline found at index 'ix'+ | Just ix <- S.elemIndex _lf bs = do+ -- Too many bytes+ when (currentTotal > maxTotalHeaderLength) $ throwIO OverLargeHeader+ newlineFound ix+ -- No newline found+ | otherwise = do+ -- Early easy abort+ when (currentTotal + bsLen > maxTotalHeaderLength) $ throwIO OverLargeHeader+ withNewChunk noNewlineFound+ where+ bsLen = S.length bs+ currentTotal = totalLen + chunkLen+ {-# INLINE withNewChunk #-}+ withNewChunk :: (S.ByteString -> IO a) -> IO a+ withNewChunk f = do+ newChunk <- readSource' src+ when (S.null newChunk) $ throwIO IncompleteHeaders+ f newChunk+ {-# INLINE noNewlineFound #-}+ noNewlineFound newChunk+ -- The chunk split the CRLF in half+ | SU.unsafeLast bs == _cr && S.head newChunk == _lf =+ let bs' = SU.unsafeDrop 1 newChunk+ in if bsLen == 1 && chunkLen == 0+ -- first part is only CRLF, we're done+ then do+ when (not $ S.null bs') $ leftoverSource src bs'+ pure $ reqLines []+ else do+ rest <- if S.null bs'+ -- new chunk is only LF, we need more to check for multiline+ then withNewChunk pure+ else pure bs'+ let status = addLine (bsLen + 1) (SU.unsafeTake (bsLen - 1) bs)+ push maxTotalHeaderLength src status rest+ -- chunk and keep going+ | otherwise = do+ let newChunkTotal = chunkLen + bsLen+ newPrepend = prepend . (bs <>)+ status = THStatus totalLen newChunkTotal reqLines newPrepend+ push maxTotalHeaderLength src status newChunk+ {-# INLINE newlineFound #-}+ newlineFound ix+ -- Is end of headers+ | chunkLen == 0 && startsWithLF = do+ let rest = SU.unsafeDrop end bs+ when (not $ S.null rest) $ leftoverSource src rest+ pure $ reqLines []+ | otherwise = do+ -- LF is on last byte+ let p = ix - 1+ chunk =+ if ix > 0 && SU.unsafeIndex bs p == _cr then p else ix+ status = addLine end (SU.unsafeTake chunk bs)+ continue = push maxTotalHeaderLength src status+ if end == bsLen+ then withNewChunk continue+ else continue $ SU.unsafeDrop end bs+ where+ end = ix + 1+ startsWithLF =+ case ix of+ 0 -> True+ 1 -> SU.unsafeHead bs == _cr+ _ -> False+ -- addLine: take the current chunk and, if there's nothing to prepend,+ -- add straight to 'reqLines', otherwise first prepend then add.+ {-# INLINE addLine #-}+ addLine len chunk =+ let newTotal = currentTotal + len+ newLine =+ if chunkLen == 0 then chunk else prepend chunk+ in THStatus newTotal 0 (reqLines . (newLine:)) id+{- HLint ignore push "Use unless" -}+++pauseTimeoutKey :: Vault.Key (IO ())+pauseTimeoutKey = unsafePerformIO Vault.newKey+{-# NOINLINE pauseTimeoutKey #-}++getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)+getFileInfoKey = unsafePerformIO Vault.newKey+{-# NOINLINE getFileInfoKey #-}++#ifdef MIN_VERSION_crypton_x509+getClientCertificateKey :: Vault.Key (Maybe CertificateChain)+getClientCertificateKey = unsafePerformIO Vault.newKey+{-# NOINLINE getClientCertificateKey #-}+#endif
+ Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Handler.Warp.RequestHeader (+ parseHeaderLines,+) where++import Control.Exception (throwIO)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C8 (unpack)+import Data.ByteString.Internal (memchr)+import qualified Data.CaseInsensitive as CI+import Data.Word8+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)+import Foreign.Storable (peek)+import qualified Network.HTTP.Types as H++import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++parseHeaderLines+ :: [ByteString]+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Path, parsed+ , ByteString -- Query+ , H.HttpVersion+ , H.RequestHeaders+ )+parseHeaderLines [] = throwIO $ NotEnoughLines []+parseHeaderLines (firstLine : otherLines) = do+ (method, path', query, httpversion) <- parseRequestLine firstLine+ let path = H.extractPath path'+ hdr = map parseHeader otherLines+ return (method, path', path, query, httpversion, hdr)++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine "GET "+-- *** Exception: Warp: Invalid first line of request: "GET "+-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: Warp: Request line specified a non-HTTP request+-- >>> parseRequestLine "PRI * HTTP/2.0"+-- ("PRI","*","",HTTP/2.0)+parseRequestLine+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ )+parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do+ when (len < 14) $ throwIO baderr+ let methodptr = ptr `plusPtr` off+ limptr = methodptr `plusPtr` len+ lim0 = fromIntegral len++ pathptr0 <- memchr methodptr _space lim0+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $+ throwIO baderr+ let pathptr = pathptr0 `plusPtr` 1+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)++ httpptr0 <- memchr pathptr _space lim1+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $+ throwIO baderr+ let httpptr = httpptr0 `plusPtr` 1+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)++ checkHTTP httpptr+ !hv <- httpVersion httpptr+ queryptr <- memchr pathptr _question lim2++ let !method = bs ptr methodptr pathptr0+ !path+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr+ !query+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0++ return (method, path, query, hv)+ where+ baderr = BadFirstLine $ C8.unpack requestLine+ check :: Ptr Word8 -> Int -> Word8 -> IO ()+ check p n w = do+ w0 <- peek $ p `plusPtr` n+ when (w0 /= w) $ throwIO NonHttp+ checkHTTP httpptr = do+ check httpptr 0 _H+ check httpptr 1 _T+ check httpptr 2 _T+ check httpptr 3 _P+ check httpptr 4 _slash+ check httpptr 6 _period+ httpVersion httpptr = do+ major <- peek (httpptr `plusPtr` 5) :: IO Word8+ minor <- peek (httpptr `plusPtr` 7) :: IO Word8+ let version+ | major == _1 = if minor == _1 then H.http11 else H.http10+ | major == _2 && minor == _0 = H.http20+ | otherwise = H.http10+ return version+ bs ptr p0 p1 = PS fptr o l+ where+ o = p0 `minusPtr` ptr+ l = p1 `minusPtr` p0++----------------------------------------------------------------++-- |+--+-- >>> parseHeader "Content-Length:47"+-- ("Content-Length","47")+-- >>> parseHeader "Accept-Ranges: bytes"+-- ("Accept-Ranges","bytes")+-- >>> parseHeader "Host: example.com:8080"+-- ("Host","example.com:8080")+-- >>> parseHeader "NoSemiColon"+-- ("NoSemiColon","")+parseHeader :: ByteString -> H.Header+parseHeader s =+ let (k, rest) = S.break (== _colon) s+ rest' = S.dropWhile (\c -> c == _space || c == _tab) $ S.drop 1 rest+ in (CI.mk k, rest')
+ Network/Wai/Handler/Warp/Response.hs view
@@ -0,0 +1,579 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.Response (+ sendResponse,+ sanitizeHeaderValue, -- for testing+ containsRecoverableWhitespace, -- for benchmarking+ -- Provided here for backwards compatibility.+ warpVersion,+ hasBody,+ replaceHeader,+ addServer, -- testing+ addAltSvc,+) where++import qualified Control.Exception as E+import qualified Data.ByteString as S+import Data.ByteString.Internal (toForeignPtr, unsafeCreate)+import Data.ByteString.Builder (Builder, byteString)+import Data.ByteString.Builder.Extra (flush)+import Data.ByteString.Builder.HTTP.Chunked (+ chunkedTransferEncoding,+ chunkedTransferTerminator,+ )+import qualified Data.CaseInsensitive as CI+import Data.Foldable (for_)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Streaming.ByteString.Builder (+ newByteStringBuilderRecv,+ reuseBufferStrategy,+ )+import Data.Word8 (_cr, _lf, _nul, _space)+import Foreign (copyBytes, plusForeignPtr, pokeByteOff, withForeignPtr)+import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as Header+import Network.Wai+import Network.Wai.Internal+import qualified System.TimeManager as T++import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)+import qualified Network.Wai.Handler.Warp.Date as D+import Network.Wai.Handler.Warp.File+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.IO (toBufIOWith)+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.ResponseHeader+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++-- | Sending a HTTP response to 'Connection' according to 'Response'.+--+-- Applications/middlewares MUST provide a proper 'H.ResponseHeaders'.+-- so that inconsistency does not happen.+-- No header is deleted by this function.+--+-- Especially, Applications/middlewares MUST provide a proper+-- Content-Type. They MUST NOT provide+-- Content-Length, Content-Range, and Transfer-Encoding+-- because they are inserted, when necessary,+-- regardless they already exist.+-- This function does not insert Content-Encoding. It's middleware's+-- responsibility.+--+-- The Date and Server header is added if not exist+-- in HTTP response header.+--+-- There are three basic APIs to create 'Response':+--+-- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']+-- HTTP response body is created from 'Builder'.+-- Transfer-Encoding: chunked is used in HTTP/1.1.+--+-- ['responseStream' :: 'H.Status' -> 'H.ResponseHeaders' -> 'StreamingBody' -> 'Response']+-- HTTP response body is created from 'Builder'.+-- Transfer-Encoding: chunked is used in HTTP/1.1.+--+-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']+-- No header is added and no Transfer-Encoding: is applied.+--+-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']+-- HTTP response body is sent (by sendfile(), if possible) for GET method.+-- HTTP response body is not sent by HEAD method.+-- Content-Length and Content-Range are automatically+-- added into the HTTP response header if necessary.+-- If Content-Length and Content-Range exist in the HTTP response header,+-- they would cause inconsistency.+-- \"Accept-Ranges: bytes\" is also inserted.+--+-- Applications are categorized into simple and sophisticated.+-- Sophisticated applications should specify 'Just' to+-- 'Maybe' 'FilePart'. They should treat the conditional request+-- by themselves. A proper 'Status' (200 or 206) must be provided.+--+-- Simple applications should specify 'Nothing' to+-- 'Maybe' 'FilePart'. The size of the specified file is obtained+-- by disk access or from the file info cache.+-- If-Modified-Since, If-Unmodified-Since, If-Range and Range+-- are processed. Since a proper status is chosen, 'Status' is+-- ignored. Last-Modified is inserted.+sendResponse+ :: Settings+ -> Connection+ -> InternalInfo+ -> T.Handle+ -> Request+ -- ^ HTTP request.+ -> IndexedRequestHeader+ -- ^ Indexed header of HTTP request.+ -> IO ByteString+ -- ^ source from client, for raw response+ -> Response+ -- ^ HTTP response including status code and response header.+ -> IO Bool+ -- ^ Returing True if the connection is persistent.+sendResponse settings conn ii th req reqidxhdr src response = do+ -- Decide connection persistence+ isShuttingDown <-+ case settingsServerState settings of+ Just serverState -> currentShuttingDownState serverState+ -- Should never be reached!+ -- (cf. 'makeServerState' in 'runSettingsConnectionMakerSecure')+ Nothing -> pure False+ let shouldPersist = not isShuttingDown && ret+ addConnection hs =+ if shouldPersist || responseWantsToClose+ then hs+ else (Header.hConnection, "close") : hs++ -- Adjust headers+ hs <- addConnection . addAltSvc settings <$> addServerAndDate hs0++ -- Start response logic+ if hasBody s+ then do+ -- The response to HEAD does not have body.+ -- But to handle the conditional requests defined RFC 7232 and+ -- to generate appropriate content-length, content-range,+ -- and status, the response to HEAD is processed here.+ --+ -- See definition of rsp below for proper body stripping.+ (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method rsp+ case ms of+ Nothing -> return ()+ Just realStatus -> logger req realStatus mlen+ else do+ _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody+ logger req s Nothing+ T.tickle th+ return shouldPersist+ where+ -- From Settings --+ defServer = settingsServerName settings+ logger = settingsLogger settings+ maxRspBufSize = settingsMaxBuilderResponseBufferSize settings++ -- From Request --+ method = requestMethod req+ isHead = method == H.methodHead+ ver = httpVersion req+ isHttp11 = ver == H.http11+ reqSaysPersist = checkReqConnectionHeader isHttp11 reqidxhdr++ -- From Response --+ s = responseStatus response+ hs0 = sanitizeHeaders $ responseHeaders response+ rspidxhdr = indexResponseHeader hs0+ hasLength = hasContentLength rspidxhdr+ responseWantsToClose =+ case hasConnection rspidxhdr of+ Nothing -> False+ Just v -> CI.foldCase v == "close"+ isPersist = reqSaysPersist && not responseWantsToClose++ -- Other --+ getdate = getDate ii+ addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr+ needsChunked = isHttp11 && not hasLength+ rsp = case response of+ ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr (T.tickle th)+ ResponseBuilder _ _ b+ | isHead -> RspNoBody+ | otherwise -> RspBuilder b needsChunked+ ResponseStream _ _ fb+ | isHead -> RspNoBody+ | otherwise -> RspStream fb needsChunked+ ResponseRaw raw _ -> RspRaw raw src+ -- Should be False if (http10 && not hasLength), regardless of what+ -- the 'Connection' header says. (as long as the response should have a body)+ isKeepAlive =+ isPersist && (isHttp11 || hasLength || isHead || not (hasBody s))+ -- Make sure we don't hang on to 'response' (avoid space leak)+ !ret = case response of+ -- Will get 'Content-Length' header later on using the+ -- 'addContentHeaders(ForFilePart)' functions, so if the+ -- 'Connection' header says we persist, we persist.+ ResponseFile{} -> isPersist+ ResponseBuilder{} -> isKeepAlive+ ResponseStream{} -> isKeepAlive+ -- Is already an ongoing open connection, so if it is done,+ -- the connection should be closed.+ ResponseRaw{} -> False++----------------------------------------------------------------++-- | As per RFC 9110 we replace any newlines (\r\n) or \NUL with spaces+-- Values without CR/LF/NUL (the overwhelmingly common case) leave the+-- header list untouched; only a dirty value triggers a rebuild.+sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders+sanitizeHeaders hdrs+ -- slow path+ | any (containsRecoverableWhitespace . snd) hdrs = map (sanitize <$>) hdrs+ -- fast path+ | otherwise = hdrs+ where+ sanitize bs+ | containsRecoverableWhitespace bs = sanitizeHeaderValue bs+ | otherwise = bs++-- Yes, this is quicker than @S.any (\w -> w == _lf || w == _cr || w == _nul)@+-- because of `bytestring`'s rewrite rules.+containsRecoverableWhitespace :: ByteString -> Bool+containsRecoverableWhitespace bs =+ S.any (_lf ==) bs || S.any (_cr ==) bs || S.any (_nul ==) bs++{-# INLINE isRecoverableWhitespace #-}+-- | CR, LF and NUL can safely be replaced with a SP according to RFC 9110+-- <https://www.rfc-editor.org/rfc/rfc9110.html#section-5.5-5>+isRecoverableWhitespace :: Word8 -> Bool+isRecoverableWhitespace w = w == _cr || w == _lf || w == _nul++sanitizeHeaderValue :: ByteString -> ByteString+sanitizeHeaderValue v =+ case S.findIndices isRecoverableWhitespace v of+ -- Nothing to replace+ [] -> v+ -- Found CR, LF or NUL.+ ixs ->+ unsafeCreate len $ \dst -> do+ withForeignPtr fptr $ \src -> do+ -- copy the bytestring+ copyBytes dst src len+ -- and then replace the offending bytes+ for_ ixs $ \ix -> pokeByteOff dst ix _space+ where+ (fptr', offset, len) = toForeignPtr v+ -- We need to use the offset for backwards compatibility with+ -- "bytestring < 0.11"+ fptr = fptr' `plusForeignPtr` offset++----------------------------------------------------------------++data Rsp+ = RspNoBody+ | RspFile FilePath (Maybe FilePart) IndexedRequestHeader (IO ())+ | RspBuilder Builder Bool+ | RspStream StreamingBody Bool+ | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)++----------------------------------------------------------------++sendRsp+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> ResponseHeaderPresence+ -> Int -- maxBuilderResponseBufferSize+ -> H.Method+ -> Rsp+ -> IO (Maybe H.Status, Maybe Integer)+----------------------------------------------------------------++sendRsp conn _ _ ver s hs _ _ _ RspNoBody = do+ -- Not adding Content-Length.+ -- User agents treats it as Content-Length: 0.+ composeHeader ver s hs >>= connSendAll conn+ return (Just s, Just 0)++----------------------------------------------------------------++sendRsp conn _ th ver s hs rspidxhdr maxRspBufSize _ (RspBuilder body needsChunked) = do+ (header, hdrLen) <- composeHeaderBuilder ver s hs rspidxhdr needsChunked+ let hdrBdy+ | needsChunked =+ header+ <> chunkedTransferEncoding body+ <> chunkedTransferTerminator+ | otherwise = header <> body+ writeBufferRef = connWriteBuffer conn+ len <-+ toBufIOWith+ maxRspBufSize+ writeBufferRef+ (\bs -> connSendAll conn bs >> T.tickle th)+ hdrBdy+ -- small adjustment to only count the body+ return (Just s, Just $ len - fromIntegral hdrLen)++----------------------------------------------------------------++sendRsp conn _ th ver s hs rspidxhdr _ _ (RspStream streamingBody needsChunked) = do+ (header, hdrLen) <- composeHeaderBuilder ver s hs rspidxhdr needsChunked+ (recv, finish) <-+ newByteStringBuilderRecv $+ reuseBufferStrategy $+ toBuilderBuffer $+ connWriteBuffer conn+ -- We'll be counting how many bytes we send with this 'IORef'+ sizeCounter <- newIORef (0 :: Integer)+ let sendFragmentAndCount bs = do+ sendFragment conn th bs+ -- add amount of bytes to count+ S.length bs `addToCounter` sizeCounter+ let send builder = do+ popper <- recv builder+ let loop = do+ bs <- popper+ unless (S.null bs) $ do+ sendFragmentAndCount bs+ loop+ loop+ sendChunk+ | needsChunked = send . chunkedTransferEncoding+ | otherwise = send+ send header+ streamingBody sendChunk (sendChunk flush)+ when needsChunked $ send chunkedTransferTerminator+ -- final flush+ finish >>= mapM_ sendFragmentAndCount+ finalSize <- readIORef sizeCounter+ -- small adjustment to only count the body+ return (Just s, Just $ finalSize - fromIntegral hdrLen)+ where+ addToCounter :: Int -> IORef Integer -> IO ()+ addToCounter bytes ref =+ atomicModifyIORef' ref $ \old ->+ (old + fromIntegral bytes, ())++----------------------------------------------------------------++sendRsp conn _ th _ _ _ _ _ _ (RspRaw withApp src) = do+ withApp recv send+ return (Nothing, Nothing)+ where+ recv = do+ bs <- src+ unless (S.null bs) $ T.tickle th+ return bs+ send bs = connSendAll conn bs >> T.tickle th++----------------------------------------------------------------++-- Sophisticated WAI applications.+-- We respect s0. s0 MUST be a proper value.+sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just part) _ hook) =+ sendRspFile2XX+ conn+ ii+ th+ ver+ s0+ hs+ rspidxhdr+ maxRspBufSize+ method+ path+ beg+ len+ hook+ where+ beg = filePartOffset part+ len = filePartByteCount part+ hs = addContentHeadersForFilePart hs0 part++----------------------------------------------------------------++-- Simple WAI applications.+-- Status is ignored+sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize method (RspFile path Nothing reqidxhdr hook) = do+ efinfo <- E.try $ getFileInfo ii path+ case efinfo of+ Left (_ex :: E.IOException) ->+#ifdef WARP_DEBUG+ print _ex >>+#endif+ sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method+ Right finfo -> case conditionalRequest finfo hs0 method rspidxhdr reqidxhdr of+ WithoutBody s ->+ sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize method RspNoBody+ WithBody s hs beg len ->+ sendRspFile2XX+ conn+ ii+ th+ ver+ s+ hs+ rspidxhdr+ maxRspBufSize+ method+ path+ beg+ len+ hook++----------------------------------------------------------------++sendRspFile2XX+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> ResponseHeaderPresence+ -> Int+ -> H.Method+ -> FilePath+ -> Integer+ -> Integer+ -> IO ()+ -> IO (Maybe H.Status, Maybe Integer)+sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len hook+ | method == H.methodHead =+ -- FIXME: We could check the size of the file and add a+ -- 'Content-Length' header to give the requester more information?+ sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody+ | otherwise = do+ lheader <- composeHeader ver s hs+ (mfd, fresher) <- getFd ii path+ let fid = FileId path mfd+ hook' = hook >> fresher+ connSendFile conn fid beg len hook' [lheader]+ return (Just s, Just len)++sendRspFile404+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.ResponseHeaders+ -> ResponseHeaderPresence+ -> Int+ -> H.Method+ -> IO (Maybe H.Status, Maybe Integer)+sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method =+ sendRsp+ conn+ ii+ th+ ver+ s+ hs+ rspidxhdr+ maxRspBufSize+ method+ (RspBuilder body True)+ where+ s = H.notFound404+ hs = replaceHeader Header.hContentType "text/plain; charset=utf-8" hs0+ body = byteString "File not found"++----------------------------------------------------------------+----------------------------------------------------------------++-- | Use 'connSendAll' to send this data while respecting timeout rules.+sendFragment :: Connection -> T.Handle -> ByteString -> IO ()+sendFragment Connection{connSendAll = send} th bs = do+ T.resume th+ send bs+ T.pause th++-- We pause timeouts before passing control back to user code. This ensures+-- that a timeout will only ever be executed when Warp is in control. We+-- also make sure to resume the timeout after the completion of user code+-- so that we can kill idle connections.++----------------------------------------------------------------++-- | We infer from the request whether the connection should be persisted.+checkReqConnectionHeader :: Bool -> IndexedRequestHeader -> Bool+checkReqConnectionHeader isHttp11 reqidxhdr =+ case reqidxConnection reqidxhdr of+ -- If no "Connection" header, then default: HTTP/1.1 == persist+ Nothing -> isHttp11+ Just val ->+ let connValue = CI.foldCase val+ in if isHttp11+ then connValue /= "close"+ else connValue == "keep-alive"++----------------------------------------------------------------++-- | Only checks for status codes, NOT for methods.+--+-- This is by design and some handling relies on HEAD being a separate check.+hasBody :: H.Status -> Bool+hasBody s =+ sc /= 204+ && sc /= 304+ && sc >= 200+ where+ sc = H.statusCode s++----------------------------------------------------------------++-- | We ASSUME there's no middleware that will chunk the transfer, so+-- we'll add it to the headers if there's no other encoding, or add it+-- to the end in case it is.+-- (e.g. if a 'Middleware' were to add "Transfer-Encoding: gzip")+addTransferEncoding :: ResponseHeaderPresence -> H.ResponseHeaders -> H.ResponseHeaders+addTransferEncoding rspidxhdr =+ case hasTransferEncoding rspidxhdr of+ Just value -> replaceHeader Header.hTransferEncoding (value <> ", chunked")+ Nothing -> ((Header.hTransferEncoding, "chunked") :)++addDate+ :: IO D.GMTDate -> ResponseHeaderPresence -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate getdate rspidxhdr hdrs+ | hasDate rspidxhdr = return hdrs+ | otherwise = do+ gmtdate <- getdate+ return $ (Header.hDate, gmtdate) : hdrs++----------------------------------------------------------------++{-# INLINE addServer #-}+addServer+ :: HeaderValue -> ResponseHeaderPresence -> H.ResponseHeaders -> H.ResponseHeaders+addServer serverName rspidxhdr hdrs =+ case serverName of+ -- empty string means there shouldn't be a "Server" header+ ""+ | serverPresent -> filter ((/= Header.hServer) . fst) hdrs+ | otherwise -> hdrs+ -- Anything else should set the "Server" header if it isn't already set+ _+ | not serverPresent -> (Header.hServer, serverName) : hdrs+ | otherwise -> hdrs+ where+ serverPresent = hasServer rspidxhdr++addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders+addAltSvc settings hs = case settingsAltSvc settings of+ Nothing -> hs+ Just v -> ("Alt-Svc", v) : hs++----------------------------------------------------------------++-- | Replaces a header, instead of just adding it which might lead to+-- duplicate entries of the same header name.+--+-- >>> replaceHeader "Content-Type" "new" [("content-type","old")]+-- [("Content-Type","new")]+replaceHeader+ :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders+replaceHeader k v hdrs = (k, v) : filter ((/= k) . fst) hdrs++----------------------------------------------------------------++composeHeaderBuilder+ :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ResponseHeaderPresence -> Bool -> IO (Builder, Int)+composeHeaderBuilder ver s hs rspidxhdr shouldChunk = do+ bs <- composeHeader ver s finalHdrs+ pure (byteString bs, S.length bs)+ where+ finalHdrs+ | shouldChunk = addTransferEncoding rspidxhdr hs+ | otherwise = hs
+ Network/Wai/Handler/Warp/ResponseHeader.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where++import qualified Data.ByteString as S+import Data.ByteString.Internal (create)+import qualified Data.CaseInsensitive as CI+import Data.List as List (foldl')+import Data.Word8+import Foreign.Ptr+import GHC.Storable+import qualified Network.HTTP.Types as H+import Network.Socket.BufferPool (copy)++import Network.Wai.Handler.Warp.Imports++----------------------------------------------------------------++composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString+composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do+ ptr1 <- copyStatus ptr httpversion status+ ptr2 <- copyHeaders ptr1 responseHeaders+ void $ copyCRLF ptr2+ where+ !len = 17 + slen + List.foldl' fieldLength 0 responseHeaders+ fieldLength !l (!k, !v) = l + S.length (CI.original k) + S.length v + 4+ !slen = S.length $ H.statusMessage status++httpVer11 :: ByteString+httpVer11 = "HTTP/1.1 "++httpVer10 :: ByteString+httpVer10 = "HTTP/1.0 "++{-# INLINE copyStatus #-}+copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8)+copyStatus !ptr !httpversion !status = do+ ptr1 <- copy ptr httpVer+ writeWord8OffPtr ptr1 0 (_0 + fromIntegral r2)+ writeWord8OffPtr ptr1 1 (_0 + fromIntegral r1)+ writeWord8OffPtr ptr1 2 (_0 + fromIntegral r0)+ writeWord8OffPtr ptr1 3 _space+ ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status)+ copyCRLF ptr2+ where+ httpVer+ | httpversion == H.HttpVersion 1 1 = httpVer11+ | otherwise = httpVer10+ (q0, r0) = H.statusCode status `divMod` 10+ (q1, r1) = q0 `divMod` 10+ r2 = q1 `mod` 10++{-# INLINE copyHeaders #-}+copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8)+copyHeaders !ptr [] = return ptr+copyHeaders !ptr (h : hs) = do+ ptr1 <- copyHeader ptr h+ copyHeaders ptr1 hs++{-# INLINE copyHeader #-}+copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8)+copyHeader !ptr (k, v) = do+ ptr1 <- copy ptr (CI.original k)+ writeWord8OffPtr ptr1 0 _colon+ writeWord8OffPtr ptr1 1 _space+ ptr2 <- copy (ptr1 `plusPtr` 2) v+ copyCRLF ptr2++{-# INLINE copyCRLF #-}+copyCRLF :: Ptr Word8 -> IO (Ptr Word8)+copyCRLF !ptr = do+ writeWord8OffPtr ptr 0 _cr+ writeWord8OffPtr ptr 1 _lf+ return $! ptr `plusPtr` 2
+ Network/Wai/Handler/Warp/Run.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Network.Wai.Handler.Warp.Run where++import Control.Arrow (first)+import Control.Concurrent.STM (+ TVar,+ atomically,+ check,+ modifyTVar',+ newTVarIO,+ readTVar,+ )+import qualified Control.Exception as E+import qualified Data.ByteString as S+import Data.Functor (($>))+import Data.IORef (newIORef, readIORef, IORef, writeIORef)+import Data.Streaming.Network (bindPortTCP)+import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE)+import GHC.Conc.Sync (labelThread, myThreadId)+import GHC.IO.Exception (IOErrorType (..), IOException (..))+import Network.Socket (+ SockAddr,+ Socket,+ SocketOption (..),+ close,+#if !WINDOWS+ fdSocket,+#if MIN_VERSION_network(3,2,2)+ waitReadSocketSTM,+#endif+#endif+ getSocketName,+ setSocketOption,+ withSocketsDo,+ )+#if MIN_VERSION_network(3,1,1)+import Network.Socket (gracefulClose)+#endif+import Network.Socket.BufferPool+import qualified Network.Socket.ByteString as Sock+import Network.Wai+import System.Environment (lookupEnv)+import System.IO.Error (ioeGetErrorType)+import qualified System.TimeManager as T+import System.Timeout (timeout)++import Network.Wai.Handler.Warp.Buffer (createWriteBuffer)+import Network.Wai.Handler.Warp.Counter+import qualified Network.Wai.Handler.Warp.Date as D+import qualified Network.Wai.Handler.Warp.FdCache as F+import qualified Network.Wai.Handler.Warp.FileInfoCache as I+import Network.Wai.Handler.Warp.HTTP1 (http1)+import Network.Wai.Handler.Warp.HTTP2 (http2)+import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)+import Network.Wai.Handler.Warp.Imports hiding (readInt)+import Network.Wai.Handler.Warp.SendFile (sendFile)+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown)+import Network.Wai.Handler.Warp.Types++-- | Creating 'Connection' for plain HTTP based on a given socket.+--+-- (N.B. make sure the 'Settings' have an initialized 'ServerState' to guarantee+-- a graceful shutdown)+socketConnection :: Settings -> Socket -> IO Connection+socketConnection set s = do+ (ss, _) <- makeServerState set+ bufferPool <- newBufferPool 2048 16384+ writeBuffer <- createWriteBuffer 16384+ writeBufferRef <- newIORef writeBuffer+ isH2 <- newIORef False -- HTTP/1.x+ mysa <- getSocketName s+ appsInProgress <- newTVarIO 0+ return+ Connection+ { connSendMany = Sock.sendMany s+ , connSendAll = sendall+ , connSendFile = sendfile writeBufferRef+#if MIN_VERSION_network(3,1,1)+ , connClose = do+ h2 <- readIORef isH2+ let tm =+ if h2+ then settingsGracefulCloseTimeout2 set+ else settingsGracefulCloseTimeout1 set+ if tm == 0+ then close s+ else gracefulClose s tm `E.catch` throughAsync (return ())+#else+ , connClose = close s+#endif+ , connRecv = receive' bufferPool ss appsInProgress+ , connRecvBuf = \_ _ -> return True -- obsoleted+ , connWriteBuffer = writeBufferRef+ , connHTTP2 = isH2+ , connMySockAddr = mysa+ , connAppsInProgress = appsInProgress+ }+ where+ receive' bufferPool ss appsInProgress =+ E.handle handler $ makeGracefulRecv s bufferPool ss appsInProgress+ where+ handler :: E.IOException -> IO ByteString+ handler e+ | ioeGetErrorType e == InvalidArgument = return ""+ | otherwise = E.throwIO e++ sendfile writeBufferRef fid offset len hook headers = do+ writeBuffer <- readIORef writeBufferRef+ sendFile+ s+ (bufBuffer writeBuffer)+ (bufSize writeBuffer)+ sendall+ fid+ offset+ len+ hook+ headers++ sendall = sendAll' s++ sendAll' sock bs =+ E.handleJust+ ( \e ->+ if ioeGetErrorType e == ResourceVanished+ then Just ConnectionClosedByPeer+ else Nothing+ )+ E.throwIO+ $ Sock.sendAll sock bs++-- | Create a 'Recv' using 'Network.Socket.BufferPool.Recv.receive', but make+-- it non-blocking with 'waitReadSocketSTM' /AND/ cut off receiving any bytes+-- when the server is shutting down and there are no more 'Application's+-- actively using this 'Socket'.+makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv+makeGracefulRecv sock pool ss appsInProgress = do+ sockWait <-+#if !WINDOWS && MIN_VERSION_network(3,2,2)+ waitReadSocketSTM sock+#else+ -- FIXME: 'waitReadSocketSTM' doesn't work on WINDOWS, and actually+ -- blocks indefinitely, so we fall back to going straight to 'recv'.+ pure (pure ())+#endif+ isShuttingDown <- atomically $+ -- when shutting down+ (checkShutdown $> True)+ <|>+ -- else wait for socket readiness and do non-blocking read+ (sockWait $> False)+ if isShuttingDown then pure "" else recv+ where+ recv = receive sock pool+ checkShutdown = do+ check =<< currentShuttingDownStateSTM ss+ check . (<= 0) =<< readTVar appsInProgress++-- | Run an 'Application' on the given port.+-- This calls 'runSettings' with 'defaultSettings'.+run :: Port -> Application -> IO ()+run p = runSettings defaultSettings{settingsPort = p}++-- | Run an 'Application' on the port present in the @PORT@+-- environment variable. Uses the 'Port' given when the variable is unset.+-- This calls 'runSettings' with 'defaultSettings'.+--+-- Since 3.0.9+runEnv :: Port -> Application -> IO ()+runEnv p app = do+ mp <- lookupEnv "PORT"++ maybe (run p app) runReadPort mp+ where+ runReadPort :: String -> IO ()+ runReadPort sp = case reads sp of+ ((p', _) : _) -> run p' app+ _ -> fail $ "Invalid value in $PORT: " ++ sp++-- | Run an 'Application' with the given 'Settings'.+-- This opens a listen socket on the port defined in 'Settings' and+-- calls 'runSettingsSocket'.+runSettings :: Settings -> Application -> IO ()+runSettings set app =+ withSocketsDo $+ E.bracket+ (bindPortTCP (settingsPort set) (settingsHost set))+ close+ ( \socket -> do+ setSocketCloseOnExec socket+ runSettingsSocket set socket app+ )++-- | This installs a shutdown handler for the given socket and+-- calls 'runSettingsConnection' with the default connection setup action+-- which handles plain (non-cipher) HTTP.+-- When the listen socket in the second argument is closed, all live+-- connections are gracefully shut down.+--+-- The supplied socket can be a Unix named socket, which+-- can be used when reverse HTTP proxying into your application.+--+-- Note that the 'settingsPort' will still be passed to 'Application's via the+-- 'serverPort' record.+runSettingsSocket :: Settings -> Socket -> Application -> IO ()+runSettingsSocket oldSettings@Settings{settingsAccept = accept'} socket app = do+ settingsInstallShutdownHandler oldSettings closeListenSocket+ (_, newSettings) <- makeServerState oldSettings+ runSettingsConnection newSettings (getConn newSettings) app+ where+ getConn set = do+ (s, sa) <- accept' socket+ setSocketCloseOnExec s+ -- NoDelay causes an error for AF_UNIX.+ setSocketOption s NoDelay 1 `E.catch` throughAsync (return ())+ conn <- socketConnection set s+ return (conn, sa)++ closeListenSocket = close socket++-- | The connection setup action would be expensive. A good example+-- is initialization of TLS.+-- So, this converts the connection setup action to the connection maker+-- which will be executed after forking a new worker thread.+-- Then this calls 'runSettingsConnectionMaker' with the connection maker.+-- This allows the expensive computations to be performed+-- in a separate worker thread instead of the main server loop.+--+-- Since 1.3.5+runSettingsConnection+ :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()+runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app+ where+ getConnMaker = do+ (conn, sa) <- getConn+ return (return conn, sa)++-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'+-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.+runSettingsConnectionMaker+ :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()+runSettingsConnectionMaker x y =+ runSettingsConnectionMakerSecure x (toTCP <$> y)+ where+ toTCP = first ((,TCP) <$>)++----------------------------------------------------------------++-- | The core run function which takes 'Settings',+-- a connection maker and 'Application'.+-- The connection maker can return a connection of either plain HTTP+-- or HTTP over TLS.+--+-- Since 2.1.4+runSettingsConnectionMakerSecure+ :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()+runSettingsConnectionMakerSecure oldSettings getConnMaker app = do+ settingsBeforeMainLoop oldSettings+ (ServerState{serverConnectionCounter}, newSettings) <- makeServerState oldSettings+ withII newSettings $ \ii ->+ initFdExhaustionRef >>=+ acceptConnection newSettings getConnMaker app serverConnectionCounter ii++-- | Running an action with internal info.+--+-- Since 3.3.11+withII :: Settings -> (InternalInfo -> IO a) -> IO a+withII set action =+ withTimeoutManager $ \tm ->+ D.withDateCache $ \dc ->+ F.withFdCache fdCacheDurationInMicroseconds $ \fdc ->+ I.withFileInfoCache fdFileInfoDurationInMicroseconds $ \fic -> do+ let ii = InternalInfo tm dc fdc fic+ action ii+ where+ !fdCacheDurationInMicroseconds = settingsFdCacheDuration set * 1000000+ !fdFileInfoDurationInMicroseconds = settingsFileInfoCacheDuration set * 1000000+ !timeoutInMicroseconds = settingsTimeout set * 1000000+ withTimeoutManager f = case settingsManager set of+ Just tm -> f tm+ Nothing ->+ E.bracket+ (T.initialize timeoutInMicroseconds)+ T.stopManager+ f++-- Note that there is a thorough discussion of the exception safety of the+-- following code at: https://github.com/yesodweb/wai/issues/146+--+-- We need to make sure of two things:+--+-- 1. Asynchronous exceptions are not blocked entirely in the main loop.+-- Doing so would make it impossible to kill the Warp thread.+--+-- 2. Once a connection maker is received via acceptNewConnection, the+-- connection is guaranteed to be closed, even in the presence of+-- async exceptions.+--+-- Our approach is explained in the comments below.+acceptConnection+ :: Settings+ -> IO (IO (Connection, Transport), SockAddr)+ -> Application+ -> Counter+ -> InternalInfo+ -> IORef FdExhaustion+ -- ^ This ref will be used to "debounce" the call to 'settingsOnException'+ -- when we hit an 'IOError' with 'eMFILE' in the case that Warp is not+ -- the reason the file descriptors are exhausted.+ -> IO ()+acceptConnection set getConnMaker app counter ii fdRef = do+ -- First mask all exceptions in acceptLoop. This is necessary to+ -- ensure that no async exception is throw between the call to+ -- acceptNewConnection and the registering of connClose.+ --+ -- acceptLoop can be broken by closing the listening socket.+ void $ E.mask_ acceptLoop+ -- In some cases, we want to stop Warp here without graceful shutdown.+ -- So, async exceptions are allowed here.+ -- That's why `finally` is not used.+ gracefulShutdown set counter+ where+ acceptLoop = do+ -- Allow async exceptions before receiving the next connection maker.+ E.allowInterrupt++ -- acceptNewConnection will try to receive the next incoming+ -- request. It returns a /connection maker/, not a connection,+ -- since in some circumstances creating a working connection+ -- from a raw socket may be an expensive operation, and this+ -- expensive work should not be performed in the main event+ -- loop. An example of something expensive would be TLS+ -- negotiation.+ mx <- acceptNewConnection+ case mx of+ Nothing -> return ()+ Just (mkConn, addr) -> do+ fork set mkConn addr app counter ii+ acceptLoop++ acceptNewConnection = do+ ex <- E.try getConnMaker+ case ex of+ Right x -> do+ -- Important to mark the exhaustion issue to be resolved+ -- when we get connections again.+ resetFdExhaustion fdRef+ return $ Just x+ Left e -> do+ let getErrno (Errno cInt) = cInt+ isErrno err = ioe_errno e == Just (getErrno err)+ if | isErrno eCONNABORTED -> do+ -- Important to mark the exhaustion issue to be resolved+ resetFdExhaustion fdRef+ acceptNewConnection+ -- Keep in mind to reset the ref when anything other+ -- than this branch runs+ | isErrno eMFILE -> do+ handleFdExhaustion e+ acceptNewConnection+ | otherwise -> do+ -- Maybe not important to mark the exhaustion issue+ -- as resolved here, but just for completeness' sake.+ resetFdExhaustion fdRef+ settingsOnException set Nothing $ E.toException e+ return Nothing++ handleFdExhaustion e = do+ fdExhaustion <- readIORef fdRef+ -- If file descriptors are exhausted while Warp has+ -- no current connections, 'settingsOnException' would+ -- get called an enormous amount of times per second.+ when (fdExhaustion /= FdExhausted) $+ settingsOnException set Nothing $ E.toException e+ hasDecreased <- waitForDecreased counter+ -- If we get 'NoConnections', that means the file+ -- descriptor exhaustion is outside of our control.+ -- We flag it so that 'settingsOnException' doesn't get+ -- called until the exhaustion issue is resolved.+ when (hasDecreased == NoConnections) $ setFdExhaustion fdRef++-- Fork a new worker thread for this connection maker, and ask for a+-- function to unmask (i.e., allow async exceptions to be thrown).+fork+ :: Settings+ -> IO (Connection, Transport)+ -> SockAddr+ -> Application+ -> Counter+ -> InternalInfo+ -> IO ()+fork set mkConn addr app counter ii = settingsFork set $ \unmask -> do+ tid <- myThreadId+ labelThread tid "Warp just forked"+ -- Call the user-supplied on exception code if any+ -- exceptions are thrown.+ --+ -- Intentionally using Control.Exception.handle, since we want to+ -- catch all exceptions and avoid them from propagating, even+ -- async exceptions. See:+ -- https://github.com/yesodweb/wai/issues/850+ E.handle (settingsOnException set Nothing) $+ -- Run the connection maker to get a new connection, and ensure+ -- that the connection is closed. If the mkConn call throws an+ -- exception, we will leak the connection. If the mkConn call is+ -- vulnerable to attacks (e.g., Slowloris), we do nothing to+ -- protect the server. It is therefore vital that mkConn is well+ -- vetted.+ --+ -- We grab the connection before registering timeouts since the+ -- timeouts will be useless during connection creation, due to the+ -- fact that async exceptions are still masked.+ E.bracket mkConn cleanUp (serve unmask)+ where+ cleanUp (conn, _) =+ connClose conn `E.finally` do+ writeBuffer <- readIORef $ connWriteBuffer conn+ bufFree writeBuffer++ -- We need to register a timeout handler for this thread, and+ -- cancel that handler as soon as we exit.+ serve unmask (conn, transport) = T.withHandleKillThread (timeoutManager ii) (return ()) $ \th -> do+ -- We now have fully registered a connection close handler in+ -- the case of all exceptions, so it is safe to once again+ -- allow async exceptions.+ unmask+ .+ -- Call the user-supplied code for connection open and+ -- close events+ E.bracket (onOpen addr) (onClose addr)+ $ \goingon ->+ -- Actually serve this connection. bracket with closeConn+ -- above ensures the connection is closed.+ when goingon $ serveConnection conn ii th addr transport set app++ onOpen adr = increase counter >> settingsOnOpen set adr+ onClose adr _ = decrease counter >> settingsOnClose set adr++serveConnection+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> SockAddr+ -> Transport+ -> Settings+ -> Application+ -> IO ()+serveConnection conn ii th origAddr transport settings app = do+ -- fixme: Upgrading to HTTP/2 should be supported.+ tid <- myThreadId+ (h2, bs) <-+ if isHTTP2 transport+ then return (True, "")+ else do+ bs0 <- recv4 ""+ if "PRI " `S.isPrefixOf` bs0+ then return (True, bs0)+ else return (False, bs0)+ let appsInProgress = connAppsInProgress conn+ app' req rsp =+ E.bracket_+ (atomically $ modifyTVar' appsInProgress $ (+ 1))+ (atomically $ modifyTVar' appsInProgress $ \i -> (i - 1))+ $ app req rsp+ if settingsHTTP2Enabled settings && h2+ then do+ labelThread tid ("Warp HTTP/2 " ++ show origAddr)+ http2 settings ii conn transport app' origAddr th bs+ else do+ labelThread tid ("Warp HTTP/1.1 " ++ show origAddr)+ http1 settings ii conn transport app' origAddr th bs+ where+ recv4 bs0 = do+ bs1 <- connRecv conn+ if S.null bs1 then+ return bs0+ else do+ -- In the case where bs0 is "", (<>) is called unnecessarily.+ -- But we adopt this logic for simplicity.+ let bs2 = bs0 <> bs1+ if S.length bs2 >= 4+ then return bs2+ else recv4 bs2++-- | Set flag FileCloseOnExec flag on a socket (on Unix)+--+-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs+--+-- @since 3.2.17+setSocketCloseOnExec :: Socket -> IO ()+#if WINDOWS+setSocketCloseOnExec _ = return ()+#else+setSocketCloseOnExec socket = do+#if MIN_VERSION_network(3,0,0)+ fd <- fdSocket socket+#else+ let fd = fdSocket socket+#endif+ F.setFileCloseOnExec $ fromIntegral fd+#endif++gracefulShutdown :: Settings -> Counter -> IO ()+gracefulShutdown set counter = do+ setShuttingDown+ case settingsGracefulShutdownTimeout set of+ Nothing ->+ waitForZero counter+ (Just seconds) ->+ void (timeout (seconds * microsPerSecond) (waitForZero counter))+ where+ microsPerSecond = 1000000+ setShuttingDown =+ case settingsServerState set of+ Nothing -> pure ()+ Just ServerState{serverShuttingDown} ->+ writeShuttingDown serverShuttingDown True++data FdExhaustion = NoFdIssue | FdExhausted+ deriving (Eq, Show)++initFdExhaustionRef :: IO (IORef FdExhaustion)+initFdExhaustionRef = newIORef NoFdIssue++resetFdExhaustion :: IORef FdExhaustion -> IO ()+resetFdExhaustion = flip writeIORef NoFdIssue++setFdExhaustion :: IORef FdExhaustion -> IO ()+setFdExhaustion = flip writeIORef FdExhausted
+ Network/Wai/Handler/Warp/SendFile.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module Network.Wai.Handler.Warp.SendFile (+ sendFile,+ readSendFile,+ packHeader, -- for testing+#ifndef WINDOWS+ positionRead,+#endif+) where++import qualified Data.ByteString as BS+import Network.Socket (Socket)+import Network.Socket.BufferPool++#ifdef WINDOWS+import Foreign.ForeignPtr (newForeignPtr_)+import Foreign.Ptr (plusPtr)+import qualified System.IO as IO+#else+import qualified Control.Exception as E+import Foreign.C.Error (throwErrno)+import Foreign.C.Types+import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Network.Sendfile+import Network.Wai.Handler.Warp.FdCache (openFile, closeFile)+import System.Posix.Types+#endif++import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++-- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD.+-- This makes use of the file descriptor cache.+-- For other OSes, this is identical to 'readSendFile'.+--+-- Since: 3.1.0+sendFile :: Socket -> Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile+#ifdef SENDFILEFD+sendFile s _ _ _ fid off len act hdr = case mfid of+ -- settingsFdCacheDuration is 0+ Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr+ Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr+ where+ mfid = fileIdFd fid+ path = fileIdPath fid+#else+sendFile _ = readSendFile+#endif++----------------------------------------------------------------++packHeader+ :: Buffer+ -> BufSize+ -> (ByteString -> IO ())+ -> IO ()+ -> [ByteString]+ -> Int+ -> IO Int+packHeader _ _ _ _ [] n = return n+packHeader buf siz send hook (bs : bss) n+ | len < room = do+ let dst = buf `plusPtr` n+ void $ copy dst bs+ packHeader buf siz send hook bss (n + len)+ | otherwise = do+ let dst = buf `plusPtr` n+ (bs1, bs2) = BS.splitAt room bs+ void $ copy dst bs1+ bufferIO buf siz send+ hook+ packHeader buf siz send hook (bs2 : bss) 0+ where+ len = BS.length bs+ room = siz - n++mini :: Int -> Integer -> Int+mini i n+ | fromIntegral i < n = i+ | otherwise = fromIntegral n++-- | Function to send a file based on pread()\/send() for Unix.+-- This makes use of the file descriptor cache.+-- For Windows, this is emulated by 'Handle'.+--+-- Since: 3.1.0+#ifdef WINDOWS+readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile+readSendFile buf siz send fid off0 len0 hook headers = do+ hn <- packHeader buf siz send hook headers 0+ let room = siz - hn+ buf' = buf `plusPtr` hn+ IO.withBinaryFile path IO.ReadMode $ \h -> do+ IO.hSeek h IO.AbsoluteSeek off0+ n <- IO.hGetBufSome h buf' (mini room len0)+ bufferIO buf (hn + n) send+ hook+ let n' = fromIntegral n+ fptr <- newForeignPtr_ buf+ loop h fptr (len0 - n')+ where+ path = fileIdPath fid+ loop h fptr len+ | len <= 0 = return ()+ | otherwise = do+ n <- IO.hGetBufSome h buf (mini siz len)+ when (n /= 0) $ do+ let bs = PS fptr 0 n+ n' = fromIntegral n+ send bs+ hook+ loop h fptr (len - n')+#else+readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile+readSendFile buf siz send fid off0 len0 hook headers =+ E.bracket setup teardown $ \fd -> do+ hn <- packHeader buf siz send hook headers 0+ let room = siz - hn+ buf' = buf `plusPtr` hn+ n <- positionRead fd buf' (mini room len0) off0+ bufferIO buf (hn + n) send+ hook+ let n' = fromIntegral n+ loop fd (len0 - n') (off0 + n')+ where+ path = fileIdPath fid+ setup = case fileIdFd fid of+ Just fd -> return fd+ Nothing -> openFile path+ teardown fd = case fileIdFd fid of+ Just _ -> return ()+ Nothing -> closeFile fd+ loop fd len off+ | len <= 0 = return ()+ | otherwise = do+ n <- positionRead fd buf (mini siz len) off+ bufferIO buf n send+ let n' = fromIntegral n+ hook+ loop fd (len - n') (off + n')++positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int+positionRead fd buf siz off = do+ bytes <-+ fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)+ when (bytes < 0) $ throwErrno "positionRead"+ return bytes++foreign import ccall unsafe "pread"+ c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize+#endif
+ Network/Wai/Handler/Warp/Settings.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ViewPatterns #-}++module Network.Wai.Handler.Warp.Settings where++import Control.Concurrent.STM (STM)+import Control.Exception (SomeException (..), fromException, throw)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Char8 as C8+import Data.Streaming.Network (HostPreference)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import GHC.Exts (fork#)+import GHC.IO (IO (IO), unsafeUnmask)+import GHC.IO.Exception (IOErrorType (..))+import qualified Network.HTTP.Types as H+import Network.Socket (SockAddr, Socket, accept)+import Network.Wai+import System.IO (stderr)+import System.IO.Error (ioeGetErrorType)+import System.TimeManager++import Network.Wai.Handler.Warp.Counter (Counter, getCount, newCounter, getCountSTM)+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ )+import Network.Wai.Handler.Warp.Types+#if WINDOWS+import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack)+#endif++#ifdef INCLUDE_WARP_VERSION+import Data.Version (showVersion)+import qualified Paths_warp+#endif++-- | Various Warp server settings. This is purposely kept as an abstract data+-- type so that new settings can be added without breaking backwards+-- compatibility. In order to create a 'Settings' value, use 'defaultSettings'+-- and the various \'set\' functions to modify individual fields. For example:+--+-- > setTimeout 20 defaultSettings+data Settings = Settings+ { settingsPort :: Port+ -- ^ Port to listen on. Default value: 3000+ , settingsHost :: HostPreference+ -- ^ Default value: HostIPv4+ , 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.+ , settingsOnExceptionResponse :: SomeException -> Response+ -- ^ A function to create `Response` when an exception occurs.+ --+ -- Default: 500, text/plain, \"Something went wrong\"+ --+ -- Since 2.0.3+ , settingsOnOpen :: SockAddr -> IO Bool+ -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.+ , settingsOnClose :: SockAddr -> IO ()+ -- ^ What to do when a connection is close. Default: do nothing.+ , settingsTimeout :: Int+ -- ^ Timeout value in seconds. Default value: 30+ , settingsManager :: Maybe Manager+ -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'+ , settingsFdCacheDuration :: Int+ -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0+ , settingsFileInfoCacheDuration :: Int+ -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0+ , settingsBeforeMainLoop :: IO ()+ -- ^ Code to run after the listening socket is ready but before entering+ -- the main event loop. Useful for signaling to tests that they can start+ -- running, or to drop permissions after binding to a restricted port.+ --+ -- Default: do nothing.+ --+ -- Since 1.3.6+ , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()+ -- ^ Code to fork a new thread to accept a connection.+ --+ -- This may be useful if you need OS bound threads, or if+ -- you wish to develop an alternative threading model.+ --+ -- Default: 'defaultFork'+ --+ -- Since 3.0.4+ , settingsAccept :: Socket -> IO (Socket, SockAddr)+ -- ^ Code to accept a new connection.+ --+ -- Useful if you need to provide connected sockets from something other+ -- than a standard accept call.+ --+ -- Default: 'defaultAccept'+ --+ -- Since 3.3.24+ , settingsNoParsePath :: Bool+ -- ^ Perform no parsing on the rawPathInfo.+ --+ -- This is useful for writing HTTP proxies.+ --+ -- Default: False+ --+ -- Since 2.0.3+ , settingsInstallShutdownHandler :: IO () -> IO ()+ -- ^ An action to install a handler (e.g. Unix signal handler)+ -- to close a listen socket.+ -- The first argument is an action to close the listen socket.+ --+ -- Default: no action+ --+ -- Since 3.0.1+ , settingsServerName :: ByteString+ -- ^ Default server name if application does not set one.+ --+ -- Since 3.0.2+ , settingsMaximumBodyFlush :: Maybe Int+ -- ^ See @setMaximumBodyFlush@.+ --+ -- Since 3.0.3+ , settingsProxyProtocol :: ProxyProtocol+ -- ^ Specify usage of the PROXY protocol.+ --+ -- Since 3.0.5+ , settingsSlowlorisSize :: Int+ -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048+ --+ -- Since 3.1.2+ , settingsHTTP2Enabled :: Bool+ -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True+ --+ -- Since 3.1.7+ , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()+ -- ^ A log function. Default: no action.+ --+ -- @settingsLogger req status mSentBytes@+ --+ -- /N.B. @Maybe Integer@ is the concrete bytes of the message body/+ -- /after all the headers have been sent. This is 'Nothing' when/+ -- /'responseRaw' is used. (e.g. when using websockets)/+ --+ -- Since 3.1.10+ , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()+ -- ^ A HTTP/2 server push log function. Default: no action.+ --+ -- Since 3.2.7+ , settingsGracefulShutdownTimeout :: Maybe Int+ -- ^ An optional timeout to limit the time (in seconds) waiting for+ -- a graceful shutdown of the web server.+ --+ -- Since 3.2.8+ , settingsGracefulCloseTimeout1 :: Int+ -- ^ A timeout to limit the time (in milliseconds) waiting for+ -- FIN for HTTP/1.x. 0 means uses immediate close.+ -- Default: 0.+ --+ -- Since 3.3.5+ , settingsGracefulCloseTimeout2 :: Int+ -- ^ A timeout to limit the time (in milliseconds) waiting for+ -- FIN for HTTP/2. 0 means uses immediate close.+ -- Default: 2000.+ --+ -- Since 3.3.5+ , settingsMaxTotalHeaderLength :: Int+ -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.+ --+ -- Since 3.3.8+ , settingsAltSvc :: Maybe ByteString+ -- ^ Specify the header value of Alternative Services (AltSvc:).+ --+ -- Default: Nothing+ --+ -- Since 3.3.11+ , settingsMaxBuilderResponseBufferSize :: Int+ -- ^ Determines the maxium buffer size when sending `Builder` responses+ -- (See `responseBuilder`).+ --+ -- When sending a builder response warp uses a 16 KiB buffer to write the+ -- builder to. When that buffer is too small to fit the builder warp will+ -- free it and create a new one that will fit the builder.+ --+ -- To protect against allocating too large a buffer warp will error if the+ -- builder requires more than this maximum.+ --+ -- Default: 1049_000_000 = 1 MiB.+ --+ -- Since 3.3.22+ , settingsConnectionCounter :: Maybe Counter+ -- ^ A counter for tracking open connections.+ -- Use 'makeSettingsAndCounter' to create settings with a counter,+ -- then use 'getCount' on the returned 'Counter' to read the current value.+ --+ -- Default: 'Nothing' (warp creates an internal counter)+ --+ -- /DEPRECATED in favor of 'settingsServerState'/+ --+ -- Since 3.4.11+ , settingsServerState :: Maybe ServerState+ -- ^ Internal read-only server state.+ -- Use 'makeSettingsAndServerState' to gain access to the state of the server.+ -- Using functions like 'currentOpenConnections' or 'currentShuttingDownState'+ -- to gain insight into the current state of the server.+ --+ -- Default: 'Nothing' (warp creates its own internal state)+ --+ -- Since 3.4.13+ }++-- | Specify usage of the PROXY protocol.+data ProxyProtocol+ = -- | See @setProxyProtocolNone@.+ ProxyProtocolNone+ | -- | See @setProxyProtocolRequired@.+ ProxyProtocolRequired+ | -- | See @setProxyProtocolOptional@.+ ProxyProtocolOptional++-- | Internal read-only state of the server+--+-- Since 3.4.13+data ServerState = ServerState+ { serverConnectionCounter :: Counter+ , serverShuttingDown :: ShuttingDown+ }++-- | Takes 'Settings' and either returns the 'ServerState'+-- that was already in there, or creates a new 'ServerState'.+--+-- The returned 'Settings' will always contain a 'ServerState'.+--+-- This makes it idempotent if care is taken that the @oldSettings@+-- are not used after using this function.+--+-- Since 3.4.13+makeServerState :: Settings -> IO (ServerState, Settings)+makeServerState oldSettings =+ case settingsServerState oldSettings of+ Just serverState -> pure (serverState, oldSettings)+ Nothing -> do+ serverState <- newServerState+ let counter = serverConnectionCounter serverState+ pure+ ( serverState+ , oldSettings+ { settingsServerState = Just serverState+ , settingsConnectionCounter = Just counter+ }+ )++-- | Initialize a 'ServerState'+--+-- Since 3.4.13+newServerState :: IO ServerState+newServerState = do+ counter <- newCounter+ shuttingDown <- newShuttingDown+ pure+ ServerState+ { serverConnectionCounter = counter+ , serverShuttingDown = shuttingDown+ }++-- | Get the currently open connections of the server.+--+-- Since 3.4.13+currentOpenConnections :: ServerState -> IO Int+currentOpenConnections = getCount . serverConnectionCounter++-- | Get the currently open connections of the server in an 'STM' transaction.+--+-- Since 3.4.13+currentOpenConnectionsSTM :: ServerState -> STM Int+currentOpenConnectionsSTM = getCountSTM . serverConnectionCounter++-- | Check if the server is currently shutting down.+--+-- > False: Server is not shutting down+-- > True: Server is shutting down or has shut down.+--+-- Since 3.4.13+currentShuttingDownState :: ServerState -> IO Bool+currentShuttingDownState = readShuttingDown . serverShuttingDown++-- | Check if the server is currently shutting down in an 'STM' transaction.+--+-- (This way you can have a thread wait for server shutdown with 'Control.Concurrent.STM.retry')+--+-- > False: Server is not shutting down+-- > True: Server is shutting down or has shut down.+--+-- Since 3.4.13+currentShuttingDownStateSTM :: ServerState -> STM Bool+currentShuttingDownStateSTM = readShuttingDownSTM . serverShuttingDown++-- | The default settings for the Warp server. See the individual settings for+-- the default value.+defaultSettings :: Settings+defaultSettings =+ Settings+ { settingsPort = 3000+ , settingsHost = "*4"+ , settingsOnException = defaultOnException+ , settingsOnExceptionResponse = defaultOnExceptionResponse+ , settingsOnOpen = const $ return True+ , settingsOnClose = const $ return ()+ , settingsTimeout = 30+ , settingsManager = Nothing+ , settingsFdCacheDuration = 0+ , settingsFileInfoCacheDuration = 0+ , settingsBeforeMainLoop = return ()+ , settingsFork = defaultFork+ , settingsAccept = defaultAccept+ , settingsNoParsePath = False+ , settingsInstallShutdownHandler = const $ return ()+ , settingsServerName = C8.pack $ "Warp/" ++ warpVersion+ , settingsMaximumBodyFlush = Just 8192+ , settingsProxyProtocol = ProxyProtocolNone+ , settingsSlowlorisSize = 2048+ , settingsHTTP2Enabled = True+ , settingsLogger = \_ _ _ -> return ()+ , settingsServerPushLogger = \_ _ _ -> return ()+ , settingsGracefulShutdownTimeout = Nothing+ , settingsGracefulCloseTimeout1 = 0+ , settingsGracefulCloseTimeout2 = 2000+ , settingsMaxTotalHeaderLength = 50 * 1024+ , settingsAltSvc = Nothing+ , settingsMaxBuilderResponseBufferSize = 1049000000+ , settingsConnectionCounter = Nothing+ , settingsServerState = Nothing+ }++-- | Create 'defaultSettings' with a connection counter.+-- Use 'getCount' on the returned 'Counter' to check open connections.+--+-- /DEPRECATED in favor of 'makeSettingsAndServerState'/+--+-- Since 3.4.11+makeSettingsAndCounter :: IO (Counter, Settings)+makeSettingsAndCounter = do+ (serverState, settings) <- makeSettingsAndServerState+ pure (serverConnectionCounter serverState, settings)++-- | Create 'defaultSettings' with a 'ServerState'.+-- Use functions like 'currentOpenConnections' and 'currentShuttingDownState'+-- to gain insight into the state of the server.+--+-- Since 3.4.13+makeSettingsAndServerState :: IO (ServerState, Settings)+makeSettingsAndServerState = makeServerState defaultSettings++-- | Apply the logic provided by 'defaultOnException' to determine if an+-- exception should be shown or not. The goal is to hide exceptions which occur+-- under the normal course of the web server running.+--+-- Since 2.1.3+defaultShouldDisplayException :: SomeException -> Bool+defaultShouldDisplayException se+ | Just (_ :: InvalidRequest) <- fromException se = False+ | Just (ioeGetErrorType -> et) <- fromException se+ , et == ResourceVanished || et == InvalidArgument =+ False+ | isAsyncException se = False+ | otherwise = True++-- | Printing an exception to standard error+-- if `defaultShouldDisplayException` returns `True`.+--+-- Since: 3.1.0+defaultOnException :: Maybe Request -> SomeException -> IO ()+defaultOnException _ e =+ when (defaultShouldDisplayException e) $+ TIO.hPutStrLn stderr $+ T.pack $+ show e++-- | Sending 400 for bad requests.+-- Sending 500 for internal server errors.+-- Since: 3.1.0+-- Sending 413 for too large payload.+-- Sending 431 for too large headers.+-- Since 3.2.27+defaultOnExceptionResponse :: SomeException -> Response+defaultOnExceptionResponse e+ | isAsyncException e = throw e+ | Just PayloadTooLarge <- fromException e =+ responseLBS+ H.status413+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Payload too large"+ | Just RequestHeaderFieldsTooLarge <- fromException e =+ responseLBS+ H.status431+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Request header fields too large"+ | Just (_ :: InvalidRequest) <- fromException e =+ responseLBS+ H.badRequest400+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Bad Request"+ | otherwise =+ responseLBS+ H.internalServerError500+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Something went wrong"++-- | Exception handler for the debugging purpose.+-- 500, text/plain, a showed exception.+--+-- Since: 2.0.3.2+exceptionResponseForDebug :: SomeException -> Response+exceptionResponseForDebug e =+ responseBuilder+ H.internalServerError500+ [(H.hContentType, "text/plain; charset=utf-8")]+ $ "Exception: " <> Builder.stringUtf8 (show e)++-- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler.+--+-- Since Warp will always install its own exception handler in forked threads, this provides+-- a minor optimization.+--+-- For inspiration of this function, see @rawForkIO@ in the @async@ package.+--+-- @since 3.3.17+defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()+defaultFork io =+ IO $ \s0 ->+#if __GLASGOW_HASKELL__ >= 904+ case io unsafeUnmask of+ IO io' ->+ case fork# io' s0 of+ (# s1, _tid #) -> (# s1, () #)+#else+ case fork# (io unsafeUnmask) s0 of+ (# s1, _tid #) -> (# s1, () #)+#endif++-- | Standard "accept" call for a listening socket.+--+-- @since 3.3.24+defaultAccept :: Socket -> IO (Socket, SockAddr)+defaultAccept =+#if WINDOWS+ windowsThreadBlockHack . accept+#else+ accept+#endif++-- | The version of Warp.+warpVersion :: String+warpVersion =+#ifdef INCLUDE_WARP_VERSION+ showVersion Paths_warp.version+#else+ "unknown"+#endif
+ Network/Wai/Handler/Warp/ShuttingDown.hs view
@@ -0,0 +1,34 @@+-- Most important is to not export the data constructor from this module+-- and to not expose 'writeShuttingDown' to the end user.+module Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ writeShuttingDown,+) where++import Control.Concurrent.STM (+ STM,+ TVar,+ atomically,+ newTVarIO,+ readTVar,+ readTVarIO,+ writeTVar,+ )++newtype ShuttingDown = ShuttingDown (TVar Bool)++newShuttingDown :: IO ShuttingDown+newShuttingDown = ShuttingDown <$> newTVarIO False++readShuttingDown :: ShuttingDown -> IO Bool+readShuttingDown (ShuttingDown var) = readTVarIO var++readShuttingDownSTM :: ShuttingDown -> STM Bool+readShuttingDownSTM (ShuttingDown var) = readTVar var++writeShuttingDown :: ShuttingDown -> Bool -> IO ()+writeShuttingDown (ShuttingDown var) b =+ atomically $ writeTVar var b
+ Network/Wai/Handler/Warp/Types.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.Types where++import Control.Concurrent.STM (TVar)+import qualified Control.Exception as E+import qualified Data.ByteString as S+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+#ifdef MIN_VERSION_crypton_x509+import Data.X509+#endif+import Network.Socket (SockAddr)+import Network.Socket.BufferPool+import System.Posix.Types (Fd)+import qualified System.TimeManager as T++import qualified Network.Wai.Handler.Warp.Date as D+import qualified Network.Wai.Handler.Warp.FdCache as F+import qualified Network.Wai.Handler.Warp.FileInfoCache as I+import Network.Wai.Handler.Warp.Imports++----------------------------------------------------------------++-- | TCP port number.+type Port = Int++----------------------------------------------------------------++-- | The type for header value used with 'HeaderName'.+type HeaderValue = ByteString++----------------------------------------------------------------++-- | Error types for bad 'Request'.+data InvalidRequest+ = NotEnoughLines [String]+ | BadFirstLine String+ | NonHttp+ | IncompleteHeaders+ | ConnectionClosedByPeer+ | OverLargeHeader+ | BadProxyHeader String+ | -- | Since 3.3.22+ PayloadTooLarge+ | -- | Since 3.3.22+ RequestHeaderFieldsTooLarge+ deriving (Eq)++instance Show InvalidRequest where+ show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs+ show (BadFirstLine s) = "Warp: Invalid first line of request: " ++ show s+ show NonHttp = "Warp: Request line specified a non-HTTP request"+ show IncompleteHeaders = "Warp: Request headers did not finish transmission"+ show ConnectionClosedByPeer = "Warp: Client closed connection prematurely"+ show OverLargeHeader =+ "Warp: Request headers too large, possible memory attack detected. Closing connection."+ show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s+ show RequestHeaderFieldsTooLarge = "Request header fields too large"+ show PayloadTooLarge = "Payload too large"++instance E.Exception InvalidRequest++----------------------------------------------------------------++-- | Exception thrown if something goes wrong while in the midst of+-- sending a response, since the status code can't be altered at that+-- point.+--+-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe+-- or irrecoverable.+newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody E.SomeException+ deriving (Show)++instance E.Exception ExceptionInsideResponseBody++----------------------------------------------------------------++-- | Data type to abstract file identifiers.+-- On Unix, a file descriptor would be specified to make use of+-- the file descriptor cache.+--+-- Since: 3.1.0+data FileId = FileId+ { fileIdPath :: FilePath+ , fileIdFd :: Maybe Fd+ }++-- | fileid, offset, length, hook action, HTTP headers+--+-- Since: 3.1.0+type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO ()++-- | A write buffer of a specified size+-- containing bytes and a way to free the buffer.+data WriteBuffer = WriteBuffer+ { bufBuffer :: Buffer+ , bufSize :: !BufSize+ -- ^ The size of the write buffer.+ , bufFree :: IO ()+ -- ^ Free the allocated buffer. Warp guarantees it will only be+ -- called once, and no other functions will be called after it.+ }++type RecvBuf = Buffer -> BufSize -> IO Bool++-- | Data type to manipulate IO actions for connections.+-- This is used to abstract IO actions for plain HTTP and HTTP over TLS.+data Connection = Connection+ { connSendMany :: [ByteString] -> IO ()+ -- ^ This is not used at this moment.+ , connSendAll :: ByteString -> IO ()+ -- ^ The sending function.+ , connSendFile :: SendFile+ -- ^ The sending function for files in HTTP/1.1.+ , connClose :: IO ()+ -- ^ The connection closing function. Warp guarantees it will only be+ -- called once. Other functions (like 'connRecv') may be called after+ -- 'connClose' is called.+ , connRecv :: Recv+ -- ^ The connection receiving function. This returns "" for EOF or exceptions.+ , connRecvBuf :: RecvBuf+ -- ^ Obsoleted.+ , connWriteBuffer :: IORef WriteBuffer+ -- ^ Reference to a write buffer. When during sending of a 'Builder'+ -- response it's detected the current 'WriteBuffer' is too small it will be+ -- freed and a new bigger buffer will be created and written to this+ -- reference.+ , connHTTP2 :: IORef Bool+ -- ^ Is this connection HTTP/2?+ , connMySockAddr :: SockAddr+ , connAppsInProgress :: TVar Int+ -- ^ Amount of apps currently in progress on this connection.+ --+ -- /HTTP2 can handle more than one request concurrently/+ --+ -- @since 3.4.13+ }++getConnHTTP2 :: Connection -> IO Bool+getConnHTTP2 = readIORef . connHTTP2++setConnHTTP2 :: Connection -> Bool -> IO ()+setConnHTTP2 = writeIORef . connHTTP2++----------------------------------------------------------------++data InternalInfo = InternalInfo+ { timeoutManager :: T.Manager+ , getDate :: IO D.GMTDate+ , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)+ , getFileInfo :: FilePath -> IO I.FileInfo+ }++----------------------------------------------------------------++-- | Type for input streaming.+data Source = Source !(IORef ByteString) !(IO ByteString)++mkSource :: IO ByteString -> IO Source+mkSource func = do+ ref <- newIORef S.empty+ return $! Source ref func++readSource :: Source -> IO ByteString+readSource (Source ref func) = do+ bs <- readIORef ref+ if S.null bs+ then func+ else do+ writeIORef ref S.empty+ return bs++-- | Read from a Source, ignoring any leftovers.+readSource' :: Source -> IO ByteString+readSource' (Source _ func) = func++leftoverSource :: Source -> ByteString -> IO ()+leftoverSource (Source ref _) = writeIORef ref++readLeftoverSource :: Source -> IO ByteString+readLeftoverSource (Source ref _) = readIORef ref++----------------------------------------------------------------++-- | What kind of transport is used for this connection?+data Transport+ = -- | Plain channel: TCP+ TCP+ | TLS+ { tlsMajorVersion :: Int+ , tlsMinorVersion :: Int+ , tlsNegotiatedProtocol :: Maybe ByteString+ -- ^ The result of Application Layer Protocol Negociation in RFC 7301+ , tlsChiperID :: Word16+ -- ^ Encrypted channel: TLS or SSL+#ifdef MIN_VERSION_crypton_x509+ , tlsClientCertificate :: Maybe CertificateChain+#endif+ }+ | QUIC+ { quicNegotiatedProtocol :: Maybe ByteString+ , quicChiperID :: Word16+#ifdef MIN_VERSION_crypton_x509+ , quicClientCertificate :: Maybe CertificateChain+#endif+ }++isTransportSecure :: Transport -> Bool+isTransportSecure TCP = False+isTransportSecure _ = True++isTransportQUIC :: Transport -> Bool+isTransportQUIC QUIC{} = True+isTransportQUIC _ = False++#ifdef MIN_VERSION_crypton_x509+getTransportClientCertificate :: Transport -> Maybe CertificateChain+getTransportClientCertificate TCP = Nothing+getTransportClientCertificate (TLS _ _ _ _ cc) = cc+getTransportClientCertificate (QUIC _ _ cc) = cc+#endif
+ Network/Wai/Handler/Warp/Windows.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.Windows (+ windowsThreadBlockHack,+) where++#if WINDOWS+import Control.Concurrent.MVar+import Control.Concurrent+import qualified Control.Exception++import GHC.Conc (labelThread)++-- | Allow main socket listening thread to be interrupted on Windows platform+--+-- @since 3.2.17+windowsThreadBlockHack :: IO a -> IO a+windowsThreadBlockHack act = do+ var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a))+ -- Catch and rethrow even async exceptions, so don't bother with UnliftIO+ threadId <- forkIO $ Control.Exception.try act >>= putMVar var+ labelThread threadId "Windows Thread Block Hack (warp)"+ res <- takeMVar var+ case res of+ Left e -> Control.Exception.throwIO e+ Right r -> return r+#else+windowsThreadBlockHack :: IO a -> IO a+windowsThreadBlockHack = id+#endif
+ Network/Wai/Handler/Warp/WithApplication.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.WithApplication (+ withApplication,+ withApplicationSettings,+ testWithApplication,+ testWithApplicationSettings,+ openFreePort,+ withFreePort,+) where++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as E+import Control.Monad (when)+import Data.Streaming.Network (bindRandomPortTCP)+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp.Run+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types++-- | Runs the given 'Application' on a free port. Passes the port to the given+-- operation and executes it, while the 'Application' is running. Shuts down the+-- server before returning.+--+-- @since 3.2.4+withApplication :: IO Application -> (Port -> IO a) -> IO a+withApplication = withApplicationSettings defaultSettings++-- | 'withApplication' with given 'Settings'. This will ignore the port value+-- set by 'setPort' in 'Settings'.+--+-- @since 3.2.7+withApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a+withApplicationSettings settings' mkApp action = do+ app <- mkApp+ withFreePort $ \(port, sock) -> do+ started <- mkWaiter+ let settings =+ settings'+ { settingsBeforeMainLoop =+ notify started () >> settingsBeforeMainLoop settings'+ }+ result <-+ race+ (runSettingsSocket settings sock app)+ (waitFor started >> action port)+ case result of+ Left () -> E.throwIO $ E.ErrorCall "Unexpected: runSettingsSocket exited"+ Right x -> return x++-- | Same as 'withApplication' but with different exception handling: If the+-- given 'Application' throws an exception, 'testWithApplication' will re-throw+-- the exception to the calling thread, possibly interrupting the execution of+-- the given operation.+--+-- This is handy for running tests against an 'Application' over a real network+-- port. When running tests, it's useful to let exceptions thrown by your+-- 'Application' propagate to the main thread of the test-suite.+--+-- __The exception handling makes this function unsuitable for use in production.__+-- Use 'withApplication' instead.+--+-- @since 3.2.4+testWithApplication :: IO Application -> (Port -> IO a) -> IO a+testWithApplication = testWithApplicationSettings defaultSettings++-- | 'testWithApplication' with given 'Settings'.+--+-- @since 3.2.7+testWithApplicationSettings+ :: Settings -> IO Application -> (Port -> IO a) -> IO a+testWithApplicationSettings settings mkApp action = do+ callingThread <- myThreadId+ app <- mkApp+ let wrappedApp request respond =+ app request respond `E.catch` \e -> do+ when+ (defaultShouldDisplayException e)+ (throwTo callingThread e)+ E.throwIO e+ withApplicationSettings settings (return wrappedApp) action++data Waiter a = Waiter+ { notify :: a -> IO ()+ , waitFor :: IO a+ }++mkWaiter :: IO (Waiter a)+mkWaiter = do+ mvar <- newEmptyMVar+ return+ Waiter+ { notify = putMVar mvar+ , waitFor = readMVar mvar+ }++-- | Opens a socket on a free port and returns both port and socket.+--+-- @since 3.2.4+openFreePort :: IO (Port, Socket)+openFreePort = bindRandomPortTCP "127.0.0.1"++-- | Like 'openFreePort' but closes the socket before exiting.+withFreePort :: ((Port, Socket) -> IO a) -> IO a+withFreePort = E.bracket openFreePort (close . snd)
+ README.md view
@@ -0,0 +1,3 @@+# Warp++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).
− Timeout.hs
@@ -1,66 +0,0 @@-module Timeout- ( Manager- , Handle- , initialize- , register- , registerKillThread- , tickle- , pause- , resume- , cancel- ) where--import qualified Data.IORef as I-import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)-import Control.Monad (forever)-import qualified Control.Exception as E---- FIXME implement stopManager---- | A timeout manager-newtype Manager = Manager (I.IORef [Handle])-data Handle = Handle (IO ()) (I.IORef State)-data State = Active | Inactive | Paused | Canceled--initialize :: Int -> IO Manager-initialize timeout = do- ref <- I.newIORef []- _ <- forkIO $ forever $ do- threadDelay timeout- ms <- I.atomicModifyIORef ref (\x -> ([], x))- ms' <- go ms id- I.atomicModifyIORef ref (\x -> (ms' x, ()))- return $ Manager ref- where- go [] front = return front- go (m@(Handle onTimeout iactive):rest) front = do- state <- I.atomicModifyIORef iactive (\x -> (go' x, x))- case state of- Inactive -> do- onTimeout `E.catch` ignoreAll- go rest front- Canceled -> go rest front- _ -> go rest (front . (:) m)- go' Active = Inactive- go' x = x--ignoreAll :: E.SomeException -> IO ()-ignoreAll _ = return ()--register :: Manager -> IO () -> IO Handle-register (Manager ref) onTimeout = do- iactive <- I.newIORef Active- let h = Handle onTimeout iactive- I.atomicModifyIORef ref (\x -> (h : x, ()))- return h--registerKillThread :: Manager -> IO Handle-registerKillThread m = do- tid <- myThreadId- register m $ killThread tid--tickle, pause, resume, cancel :: Handle -> IO ()-tickle (Handle _ iactive) = I.writeIORef iactive Active-pause (Handle _ iactive) = I.writeIORef iactive Paused-resume = tickle-cancel (Handle _ iactive) = I.writeIORef iactive Canceled
+ attic/hex view
@@ -0,0 +1,1 @@+0123456789abcdef
+ bench/Parser.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Exception (throw, throwIO)+import Control.Monad+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as B (pack, unpack)+import Data.ByteString.Internal+import Data.IORef (atomicModifyIORef', newIORef)+import qualified Data.List as L+import Data.Word8+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import qualified Network.HTTP.Types as H+import Prelude hiding (lines)++import Network.Wai.Handler.Warp.Request (FirstRequest (..), headerLines)+import Network.Wai.Handler.Warp.Response (containsRecoverableWhitespace)+import Network.Wai.Handler.Warp.Types++import Criterion.Main++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++main :: IO ()+main = do+ let requestLine1 = "GET http://www.example.com HTTP/1.1"+ let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"+ defaultMain+ [ bgroup+ "requestLine1"+ [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1+ ]+ , bgroup+ "requestLine2"+ [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2+ ]+ , bgroup+ "parsing request"+ [ bench "new parsing 4" $ whnfAppIO testIt (chunkRequest 4)+ , bench "new parsing 10" $ whnfAppIO testIt (chunkRequest 10)+ , bench "new parsing 25" $ whnfAppIO testIt (chunkRequest 25)+ , bench "new parsing 100" $ whnfAppIO testIt (chunkRequest 100)+ ]+ , bgroup+ "containsRecoverableWhitespace"+ -- Clean values (no CR/LF/NUL) are the overwhelmingly common case and+ -- the one the fast path must stay cheap for; the dirty case is+ -- what forces a rebuild in 'sanitizeHeaders'.+ [ bench "clean short" $ whnf containsRecoverableWhitespace "Mighttpd/2.5.8"+ , bench "clean long" $ whnf containsRecoverableWhitespace cleanLong+ , bench "dirty" $+ whnf containsRecoverableWhitespace "text/html\r\nInjected: header"+ ]+ ]+ where+ testIt req = producer req >>= headerLines 800 FirstRequest++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine3 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine3 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine3 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine3+ :: ByteString+ -> ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ )+parseRequestLine3 requestLine = ret+ where+ (!method, !rest) = S.break (== _space) requestLine+ (!pathQuery, !httpVer')+ | rest == "" = throw badmsg+ | otherwise = S.break (== _space) (S.drop 1 rest)+ (!path, !query) = S.break (== _question) pathQuery+ !httpVer = S.drop 1 httpVer'+ (!http, !ver)+ | httpVer == "" = throw badmsg+ | otherwise = S.break (== _slash) httpVer+ !hv+ | http /= "HTTP" = throw NonHttp+ | ver == "/1.1" = H.http11+ | otherwise = H.http10+ !ret = (method, path, query, hv)+ badmsg = BadFirstLine $ B.unpack requestLine++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine2 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine2 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine2 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine2+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ )+parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do+ when (len < 14) $ throwIO baderr+ let methodptr = ptr `plusPtr` off+ limptr = methodptr `plusPtr` len+ lim0 = fromIntegral len++ pathptr0 <- memchr methodptr _space lim0+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $+ throwIO baderr+ let pathptr = pathptr0 `plusPtr` 1+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)++ httpptr0 <- memchr pathptr _space lim1+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $+ throwIO baderr+ let httpptr = httpptr0 `plusPtr` 1+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)++ checkHTTP httpptr+ !hv <- httpVersion httpptr+ queryptr <- memchr pathptr _question lim2+ let !method = bs ptr methodptr pathptr0+ !path+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr+ !query+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0++ return (method, path, query, hv)+ where+ baderr = BadFirstLine $ B.unpack requestLine+ check :: Ptr Word8 -> Int -> Word8 -> IO ()+ check p n w = do+ w0 <- peek $ p `plusPtr` n+ when (w0 /= w) $ throwIO NonHttp+ checkHTTP httpptr = do+ check httpptr 0 _H+ check httpptr 1 _T+ check httpptr 2 _T+ check httpptr 3 _P+ check httpptr 4 _slash+ check httpptr 6 _period+ httpVersion httpptr = do+ major <- peek $ httpptr `plusPtr` 5+ minor <- peek $ httpptr `plusPtr` 7+ if major == _1 && minor == _1+ then return H.http11+ else return H.http10+ bs ptr p0 p1 = PS fptr o l+ where+ o = p0 `minusPtr` ptr+ l = p1 `minusPtr` p0++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine1 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine1 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine1 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine1+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ )+parseRequestLine1 requestLine = do+ let (!method, !rest) = S.break (== _space) requestLine+ (!pathQuery, !httpVer') = S.break (== _space) (S.drop 1 rest)+ !httpVer = S.drop 1 httpVer'+ when (rest == "" || httpVer == "") $+ throwIO $+ BadFirstLine $+ B.unpack requestLine+ let (!path, !query) = S.break (== _question) pathQuery+ (!http, !ver) = S.break (== _slash) httpVer+ when (http /= "HTTP") $ throwIO NonHttp+ let !hv+ | ver == "/1.1" = H.http11+ | otherwise = H.http10+ return $! (method, path, query, hv)++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine0 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine0 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine0 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine0+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ )+parseRequestLine0 s =+ case filter (not . S.null) $ S.splitWith (\c -> c == _space || c == _tab) s of+ (method' : query : http'') -> do+ let !method = method'+ !http' = S.concat http''+ (!hfirst, !hsecond) = S.splitAt 5 http'+ if hfirst == "HTTP/"+ then+ let (!rpath, !qstring) = S.break (== _question) query+ !hv =+ case hsecond of+ "1.1" -> H.http11+ _ -> H.http10+ in return $! (method, rpath, qstring, hv)+ else throwIO NonHttp+ _ -> throwIO $ BadFirstLine $ B.unpack s++-- A long, clean header value (no CR/LF): forces the memchr scan to walk the+-- whole value before deciding it is clean.+cleanLong :: S.ByteString+cleanLong = S.replicate 512 _A++producer :: [ByteString] -> IO Source+producer a = do+ ref <- newIORef a+ mkSource $+ atomicModifyIORef' ref $ \case+ [] -> ([], S.empty)+ b : bs -> (bs, b)++chunkRequest :: Int -> [ByteString]+chunkRequest chunkAmount =+ go basicRequest+ where+ len = L.length basicRequest+ chunkSize = (len `div` chunkAmount) + 1+ go [] = []+ go xs =+ let (a, b) = L.splitAt chunkSize xs+ in B.pack a : go b++-- Random google search request+basicRequest :: String+basicRequest =+ mconcat+ [ "GET /search?q=test&sca_esv=600090652&source=hp&uact=5&oq=test&sclient=gws-wiz HTTP/3\r\n"+ , "Host: www.google.com\r\n"+ , "User-Agent: Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:121.0) Gecko/20100101 Firefox/121.0\r\n"+ , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8\r\n"+ , "Accept-Language: en-US,en;q=0.5\r\n"+ , "Accept-Encoding: gzip, deflate, br\r\n"+ , "Referer: https://www.google.com/\r\n"+ , "Alt-Used: www.google.com\r\n"+ , "Connection: keep-alive\r\n"+ , "Cookie: CONSENT=PENDING+252\r\n"+ , "Upgrade-Insecure-Requests: 1\r\n"+ , "Sec-Fetch-Dest: document\r\n"+ , "Sec-Fetch-Mode: navigate\r\n"+ , "Sec-Fetch-Site: same-origin\r\n"+ , "Sec-Fetch-User: ?1\r\n"+ , "TE: trailers\r\n\r\n"+ ]
+ test/BufferSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module BufferSpec (main, spec) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Builder as BLD+import Data.IORef as I+import Network.Wai.Handler.Warp.Buffer (createWriteBuffer)+import Network.Wai.Handler.Warp.IO (toBufIOWith)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (NonNegative (..))++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "toBufIOWith" $ do+ it "counts short bytestrings" $+ testBufIOWith 10+ -- This failed before fixing 'toBufIOWith'+ it "counts long bytestrings" $ do+ testBufIOWith 1000000+ modifyMaxSize (const 10000000) . prop "counts bytestrings of different sizes" $+ \(NonNegative i) -> testBufIOWith i++testBufIOWith :: Int -> Expectation+testBufIOWith bsLen = do+ len <- toBufIOWithBuilder $ BLD.byteString $ S.replicate bsLen 0+ len `shouldBe` fromIntegral bsLen++toBufIOWithBuilder :: BLD.Builder -> IO Integer+toBufIOWithBuilder bld = do+ countRef <- newIORef 0 :: IO (IORef Int)+ buf <- createWriteBuffer 16384+ bufRef <- newIORef buf+ let go bs = modifyIORef' countRef (+ S.length bs)+ toBufIOWith 1049000000 bufRef go bld
+ test/ConduitSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module ConduitSpec (main, spec) where++import Control.Monad (replicateM)+import qualified Data.ByteString as S+import Data.IORef as I+import Network.Wai.Handler.Warp.Conduit+import Network.Wai.Handler.Warp.Types+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "conduit" $ do+ it "IsolatedBSSource" $ do+ ref <- newIORef $ map S.singleton [1 .. 50]+ src <- mkSource $ do+ x <- readIORef ref+ case x of+ [] -> return S.empty+ y : z -> do+ writeIORef ref z+ return y+ isrc <- mkISource src 40+ x <- replicateM 20 $ readISource isrc+ S.concat x `shouldBe` S.pack [1 .. 20]++ y <- replicateM 40 $ readISource isrc+ S.concat y `shouldBe` S.pack [21 .. 40]++ z <- replicateM 40 $ readSource src+ S.concat z `shouldBe` S.pack [41 .. 50]+ it "chunkedSource" $ do+ ref <- newIORef "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH"+ src <- mkSource $ do+ x <- readIORef ref+ writeIORef ref S.empty+ return x+ csrc <- mkCSource src++ x <- replicateM 15 $ readCSource csrc+ S.concat x `shouldBe` "12345678"++ y <- replicateM 15 $ readSource src+ S.concat y `shouldBe` "BLAH"+ it "chunk boundaries" $ do+ ref <-+ newIORef+ [ "5\r\n"+ , "12345\r\n3\r"+ , "\n678\r\n0\r\n"+ , "\r\nBLAH"+ ]+ src <- mkSource $ do+ x <- readIORef ref+ case x of+ [] -> return S.empty+ y : z -> do+ writeIORef ref z+ return y+ csrc <- mkCSource src++ x <- replicateM 15 $ readCSource csrc+ S.concat x `shouldBe` "12345678"++ y <- replicateM 15 $ readSource src+ S.concat y `shouldBe` "BLAH"
+ test/ConnectionSpec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}++module ConnectionSpec (spec) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp+import RunSpec (msRead, msWrite, withApp, withMySocket)+import Test.Hspec++spec :: Spec+spec = describe "Connection header" $ do+ describe "HTTP/1.0 Connection: close behavior" $ do+ -- HTTP/1.0 defaults to close. We ask for Keep-Alive.+ -- But we provide no Content-Length in response.+ -- So Warp should decide to close (because it can't keep alive without length or chunking),+ -- and MUST send "Connection: close" to inform the client.+ -- (In HTTP/1.0 this requires closing the connection to delimit the+ -- response; or rather, lack of persistence info)+ testClose+ "when response implies close (HTTP/1.0 Keep-Alive, but no Content-Length)"+ (responseLBS status200 [] "foo")+ "GET / HTTP/1.0\r\nConnection: Keep-Alive\r\n\r\n"+ testClose+ "sends \"Connection: close\" on regular HTTP/1.0 GET request"+ (responseBuilder status200 [] "foo")+ "GET / HTTP/1.0\r\nHost: localhost\r\n\r\n"++ describe "HTTP/1.1 Connection: close behavior" $ do+ -- Response has no Content-Length and is not chunked (HEAD implies no body).+ it "does NOT send \"Connection: close\" for HTTP/1.1 HEAD request" $ do+ let app _ f = f $ responseBuilder status200 [] "foo"+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "HEAD / HTTP/1.1\r\nHost: localhost\r\n\r\n"+ -- Should include the Connection header if present and also+ -- should be less then all headers when it's absent, so we+ -- don't wait for nothing.+ response <- msRead ms 73+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Nothing+ testClose+ "when GET request has \"Connection: close\" (200 OK)"+ (responseLBS status200 [] "foo")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when HEAD request has \"Connection: close\" (200 OK)"+ (responseLBS status200 [] "foo")+ "HEAD / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when request has \"Connection: close\" (204 No Content)"+ (responseLBS status204 [] "")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when request has \"Connection: close\" (500 Internal Server Error)"+ (responseLBS status500 [] "error")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ where+ testClose name res input = do+ let prefix = "sends \"Connection: close\" "+ it (prefix <> name) $ do+ let app _ f = f res+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms input+ -- We expect the connection to be closed by the server, so reading a large amount+ -- should return whatever was sent and then finish.+ response <- msRead ms 4096+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Just "close"++parseHeaders :: ByteString -> [(ByteString, ByteString)]+parseHeaders bs =+ let allLines = S8.lines bs+ -- Drop status line+ headerLines = takeWhile (not . S8.null . S8.filter (/= '\r')) $ drop 1 allLines+ parseLine line =+ let (k, v) = S8.break (== ':') line+ v' = S8.takeWhile (/= '\r') v+ in (k, S8.dropWhile (== ' ') $ S8.drop 1 v')+ in map parseLine headerLines
+ test/EarlyHintsSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module EarlyHintsSpec (spec) where++import Test.Hspec++#define HAS_EARLY_HINTS_SUPPORT (MIN_VERSION_http_semantics(0,4,1) && MIN_VERSION_http2(5,4,2))++#if HAS_EARLY_HINTS_SUPPORT+import Control.Exception (bracket)+import Data.ByteString (ByteString)+import Data.IORef+import Network.HPACK (TokenHeaderTable, getFieldValue)+import Network.HPACK.Token (toToken)+import Network.HTTP.Types (Status, methodGet, ok200, status200, status404)+import qualified Network.HTTP2.Client as C+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp (Port, testWithApplication)++spec :: Spec+spec = describe "HTTP/2 Early Hints" $+ it "delivers a WAI app's 103 Early Hints to the client before the final response (h2c)" $+ testWithApplication (pure app) $ \port -> do+ hintsRef <- newIORef []+ earlyHintsClient port hintsRef `shouldReturn` Just ok200+ hints <- readIORef hintsRef+ map (getFieldValue (toToken "link") . snd) hints+ `shouldBe` (Just <$> earlyResponses)++-- | The @Link@ header values delivered as Early Hints, in order.+earlyResponses :: [ByteString]+earlyResponses =+ [ "</style.css>; rel=preload; as=style"+ , "</app.js>; rel=preload; as=script"+ ]++-- | A WAI app that emits two Early Hints sections, then the final response.+app :: Application+app req respond+ | pathInfo req == ["early"] = do+ mapM_ (\link -> requestSendEarlyHints req [("link", link)]) earlyResponses+ respond $ responseLBS status200 [("content-type", "text/plain")] "Hello"+ | otherwise = respond $ responseLBS status404 [] ""++-- | Drive Warp over h2c with the HTTP/2 client, recording each 103 Early Hints+-- section via the client's informational handler, and return the final status.+earlyHintsClient :: Port -> IORef [TokenHeaderTable] -> IO (Maybe Status)+earlyHintsClient port hintsRef = withTCP "127.0.0.1" port $ \sock ->+ bracket (C.allocSimpleConfig sock 4096) C.freeSimpleConfig $ \conf ->+ C.run cliconf (conf{C.confOnInformational = onInformational}) $ \sendRequest _aux ->+ sendRequest (C.requestNoBody methodGet "/early" []) (return . C.responseStatus)+ where+ cliconf = C.defaultClientConfig{C.authority = "127.0.0.1"}+ onInformational _streamId tbl = modifyIORef' hintsRef (++ [tbl])++-- | Connect to a TCP server, run an action, and close the socket afterwards.+withTCP :: HostName -> Port -> (Socket -> IO a) -> IO a+withTCP host port = bracket open close+ where+ open = do+ addr : _ <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just host) (Just (show port))+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ connect sock (addrAddress addr)+ return sock+#else+spec :: Spec+spec = describe "HTTP/2 Early Hints" $+ it "delivers a WAI app's 103 Early Hints to the client before the final response (h2c)" $+ pendingWith "requires http2 >= 5.4.2 and http-semantics >= 0.4.1"+#endif
+ test/ExceptionSpec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module ExceptionSpec (main, spec) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import Control.Concurrent.Async (withAsync)+import Control.Exception+import Control.Monad+import qualified Data.Streaming.Network as N+import Network.HTTP.Types hiding (Header)+import Network.Socket (close)+import Network.Wai hiding (Response, responseStatus)+import Network.Wai.Handler.Warp+import Network.Wai.Internal (Request (..))+import Test.Hspec++import HTTP++main :: IO ()+main = hspec spec++withTestServer :: (Int -> IO a) -> IO a+withTestServer inner = bracket+ (N.bindRandomPortTCP "127.0.0.1")+ (close . snd)+ $ \(prt, lsocket) -> do+ withAsync (runSettingsSocket defaultSettings lsocket testApp) $+ \_ -> inner prt++testApp :: Application+testApp (Network.Wai.Internal.Request{pathInfo = [x]}) f+ | x == "statusError" =+ f $ responseLBS undefined [] "foo"+ | x == "headersError" =+ f $ responseLBS ok200 undefined "foo"+ | x == "headerError" =+ f $ responseLBS ok200 [undefined] "foo"+ | x == "bodyError" =+ f $ responseLBS ok200 [] undefined+ | x == "ioException" = do+ void $ fail "ioException"+ f $ responseLBS ok200 [] "foo"+testApp _ f =+ f $ responseLBS ok200 [] "foo"++spec :: Spec+spec = describe "responds even if there is an exception" $ do+ {- Disabling these tests. We can consider forcing evaluation in Warp.+ it "statusError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"+ sc `shouldBe` internalServerError500+ it "headersError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"+ sc `shouldBe` internalServerError500+ it "headerError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"+ sc `shouldBe` internalServerError500+ it "bodyError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"+ sc `shouldBe` internalServerError500+ -}+ it "ioException" $ withTestServer $ \prt -> do+ sc <-+ responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")+ sc `shouldBe` internalServerError500
+ test/FdCacheSpec.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}++module FdCacheSpec where++import Test.Hspec+#ifndef WINDOWS+import Data.IORef+import Network.Wai.Handler.Warp.FdCache+import System.Posix.IO.ByteString (fdRead)+import System.Posix.Types (Fd(..))++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "withFdCache" $ do+ it "clean up Fd" $ do+ ref <- newIORef (Fd (-1))+ withFdCache 30000000 $ \getFd -> do+ (Just fd,_) <- getFd "warp.cabal"+ writeIORef ref fd+ nfd <- readIORef ref+ fdRead nfd 1 `shouldThrow` anyIOException+#else+spec :: Spec+spec = return ()+#endif
+ test/FileSpec.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}++module FileSpec (main, spec) where++import Data.ByteString+import Data.String (fromString)+import Network.HTTP.Types+import Network.Wai.Handler.Warp.File+import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.Header+import System.IO.Unsafe (unsafePerformIO)++import Test.Hspec++main :: IO ()+main = hspec spec++changeHeaders+ :: (ResponseHeaders -> ResponseHeaders) -> RspFileInfo -> RspFileInfo+changeHeaders f rfi =+ case rfi of+ WithBody s hs off len -> WithBody s (f hs) off len+ other -> other++getHeaders :: RspFileInfo -> ResponseHeaders+getHeaders rfi =+ case rfi of+ WithBody _ hs _ _ -> hs+ _ -> []++testFileRange+ :: String+ -> RequestHeaders+ -> RspFileInfo+ -> Spec+testFileRange desc reqhs ans = it desc $ do+ finfo <- getInfo "attic/hex"+ let f = (:) ("Last-Modified", fileInfoDate finfo)+ hs = getHeaders ans+ ans' = changeHeaders f ans+ conditionalRequest+ finfo+ []+ methodGet+ (indexResponseHeader hs)+ (indexRequestHeader reqhs)+ `shouldBe` ans'++farPast, farFuture :: ByteString+farPast = "Thu, 01 Jan 1970 00:00:00 GMT"+farFuture = "Sun, 05 Oct 3000 00:00:00 GMT"++regularBody :: RspFileInfo+regularBody = WithBody ok200 [("Content-Length", "16"), ("Accept-Ranges", "bytes")] 0 16++make206Body :: Integer -> Integer -> RspFileInfo+make206Body start len =+ WithBody status206 [crHeader, lenHeader, ("Accept-Ranges", "bytes")] start len+ where+ lenHeader = ("Content-Length", fromString $ show len)+ crHeader =+ ( "Content-Range"+ , fromString $ "bytes " <> show start <> "-" <> show (start + len - 1) <> "/16"+ )++spec :: Spec+spec = do+ describe "conditionalRequest" $ do+ testFileRange+ "gets a file size from file system"+ []+ regularBody+ testFileRange+ "gets a file size from file system and handles Range and returns Partical Content"+ [("Range", "bytes=2-14")]+ $ make206Body 2 13+ testFileRange+ "truncates end point of range to file size"+ [("Range", "bytes=10-20")]+ $ make206Body 10 6+ testFileRange+ "gets a file size from file system and handles Range and returns OK if Range means the entire"+ [("Range:", "bytes=0-15")]+ regularBody+ testFileRange+ "returns a 412 if the file has been changed in the meantime"+ [("If-Unmodified-Since", farPast)]+ $ WithoutBody status412+ testFileRange+ "gets a file if the file has not been changed in the meantime"+ [("If-Unmodified-Since", farFuture)]+ regularBody+ testFileRange+ "ignores the If-Unmodified-Since header if an If-Match header is also present"+ [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast)]+ regularBody+ testFileRange+ "still gives only a range, even after conditionals"+ [ ("If-Match", "SomeETag")+ , ("If-Unmodified-Since", farPast)+ , ("Range", "bytes=10-20")+ ]+ $ make206Body 10 6+ testFileRange+ "gets a file if the file has been changed in the meantime"+ [("If-Modified-Since", farPast)]+ regularBody+ testFileRange+ "returns a 304 if the file has not been changed in the meantime"+ [("If-Modified-Since", farFuture)]+ $ WithoutBody status304+ testFileRange+ "ignores the If-Modified-Since header if an If-None-Match header is also present"+ [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture)]+ regularBody+ testFileRange+ "still gives only a range, even after conditionals"+ [ ("If-None-Match", "SomeETag")+ , ("If-Modified-Since", farFuture)+ , ("Range", "bytes=10-13")+ ]+ $ make206Body 10 4+ testFileRange+ "gives the a range, if the condition is met"+ [ ("If-Range", fileInfoDate (unsafePerformIO $ getInfo "attic/hex"))+ , ("Range", "bytes=2-7")+ ]+ $ make206Body 2 6+ testFileRange+ "gives the entire body and ignores the Range header if the condition isn't met"+ [("If-Range", farPast), ("Range", "bytes=2-7")]+ regularBody
+ test/GracefulShutdownSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module GracefulShutdownSpec (spec) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception (bracket)+import Control.Monad (void)+import Network.HTTP.Client+import Network.HTTP.Types (ok200, status200)+import Network.Socket (close)+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+spec = describe "graceful shutdown" $+ it "serves the request in flight, then closes keep-alive connections and exits" $ do+ shutdownSignal <- newEmptyMVar+ allowResponse <- newEmptyMVar+ receivedRequests <- newQSemN 0+ allowSecondRequest <- newEmptyMVar++ let installShutdownHandler closeListenSocket =+ void . forkIO $ do+ readMVar shutdownSignal+ closeListenSocket++ settings =+ setInstallShutdownHandler installShutdownHandler defaultSettings++ app _ respond = do+ -- signal 1 received request+ signalQSemN receivedRequests 1+ -- block until signaled+ readMVar allowResponse+ respond $ responseLBS status200 [("Content-Length", "0")] ""++ client sendRequest = do+ -- first request should return OK+ response <- sendRequest+ responseStatus response `shouldBe` ok200+ lookup "Connection" (responseHeaders response) `shouldBe` Just "close"+ -- wait with the second request+ void $ readMVar allowSecondRequest+ -- second request should end with connection refused+ sendRequest `shouldThrow` connectionRefused++ bracket openFreePort (close . snd) $ \(testPort, sock) ->+ withAsync (runSettingsSocket settings sock app) $ \server -> do+ manager <- newManager defaultManagerSettings+ request <- parseRequest ("http://127.0.0.1:" ++ show testPort)+ withAsync+ -- start all clients+ ( replicateConcurrently_ numClients $+ client (httpNoBody request manager)+ )+ $ \clients -> do+ -- wait for all clients to send requests+ waitQSemN receivedRequests numClients+ -- shutdown the server before serving requests+ putMVar shutdownSignal ()+ -- wait a little - otherwise some requests might not get+ -- Connection: close response header+ threadDelay 100_000+ -- let requests be handled+ putMVar allowResponse ()+ -- server should exit+ timeout 5_000_000 (wait server)+ >>= maybe (expectationFailure "Timeout waiting for server shutdown") pure+ -- let clients proceed with the second request+ putMVar allowSecondRequest ()+ -- wait for all clients and propagate any exceptions+ wait clients+ where+ -- set number of clients to the number of keep-alive connections+ numClients = managerConnCount defaultManagerSettings+ connectionRefused = \case+ (HttpExceptionRequest _ (ConnectionFailure _)) -> True+ _ -> False
+ test/HTTP.hs view
@@ -0,0 +1,41 @@+module HTTP (+ sendGET,+ sendGETwH,+ sendHEAD,+ sendHEADwH,+ responseBody,+ responseStatus,+ responseHeaders,+ getHeaderValue,+ HeaderName,+) where++import Data.ByteString+import qualified Data.ByteString.Lazy as BL+import Network.HTTP.Client+import Network.HTTP.Types++sendGET :: String -> IO (Response BL.ByteString)+sendGET url = sendGETwH url []++sendGETwH :: String -> [Header] -> IO (Response BL.ByteString)+sendGETwH url hdr = do+ manager <- newManager defaultManagerSettings+ request <- parseRequest url+ let request' = request{requestHeaders = hdr}+ response <- httpLbs request' manager+ return response++sendHEAD :: String -> IO (Response BL.ByteString)+sendHEAD url = sendHEADwH url []++sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString)+sendHEADwH url hdr = do+ manager <- newManager defaultManagerSettings+ request <- parseRequest url+ let request' = request{requestHeaders = hdr, method = methodHead}+ response <- httpLbs request' manager+ return response++getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString+getHeaderValue = lookup
+ test/PackIntSpec.hs view
@@ -0,0 +1,14 @@+module PackIntSpec (spec) where++import qualified Data.ByteString.Char8 as C8+import Network.Wai.Handler.Warp.PackInt+import Test.Hspec+import Test.Hspec.QuickCheck+import qualified Test.QuickCheck as QC++spec :: Spec+spec = describe "readInt64" $ do+ prop "" $ \n -> packIntegral (abs n :: Int) == C8.pack (show (abs n))+ prop "" $ \(QC.Large n) ->+ let n' = fromIntegral (abs n :: Int)+ in packIntegral (n' :: Int) == C8.pack (show n')
+ test/ReadIntSpec.hs view
@@ -0,0 +1,28 @@+module ReadIntSpec (main, spec) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Network.Wai.Handler.Warp.ReadInt+import Test.Hspec+import qualified Test.QuickCheck as QC++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "readInt64" $ do+ it "converts ByteString to Int" $+ QC.property (prop_read_show_idempotent readInt64)++-- A QuickCheck property. Test that for a number >= 0, converting it to+-- a string using show and then reading the value back with the function+-- under test returns the original value.+-- The functions under test only work on Natural numbers (the Conent-Length+-- field in a HTTP header is always >= 0) so we check the absolute value of+-- the value that QuickCheck generates for us.+prop_read_show_idempotent+ :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool+prop_read_show_idempotent freader x = px == freader (toByteString px)+ where+ px = abs x+ toByteString = B.pack . show
+ test/RequestSpec.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module RequestSpec (main, spec) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.IORef+import Data.Monoid (Sum (..))+import qualified Network.HTTP.Types.Header as HH+import Network.Wai.Handler.Warp.File (parseByteRanges)+import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Settings (+ defaultSettings,+ settingsMaxTotalHeaderLength,+ )+import Network.Wai.Handler.Warp.Types+import Test.Hspec+import Test.Hspec.QuickCheck++main :: IO ()+main = hspec spec++defaultMaxTotalHeaderLength :: Int+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings++spec :: Spec+spec = do+ describe "headerLines" $ do+ it "takes until blank" $+ blankSafe `shouldReturn` ("", ["foo", "bar", "baz"])+ it "ignored leading whitespace in bodies" $+ whiteSafe `shouldReturn` (" hi there", ["foo", "bar", "baz"])+ it "throws OverLargeHeader when too many" $+ tooMany `shouldThrow` overLargeHeader+ it "throws OverLargeHeader when too large" $+ tooLarge `shouldThrow` overLargeHeader+ it "known bad chunking behavior #239" $ do+ let chunks =+ [ "GET / HTTP/1.1\r\nConnection: Close\r"+ , "\n\r\n"+ ]+ (actual, src) <- headerLinesList' chunks+ leftover <- readLeftoverSource src+ leftover `shouldBe` S.empty+ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]+ prop "random chunking" $ \breaks extraS -> do+ let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra+ extra = S8.pack extraS+ chunks = loop breaks bsFull+ loop [] bs = [bs, undefined]+ loop (x : xs) bs =+ bs1 : loop xs bs2+ where+ (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs+ (actual, src) <- headerLinesList' chunks+ leftover <- consumeLen (length extraS) src++ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]+ leftover `shouldBe` extra+ describe "parseByteRanges" $ do+ let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y+ test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499]+ test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999]+ test "bytes=-500" $ Just [HH.ByteRangeSuffix 500]+ test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500]+ test "foobytes=9500-" Nothing+ test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1]++ describe "headerLines" $ do+ let parseHeaderLine chunks = do+ src <- mkSourceFunc chunks >>= mkSource+ x <- headerLines defaultMaxTotalHeaderLength FirstRequest src+ x `shouldBe` ["Status: 200", "Content-Type: text/plain"]++ it "can handle a normal case" $+ parseHeaderLine ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"]++ it "can handle a nasty case (1)" $ do+ parseHeaderLine ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"]+ parseHeaderLine ["Status: 200\r\n", "Content-Type: text/plain", "\r\n\r\n"]++ it "can handle a nasty case (2)" $ do+ parseHeaderLine+ ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"]++ it "can handle a nasty case (3)" $ do+ parseHeaderLine+ ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"]++ it "can handle a stupid case (3)" $+ parseHeaderLine $+ S8.pack . (: []) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n"++ it "can (not) handle an illegal case (1)" $ do+ let chunks = ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"]+ src <- mkSourceFunc chunks >>= mkSource+ x <- headerLines defaultMaxTotalHeaderLength FirstRequest src+ x `shouldBe` []+ y <- headerLines defaultMaxTotalHeaderLength FirstRequest src+ y `shouldBe` ["Status:", " 200", "Content-Type: text/plain"]++ let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"]+ headerLength = getSum $ foldMap (Sum . S.length) testLengthHeaders+ testLength = headerLength - 2 -- Because the second CRLF at the end isn't counted+ -- Length is 39, this shouldn't fail+ it "doesn't throw on correct length" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ x <- headerLines testLength FirstRequest src+ x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ -- Length is still 39, this should fail+ it "throws error on correct length too long" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ headerLines (testLength - 1) FirstRequest src `shouldThrow` (== OverLargeHeader)+ where+ blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"]+ whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]+ tooMany = headerLinesList $ repeat "f\n"+ tooLarge = headerLinesList $ repeat "f"++headerLinesList :: [S8.ByteString] -> IO (S8.ByteString, [S8.ByteString])+headerLinesList orig = do+ (res, src) <- headerLinesList' orig+ leftover <- readLeftoverSource src+ return (leftover, res)++headerLinesList' :: [S8.ByteString] -> IO ([S8.ByteString], Source)+headerLinesList' orig = do+ ref <- newIORef orig+ let src = do+ x <- readIORef ref+ case x of+ [] -> return S.empty+ y : z -> do+ writeIORef ref z+ return y+ src' <- mkSource src+ res <- headerLines defaultMaxTotalHeaderLength FirstRequest src'+ return (res, src')++consumeLen :: Int -> Source -> IO S8.ByteString+consumeLen len0 src =+ loop id len0+ where+ loop front len+ | len <= 0 = return $ S.concat $ front []+ | otherwise = do+ bs <- readSource src+ if S.null bs+ then loop front 0+ else do+ let (x, _) = S.splitAt len bs+ loop (front . (x :)) (len - S.length x)++overLargeHeader :: Selector InvalidRequest+overLargeHeader e = e == OverLargeHeader++mkSourceFunc :: [S8.ByteString] -> IO (IO S8.ByteString)+mkSourceFunc bss = do+ ref <- newIORef bss+ return $ reader ref+ where+ reader ref = do+ xss <- readIORef ref+ case xss of+ [] -> return S.empty+ (x : xs) -> do+ writeIORef ref xs+ return x
+ test/ResponseHeaderSpec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module ResponseHeaderSpec (main, spec) where++import Data.ByteString+import qualified Network.HTTP.Types as H+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.ResponseHeader+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "composeHeader" $ do+ it "composes a HTTP header" $+ composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader+ describe "addServer" $ do+ it "adds Server if not exist" $ do+ let hdrs = []+ rspidxhdr = indexResponseHeader hdrs+ addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server", "MyServer")]+ it "does not add Server if exists" $ do+ let hdrs = [("Server", "MyServer")]+ rspidxhdr = indexResponseHeader hdrs+ addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs+ it "does not add Server if empty" $ do+ let hdrs = []+ rspidxhdr = indexResponseHeader hdrs+ addServer "" rspidxhdr hdrs `shouldBe` hdrs+ it "deletes Server " $ do+ let hdrs = [("Server", "MyServer")]+ rspidxhdr = indexResponseHeader hdrs+ addServer "" rspidxhdr hdrs `shouldBe` []++headers :: H.ResponseHeaders+headers =+ [ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")+ , ("Content-Length", "151")+ , ("Server", "Mighttpd/2.5.8")+ , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")+ , ("Content-Type", "text/html")+ ]++composedHeader :: ByteString+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"
+ test/ResponseSpec.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module ResponseSpec (main, spec) where++import Control.Concurrent (threadDelay)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.Maybe (mapMaybe)+import Network.HTTP.Types+import Network.Wai hiding (responseHeaders)+import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp.Response+import RunSpec (msRead, msWrite, withApp, withMySocket)+import Test.Hspec++main :: IO ()+main = hspec spec++testRange+ :: S.ByteString+ -- ^ range value+ -> String+ -- ^ expected output+ -> Maybe String+ -- ^ expected content-range value+ -> Spec+testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "GET / HTTP/1.0\r\n"+ msWrite ms "Range: bytes="+ msWrite ms range+ msWrite ms "\r\n\r\n"+ threadDelay 10000+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024+ last bss `shouldBe` out+ let hs = mapMaybe toHeader bss+ lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange+ lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)+ where+ app _ = ($ responseFile status200 [] "attic/hex" Nothing)+ title = show (range, out, crange)+ toHeader s =+ case break (== ':') s of+ (x, ':' : y) -> Just (x, dropWhile (== ' ') y)+ _ -> Nothing++testPartial+ :: Integer+ -- ^ file size+ -> Integer+ -- ^ offset+ -> Integer+ -- ^ byte count+ -> String+ -- ^ expected output+ -> Spec+testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "GET / HTTP/1.0\r\n\r\n"+ threadDelay 10000+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024+ out `shouldBe` last bss+ let hs = mapMaybe toHeader bss+ lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)+ lookup "Content-Range" hs `shouldBe` Just range+ where+ app _ = ($ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size)+ title = show (offset, count, out)+ toHeader s =+ case break (== ':') s of+ (x, ':' : y) -> Just (x, dropWhile (== ' ') y)+ _ -> Nothing+ range =+ "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size++spec :: Spec+spec = do+ describe "sanitizeHeaderValue" $ do+ it "replaces multiline header value's [CR LF NUL] with SP" $ do+ sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\r\n\NULbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\n bar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\nbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\rbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\NULbar" `shouldBe` "foo bar"++ describe "range requests" $ do+ testRange "2-3" "23" $ Just "2-3/16"+ testRange "5-" "56789abcdef" $ Just "5-15/16"+ testRange "5-8" "5678" $ Just "5-8/16"+ testRange "-3" "def" $ Just "13-15/16"+ testRange "16-" "" $ Just "*/16"+ testRange "-17" "0123456789abcdef" Nothing++ describe "partial files" $ do+ testPartial 16 2 2 "23"+ testPartial 16 0 2 "01"+ testPartial 16 3 8 "3456789a"
+ test/RunSpec.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM+import Control.Exception (IOException, bracket, onException, try)+import qualified Control.Exception as E+import Control.Monad (forM_, replicateM_, unless)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import Data.ByteString.Builder (byteString)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import qualified Data.IORef as I+import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)+import Network.HTTP.Types+import Network.Socket+import Network.Socket.ByteString (sendAll)+import Network.Wai hiding (responseHeaders)+import Network.Wai.Handler.Warp hiding (Counter)+import System.IO.Unsafe (unsafePerformIO)+import System.Timeout (timeout)+import Test.Hspec++import HTTP++main :: IO ()+main = hspec spec++type Counter = I.IORef (Either String Int)+type CounterApplication = Counter -> Application++data MySocket = MySocket+ { msSocket :: !Socket+ , msBuffer :: !(I.IORef ByteString)+ }++msWrite :: MySocket -> ByteString -> IO ()+msWrite = sendAll . msSocket++msRead :: MySocket -> Int -> IO ByteString+msRead (MySocket s ref) expected = do+ bs <- I.readIORef ref+ inner (bs :) (S.length bs)+ where+ inner front total =+ case compare total expected of+ EQ -> do+ I.writeIORef ref mempty+ pure $ S.concat $ front []+ GT -> do+ let bs = S.concat $ front []+ (x, y) = S.splitAt expected bs+ I.writeIORef ref y+ pure x+ LT -> do+ bs <- safeRecv s 4096+ if S.null bs+ then do+ I.writeIORef ref mempty+ pure $ S.concat $ front []+ else inner (front . (bs :)) (total + S.length bs)++msClose :: MySocket -> IO ()+msClose = Network.Socket.close . msSocket++connectTo :: Int -> IO MySocket+connectTo port = do+ s <- fst <$> getSocketTCP "127.0.0.1" port+ ref <- I.newIORef mempty+ return+ MySocket+ { msSocket = s+ , msBuffer = ref+ }++withMySocket :: (MySocket -> IO a) -> Int -> IO a+withMySocket body port = bracket (connectTo port) msClose body++incr :: MonadIO m => Counter -> m ()+incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->+ ( case ecount of+ Left s -> Left s+ Right i -> Right $ i + 1+ , ()+ )++err :: (MonadIO m, Show a) => Counter -> a -> m ()+err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg++readBody :: CounterApplication+readBody icount req f = do+ body <- consumeBody $ getRequestBodyChunk req+ case () of+ ()+ | pathInfo req == ["hello"] && L.fromChunks body /= "Hello" ->+ err icount ("Invalid hello" :: String, body)+ | requestMethod req == "GET" && L.fromChunks body /= "" ->+ err icount ("Invalid GET" :: String, body)+ | requestMethod req `notElem` ["GET", "POST"] ->+ err icount ("Invalid request method (readBody)" :: String, requestMethod req)+ | otherwise -> incr icount+ f $ responseLBS status200 [] "Read the body"++ignoreBody :: CounterApplication+ignoreBody icount req f = do+ if requestMethod req `elem` ["GET", "POST"]+ then incr icount+ else err icount ("Invalid request method" :: String, requestMethod req)+ f $ responseLBS status200 [] "Ignored the body"++doubleConnect :: CounterApplication+doubleConnect icount req f = do+ _ <- consumeBody $ getRequestBodyChunk req+ _ <- consumeBody $ getRequestBodyChunk req+ incr icount+ f $ responseLBS status200 [] "double connect"++nextPort :: I.IORef Int+nextPort = unsafePerformIO $ I.newIORef 5000+{-# NOINLINE nextPort #-}++getPort :: IO Int+getPort = do+ port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)+ esocket <- try $ bindPortTCP port "127.0.0.1"+ case esocket of+ Left (_ :: IOException) -> RunSpec.getPort+ Right sock -> do+ close sock+ return port++withApp :: Settings -> Application -> (Int -> IO a) -> IO a+withApp settings app f = do+ port <- RunSpec.getPort+ baton <- newEmptyMVar+ let settings' =+ setPort port $+ setHost "127.0.0.1" $+ setBeforeMainLoop+ (putMVar baton ())+ settings+ bracket+ (forkIO $ runSettings settings' app `onException` putMVar baton ())+ killThread+ ( const $ do+ takeMVar baton+ -- use timeout to make sure we don't take too long+ mres <- timeout (3 * 1000 * 1000) (f port)+ case mres of+ Nothing -> error "Timeout triggered, too slow!"+ Just a -> pure a+ )++runTest+ :: Int+ -- ^ expected number of requests+ -> CounterApplication+ -> [ByteString]+ -- ^ chunks to send+ -> IO ()+runTest expected app chunks = do+ ref <- I.newIORef (Right 0)+ withApp defaultSettings (app ref) $ withMySocket $ \ms -> do+ forM_ chunks $ \chunk -> msWrite ms chunk+ _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096+ res <- I.readIORef ref+ case res of+ Left s -> error s+ Right i -> i `shouldBe` expected++dummyApp :: Application+dummyApp _ f = f $ responseLBS status200 [] "foo"++runTerminateTest+ :: InvalidRequest+ -> ByteString+ -> IO ()+runTerminateTest expected input = do+ ref <- I.newIORef Nothing+ let onExc _ = I.writeIORef ref . Just+ withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do+ msWrite ms input+ msClose ms -- explicitly+ threadDelay 5000+ res <- I.readIORef ref+ show res `shouldBe` show (Just expected)++singleGet :: ByteString+singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"++singlePostHello :: ByteString+singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"++singleChunkedPostHello :: [ByteString]+singleChunkedPostHello =+ [ "POST /hello HTTP/1.1\r\nHost: localhost\r\nTransfer-Encoding: chunked\r\n\r\n"+ , "5\r\nHello\r\n0\r\n"+ ]++spec :: Spec+spec = do+ describe "non-pipelining" $ do+ it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet+ it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet+ it "has body, read" $+ runTest+ 2+ readBody+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $+ runTest+ 2+ ignoreBody+ [ singlePostHello+ , singleGet+ ]+ it "chunked body, read" $+ runTest 2 readBody $+ singleChunkedPostHello ++ [singleGet]+ it "chunked body, ignore" $+ runTest 2 ignoreBody $+ singleChunkedPostHello ++ [singleGet]+ describe "pipelining" $ do+ it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]+ it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]+ it "has body, read" $+ runTest 2 readBody $+ return $+ S.concat+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $+ runTest 2 ignoreBody $+ return $+ S.concat+ [ singlePostHello+ , singleGet+ ]+ it "chunked body, read" $+ runTest 2 readBody $+ return $+ S.concat+ [ S.concat singleChunkedPostHello+ , singleGet+ ]+ it "chunked body, ignore" $+ runTest 2 ignoreBody $+ return $+ S.concat+ [ S.concat singleChunkedPostHello+ , singleGet+ ]+ describe "no hanging" $ do+ it "has body, read" $+ runTest 1 readBody $+ map S.singleton $+ S.unpack singlePostHello+ it "double connect" $ runTest 1 doubleConnect [singlePostHello]++ describe "connection termination" $ do+ -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"+ it "IncompleteHeaders" $ do+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-lengt"++ describe "special input" $ do+ let appWithSocket f = do+ iheaders <- I.newIORef []+ let app req respond = do+ liftIO $ I.writeIORef iheaders $ requestHeaders req+ respond $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ f iheaders++ it "multiline headers" $ do+ appWithSocket $ \iheaders ms -> do+ let input = "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"+ msWrite ms input+ threadDelay 5000+ headers <- I.readIORef iheaders+ headers+ `shouldBe` [ ("foo", "bar")+ , (" baz", "")+ , ("\tbin", "")+ ]+ it "no space between colon and value" $ do+ appWithSocket $ \iheaders ms -> do+ let input = "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"+ msWrite ms input+ threadDelay 5000+ headers <- I.readIORef iheaders+ headers `shouldBe` [("foo", "bar")]+ it "does not recognize multiline headers" $ do+ appWithSocket $ \iheaders ms -> do+ msWrite ms "GET / HTTP/1.1\r\nfoo: and\r\n"+ msWrite ms " baz as well\r\n\r\n"+ threadDelay 5000+ headers <- I.readIORef iheaders+ headers+ `shouldBe` [ ("foo", "and")+ , (" baz as well", "")+ ]++ describe "chunked bodies" $ do+ it "works" $ do+ countVar <- newTVarIO (0 :: Int)+ ifront <- I.newIORef id+ let app req f = do+ bss <- consumeBody $ getRequestBodyChunk req+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+ atomically $ modifyTVar countVar (+ 1)+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ let input =+ S.concat+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "b\r\nHello World\r\n0\r\n\r\n"+ ]+ msWrite ms input+ atomically $ do+ count <- readTVar countVar+ check $ count == 2+ front <- I.readIORef ifront+ front []+ `shouldBe` [ "Hello World\nBye"+ , "Hello World"+ ]+ it "lots of chunks" $ do+ ifront <- I.newIORef id+ countVar <- newTVarIO (0 :: Int)+ let app req f = do+ bss <- consumeBody $ getRequestBodyChunk req+ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+ atomically $ modifyTVar countVar (+ 1)+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ let input =+ concat $+ replicate 2 $+ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"]+ ++ replicate 50 "5\r\n12345\r\n"+ ++ ["0\r\n\r\n"]+ mapM_ (msWrite ms) input+ atomically $ do+ count <- readTVar countVar+ check $ count == 2+ front <- I.readIORef ifront+ front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")+ -- For some reason, the following test on Windows causes the socket+ -- to be killed prematurely. Worth investigating in the future if possible.+ it "in chunks" $ do+ ifront <- I.newIORef id+ countVar <- newTVarIO (0 :: Int)+ let app req f = do+ bss <- consumeBody $ getRequestBodyChunk req+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+ atomically $ modifyTVar countVar (+ 1)+ f $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ let input =+ S.concat+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "b\r\nHello World\r\n0\r\n\r\n"+ ]+ mapM_ (msWrite ms . S.singleton) $ S.unpack input+ atomically $ do+ count <- readTVar countVar+ check $ count == 2+ front <- I.readIORef ifront+ front []+ `shouldBe` [ "Hello World\nBye"+ , "Hello World"+ ]+ it "timeout in request body" $ do+ ifront <- I.newIORef id+ let app req f = do+ bss <-+ consumeBody (getRequestBodyChunk req)+ `onException` liftIO+ (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted" :), ())))+ liftIO $+ threadDelay 500000 `E.catch` \e -> do+ I.atomicModifyIORef+ ifront+ ( \front ->+ ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e) :)+ , ()+ )+ )+ E.throwIO (e :: E.SomeException)+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+ f $ responseLBS status200 [] ""+ withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do+ let bs1 = S.replicate 2048 88+ bs2 = "This is short"+ bs = S.append bs1 bs2+ msWrite ms "POST / HTTP/1.1\r\n"+ msWrite ms "content-length: "+ msWrite ms $ S8.pack $ show $ S.length bs+ msWrite ms "\r\n\r\n"+ threadDelay 100000+ msWrite ms bs1+ threadDelay 100000+ msWrite ms bs2+ threadDelay 1000000+ front <- I.readIORef ifront+ S.concat (front []) `shouldBe` bs+ describe "raw body" $ do+ it "works" $ do+ let app _req f = do+ let backup = responseLBS status200 [] "Not raw"+ f $ flip responseRaw backup $ \src sink -> do+ let loop = do+ bs <- src+ unless (S.null bs) $ do+ sink $ doubleBS bs+ loop+ loop+ doubleBS = S.concatMap $ \w -> S.pack [w, w]+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "POST / HTTP/1.1\r\n\r\n12345"+ timeout 100000 (msRead ms 10) `shouldReturn` Just "1122334455"+ msWrite ms "67890"+ timeout 100000 (msRead ms 10) `shouldReturn` Just "6677889900"+ it "only one date and server header" $ do+ let app _ f =+ f $+ responseLBS+ status200+ [ ("server", "server")+ , ("date", "date")+ ]+ ""+ getValues key =+ map snd+ . filter (\(key', _) -> key == key')+ . responseHeaders+ withApp defaultSettings app $ \port -> do+ res <- sendGET $ "http://127.0.0.1:" ++ show port+ getValues hServer res `shouldBe` ["server"]+ getValues hDate res `shouldBe` ["date"]++ it "streaming echo #249" $ do+ countVar <- newTVarIO (0 :: Int)+ let app req f = f $ responseStream status200 [] $ \write _ -> do+ let loop = do+ bs <- getRequestBodyChunk req+ unless (S.null bs) $ do+ write $ byteString bs+ atomically $ modifyTVar countVar (+ 1)+ loop+ loop+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"+ threadDelay 10000+ msWrite ms "5\r\nhello\r\n0\r\n\r\n"+ atomically $ do+ count <- readTVar countVar+ check $ count >= 1+ bs <- safeRecv (msSocket ms) 4096 -- must not use msRead+ S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"++ it "streaming response with length" $ do+ let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do+ replicateM_ 4 $ write $ byteString "Hello"+ withApp defaultSettings app $ \port -> do+ res <- sendGET $ "http://127.0.0.1:" ++ show port+ responseBody res `shouldBe` "HelloHelloHelloHello"++ describe "head requests" $ do+ let fp = "test/head-response"+ let app req f =+ f $ case pathInfo req of+ ["builder"] -> responseBuilder status200 [] $ error "should never be evaluated"+ ["streaming"] -> responseStream status200 [] $ \write _ ->+ write $ error "should never be evaluated"+ ["file"] -> responseFile status200 [] fp Nothing+ _ -> error "invalid path"+ it "builder" $ withApp defaultSettings app $ \port -> do+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]+ responseBody res `shouldBe` ""+ it "streaming" $ withApp defaultSettings app $ \port -> do+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]+ responseBody res `shouldBe` ""+ it "file, no range" $ withApp defaultSettings app $ \port -> do+ bs <- S.readFile fp+ res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]+ getHeaderValue hContentLength (responseHeaders res)+ `shouldBe` Just (S8.pack $ show $ S.length bs)+ it "file, with range" $ withApp defaultSettings app $ \port -> do+ res <-+ sendHEADwH+ (concat ["http://127.0.0.1:", show port, "/file"])+ [(hRange, "bytes=0-1")]+ getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2"++consumeBody :: IO ByteString -> IO [ByteString]+consumeBody body =+ loop id+ where+ loop front = do+ bs <- body+ if S.null bs+ then return $ front []+ else loop $ front . (bs :)
+ test/SendFileSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}++module SendFileSpec where++import Control.Exception+import Control.Monad (when)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.SendFile+import Network.Wai.Handler.Warp.Types+import System.Directory+import System.Exit+import qualified System.IO as IO+import System.Process (system)+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "packHeader" $ do+ it "returns how much the buffer is consumed (1)" $+ tryPackHeader 10 ["foo"] `shouldReturn` 3+ it "returns how much the buffer is consumed (2)" $+ tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6+ it "returns how much the buffer is consumed (3)" $+ tryPackHeader 10 ["0123456789"] `shouldReturn` 0+ it "returns how much the buffer is consumed (4)" $+ tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0+ it "returns how much the buffer is consumed (5)" $+ tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3+ it "returns how much the buffer is consumed (6)" $+ tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5++ it "sends headers correctly (1)" $+ tryPackHeader2 10 ["foo"] "" `shouldReturn` True+ it "sends headers correctly (2)" $+ tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True+ it "sends headers correctly (3)" $+ tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True+ it "sends headers correctly (4)" $+ tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True+ it "sends headers correctly (5)" $+ tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True+ it "sends headers correctly (6)" $+ tryPackHeader2+ 10+ ["012345678901234567890123456789012", "34"]+ "012345678901234567890123456789"+ `shouldReturn` True++ describe "readSendFile" $ do+ it "sends a file correctly (1)" $+ tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess+ it "sends a file correctly (2)" $+ tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess+ it "sends a file correctly (3)" $+ tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess++tryPackHeader :: Int -> [ByteString] -> IO Int+tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf ->+ packHeader buf siz send hook hdrs 0+ where+ send _ = return ()+ hook = return ()++tryPackHeader2 :: Int -> [ByteString] -> ByteString -> IO Bool+tryPackHeader2 siz hdrs ans = bracket setup teardown $ \buf -> do+ _ <- packHeader buf siz send hook hdrs 0+ checkFile outputFile ans+ where+ setup = allocateBuffer siz+ teardown buf = freeBuffer buf >> removeFileIfExists outputFile+ outputFile = "tempfile"+ send = BS.appendFile outputFile+ hook = return ()++tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO ExitCode+tryReadSendFile siz off len hdrs = bracket setup teardown $ \buf -> do+ mapM_ (BS.appendFile expectedFile) hdrs+ copyfile inputFile expectedFile off len+ readSendFile buf siz send fid off len hook hdrs+ compareFiles expectedFile outputFile+ where+ hook = return ()+ setup = allocateBuffer siz+ teardown buf = do+ freeBuffer buf+ removeFileIfExists outputFile+ removeFileIfExists expectedFile+ inputFile = "test/inputFile"+ outputFile = "outputFile"+ expectedFile = "expectedFile"+ fid = FileId inputFile Nothing+ send = BS.appendFile outputFile++checkFile :: FilePath -> ByteString -> IO Bool+checkFile path bs = do+ exist <- doesFileExist path+ if exist+ then do+ bs' <- BS.readFile path+ return $ bs == bs'+ else return $ bs == ""++compareFiles :: FilePath -> FilePath -> IO ExitCode+compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2++copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO ()+copyfile src dst off len =+ IO.withBinaryFile src IO.ReadMode $ \h -> do+ IO.hSeek h IO.AbsoluteSeek off+ BS.hGet h (fromIntegral len) >>= BS.appendFile dst++removeFileIfExists :: FilePath -> IO ()+removeFileIfExists file = do+ exist <- doesFileExist file+ when exist $ removeFile file
+ test/ServerStateSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module ServerStateSpec where++import Network.Wai.Handler.Warp (getServerState)+import Network.Wai.Handler.Warp.Counter (increase)+import Network.Wai.Handler.Warp.Settings (+ ServerState (..),+ currentOpenConnections,+ currentShuttingDownState,+ defaultSettings,+ makeServerState,+ newServerState,+ )+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown)+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "ServerState" $ do+ it "has the correct initialization" $ do+ ss <- newServerState+ currentOpenConnections ss `shouldReturn` 0+ currentShuttingDownState ss `shouldReturn` False+ describe "makeServerState" $ do+ it "has the same state in settings" $ do+ (outerSS, set) <- makeServerState defaultSettings+ case getServerState set of+ Nothing -> expectationFailure "'makeServerState' should set the 'ServerState'"+ Just innerSS -> do+ let bothCount i = do+ a <- currentOpenConnections outerSS+ b <- currentOpenConnections innerSS+ (a, b) `shouldBe` (i, i)+ increase $ serverConnectionCounter outerSS+ bothCount 1+ increase $ serverConnectionCounter innerSS+ bothCount 2+ let bothDown bool = do+ a <- currentShuttingDownState outerSS+ b <- currentShuttingDownState innerSS+ (a, b) `shouldBe` (bool, bool)+ writeShuttingDown (serverShuttingDown outerSS) True+ bothDown True+ writeShuttingDown (serverShuttingDown innerSS) False+ bothDown False+ it "is idempotent" $ do+ let incAndCheck ss i = do+ increase $ serverConnectionCounter ss+ currentOpenConnections ss `shouldReturn` i+ (ss1, set1) <- makeServerState defaultSettings+ incAndCheck ss1 1+ (ss2, _set2) <- makeServerState set1+ incAndCheck ss2 2+ incAndCheck ss1 3
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/WithApplicationSpec.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}++module WithApplicationSpec where++import Control.Exception+import Network.HTTP.Types+import Network.Wai+import System.Environment+import System.Process+import Test.Hspec++import Network.Wai.Handler.Warp (defaultSettings, setOnException)+import Network.Wai.Handler.Warp.WithApplication++-- All these tests assume the "curl" process can be called directly.+spec :: Spec+spec = do+ runIO $ do+ unsetEnv "http_proxy"+ unsetEnv "https_proxy"+ describe "\"curl\" dependency" $+ let msg =+ "All \"WithApplication\" tests assume the \"curl\" process can be called directly."+ underline = replicate (length msg) '^'+ in it (msg ++ "\n " ++ underline) True+ describe "withApplication" $ do+ it "runs a wai Application while executing the given action" $ do+ let mkApp = return $ \_request respond -> respond $ responseLBS ok200 [] "foo"+ withApplication mkApp $ \port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldBe` "foo"++ it "does not propagate exceptions from the server to the executing thread" $ do+ let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"+ withApplicationSettings silentSettings mkApp $ \port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldContain` "Something went wrong"++ describe "testWithApplication" $ do+ it "propagates exceptions from the server to the executing thread" $ do+ let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"+ testWithApplicationSettings+ silentSettings+ mkApp+ ( \port -> do+ readProcess "curl" ["-s", "localhost:" ++ show port] ""+ )+ `shouldThrow` (errorCall "foo")+ where+ -- So that we don't muddy the test result screen.+ -- (normally, 'defaultSettings' use 'defaultOnException', sending to 'stderr')+ silentSettings = setOnException (\_ _ -> pure ()) defaultSettings
+ test/doctests.hs view
@@ -0,0 +1,4 @@+import Test.DocTest++main :: IO ()+main = doctest ["Network"]
+ test/head-response view
@@ -0,0 +1,1 @@+This is the body
+ test/inputFile view
@@ -0,0 +1,100 @@+A acid+abacus major+abacus pythagoricus+A battery+abbey counter+abbey laird+abbey lands+abbey lubber+abbot cloth+Abbott papyrus+abb wool+A-b-c book+A-b-c method+abdomino-uterotomy+Abdul-baha+a-be+aberrant duct+aberration constant+abiding place+able-bodied+able-bodiedness+able-minded+able-mindedness+able seaman+aboli fruit+A bond+Abor-miri+a-borning+about-face+about ship+about-sledge+above-cited+above-found+above-given+above-mentioned+above-named+above-quoted+above-reported+above-said+above-water+above-written+Abraham-man+abraum salts+abraxas stone+Abri audit culture+abruptly acuminate+abruptly pinnate+absciss layer+absence state+absentee voting+absent-minded+absent-mindedly+absent-mindedness+absent treatment+absent voter+Absent voting+absinthe green+absinthe oil+absorption bands+absorption circuit+absorption coefficient+absorption current+absorption dynamometer+absorption factor+absorption lines+absorption pipette+absorption screen+absorption spectrum+absorption system+A b station+abstinence theory+abstract group+Abt system+abundance declaree+aburachan seed+abutment arch+abutment pier+abutting joint+acacia veld+academy blue+academy board+academy figure+acajou balsam+acanthosis nigricans+acanthus family+acanthus leaf+acaroid resin+Acca larentia+acceleration note+accelerator nerve+accent mark+acceptance bill+acceptance house+acceptance supra protest+acceptor supra protest+accession book+accession number+accession service+access road+accident insurance
− test/main.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Network.Wai-import Network.Wai.Handler.Warp-import qualified Data.IORef as I-import Control.Monad.IO.Class (MonadIO, liftIO)-import Network.HTTP.Types-import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Monad (forM_)--import System.IO (hFlush)-import System.IO.Unsafe (unsafePerformIO)-import Data.ByteString (ByteString, hPutStr, hGetSome)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Network (connectTo, PortID (PortNumber))--import Test.Hspec.Monadic-import Test.Hspec.HUnit ()-import Test.HUnit--import Data.Conduit (($$))-import qualified Data.Conduit.List--type Counter = I.IORef (Either String Int)-type CounterApplication = Counter -> Application--incr :: MonadIO m => Counter -> m ()-incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->- ((case ecount of- Left s -> Left s- Right i -> Right $ i + 1), ())--err :: (MonadIO m, Show a) => Counter -> a -> m ()-err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg--readBody :: CounterApplication-readBody icount req = do- body <- requestBody req $$ Data.Conduit.List.consume- case () of- ()- | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"- -> err icount ("Invalid hello" :: String, body)- | requestMethod req == "GET" && L.fromChunks body /= ""- -> err icount ("Invalid GET" :: String, body)- | not $ requestMethod req `elem` ["GET", "POST"]- -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)- | otherwise -> incr icount- return $ responseLBS status200 [] "Read the body"--ignoreBody :: CounterApplication-ignoreBody icount req = do- if (requestMethod req `elem` ["GET", "POST"])- then incr icount- else err icount ("Invalid request method" :: String, requestMethod req)- return $ responseLBS status200 [] "Ignored the body"--doubleConnect :: CounterApplication-doubleConnect icount req = do- _ <- requestBody req $$ Data.Conduit.List.consume- _ <- requestBody req $$ Data.Conduit.List.consume- incr icount- return $ responseLBS status200 [] "double connect"--nextPort :: I.IORef Int-nextPort = unsafePerformIO $ I.newIORef 5000--getPort :: IO Int-getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p)--runTest :: Int -- ^ expected number of requests- -> CounterApplication- -> [ByteString] -- ^ chunks to send- -> IO ()-runTest expected app chunks = do- port <- getPort- ref <- I.newIORef (Right 0)- tid <- forkIO $ run port $ app ref- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle- _ <- hGetSome handle 4096- threadDelay 1000- killThread tid- res <- I.readIORef ref- case res of- Left s -> error s- Right i -> i @?= expected--singleGet :: ByteString-singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"--singlePostHello :: ByteString-singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"--main :: IO ()-main = hspecX $ do- describe "non-pipelining" $ do- it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet- it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet- it "has body, read" $ runTest 2 readBody- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody- [ singlePostHello- , singleGet- ]- describe "pipelining" $ do- it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]- it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]- it "has body, read" $ runTest 2 readBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- describe "no hanging" $ do- it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello- it "double connect" $ runTest 1 doubleConnect [singlePostHello]
warp.cabal view
@@ -1,65 +1,368 @@-Name: warp-Version: 1.1.0.1-Synopsis: A fast, light-weight web server for WAI applications.-License: BSD3-License-file: LICENSE-Author: Michael Snoyman, Matt Brown-Maintainer: michael@snoyman.com-Homepage: http://github.com/yesodweb/wai-Category: Web, Yesod-Build-Type: Simple-Cabal-Version: >=1.8-Stability: Stable-Description: The premier WAI handler. For more information, see <http://steve.vinoski.net/blog/2011/05/01/warp-a-haskell-web-server/>.-extra-source-files: test/main.hs+cabal-version: >=1.10+name: warp+version: 3.4.15+license: MIT+license-file: LICENSE+maintainer: michael@snoyman.com+author: Michael Snoyman, Kazu Yamamoto, Matt Brown+stability: Stable+homepage: https://github.com/yesodweb/wai+synopsis: A fast, light-weight web server for WAI applications.+description:+ HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.+ For HTTP\/2, Warp supports direct and ALPN (in TLS)+ but not upgrade.+ API docs and the README are available at+ <https://www.stackage.org/package/warp>. +category: Web, Yesod+build-type: Simple+extra-source-files:+ attic/hex+ ChangeLog.md+ README.md+ test/head-response+ test/inputFile++source-repository head+ type: git+ location: https://github.com/yesodweb/wai.git+ subdir: warp+ flag network-bytestring- Default: False+ default: False -Library- Build-Depends: base >= 3 && < 5- , bytestring >= 0.9.1.4 && < 0.10- , wai >= 1.1 && < 1.2- , transformers >= 0.2.2 && < 0.3- , conduit >= 0.2- , blaze-builder-conduit >= 0.2 && < 0.3- , lifted-base >= 0.1 && < 0.2- , blaze-builder >= 0.2.1.4 && < 0.4- , simple-sendfile >= 0.1 && < 0.3- , http-types >= 0.6 && < 0.7- , case-insensitive >= 0.2- , unix-compat >= 0.2- , bytestring-lexing >= 0.4- , ghc-prim- if flag(network-bytestring)- build-depends: network >= 2.2.1.5 && < 2.2.3- , network-bytestring >= 0.1.3 && < 0.1.4- else- build-depends: network >= 2.3 && < 2.4- Exposed-modules: Network.Wai.Handler.Warp- Other-modules: Timeout- Paths_warp- ghc-options: -Wall- if os(windows)- Cpp-options: -DWINDOWS+flag allow-sendfilefd+ description: Allow use of sendfileFd (not available on GNU/kFreeBSD) -test-suite test- main-is: main.hs- hs-source-dirs: test- type: exitcode-stdio-1.0+flag include-warp-version+ description:+ Exposes the version in Network.Wai.Handler.Warp.warpVersion.+ This adds a dependency on Paths_warp so application binaries may+ reference subpaths of GHC. For nix users this may result in binaries+ with a large transitive runtime dependency closure that includes GHC+ itself.+ default: True+ manual: True - ghc-options: -Wall- build-depends: base >= 4 && < 5- , HUnit- , hspec- , bytestring- , warp- , conduit- , network- , http-types- , transformers- , wai+flag warp-debug+ description: print debug output. not suitable for production+ default: False -source-repository head- type: git- location: git://github.com/yesodweb/wai.git+flag x509+ description:+ Adds a dependency on the x509 library to enable getting TLS client certificates.++library+ exposed-modules:+ Network.Wai.Handler.Warp+ Network.Wai.Handler.Warp.Internal++ other-modules:+ Network.Wai.Handler.Warp.Buffer+ Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Counter+ Network.Wai.Handler.Warp.Date+ Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File+ Network.Wai.Handler.Warp.FileInfoCache+ Network.Wai.Handler.Warp.HTTP1+ Network.Wai.Handler.Warp.HTTP2+ Network.Wai.Handler.Warp.HTTP2.File+ Network.Wai.Handler.Warp.HTTP2.PushPromise+ Network.Wai.Handler.Warp.HTTP2.Request+ Network.Wai.Handler.Warp.HTTP2.Response+ Network.Wai.Handler.Warp.HTTP2.Types+ Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IO+ Network.Wai.Handler.Warp.Imports+ Network.Wai.Handler.Warp.PackInt+ Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Response+ Network.Wai.Handler.Warp.ResponseHeader+ Network.Wai.Handler.Warp.Run+ Network.Wai.Handler.Warp.SendFile+ Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown+ Network.Wai.Handler.Warp.Types+ Network.Wai.Handler.Warp.Windows+ Network.Wai.Handler.Warp.WithApplication++ if flag(include-warp-version)+ other-modules: Paths_warp++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.12 && <5,+ auto-update >=0.2.2 && <0.3,+ async >= 2,+ bsb-http-chunked <0.1,+ bytestring >=0.9.1.4,+ case-insensitive >=0.2,+ containers,+ hashable,+ http-date,+ http-types >=0.12 && <1,+ http-semantics >=0.4 && <0.5,+ http2 >=5.4 && <5.5,+ iproute >=1.3.1,+ recv >=0.1.0 && <0.2.0,+ simple-sendfile >=0.2.7 && <0.3,+ stm >=2.3,+ streaming-commons >=0.1.10,+ text,+ time-manager >=0.2 && <0.4,+ vault >=0.3,+ wai >=3.2.5 && <3.3,+ word8++ if flag(x509)+ build-depends: crypton-x509++ if impl(ghc <8)+ build-depends: semigroups++ if flag(network-bytestring)+ build-depends:+ network >=2.2.1.5 && <2.2.3,+ network-bytestring >=0.1.3 && <0.1.4++ else+ build-depends: network >=2.3++ if flag(warp-debug)+ cpp-options: -DWARP_DEBUG++ if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd))+ cpp-options: -DSENDFILEFD++ if os(windows)+ cpp-options: -DWINDOWS+ build-depends:+ time,+ unix-compat >=0.2++ else+ other-modules: Network.Wai.Handler.Warp.MultiMap+ build-depends: unix++ if impl(ghc >=8)+ default-extensions: Strict StrictData++ if flag(include-warp-version)+ cpp-options: -DINCLUDE_WARP_VERSION++test-suite doctest+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ buildable: False+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -threaded -Wall+ build-depends:+ base >=4.8 && <5,+ doctest >=0.10.1++ if os(windows)+ buildable: False++ if impl(ghc >=8)+ default-extensions: Strict StrictData++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test .+ other-modules:+ BufferSpec+ ConduitSpec+ ConnectionSpec+ EarlyHintsSpec+ ExceptionSpec+ FdCacheSpec+ FileSpec+ GracefulShutdownSpec+ HTTP+ PackIntSpec+ ReadIntSpec+ RequestSpec+ ResponseHeaderSpec+ ResponseSpec+ RunSpec+ SendFileSpec+ ServerStateSpec+ WithApplicationSpec+ Network.Wai.Handler.Warp+ Network.Wai.Handler.Warp.Internal+ Network.Wai.Handler.Warp.Buffer+ Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Counter+ Network.Wai.Handler.Warp.Date+ Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File+ Network.Wai.Handler.Warp.FileInfoCache+ Network.Wai.Handler.Warp.HTTP1+ Network.Wai.Handler.Warp.HTTP2+ Network.Wai.Handler.Warp.HTTP2.File+ Network.Wai.Handler.Warp.HTTP2.PushPromise+ Network.Wai.Handler.Warp.HTTP2.Request+ Network.Wai.Handler.Warp.HTTP2.Response+ Network.Wai.Handler.Warp.HTTP2.Types+ Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IO+ Network.Wai.Handler.Warp.Imports+ Network.Wai.Handler.Warp.PackInt+ Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Response+ Network.Wai.Handler.Warp.ResponseHeader+ Network.Wai.Handler.Warp.Run+ Network.Wai.Handler.Warp.SendFile+ Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown+ Network.Wai.Handler.Warp.Types+ Network.Wai.Handler.Warp.Windows+ Network.Wai.Handler.Warp.WithApplication++ if flag(include-warp-version)+ other-modules: Paths_warp++ default-language: Haskell2010+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.8 && <5,+ QuickCheck,+ auto-update,+ async,+ bsb-http-chunked <0.1,+ bytestring >=0.9.1.4,+ case-insensitive >=0.2,+ containers,+ directory,+ hashable,+ hspec >=1.3,+ http-client,+ http-date,+ http-types >=0.12,+ http-semantics >=0.4 && <0.5,+ http2 >=5.4 && <5.5,+ iproute >=1.3.1,+ network,+ process,+ recv >=0.1.0 && <0.2.0,+ simple-sendfile >=0.2.4 && <0.3,+ stm >=2.3,+ streaming-commons >=0.1.10,+ text,+ time-manager,+ vault,+ wai >=3.2.5 && <3.3,+ -- workaround: this should be unnecessary+ warp,+ word8++ if flag(x509)+ build-depends: crypton-x509++ if impl(ghc <8)+ build-depends:+ semigroups,+ transformers++ if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd))+ cpp-options: -DSENDFILEFD++ if os(windows)+ cpp-options: -DWINDOWS+ build-depends:+ time,+ unix-compat >=0.2++ else+ other-modules: Network.Wai.Handler.Warp.MultiMap+ build-depends: unix++ if impl(ghc >=8)+ default-extensions: Strict StrictData++benchmark parser+ type: exitcode-stdio-1.0+ main-is: Parser.hs+ hs-source-dirs: bench .+ other-modules:+ Network.Wai.Handler.Warp.Buffer+ Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Counter+ Network.Wai.Handler.Warp.Date+ Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File+ Network.Wai.Handler.Warp.FileInfoCache+ Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IO+ Network.Wai.Handler.Warp.Imports+ Network.Wai.Handler.Warp.MultiMap+ Network.Wai.Handler.Warp.PackInt+ Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Response+ Network.Wai.Handler.Warp.ResponseHeader+ Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown+ Network.Wai.Handler.Warp.Types++ if flag(include-warp-version)+ other-modules: Paths_warp++ default-language: Haskell2010+ build-depends:+ base >=4.8 && <5,+ async,+ auto-update,+ bsb-http-chunked,+ bytestring,+ case-insensitive,+ containers,+ criterion,+ hashable,+ http-date,+ http-types,+ http2,+ iproute,+ network,+ recv,+ simple-sendfile,+ stm,+ streaming-commons,+ text,+ time-manager,+ vault,+ wai,+ word8++ if flag(x509)+ build-depends: crypton-x509++ if impl(ghc <8)+ build-depends: semigroups++ if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd))+ cpp-options: -DSENDFILEFD+ build-depends: unix++ if os(windows)+ cpp-options: -DWINDOWS+ build-depends:+ time,+ unix-compat >=0.2++ if impl(ghc >=8)+ default-extensions: Strict StrictData