warp 1.3.10.2 → 3.4.14

raw patch · 58 files changed

Files

• ChangeLog.md +624/−0
• Network/Wai/Handler/Warp.hs +595/−57
• Network/Wai/Handler/Warp/Buffer.hs +59/−0
• Network/Wai/Handler/Warp/Conduit.hs +132/−120
• Network/Wai/Handler/Warp/Counter.hs +58/−0
• Network/Wai/Handler/Warp/Date.hs +49/−0
• Network/Wai/Handler/Warp/FdCache.hs +110/−84
• Network/Wai/Handler/Warp/File.hs +200/−0
• Network/Wai/Handler/Warp/FileInfoCache.hs +122/−0
• Network/Wai/Handler/Warp/HTTP1.hs +306/−0
• Network/Wai/Handler/Warp/HTTP2.hs +158/−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 +50/−0
• Network/Wai/Handler/Warp/Imports.hs +39/−0
• Network/Wai/Handler/Warp/Internal.hs +131/−0
• Network/Wai/Handler/Warp/MultiMap.hs +60/−205
• Network/Wai/Handler/Warp/PackInt.hs +47/−0
• Network/Wai/Handler/Warp/ReadInt.hs +13/−45
• Network/Wai/Handler/Warp/Request.hs +310/−211
• Network/Wai/Handler/Warp/RequestHeader.hs +138/−0
• Network/Wai/Handler/Warp/Response.hs +452/−182
• Network/Wai/Handler/Warp/ResponseHeader.hs +21/−40
• Network/Wai/Handler/Warp/Run.hs +478/−248
• Network/Wai/Handler/Warp/SendFile.hs +156/−0
• Network/Wai/Handler/Warp/Settings.hs +436/−69
• Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
• Network/Wai/Handler/Warp/Timeout.hs +0/−171
• Network/Wai/Handler/Warp/Types.hs +183/−61
• Network/Wai/Handler/Warp/Windows.hs +30/−0
• Network/Wai/Handler/Warp/WithApplication.hs +107/−0
• README.md +3/−0
• bench/Parser.hs +284/−0
• test/ConduitSpec.hs +69/−0
• test/ConnectionSpec.hs +74/−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 +117/−0
• test/RunSpec.hs +518/−0
• test/SendFileSpec.hs +120/−0
• test/ServerStateSpec.hs +58/−0
• test/WithApplicationSpec.hs +46/−0
• test/doctests.hs +4/−0
• test/head-response +1/−0
• test/inputFile +100/−0
• warp.cabal +349/−107

@@ -0,0 +1,624 @@+# ChangeLog for warp++## 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.

@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}  --------------------------------------------------------- --@@ -15,68 +18,603 @@ ---------------------------------------------------------  -- | 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-    run-  , runSettings-  , runSettingsSocket++    -- | All of these automatically serve the same 'Application' over HTTP\/1,+    -- HTTP\/1.1, and HTTP\/2.+    run,+    runEnv,+    runSettings,+    runSettingsSocket,+     -- * Settings-  , Settings-  , defaultSettings-  , settingsPort-  , settingsHost-  , settingsOnException-  , settingsOnOpen-  , settingsOnClose-  , settingsTimeout-  , settingsIntercept-  , settingsManager-  , settingsFdCacheDuration-  , settingsResourceTPerRequest-  , settingsBeforeMainLoop-  , settingsServerName-    -- ** Data types-  , HostPreference (..)-    -- * Connection-  , Connection (..)-  , runSettingsConnection-  , runSettingsConnectionMaker-    -- * Datatypes-  , Port-  , InvalidRequest (..)-    -- * Internal-    -- ** Time out manager-  , Manager-  , Handle-  , TimeoutAction-  , initialize-  , withManager-  , register-  , registerKillThread-  , tickle-  , cancel-  , resume-  , pause-    -- ** Cleaner-  , Cleaner-  , dummyCleaner-    -- ** Request and response-  , parseRequest-  , sendResponse-  , socketConnection-#if TEST-  , takeHeaders-  , parseFirst-  , readInt+    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-    -- ** Version-  , warpVersion-  ) where+    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.Response import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings-import Network.Wai.Handler.Warp.Types-import Network.Wai.Handler.Warp.Timeout-import Data.Conduit.Network (HostPreference(..))+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

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

@@ -1,160 +1,172 @@+{-# LANGUAGE CPP #-}+ module Network.Wai.Handler.Warp.Conduit where -import Control.Applicative-import Control.Exception-import Control.Monad (unless)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Data.ByteString (ByteString)-import Data.ByteString.Lazy.Char8 (pack)+import Control.Exception (assert, throwIO) import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Conduit-import qualified Data.Conduit.Binary as CB-import Data.Conduit.Internal (ResumableSource (..))-import qualified Data.Conduit.List as CL import qualified Data.IORef as I-import Data.Word (Word, Word8)+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.-newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource (ResourceT IO) ByteString))+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.-ibsIsolate :: IsolatedBSSource -> Source (ResourceT IO) ByteString-ibsIsolate ibs@(IsolatedBSSource ref) = do-    (count, src) <- liftIO $ I.readIORef ref-    unless (count == 0) $ do-        -- Get the next chunk (if available) and the updated source-        (src', mbs) <- lift $ src $$++ CL.head+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-        bs <- maybe (liftIO $ throwIO ConnectionClosedByPeer) return mbs+            -- 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-        case () of-            ()-                -- The expected count is greater than the size of the+            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.-                | count' > 0 -> do-                    liftIO $ I.writeIORef ref (count', src')-                    yield bs-                    ibsIsolate ibs--                -- The expected count is the total size of the chunk we-                -- just read. Send this chunk downstream, and then-                -- terminate the stream.-                | count == S.length bs -> do-                    liftIO $ I.writeIORef ref (count', src')-                    yield bs--                -- 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.-                | otherwise -> do+                    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-                    liftIO $ I.writeIORef ref (count', fmapResume (yield y >>) src')-                    yield x---- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not--- perform any more isolation.-ibsDone :: IsolatedBSSource -> IO (ResumableSource (ResourceT IO) ByteString)-ibsDone (IsolatedBSSource ref) = snd <$> I.readIORef ref+                    leftoverSource src y+                    assert (count' == 0) $ return x  ---------------------------------------------------------------- -data ChunkState = NeedLen-                | NeedLenNewline-                | HaveLen Word+data CSource = CSource !Source !(I.IORef ChunkState) -bsCRLF :: L.ByteString-bsCRLF = pack "\r\n"+data ChunkState+    = NeedLen+    | NeedLenNewline+    | HaveLen Word+    | DoneChunking+    deriving (Show) -chunkedSource :: MonadIO m-              => I.IORef (ResumableSource m ByteString, ChunkState)-              -> Source m ByteString-chunkedSource ipair = do-    (src, mlen) <- liftIO $ I.readIORef ipair-    go src mlen+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-    go' src front = do-        (src', (len, bs)) <- lift $ src $$++ front getLen-        let src''-                | S.null bs = src'-                | otherwise = fmapResume (yield bs >>) src'-        go src'' $ HaveLen len+    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 -    go src NeedLen = go' src id-    go src NeedLenNewline = go' src (CB.take 2 >>)-    go src (HaveLen 0) = do-        -- Drop the final CRLF-        (src', ()) <- lift $ src $$++ do-            crlf <- CB.take 2-            unless (crlf == bsCRLF) $ leftover $ S.concat $ L.toChunks crlf-        liftIO $ I.writeIORef ipair (src', HaveLen 0)-    go src (HaveLen len) = do-        (src', mbs) <- lift $ src $$++ CL.head-        case mbs of-            Nothing -> liftIO $ I.writeIORef ipair (src', HaveLen 0)-            Just bs ->-                case S.length bs `compare` fromIntegral len of-                    EQ -> yield' src' NeedLenNewline bs-                    LT -> do-                        let mlen = HaveLen $ len - fromIntegral (S.length bs)-                        yield' src' mlen bs-                    GT -> do-                        let (x, y) = S.splitAt (fromIntegral len) bs-                        let src'' = fmapResume (yield y >>) src'-                        yield' src'' NeedLenNewline x+    yield' bs mlen = do+        I.writeIORef ref mlen+        return bs -    yield' src mlen bs = do-        liftIO $ I.writeIORef ipair (src, mlen)-        yield bs-        go src mlen+    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 -    getLen :: Monad m => Sink ByteString m (Word, ByteString)+    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-        mbs <- CL.head-        case mbs of-            Nothing -> return (0, S.empty)-            Just bs -> 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.breakByte 10 bs of+                    case S.break (== _lf) bs of                         (x, y)                             | S.null y -> do-                                mbs2 <- CL.head-                                case mbs2 of-                                    Nothing -> return (x, y)-                                    Just bs2 -> return $ S.breakByte 10 $ bs `S.append` bs2+                                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-                return (w, S.drop 1 y)+                        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 < 58 = w - 48-        | w < 71 = w - 55+        | w <= _9 = w - _0+        | w <= _F = w - 55         | otherwise = w - 87  isHexDigit :: Word8 -> Bool-isHexDigit w = w >= 48 && w <= 57-            || w >= 65 && w <= 70-            || w >= 97 && w <= 102--------------------------------------------------------------------fmapResume :: (Source m o1 -> Source m o2) -> ResumableSource m o1 -> ResumableSource m o2-fmapResume f (ResumableSource src m) = ResumableSource (f src) m+isHexDigit w =+    w >= _0 && w <= _9+        || w >= _A && w <= _F+        || w >= _a && w <= _f

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

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

@@ -1,28 +1,64 @@-{-# LANGUAGE BangPatterns, FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} +-- | File descriptor cache to avoid locks in kernel. module Network.Wai.Handler.Warp.FdCache (-    initialize-  , getFd-  , MutableFdCache-  ) where+    withFdCache,+    Fd,+    Refresh,+#ifndef WINDOWS+    closeFile,+    openFile,+    setFileCloseOnExec,+#endif+) where -import Control.Applicative ((<$>), (<*>))-import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)-import Control.Exception (mask_)-import Data.Hashable (hash)-import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef, mkWeakIORef)-import Network.Wai.Handler.Warp.MultiMap-import System.Posix.IO (openFd, defaultFileFlags, OpenMode(ReadOnly), closeFd)+#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) -type Refresh = IO ()- status :: MutableStatus -> IO Status status (MutableStatus ref) = readIORef ref @@ -37,96 +73,86 @@  ---------------------------------------------------------------- -data FdEntry = FdEntry !FilePath !Fd !MutableStatus+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 path-              <$> openFd path ReadOnly Nothing defaultFileFlags-              <*> newActiveStatus+newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus +setFileCloseOnExec :: Fd -> IO ()+setFileCloseOnExec fd = setFdOption fd CloseOnExec True+ ---------------------------------------------------------------- -type Hash = Int-type FdCache = MMap Hash FdEntry-newtype MutableFdCache = MutableFdCache { unMutableFdCache :: IORef FdCache }+type FdCache = MultiMap FdEntry -newMutableFdCache :: IO MutableFdCache-newMutableFdCache = MutableFdCache <$> newIORef empty+-- | Mutable Fd cacher.+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath, FdEntry))  fdCache :: MutableFdCache -> IO FdCache-fdCache (MutableFdCache ref) = readIORef ref--swapWithNew :: MutableFdCache -> IO FdCache-swapWithNew (MutableFdCache ref) = atomicModifyIORef ref (\t -> (empty, t))--update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()-update (MutableFdCache ref) f = do-    !_  <- atomicModifyIORef ref $ \t -> let !new = f t in (new, ())-    return ()+fdCache (MutableFdCache reaper) = reaperRead reaper -look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)-look mfc path key = searchWith key check <$> fdCache mfc-  where-    check (One ent@(FdEntry path' _ _))-      | path == path' = Just ent-      | otherwise     = Nothing-    check (Tom ent@(FdEntry path' _ _) vs)-      | path == path' = Just ent-      | otherwise     = check vs+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 = do-    mfc <- newMutableFdCache-    tid <- forkIO $ loop mfc-    -- Registering finalizer to this IORef.-    -- When Warp is finished in GHCi, this IORef is GCed.-    -- At that time, we should close all opened file descriptors.-    _ <- mkWeakIORef (unMutableFdCache mfc) $ terminate mfc tid-    return mfc+initialize duration = MutableFdCache <$> mkReaper settings   where-    loop mfc = do-        mask_ $ do-            old <- swapWithNew mfc-            new <- pruneWith old prune-            update mfc (merge new)-        threadDelay duration-        loop mfc+    settings =+        defaultReaperSettings+            { reaperAction = clean+            , reaperDelay = duration+            , reaperCons = uncurry insert+            , reaperNull = isEmpty+            , reaperEmpty = empty+            , reaperThreadName = "Fd cacher (Reaper) "+            } -terminate :: MutableFdCache -> ThreadId -> IO ()-terminate (MutableFdCache icache) tid = do-    killThread tid-    readIORef icache >>= mapM_ go . toList+clean :: FdCache -> IO (FdCache -> FdCache)+clean old = do+    new <- pruneWith old prune+    return $ merge new   where-    go (_, FdEntry _ fd _) = closeFd fd+    prune (_, FdEntry fd mst) = status mst >>= act+      where+        act Active = inactive mst >> return True+        act Inactive = closeFd fd >> return False -prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]-prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'-  where-    prune' Active   = inactive mst >> return [(k,v)]-    prune' Inactive = closeFd fd   >> return []-prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'+----------------------------------------------------------------++terminate :: MutableFdCache -> IO ()+terminate (MutableFdCache reaper) = do+    !t <- reaperStop reaper+    mapM_ (closeIt . snd) $ toList t   where-    prune' Active = do-        inactive mst-        zs <- prune k vs-        case zs of-            []        -> return [(k,One ent)]-            [(_,zvs)] -> return [(k,Tom ent zvs)]-            _         -> error "prune"-    prune' Inactive = closeFd fd >> prune k vs+    closeIt (FdEntry fd _) = closeFd fd  ---------------------------------------------------------------- -getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)-getFd mfc path = look mfc path key >>= getFd'+-- | 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-    key = hash path-    getFd' Nothing = do-        ent@(FdEntry _ fd mst) <- newFdEntry path-        update mfc (insert key ent)-        return (fd, refresh mst)-    getFd' (Just (FdEntry _ fd mst)) = do+    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 (fd, refresh mst)+        return (Just fd, refresh mst)+#endif

@@ -0,0 +1,200 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.File (+    RspFileInfo (..),+    conditionalRequest,+    addContentHeadersForFilePart,+    H.parseByteRanges,+) where++import Data.Array ((!))+import qualified Data.ByteString.Char8 as C8 (pack)+import Network.HTTP.Date+import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as H+import Network.Wai++import qualified Network.Wai.Handler.Warp.FileInfoCache as I+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.PackInt++----------------------------------------------------------------++data RspFileInfo+    = WithoutBody H.Status+    | WithBody H.Status H.ResponseHeaders Integer Integer+    deriving (Eq, Show)++----------------------------------------------------------------++conditionalRequest+    :: I.FileInfo+    -> H.ResponseHeaders+    -> H.Method+    -> IndexedHeader+    -- ^ Response+    -> IndexedHeader+    -- ^ Request+    -> 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 = case rspidx ! fromEnum ResLastModified of+                Just _ -> hs1+                Nothing -> (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 :: IndexedHeader -> Maybe HTTPDate+ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate++ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate+ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate++ifRange :: IndexedHeader -> Maybe HTTPDate+ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate++----------------------------------------------------------------++ifmodified :: IndexedHeader -> 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 $ reqidx ! fromEnum ReqIfNoneMatch+    -- "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 :: IndexedHeader -> 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 $ reqidx ! fromEnum ReqIfMatch+    guard $ date /= mtime && date < mtime+    Just $ WithoutBody H.preconditionFailed412++-- TODO: Should technically also strongly match on ETags.+ifrange :: IndexedHeader -> 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 <- reqidx ! fromEnum ReqRange+    guard $ method == H.methodGet+    return $+        if date == mtime+            then parseRange rng size+            else WithBody H.ok200 [] 0 size++unconditional :: IndexedHeader -> Integer -> RspFileInfo+unconditional reqidx =+    case reqidx ! fromEnum ReqRange 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 = (H.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' = (H.hContentLength, lengthBS) : (H.hAcceptRanges, "bytes") : 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

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

@@ -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)+    -> IndexedHeader+    -> 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

@@ -0,0 +1,158 @@+{-# LANGUAGE BangPatterns #-}+{-# 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++----------------------------------------------------------------++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)+    req <- toWAIRequest h2req0 aux0+    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.ErrorCodeId -> 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

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

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

@@ -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 = getHeaderValue tokenPath reqvt -- SHOULD+    !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST+    !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD+    !mHost = getHeaderValue tokenHost reqvt+    !mRange = getHeaderValue tokenRange reqvt+    !mReferer = getHeaderValue tokenReferer reqvt+    !mUserAgent = getHeaderValue 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

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

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

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

@@ -0,0 +1,122 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.Header where++import Data.Array+import Data.Array.ST+import qualified Data.ByteString as BS+import Data.CaseInsensitive (foldedCase)+import Network.HTTP.Types++import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++-- | Array for a set of HTTP headers.+type IndexedHeader = Array Int (Maybe HeaderValue)++----------------------------------------------------------------++indexRequestHeader :: RequestHeaders -> IndexedHeader+indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex++data RequestHeaderIndex+    = ReqContentLength+    | ReqTransferEncoding+    | ReqExpect+    | ReqConnection+    | ReqRange+    | ReqHost+    | ReqIfModifiedSince+    | ReqIfUnmodifiedSince+    | ReqIfRange+    | ReqReferer+    | ReqUserAgent+    | ReqIfMatch+    | ReqIfNoneMatch+    deriving (Enum, Bounded)++-- | The size for 'IndexedHeader' for HTTP Request.+--   From 0 to this corresponds to:+--+-- - \"Content-Length\"+-- - \"Transfer-Encoding\"+-- - \"Expect\"+-- - \"Connection\"+-- - \"Range\"+-- - \"Host\"+-- - \"If-Modified-Since\"+-- - \"If-Unmodified-Since\"+-- - \"If-Range\"+-- - \"Referer\"+-- - \"User-Agent\"+-- - \"If-Match\"+-- - \"If-None-Match\"+requestMaxIndex :: Int+requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex)++requestKeyIndex :: HeaderName -> Int+requestKeyIndex hn = case BS.length bs of+    4 | bs == "host" -> fromEnum ReqHost+    5 | bs == "range" -> fromEnum ReqRange+    6 | bs == "expect" -> fromEnum ReqExpect+    7 | bs == "referer" -> fromEnum ReqReferer+    8+        | bs == "if-range" -> fromEnum ReqIfRange+        | bs == "if-match" -> fromEnum ReqIfMatch+    10+        | bs == "user-agent" -> fromEnum ReqUserAgent+        | bs == "connection" -> fromEnum ReqConnection+    13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch+    14 | bs == "content-length" -> fromEnum ReqContentLength+    17+        | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding+        | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince+    19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince+    _ -> -1+  where+    bs = foldedCase hn++defaultIndexRequestHeader :: IndexedHeader+defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0 .. requestMaxIndex]]++----------------------------------------------------------------++indexResponseHeader :: ResponseHeaders -> IndexedHeader+indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex++data ResponseHeaderIndex+    = ResContentLength+    | ResServer+    | ResDate+    | ResLastModified+    deriving (Enum, Bounded)++-- | The size for 'IndexedHeader' for HTTP Response.+responseMaxIndex :: Int+responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex)++responseKeyIndex :: HeaderName -> Int+responseKeyIndex hn = case BS.length bs of+    4 | bs == "date" -> fromEnum ResDate+    6 | bs == "server" -> fromEnum ResServer+    13 | bs == "last-modified" -> fromEnum ResLastModified+    14 | bs == "content-length" -> fromEnum ResContentLength+    _ -> -1+  where+    bs = foldedCase hn++----------------------------------------------------------------++traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader+traverseHeader hdr maxidx getIndex = runSTArray $ do+    arr <- newArray (0, maxidx) Nothing+    mapM_ (insert arr) hdr+    return arr+  where+    insert arr (key, val)+        | idx == -1 = return ()+        | otherwise = writeArray arr idx (Just val)+      where+        idx = getIndex key

@@ -0,0 +1,50 @@+module Network.Wai.Handler.Warp.IO where++import Control.Exception (mask_)+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

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

@@ -0,0 +1,131 @@+{-# 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+    InternalInfo (..),+    HeaderValue,+    IndexedHeader,+    requestMaxIndex,++    -- * 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

@@ -1,236 +1,91 @@ module Network.Wai.Handler.Warp.MultiMap (-    MMap-  , Some(..)-  , empty-  , singleton-  , insert-  , search-  , searchWith-  , isEmpty-  , valid-  , pruneWith-  , fromList-  , toList-  , fromSortedList-  , toSortedList-  , merge-  ) where--import Control.Applicative ((<$>))-import Data.List (foldl')---------------------------------------------------------------------- | One ore more list to implement multimap.-data Some a = One !a-            | Tom !a !(Some a) -- Two or more-            deriving (Eq,Show)---- This is slow but assuming rarely used.-snoc :: Some a -> a -> Some a-snoc (One x) y    = Tom x (One y)-snoc (Tom x xs) y = Tom x (snoc xs y)--top :: Some a -> a-top (One x)   = x-top (Tom x _) = x---------------------------------------------------------------------- | Red black tree as multimap.-data MMap k v = Leaf -- color is Black-              | Node Color !(MMap k v) !k !(Some v) !(MMap k v)-              deriving (Show)--data Color = B -- ^ Black-           | R -- ^ Red-           deriving (Eq, Show)------------------------------------------------------------------+    MultiMap,+    isEmpty,+    empty,+    singleton,+    insert,+    Network.Wai.Handler.Warp.MultiMap.lookup,+    pruneWith,+    toList,+    merge,+) where -instance (Eq k, Eq v) => Eq (MMap k v) where-    t1 == t2 = toSortedList t1 == toSortedList t2+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  ---------------------------------------------------------------- --- | O(log N)-search :: Ord k => k -> MMap k v -> Maybe v-search _ Leaf = Nothing-search xk (Node _ l k v r) = case compare xk k of-    LT -> search xk l-    GT -> search xk r-    EQ -> Just $ top v---- | O(log N)-searchWith :: Ord k => k -> (Some v -> Maybe v) -> MMap k v -> Maybe v-searchWith _ _ Leaf = Nothing-searchWith xk f (Node _ l k v r) = case compare xk k of-    LT -> searchWith xk f l-    GT -> searchWith xk f r-    EQ -> f v+-- | '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)-isEmpty :: (Eq k, Eq v) => MMap k v -> Bool-isEmpty Leaf = True-isEmpty _    = False+empty :: MultiMap v+empty = MultiMap I.empty  -- | O(1)-empty :: MMap k v-empty = Leaf+isEmpty :: MultiMap v -> Bool+isEmpty (MultiMap mm) = I.null mm  ----------------------------------------------------------------  -- | O(1)-singleton :: Ord k => k -> v -> MMap k v-singleton k v = Node B Leaf k (One v) Leaf---------------------------------------------------------------------- | O(log N)-insert :: Ord k => k -> v -> MMap k v -> MMap k v-insert kx kv t = turnB (insert' kx kv t)--insert' :: Ord k => k -> v -> MMap k v -> MMap k v-insert' xk xv Leaf = Node R Leaf xk (One xv) Leaf-insert' xk xv (Node B l k v r) = case compare xk k of-    LT -> balanceL' (insert' xk xv l) k v r-    GT -> balanceR' l k v (insert' xk xv r)-    EQ -> Node B l k (snoc v xv) r-insert' xk xv (Node R l k v r) = case compare xk k of-    LT -> Node R (insert' xk xv l) k v r-    GT -> Node R l k v (insert' xk xv r)-    EQ -> Node R l k (snoc v xv) r--balanceL' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v-balanceL' (Node R (Node R a xk xv b) yk yv c) zk zv d =-    Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceL' (Node R a xk xv (Node R b yk yv c)) zk zv d =-    Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceL' l k v r = Node B l k v r--balanceR' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v-balanceR' a xk xv (Node R b yk yv (Node R c zk zv d)) =-    Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceR' a xk xv (Node R (Node R b yk yv c) zk zv d) =-    Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceR' l xk xv r = Node B l xk xv r--turnB :: MMap k v -> MMap k v-turnB Leaf             = error "turnB"-turnB (Node _ l k v r) = Node B l k v r+singleton :: FilePath -> v -> MultiMap v+singleton path v = MultiMap $ I.singleton (hash path) [(path, v)]  ---------------------------------------------------------------- --- | O(N log N)-fromList :: Ord k => [(k,v)] -> MMap k v-fromList = foldl' (\t (k,v) -> insert k v t) empty---- | O(N)-toList :: MMap k v -> [(k,v)]-toList t = inorder t []-  where-    inorder Leaf xs = xs-    inorder (Node _ l k v r) xs = inorder l (pairs k v ++ inorder r xs)-    pairs k (One v) = [(k,v)]-    pairs k (Tom v vs) = (k,v) : pairs k vs+-- | 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(N)--- "Constructing Red-Black Trees" by Ralf Hinze-fromSortedList :: Ord k => [(k,Some v)] -> MMap k v-fromSortedList = linkAll . foldr add []--data Digit k v = Uno k (Some v) (MMap k v)-               | Due k (Some v) (MMap k v) k (Some v) (MMap k v)-               deriving (Eq,Show)--incr :: Digit k v -> [Digit k v] -> [Digit k v]-incr (Uno k v t) [] = [Uno k v t]-incr (Uno k1 v1 t1) (Uno k2 v2 t2 : ps) = Due k1 v1 t1 k2 v2 t2 : ps-incr (Uno k1 v1 t1) (Due k2 v2 t2 k3 v3 t3 : ps) = Uno k1 v1 t1 : incr (Uno k2 v2 (Node B t2 k3 v3 t3)) ps-incr _ _ = error "incr"--add :: (k,Some v) -> [Digit k v] -> [Digit k v]-add (k,v) ps = incr (Uno k v Leaf) ps--linkAll :: [Digit k v] -> MMap k v-linkAll = foldl' link Leaf--link :: MMap k v -> Digit k v -> MMap k v-link l (Uno k v t) = Node B l k v t---link l (Due k1 v1 t1 k2 v2 t2) = Node B (Node R l k1 v1 t1) k2 v2 t2-link l (Due k1 v1 t1 k2 v2 t2) = Node B l k1 v1 (Node R t1 k2 v2 t2)+-- | 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)-toSortedList :: MMap k v -> [(k,Some v)]-toSortedList t = inorder t []-  where-    inorder Leaf xs = xs-    inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs)+-- | O(n)+toList :: MultiMap v -> [(FilePath, v)]+toList (MultiMap mm) = concatMap snd $ I.toAscList mm  ---------------------------------------------------------------- --- | O(N)-pruneWith :: Ord k =>-             MMap k v-          -> (k -> Some v -> IO [(k, Some v)])-          -> IO (MMap k v)-pruneWith t run = fromSortedList <$> inorder t []+-- | 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-    inorder Leaf xs = return xs-    inorder (Node _ l k v r) xs = do-        ys <- run k v-        zs <- inorder r xs-        inorder l (ys ++ zs)+    go h s cont acc = do+        rs <- filterM action s+        case rs of+            [] -> cont acc+            _ -> cont $! I.insert h rs acc  ---------------------------------------------------------------- --- O(N log N) where N is the size of the second argument-merge :: Ord k => MMap k v -> MMap k v -> MMap k v-merge base m = foldl' ins base xs-  where-    ins t (k,v) = insert k v t-    xs = toList m--------------------------------------------------------------------- for testing--valid :: Ord k => MMap k v -> Bool-valid t = isBalanced t && isOrdered t--isBalanced :: MMap k v -> Bool-isBalanced t = isBlackSame t && isRedSeparate t--isBlackSame :: MMap k v -> Bool-isBlackSame t = all (n==) ns-  where-    n:ns = blacks t--blacks :: MMap k v -> [Int]-blacks = blacks' 0-  where-    blacks' n Leaf = [n+1]-    blacks' n (Node R l _ _ r) = blacks' n  l ++ blacks' n  r-    blacks' n (Node B l _ _ r) = blacks' n' l ++ blacks' n' r-      where-        n' = n + 1--isRedSeparate :: MMap k v -> Bool-isRedSeparate = reds B--reds :: Color -> MMap k v -> Bool-reds _ Leaf = True-reds R (Node R _ _ _ _) = False-reds _ (Node c l _ _ r) = reds c l && reds c r--isOrdered :: Ord k => MMap k v -> Bool-isOrdered t = ordered $ toSortedList t-  where-    ordered [] = True-    ordered [_] = True-    ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)+-- 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

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

@@ -1,26 +1,22 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}  -- Copyright     : Erik de Castro Lopo <erikd@mega-nerd.com> -- License       : BSD3  module Network.Wai.Handler.Warp.ReadInt (-    readInt-  , readInt64-  ) where---- This function lives in its own file because the MagicHash pragma interacts--- poorly with the CPP pragma.+    readInt,+    readInt64,+) where -import Data.ByteString (ByteString) import qualified Data.ByteString as S-import Data.Int (Int64)-import GHC.Prim-import GHC.Types-import GHC.Word+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 @@ -32,36 +28,8 @@ -- use Int64 here and then make a generic 'readInt' that allows conversion to -- Int and Integer. -{- NOINLINE readInt64MH #-}+{-# NOINLINE readInt64 #-} readInt64 :: ByteString -> Int64-readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (mhDigitToInt c)) 0-             $ S.takeWhile isDigit bs--data Table = Table !Addr#--{- NOINLINE mhDigitToInt #-}-mhDigitToInt :: Word8 -> Int-mhDigitToInt (W8# i) = I# (word2Int# (indexWord8OffAddr# addr (word2Int# i)))-  where-    !(Table addr) = table-    table :: Table-    table = Table-        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--isDigit :: Word8 -> Bool-isDigit w = w >= 48 && w <= 57+readInt64 bs =+    S.foldl' (\ !i !c -> i * 10 + fromIntegral (c - _0)) 0 $+        S.takeWhile isDigit bs

@@ -1,244 +1,343 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} -module Network.Wai.Handler.Warp.Request where+module Network.Wai.Handler.Warp.Request (+    FirstRequest(..),+    recvRequest,+    headerLines,+    pauseTimeoutKey,+    getFileInfoKey,+#ifdef MIN_VERSION_crypton_x509+    getClientCertificateKey,+#endif+    NoKeepAliveRequest (..),+) where -import Control.Applicative-import Control.Exception.Lifted (throwIO)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.ByteString (ByteString)+import qualified Control.Concurrent as Conc (yield)+import Data.Array ((!)) import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as B (unpack) import qualified Data.ByteString.Unsafe as SU import qualified Data.CaseInsensitive as CI-import Data.Conduit import qualified Data.IORef as I-import Data.Maybe (fromMaybe)-import Data.Monoid (mempty)-import Data.Word (Word8)+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.Conduit-import Network.Wai.Handler.Warp.ReadInt 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 qualified Network.Wai.Handler.Warp.Timeout as Timeout --- FIXME come up with good values here-maxTotalHeaderLength :: Int-maxTotalHeaderLength = 50 * 1024+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,+ ) -parseRequest :: Connection-             -> Port -> SockAddr-             -> Source (ResourceT IO) ByteString-             -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))-parseRequest conn = parseRequestInternal conn Timeout.dummyHandle+---------------------------------------------------------------- -parseRequestInternal-             :: Connection-             -> Timeout.Handle-             -> Port -> SockAddr-             -> Source (ResourceT IO) ByteString-             -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))-parseRequestInternal conn timeoutHandle port remoteHost' src1 = do-    (src2, headers') <- src1 $$+ takeHeaders-    parseRequest' conn timeoutHandle port headers' remoteHost' src2+-- | first request on this connection?+data FirstRequest = FirstRequest | SubsequentRequest -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+-- | 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)+        , IndexedHeader+        , 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 = idxhdr ! fromEnum ReqExpect+        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 = idxhdr ! fromEnum ReqHost+                , requestHeaderRange = idxhdr ! fromEnum ReqRange+                , requestHeaderReferer = idxhdr ! fromEnum ReqReferer+                , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent+                }+    return (req, remainingRef, idxhdr, rbodyFlush) --- | Parse a set of header lines and body into a 'Request'.-parseRequest' :: Connection-              -> Timeout.Handle-              -> Port-              -> [ByteString]-              -> SockAddr-              -> ResumableSource (ResourceT IO) ByteString -- FIXME was buffered-              -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))-parseRequest' _ _ _ [] _ _ = throwIO $ NotEnoughLines []-parseRequest' conn timeoutHandle 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 hHost heads-    let len0 =-            case lookup H.hContentLength heads of-                Nothing -> 0-                Just bs -> readInt bs-    let serverName' = takeUntil 58 host -- ':'-    let chunked = maybe False ((== "chunked") . CI.foldCase)-                  $ lookup hTransferEncoding heads-    (rbody, getSource) <- liftIO $-        if chunked-          then do-            ref <- I.newIORef (src, NeedLen)-            return (chunkedSource ref, fst <$> I.readIORef ref)-          else do-            ibs <- IsolatedBSSource <$> I.newIORef (len0, src)-            return (ibsIsolate ibs, ibsDone ibs)+---------------------------------------------------------------- -    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 = do-                -- 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.-                liftIO $ Timeout.resume timeoutHandle-                -- 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.-                addCleanup (const $ liftIO $ Timeout.pause timeoutHandle) rbody-            , vault = mempty-#if MIN_VERSION_wai(1, 4, 0)-            , requestBodyLength =-                if chunked-                    then ChunkedBody-                    else KnownLength $ fromIntegral len0-#endif-            }, getSource)+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. -{-# INLINE takeUntil #-}-takeUntil :: Word8 -> ByteString -> ByteString-takeUntil c bs =-    case S.elemIndex c bs of-       Just !idx -> SU.unsafeTake idx bs-       Nothing -> bs+            case firstRequest of+              FirstRequest -> throwIO ConnectionClosedByPeer+              SubsequentRequest -> throwIO NoKeepAliveRequest+        else push maxTotalHeaderLength src (THStatus 0 0 id id) bs -{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported-parseFirst :: ByteString-           -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)-parseFirst s =-    case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of  -- ' '-        (method:query:http'') -> do-            let http' = S.concat http''-                (hfirst, hsecond) = S.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+data NoKeepAliveRequest = NoKeepAliveRequest+    deriving (Show)+instance Exception NoKeepAliveRequest -parseHeaderNoAttr :: ByteString -> H.Header-parseHeaderNoAttr s =-    let (k, rest) = S.breakByte 58 s -- ':'-        rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest-     in (CI.mk k, rest')+---------------------------------------------------------------- -type BSEndo = ByteString -> ByteString+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+    -> IndexedHeader+    -> 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 $ idxhdr ! fromEnum ReqContentLength+            bodyLen = KnownLength $ fromIntegral len+        isrc@(ISource _ remaining) <- mkISource src len+        return (readISource isrc, Just remaining, bodyLen)+  where+    chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding++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-    {-# UNPACK #-} !Int -- running total byte count-    BSEndoList -- previously parsed lines-    BSEndo -- bytestrings to be prepended+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 -{-# INLINE takeHeaders #-}-takeHeaders :: Sink ByteString (ResourceT IO) [ByteString]-takeHeaders =-    await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))+---------------------------------------------------------------- -close :: Sink ByteString (ResourceT IO) a+{- FIXME+close :: Sink ByteString IO a close = throwIO IncompleteHeaders+-} -push :: THStatus -> ByteString -> Sink ByteString (ResourceT IO) [ByteString]-push (THStatus len lines prepend) bs+-- | 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-        | len > maxTotalHeaderLength = throwIO OverLargeHeader-        | otherwise = push' mnl+        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-    mnl = do-        nl <- S.elemIndex 10 bs-        -- check if there are two more bytes in the bs-        -- if so, see if the second of those is a horizontal space-        if bsLen > nl + 1 then-            let c = S.index bs (nl + 1)-                b = case nl of-                      0 -> True-                      1 -> S.index bs 0 == 13-                      _ -> False-            in Just (nl, (not b) && (c == 32 || c == 9))-            else-            Just (nl, False)--    {-# INLINE push' #-}-    -- No newline find in this chunk.  Add it to the prepend,-    -- update the length, and continue processing.-    push' Nothing = await >>= maybe close (push status)-      where-        len' = len + bsLen-        prepend' = prepend . S.append bs-        status = THStatus len' lines prepend'-    -- Found a newline, but next line continues as a multiline header-    push' (Just (end, True)) = push status rest-      where-        rest = S.drop (end + 1) bs-        prepend' = prepend . S.append (SU.unsafeTake (checkCR bs end) bs)-        len' = len + end-        status = THStatus len' lines prepend'-    -- Found a newline at position end.-    push' (Just (end, False))-      -- leftover-      | S.null line = let lines' = lines []-                          rest = if start < bsLen then-                                     Just (SU.unsafeDrop start bs)-                                   else-                                     Nothing-                       in maybe (return ()) leftover rest >> return lines'-      -- more headers-      | otherwise   = let len' = len + start-                          lines' = lines . (line:)-                          status = THStatus len' lines' id-                      in if start < bsLen then-                             -- more bytes in this chunk, push again-                             let bs' = SU.unsafeDrop start bs-                              in push status bs'-                           else-                             -- no more bytes in this chunk, ask for more-                             await >>= maybe close (push status)+    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-        start = end + 1 -- start of next chunk-        line-          -- There were some bytes before the newline, get them-          | end > 0 = prepend $ SU.unsafeTake (checkCR bs end) bs-          -- No bytes before the newline-          | otherwise = prepend S.empty+        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" -} -{-# INLINE checkCR #-}-checkCR :: ByteString -> Int -> Int-checkCR bs pos = if 13 == S.index bs p then p else pos -- 13 is CR-  where-    !p = pos - 1++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

@@ -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')

@@ -1,251 +1,521 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}  module Network.Wai.Handler.Warp.Response (-    sendResponse-  ) where+    sendResponse,+    sanitizeHeaderValue, -- for testing+    --  Provided here for backwards compatibility.+    warpVersion,+    hasBody,+    replaceHeader,+    addServer, -- testing+    addAltSvc,+) where -import Blaze.ByteString.Builder (fromByteString, Builder, toByteStringIO, flush)-import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)-import Control.Applicative-import Control.Exception-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B (pack)+import qualified Control.Exception as E+import Data.Array ((!))+import qualified Data.ByteString as S+import Data.ByteString.Builder (Builder, byteString)+import Data.ByteString.Builder.Extra (flush)+import Data.ByteString.Builder.HTTP.Chunked (+    chunkedTransferEncoding,+    chunkedTransferTerminator,+ )+import qualified Data.ByteString.Char8 as C8 import qualified Data.CaseInsensitive as CI-import Data.Conduit-import Data.Conduit.Blaze (builderToByteString)-import qualified Data.Conduit.List as CL-import Data.Maybe (isJust, listToMaybe)-import Data.Monoid (mappend)+import Data.Function (on)+import Data.List (deleteBy)+import Data.Streaming.ByteString.Builder (+    newByteStringBuilderRecv,+    reuseBufferStrategy,+ )+import Data.Word8 (_cr, _lf, _space, _tab) import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as H import Network.Wai-import Network.Wai.Handler.Warp.ReadInt+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 qualified Network.Wai.Handler.Warp.ResponseHeader as RH-import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types-import qualified System.PosixCompat.Files as P-import Network.HTTP.Attoparsec (parseByteRanges)-import Numeric (showInt) -----------------------------------------------------------------+-- $setup+-- >>> :set -XOverloadedStrings+ ---------------------------------------------------------------- -sendResponse :: Settings-             -> Cleaner -> Request -> Connection -> Response-             -> ResourceT IO Bool+-- | 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.+    -> IndexedHeader+    -- ^ 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+    isShuttingDown <-+        case settingsServerState settings of+            Just serverState -> currentShuttingDownState serverState+            -- Should never be reached!+            -- (cf. 'makeServerState' in 'runSettingsConnectionMakerSecure')+            Nothing -> pure False+    let shouldPersist =+            not isShuttingDown && if hasBody s then ret else isPersist+        addConnection hs =+            if shouldPersist then hs else (H.hConnection, "close") : hs+    hs <- addConnection . addAltSvc settings <$> addServerAndDate hs0+    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+    defServer = settingsServerName settings+    logger = settingsLogger settings+    maxRspBufSize = settingsMaxBuilderResponseBufferSize settings+    ver = httpVersion req+    s = responseStatus response+    hs0 = sanitizeHeaders $ responseHeaders response+    rspidxhdr = indexResponseHeader hs0+    getdate = getDate ii+    addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr+    (isPersist, isChunked0) = infoFromRequest req reqidxhdr+    isChunked = not isHead && isChunked0+    (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist, isChunked)+    method = requestMethod req+    isHead = method == H.methodHead+    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+    -- Make sure we don't hang on to 'response' (avoid space leak)+    !ret = case response of+        ResponseFile{} -> isPersist+        ResponseBuilder{} -> isKeepAlive+        ResponseStream{} -> isKeepAlive+        ResponseRaw{} -> False  ---------------------------------------------------------------- -sendResponse settings cleaner req conn (ResponseFile s0 hs0 path mpart0) =-    headerAndLength >>= sendResponse'+sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders+sanitizeHeaders = map (sanitize <$>)   where-    hs = addAccept hs0-    th = threadHandle cleaner-    headerAndLength = liftIO . try $ do-        (hadLength, cl) <--            case readInt <$> checkLength hs of-                Just cl -> return (True, cl)-                Nothing ->-                    case mpart0 of-                        Just part -> return (False, fromIntegral $ filePartByteCount part)-                        Nothing -> (False, ) . fromIntegral . P.fileSize-                               <$> P.getFileStatus path-        let (s, addRange, beg, end) =-                case mpart0 of-                    Just part -> (s0, id, filePartOffset part, filePartByteCount part)-                    Nothing ->-                        case lookup H.hRange (requestHeaders req) >>= parseByteRanges >>= listToMaybe of-                            Just range | s0 == H.status200 ->-                                case range of-                                    H.ByteRangeFrom from -> rangeRes cl from (cl - 1)-                                    H.ByteRangeFromTo from to -> rangeRes cl from to-                                    H.ByteRangeSuffix count -> rangeRes cl (cl - count) (cl - 1)-                            _ -> (s0, id, 0, cl)-            hs'-                | hadLength = hs-                | otherwise = addLength end hs-        return (s, addRange hs', beg, end)+    sanitize v+        | containsNewlines v = sanitizeHeaderValue v -- slow path+        | otherwise = v -- fast path -    rangeRes cl from to = (H.status206, (("Content-Range", rangeHeader cl from to):), from, to - from + 1)+{-# INLINE containsNewlines #-}+containsNewlines :: ByteString -> Bool+containsNewlines = S.any (\w -> w == _cr || w == _lf) -    rangeHeader total from to = B.pack-      $ 'b' : 'y': 't' : 'e' : 's' : ' '-      : showInt from-      ( '-'-      : showInt to-      ( '/'-      : showInt total ""))+{-# INLINE sanitizeHeaderValue #-}+sanitizeHeaderValue :: ByteString -> ByteString+sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of+    [] -> ""+    x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)+  where+    addSpaceIfMissing line = case S.uncons line of+        Nothing -> Nothing+        Just (first, _)+            | first == _space || first == _tab -> Just line+            | otherwise -> Just $ _space `S.cons` line -    sendResponse' (Right (s, lengthyHeaders, beg, end))-      | hasBody s req = liftIO $ do-          lheader <- composeHeader settings version s lengthyHeaders-          connSendFile conn path beg end (T.tickle th) [lheader] cleaner-          T.tickle th-          return isPersist-      | otherwise = liftIO $ do-          composeHeader settings version s hs >>= connSendAll conn-          T.tickle th-          return isPersist -- FIXME isKeepAlive?-      where-        version = httpVersion req-        (isPersist,_) = infoFromRequest req+---------------------------------------------------------------- -    sendResponse' (Left (_ :: SomeException)) =-        sendResponse settings cleaner req conn notFound-      where-        notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"+data Rsp+    = RspNoBody+    | RspFile FilePath (Maybe FilePart) IndexedHeader (IO ())+    | RspBuilder Builder Bool+    | RspStream StreamingBody Bool+    | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)  ---------------------------------------------------------------- -sendResponse settings cleaner req conn (ResponseBuilder s hs b)-  | hasBody s req = liftIO $ do-      header <- composeHeaderBuilder settings version s hs needsChunked-      let body-            | needsChunked = header `mappend` chunkedTransferEncoding b-                                    `mappend` chunkedTransferTerminator-            | otherwise    = header `mappend` b-      flip toByteStringIO body $ \bs -> do-          connSendAll conn bs-          T.tickle th-      return isKeepAlive-  | otherwise = liftIO $ do-      composeHeader settings version s hs >>= connSendAll conn-      T.tickle th-      return isPersist+sendRsp+    :: Connection+    -> InternalInfo+    -> T.Handle+    -> H.HttpVersion+    -> H.Status+    -> H.ResponseHeaders+    -> IndexedHeader -- Response+    -> 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, Nothing)++----------------------------------------------------------------++sendRsp conn _ th ver s hs _ maxRspBufSize _ (RspBuilder body needsChunked) = do+    header <- composeHeaderBuilder ver s hs 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+    return (Just s, Just len)++----------------------------------------------------------------++sendRsp conn _ th ver s hs _ _ _ (RspStream streamingBody needsChunked) = do+    header <- composeHeaderBuilder ver s hs needsChunked+    (recv, finish) <-+        newByteStringBuilderRecv $+            reuseBufferStrategy $+                toBuilderBuffer $+                    connWriteBuffer conn+    let send builder = do+            popper <- recv builder+            let loop = do+                    bs <- popper+                    unless (S.null bs) $ do+                        sendFragment conn th bs+                        loop+            loop+        sendChunk+            | needsChunked = send . chunkedTransferEncoding+            | otherwise = send+    send header+    streamingBody sendChunk (sendChunk flush)+    when needsChunked $ send chunkedTransferTerminator+    mbs <- finish+    maybe (return ()) (sendFragment conn th) mbs+    return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?++----------------------------------------------------------------++sendRsp conn _ th _ _ _ _ _ _ (RspRaw withApp src) = do+    withApp recv send+    return (Nothing, Nothing)   where-    th = threadHandle cleaner-    version = httpVersion req-    reqinfo@(isPersist,_) = infoFromRequest req-    (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo+    recv = do+        bs <- src+        unless (S.null bs) $ T.tickle th+        return bs+    send bs = connSendAll conn bs >> T.tickle th  ---------------------------------------------------------------- -sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush)-  | hasBody s req = do-      header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked-      let src = CL.sourceList [header] `mappend` cbody-      src $$ builderToByteString =$ connSink conn th-      return isKeepAlive-  | otherwise = liftIO $ do-      composeHeader settings version s hs >>= connSendAll conn-      T.tickle th-      return isPersist+-- 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-    th = threadHandle cleaner-    body =-           mapOutput (\x -> case x of-                    Flush -> flush-                    Chunk builder -> builder)-           bodyFlush-    cbody = if needsChunked then body $= chunk else body-    -- FIXME perhaps alloca a buffer per thread and reuse that in all-    -- functions below. Should lessen greatly the GC burden (I hope)-    chunk :: Conduit Builder (ResourceT IO) Builder-    chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)-    version = httpVersion req-    reqinfo@(isPersist,_) = infoFromRequest req-    (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo+    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+ ---------------------------------------------------------------- --- | Use 'connSendAll' to send this data while respecting timeout rules.-connSink :: Connection -> T.Handle -> Sink ByteString (ResourceT IO) ()-connSink Connection { connSendAll = send } th =-    sink+sendRspFile2XX+    :: Connection+    -> InternalInfo+    -> T.Handle+    -> H.HttpVersion+    -> H.Status+    -> H.ResponseHeaders+    -> IndexedHeader+    -> 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 =+        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+    -> IndexedHeader+    -> 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-    sink = await >>= maybe close push-    close = liftIO (T.resume th)-    push x = do-        liftIO $ T.resume th-        liftIO $ send x-        liftIO $ T.pause th-        sink-    -- 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.+    s = H.notFound404+    hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0+    body = byteString "File not found"  ----------------------------------------------------------------+---------------------------------------------------------------- -infoFromRequest :: Request -> (Bool,Bool)-infoFromRequest req = (checkPersist req, checkChunk req)+-- | 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 -checkPersist :: Request -> Bool-checkPersist req+-- 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.++----------------------------------------------------------------++infoFromRequest+    :: Request+    -> IndexedHeader+    -> ( Bool -- isPersist+       , Bool -- isChunked+       )+infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req)++checkPersist :: Request -> IndexedHeader -> Bool+checkPersist req reqidxhdr     | ver == H.http11 = checkPersist11 conn-    | otherwise       = checkPersist10 conn+    | otherwise = checkPersist10 conn   where     ver = httpVersion req-    conn = lookup H.hConnection $ requestHeaders req+    conn = reqidxhdr ! fromEnum ReqConnection     checkPersist11 (Just x)-        | CI.foldCase x == "close"      = False-    checkPersist11 _                    = True+        | CI.foldCase x == "close" = False+    checkPersist11 _ = True     checkPersist10 (Just x)         | CI.foldCase x == "keep-alive" = True-    checkPersist10 _                    = False+    checkPersist10 _ = False  checkChunk :: Request -> Bool checkChunk req = httpVersion req == H.http11  ---------------------------------------------------------------- -infoFromResponse :: H.ResponseHeaders -> (Bool,Bool) -> (Bool,Bool)-infoFromResponse hs (isPersist,isChunked) = (isKeepAlive, needsChunked)+-- Used for ResponseBuilder and ResponseSource.+-- Don't use this for ResponseFile since this logic does not fit+-- for ResponseFile. For instance, isKeepAlive should be True in some cases+-- even if the response header does not have Content-Length.+--+-- Content-Length is specified by a reverse proxy.+-- Note that CGI does not specify Content-Length.+infoFromResponse :: IndexedHeader -> (Bool, Bool) -> (Bool, Bool)+infoFromResponse rspidxhdr (isPersist, isChunked) = (isKeepAlive, needsChunked)   where     needsChunked = isChunked && not hasLength     isKeepAlive = isPersist && (isChunked || hasLength)-    hasLength = isJust $ checkLength hs--checkLength :: H.ResponseHeaders -> Maybe ByteString-checkLength = lookup H.hContentLength+    hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength  ---------------------------------------------------------------- -hasBody :: H.Status -> Request -> Bool-hasBody s req = sc /= 204-             && sc /= 304-             && sc >= 200-             && method /= H.methodHead+hasBody :: H.Status -> Bool+hasBody s =+    sc /= 204+        && sc /= 304+        && sc >= 200   where     sc = H.statusCode s-    method = requestMethod req  ---------------------------------------------------------------- -addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders-addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs+addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders+addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs -addAccept :: H.ResponseHeaders -> H.ResponseHeaders-addAccept = (("Accept-Ranges", "bytes"):)+addDate+    :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of+    Nothing -> do+        gmtdate <- getdate+        return $ (H.hDate, gmtdate) : hdrs+    Just _ -> return hdrs -addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders-addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs+---------------------------------------------------------------- -addServerHeader :: Settings -> H.ResponseHeaders -> H.ResponseHeaders-addServerHeader settings hdrs = case lookup hServer hdrs of-    Nothing -> warpVersionHeader settings : hdrs-    Just _  -> hdrs+{-# INLINE addServer #-}+addServer+    :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders+addServer "" rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of+    Nothing -> hdrs+    _ -> filter ((/= H.hServer) . fst) hdrs+addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of+    Nothing -> (H.hServer, serverName) : hdrs+    _ -> hdrs -warpVersionHeader :: Settings -> H.Header-warpVersionHeader settings = (hServer, settingsServerName settings)+addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders+addAltSvc settings hs = case settingsAltSvc settings of+    Nothing -> hs+    Just v -> ("Alt-Svc", v) : hs  ---------------------------------------------------------------- -composeHeader :: Settings-              -> H.HttpVersion-              -> H.Status-              -> H.ResponseHeaders-              -> IO ByteString-composeHeader settings version s hs =-    RH.composeHeader version s-  $ addServerHeader settings hs+-- |+--+-- >>> replaceHeader "Content-Type" "new" [("content-type","old")]+-- [("Content-Type","new")]+replaceHeader+    :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders+replaceHeader k v hdrs = (k, v) : deleteBy ((==) `on` fst) (k, v) hdrs -composeHeaderBuilder :: Settings -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder-composeHeaderBuilder settings ver s hs True =-    fromByteString <$> composeHeader settings ver s (addEncodingHeader hs)-composeHeaderBuilder settings ver s hs False =-    fromByteString <$> composeHeader settings ver s hs+----------------------------------------------------------------++composeHeaderBuilder+    :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder+composeHeaderBuilder ver s hs True =+    byteString <$> composeHeader ver s (addTransferEncoding hs)+composeHeaderBuilder ver s hs False =+    byteString <$> composeHeader ver s hs

@@ -1,20 +1,20 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}  module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where -import Control.Monad-import Data.ByteString (ByteString) import qualified Data.ByteString as S-import Data.ByteString.Internal (ByteString(..), create, memcpy)+import Data.ByteString.Internal (create) import qualified Data.CaseInsensitive as CI import Data.List (foldl')-import Data.Word (Word8)-import Foreign.ForeignPtr+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@@ -24,15 +24,9 @@     void $ copyCRLF ptr2   where     !len = 17 + slen + foldl' fieldLength 0 responseHeaders-    fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4+    fieldLength !l (!k, !v) = l + S.length (CI.original k) + S.length v + 4     !slen = S.length $ H.statusMessage status -{-# INLINE copy #-}-copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)-copy !ptr !(PS fp o l) = withForeignPtr fp $ \p -> do-    memcpy ptr (p `plusPtr` o) (fromIntegral l)-    return $! ptr `plusPtr` l- httpVer11 :: ByteString httpVer11 = "HTTP/1.1 " @@ -43,52 +37,39 @@ copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) copyStatus !ptr !httpversion !status = do     ptr1 <- copy ptr httpVer-    writeWord8OffPtr ptr1 0 (zero + fromIntegral r2)-    writeWord8OffPtr ptr1 1 (zero + fromIntegral r1)-    writeWord8OffPtr ptr1 2 (zero + fromIntegral r0)-    writeWord8OffPtr ptr1 3 spc+    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+        | 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+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+copyHeader !ptr (k, v) = do     ptr1 <- copy ptr (CI.original k)-    writeWord8OffPtr ptr1 0 colon-    writeWord8OffPtr ptr1 1 spc+    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+    writeWord8OffPtr ptr 0 _cr+    writeWord8OffPtr ptr 1 _lf     return $! ptr `plusPtr` 2--zero :: Word8-zero = 48-spc :: Word8-spc = 32-colon :: Word8-colon = 58-cr :: Word8-cr = 13-lf :: Word8-lf = 10--

@@ -1,308 +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.Concurrent (threadDelay, forkIOWithUnmask)-import Control.Exception as E-import Control.Monad (forever, when, unless, void)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Data.ByteString (ByteString)+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.Conduit-import Data.Conduit.Internal (ResumableSource (..))-import qualified Data.Conduit.List as CL-import Data.Conduit.Network (bindPort)-import Network (sClose, Socket)-import Network.Sendfile-import Network.Socket (accept, SockAddr)+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 Data.Monoid (mempty)-import qualified Network.HTTP.Types as H import Network.Wai-import Network.Wai.Handler.Warp.Request-import Network.Wai.Handler.Warp.Response+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 qualified Network.Wai.Handler.Warp.Timeout as T+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown) import Network.Wai.Handler.Warp.Types-import Data.IORef (IORef, newIORef, readIORef, writeIORef) --- Sock.recv first tries to call recvfrom() optimistically.--- If EAGAIN returns, it polls incoming data with epoll/kqueue.--- This code first polls incoming data with epoll/kqueue.--#if WINDOWS-import qualified Control.Concurrent.MVar as MV-import Network.Socket (withSocketsDo)-import Control.Concurrent (forkIO)+-- | 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-import System.Posix.IO (FdOption(CloseOnExec), setFdOption)-import Network.Socket (fdSocket)+            , 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 -#if SENDFILEFD-import Control.Applicative-import qualified Network.Wai.Handler.Warp.FdCache as F-#endif+    sendfile writeBufferRef fid offset len hook headers = do+        writeBuffer <- readIORef writeBufferRef+        sendFile+            s+            (bufBuffer writeBuffer)+            (bufSize writeBuffer)+            sendall+            fid+            offset+            len+            hook+            headers --- FIXME come up with good values here-bytesPerRead :: Int-bytesPerRead = 4096+    sendall = sendAll' s --- | Default action value for 'Connection'-socketConnection :: Socket -> Connection-socketConnection s = Connection-    { connSendMany = Sock.sendMany s-    , connSendAll = Sock.sendAll s-    , connSendFile = sendFile s-    , connClose = sClose s-    , connRecv = Sock.recv s bytesPerRead-    }+    sendAll' sock bs =+        E.handleJust+            ( \e ->+                if ioeGetErrorType e == ResourceVanished+                    then Just ConnectionClosedByPeer+                    else Nothing+            )+            E.throwIO+            $ Sock.sendAll sock bs -sendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO ()-#if SENDFILEFD-sendFile s path off len act hdr cleaner = case fdCacher cleaner of-    Nothing  -> sendfileWithHeader s path (PartOfFile off len) act hdr-    Just fdc -> do-        (fd, fresher) <- F.getFd fdc path-        sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr+-- | 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-sendFile s path off len act hdr _ =-    sendfileWithHeader s path (PartOfFile off len) act hdr-#endif--#if __GLASGOW_HASKELL__ < 702-allowInterrupt :: IO ()-allowInterrupt = unblock $ return ()+        -- 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 an 'Application' on the given port.+-- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO ()-run p = runSettings defaultSettings { settingsPort = p }+run p = runSettings defaultSettings{settingsPort = p} --- | Run a Warp server with the given settings.+-- | 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 ()-#if WINDOWS-runSettings set app = withSocketsDo $ do-    var <- MV.newMVar Nothing-    let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing-    void . 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 app =-    bracket-        (bindPort (settingsPort set) (settingsHost set))-        sClose-        (\socket -> do-            setSocketCloseOnExec socket-            runSettingsSocket set socket app)-#endif+    withSocketsDo $+        E.bracket+            (bindPortTCP (settingsPort set) (settingsHost set))+            close+            ( \socket -> do+                setSocketCloseOnExec socket+                runSettingsSocket set socket app+            ) --- | 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+-- | 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 set socket app =-    runSettingsConnection set getter app+runSettingsSocket oldSettings@Settings{settingsAccept = accept'} socket app = do+    settingsInstallShutdownHandler oldSettings closeListenSocket+    (_, newSettings) <- makeServerState oldSettings+    runSettingsConnection newSettings (getConn newSettings) app   where-    getter = do-        (conn, sa) <- accept socket-        setSocketCloseOnExec conn-        return (socketConnection conn, sa)+    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) -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)+    closeListenSocket = close socket --- | Allows you to provide a function which will return a @Connection@. In--- cases where creating the @Connection@ can be expensive, this allows the--- expensive computations to be performed in a separate thread instead of the--- main server loop.+-- | 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-runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()-runSettingsConnectionMaker set getConn app = do-#if SENDFILEFD-    let duration = settingsFdCacheDuration set-    fc <- case duration of-        0 -> return Nothing-        _ -> Just <$> F.initialize (duration * 1000000)-#endif-    settingsBeforeMainLoop set--    -- 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 getConnLoop, the connection-    --    is guaranteed to be closed, even in the presence of async exceptions.-    ---    -- Our approach is explained in the comments below.--    -- First mask all exceptions in the main loop. This is necessary to ensure-    -- that no async exception is throw between the call to getConnLoop and the-    -- registering of connClose.-    withTimeoutManager $ \tm -> mask_ . forever $ do-        -- Allow async exceptions before receiving the next connection maker.-        allowInterrupt--        -- getConnLoop 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.-        (mkConn, addr) <- getConnLoop+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) -        -- Fork a new worker thread for this connection maker, and ask for a-        -- function to unmask (i.e., allow async exceptions to be thrown).-        ---        -- GHC 7.8 cannot infer the type of "void . forkIOWithUnmask"-        void $ forkIOWithUnmask $ \unmask ->-            -- 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.-            bracket mkConn connClose $ \conn ->+-- | 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) <$>) -            -- We need to register a timeout handler for this thread, and-            -- cancel that handler as soon as we exit.-            bracket (T.registerKillThread tm) T.cancel $ \th ->-#if SENDFILEFD-                let cleaner = Cleaner th fc-#else-                let cleaner = Cleaner th-#endif-                    -- We now have fully registered a connection close handler-                    -- in the case of all exceptions, so it is safe to one-                    -- again allow async exceptions.-                 in unmask .-                    -- Call the user-supplied on exception code if any-                    -- exceptions are thrown.-                    handle onE .+---------------------------------------------------------------- -                    -- Call the user-supplied code for connection open and close events-                    bracket_ onOpen onClose $+-- | 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 -                    -- Actually serve this connection.-                    serveConnection th set cleaner port app conn addr+-- | 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-    -- FIXME: only IOEception is caught. What about other exceptions?-    getConnLoop = getConn `E.catch` \(e :: IOException) -> do-        onE (toException e)-        -- "resource exhausted (Too many open files)" may happen by accept().-        -- Wait a second hoping that resource will be available.-        threadDelay 1000000-        getConnLoop-    onE = settingsOnException set-    port = settingsPort set-    onOpen = settingsOnOpen set-    onClose = settingsOnClose set--    withTimeoutManager f =-        case settingsManager set of-            Nothing -> bracket-                (T.initialize $ settingsTimeout set * 1000000)+    !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-            Just tm -> f tm -serveConnection :: T.Handle-                -> Settings-                -> Cleaner-                -> Port -> Application -> Connection -> SockAddr-> IO ()-serveConnection timeoutHandle settings cleaner port app conn remoteHost' = do-    istatus <- newIORef False-    respondOnException istatus settings cleaner conn remoteHost' $-        runResourceT (serveConnection' istatus)+-- 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-    innerRunResourceT-        | settingsResourceTPerRequest settings = lift . runResourceT-        | otherwise = id-    th = threadHandle cleaner+    acceptLoop = do+        -- Allow async exceptions before receiving the next connection maker.+        E.allowInterrupt -    serveConnection' :: IORef Bool -> ResourceT IO ()-    serveConnection' istatus = serveConnection'' istatus $ connSource conn th istatus+        -- 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 -    serveConnection'' istatus fromClient = do-        (env, getSource) <- parseRequestInternal conn timeoutHandle port remoteHost' fromClient-        case settingsIntercept settings env of-            Nothing -> do-                -- Let the application run for as long as it wants-                liftIO $ T.pause th-                keepAlive <- innerRunResourceT $ do-                    res <- app env+    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 -                    liftIO $ 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-                    sendResponse settings cleaner env conn res+    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 -                -- flush the rest of the request body-                requestBody env $$ CL.sinkNull-                ResumableSource fromClient' _ <- liftIO getSource+-- 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 -                when keepAlive $ serveConnection'' istatus fromClient'-            Just intercept -> do-                liftIO $ T.pause th-                ResumableSource fromClient' _ <- liftIO getSource-                intercept fromClient' conn+    -- 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 -respondOnException :: IORef Bool -> Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()-respondOnException istatus settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do-    status <- readIORef istatus-    when status $ do-        _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError-        return ()-    throwIO e-  where-    blankRequest = Request H.methodGet H.http10 mempty mempty mempty 0 [] False remoteHost' [] [] (return mempty) mempty (KnownLength 0)-    internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"+    onOpen adr = increase counter >> settingsOnOpen set adr+    onClose adr _ = decrease counter >> settingsOnClose set adr -connSource :: Connection -> T.Handle -> IORef Bool -> Source (ResourceT IO) ByteString-connSource Connection { connRecv = recv } th istatus = src+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-    src = do-        bs <- liftIO recv-        unless (S.null bs) $ do-            liftIO $ do-                writeIORef istatus True-                when (S.length bs >= 2048) $ T.tickle th-            yield bs-            src+    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 =-    setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True+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

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

@@ -1,90 +1,457 @@+{-# 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.Exception-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import Data.Conduit-import Data.Conduit.Network (HostPreference (HostIPv4))-import GHC.IO.Exception (IOErrorType(..))+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 Network.Wai.Handler.Warp.Timeout-import Network.Wai.Handler.Warp.Types-import System.IO (hPrint, stderr)+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 record syntax to modify individual records. For example:+-- and the various \'set\' functions to modify individual fields. For example: ----- > defaultSettings { settingsTimeout = 20 }+-- > setTimeout 20 defaultSettings 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.-    , settingsOnOpen :: IO () -- ^ What to do when a connection is open. Default: do nothing.-    , settingsOnClose :: IO ()  -- ^ What to do when a connection is close. Default: do nothing.-    , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30-    , settingsIntercept :: Request -> Maybe (Source (ResourceT 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'-    , settingsFdCacheDuration :: Int -- ^ Cache duratoin time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 10-    , settingsResourceTPerRequest :: Bool-      -- ^ If @True@, each request\/response pair will run in a separate-      -- @ResourceT@. This provides more intuitive behavior for dynamic code,-      -- but can hinder performance in high-throughput cases. File servers can-      -- safely set to @False@ for increased performance. Default is @True@.+    { 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-    , settingsServerName :: S.ByteString-      -- ^ Server name to be sent in the Server header.-      ---      -- Default: Warp\//version/-      ---      -- Since 1.3.8+    -- ^ 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.+    --+    -- 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 = HostIPv4-    , settingsOnException = defaultExceptionHandler-    , settingsOnOpen = return ()-    , settingsOnClose = return ()-    , settingsTimeout = 30-    , settingsIntercept = const Nothing-    , settingsManager = Nothing-    , settingsFdCacheDuration = 10-    , settingsResourceTPerRequest = True-    , settingsBeforeMainLoop = return ()-    , settingsServerName = S8.pack $ "Warp/" ++ warpVersion-    }+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+        } -defaultExceptionHandler :: SomeException -> IO ()-defaultExceptionHandler e = throwIO e `catches` handlers-  where-    handlers = [Handler ah, Handler ih, Handler oh, Handler sh]+-- | 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) -    ah :: AsyncException -> IO ()-    ah ThreadKilled = return ()-    ah x            = hPrint stderr x+-- | 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 -    ih :: InvalidRequest -> IO ()-    ih _ = return ()+-- | 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 -    oh :: IOException -> IO ()-    oh x-      | et == ResourceVanished || et == InvalidArgument = return ()-      | otherwise         = hPrint stderr x-      where-        et = ioeGetErrorType x+-- | 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 -    sh :: SomeException -> IO ()-    sh x = hPrint stderr x+-- | 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

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

@@ -1,171 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE UnboxedTuples, MagicHash #-}-module Network.Wai.Handler.Warp.Timeout (-    Manager-  , Handle-  , TimeoutAction-  , initialize-  , stopManager-  , register-  , registerKillThread-  , tickle-  , pause-  , resume-  , cancel-  , withManager-  , dummyHandle-  ) where--#if MIN_VERSION_base(4,6,0)-import Control.Concurrent (mkWeakThreadId, ThreadId)-#else-import GHC.Conc (ThreadId(..))-import GHC.Exts (mkWeak#)-import GHC.IO (IO (IO))-#endif-import GHC.Weak (Weak (..))-import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)-import qualified Control.Exception as E-import Control.Monad (forever, void)-import Data.IORef (IORef)-import qualified Data.IORef as I-import Data.Typeable (Typeable)-import System.IO.Unsafe (unsafePerformIO)-import System.Mem.Weak (deRefWeak)---------------------------------------------------------------------- | A timeout manager-newtype Manager = Manager (IORef [Handle])---- | An action to be performed on timeout.-type TimeoutAction = IO ()---- | A handle used by 'Manager'-data Handle = Handle TimeoutAction (IORef State)--data State = Active    -- Manager turns it to Inactive.-           | Inactive  -- Manager removes it with timeout action.-           | Paused    -- Manager does not change it.-           | Canceled  -- Manager removes it without timeout action.---------------------------------------------------------------------- | A dummy @Handle@.-dummyHandle :: Handle-dummyHandle = Handle (return ()) (unsafePerformIO $ I.newIORef Active)--------------------------------------------------------------------data TimeoutManagerStopped = TimeoutManagerStopped-    deriving (Show, Typeable)-instance E.Exception TimeoutManagerStopped---------------------------------------------------------------------- | Creating timeout manager which works every N micro seconds---   where N is the first argument.-initialize :: Int -> IO Manager-initialize timeout = do-    ref <- I.newIORef []-    void . forkIO $ E.handle ignoreStop $ forever $ do-        threadDelay timeout-        -- FIXME: isn't mask_ necessary?-        old <- I.atomicModifyIORef ref (\x -> ([], x))-        merge <- prune old id-        I.atomicModifyIORef ref (\new -> (merge new, ()))-    return $ Manager ref-  where-    ignoreStop TimeoutManagerStopped = return ()--    prune [] front = return front-    prune (m@(Handle onTimeout iactive):rest) front = do-        state <- I.atomicModifyIORef iactive (\x -> (inactivate x, x))-        case state of-            Inactive -> do-                onTimeout `E.catch` ignoreAll-                prune rest front-            Canceled -> prune rest front-            _        -> prune rest (front . (:) m)-    inactivate Active = Inactive-    inactivate x = x--------------------------------------------------------------------stopManager :: Manager -> IO ()-stopManager (Manager ihandles) = E.mask_ $ do-    -- Put an undefined value in the IORef to kill the worker thread (yes, it's-    -- a bit of a hack)-    !handles <- I.atomicModifyIORef ihandles $ \h -> (E.throw TimeoutManagerStopped, h)-    mapM_ fire handles-  where-    fire (Handle onTimeout _) = onTimeout `E.catch` ignoreAll--ignoreAll :: E.SomeException -> IO ()-ignoreAll _ = return ()---------------------------------------------------------------------- | Registering a timeout action.-register :: Manager -> TimeoutAction -> IO Handle-register (Manager ref) onTimeout = do-    iactive <- I.newIORef Active-    let h = Handle onTimeout iactive-    I.atomicModifyIORef ref (\x -> (h : x, ()))-    return h---- | Registering a timeout action of killing this thread.-registerKillThread :: Manager -> IO Handle-registerKillThread m = do-    wtid <- myThreadId >>= mkWeakThreadId-    register m $ killIfExist wtid---- If ThreadId is hold referred by a strong reference,--- it leaks even after the thread is killed.--- So, let's use a weak reference so that CG can throw ThreadId away.--- deRefWeak checks if ThreadId referenced by the weak reference--- exists. If exists, it means that the thread is alive.-killIfExist :: Weak ThreadId -> TimeoutAction-killIfExist wtid = deRefWeak wtid >>= maybe (return ()) killThread--#if !MIN_VERSION_base(4,6,0)-mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)-mkWeakThreadId t@(ThreadId t#) = IO $ \s ->-   case mkWeak# t# t Nothing s of-      (# s1, w #) -> (# s1, Weak w #)-#endif---------------------------------------------------------------------- | Setting the state to active.---   'Manager' turns active to inactive repeatedly.-tickle :: Handle -> IO ()-tickle (Handle _ iactive) = I.writeIORef iactive Active---- | Setting the state to canceled.---   'Manager' eventually removes this without timeout action.-cancel :: Handle -> IO ()-cancel (Handle _ iactive) = I.writeIORef iactive Canceled---- | Setting the state to paused.---   'Manager' does not change the value.-pause :: Handle -> IO ()-pause (Handle _ iactive) = I.writeIORef iactive Paused---- | Setting the state to active.---   This is an alias to 'ticle'.-resume :: Handle -> IO ()-resume = tickle---------------------------------------------------------------------- | 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 <- initialize timeout-    f man

@@ -1,100 +1,222 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Network.Wai.Handler.Warp.Types where -import Control.Exception-import Data.ByteString (ByteString)-import Data.Typeable (Typeable)-import Data.Version (showVersion)-import Network.HTTP.Types.Header-import qualified Paths_warp-import qualified Network.Wai.Handler.Warp.Timeout as T-#if SENDFILEFD-import qualified Network.Wai.Handler.Warp.FdCache as F+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 -warpVersion :: String-warpVersion = showVersion Paths_warp.version+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+-- | TCP port number. type Port = Int  ---------------------------------------------------------------- -hTransferEncoding :: HeaderName-hTransferEncoding = "Transfer-Encoding"--hHost :: HeaderName-hHost = "Host"--hServer :: HeaderName-hServer = "Server"+-- | The type for header value used with 'HeaderName'.+type HeaderValue = ByteString  ---------------------------------------------------------------- -data InvalidRequest =-    NotEnoughLines [String]+-- | Error types for bad 'Request'.+data InvalidRequest+    = NotEnoughLines [String]     | BadFirstLine String     | NonHttp     | IncompleteHeaders     | ConnectionClosedByPeer     | OverLargeHeader-    deriving (Eq, Show, Typeable)+    | BadProxyHeader String+    | -- | Since 3.3.22+      PayloadTooLarge+    | -- | Since 3.3.22+      RequestHeaderFieldsTooLarge+    deriving (Eq) -instance Exception InvalidRequest+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+ ---------------------------------------------------------------- --- |------ 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.+-- | 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. ----- * Every time at least 2048 bytes of the request body are read, the timeout---   is tickled.+-- 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. ----- * 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.+-- Since: 3.1.0+data FileId = FileId+    { fileIdPath :: FilePath+    , fileIdFd :: Maybe Fd+    }++-- |  fileid, offset, length, hook action, HTTP headers ----- * Every time data is successfully sent to the client, the timeout is tickled.+-- 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 ()-    , connSendAll  :: ByteString -> IO ()-    , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO () -- ^ offset, length-    , connClose    :: IO ()-    , connRecv     :: IO ByteString+    -- ^ 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+ ---------------------------------------------------------------- --- | A dummy @Cleaner@, intended for applications making use of the low-level--- request parsing and rendering functions.------ Since 1.3.4-dummyCleaner :: Cleaner+data InternalInfo = InternalInfo+    { timeoutManager :: T.Manager+    , getDate :: IO D.GMTDate+    , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)+    , getFileInfo :: FilePath -> IO I.FileInfo+    } -#if SENDFILEFD-dummyCleaner = Cleaner T.dummyHandle Nothing+---------------------------------------------------------------- --- | A type used to clean up file descriptor caches.-data Cleaner = Cleaner {-    threadHandle :: T.Handle-  , fdCacher :: Maybe F.MutableFdCache-  }+-- | Type for input streaming.+data Source = Source !(IORef ByteString) !(IO ByteString) -#else-dummyCleaner = Cleaner T.dummyHandle+mkSource :: IO ByteString -> IO Source+mkSource func = do+    ref <- newIORef S.empty+    return $! Source ref func -newtype Cleaner = Cleaner { threadHandle :: T.Handle }+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

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

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

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

@@ -0,0 +1,284 @@+{-# 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.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)+            ]+        ]+  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++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"+        ]