warp 3.1.12 → 3.4.14

raw patch · 65 files changed

Files

• ChangeLog.md +452/−0
• Network/Wai/Handler/Warp.hs +338/−139
• Network/Wai/Handler/Warp/Buffer.hs +30/−78
• Network/Wai/Handler/Warp/Conduit.hs +48/−49
• Network/Wai/Handler/Warp/Counter.hs +42/−15
• Network/Wai/Handler/Warp/Date.hs +18/−22
• Network/Wai/Handler/Warp/FdCache.hs +100/−96
• Network/Wai/Handler/Warp/File.hs +132/−117
• Network/Wai/Handler/Warp/FileInfoCache.hs +73/−52
• Network/Wai/Handler/Warp/HTTP1.hs +306/−0
• Network/Wai/Handler/Warp/HTTP2.hs +137/−47
• Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs +0/−35
• Network/Wai/Handler/Warp/HTTP2/File.hs +33/−0
• Network/Wai/Handler/Warp/HTTP2/HPACK.hs +0/−73
• Network/Wai/Handler/Warp/HTTP2/Manager.hs +0/−86
• Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +33/−0
• Network/Wai/Handler/Warp/HTTP2/Receiver.hs +0/−345
• Network/Wai/Handler/Warp/HTTP2/Request.hs +127/−129
• Network/Wai/Handler/Warp/HTTP2/Response.hs +152/−0
• Network/Wai/Handler/Warp/HTTP2/Sender.hs +0/−426
• Network/Wai/Handler/Warp/HTTP2/Types.hs +61/−292
• Network/Wai/Handler/Warp/HTTP2/Worker.hs +0/−279
• Network/Wai/Handler/Warp/HashMap.hs +36/−0
• Network/Wai/Handler/Warp/Header.hs +74/−37
• Network/Wai/Handler/Warp/IO.hs +40/−19
• Network/Wai/Handler/Warp/IORef.hs +0/−26
• Network/Wai/Handler/Warp/Imports.hs +39/−0
• Network/Wai/Handler/Warp/Internal.hs +86/−47
• Network/Wai/Handler/Warp/MultiMap.hs +60/−209
• Network/Wai/Handler/Warp/PackInt.hs +47/−0
• Network/Wai/Handler/Warp/ReadInt.hs +12/−44
• Network/Wai/Handler/Warp/Recv.hs +0/−133
• Network/Wai/Handler/Warp/Request.hs +228/−172
• Network/Wai/Handler/Warp/RequestHeader.hs +48/−45
• Network/Wai/Handler/Warp/Response.hs +270/−212
• Network/Wai/Handler/Warp/ResponseHeader.hs +20/−31
• Network/Wai/Handler/Warp/Run.hs +391/−426
• Network/Wai/Handler/Warp/SendFile.hs +75/−70
• Network/Wai/Handler/Warp/Settings.hs +392/−114
• Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
• Network/Wai/Handler/Warp/Timeout.hs +0/−149
• Network/Wai/Handler/Warp/Types.hs +132/−78
• Network/Wai/Handler/Warp/Windows.hs +15/−8
• Network/Wai/Handler/Warp/WithApplication.hs +107/−0
• bench/Parser.hs +156/−87
• test/BufferPoolSpec.hs +0/−47
• test/ConduitSpec.hs +18/−16
• test/ConnectionSpec.hs +74/−0
• test/ExceptionSpec.hs +31/−29
• test/FdCacheSpec.hs +3/−3
• test/FileSpec.hs +106/−19
• test/GracefulShutdownSpec.hs +83/−0
• test/HTTP.hs +32/−34
• test/MultiMapSpec.hs +0/−30
• test/PackIntSpec.hs +14/−0
• test/ReadIntSpec.hs +6/−4
• test/RequestSpec.hs +98/−74
• test/ResponseHeaderSpec.hs +32/−11
• test/ResponseSpec.hs +43/−41
• test/RunSpec.hs +316/−211
• test/SendFileSpec.hs +44/−40
• test/ServerStateSpec.hs +58/−0
• test/WithApplicationSpec.hs +46/−0
• test/inputFile +100/−0
• warp.cabal +345/−180

@@ -1,3 +1,455 @@+# 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)

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}  ---------------------------------------------------------@@ -34,159 +34,198 @@ -- * call the 'pauseTimeout' function -- -- For more information, see <https://github.com/yesodweb/wai/issues/351>.------ module Network.Wai.Handler.Warp (     -- * Run a Warp server+     -- | All of these automatically serve the same 'Application' over HTTP\/1,     -- HTTP\/1.1, and HTTP\/2.-    run-  , runEnv-  , runSettings-  , runSettingsSocket-    -- * Run an HTTP\/2-aware server-    -- | Each of these takes an HTTP\/2-aware application as well as a backup-    -- 'Application' to be used for HTTP\/1.1 and HTTP\/1 connections.  These-    -- are only needed if your application needs access to HTTP\/2-specific-    -- features such as trailers or pushed streams.-  , runHTTP2-  , runHTTP2Env-  , runHTTP2Settings-  , runHTTP2SettingsSocket+    run,+    runEnv,+    runSettings,+    runSettingsSocket,+     -- * Settings-  , Settings-  , defaultSettings+    Settings,+    defaultSettings,+     -- ** Setters-  , setPort-  , setHost-  , setOnException-  , setOnExceptionResponse-  , setOnOpen-  , setOnClose-  , setTimeout-  , setManager-  , setFdCacheDuration-  , setFileInfoCacheDuration-  , setBeforeMainLoop-  , setNoParsePath-  , setInstallShutdownHandler-  , setServerName-  , setMaximumBodyFlush-  , setFork-  , setProxyProtocolNone-  , setProxyProtocolRequired-  , setProxyProtocolOptional-  , setSlowlorisSize-  , setHTTP2Disabled-  , setLogger+    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+    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+    defaultOnException,+    defaultShouldDisplayException,+     -- ** Exception response handler-  , defaultOnExceptionResponse-  , exceptionResponseForDebug+    defaultOnExceptionResponse,+    exceptionResponseForDebug,+     -- * Data types-  , HostPreference (..)-  , Port-  , InvalidRequest (..)+    HostPreference,+    Port,+    InvalidRequest (..),+     -- * Utilities-  , pauseTimeout-  , FileInfo(..)-  , getFileInfo-    -- * Internal-    -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal.+    pauseTimeout,+    FileInfo (..),+    getFileInfo,+#ifdef MIN_VERSION_crypton_x509+    clientCertificate,+#endif+    withApplication,+    withApplicationSettings,+    testWithApplication,+    testWithApplicationSettings,+    openFreePort, -    -- ** Low level run functions-  , runSettingsConnection-  , runSettingsConnectionMaker-  , runSettingsConnectionMakerSecure-  , Transport (..)-    -- ** Connection-  , Connection (..)-  , socketConnection-    -- ** Buffer-  , Buffer-  , BufSize-  , bufferSize-  , allocateBuffer-  , freeBuffer-    -- ** Sendfile-  , FileId (..)-  , SendFile-  , sendFile-  , readSendFile-    -- ** Version-  , warpVersion-    -- ** Data types-  , InternalInfo (..)-  , HeaderValue-  , IndexedHeader-  , requestMaxIndex-    -- ** File descriptor cache-  , module Network.Wai.Handler.Warp.FdCache-    -- ** Date-  , module Network.Wai.Handler.Warp.Date-    -- ** Request and response-  , Source-  , recvRequest-  , sendResponse-    -- ** Time out manager-  , module Network.Wai.Handler.Warp.Timeout-  ) where+    -- * Version+    warpVersion, -import Control.Exception (SomeException, throwIO)-import Data.ByteString (ByteString)-import Data.Maybe (fromMaybe)+    -- * 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)+import Network.Socket (SockAddr, Socket) import Network.Wai (Request, Response, vault)-import Network.Wai.Handler.Warp.Buffer-import Network.Wai.Handler.Warp.Date-import Network.Wai.Handler.Warp.FdCache+import System.TimeManager++import Network.Wai.Handler.Warp.Counter (Counter, getCount) import Network.Wai.Handler.Warp.FileInfoCache-import Network.Wai.Handler.Warp.Header+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.SendFile import Network.Wai.Handler.Warp.Settings-import Network.Wai.Handler.Warp.Timeout-import Network.Wai.Handler.Warp.Types+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 }+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 }+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 }+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 }+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.@@ -194,26 +233,32 @@ -- -- Since 2.1.0 setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings-setOnOpen x y = y { settingsOnOpen = x }+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 }+setOnClose x y = y{settingsOnClose = x} --- | Timeout value in seconds. Default value: 30+-- | "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 }+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 }+setManager x y = y{settingsManager = Just x}  -- | Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. --@@ -229,7 +274,7 @@ -- -- Since 3.0.13 setFdCacheDuration :: Int -> Settings -> Settings-setFdCacheDuration x y = y { settingsFdCacheDuration = x }+setFdCacheDuration x y = y{settingsFdCacheDuration = x}  -- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. --@@ -243,7 +288,7 @@ -- -- Default value: 0 setFileInfoCacheDuration :: Int -> Settings -> Settings-setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }+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@@ -253,7 +298,7 @@ -- -- Since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings-setBeforeMainLoop x y = y { settingsBeforeMainLoop = x }+setBeforeMainLoop x y = y{settingsBeforeMainLoop = x}  -- | Perform no parsing on the rawPathInfo. --@@ -263,7 +308,7 @@ -- -- Since 2.1.0 setNoParsePath :: Bool -> Settings -> Settings-setNoParsePath x y = y { settingsNoParsePath = x }+setNoParsePath x y = y{settingsNoParsePath = x}  -- | Get the listening port. --@@ -289,23 +334,54 @@ 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 close the listen socket, at shutdown.+-- 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 }+setInstallShutdownHandler x y = y{settingsInstallShutdownHandler = x} --- | Default server name if application does not set one.+-- | 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 }+setServerName x y = y{settingsServerName = x}  -- | The maximum number of bytes to flush from an unconsumed request body. --@@ -322,7 +398,7 @@ setMaximumBodyFlush :: Maybe Int -> Settings -> Settings setMaximumBodyFlush x y     | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive"-    | otherwise = y { settingsMaximumBodyFlush = x }+    | otherwise = y{settingsMaximumBodyFlush = x}  -- | Code to fork a new thread to accept a connection. --@@ -332,14 +408,26 @@ -- Default: void . forkIOWithUnmask -- -- Since 3.0.4-setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings-setFork fork' s = s { settingsFork = fork' }+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 }+setProxyProtocolNone y = y{settingsProxyProtocol = ProxyProtocolNone}  -- | Require PROXY header. --@@ -355,14 +443,14 @@ -- -- Since 3.0.5 setProxyProtocolRequired :: Settings -> Settings-setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }+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 accessable+-- 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@@ -371,27 +459,76 @@ -- -- Since 3.0.5 setProxyProtocolOptional :: Settings -> Settings-setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional }+setProxyProtocolOptional y = y{settingsProxyProtocol = ProxyProtocolOptional} --- | Size in bytes read to prevent Slowloris protection. Default value: 2048+-- | 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 }+setSlowlorisSize x y = y{settingsSlowlorisSize = x}  -- | Disable HTTP2. -- -- Since 3.1.7 setHTTP2Disabled :: Settings -> Settings-setHTTP2Disabled y = y { settingsHTTP2Enabled = False }+setHTTP2Disabled y = y{settingsHTTP2Enabled = False}  -- | Setting a log function. -- -- Since 3.X.X-setLogger :: (Request -> H.Status -> Maybe Integer -> IO ())-          -> Settings -> Settings-setLogger lgr y = y { settingsLogger = lgr }+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@@ -418,4 +555,66 @@ -- -- Since 3.1.10 getFileInfo :: Request -> FilePath -> IO FileInfo-getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault+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

@@ -1,36 +1,37 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}- module Network.Wai.Handler.Warp.Buffer (-    bufferSize-  , allocateBuffer-  , freeBuffer-  , mallocBS-  , newBufferPool-  , withBufferPool-  , toBuilderBuffer-  , copy-  , bufferIO-  ) where+    createWriteBuffer,+    allocateBuffer,+    freeBuffer,+    toBuilderBuffer,+    bufferIO,+) where -import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString(..), memcpy)-import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)-import Data.IORef (newIORef, readIORef, writeIORef)+import Data.IORef (IORef, readIORef) import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..)) import Foreign.ForeignPtr-import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)-import Foreign.Ptr (castPtr, plusPtr)+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  ---------------------------------------------------------------- --- | The default size of the write buffer: 16384 (2^14 = 1024 * 16).---   This is the maximum size of TLS record.---   This is also the maximum size of HTTP/2 frame payload---   (excluding frame header).-bufferSize :: BufSize-bufferSize = 16384+-- | 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@@ -40,66 +41,17 @@ freeBuffer = free  ------------------------------------------------------------------largeBufferSize :: Int-largeBufferSize = 16384--minBufferSize :: Int-minBufferSize = 2048--newBufferPool :: IO BufferPool-newBufferPool = newIORef BS.empty--mallocBS :: Int -> IO ByteString-mallocBS size = do-    ptr <- allocateBuffer size-    fptr <- newForeignPtr finalizerFree ptr-    return $! PS fptr 0 size-{-# INLINE mallocBS #-}--usefulBuffer :: ByteString -> Bool-usefulBuffer buffer = BS.length buffer >= minBufferSize-{-# INLINE usefulBuffer #-}--getBuffer :: BufferPool -> IO ByteString-getBuffer pool = do-    buffer <- readIORef pool-    if usefulBuffer buffer then return buffer else mallocBS largeBufferSize-{-# INLINE getBuffer #-}--putBuffer :: BufferPool -> ByteString -> IO ()-putBuffer pool buffer = writeIORef pool buffer-{-# INLINE putBuffer #-}--withForeignBuffer :: ByteString -> ((Buffer, BufSize) -> IO Int) -> IO Int-withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s, l)-{-# INLINE withForeignBuffer #-}--withBufferPool :: BufferPool -> ((Buffer, BufSize) -> IO Int) -> IO ByteString-withBufferPool pool f = do-    buffer <- getBuffer pool-    consumed <- withForeignBuffer buffer f-    putBuffer pool $! unsafeDrop consumed buffer-    return $! unsafeTake consumed buffer-{-# INLINE withBufferPool #-}------------------------------------------------------------------ -- -- Utilities -- -toBuilderBuffer :: Buffer -> BufSize -> IO B.Buffer-toBuilderBuffer ptr size = do+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)---- | Copying the bytestring to the buffer.---   This function returns the point where the next copy should start.-copy :: Buffer -> ByteString -> IO Buffer-copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do-    memcpy ptr (p `plusPtr` o) (fromIntegral l)-    return $! ptr `plusPtr` l-{-# INLINE copy #-}  bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO () bufferIO ptr siz io = do

@@ -2,15 +2,12 @@  module Network.Wai.Handler.Warp.Conduit where -import Control.Exception-import Control.Monad (when, unless)-import Data.ByteString (ByteString)+import Control.Exception (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I-#if __GLASGOW_HASKELL__ < 709-import Data.Word (Word)-#endif-import Data.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  ----------------------------------------------------------------@@ -33,46 +30,44 @@     if count == 0         then return S.empty         else do+            bs <- readSource src -        bs <- readSource src+            -- If no chunk available, then there aren't enough bytes in the+            -- stream. Throw a ConnectionClosedByPeer+            when (S.null bs) $ throwIO ConnectionClosedByPeer -        -- 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 -        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+            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-                    I.writeIORef ref count'                     return 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+                else do+                    -- Some of the bytes in this chunk should not be sent+                    -- downstream. Split up the chunk into the sent and+                    -- not-sent parts, add the not-sent parts onto the new+                    -- source, and send the rest of the chunk downstream.                     let (x, y) = S.splitAt toSend bs                     leftoverSource src y-                    assert (count' == 0) $ I.writeIORef ref count'-                    return x+                    assert (count' == 0) $ return x  ----------------------------------------------------------------  data CSource = CSource !Source !(I.IORef ChunkState) -data ChunkState = NeedLen-                | NeedLenNewline-                | HaveLen Word-                | DoneChunking-    deriving Show+data ChunkState+    = NeedLen+    | NeedLenNewline+    | HaveLen Word+    | DoneChunking+    deriving (Show)  mkCSource :: Source -> IO CSource mkCSource src = do@@ -110,17 +105,19 @@         bs <- readSource src         case S.uncons bs of             Nothing -> return ()-            Just (13, bs') -> dropLF bs'-            Just (10, bs') -> leftoverSource src bs'-            Just _ -> leftoverSource src bs+            Just (w8, bs')+                | w8 == _cr -> dropLF bs'+                | w8 == _lf -> leftoverSource src bs'+                | otherwise -> leftoverSource src bs      dropLF bs =         case S.uncons bs of             Nothing -> do                 bs2 <- readSource' src                 unless (S.null bs2) $ dropLF bs2-            Just (10, bs') -> leftoverSource src bs'-            Just _ -> leftoverSource src bs+            Just (w8, bs') ->+                leftoverSource src $+                    if w8 == _lf then bs' else bs      go NeedLen = getLen     go NeedLenNewline = dropCRLF >> getLen@@ -143,17 +140,18 @@                 return S.empty             else do                 (x, y) <--                    case S.break (== 10) bs of+                    case S.break (== _lf) bs of                         (x, y)                             | S.null y -> do                                 bs2 <- readSource' src-                                return $ if S.null bs2-                                    then (x, y)-                                    else S.break (== 10) $ bs `S.append` bs2+                                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+                        S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $+                            S.takeWhile isHexDigit x                  let y' = S.drop 1 y                 y'' <-@@ -163,11 +161,12 @@                 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+isHexDigit w =+    w >= _0 && w <= _9+        || w >= _A && w <= _F+        || w >= _a && w <= _f

@@ -1,31 +1,58 @@ {-# LANGUAGE CPP #-}  module Network.Wai.Handler.Warp.Counter (-    Counter-  , newCounter-  , waitForZero-  , increase-  , decrease-  ) where+    Counter,+    newCounter,+    HasDecreased (..),+    waitForZero,+    increase,+    decrease,+    waitForDecreased,+    getCount,+    getCountSTM,+) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Control.Concurrent.STM-import Control.Monad (unless) +import Network.Wai.Handler.Warp.Imports+ newtype Counter = Counter (TVar Int)  newCounter :: IO Counter newCounter = Counter <$> newTVarIO 0  waitForZero :: Counter -> IO ()-waitForZero (Counter ref) = atomically $ do-    x <- readTVar ref-    unless (x == 0) retry+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 ref) = atomically $ modifyTVar' ref $ \x -> x + 1+increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1  decrease :: Counter -> IO ()-decrease (Counter ref) = atomically $ modifyTVar' ref $ \x -> x - 1+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

@@ -1,17 +1,17 @@ {-# LANGUAGE CPP #-}  module Network.Wai.Handler.Warp.Date (-    withDateCache-  , getDate-  , DateCache-  , GMTDate-  ) where+    withDateCache,+    GMTDate,+) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)-import Data.ByteString.Char8+import Control.AutoUpdate (+    defaultUpdateSettings,+    mkAutoUpdate,+    updateAction,+    updateThreadName,+ )+import Data.ByteString import Network.HTTP.Date  #if WINDOWS@@ -25,21 +25,17 @@ -- | The type of the Date header value. type GMTDate = ByteString --- | The type of the cache of the Date header value.-type DateCache = IO GMTDate- -- | Creating 'DateCache' and executing the action.-withDateCache :: (DateCache -> IO a) -> IO a+withDateCache :: (IO GMTDate -> IO a) -> IO a withDateCache action = initialize >>= action -initialize :: IO DateCache-initialize = mkAutoUpdate defaultUpdateSettings {-                            updateAction = formatHTTPDate <$> getCurrentHTTPDate-                          }---- | Getting current 'GMTDate' based on 'DateCache'.-getDate :: DateCache -> IO GMTDate-getDate = id+initialize :: IO (IO GMTDate)+initialize =+    mkAutoUpdate+        defaultUpdateSettings+            { updateAction = formatHTTPDate <$> getCurrentHTTPDate+            , updateThreadName = "Date cacher (AutoUpdate)"+            }  #ifdef WINDOWS uToH :: UTCTime -> HTTPDate

@@ -1,47 +1,64 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}  -- | File descriptor cache to avoid locks in kernel.--#ifdef WINDOWS module Network.Wai.Handler.Warp.FdCache (-    withFdCache-  , MutableFdCache-  , Refresh-  ) where+    withFdCache,+    Fd,+    Refresh,+#ifndef WINDOWS+    closeFile,+    openFile,+    setFileCloseOnExec,+#endif+) where +#ifndef WINDOWS+import Control.Reaper+import Data.IORef+import Network.Wai.Handler.Warp.MultiMap as MM+import System.Posix.IO (+    FdOption (CloseOnExec),+    OpenFileFlags (..),+    OpenMode (ReadOnly),+    closeFd,+    defaultFileFlags,+    openFd,+    setFdOption,+ )+import Control.Exception (bracket)+#endif+import System.Posix.Types (Fd)++----------------------------------------------------------------++-- | An action to activate a Fd cache entry. type Refresh = IO ()-type MutableFdCache = () -withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a-withFdCache _ f = f Nothing-#else-module Network.Wai.Handler.Warp.FdCache (-    withFdCache-  , getFd-  , MutableFdCache-  , Refresh-  ) where+getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)+getFdNothing _ = return (Nothing, return ()) -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>), (<*>))-#endif-import Control.Exception (bracket)-import Data.Hashable (hash)-import Network.Wai.Handler.Warp.IORef-import Network.Wai.Handler.Warp.MultiMap-import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)-import System.Posix.Types (Fd)-import Control.Reaper+---------------------------------------------------------------- +-- | 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) --- | An action to activate a Fd cache entry.-type Refresh = IO ()- status :: MutableStatus -> IO Status status (MutableStatus ref) = readIORef ref @@ -56,99 +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{nonBlock=True}-              <*> newActiveStatus+newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus +setFileCloseOnExec :: Fd -> IO ()+setFileCloseOnExec fd = setFdOption fd CloseOnExec True+ ---------------------------------------------------------------- -type Hash = Int-type FdCache = MMap Hash FdEntry+type FdCache = MultiMap FdEntry  -- | Mutable Fd cacher.-type MutableFdCache = Reaper FdCache (Hash, FdEntry)+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath, FdEntry))  fdCache :: MutableFdCache -> IO FdCache-fdCache mfc = reaperRead mfc--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------------------------------------------------------------------+fdCache (MutableFdCache reaper) = reaperRead reaper --- | Creating 'MutableFdCache' and executing the action in the second---   argument. The first argument is a cache duration in second.-withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a-withFdCache duration action = bracket (initialize duration)-                                      terminate-                                      action+look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)+look mfc path = MM.lookup path <$> fdCache mfc  ---------------------------------------------------------------- --- The first argument is a cache duration in second.-initialize :: Int -> IO (Maybe MutableFdCache)-initialize 0 = return Nothing-initialize duration = Just <$> mkReaper defaultReaperSettings-    { reaperAction = clean-    , reaperDelay = duration-    , reaperCons = uncurry insert-    , reaperNull = isEmpty-    , reaperEmpty = empty-    }+-- The first argument is a cache duration in microseconds.+initialize :: Int -> IO MutableFdCache+initialize duration = MutableFdCache <$> mkReaper settings+  where+    settings =+        defaultReaperSettings+            { reaperAction = clean+            , reaperDelay = duration+            , reaperCons = uncurry insert+            , reaperNull = isEmpty+            , reaperEmpty = empty+            , reaperThreadName = "Fd cacher (Reaper) "+            }  clean :: FdCache -> IO (FdCache -> FdCache) clean old = do     new <- pruneWith old prune     return $ merge new--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'-  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+    prune (_, FdEntry fd mst) = status mst >>= act+      where+        act Active = inactive mst >> return True+        act Inactive = closeFd fd >> return False  ---------------------------------------------------------------- -terminate :: Maybe MutableFdCache -> IO ()-terminate Nothing = return ()-terminate (Just mfc) = do-    !t <- reaperStop mfc-    mapM_ closeIt $ toList t+terminate :: MutableFdCache -> IO ()+terminate (MutableFdCache reaper) = do+    !t <- reaperStop reaper+    mapM_ (closeIt . snd) $ toList t   where-    closeIt (_, FdEntry _ fd _) = closeFd fd+    closeIt (FdEntry fd _) = closeFd fd  ----------------------------------------------------------------  -- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.-getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)-getFd mfc path = look mfc path key >>= getFd'+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-        reaperAdd mfc (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

@@ -1,52 +1,74 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}  module Network.Wai.Handler.Warp.File (-    RspFileInfo(..)-  , conditionalRequest-  , addContentHeadersForFilePart-  ) where+    RspFileInfo (..),+    conditionalRequest,+    addContentHeadersForFilePart,+    H.parseByteRanges,+) where -import Control.Applicative ((<|>)) import Data.Array ((!))-import Data.ByteString (ByteString)-import qualified Data.ByteString as B hiding (pack)-import qualified Data.ByteString.Char8 as B (pack, readInteger)+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 Numeric (showInt)+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)+data RspFileInfo+    = WithoutBody H.Status+    | WithBody H.Status H.ResponseHeaders Integer Integer+    deriving (Eq, Show)  ---------------------------------------------------------------- -conditionalRequest :: I.FileInfo-                   -> H.ResponseHeaders -> IndexedHeader-                   -> RspFileInfo-conditionalRequest finfo hs0 reqidx = case condition of+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 hs = (H.hLastModified,date) :-                                       addContentHeaders hs0 off len size-                              in WithBody s hs off len+    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-    mcondition = ifmodified    reqidx size mtime-             <|> ifunmodified  reqidx size mtime-             <|> ifrange       reqidx size mtime-    condition = case mcondition of-        Nothing -> unconditional reqidx size-        Just x  -> x+    !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  ---------------------------------------------------------------- @@ -61,115 +83,107 @@  ---------------------------------------------------------------- -ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo-ifmodified reqidx size mtime = do+ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo+ifmodified reqidx mtime method = do     date <- ifModifiedSince reqidx-    return $ if date /= mtime-             then unconditional reqidx size-             else  WithoutBody H.notModified304+    -- 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 -> Integer -> HTTPDate -> Maybe RspFileInfo-ifunmodified reqidx size mtime = do+ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo+ifunmodified reqidx mtime = do     date <- ifUnmodifiedSince reqidx-    return $ if date == mtime-             then unconditional reqidx size-             else WithoutBody H.preconditionFailed412+    -- 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 -ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo-ifrange reqidx size mtime = do+-- 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-    return $ if date == mtime-             then parseRange rng size-             else WithBody H.ok200 [] 0 size+    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 size = case reqidx ! fromEnum ReqRange of-    Nothing  -> WithBody H.ok200 [] 0 size-    Just rng -> parseRange rng size+unconditional reqidx =+    case reqidx ! fromEnum ReqRange of+        Nothing -> WithBody H.ok200 [] 0+        Just rng -> parseRange rng  ----------------------------------------------------------------  parseRange :: ByteString -> Integer -> RspFileInfo-parseRange rng size = case 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+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)---- | Parse the value of a Range header into a 'H.ByteRanges'.-parseByteRanges :: B.ByteString -> Maybe H.ByteRanges-parseByteRanges bs1 = do-    bs2 <- stripPrefix "bytes=" bs1-    (r, bs3) <- range bs2-    ranges (r:) bs3-  where-    range bs2 = do-        (i, bs3) <- B.readInteger bs2-        if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")-            then Just (H.ByteRangeSuffix (negate i), bs3)-            else do-                bs4 <- stripPrefix "-" bs3-                case B.readInteger bs4 of-                    Just (j, bs5) | j >= i -> Just (H.ByteRangeFromTo i j, bs5)-                    _ -> Just (H.ByteRangeFrom i, bs4)-    ranges front bs3-        | B.null bs3 = Just (front [])-        | otherwise = do-            bs4 <- stripPrefix "," bs3-            (r, bs5) <- range bs4-            ranges (front . (r:)) bs5--    stripPrefix x y-        | x `B.isPrefixOf` y = Just (B.drop (B.length x) y)-        | otherwise = Nothing+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 = (-#if MIN_VERSION_http_types(0,9,0)-        H.hContentRange-#else-        "Content-Range"-#endif-    , range)+contentRangeHeader beg end total = (H.hContentRange, range)   where-    range = B.pack-      -- building with ShowS-      $ 'b' : 'y': 't' : 'e' : 's' : ' '-      : (if beg > end then ('*':) else-          showInt beg-          . ('-' :)-          . showInt end)-      ( '/'-      : showInt total "")+    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 = hs''+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-    contentRange = contentRangeHeader off (off + len - 1) size-    !lengthBS = B.pack $ show len-    hs' = (H.hContentLength, lengthBS):(-#if MIN_VERSION_http_types(0,9,0)-        H.hAcceptRanges-#else-        "Accept-Ranges"-#endif-        , "bytes"):hs-    hs'' = if len == size then hs' else contentRange:hs'+    !lengthBS = packIntegral len+    !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges, "bytes") : hs  -- | --@@ -177,7 +191,8 @@ -- [("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+    :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders addContentHeadersForFilePart hs part = addContentHeaders hs off len size   where     off = filePartOffset part

@@ -1,33 +1,41 @@-{-# LANGUAGE RecordWildCards, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}  module Network.Wai.Handler.Warp.FileInfoCache (-    FileInfo(..)-  , withFileInfoCache-  , getInfo -- test purpose only-  ) where+    FileInfo (..),+    withFileInfoCache,+    getInfo, -- test purpose only+) where -import Control.Exception as E-import Control.Monad (void)+import Control.Exception (bracket, onException, throwIO) import Control.Reaper-import Data.ByteString (ByteString)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M 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 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 FilePath Entry-type FileInfoCache = Reaper Cache (FilePath,Entry)+type Cache = HashMap Entry+type FileInfoCache = Reaper Cache (FilePath, Entry)  ---------------------------------------------------------------- @@ -37,62 +45,75 @@     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")+    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@Reaper{..} path = do-    cache <- reaperRead+getAndRegisterInfo reaper path = do+    cache <- reaperRead reaper     case M.lookup path cache of-        Just Negative     -> throwIO (userError "FileInfoCache:getAndRegisterInfo")+        Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")         Just (Positive x) -> return x-        Nothing           -> positive reaper path `E.onException` negative reaper path+        Nothing ->+            positive reaper path+                `onException` negative reaper path  positive :: FileInfoCache -> FilePath -> IO FileInfo-positive Reaper{..} path = do+positive reaper path = do     info <- getInfo path-    reaperAdd (path, Positive info)+    reaperAdd reaper (path, Positive info)     return info  negative :: FileInfoCache -> FilePath -> IO FileInfo-negative Reaper{..} path = do-    reaperAdd (path,Negative)+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 second.-withFileInfoCache :: Int -> ((FilePath -> IO FileInfo) -> IO a) -> IO a-withFileInfoCache 0        action = action getInfo-withFileInfoCache duration action = E.bracket (initialize duration)-                                              terminate-                                              (\c -> action (getAndRegisterInfo c))+--   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 * 1000000-      , reaperCons   = uncurry M.insert-      , reaperNull   = M.null-      , reaperEmpty  = M.empty-      }+    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

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

@@ -1,68 +1,158 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} -module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where+module Network.Wai.Handler.Warp.HTTP2 (+    http2,+    http2server,+) where -import Control.Concurrent (forkIO, killThread) import qualified Control.Exception as E-import Control.Monad (when, unless, replicateM_)-import Data.ByteString (ByteString)--import Network.HTTP2+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.HTTP2 (HTTP2Application)-import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.Manager-import Network.Wai.Handler.Warp.HTTP2.Receiver+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.Sender-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.HTTP2.Worker-import qualified Network.Wai.Handler.Warp.Settings as S (Settings)+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 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> HTTP2Application -> IO ()-http2 conn ii addr transport settings readN app = do+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-    ok <- checkPreface-    when ok $ do-        ctx <- newContext-        -- Workers & Manager-        mgr <- start-        let responder = response ctx mgr-            action = worker ctx settings tm app responder-        setAction mgr action-        -- fixme: hard coding: 10-        replicateM_ 10 $ spawnAction mgr-        -- Receiver-        let mkreq = mkRequest ii settings addr-        tid <- forkIO $ frameReceiver ctx mkreq readN-        -- Sender-        -- frameSender is the main thread because it ensures to send-        -- a goway frame.-        frameSender ctx conn ii settings `E.finally` do-            clearContext ctx-            stop mgr-            killThread tid+    setConnHTTP2 conn True+    H2.run H2.defaultServerConfig conf $+        http2server "Warp HTTP/2" settings ii transport peersa app   where-    tm = timeoutManager ii     checkTLS = case transport of         TCP -> return () -- direct-        tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"+        tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"     tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3-    checkPreface = do-        preface <- readN connectionPrefaceLength-        if connectionPreface /= preface then do-            goaway conn ProtocolError "Preface mismatch"-            return False-          else-            return True +-- | 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 -> ErrorCodeId -> ByteString -> IO ()+goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO () goaway Connection{..} etype debugmsg = connSendAll bytestream   where-    bytestream = goawayFrame 0 etype debugmsg+    einfo = H2.encodeInfo id 0+    frame = H2.GoAwayFrame 0 etype debugmsg+    bytestream = H2.encodeFrame einfo frame

@@ -1,35 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where--import Data.ByteString (ByteString)-import Network.HTTP2--------------------------------------------------------------------goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString-goawayFrame sid etype debugmsg = encodeFrame einfo frame-  where-    einfo = encodeInfo id 0-    frame = GoAwayFrame sid etype debugmsg--resetFrame :: ErrorCodeId -> StreamId -> ByteString-resetFrame etype sid = encodeFrame einfo frame-  where-    einfo = encodeInfo id sid-    frame = RSTStreamFrame etype--settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString-settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist-  where-    einfo = encodeInfo func 0--pingFrame :: ByteString -> ByteString-pingFrame bs = encodeFrame einfo $ PingFrame bs-  where-    einfo = encodeInfo setAck 0--windowUpdateFrame :: StreamId -> WindowSize -> ByteString-windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz-  where-    einfo = encodeInfo id sid

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

@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NamedFieldPuns #-}--module Network.Wai.Handler.Warp.HTTP2.HPACK where--import Control.Arrow (first)-import qualified Control.Exception as E-import qualified Data.ByteString as B-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Char8 as B8-import Data.CaseInsensitive (foldedCase)-import Data.IORef (readIORef, writeIORef)-import Network.HPACK-import qualified Network.HTTP.Types as H-import Network.HTTP2-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.Header-import Network.Wai.Handler.Warp.Response-import qualified Network.Wai.Handler.Warp.Settings as S-import Network.Wai.Handler.Warp.Types---- $setup--- >>> :set -XOverloadedStrings---- Set-Cookie: contains only one cookie value.--- So, we don't need to split it.-hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> H.Status-                  -> H.ResponseHeaders -> IO Builder-hpackEncodeHeader ctx ii settings s h = do-    hdr1 <- addServerAndDate h-    let hdr2 = (":status", status) : map (first foldedCase) hdr1-    hpackEncodeRawHeaders ctx hdr2-  where-    status = B8.pack $ show $ H.statusCode $ s-    dc = dateCacher ii-    rspidxhdr = indexResponseHeader h-    defServer = S.settingsServerName settings-    addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr--hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder-hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase)--hpackEncodeRawHeaders :: Context -> [(B.ByteString, B.ByteString)] -> IO Builder-hpackEncodeRawHeaders Context{encodeDynamicTable} hdr = do-    ehdrtbl <- readIORef encodeDynamicTable-    (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr-    writeIORef encodeDynamicTable ehdrtbl'-    return builder--------------------------------------------------------------------hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList-hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do-    hdrtbl <- readIORef decodeDynamicTable-    (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup-    writeIORef decodeDynamicTable hdrtbl'-    return $ concatCookie hdr-  where-    cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"---- |------ >>> concatCookie [("foo","bar")]--- [("foo","bar")]--- >>> concatCookie [("cookie","a=b"),("foo","bar"),("cookie","c=d"),("cookie","e=f")]--- [("foo","bar"),("cookie","a=b; c=d; e=f")]-concatCookie :: HeaderList -> HeaderList-concatCookie = collect []-  where-    collect cookies (("cookie",c):rest) = collect (cookies ++ [c]) rest-    collect cookies (h:rest) = h : collect cookies rest-    collect [] [] = []-    collect cookies [] = [("cookie", B.intercalate "; " cookies)]

@@ -1,86 +0,0 @@-{-# LANGUAGE CPP #-}---- | A thread pool manager.---   The manager has responsibility to spawn and kill---   worker threads.-module Network.Wai.Handler.Warp.HTTP2.Manager (-    Manager-  , start-  , setAction-  , stop-  , spawnAction-  , replaceWithAction-  ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad (void)-import Data.Set (Set)-import qualified Data.Set as Set-import Network.Wai.Handler.Warp.IORef--------------------------------------------------------------------data Command = Stop | Spawn | Replace ThreadId--data Manager = Manager (TQueue Command) (IORef (IO ()))---- | Starting a thread pool manager.---   Its action is initially set to 'return ()' and should be set---   by 'setAction'. This allows that the action can include---   the manager itself.-start :: IO Manager-start = do-    tset <- newThreadSet-    q <- newTQueueIO-    ref <- newIORef (return ())-    void $ forkIO $ go q tset ref-    return $ Manager q ref-  where-    go q tset ref = do-        x <- atomically $ readTQueue q-        case x of-            Stop           -> kill tset-            Spawn          -> next-            Replace oldtid -> do-                del tset oldtid-                next-      where-        next = do-            action <- readIORef ref-            newtid <- forkIO action-            add tset newtid-            go q tset ref--setAction :: Manager -> IO () -> IO ()-setAction (Manager _ ref) action = writeIORef ref action--stop :: Manager -> IO ()-stop (Manager q _) = atomically $ writeTQueue q Stop--spawnAction :: Manager -> IO ()-spawnAction (Manager q _) = atomically $ writeTQueue q Spawn--replaceWithAction :: Manager -> ThreadId -> IO ()-replaceWithAction (Manager q _) tid = atomically $ writeTQueue q $ Replace tid--------------------------------------------------------------------newtype ThreadSet = ThreadSet (IORef (Set ThreadId))--newThreadSet :: IO ThreadSet-newThreadSet = ThreadSet <$> newIORef Set.empty--add :: ThreadSet -> ThreadId -> IO ()-add (ThreadSet ref) tid =-    atomicModifyIORef' ref (\set -> (Set.insert tid set, ()))--del :: ThreadSet -> ThreadId -> IO ()-del (ThreadSet ref) tid =-    atomicModifyIORef' ref (\set -> (Set.delete tid set, ()))--kill :: ThreadSet -> IO ()-kill (ThreadSet ref) = Set.toList <$> readIORef ref >>= mapM_ killThread

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

@@ -1,345 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-}--module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Monad (when, unless, void)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Maybe (isJust)-import Network.HTTP2-import Network.HTTP2.Priority-import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.HPACK-import Network.Wai.Handler.Warp.HTTP2.Request-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.IORef-import Network.Wai.Handler.Warp.Types--------------------------------------------------------------------frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()-frameReceiver ctx mkreq recvN = loop `E.catch` sendGoaway-  where-    Context{ http2settings-           , streamTable-           , concurrency-           , continued-           , currentStreamId-           , inputQ-           , outputQ-           } = ctx-    sendGoaway e-      | Just (ConnectionError err msg) <- E.fromException e = do-          csid <- readIORef currentStreamId-          let frame = goawayFrame csid err msg-          enqueueControl outputQ 0 $ OGoaway frame-      | otherwise = return ()--    sendReset err sid = do-        let frame = resetFrame err sid-        enqueueControl outputQ 0 $ OFrame frame--    loop = do-        hd <- recvN frameHeaderLength-        if BS.null hd then-            enqueueControl outputQ 0 OFinish-          else do-            cont <- processStreamGuardingError $ decodeFrameHeader hd-            when cont loop--    processStreamGuardingError (FrameHeaders, FrameHeader{streamId})-      | isResponse streamId = E.throwIO $ ConnectionError ProtocolError "stream id should be odd"-    processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do-        mx <- readIORef continued-        case mx of-            Nothing -> do-                -- ignoring unknown frame-                consume payloadLength-                return True-            Just _  -> E.throwIO $ ConnectionError ProtocolError "unknown frame"-    processStreamGuardingError (FramePushPromise, _) =-        E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"-    processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do-        settings <- readIORef http2settings-        case checkFrameHeader settings typhdr of-            Left h2err -> case h2err of-                StreamError err sid -> do-                    sendReset err sid-                    consume payloadLength-                    return True-                connErr -> E.throwIO connErr-            Right _ -> do-                ex <- E.try $ controlOrStream ftyp header-                case ex of-                    Left (StreamError err sid) -> do-                        sendReset err sid-                        return True-                    Left connErr -> E.throw connErr-                    Right cont -> return cont--    controlOrStream ftyp header@FrameHeader{streamId, payloadLength}-      | isControl streamId = do-          pl <- recvN payloadLength-          control ftyp header pl ctx-      | otherwise = do-          checkContinued-          strm@Stream{streamState,streamContentLength,streamPrecedence} <- getStream-          pl <- recvN payloadLength-          state <- readIORef streamState-          state' <- stream ftyp header pl ctx state strm-          case state' of-              Open (NoBody hdr pri) -> do-                  resetContinued-                  case validateHeaders hdr of-                      Just vh -> do-                          when (isJust (vhCL vh) && vhCL vh /= Just 0) $-                              E.throwIO $ StreamError ProtocolError streamId-                          writeIORef streamPrecedence $ toPrecedence pri-                          writeIORef streamState HalfClosed-                          let req = mkreq vh (return "")-                          atomically $ writeTQueue inputQ $ Input strm req-                      Nothing -> E.throwIO $ StreamError ProtocolError streamId-              Open (HasBody hdr pri) -> do-                  resetContinued-                  case validateHeaders hdr of-                      Just vh -> do-                          q <- newTQueueIO-                          writeIORef streamPrecedence $ toPrecedence pri-                          writeIORef streamState (Open (Body q))-                          writeIORef streamContentLength $ vhCL vh-                          readQ <- newReadBody q-                          bodySource <- mkSource readQ-                          let req = mkreq vh (readSource bodySource)-                          atomically $ writeTQueue inputQ $ Input strm req-                      Nothing -> E.throwIO $ StreamError ProtocolError streamId-              s@(Open Continued{}) -> do-                  setContinued-                  writeIORef streamState s-              s -> do -- Idle, Open Body, HalfClosed, Closed-                  resetContinued-                  writeIORef streamState s-          return True-       where-         setContinued = writeIORef continued (Just streamId)-         resetContinued = writeIORef continued Nothing-         checkContinued = do-             mx <- readIORef continued-             case mx of-                 Nothing  -> return ()-                 Just sid-                   | sid == streamId && ftyp == FrameContinuation -> return ()-                   | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"-         getStream = do-             mstrm0 <- search streamTable streamId-             case mstrm0 of-                 Just strm0 -> do-                     when (ftyp == FrameHeaders) $ do-                         st <- readIORef $ streamState strm0-                         when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed"-                     return strm0-                 Nothing    -> do-                     when (ftyp `notElem` [FrameHeaders,FramePriority]) $-                         E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream"-                     when (ftyp == FrameHeaders) $ do-                         csid <- readIORef currentStreamId-                         if streamId <= csid then-                             E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"-                           else-                             writeIORef currentStreamId streamId-                         cnt <- readIORef concurrency-                         when (cnt >= recommendedConcurrency) $ do-                             -- Record that the stream is closed, rather than-                             -- idle, so that receiving frames on it is only a-                             -- stream error.-                             consume payloadLength-                             strm <- newStream concurrency streamId 0-                             writeIORef (streamState strm) $ Closed $-                                 ResetByMe $ E.toException $-                                     StreamError RefusedStream streamId-                             insert streamTable streamId strm-                             E.throwIO $ StreamError RefusedStream streamId-                     ws <- initialWindowSize <$> readIORef http2settings-                     newstrm <- newStream concurrency streamId (fromIntegral ws)-                     when (ftyp == FrameHeaders) $ opened newstrm-                     insert streamTable streamId newstrm-                     return newstrm--    consume = void . recvN--------------------------------------------------------------------control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool-control FrameSettings header@FrameHeader{flags} bs Context{http2settings, outputQ} = do-    SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs-    case checkSettingsList alist of-        Just x  -> E.throwIO x-        Nothing -> return ()-    unless (testAck flags) $ do-        modifyIORef http2settings $ \old -> updateSettings old alist-        let frame = settingsFrame setAck []-        enqueueControl outputQ 0 $ OSettings frame alist-    return True--control FramePing FrameHeader{flags} bs Context{outputQ} =-    if testAck flags then-        E.throwIO $ ConnectionError ProtocolError "the ack flag of this ping frame must not be set"-      else do-        let frame = pingFrame bs-        enqueueControl outputQ 0 $ OFrame frame-        return True--control FrameGoAway _ _ Context{outputQ} = do-    enqueueControl outputQ 0 OFinish-    return False--control FrameWindowUpdate header bs Context{connectionWindow} = do-    WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs-    w <- (n +) <$> atomically (readTVar connectionWindow)-    when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"-    atomically $ writeTVar connectionWindow w-    return True--control _ _ _ _ =-    -- must not reach here-    return False--------------------------------------------------------------------guardIt :: Either HTTP2Error a -> IO a-guardIt x = case x of-    Left err    -> E.throwIO err-    Right frame -> return frame--checkPriority :: Priority -> StreamId -> IO ()-checkPriority p me-  | dep == me = E.throwIO $ StreamError ProtocolError me-  | otherwise = return ()-  where-    dep = streamDependency p--stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState-stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do-    HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs-    pri <- case mp of-        Nothing -> return defaultPriority-        Just p  -> do-            checkPriority p streamNumber-            return p-    let endOfStream = testEndStream flags-        endOfHeader = testEndHeader flags-    if endOfHeader then do-        hdr <- hpackDecodeHeader frag ctx-        return $ if endOfStream then-                    Open (NoBody hdr pri)-                   else-                    Open (HasBody hdr pri)-      else do-        let !siz = BS.length frag-        return $ Open $ Continued [frag] siz 1 endOfStream pri--stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q)) _ = do-    -- trailer is not supported.-    -- let's read and ignore it.-    HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs-    let endOfStream = testEndStream flags-    if endOfStream then do-        atomically $ writeTQueue q ""-        return HalfClosed-      else-        -- we don't support continuation here.-        E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"--stream FrameData-       header@FrameHeader{flags,payloadLength,streamId}-       bs-       Context{outputQ} s@(Open (Body q))-       Stream{streamNumber,streamBodyLength,streamContentLength} = do-    DataFrame body <- guardIt $ decodeDataFrame header bs-    let endOfStream = testEndStream flags-    len0 <- readIORef streamBodyLength-    let !len = len0 + payloadLength-    writeIORef streamBodyLength len-    when (payloadLength /= 0) $ do-        let frame1 = windowUpdateFrame 0 payloadLength-            frame2 = windowUpdateFrame streamNumber payloadLength-            frame = frame1 `BS.append` frame2-        enqueueControl outputQ 0 $ OFrame frame-    atomically $ writeTQueue q body-    if endOfStream then do-        mcl <- readIORef streamContentLength-        case mcl of-            Nothing -> return ()-            Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId-        atomically $ writeTQueue q ""-        return HalfClosed-      else-        return s--stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do-    let endOfHeader = testEndHeader flags-        rfrags' = frag : rfrags-        siz' = siz + BS.length frag-        n' = n + 1-    when (siz' > 51200) $ -- fixme: hard coding: 50K-      E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"-    when (n' > 10) $ -- fixme: hard coding-      E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"-    if endOfHeader then do-        let hdrblk = BS.concat $ reverse rfrags'-        hdr <- hpackDecodeHeader hdrblk ctx-        return $ if endOfStream then-                    Open (NoBody hdr pri)-                   else-                    Open (HasBody hdr pri)-      else-        return $ Open $ Continued rfrags' siz' n' endOfStream pri--stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do-    WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs-    w <- (n +) <$> atomically (readTVar streamWindow)-    when (isWindowOverflow w) $-        E.throwIO $ StreamError FlowControlError streamId-    atomically $ writeTVar streamWindow w-    return s--stream FrameRSTStream header bs _ _ strm = do-    RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs-    let cc = Reset e-    closed strm cc-    return $ Closed cc -- will be written to streamState again--stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do-    PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs-    checkPriority newpri streamNumber-    -- checkme: this should be tested-    oldpre <- readIORef streamPrecedence-    let !newpre = toPrecedence newpri-    writeIORef streamPrecedence newpre-    if isIdle s then do-        n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))-        -- fixme hard coding-        when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"-        prepare outputQ streamNumber newpri-      else do-        mx <- delete outputQ streamNumber oldpre-        case mx of-            Nothing -> return ()-            Just x  -> enqueue outputQ streamNumber newpre x-    return s---- this ordering is important-stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"-stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"--- Ignore frames to streams we have just reset, per section 5.1.-stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st-stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId-stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId

@@ -1,151 +1,149 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}  module Network.Wai.Handler.Warp.HTTP2.Request (-    mkRequest-  , newReadBody-  , MkReq-  , ValidHeaders(..)-  , validateHeaders-  ) where+    toRequest,+    getHTTP2Data,+    setHTTP2Data,+    modifyHTTP2Data,+) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif-import Control.Concurrent.STM-import Control.Monad (when)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as B8-import Data.CaseInsensitive (mk)-import Data.IORef (IORef, readIORef, newIORef, writeIORef)-import Data.Maybe (isJust)+import Control.Arrow (first)+import qualified Data.ByteString.Char8 as C8+import Data.IORef import qualified Data.Vault.Lazy as Vault-#if __GLASGOW_HASKELL__ < 709-import Data.Monoid (mempty)-#endif-import Data.Word8 (isUpper,_colon) import Network.HPACK-import Network.HTTP.Types (RequestHeaders,hRange)+import Network.HPACK.Token import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai-import Network.Wai.Internal (Request(..))-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.ReadInt-import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)-import Network.Wai.Handler.Warp.Types (InternalInfo(..))-import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)-import qualified Network.Wai.Handler.Warp.Timeout as Timeout--data ValidHeaders = ValidHeaders {-    vhMethod :: ByteString-  , vhPath   :: ByteString-  , vhAuth   :: Maybe ByteString-  , vhCL     :: Maybe Int -- ^ Content-Length-  , vhHeader :: RequestHeaders-  }+import System.IO.Unsafe (unsafePerformIO)+import qualified System.TimeManager as T -type MkReq = ValidHeaders -> IO ByteString -> Request+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 -mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq-mkRequest ii settings addr (ValidHeaders m p ma _ hdr) body = req-  where-    (unparsedPath,query) = B8.break (=='?') p-    path = H.extractPath unparsedPath-    req = Request {-        requestMethod = m-      , httpVersion = http2ver-      , rawPathInfo = if S.settingsNoParsePath settings then unparsedPath else path-      , pathInfo = H.decodePathSegments path-      , rawQueryString = query-      , queryString = H.parseQuery query-      , requestHeaders = case ma of-                           Nothing -> hdr-                           Just h  -> (mk "host", h) : hdr-      , isSecure = True-      , remoteHost = addr-      , requestBody = body-      , vault = vaultValue-      , requestBodyLength = ChunkedBody -- fixme-      , requestHeaderHost = ma-      , requestHeaderRange = lookup hRange hdr-      }-    th = threadHandle ii-    vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)-               $ Vault.insert getFileInfoKey (fileInfo ii)-                 Vault.empty+type ToReq =+    (TokenHeaderList, ValueTable)+    -> Maybe Int+    -> IO ByteString+    -> T.Handle+    -> Transport+    -> IO Request  ---------------------------------------------------------------- -data Pseudo = Pseudo {-    colonMethod :: !(Maybe ByteString)-  , colonPath   :: !(Maybe ByteString)-  , colonAuth   :: !(Maybe ByteString)-  , contentLen  :: !(Maybe ByteString)-  }+http30 :: H.HttpVersion+http30 = H.HttpVersion 3 0 -emptyPseudo :: Pseudo-emptyPseudo = Pseudo Nothing Nothing Nothing Nothing+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 -validateHeaders :: HeaderList -> Maybe ValidHeaders-validateHeaders hs = case pseudo hs (emptyPseudo,id) of-    Just (Pseudo (Just m) (Just p) ma mcl, h)-        -> Just $ ValidHeaders m p ma (readInt <$> mcl) h-    _   -> Nothing+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-    pseudo [] (p,b)       = Just (p,b [])-    pseudo h@((k,v):kvs) (p,b)-      | k == ":method"    = if isJust (colonMethod p) then-                                Nothing-                              else-                                pseudo kvs (p { colonMethod = Just v },b)-      | k == ":path"      = if isJust (colonPath p) then-                                Nothing-                              else-                                pseudo kvs (p { colonPath   = Just v },b)-      | k == ":authority" = if isJust (colonAuth p) then-                                Nothing-                              else-                                pseudo kvs (p { colonAuth   = Just v },b)-      | k == ":scheme"    = pseudo kvs (p,b) -- fixme: how to store :scheme?-      | isPseudo k        = Nothing-      | otherwise         = normal h (p,b)+    !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 -    normal [] (p,b)       = Just (p,b [])-    normal ((k,v):kvs) (p,b)-      | isPseudo k        = Nothing-      | k == "connection" = Nothing-      | k == "te"         = if v == "trailers" then-                                normal kvs (p, b . ((mk k,v) :))-                              else-                                Nothing-      | k == "content-length"-                          = normal kvs (p { contentLen = Just v }, b . ((mk k,v) :))-      | k == "host"       = if isJust (colonAuth p) then-                                normal kvs (p,b)-                              else-                                normal kvs (p { colonAuth = Just v },b)-      | otherwise         = case BS.find isUpper k of-                                 Nothing -> normal kvs (p, b . ((mk k,v) :))-                                 Just _  -> Nothing+getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))+getHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE getHTTP2DataKey #-} -    isPseudo "" = False-    isPseudo k  = BS.head k == _colon+-- | 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 -newReadBody :: TQueue ByteString -> IO (IO ByteString)-newReadBody q = do-    ref <- newIORef False-    return $ readBody q ref+modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ())+modifyHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE modifyHTTP2DataKey #-} -readBody :: TQueue ByteString -> IORef Bool -> IO ByteString-readBody q ref = do-    eof <- readIORef ref-    if eof then-        return ""-      else do-        bs <- atomically $ readTQueue q-        when (bs == "") $ writeIORef ref True-        return bs+-- | 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

@@ -1,426 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns, CPP #-}-{-# LANGUAGE NamedFieldPuns #-}--module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.Concurrent.MVar (putMVar)-import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Monad (void, when)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Builder as B (int32BE)-import qualified Data.ByteString.Builder.Extra as B-import Data.Monoid ((<>))-import Foreign.Ptr-import qualified Network.HTTP.Types as H-import Network.HPACK (setLimitForEncoding)-import Network.HTTP2-import Network.HTTP2.Priority-import Network.Wai (FilePart(..))-import Network.Wai.HTTP2 (Trailers, promiseHeaders)-import Network.Wai.Handler.Warp.Buffer-import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.HPACK-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.IORef-import qualified Network.Wai.Handler.Warp.Settings as S-import Network.Wai.Handler.Warp.Types--#ifdef WINDOWS-import qualified System.IO as IO-#else-import Network.Wai.Handler.Warp.FdCache (getFd)-import Network.Wai.Handler.Warp.SendFile (positionRead)-import qualified Network.Wai.Handler.Warp.Timeout as T-import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)-import System.Posix.Types (Fd)-#endif---------------------------------------------------------------------- | The platform-specific type of an open file to stream from.  On Windows we--- don't have pread, so this is just a Handle; on Unix platforms with pread,--- this is a file descriptor supplied by the fd cache.-#ifdef WINDOWS-type OpenFile = IO.Handle-#else-type OpenFile = Fd-#endif--data Leftover = LZero-              | LOne B.BufferWriter-              | LTwo BS.ByteString B.BufferWriter-              | LFile OpenFile Integer Integer (IO ())---------------------------------------------------------------------- | Run the given action if the stream is not closed; handle any exceptions by--- resetting the stream.-unlessClosed :: Connection -> Stream -> IO () -> IO Bool-unlessClosed Connection{connSendAll}-             strm@Stream{streamState,streamNumber}-             body = E.handle resetStream $ do-    state <- readIORef streamState-    if (isClosed state) then return False else body >> return True-  where-    resetStream e = do-        closed strm (ResetByMe e)-        let rst = resetFrame InternalError streamNumber-        connSendAll rst-        return False--getWindowSize :: TVar WindowSize -> TVar WindowSize -> IO WindowSize-getWindowSize connWindow strmWindow = do-   -- Waiting that the connection window gets open.-   cw <- atomically $ do-       w <- readTVar connWindow-       check (w > 0)-       return w-   -- This stream window is greater than 0 thanks to the invariant.-   sw <- atomically $ readTVar strmWindow-   return $ min cw sw--frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> IO ()-frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable}-            conn@Connection{connWriteBuffer,connBufferSize,connSendAll}-            ii settings = go `E.catch` ignore-  where-    initialSettings = [(SettingsMaxConcurrentStreams,recommendedConcurrency)]-    initialFrame = settingsFrame id initialSettings-    bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength-    headerPayloadLim = connBufferSize - frameHeaderLength--    go = do-        connSendAll initialFrame-        loop--    -- ignoring the old priority because the value might be changed.-    loop = dequeue outputQ >>= \(_sid,pre,out) -> switch out pre--    ignore :: E.SomeException -> IO ()-    ignore _ = return ()--    switch OFinish         _ = return ()-    switch (OGoaway frame) _ = connSendAll frame-    switch (OSettings frame alist) _ = do-        connSendAll frame-        case lookup SettingsHeaderTableSize alist of-            Nothing  -> return ()-            Just siz -> do-                dyntbl <- readIORef encodeDynamicTable-                setLimitForEncoding siz dyntbl-        loop-    switch (OFrame frame)  _ = do-        connSendAll frame-        loop-    switch (OResponse strm s h aux) pre = do-        writeIORef (streamPrecedence strm) pre -- fixme-        _ <- unlessClosed conn strm $-            getWindowSize connectionWindow (streamWindow strm) >>=-                sendResponse strm s h aux-        loop-    switch (ONext strm curr) pre = do-        writeIORef (streamPrecedence strm) pre-        _ <- unlessClosed conn strm $ do-            lim <- getWindowSize connectionWindow (streamWindow strm)-            -- Data frame payload-            Next datPayloadLen mnext <- curr lim-            fillDataHeaderSend strm 0 datPayloadLen-            dispatchNext strm mnext-        loop-    switch (OPush oldStrm push mvar strm s h aux) pre = do-        writeIORef (streamPrecedence strm) pre -- fixme-        pushed <- unlessClosed conn oldStrm $ do-            lim <- getWindowSize connectionWindow (streamWindow strm)-            -- Write and send the promise.-            builder <- hpackEncodeCIHeaders ctx $ promiseHeaders push-            off <- pushContinue (streamNumber oldStrm) (streamNumber strm) builder-            flushN $ off + frameHeaderLength-            -- TODO(awpr): refactor sendResponse to be able to handle non-zero-            -- initial offsets and use that to potentially avoid the extra syscall.-            sendResponse strm s h aux lim-        putMVar mvar pushed-        loop--    -- Send the response headers and as much of the response as is immediately-    -- available; shared by normal responses and pushed streams.-    sendResponse :: Stream -> H.Status -> H.ResponseHeaders -> Aux -> WindowSize -> IO ()-    sendResponse strm s h (Persist sq tvar) lim = do-        -- Header frame and Continuation frame-        let sid = streamNumber strm-        builder <- hpackEncodeHeader ctx ii settings s h-        len <- headerContinue sid builder False-        let total = len + frameHeaderLength-        (off, needSend) <- sendHeadersIfNecessary total-        let payloadOff = off + frameHeaderLength-        Next datPayloadLen mnext <--            fillStreamBodyGetNext ii conn payloadOff lim sq tvar strm-        -- If no data was immediately available, avoid sending an-        -- empty data frame.-        if datPayloadLen > 0 then-            fillDataHeaderSend strm total datPayloadLen-          else-            when needSend $ flushN off-        dispatchNext strm mnext--    -- Send the stream's trailers and close the stream.-    sendTrailers :: Stream -> Trailers -> IO ()-    sendTrailers strm trailers = do-        -- Trailers always indicate the end of a stream; send them in-        -- consecutive header+continuation frames and end the stream.  Some-        -- clients dislike empty headers frames, so end the stream with an-        -- empty data frame instead, as recommended by the spec.-        toFlush <- case trailers of-            [] -> frameHeaderLength <$ fillFrameHeader FrameData 0-                    (streamNumber strm)-                    (setEndStream defaultFlags)-                    connWriteBuffer-            _ -> do-                builder <- hpackEncodeCIHeaders ctx trailers-                off <- headerContinue (streamNumber strm) builder True-                return (off + frameHeaderLength)-        -- 'closed' must be before 'flushN'. If not, the context would be-        -- switched to the receiver, resulting in the inconsistency of-        -- concurrency.-        closed strm Finished-        flushN toFlush--    -- Flush the connection buffer to the socket, where the first 'n' bytes of-    -- the buffer are filled.-    flushN :: Int -> IO ()-    flushN n = bufferIO connWriteBuffer n connSendAll--    -- A flags value with the end-header flag set iff the argument is B.Done.-    maybeEndHeaders B.Done = setEndHeader defaultFlags-    maybeEndHeaders _      = defaultFlags--    -- Write PUSH_PROMISE and possibly CONTINUATION frames into the connection-    -- buffer, using the given builder as their contents; flush them to the-    -- socket as necessary.-    pushContinue sid newSid builder = do-        let builder' = B.int32BE (fromIntegral newSid) <> builder-        (len, signal) <- B.runBuilder builder' bufHeaderPayload headerPayloadLim-        let flag = maybeEndHeaders signal-        fillFrameHeader FramePushPromise len sid flag connWriteBuffer-        continue sid len signal--    -- Write HEADER and possibly CONTINUATION frames.-    headerContinue sid builder endOfStream = do-        (len, signal) <- B.runBuilder builder bufHeaderPayload headerPayloadLim-        let flag0 = maybeEndHeaders signal-            flag = if endOfStream then setEndStream flag0 else flag0-        fillFrameHeader FrameHeaders len sid flag connWriteBuffer-        continue sid len signal--    continue _   len B.Done = return len-    continue sid len (B.More _ writer) = do-        flushN $ len + frameHeaderLength-        (len', signal') <- writer bufHeaderPayload headerPayloadLim-        let flag = maybeEndHeaders signal'-        fillFrameHeader FrameContinuation len' sid flag connWriteBuffer-        continue sid len' signal'-    continue sid len (B.Chunk bs writer) = do-        flushN $ len + frameHeaderLength-        let (bs1,bs2) = BS.splitAt headerPayloadLim bs-            len' = BS.length bs1-        void $ copy bufHeaderPayload bs1-        fillFrameHeader FrameContinuation len' sid defaultFlags connWriteBuffer-        if bs2 == "" then-            continue sid len' (B.More 0 writer)-          else-            continue sid len' (B.Chunk bs2 writer)--    -- True if the connection buffer has room for a 1-byte data frame.-    canFitDataFrame total = total + frameHeaderLength < connBufferSize--    -- Take the appropriate action based on the given 'Control':-    -- - If more output is immediately available, re-enqueue the stream in the-    -- output queue.-    -- - If the output is over and trailers are available, send them now and-    -- end the stream.-    -- - If we've drained the queue and handed the stream back to its waiter,-    -- do nothing.-    ---    -- This is done after sending any part of the stream body, so it's shared-    -- by 'sendResponse' and @switch (ONext ...)@.-    dispatchNext :: Stream -> Control DynaNext -> IO ()-    dispatchNext _    CNone              = return ()-    dispatchNext strm (CFinish trailers) = sendTrailers strm trailers-    dispatchNext strm (CNext next)       = do-        let out = ONext strm next-        enqueueOrSpawnTemporaryWaiter strm outputQ out---    -- Send headers if there is not room for a 1-byte data frame, and return-    -- the offset of the next frame's first header byte and whether the headers-    -- still need to be sent.-    sendHeadersIfNecessary total-      | canFitDataFrame total = return (total, True)-      | otherwise             = do-          flushN total-          return (0, False)--    fillDataHeaderSend strm otherLen datPayloadLen = do-        -- Data frame header-        let sid = streamNumber strm-            buf = connWriteBuffer `plusPtr` otherLen-            total = otherLen + frameHeaderLength + datPayloadLen-        fillFrameHeader FrameData datPayloadLen sid defaultFlags buf-        flushN total-        atomically $ do-           modifyTVar' connectionWindow (subtract datPayloadLen)-           modifyTVar' (streamWindow strm) (subtract datPayloadLen)--    fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf-      where-        hinfo = FrameHeader len flag sid--------------------------------------------------------------------fillStreamBodyGetNext :: InternalInfo -> Connection -> Int -> WindowSize-                      -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next-fillStreamBodyGetNext ii Connection{connWriteBuffer,connBufferSize}-                      off lim sq tvar strm = do-    let datBuf = connWriteBuffer `plusPtr` off-        room = min (connBufferSize - off) lim-    (leftover, cont, len) <- runStreamBuilder ii datBuf room sq-    nextForStream ii connWriteBuffer connBufferSize sq tvar strm leftover cont len--------------------------------------------------------------------runStreamBuilder :: InternalInfo -> Buffer -> BufSize -> TBQueue Sequence-                 -> IO (Leftover, Maybe Trailers, BytesFilled)-runStreamBuilder ii buf0 room0 sq = loop buf0 room0 0-  where-    loop !buf !room !total = do-        mbuilder <- atomically $ tryReadTBQueue sq-        case mbuilder of-            Nothing      -> return (LZero, Nothing, total)-            Just (SBuilder builder) -> do-                (len, signal) <- B.runBuilder builder buf room-                let !total' = total + len-                case signal of-                    B.Done -> loop (buf `plusPtr` len) (room - len) total'-                    B.More  _ writer  -> return (LOne writer, Nothing, total')-                    B.Chunk bs writer -> return (LTwo bs writer, Nothing, total')-            Just (SFile path part) -> do-                (leftover, len) <- runStreamFile ii buf room path part-                let !total' = total + len-                case leftover of-                    LZero -> loop (buf `plusPtr` len) (room - len) total'-                    _     -> return (leftover, Nothing, total')--            Just SFlush  -> return (LZero, Nothing, total)-            Just (SFinish trailers) -> return (LZero, Just trailers, total)---- | Open the file and start reading into the send buffer.-runStreamFile :: InternalInfo -> Buffer -> BufSize -> FilePath -> FilePart-              -> IO (Leftover, BytesFilled)---- | Read the given (OS-specific) file representation into the buffer.  On--- non-Windows systems this uses pread; on Windows this ignores the position--- because we use the Handle's internal read position instead (because it's not--- potentially shared with other readers).-readOpenFile :: OpenFile -> Buffer -> BufSize -> Integer -> IO Int--#ifdef WINDOWS-runStreamFile _ buf room path part = do-    let start = filePartOffset part-        bytes = filePartByteCount part-    -- fixme: how to close Handle? GC does it at this moment.-    h <- IO.openBinaryFile path IO.ReadMode-    IO.hSeek h IO.AbsoluteSeek start-    fillBufFile buf room h start bytes (return ())--readOpenFile h buf room _ = IO.hGetBufSome h buf room-#else-runStreamFile ii buf room path part = do-    let start = filePartOffset part-        bytes = filePartByteCount part-    (fd, refresh) <- case fdCacher ii of-        Just fdcache -> getFd fdcache path-        Nothing      -> do-            fd' <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}-            th <- T.register (timeoutManager ii) (closeFd fd')-            return (fd', T.tickle th)-    fillBufFile buf room fd start bytes refresh--readOpenFile = positionRead-#endif---- | Read as much of the file as is currently available into the buffer, then--- return a 'Leftover' to indicate whether this file chunk has more data to--- send.  If this read hit the end of the file range, return 'LZero'; otherwise--- return 'LFile' so this stream will continue reading from the file the next--- time it's pulled from the queue.-fillBufFile :: Buffer -> BufSize -> OpenFile -> Integer -> Integer -> (IO ())-            -> IO (Leftover, BytesFilled)-fillBufFile buf room f start bytes refresh = do-    len <- readOpenFile f buf (mini room bytes) start-    refresh-    let len' = fromIntegral len-        leftover = if bytes > len' then-            LFile f (start + len') (bytes - len') refresh-          else-            LZero-    return (leftover, len)--mini :: Int -> Integer -> Int-mini i n-  | fromIntegral i < n = i-  | otherwise          = fromIntegral n--fillBufStream :: InternalInfo -> Buffer -> BufSize -> Leftover-              -> TBQueue Sequence -> TVar Sync -> Stream -> DynaNext-fillBufStream ii buf0 siz0 leftover0 sq tvar strm lim0 = do-    let payloadBuf = buf0 `plusPtr` frameHeaderLength-        room0 = min (siz0 - frameHeaderLength) lim0-    case leftover0 of-        LZero -> do-            (leftover, end, len) <- runStreamBuilder ii payloadBuf room0 sq-            getNext leftover end len-        LOne writer -> write writer payloadBuf room0 0-        LTwo bs writer-          | BS.length bs <= room0 -> do-              buf1 <- copy payloadBuf bs-              let len = BS.length bs-              write writer buf1 (room0 - len) len-          | otherwise -> do-              let (bs1,bs2) = BS.splitAt room0 bs-              void $ copy payloadBuf bs1-              getNext (LTwo bs2 writer) Nothing room0-        LFile fd start bytes refresh -> do-            (leftover, len) <- fillBufFile payloadBuf room0 fd start bytes refresh-            getNext leftover Nothing len-  where-    getNext = nextForStream ii buf0 siz0 sq tvar strm-    write writer1 buf room sofar = do-        (len, signal) <- writer1 buf room-        case signal of-            B.Done -> do-                (leftover, end, extra) <- runStreamBuilder ii (buf `plusPtr` len) (room - len) sq-                let !total = sofar + len + extra-                getNext leftover end total-            B.More  _ writer -> do-                let !total = sofar + len-                getNext (LOne writer) Nothing total-            B.Chunk bs writer -> do-                let !total = sofar + len-                getNext (LTwo bs writer) Nothing total--nextForStream :: InternalInfo -> Buffer -> BufSize -> TBQueue Sequence-              -> TVar Sync -> Stream -> Leftover -> Maybe Trailers-              -> BytesFilled -> IO Next-nextForStream _ _  _ _  tvar _ _ (Just trailers) len = do-    atomically $ writeTVar tvar $ SyncFinish-    return $ Next len $ CFinish trailers-nextForStream ii buf siz sq tvar strm LZero Nothing len = do-    let out = ONext strm (fillBufStream ii buf siz LZero sq tvar strm)-    atomically $ writeTVar tvar $ SyncNext out-    return $ Next len CNone-nextForStream ii buf siz sq tvar strm leftover Nothing len =-    return $ Next len (CNext (fillBufStream ii buf siz leftover sq tvar strm))

@@ -1,312 +1,81 @@-{-# LANGUAGE OverloadedStrings, CPP #-}-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Network.Wai.Handler.Warp.HTTP2.Types where -import Data.ByteString.Builder (Builder)-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>), (<*>), pure)-#endif-import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (MVar)-import Control.Concurrent.STM-import Control.Exception (SomeException)-import Control.Monad (void)-import Control.Reaper-import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.IntMap.Strict (IntMap, IntMap)-import qualified Data.IntMap.Strict as M import qualified Network.HTTP.Types as H-import Network.Wai (Request, FilePart)-import Network.Wai.HTTP2 (PushPromise, Trailers)-import Network.Wai.Handler.Warp.IORef-import Network.Wai.Handler.Warp.Types+import Network.HTTP2.Frame+import qualified Network.HTTP2.Server as H2 -import Network.HTTP2-import Network.HTTP2.Priority-import Network.HPACK+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types  ---------------------------------------------------------------- -http2ver :: H.HttpVersion-http2ver = H.HttpVersion 2 0- isHTTP2 :: Transport -> Bool isHTTP2 TCP = False isHTTP2 tls = useHTTP2   where     useHTTP2 = case tlsNegotiatedProtocol tls of-        Nothing    -> False-        Just proto -> "h2-" `BS.isPrefixOf` proto || proto == "h2"--------------------------------------------------------------------data Input = Input Stream Request---------------------------------------------------------------------- | The result of writing data from a stream's queue into the buffer.-data Control a = CFinish Trailers-               -- ^ The stream has ended, and the trailers should be sent.-               | CNext a-               -- ^ The stream has more data immediately available, and we-               -- should re-enqueue it when the stream window becomes open.-               | CNone-               -- ^ The stream queue has been drained and we've handed it off-               -- to its dedicated waiter thread, which will re-enqueue it when-               -- more data is available.--instance Show (Control a) where-    show (CFinish _) = "CFinish"-    show (CNext _)   = "CNext"-    show CNone       = "CNone"--type DynaNext = WindowSize -> IO Next--type BytesFilled = Int--data Next = Next BytesFilled (Control DynaNext)--data Output = OFinish-            -- ^ Terminate the connection.-            | OGoaway ByteString-            -- ^ Send a goaway frame and terminate the connection.-            | OSettings ByteString SettingsList-            -- ^ Update settings and send an ack settings frame.-            | OFrame  ByteString-            -- ^ Send an entire pre-encoded frame.-            | OResponse Stream H.Status H.ResponseHeaders Aux-            -- ^ Send the headers and as much of the response as is immediately-            -- available.-            | OPush Stream PushPromise (MVar Bool) Stream H.Status H.ResponseHeaders Aux-            -- ^ Send a PUSH_PROMISE frame, then act like OResponse; signal the-            -- MVar whether the promise has been sent.-            | ONext Stream DynaNext-            -- ^ Send a chunk of the response.--outputStream :: Output -> Stream-outputStream (OResponse strm _ _ _)   = strm-outputStream (ONext strm _)           = strm-outputStream (OPush strm _ _ _ _ _ _) = strm-outputStream _                        = error "outputStream"---------------------------------------------------------------------- | An element on the queue between a running stream and the sender; the order--- should consist of any number of 'SFile', 'SBuilder', and 'SFlush', followed--- by a single 'SFinish'.-data Sequence = SFinish Trailers-              -- ^ The stream is over; its trailers are provided.-              | SFlush-              -- ^ Any buffered data should be sent immediately.-              | SBuilder Builder-              -- ^ Append a chunk of data to the stream.-              | SFile FilePath FilePart-              -- ^ Append a chunk of a file's contents to the stream.---- | A message from the sender to a stream's dedicated waiter thread.-data Sync = SyncNone-          -- ^ Nothing interesting has happened.  Go back to sleep.-          | SyncFinish-          -- ^ The stream has ended.-          | SyncNext Output-          -- ^ The stream's queue has been drained; wait for more to be-          -- available and re-enqueue the given 'Output'.---- | Auxiliary information needed to communicate with a running stream: a queue--- of stream elements ('Sequence') and a 'TVar' connected to its waiter thread.-data Aux = Persist (TBQueue Sequence) (TVar Sync)---------------------------------------------------------------------- | The context for HTTP/2 connection.-data Context = Context {-    http2settings      :: IORef Settings-  , streamTable        :: StreamTable-  -- | Number of active streams initiated by the client; for enforcing our own-  -- max concurrency setting.-  , concurrency        :: IORef Int-  -- | Number of active streams initiated by the server; for respecting the-  -- client's max concurrency setting.-  , pushConcurrency    :: IORef Int-  , priorityTreeSize   :: IORef Int-  -- | RFC 7540 says "Other frames (from any stream) MUST NOT-  --   occur between the HEADERS frame and any CONTINUATION-  --   frames that might follow". This field is used to implement-  --   this requirement.-  , continued          :: IORef (Maybe StreamId)-  , currentStreamId    :: IORef StreamId-  -- ^ Last client-initiated stream ID we've handled.-  , nextPushStreamId   :: IORef StreamId-  -- ^ Next available server-initiated stream ID.-  , inputQ             :: TQueue Input-  , outputQ            :: PriorityTree Output-  , encodeDynamicTable :: IORef DynamicTable-  , decodeDynamicTable :: IORef DynamicTable-  , connectionWindow   :: TVar WindowSize-  }--------------------------------------------------------------------newContext :: IO Context-newContext = Context <$> newIORef defaultSettings-                     <*> initialize 10 -- fixme: hard coding: 10-                     <*> newIORef 0-                     <*> newIORef 0-                     <*> newIORef 0-                     <*> newIORef Nothing-                     <*> newIORef 0-                     <*> newIORef 2 -- first server push stream; 0 is reserved-                     <*> newTQueueIO-                     <*> newPriorityTree-                     <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef)-                     <*> (newDynamicTableForDecoding defaultDynamicTableSize >>= newIORef)-                     <*> newTVarIO defaultInitialWindowSize--clearContext :: Context -> IO ()-clearContext ctx = void $ reaperStop $ streamTable ctx--------------------------------------------------------------------data OpenState =-    JustOpened-  | Continued [HeaderBlockFragment]-              Int  -- Total size-              Int  -- The number of continuation frames-              Bool -- End of stream-              Priority-  | NoBody HeaderList Priority-  | HasBody HeaderList Priority-  | Body (TQueue ByteString)--data ClosedCode = Finished-                | Killed-                | Reset ErrorCodeId-                | ResetByMe SomeException-                deriving Show--data StreamState =-    Idle-  | Open OpenState-  | HalfClosed-  | Closed ClosedCode--isIdle :: StreamState -> Bool-isIdle Idle = True-isIdle _    = False--isOpen :: StreamState -> Bool-isOpen Open{} = True-isOpen _      = False--isHalfClosed :: StreamState -> Bool-isHalfClosed HalfClosed = True-isHalfClosed _          = False--isClosed :: StreamState -> Bool-isClosed Closed{} = True-isClosed _        = False--instance Show StreamState where-    show Idle        = "Idle"-    show Open{}      = "Open"-    show HalfClosed  = "HalfClosed"-    show (Closed e)  = "Closed: " ++ show e--------------------------------------------------------------------data Stream = Stream {-    streamNumber        :: StreamId-  , streamState         :: IORef StreamState-  -- Next two fields are for error checking.-  , streamContentLength :: IORef (Maybe Int)-  , streamBodyLength    :: IORef Int-  , streamWindow        :: TVar WindowSize-  , streamPrecedence    :: IORef Precedence-  -- | The concurrency IORef in which this stream has been counted.  The client-  -- and server each have separate concurrency values to respect, so pushed-  -- streams need to decrement a different count when they're closed.  This-  -- should be either @concurrency ctx@ or @pushConcurrency ctx@.-  , concurrencyRef      :: IORef Int-  }--instance Show Stream where-  show s = show (streamNumber s)--newStream :: IORef Int -> StreamId -> WindowSize -> IO Stream-newStream ref sid win =-    Stream sid <$> newIORef Idle-               <*> newIORef Nothing-               <*> newIORef 0-               <*> newTVarIO win-               <*> newIORef defaultPrecedence-               <*> pure ref--------------------------------------------------------------------opened :: Stream -> IO ()-opened Stream{concurrencyRef,streamState} = do-    atomicModifyIORef' concurrencyRef (\x -> (x+1,()))-    writeIORef streamState (Open JustOpened)--closed :: Stream -> ClosedCode -> IO ()-closed Stream{concurrencyRef,streamState} cc = do-    atomicModifyIORef' concurrencyRef (\x -> (x-1,()))-    writeIORef streamState (Closed cc)+        Nothing -> False+        Just proto -> "h2" `BS.isPrefixOf` proto  ---------------------------------------------------------------- -type StreamTable = Reaper (IntMap Stream) (M.Key, Stream)--initialize :: Int -> IO StreamTable-initialize duration = mkReaper settings-  where-    settings = defaultReaperSettings {-          reaperAction = clean-        , reaperDelay  = duration * 1000000-        , reaperCons   = uncurry M.insert-        , reaperNull   = M.null-        , reaperEmpty  = M.empty-        }--clean :: IntMap Stream -> IO (IntMap Stream -> IntMap Stream)-clean old = do-    new <- M.fromAscList <$> prune oldlist []-    return $ M.union new-  where-    oldlist = M.toDescList old-    prune []     lst = return lst-    prune (x@(_,s):xs) lst = do-        st <- readIORef (streamState s)-        if isClosed st then-            prune xs lst-          else-            prune xs (x:lst)--insert :: StreamTable -> M.Key -> Stream -> IO ()-insert strmtbl k v = reaperAdd strmtbl (k,v)--search :: StreamTable -> M.Key -> IO (Maybe Stream)-search strmtbl k = M.lookup k <$> reaperRead strmtbl+-- | 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 --- INVARIANT: streams in the output queue have non-zero window size.-enqueueWhenWindowIsOpen :: PriorityTree Output -> Output -> IO ()-enqueueWhenWindowIsOpen outQ out = do-    let Stream{..} = outputStream out-    atomically $ do-        x <- readTVar streamWindow-        check (x > 0)-    pre <- readIORef streamPrecedence-    enqueue outQ streamNumber pre out+-- | 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) -enqueueOrSpawnTemporaryWaiter :: Stream -> PriorityTree Output -> Output -> IO ()-enqueueOrSpawnTemporaryWaiter Stream{..} outQ out = do-    sw <- atomically $ readTVar streamWindow-    if sw == 0 then-        -- This waiter waits only for the stream window.-        void $ forkIO $ enqueueWhenWindowIsOpen outQ out-      else do-        pre <- readIORef streamPrecedence-        enqueue outQ streamNumber pre out+-- | Default push promise.+--+--   Since: 3.2.7+defaultPushPromise :: PushPromise+defaultPushPromise = PushPromise "" "" [] 16

@@ -1,279 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE CPP #-}--module Network.Wai.Handler.Warp.HTTP2.Worker (-    Respond-  , response-  , worker-  ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception (Exception, SomeException(..), AsyncException(..))-import qualified Control.Exception as E-import Control.Monad (void, when)-import Data.Typeable-import qualified Network.HTTP.Types as H-import Network.HTTP2-import Network.HTTP2.Priority-import Network.Wai-import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.Manager-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.IORef-import Network.Wai.HTTP2-    ( Chunk(..)-    , HTTP2Application-    , PushPromise-    , Responder(runResponder)-    , RespondFunc-    )-import qualified Network.Wai.Handler.Warp.Settings as S-import qualified Network.Wai.Handler.Warp.Timeout as T---------------------------------------------------------------------- | An 'HTTP2Application' takes a function of status, headers, trailers, and--- body; this type implements that by currying some internal arguments.------ The token type of the RespondFunc is set to be ().  This is a bit--- anti-climactic, but the real benefit of the token type is that the--- application is forced to call the responder, and making it a boring type--- doesn't break that property.------ This is the argument to a 'Responder'.-type Respond = IO () -> Stream -> RespondFunc ()---- | This function is passed to workers.  They also pass responses from--- 'HTTP2Application's to this function.  This function enqueues commands for--- the HTTP/2 sender.-response :: Context -> Manager -> ThreadContinue -> Respond-response ctx mgr tconf tickle strm s h strmbdy = do-    -- TODO(awpr) HEAD requests will still stream.--    -- We must not exit this WAI application.-    -- If the application exits, streaming would be also closed.-    -- So, this work occupies this thread.-    ---    -- We need to increase the number of workers.-    myThreadId >>= replaceWithAction mgr-    -- After this work, this thread stops to decrease the number of workers.-    setThreadContinue tconf False--    runStream ctx OResponse tickle strm s h strmbdy---- | Set up a waiter thread and run the stream body with functions to enqueue--- 'Sequence's on the stream's queue.-runStream :: Context-          -> (Stream -> H.Status -> H.ResponseHeaders -> Aux -> Output)-          -> Respond-runStream Context{outputQ} mkOutput tickle strm s h strmbdy = do-    -- Since 'Body' is loop, we cannot control it.-    -- So, let's serialize 'Builder' with a designated queue.-    sq <- newTBQueueIO 10 -- fixme: hard coding: 10-    tvar <- newTVarIO SyncNone-    let out = mkOutput strm s h (Persist sq tvar)-    -- Since we must not enqueue an empty queue to the priority-    -- queue, we spawn a thread to ensure that the designated-    -- queue is not empty.-    void $ forkIO $ waiter tvar sq strm outputQ-    atomically $ writeTVar tvar $ SyncNext out-    let write chunk = do-            atomically $ writeTBQueue sq $ case chunk of-                BuilderChunk b -> SBuilder b-                FileChunk path part -> SFile path part-            tickle-        flush  = atomically $ writeTBQueue sq SFlush-    trailers <- strmbdy write flush-    atomically $ writeTBQueue sq $ SFinish trailers---- | Handle abnormal termination of a stream: mark it as closed, send a reset--- frame, and call the user's 'settingsOnException' handler if applicable.-cleanupStream :: Context -> S.Settings -> Stream -> Maybe Request -> Maybe SomeException -> IO ()-cleanupStream Context{outputQ} set strm req me = do-    closed strm Killed-    let sid = streamNumber strm-        frame = resetFrame InternalError sid-    enqueueControl outputQ sid $ OFrame frame-    case me of-        Nothing -> return ()-        Just e -> S.settingsOnException set req e---- | Push the given 'Responder' to the client if the settings allow it--- (specifically 'enablePush' and 'maxConcurrentStreams').  Returns 'True' if--- the stream was actually pushed.------ This is the push function given to an 'HTTP2Application'.-pushResponder :: Context -> S.Settings -> Stream -> PushPromise -> Responder -> IO Bool-pushResponder ctx set strm promise responder = do-    let Context{ http2settings-               , pushConcurrency-               } = ctx-    cnt <- readIORef pushConcurrency-    settings <- readIORef http2settings-    let enabled = enablePush settings-        fits = maybe True (cnt <) $ maxConcurrentStreams settings-        canPush = fits && enabled-    if canPush then-        actuallyPushResponder ctx set strm promise responder-      else-        return False---- | Set up a pushed stream and run the 'Responder' in its own thread.  Waits--- for the sender thread to handle the push request.  This can fail to push the--- stream and return 'False' if the sender dequeued the push request after the--- associated stream was closed.-actuallyPushResponder :: Context -> S.Settings -> Stream -> PushPromise -> Responder -> IO Bool-actuallyPushResponder ctx set strm promise responder = do-    let Context{ http2settings-               , nextPushStreamId-               , pushConcurrency-               , streamTable-               } = ctx-    -- Claim the next outgoing stream.-    newSid <- atomicModifyIORef nextPushStreamId $ \sid -> (sid+2, sid)-    ws <- initialWindowSize <$> readIORef http2settings--    newStrm <- newStream pushConcurrency newSid ws-    -- Section 5.3.5 of RFC 7540 defines the weight of push promise is 16.-    -- But we need not to follow the spec. So, this value would change-    -- if necessary.-    writeIORef (streamPrecedence newStrm) $-        toPrecedence $ defaultPriority { streamDependency = streamNumber strm }-    opened newStrm-    insert streamTable newSid newStrm--    -- Set up a channel for the sender to report back whether it pushed the-    -- stream.-    mvar <- newEmptyMVar--    let mkOutput = OPush strm promise mvar-        tickle = return ()-        respond = runStream ctx mkOutput--    -- TODO(awpr): synthesize a Request for 'settingsOnException'?-    _ <- forkIO $ runResponder responder (respond tickle newStrm) `E.catch`-        (cleanupStream ctx set strm Nothing . Just)--    takeMVar mvar--data Break = Break deriving (Show, Typeable)--instance Exception Break--worker :: Context-       -> S.Settings-       -> T.Manager-       -> HTTP2Application-       -> (ThreadContinue -> Respond)-       -> IO ()-worker ctx@Context{inputQ} set tm app respond = do-    tid <- myThreadId-    sinfo <- newStreamInfo-    tcont <- newThreadContinue-    let setup = T.register tm $ E.throwTo tid Break-    E.bracket setup T.cancel $ go sinfo tcont-  where-    go sinfo tcont th = do-        setThreadContinue tcont True--        ex <- E.try $ do-            T.pause th-            Input strm req <- atomically $ readTQueue inputQ-            setStreamInfo sinfo strm req-            T.resume th-            T.tickle th-            let responder = app req $ pushResponder ctx set strm-            runResponder responder $ respond tcont (T.tickle th) strm-        cont1 <- case ex of-            Right () -> return True-            Left  e@(SomeException _)-              | Just Break        <- E.fromException e -> do-                  cleanup sinfo Nothing-                  return True-              -- killed by the sender-              | Just ThreadKilled <- E.fromException e -> do-                  cleanup sinfo Nothing-                  return False-              | otherwise -> do-                  cleanup sinfo (Just e)-                  return True-        cont2 <- getThreadContinue tcont-        when (cont1 && cont2) $ go sinfo tcont th-    cleanup sinfo me = do-        m <- getStreamInfo sinfo-        case m of-            Nothing -> return ()-            Just (strm,req) -> do-                cleanupStream ctx set strm (Just req) me-                clearStreamInfo sinfo---- | A dedicated waiter thread to re-enqueue the stream in the priority tree--- whenever output becomes available.  When the sender drains the queue and--- moves on to another stream, it drops a message in the 'TVar', and this--- thread wakes up, waits for more output to become available, and re-enqueues--- the stream.-waiter :: TVar Sync -> TBQueue Sequence -> Stream -> PriorityTree Output -> IO ()-waiter tvar sq strm outQ = do-    -- waiting for actions other than SyncNone-    mx <- atomically $ do-        mout <- readTVar tvar-        case mout of-            SyncNone     -> retry-            SyncNext out -> do-                writeTVar tvar SyncNone-                return $ Just out-            SyncFinish   -> return Nothing-    case mx of-        Nothing  -> return ()-        Just out -> do-            -- ensuring that the streaming queue is not empty.-            atomically $ do-                isEmpty <- isEmptyTBQueue sq-                when isEmpty retry-            -- ensuring that stream window is greater than 0.-            enqueueWhenWindowIsOpen outQ out-            waiter tvar sq strm outQ---------------------------------------------------------------------- | It would nice if responders could return values to workers.---   Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.---   It is not wise to change this type.---   So, a reference is shared by a 'Respond' and its worker.---   The reference refers a value of this type as a return value.---   If 'True', the worker continue to serve requests.---   Otherwise, the worker get finished.-newtype ThreadContinue = ThreadContinue (IORef Bool)--newThreadContinue :: IO ThreadContinue-newThreadContinue = ThreadContinue <$> newIORef True--setThreadContinue :: ThreadContinue -> Bool -> IO ()-setThreadContinue (ThreadContinue ref) x = writeIORef ref x--getThreadContinue :: ThreadContinue -> IO Bool-getThreadContinue (ThreadContinue ref) = readIORef ref---------------------------------------------------------------------- | The type to store enough information for 'settingsOnException'.-newtype StreamInfo = StreamInfo (IORef (Maybe (Stream,Request)))--newStreamInfo :: IO StreamInfo-newStreamInfo = StreamInfo <$> newIORef Nothing--clearStreamInfo :: StreamInfo -> IO ()-clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing--setStreamInfo :: StreamInfo -> Stream -> Request -> IO ()-setStreamInfo (StreamInfo ref) strm req = writeIORef ref $ Just (strm,req)--getStreamInfo :: StreamInfo -> IO (Maybe (Stream, Request))-getStreamInfo (StreamInfo ref) = readIORef ref

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

@@ -1,10 +1,14 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}+{-# 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  ----------------------------------------------------------------@@ -17,69 +21,102 @@ indexRequestHeader :: RequestHeaders -> IndexedHeader indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex -data RequestHeaderIndex = ReqContentLength-                        | ReqTransferEncoding-                        | ReqExpect-                        | ReqConnection-                        | ReqRange-                        | ReqHost-                        | ReqIfModifiedSince-                        | ReqIfUnmodifiedSince-                        | ReqIfRange-                        deriving (Enum,Bounded)+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\" and \"If-Range\".+--   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 "content-length"      = fromEnum ReqContentLength-requestKeyIndex "transfer-encoding"   = fromEnum ReqTransferEncoding-requestKeyIndex "expect"              = fromEnum ReqExpect-requestKeyIndex "connection"          = fromEnum ReqConnection-requestKeyIndex "range"               = fromEnum ReqRange-requestKeyIndex "host"                = fromEnum ReqHost-requestKeyIndex "if-modified-since"   = fromEnum ReqIfModifiedSince-requestKeyIndex "if-unmodified-since" = fromEnum ReqIfUnmodifiedSince-requestKeyIndex "if-range"            = fromEnum ReqIfRange-requestKeyIndex _                     = -1+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]]+defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0 .. requestMaxIndex]]  ----------------------------------------------------------------  indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex -data ResponseHeaderIndex = ResContentLength-                         | ResServer-                         | ResDate-                         deriving (Enum,Bounded)+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 "content-length" = fromEnum ResContentLength-responseKeyIndex "server"         = fromEnum ResServer-responseKeyIndex "date"           = fromEnum ResDate-responseKeyIndex _                = -1+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+    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)+    insert arr (key, val)+        | idx == -1 = return ()+        | otherwise = writeArray arr idx (Just val)       where         idx = getIndex key

@@ -1,29 +1,50 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}- module Network.Wai.Handler.Warp.IO where -import Data.ByteString (ByteString)+import Control.Exception (mask_) import Data.ByteString.Builder (Builder)-import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))+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 :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()-toBufIOWith buf !size io builder = loop firstWriter+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-    runIO len = bufferIO buf len io-    loop writer = do+    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 -> runIO len-             More minSize next-               | size < minSize -> error "toBufIOWith: BufferFull: minSize"-               | otherwise      -> do-                   runIO len-                   loop next-             Chunk bs next -> do-                 runIO len-                 io bs-                 loop next+            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

@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--module Network.Wai.Handler.Warp.IORef (-    module Data.IORef-#if !MIN_VERSION_base(4,6,0)-  , atomicModifyIORef'-#endif-  ) where--import Data.IORef--#if !MIN_VERSION_base(4,6,0)--- | Strict version of 'atomicModifyIORef'.  This forces both the value stored--- in the 'IORef' as well as the value returned.-atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORef' ref f = do-    c <- atomicModifyIORef ref-            (\x -> let (a, b) = f x    -- Lazy application of "f"-                    in (a, a `seq` b)) -- Lazy application of "seq"-    -- The following forces "a `seq` b", so it also forces "f x".-    c `seq` return c-#endif

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

@@ -1,52 +1,71 @@ {-# 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(..)+    Settings (..),+    ProxyProtocol (..),+    makeSettingsAndCounter,+    makeSettingsAndServerState,++    -- ** Connection counter+    Counter,+    getCount,++    -- ** Server state+    ServerState,+    makeServerState,+     -- * Low level run functions-  , runSettingsConnection-  , runSettingsConnectionMaker-  , runSettingsConnectionMakerSecure-  , runServe-  , runServeEnv-  , runServeSettings-  , runServeSettingsSocket-  , runServeSettingsConnection-  , runServeSettingsConnectionMaker-  , runServeSettingsConnectionMakerSecure-  , Transport (..)-    -- * ServeConnection-  , ServeConnection-  , serveDefault-  , serveHTTP2+    runSettingsConnection,+    runSettingsConnectionMaker,+    runSettingsConnectionMakerSecure,+    Transport (..),+     -- * Connection-  , Connection (..)-  , socketConnection+    Connection (..),+    socketConnection,+     -- ** Receive-  , Recv-  , RecvBuf-  , makePlainReceiveN+    Recv,+    makeGracefulRecv,+    RecvBuf,+     -- ** Buffer-  , Buffer-  , BufSize-  , bufferSize-  , allocateBuffer-  , freeBuffer-  , copy+    Buffer,+    BufSize,+    WriteBuffer (..),+    createWriteBuffer,+    allocateBuffer,+    freeBuffer,+    copy,+     -- ** Sendfile-  , FileId (..)-  , SendFile-  , sendFile-  , readSendFile+    FileId (..),+    SendFile,+    sendFile,+    readSendFile,+     -- * Version-  , warpVersion+    warpVersion,+     -- * Data types-  , InternalInfo (..)-  , HeaderValue-  , IndexedHeader-  , requestMaxIndex+    InternalInfo (..),+    HeaderValue,+    IndexedHeader,+    requestMaxIndex,+     -- * Time out manager+     -- |     --     -- In order to provide slowloris protection, Warp provides timeout handlers. We@@ -64,29 +83,49 @@     --   resumed as soon as we return from user code.     --     -- * Every time data is successfully sent to the client, the timeout is tickled.-  , module Network.Wai.Handler.Warp.Timeout+    module System.TimeManager,+     -- * File descriptor cache-  , module Network.Wai.Handler.Warp.FdCache+    module Network.Wai.Handler.Warp.FdCache,+     -- * File information cache-  , module Network.Wai.Handler.Warp.FileInfoCache+    module Network.Wai.Handler.Warp.FileInfoCache,+     -- * Date-  , module Network.Wai.Handler.Warp.Date+    module Network.Wai.Handler.Warp.Date,+     -- * Request and response-  , Source-  , recvRequest-  , sendResponse-  ) where+    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.Recv 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.Timeout import Network.Wai.Handler.Warp.Types+import Network.Wai.Handler.Warp.Windows

@@ -1,240 +1,91 @@-{-# LANGUAGE CPP #-}- module Network.Wai.Handler.Warp.MultiMap (-    MMap-  , Some(..)-  , empty-  , singleton-  , insert-  , search-  , searchWith-  , isEmpty-  , valid-  , pruneWith-  , fromList-  , toList-  , fromSortedList-  , toSortedList-  , merge-  ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif-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 :: 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 @@ -34,34 +30,6 @@  {-# 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,133 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Network.Wai.Handler.Warp.Recv (-    receive-  , receiveBuf-  , makeReceiveN-  , makePlainReceiveN-  , spell-  ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif-import qualified Control.Exception as E-import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString(..))-import Data.Word (Word8)-import Foreign.C.Error (eAGAIN, getErrno, throwErrno)-import Foreign.C.Types-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, castPtr, plusPtr)-import GHC.Conc (threadWaitRead)-import Network.Socket (Socket, fdSocket)-import Network.Wai.Handler.Warp.Buffer-import Network.Wai.Handler.Warp.IORef-import Network.Wai.Handler.Warp.Types-import System.Posix.Types (Fd(..))--#ifdef mingw32_HOST_OS-import GHC.IO.FD (FD(..), readRawBufferPtr)-import Network.Wai.Handler.Warp.Windows-#endif--------------------------------------------------------------------makeReceiveN :: ByteString -> Recv -> RecvBuf -> IO (BufSize -> IO ByteString)-makeReceiveN bs0 recv recvBuf = do-    ref <- newIORef bs0-    return $ receiveN ref recv recvBuf---- | This function returns a receiving function---   based on two receiving functions.---   The returned function efficiently manages received data---   which is initialized by the first argument.---   The returned function may allocate a byte string with malloc().-makePlainReceiveN :: Socket -> ByteString -> IO (BufSize -> IO ByteString)-makePlainReceiveN s bs0 = do-    ref <- newIORef bs0-    pool <- newBufferPool-    return $ receiveN ref (receive s pool) (receiveBuf s)--receiveN :: IORef ByteString -> Recv -> RecvBuf -> BufSize -> IO ByteString-receiveN ref recv recvBuf size = E.handle handler $ do-    cached <- readIORef ref-    (bs, leftover) <- spell cached size recv recvBuf-    writeIORef ref leftover-    return bs- where-   handler :: E.SomeException -> IO ByteString-   handler _ = return ""--------------------------------------------------------------------spell :: ByteString -> BufSize -> IO ByteString -> RecvBuf -> IO (ByteString, ByteString)-spell init0 siz0 recv recvBuf-  | siz0 <= len0 = return $ BS.splitAt siz0 init0-  -- fixme: hard coding 4096-  | siz0 <= 4096 = loop [init0] (siz0 - len0)-  | otherwise    = do-      bs@(PS fptr _ _) <- mallocBS siz0-      withForeignPtr fptr $ \ptr -> do-          ptr' <- copy ptr init0-          full <- recvBuf ptr' (siz0 - len0)-          if full then-              return (bs, "")-            else-              return ("", "") -- fixme-  where-    len0 = BS.length init0-    loop bss siz = do-        bs <- recv-        let len = BS.length bs-        if len == 0 then-            return ("", "")-          else if len >= siz then do-            let (consume, leftover) = BS.splitAt siz bs-                ret = BS.concat $ reverse (consume : bss)-            return (ret, leftover)-          else do-            let bss' = bs : bss-                siz' = siz - len-            loop bss' siz'--receive :: Socket -> BufferPool -> Recv-receive sock pool = withBufferPool pool $ \ (ptr, size) -> do-    let sock' = fdSocket sock-        size' = fromIntegral size-    fromIntegral <$> receiveloop sock' ptr size'--receiveBuf :: Socket -> RecvBuf-receiveBuf sock buf0 siz0 = loop buf0 siz0-  where-    loop _   0   = return True-    loop buf siz = do-        n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)-        -- fixme: what should we do in the case of n == 0-        if n == 0 then-            return False-          else-            loop (buf `plusPtr` n) (siz - n)-    fd = fdSocket sock--receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt-receiveloop sock ptr size = do-#ifdef mingw32_HOST_OS-    bytes <- windowsThreadBlockHack $ fromIntegral <$> readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size-#else-    bytes <- c_recv sock (castPtr ptr) size 0-#endif-    if bytes == -1 then do-        errno <- getErrno-        if errno == eAGAIN then do-            threadWaitRead (Fd sock)-            receiveloop sock ptr size-          else-            throwErrno "receiveloop"-       else-        return bytes---- fixme: the type of the return value-foreign import ccall unsafe "recv"-    c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

@@ -1,171 +1,209 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}  module Network.Wai.Handler.Warp.Request (-    recvRequest-  , headerLines-  , pauseTimeoutKey-  , getFileInfoKey-  ) where+    FirstRequest(..),+    recvRequest,+    headerLines,+    pauseTimeoutKey,+    getFileInfoKey,+#ifdef MIN_VERSION_crypton_x509+    getClientCertificateKey,+#endif+    NoKeepAliveRequest (..),+) where  import qualified Control.Concurrent as Conc (yield)-import Control.Exception (throwIO) import Data.Array ((!))-import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU import qualified Data.CaseInsensitive as CI import qualified Data.IORef as I+import qualified Data.Vault.Lazy as Vault+import Data.Word8 (_cr, _lf)+#ifdef MIN_VERSION_crypton_x509+import Data.X509+#endif+import Control.Exception (Exception, throwIO) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai+import Network.Wai.Handler.Warp.Types+import Network.Wai.Internal+import System.IO.Unsafe (unsafePerformIO)+import qualified System.TimeManager as Timeout+import Prelude hiding (lines)+ import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Imports hiding (readInt) import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader-import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)-import qualified Network.Wai.Handler.Warp.Timeout as Timeout-import Network.Wai.Handler.Warp.Types-import Network.Wai.Internal-import Prelude hiding (lines)-import Control.Monad (when)-import qualified Data.Vault.Lazy as Vault-import System.IO.Unsafe (unsafePerformIO)+import Network.Wai.Handler.Warp.Settings (+    Settings,+    settingsMaxTotalHeaderLength,+    settingsNoParsePath,+ )  ---------------------------------------------------------------- --- FIXME come up with good values here-maxTotalHeaderLength :: Int-maxTotalHeaderLength = 50 * 1024------------------------------------------------------------------+-- | first request on this connection?+data FirstRequest = FirstRequest | SubsequentRequest  -- | Receiving a HTTP request from 'Connection' and parsing its header --   to create 'Request'.-recvRequest :: Settings-            -> Connection-            -> InternalInfo-            -> SockAddr -- ^ Peer's address.-            -> Source -- ^ Where HTTP request comes from.-            -> 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 settings conn ii addr src = do-    hdrlines <- headerLines src-    (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines+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-        cl = idxhdr ! fromEnum ReqContentLength-        te = idxhdr ! fromEnum ReqTransferEncoding         handle100Continue = handleExpect conn httpversion expect-    (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te+    (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 req = Request {-            requestMethod     = method-          , httpVersion       = httpversion-          , pathInfo          = H.decodePathSegments path-          , rawPathInfo       = if settingsNoParsePath settings then unparsedPath else path-          , rawQueryString    = query-          , queryString       = H.parseQuery query-          , requestHeaders    = hdr-          , isSecure          = False-          , remoteHost        = addr-          , requestBody       = rbody'-          , vault             = vaultValue-          , requestBodyLength = bodyLength-          , requestHeaderHost  = idxhdr ! fromEnum ReqHost-          , requestHeaderRange = idxhdr ! fromEnum ReqRange-          }+    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)-  where-    th = threadHandle ii-    vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)-               $ Vault.insert getFileInfoKey (fileInfo ii)-                 Vault.empty  ---------------------------------------------------------------- -headerLines :: Source -> IO [ByteString]-headerLines src = do+headerLines :: Int -> FirstRequest -> Source -> IO [ByteString]+headerLines maxTotalHeaderLength firstRequest src = do     bs <- readSource src     if S.null bs-        then throwIO ConnectionClosedByPeer-        else push src (THStatus 0 id id) bs+        then -- When we're working on a keep-alive connection and trying to+        -- get the second or later request, we don't want to treat the+        -- lack of data as a real exception. See the http1 function in+        -- the Run module for more details. +            case firstRequest of+              FirstRequest -> throwIO ConnectionClosedByPeer+              SubsequentRequest -> throwIO NoKeepAliveRequest+        else push maxTotalHeaderLength src (THStatus 0 0 id id) bs++data NoKeepAliveRequest = NoKeepAliveRequest+    deriving (Show)+instance Exception NoKeepAliveRequest+ ---------------------------------------------------------------- -handleExpect :: Connection-             -> H.HttpVersion-             -> Maybe HeaderValue-             -> IO ()+handleExpect+    :: 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 ()+        | 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-              -> Maybe HeaderValue -- ^ content length-              -> Maybe HeaderValue -- ^ transfer-encoding-              -> IO (IO ByteString-                    ,Maybe (I.IORef Int)-                    ,RequestBodyLength-                    )-bodyAndSource src cl te-  | chunked = do-      csrc <- mkCSource src-      return (readCSource csrc, Nothing, ChunkedBody)-  | otherwise = do-      isrc@(ISource _ remaining) <- mkISource src len-      return (readISource isrc, Just remaining, bodyLen)+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-    len = toLength cl-    bodyLen = KnownLength $ fromIntegral len-    chunked = isChunked te+    chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding  toLength :: Maybe HeaderValue -> Int-toLength Nothing   = 0+toLength Nothing = 0 toLength (Just bs) = readInt bs  isChunked :: Maybe HeaderValue -> Bool isChunked (Just bs) = CI.foldCase bs == "chunked"-isChunked _         = False+isChunked _ = False  ---------------------------------------------------------------- -timeoutBody :: Maybe (I.IORef Int) -- ^ remaining-            -> Timeout.Handle-            -> IO ByteString-            -> IO ()-            -> IO (IO ByteString)+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+                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@@ -193,13 +231,15 @@  ---------------------------------------------------------------- -type BSEndo = ByteString -> ByteString+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  ---------------------------------------------------------------- @@ -208,75 +248,85 @@ close = throwIO IncompleteHeaders -} -push :: Source -> THStatus -> ByteString -> IO [ByteString]-push src (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-    bs = prepend bs'     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' #-}-    push' :: Maybe (Int, Bool) -> IO [ByteString]-    -- No newline find in this chunk.  Add it to the prepend,-    -- update the length, and continue processing.-    push' Nothing = do-        bst <- readSource' src-        when (S.null bst) $ throwIO IncompleteHeaders-        push src status bst-      where-        len' = len + bsLen-        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 src status rest-      where-        rest = S.drop (end + 1) bs-        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 = do-            when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs)-            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 src status bs''-                           else do-                             -- no more bytes in this chunk, ask for more-                             bst <- readSource' src-                             when (S.null bs) $ throwIO IncompleteHeaders-                             push src status bst+    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 = SU.unsafeTake (checkCR bs end) bs+        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 pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR-  where-    !p = pos - 1  pauseTimeoutKey :: Vault.Key (IO ()) pauseTimeoutKey = unsafePerformIO Vault.newKey@@ -285,3 +335,9 @@ 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

@@ -1,39 +1,40 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}  module Network.Wai.Handler.Warp.RequestHeader (-      parseHeaderLines-    , parseByteRanges-    ) where+    parseHeaderLines,+) where  import Control.Exception (throwIO)-import Control.Monad (when) import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as B (unpack)-import Data.ByteString.Internal (ByteString(..), memchr)+import qualified Data.ByteString.Char8 as C8 (unpack)+import Data.ByteString.Internal (memchr) import qualified Data.CaseInsensitive as CI-import Data.Word (Word8)+import Data.Word8 import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)+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-import Network.Wai.Internal (parseByteRanges)+ -- $setup -- >>> :set -XOverloadedStrings  ---------------------------------------------------------------- -parseHeaderLines :: [ByteString]-                 -> IO (H.Method-                       ,ByteString  --  Path-                       ,ByteString  --  Path, parsed-                       ,ByteString  --  Query-                       ,H.HttpVersion-                       ,H.RequestHeaders-                       )+parseHeaderLines+    :: [ByteString]+    -> IO+        ( H.Method+        , ByteString --  Path+        , ByteString --  Path, parsed+        , ByteString --  Query+        , H.HttpVersion+        , H.RequestHeaders+        ) parseHeaderLines [] = throwIO $ NotEnoughLines []-parseHeaderLines (firstLine:otherLines) = do+parseHeaderLines (firstLine : otherLines) = do     (method, path', query, httpversion) <- parseRequestLine firstLine     let path = H.extractPath path'         hdr = map parseHeader otherLines@@ -53,24 +54,27 @@ -- *** 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+    :: 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 32 lim0 -- ' '+    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 32 lim1 -- ' '+    httpptr0 <- memchr pathptr _space lim1     when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $         throwIO baderr     let httpptr = httpptr0 `plusPtr` 1@@ -78,37 +82,37 @@      checkHTTP httpptr     !hv <- httpVersion httpptr-    queryptr <- memchr pathptr 63 lim2 -- '?'+    queryptr <- memchr pathptr _question lim2      let !method = bs ptr methodptr pathptr0         !path-          | queryptr == nullPtr = bs ptr pathptr httpptr0-          | otherwise           = bs ptr pathptr queryptr+            | queryptr == nullPtr = bs ptr pathptr httpptr0+            | otherwise = bs ptr pathptr queryptr         !query-          | queryptr == nullPtr = S.empty-          | otherwise           = bs ptr queryptr httpptr0+            | queryptr == nullPtr = S.empty+            | otherwise = bs ptr queryptr httpptr0 -    return (method,path,query,hv)+    return (method, path, query, hv)   where-    baderr = BadFirstLine $ B.unpack requestLine+    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 72 -- 'H'-        check httpptr 1 84 -- 'T'-        check httpptr 2 84 -- 'T'-        check httpptr 3 80 -- 'P'-        check httpptr 4 47 -- '/'-        check httpptr 6 46 -- '.'+        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 == 49 = if minor == 49 then H.http11 else H.http10-              | major == 50 && minor == 48 = H.HttpVersion 2 0-              | otherwise   = H.http10+                | 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@@ -127,9 +131,8 @@ -- ("Host","example.com:8080") -- >>> parseHeader "NoSemiColon" -- ("NoSemiColon","")- parseHeader :: ByteString -> H.Header parseHeader s =-    let (k, rest) = S.break (== 58) s -- ':'-        rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest+    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,78 +1,54 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Network.Wai.Handler.Warp.Response (-    sendResponse-  , sanitizeHeaderValue -- for testing-  , warpVersion-  , addDate-  , addServer-  , hasBody-  ) where--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--#ifndef MIN_VERSION_http_types-#define MIN_VERSION_http_types(x,y,z) 1-#endif+    sendResponse,+    sanitizeHeaderValue, -- for testing+    --  Provided here for backwards compatibility.+    warpVersion,+    hasBody,+    replaceHeader,+    addServer, -- testing+    addAltSvc,+) where -import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import qualified Control.Exception as E-import Control.Monad (unless, when) import Data.Array ((!))-import Data.ByteString (ByteString) import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import Data.ByteString.Builder (byteString, Builder)+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.Function (on) import Data.List (deleteBy)-import Data.Maybe-#if MIN_VERSION_base(4,5,0)-# if __GLASGOW_HASKELL__ < 709-import Data.Monoid (mempty)-# endif-import Data.Monoid ((<>))-#else-import Data.Monoid (mappend, mempty)-#endif-import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)-import Data.Version (showVersion)-import Data.Word8 (_cr, _lf)+import Data.Streaming.ByteString.Builder (+    newByteStringBuilderRecv,+    reuseBufferStrategy,+ )+import Data.Word8 (_cr, _lf, _space, _tab) import qualified Network.HTTP.Types as H-#if MIN_VERSION_http_types(0,9,0) import qualified Network.HTTP.Types.Header as H-#endif import Network.Wai+import Network.Wai.Internal+import qualified System.TimeManager as T+ import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D-#ifndef WINDOWS-import qualified Network.Wai.Handler.Warp.FdCache as F-#endif 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.Timeout as T import Network.Wai.Handler.Warp.Types-import Network.Wai.Internal-import qualified Paths_warp -#if !MIN_VERSION_base(4,5,0)-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif- -- $setup -- >>> :set -XOverloadedStrings @@ -124,67 +100,84 @@ -- --     Simple applications should specify 'Nothing' to --     'Maybe' 'FilePart'. The size of the specified file is obtained---     by disk access or from the file infor cache.+--     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-             -> 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 req reqidxhdr src response = do-    hs <- 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 ver s hs rsp-        case ms of-            Nothing         -> return ()-            Just realStatus -> logger req realStatus mlen-        T.tickle th-        return ret-      else do-        _ <- sendRsp conn ii ver s hs RspNoBody-        logger req s Nothing-        T.tickle th-        return isPersist+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-    th = threadHandle ii-    dc = dateCacher ii-    addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr-    (isPersist,isChunked0) = infoFromRequest req reqidxhdr+    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)-    isHead = requestMethod req == H.methodHead+    (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist, isChunked)+    method = requestMethod req+    isHead = method == H.methodHead     rsp = case response of-        ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)+        ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr (T.tickle th)         ResponseBuilder _ _ b-          | isHead                  -> RspNoBody-          | otherwise               -> RspBuilder b needsChunked+            | isHead -> RspNoBody+            | otherwise -> RspBuilder b needsChunked         ResponseStream _ _ fb-          | isHead                  -> RspNoBody-          | otherwise               -> RspStream fb needsChunked th-        ResponseRaw raw _           -> RspRaw raw src (T.tickle th)-    ret = case response of-        ResponseFile    {} -> isPersist-        ResponseBuilder {} -> isKeepAlive-        ResponseStream  {} -> isKeepAlive-        ResponseRaw     {} -> False+            | 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  ---------------------------------------------------------------- @@ -192,8 +185,8 @@ sanitizeHeaders = map (sanitize <$>)   where     sanitize v-      | containsNewlines v = sanitizeHeaderValue v -- slow path-      | otherwise          = v                     -- fast path+        | containsNewlines v = sanitizeHeaderValue v -- slow path+        | otherwise = v -- fast path  {-# INLINE containsNewlines #-} containsNewlines :: ByteString -> Bool@@ -201,37 +194,42 @@  {-# INLINE sanitizeHeaderValue #-} sanitizeHeaderValue :: ByteString -> ByteString-sanitizeHeaderValue v = case S8.lines $ S.filter (/= _cr) v of-    []     -> ""-    x : xs -> S8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)+sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of+    [] -> ""+    x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)   where-    addSpaceIfMissing line = case S8.uncons line of-        Nothing                           -> Nothing+    addSpaceIfMissing line = case S.uncons line of+        Nothing -> Nothing         Just (first, _)-          | first == ' ' || first == '\t' -> Just line-          | otherwise                     -> Just $ " " <> line+            | first == _space || first == _tab -> Just line+            | otherwise -> Just $ _space `S.cons` line  ---------------------------------------------------------------- -data Rsp = RspNoBody-         | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ())-         | RspBuilder Builder Bool-         | RspStream StreamingBody Bool T.Handle-         | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())+data Rsp+    = RspNoBody+    | RspFile FilePath (Maybe FilePart) IndexedHeader (IO ())+    | RspBuilder Builder Bool+    | RspStream StreamingBody Bool+    | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)  ---------------------------------------------------------------- -sendRsp :: Connection-        -> InternalInfo-        -> H.HttpVersion-        -> H.Status-        -> H.ResponseHeaders-        -> Rsp-        -> IO (Maybe H.Status, Maybe Integer)-+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+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@@ -239,23 +237,32 @@  ---------------------------------------------------------------- -sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do+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-        buffer = connWriteBuffer conn-        size = connBufferSize conn-    toBufIOWith buffer size (connSendAll conn) hdrBdy-    return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?+            | 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 _ ver s hs (RspStream streamingBody needsChunked th) = do+sendRsp conn _ th ver s hs _ _ _ (RspStream streamingBody needsChunked) = do     header <- composeHeaderBuilder ver s hs needsChunked-    (recv, finish) <- newBlazeRecv $ reuseBufferStrategy-                    $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)+    (recv, finish) <-+        newByteStringBuilderRecv $+            reuseBufferStrategy $+                toBuilderBuffer $+                    connWriteBuffer conn     let send builder = do             popper <- recv builder             let loop = do@@ -276,22 +283,35 @@  ---------------------------------------------------------------- -sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do+sendRsp conn _ th _ _ _ _ _ _ (RspRaw withApp src) = do     withApp recv send     return (Nothing, Nothing)   where     recv = do         bs <- src-        unless (S.null bs) tickle+        unless (S.null bs) $ T.tickle th         return bs-    send bs = connSendAll conn bs >> tickle+    send bs = connSendAll conn bs >> T.tickle th  ----------------------------------------------------------------  -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value.-sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =-    sendRspFile2XX conn ii ver s0 hs path beg len isHead hook+sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just part) _ hook) =+    sendRspFile2XX+        conn+        ii+        th+        ver+        s0+        hs+        rspidxhdr+        maxRspBufSize+        method+        path+        beg+        len+        hook   where     beg = filePartOffset part     len = filePartByteCount part@@ -301,59 +321,86 @@  -- Simple WAI applications. -- Status is ignored-sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do-    efinfo <- E.try $ fileInfo ii path+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 >>+            print _ex >> #endif-          sendRspFile404 conn ii ver hs0-        Right finfo -> case conditionalRequest finfo hs0 idxhdr of-          WithoutBody s         -> sendRsp conn ii ver s hs0 RspNoBody-          WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook+            sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method+        Right finfo -> case conditionalRequest finfo hs0 method rspidxhdr reqidxhdr of+            WithoutBody s ->+                sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize method RspNoBody+            WithBody s hs beg len ->+                sendRspFile2XX+                    conn+                    ii+                    th+                    ver+                    s+                    hs+                    rspidxhdr+                    maxRspBufSize+                    method+                    path+                    beg+                    len+                    hook  ---------------------------------------------------------------- -sendRspFile2XX :: Connection-               -> InternalInfo-               -> H.HttpVersion-               -> H.Status-               -> H.ResponseHeaders-               -> FilePath-               -> Integer-               -> Integer-               -> Bool-               -> IO ()-               -> IO (Maybe H.Status, Maybe Integer)-sendRspFile2XX conn ii ver s hs path beg len isHead hook-  | isHead = sendRsp conn ii ver s hs RspNoBody-  | otherwise = do-      lheader <- composeHeader ver s hs-#ifdef WINDOWS-      let fid = FileId path Nothing-          hook' = hook-#else-      (mfd, hook') <- case fdCacher ii of-         -- settingsFdCacheDuration is 0-         Nothing  -> return (Nothing, hook)-         Just fdc -> do-            (fd, fresher) <- F.getFd fdc path-            return (Just fd, hook >> fresher)-      let fid = FileId path mfd-#endif-      connSendFile conn fid beg len hook' [lheader]-      return (Just s, Just len)+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-               -> H.HttpVersion-               -> H.ResponseHeaders-               -> IO (Maybe H.Status, Maybe Integer)-sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)+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     s = H.notFound404-    hs =  replaceHeader H.hContentType "text/plain; charset=utf-8" hs0+    hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0     body = byteString "File not found"  ----------------------------------------------------------------@@ -361,34 +408,39 @@  -- | Use 'connSendAll' to send this data while respecting timeout rules. sendFragment :: Connection -> T.Handle -> ByteString -> IO ()-sendFragment Connection { connSendAll = send } th bs = do+sendFragment Connection{connSendAll = send} th bs = do     T.resume th     send bs     T.pause th-    -- We pause timeouts before passing control back to user code. This ensures-    -- that a timeout will only ever be executed when Warp is in control. We-    -- also make sure to resume the timeout after the completion of user code-    -- so that we can kill idle connections. +-- We 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+    :: 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 = 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@@ -402,8 +454,8 @@ -- -- 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)+infoFromResponse :: IndexedHeader -> (Bool, Bool) -> (Bool, Bool)+infoFromResponse rspidxhdr (isPersist, isChunked) = (isKeepAlive, needsChunked)   where     needsChunked = isChunked && not hasLength     isKeepAlive = isPersist && (isChunked || hasLength)@@ -412,51 +464,57 @@ ----------------------------------------------------------------  hasBody :: H.Status -> Bool-hasBody s = sc /= 204-         && sc /= 304-         && sc >= 200+hasBody s =+    sc /= 204+        && sc /= 304+        && sc >= 200   where     sc = H.statusCode s  ----------------------------------------------------------------  addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders-#if MIN_VERSION_http_types(0,9,0) addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs-#else-addTransferEncoding hdrs = ("transfer-encoding", "chunked") : hdrs-#endif -addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders-addDate dc rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of+addDate+    :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of     Nothing -> do-        gmtdate <- D.getDate dc+        gmtdate <- getdate         return $ (H.hDate, gmtdate) : hdrs     Just _ -> return hdrs  ---------------------------------------------------------------- --- | The version of Warp.-warpVersion :: String-warpVersion = showVersion Paths_warp.version--addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders+{-# 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+    _ -> hdrs +addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders+addAltSvc settings hs = case settingsAltSvc settings of+    Nothing -> hs+    Just v -> ("Alt-Svc", v) : 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+replaceHeader+    :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders+replaceHeader k v hdrs = (k, v) : deleteBy ((==) `on` fst) (k, v) hdrs  ---------------------------------------------------------------- -composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder+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 =

@@ -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 (create) import qualified Data.CaseInsensitive as CI import Data.List (foldl')-import Data.Word (Word8)+import Data.Word8 import Foreign.Ptr import GHC.Storable import qualified Network.HTTP.Types as H-import Network.Wai.Handler.Warp.Buffer (copy)+import Network.Socket.BufferPool (copy) +import Network.Wai.Handler.Warp.Imports+ ----------------------------------------------------------------  composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString@@ -24,7 +24,7 @@     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  httpVer11 :: ByteString@@ -37,50 +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,96 +1,174 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}  module Network.Wai.Handler.Warp.Run where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-#endif import Control.Arrow (first)-import Control.Concurrent (threadDelay)-import qualified Control.Concurrent as Conc (yield)-import Control.Exception as E-import Control.Monad (when, unless, void)-import Data.ByteString (ByteString)+import Control.Concurrent.STM (+    TVar,+    atomically,+    check,+    modifyTVar',+    newTVarIO,+    readTVar,+ )+import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.Char (chr)-import Data.IP (toHostAddress, toHostAddress6)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Functor (($>))+import Data.IORef (newIORef, readIORef, IORef, writeIORef) import Data.Streaming.Network (bindPortTCP)-import Network (sClose, Socket)-import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6))+import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE)+import GHC.Conc.Sync (labelThread, myThreadId)+import GHC.IO.Exception (IOErrorType (..), IOException (..))+import Network.Socket (+    SockAddr,+    Socket,+    SocketOption (..),+    close,+#if !WINDOWS+    fdSocket,+#if MIN_VERSION_network(3,2,2)+    waitReadSocketSTM,+#endif+#endif+    getSocketName,+    setSocketOption,+    withSocketsDo,+ )+#if MIN_VERSION_network(3,1,1)+import Network.Socket (gracefulClose)+#endif+import Network.Socket.BufferPool import qualified Network.Socket.ByteString as Sock import Network.Wai-import Network.Wai.HTTP2 (HTTP2Application, promoteApplication)-import Network.Wai.Handler.Warp.Buffer+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.HTTP2 (http2, isHTTP2)-import Network.Wai.Handler.Warp.Header-import Network.Wai.Handler.Warp.ReadInt-import Network.Wai.Handler.Warp.Recv-import Network.Wai.Handler.Warp.Request-import Network.Wai.Handler.Warp.Response-import Network.Wai.Handler.Warp.SendFile+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 Network.Wai.Internal (ResponseReceived (ResponseReceived))-import System.Environment (getEnvironment)-import System.IO.Error (isFullErrorType, ioeGetErrorType) -#if WINDOWS-import Network.Wai.Handler.Warp.Windows+-- | 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 --- | Creating 'Connection' for plain HTTP based on a given socket.-socketConnection :: Socket -> IO Connection-socketConnection s = do-    bufferPool <- newBufferPool-    writeBuf <- allocateBuffer bufferSize-    let sendall = Sock.sendAll s-    return Connection {-        connSendMany = Sock.sendMany s-      , connSendAll = sendall-      , connSendFile = sendFile s writeBuf bufferSize sendall-      , connClose = sClose s >> freeBuffer writeBuf-      , connRecv = receive s bufferPool-      , connRecvBuf = receiveBuf s-      , connWriteBuffer = writeBuf-      , connBufferSize = bufferSize-      }+    sendfile writeBufferRef fid offset len hook headers = do+        writeBuffer <- readIORef writeBufferRef+        sendFile+            s+            (bufBuffer writeBuffer)+            (bufSize writeBuffer)+            sendall+            fid+            offset+            len+            hook+            headers -#if __GLASGOW_HASKELL__ < 702-allowInterrupt :: IO ()-allowInterrupt = unblock $ return ()-#endif+    sendall = sendAll' s --- Composition over two arguments at once; used for runHTTP2\*.-(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d-f .: g = curry $ f . uncurry g+    sendAll' sock bs =+        E.handleJust+            ( \e ->+                if ioeGetErrorType e == ResourceVanished+                    then Just ConnectionClosedByPeer+                    else Nothing+            )+            E.throwIO+            $ Sock.sendAll sock bs +-- | Create a 'Recv' using 'Network.Socket.BufferPool.Recv.receive', but make+-- it non-blocking with 'waitReadSocketSTM' /AND/ cut off receiving any bytes+-- when the server is shutting down and there are no more 'Application's+-- actively using this 'Socket'.+makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv+makeGracefulRecv sock pool ss appsInProgress = do+    sockWait <-+#if !WINDOWS && MIN_VERSION_network(3,2,2)+        waitReadSocketSTM sock+#else+        -- FIXME: 'waitReadSocketSTM' doesn't work on WINDOWS, and actually+        -- blocks indefinitely, so we fall back to going straight to 'recv'.+        pure (pure ())+#endif+    isShuttingDown <- atomically $+        -- when shutting down+        (checkShutdown $> True)+        <|>+        -- else wait for socket readiness and do non-blocking read+        (sockWait $> False)+    if isShuttingDown then pure "" else recv+  where+    recv = receive sock pool+    checkShutdown = do+       check =<< currentShuttingDownStateSTM ss+       check . (<= 0) =<< readTVar appsInProgress+ -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO ()-run port = runServe port . serveDefault---- | Serve an 'HTTP2Application' and an 'Application' together on the given--- port.-runHTTP2 :: Port -> HTTP2Application -> Application -> IO ()-runHTTP2 port = runServe port .: serveHTTP2---- | The generalized form of 'run'.-runServe :: Port -> ServeConnection -> IO ()-runServe p = runServeSettings defaultSettings { settingsPort = p }+run p = runSettings defaultSettings{settingsPort = p}  -- | Run an 'Application' on the port present in the @PORT@ -- environment variable. Uses the 'Port' given when the variable is unset.@@ -98,44 +176,29 @@ -- -- Since 3.0.9 runEnv :: Port -> Application -> IO ()-runEnv port = runServeEnv port . serveDefault---- | The HTTP\/2-aware form of 'runEnv'.-runHTTP2Env :: Port -> HTTP2Application -> Application -> IO ()-runHTTP2Env port = runServeEnv port .: serveHTTP2---- | The generalized form of 'runEnv'.-runServeEnv :: Port -> ServeConnection -> IO ()-runServeEnv p serveConn = do-    mp <- lookup "PORT" <$> getEnvironment--    maybe (runServe p serveConn) runReadPort mp+runEnv p app = do+    mp <- lookupEnv "PORT" +    maybe (run p app) runReadPort mp   where     runReadPort :: String -> IO ()     runReadPort sp = case reads sp of-        ((p', _):_) -> runServe p' serveConn+        ((p', _) : _) -> run p' app         _ -> fail $ "Invalid value in $PORT: " ++ sp  -- | Run an 'Application' with the given 'Settings'. -- This opens a listen socket on the port defined in 'Settings' and -- calls 'runSettingsSocket'. runSettings :: Settings -> Application -> IO ()-runSettings set = runServeSettings set . serveDefault---- | The HTTP\/2-aware form of 'runSettings'.-runHTTP2Settings :: Settings -> HTTP2Application -> Application -> IO ()-runHTTP2Settings set = runServeSettings set .: serveHTTP2---- | The generalized form of 'runSettings'.-runServeSettings :: Settings -> ServeConnection -> IO ()-runServeSettings set serveConn = withSocketsDo $-    bracket-        (bindPortTCP (settingsPort set) (settingsHost set))-        sClose-        (\socket -> do-            setSocketCloseOnExec socket-            runServeSettingsSocket set socket serveConn)+runSettings set app =+    withSocketsDo $+        E.bracket+            (bindPortTCP (settingsPort set) (settingsHost set))+            close+            ( \socket -> do+                setSocketCloseOnExec socket+                runSettingsSocket set socket app+            )  -- | This installs a shutdown handler for the given socket and -- calls 'runSettingsConnection' with the default connection setup action@@ -149,34 +212,20 @@ -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO ()-runSettingsSocket set socket = runServeSettingsSocket set socket . serveDefault---- | The HTTP\/2-aware form of 'runSettingsSocket'.-runHTTP2SettingsSocket :: Settings-                       -> Socket-                       -> HTTP2Application-                       -> Application-                       -> IO ()-runHTTP2SettingsSocket set socket =-    runServeSettingsSocket set socket .: serveHTTP2---- | The generalized form of 'runSettingsSocket'.-runServeSettingsSocket :: Settings -> Socket -> ServeConnection -> IO ()-runServeSettingsSocket set socket serveConn = do-    settingsInstallShutdownHandler set closeListenSocket-    runServeSettingsConnection set getConn serveConn+runSettingsSocket oldSettings@Settings{settingsAccept = accept'} socket app = do+    settingsInstallShutdownHandler oldSettings closeListenSocket+    (_, newSettings) <- makeServerState oldSettings+    runSettingsConnection newSettings (getConn newSettings) app   where-    getConn = do-#if WINDOWS-        (s, sa) <- windowsThreadBlockHack $ accept socket-#else-        (s, sa) <- accept socket-#endif+    getConn set = do+        (s, sa) <- accept' socket         setSocketCloseOnExec s-        conn <- socketConnection s+        -- NoDelay causes an error for AF_UNIX.+        setSocketOption s NoDelay 1 `E.catch` throughAsync (return ())+        conn <- socketConnection set s         return (conn, sa) -    closeListenSocket = sClose socket+    closeListenSocket = close socket  -- | The connection setup action would be expensive. A good example -- is initialization of TLS.@@ -187,37 +236,22 @@ -- in a separate worker thread instead of the main server loop. -- -- Since 1.3.5-runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()-runSettingsConnection set getConn =-    runServeSettingsConnection set getConn . serveDefault---- | The generalized form of 'runSettingsConnection'.-runServeSettingsConnection :: Settings-                           -> IO (Connection, SockAddr)-                           -> ServeConnection-                           -> IO ()-runServeSettingsConnection set getConn serveConn =-    runServeSettingsConnectionMaker set getConnMaker serveConn+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)+        (conn, sa) <- getConn+        return (return conn, sa)  -- | This modifies the connection maker so that it returns 'TCP' for 'Transport' -- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.-runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()-runSettingsConnectionMaker set getConnMaker =-    runServeSettingsConnectionMaker set getConnMaker . serveDefault---- | The generalized form of 'runSettingsConnectionMaker'.-runServeSettingsConnectionMaker :: Settings-                                -> IO (IO Connection, SockAddr)-                                -> ServeConnection-                                -> IO ()-runServeSettingsConnectionMaker x y =-    runServeSettingsConnectionMakerSecure x (toTCP <$> y)+runSettingsConnectionMaker+    :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()+runSettingsConnectionMaker x y =+    runSettingsConnectionMakerSecure x (toTCP <$> y)   where-    toTCP = first ((, TCP) <$>)+    toTCP = first ((,TCP) <$>)  ---------------------------------------------------------------- @@ -227,36 +261,37 @@ -- or HTTP over TLS. -- -- Since 2.1.4-runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()-runSettingsConnectionMakerSecure set getConnMaker =-    runServeSettingsConnectionMakerSecure set getConnMaker . serveDefault+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 --- | The generalized form of 'runSettingsConnectionMakerSecure'.-runServeSettingsConnectionMakerSecure :: Settings-                                      -> IO (IO (Connection, Transport), SockAddr)-                                      -> ServeConnection-                                      -> IO ()-runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do-    settingsBeforeMainLoop set-    counter <- newCounter-    withII $ acceptConnection set getConnMaker serveConn counter-  where-    withII action =+-- | 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 fdCacheDurationInSeconds $ \fc ->-        I.withFileInfoCache fdFileInfoDurationInSeconds $ \get ->-        withTimeoutManager $ \tm -> do-            let ii0 = InternalInfo undefined tm fc get dc -- fixme: undefined-            action ii0--    fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000-    fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000+            F.withFdCache fdCacheDurationInMicroseconds $ \fdc ->+                I.withFileInfoCache fdFileInfoDurationInMicroseconds $ \fic -> do+                    let ii = InternalInfo tm dc fdc fic+                    action ii+  where+    !fdCacheDurationInMicroseconds = settingsFdCacheDuration set * 1000000+    !fdFileInfoDurationInMicroseconds = settingsFileInfoCacheDuration set * 1000000+    !timeoutInMicroseconds = settingsTimeout set * 1000000     withTimeoutManager f = case settingsManager set of         Just tm -> f tm-        Nothing -> bracket-                   (T.initialize $ settingsTimeout set * 1000000)-                   T.stopManager-                   f+        Nothing ->+            E.bracket+                (T.initialize timeoutInMicroseconds)+                T.stopManager+                f  -- Note that there is a thorough discussion of the exception safety of the -- following code at: https://github.com/yesodweb/wai/issues/146@@ -271,22 +306,32 @@ --    async exceptions. -- -- Our approach is explained in the comments below.-acceptConnection :: Settings-                 -> IO (IO (Connection, Transport), SockAddr)-                 -> ServeConnection-                 -> Counter-                 -> InternalInfo-                 -> IO ()-acceptConnection set getConnMaker serveConn counter ii0 = do+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.-    void $ mask_ acceptLoop-    gracefulShutdown counter+    --+    -- acceptLoop can be broken by closing the listening socket.+    void $ E.mask_ acceptLoop+    -- In some cases, we want to stop Warp here without graceful shutdown.+    -- So, async exceptions are allowed here.+    -- That's why `finally` is not used.+    gracefulShutdown set counter   where     acceptLoop = do         -- Allow async exceptions before receiving the next connection maker.-        allowInterrupt+        E.allowInterrupt          -- acceptNewConnection will try to receive the next incoming         -- request. It returns a /connection maker/, not a connection,@@ -297,277 +342,197 @@         -- negotiation.         mx <- acceptNewConnection         case mx of-            Nothing             -> return ()+            Nothing -> return ()             Just (mkConn, addr) -> do-                fork set mkConn addr serveConn counter ii0+                fork set mkConn addr app counter ii                 acceptLoop      acceptNewConnection = do-        ex <- try getConnMaker+        ex <- E.try getConnMaker         case ex of-            Right x -> return $ Just x-            Left  e  -> do-                settingsOnException set Nothing $ toException e-                if isFullErrorType (ioeGetErrorType e) then do-                    -- "resource exhausted (Too many open files)" may-                    -- happen by accept().  Wait a second hoping that-                    -- resource will be available.-                    threadDelay 1000000-                    acceptNewConnection-                  else-                    -- Assuming the listen socket is closed.-                    return Nothing+            Right x -> do+                -- Important to mark the exhaustion issue to be resolved+                -- when we get connections again.+                resetFdExhaustion fdRef+                return $ Just x+            Left e -> do+                let getErrno (Errno cInt) = cInt+                    isErrno err = ioe_errno e == Just (getErrno err)+                if | isErrno eCONNABORTED -> do+                        -- Important to mark the exhaustion issue to be resolved+                        resetFdExhaustion fdRef+                        acceptNewConnection+                     -- Keep in mind to reset the ref when anything other+                     -- than this branch runs+                   | isErrno eMFILE -> do+                        handleFdExhaustion e+                        acceptNewConnection+                   | otherwise -> do+                        -- Maybe not important to mark the exhaustion issue+                        -- as resolved here, but just for completeness' sake.+                        resetFdExhaustion fdRef+                        settingsOnException set Nothing $ E.toException e+                        return Nothing +    handleFdExhaustion e = do+        fdExhaustion <- readIORef fdRef+        -- If file descriptors are exhausted while Warp has+        -- no current connections, 'settingsOnException' would+        -- get called an enormous amount of times per second.+        when (fdExhaustion /= FdExhausted) $+            settingsOnException set Nothing $ E.toException e+        hasDecreased <- waitForDecreased counter+        -- If we get 'NoConnections', that means the file+        -- descriptor exhaustion is outside of our control.+        -- We flag it so that 'settingsOnException' doesn't get+        -- called until the exhaustion issue is resolved.+        when (hasDecreased == NoConnections) $ setFdExhaustion fdRef+ -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown).-fork :: Settings-     -> IO (Connection, Transport)-     -> SockAddr-     -> ServeConnection-     -> Counter-     -> InternalInfo-     -> IO ()-fork set mkConn addr serveConn counter ii0 = settingsFork set $ \ 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.+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.     ---    -- 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 closeConn $ \(conn, transport) ->+    -- Intentionally using Control.Exception.handle, since we want to+    -- catch all exceptions and avoid them from propagating, even+    -- async exceptions. See:+    -- https://github.com/yesodweb/wai/issues/850+    E.handle (settingsOnException set Nothing) $+        -- Run the connection maker to get a new connection, and ensure+        -- that the connection is closed. If the mkConn call throws an+        -- exception, we will leak the connection. If the mkConn call is+        -- vulnerable to attacks (e.g., Slowloris), we do nothing to+        -- protect the server. It is therefore vital that mkConn is well+        -- vetted.+        --+        -- We grab the connection before registering timeouts since the+        -- timeouts will be useless during connection creation, due to the+        -- fact that async exceptions are still masked.+        E.bracket mkConn cleanUp (serve unmask)+  where+    cleanUp (conn, _) =+        connClose conn `E.finally` do+            writeBuffer <- readIORef $ connWriteBuffer conn+            bufFree writeBuffer      -- We need to register a timeout handler for this thread, and     -- cancel that handler as soon as we exit.-    bracket (T.registerKillThread (timeoutManager ii0)) T.cancel $ \th ->--    let ii = ii0 { threadHandle = th }-        -- 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 (settingsOnException set Nothing) .--       -- Call the user-supplied code for connection open and close events-       bracket (onOpen addr) (onClose addr) $ \goingon ->--       -- Actually serve this connection.-       -- bracket with closeConn above ensures the connection is closed.-       when goingon $ serveConn conn ii addr transport set-  where-    closeConn (conn, _transport) = connClose conn+    serve unmask (conn, transport) = T.withHandleKillThread (timeoutManager ii) (return ()) $ \th -> do+        -- We now have fully registered a connection close handler in+        -- the case of all exceptions, so it is safe to once again+        -- allow async exceptions.+        unmask+            .+            -- Call the user-supplied code for connection open and+            -- close events+            E.bracket (onOpen addr) (onClose addr)+            $ \goingon ->+                -- Actually serve this connection.  bracket with closeConn+                -- above ensures the connection is closed.+                when goingon $ serveConnection conn ii th addr transport set app -    onOpen adr    = increase counter >> settingsOnOpen  set adr+    onOpen adr = increase counter >> settingsOnOpen set adr     onClose adr _ = decrease counter >> settingsOnClose set adr --- The type of a function to serve a fully-prepared connection.-type ServeConnection = Connection-                    -> InternalInfo-                    -> SockAddr-                    -> Transport-                    -> Settings-                    -> IO ()---- Serve an HTTP\/2-unaware Application to a connection over any HTTP version.-serveDefault :: Application -> ServeConnection-serveDefault app = serveHTTP2 (promoteApplication app) app---- Serve an HTTP\/2-aware application over HTTP\/2 or a backup 'Application'--- over HTTP\/1.1 or HTTP\/1.-serveHTTP2 :: HTTP2Application -> Application -> ServeConnection-serveHTTP2 app2 app conn ii origAddr transport settings = do+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.-    (h2,bs) <- if isHTTP2 transport then-                   return (True, "")-                 else do-                   bs0 <- connRecv conn-                   if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0 then-                       return (True, bs0)-                     else-                       return (False, bs0)-    if settingsHTTP2Enabled settings && h2 then do-        recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)-        -- fixme: origAddr-        http2 conn ii origAddr transport settings recvN app2-      else do-        istatus <- newIORef False-        src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))-        writeIORef istatus True-        leftoverSource src bs-        addr <- getProxyProtocolAddr src-        http1 addr istatus src `E.catch` \e -> do-            sendErrorResponse addr istatus e-            throwIO (e :: SomeException)-  where-    getProxyProtocolAddr src =-        case settingsProxyProtocol settings of-            ProxyProtocolNone ->-                return origAddr-            ProxyProtocolRequired -> do-                seg <- readSource src-                parseProxyProtocolHeader src seg-            ProxyProtocolOptional -> do-                seg <- readSource src-                if S.isPrefixOf "PROXY " seg-                    then parseProxyProtocolHeader src seg-                    else do leftoverSource src seg-                            return origAddr--    parseProxyProtocolHeader src seg = do-        let (header,seg') = S.break (== 0x0d) seg -- 0x0d == CR-            maybeAddr = case S.split 0x20 header of -- 0x20 == space-                ["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 (S.drop 2 seg') -- drop CRLF-                         return a--    decodeAscii = map (chr . fromEnum) . S.unpack--    th = threadHandle ii--    shouldSendErrorResponse se-        | Just ConnectionClosedByPeer <- fromException se = False-        | otherwise                                       = True--    sendErrorResponse addr istatus e = do-        status <- readIORef istatus-        when (shouldSendErrorResponse e && status) $ void $-            sendResponse settings conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)--    dummyreq addr = defaultRequest { remoteHost = addr }--    errorResponse e = settingsOnExceptionResponse settings e--    http1 addr istatus src = do-        (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest settings conn ii addr src-        let req = req' { isSecure = isTransportSecure transport }-        keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush-            `E.catch` \e -> do-                -- Call the user-supplied exception handlers, passing the request.-                sendErrorResponse addr istatus e-                settingsOnException settings (Just req) e-                -- Don't throw the error again to prevent calling settingsOnException twice.-                return False-        when keepAlive $ http1 addr istatus src--    processRequest 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"-        _ <- 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 req idxhdr (readSource src) res-            writeIORef keepAliveRef keepAlive-            return ResponseReceived-        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 the IO manager works.-        -- 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 not keepAlive then-            return False-          else-            -- 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 True-                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 True-                              else-                                return False-                    case mremainingRef of-                        Just ref -> do-                            remaining <- readIORef ref-                            if remaining <= maxToRead then-                                tryKeepAlive-                              else-                                return False-                        Nothing -> tryKeepAlive--flushEntireBody :: IO ByteString -> IO ()-flushEntireBody src =-    loop-  where-    loop = do-        bs <- src-        unless (S.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+    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-    loop toRead = do-        bs <- src-        let toRead' = toRead - S.length bs-        case () of-            ()-                | S.null bs -> return True-                | toRead' >= 0 -> loop toRead'-                | otherwise -> return False--wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString-wrappedRecv Connection { connRecv = recv } th istatus slowlorisSize = do-    bs <- recv-    unless (S.null bs) $ do-        writeIORef istatus True-        when (S.length bs >= slowlorisSize) $ T.tickle th-    return bs+    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 :: Counter -> IO ()-gracefulShutdown counter = waitForZero counter+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