diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -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 . --- --- 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 diff --git a/Network/Wai/Handler/Warp/Buffer.hs b/Network/Wai/Handler/Warp/Buffer.hs --- a/Network/Wai/Handler/Warp/Buffer.hs +++ b/Network/Wai/Handler/Warp/Buffer.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Conduit.hs b/Network/Wai/Handler/Warp/Conduit.hs --- a/Network/Wai/Handler/Warp/Conduit.hs +++ b/Network/Wai/Handler/Warp/Conduit.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Counter.hs b/Network/Wai/Handler/Warp/Counter.hs --- a/Network/Wai/Handler/Warp/Counter.hs +++ b/Network/Wai/Handler/Warp/Counter.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Date.hs b/Network/Wai/Handler/Warp/Date.hs --- a/Network/Wai/Handler/Warp/Date.hs +++ b/Network/Wai/Handler/Warp/Date.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/FdCache.hs b/Network/Wai/Handler/Warp/FdCache.hs --- a/Network/Wai/Handler/Warp/FdCache.hs +++ b/Network/Wai/Handler/Warp/FdCache.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/File.hs b/Network/Wai/Handler/Warp/File.hs --- a/Network/Wai/Handler/Warp/File.hs +++ b/Network/Wai/Handler/Warp/File.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/FileInfoCache.hs b/Network/Wai/Handler/Warp/FileInfoCache.hs --- a/Network/Wai/Handler/Warp/FileInfoCache.hs +++ b/Network/Wai/Handler/Warp/FileInfoCache.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP1.hs b/Network/Wai/Handler/Warp/HTTP1.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HTTP1.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs b/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/File.hs b/Network/Wai/Handler/Warp/HTTP2/File.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HTTP2/File.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs b/Network/Wai/Handler/Warp/HTTP2/HPACK.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs +++ /dev/null @@ -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)] diff --git a/Network/Wai/Handler/Warp/HTTP2/Manager.hs b/Network/Wai/Handler/Warp/HTTP2/Manager.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Manager.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs b/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs b/Network/Wai/Handler/Warp/HTTP2/Receiver.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Request.hs b/Network/Wai/Handler/Warp/HTTP2/Request.hs --- a/Network/Wai/Handler/Warp/HTTP2/Request.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Request.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Response.hs b/Network/Wai/Handler/Warp/HTTP2/Response.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HTTP2/Response.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Sender.hs b/Network/Wai/Handler/Warp/HTTP2/Sender.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Sender.hs +++ /dev/null @@ -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)) diff --git a/Network/Wai/Handler/Warp/HTTP2/Types.hs b/Network/Wai/Handler/Warp/HTTP2/Types.hs --- a/Network/Wai/Handler/Warp/HTTP2/Types.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Types.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Worker.hs b/Network/Wai/Handler/Warp/HTTP2/Worker.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Worker.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Handler/Warp/HashMap.hs b/Network/Wai/Handler/Warp/HashMap.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HashMap.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Header.hs b/Network/Wai/Handler/Warp/Header.hs --- a/Network/Wai/Handler/Warp/Header.hs +++ b/Network/Wai/Handler/Warp/Header.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/IO.hs b/Network/Wai/Handler/Warp/IO.hs --- a/Network/Wai/Handler/Warp/IO.hs +++ b/Network/Wai/Handler/Warp/IO.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/IORef.hs b/Network/Wai/Handler/Warp/IORef.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/IORef.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Handler/Warp/Imports.hs b/Network/Wai/Handler/Warp/Imports.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Imports.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Internal.hs b/Network/Wai/Handler/Warp/Internal.hs --- a/Network/Wai/Handler/Warp/Internal.hs +++ b/Network/Wai/Handler/Warp/Internal.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/MultiMap.hs b/Network/Wai/Handler/Warp/MultiMap.hs --- a/Network/Wai/Handler/Warp/MultiMap.hs +++ b/Network/Wai/Handler/Warp/MultiMap.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/PackInt.hs b/Network/Wai/Handler/Warp/PackInt.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/PackInt.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/ReadInt.hs b/Network/Wai/Handler/Warp/ReadInt.hs --- a/Network/Wai/Handler/Warp/ReadInt.hs +++ b/Network/Wai/Handler/Warp/ReadInt.hs @@ -1,26 +1,22 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} -- Copyright : Erik de Castro Lopo -- 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 diff --git a/Network/Wai/Handler/Warp/Recv.hs b/Network/Wai/Handler/Warp/Recv.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/Recv.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Handler/Warp/Request.hs b/Network/Wai/Handler/Warp/Request.hs --- a/Network/Wai/Handler/Warp/Request.hs +++ b/Network/Wai/Handler/Warp/Request.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/RequestHeader.hs b/Network/Wai/Handler/Warp/RequestHeader.hs --- a/Network/Wai/Handler/Warp/RequestHeader.hs +++ b/Network/Wai/Handler/Warp/RequestHeader.hs @@ -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') diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -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 = diff --git a/Network/Wai/Handler/Warp/ResponseHeader.hs b/Network/Wai/Handler/Warp/ResponseHeader.hs --- a/Network/Wai/Handler/Warp/ResponseHeader.hs +++ b/Network/Wai/Handler/Warp/ResponseHeader.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where -import Control.Monad -import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Internal (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 diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/SendFile.hs b/Network/Wai/Handler/Warp/SendFile.hs --- a/Network/Wai/Handler/Warp/SendFile.hs +++ b/Network/Wai/Handler/Warp/SendFile.hs @@ -1,39 +1,37 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} module Network.Wai.Handler.Warp.SendFile ( - sendFile - , readSendFile - , packHeader -- for testing + sendFile, + readSendFile, + packHeader, -- for testing #ifndef WINDOWS - , positionRead + positionRead, #endif - ) where +) where -import Control.Monad (void) -import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Network.Socket (Socket) -import Network.Wai.Handler.Warp.Buffer -import Network.Wai.Handler.Warp.Types +import Network.Socket.BufferPool #ifdef WINDOWS -import Control.Monad (when) -import Data.ByteString.Internal (ByteString(..)) import Foreign.ForeignPtr (newForeignPtr_) import Foreign.Ptr (plusPtr) import qualified System.IO as IO #else -# if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<$>)) -# endif -import Control.Exception +import qualified Control.Exception as E +import Foreign.C.Error (throwErrno) import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr) import Network.Sendfile -import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd) +import Network.Wai.Handler.Warp.FdCache (openFile, closeFile) import System.Posix.Types #endif +import Network.Wai.Handler.Warp.Buffer +import Network.Wai.Handler.Warp.Imports +import Network.Wai.Handler.Warp.Types + ---------------------------------------------------------------- -- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD. @@ -45,8 +43,8 @@ #ifdef SENDFILEFD sendFile s _ _ _ fid off len act hdr = case mfid of -- settingsFdCacheDuration is 0 - Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr - Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr + Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr + Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr where mfid = fileIdFd fid path = fileIdPath fid @@ -56,31 +54,35 @@ ---------------------------------------------------------------- -packHeader :: Buffer -> BufSize -> (ByteString -> IO ()) - -> IO () -> [ByteString] - -> Int - -> IO Int -packHeader _ _ _ _ [] n = return n -packHeader buf siz send hook (bs:bss) n - | len < room = do - let dst = buf `plusPtr` n - void $ copy dst bs - packHeader buf siz send hook bss (n + len) - | otherwise = do - let dst = buf `plusPtr` n - (bs1, bs2) = BS.splitAt room bs - void $ copy dst bs1 - bufferIO buf siz send - hook - packHeader buf siz send hook (bs2:bss) 0 +packHeader + :: Buffer + -> BufSize + -> (ByteString -> IO ()) + -> IO () + -> [ByteString] + -> Int + -> IO Int +packHeader _ _ _ _ [] n = return n +packHeader buf siz send hook (bs : bss) n + | len < room = do + let dst = buf `plusPtr` n + void $ copy dst bs + packHeader buf siz send hook bss (n + len) + | otherwise = do + let dst = buf `plusPtr` n + (bs1, bs2) = BS.splitAt room bs + void $ copy dst bs1 + bufferIO buf siz send + hook + packHeader buf siz send hook (bs2 : bss) 0 where len = BS.length bs room = siz - n mini :: Int -> Integer -> Int mini i n - | fromIntegral i < n = i - | otherwise = fromIntegral n + | fromIntegral i < n = i + | otherwise = fromIntegral n -- | Function to send a file based on pread()\/send() for Unix. -- This makes use of the file descriptor cache. @@ -104,48 +106,51 @@ where path = fileIdPath fid loop h fptr len - | len <= 0 = return () - | otherwise = do - n <- IO.hGetBufSome h buf (mini siz len) - when (n /= 0) $ do - let bs = PS fptr 0 n - n' = fromIntegral n - send bs - hook - loop h fptr (len - n') + | len <= 0 = return () + | otherwise = do + n <- IO.hGetBufSome h buf (mini siz len) + when (n /= 0) $ do + let bs = PS fptr 0 n + n' = fromIntegral n + send bs + hook + loop h fptr (len - n') #else readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers = - bracket setup teardown $ \fd -> do - hn <- packHeader buf siz send hook headers 0 - let room = siz - hn - buf' = buf `plusPtr` hn - n <- positionRead fd buf' (mini room len0) off0 - bufferIO buf (hn + n) send - hook - let n' = fromIntegral n - loop fd (len0 - n') (off0 + n') + E.bracket setup teardown $ \fd -> do + hn <- packHeader buf siz send hook headers 0 + let room = siz - hn + buf' = buf `plusPtr` hn + n <- positionRead fd buf' (mini room len0) off0 + bufferIO buf (hn + n) send + hook + let n' = fromIntegral n + loop fd (len0 - n') (off0 + n') where path = fileIdPath fid setup = case fileIdFd fid of - Just fd -> return fd - Nothing -> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True} + Just fd -> return fd + Nothing -> openFile path teardown fd = case fileIdFd fid of - Just _ -> return () - Nothing -> closeFd fd + Just _ -> return () + Nothing -> closeFile fd loop fd len off - | len <= 0 = return () - | otherwise = do - n <- positionRead fd buf (mini siz len) off - bufferIO buf n send - let n' = fromIntegral n - hook - loop fd (len - n') (off + n') + | len <= 0 = return () + | otherwise = do + n <- positionRead fd buf (mini siz len) off + bufferIO buf n send + let n' = fromIntegral n + hook + loop fd (len - n') (off + n') positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int -positionRead fd buf siz off = - fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off) +positionRead fd buf siz off = do + bytes <- + fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off) + when (bytes < 0) $ throwErrno "positionRead" + return bytes foreign import ccall unsafe "pread" - c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize + c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize #endif diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -1,32 +1,49 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-} -{-# LANGUAGE PatternGuards, RankNTypes #-} -{-# LANGUAGE ImpredicativeTypes, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} module Network.Wai.Handler.Warp.Settings where -import Control.Concurrent (forkIOWithUnmask) -import Control.Exception -import Control.Monad (when, void) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as S8 -import Data.ByteString.Builder (byteString) -#if __GLASGOW_HASKELL__ < 709 -import Data.Monoid (mappend) -#endif +import Control.Concurrent.STM (STM) +import Control.Exception (SomeException (..), fromException, throw) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Char8 as C8 import Data.Streaming.Network (HostPreference) import qualified Data.Text as T import qualified Data.Text.IO as TIO -import Data.Version (showVersion) -import GHC.IO.Exception (IOErrorType(..)) +import GHC.Exts (fork#) +import GHC.IO (IO (IO), unsafeUnmask) +import GHC.IO.Exception (IOErrorType (..)) import qualified Network.HTTP.Types as H -import Network.Socket (SockAddr) +import Network.Socket (SockAddr, Socket, accept) import Network.Wai -import Network.Wai.Handler.Warp.Timeout -import Network.Wai.Handler.Warp.Types -import qualified Paths_warp import System.IO (stderr) import System.IO.Error (ioeGetErrorType) +import System.TimeManager +import Network.Wai.Handler.Warp.Counter (Counter, getCount, newCounter, getCountSTM) +import Network.Wai.Handler.Warp.Imports +import Network.Wai.Handler.Warp.ShuttingDown ( + ShuttingDown, + newShuttingDown, + readShuttingDown, + readShuttingDownSTM, + ) +import Network.Wai.Handler.Warp.Types +#if WINDOWS +import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack) +#endif + +#ifdef INCLUDE_WARP_VERSION +import Data.Version (showVersion) +import qualified Paths_warp +#endif + -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create a 'Settings' value, use 'defaultSettings' @@ -34,109 +51,304 @@ -- -- > setTimeout 20 defaultSettings data Settings = Settings - { settingsPort :: Port -- ^ Port to listen on. Default value: 3000 - , settingsHost :: HostPreference -- ^ Default value: HostIPv4 - , settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. + { settingsPort :: Port + -- ^ Port to listen on. Default value: 3000 + , settingsHost :: HostPreference + -- ^ Default value: HostIPv4 + , settingsOnException :: Maybe Request -> SomeException -> IO () + -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , settingsOnExceptionResponse :: SomeException -> Response - -- ^ A function to create `Response` when an exception occurs. - -- - -- Default: 500, text/plain, \"Something went wrong\" - -- - -- Since 2.0.3 - , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'. - , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing. - , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 - , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' - , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0 - , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0 + -- ^ A function to create `Response` when an exception occurs. + -- + -- Default: 500, text/plain, \"Something went wrong\" + -- + -- Since 2.0.3 + , settingsOnOpen :: SockAddr -> IO Bool + -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'. + , settingsOnClose :: SockAddr -> IO () + -- ^ What to do when a connection is close. Default: do nothing. + , settingsTimeout :: Int + -- ^ Timeout value in seconds. Default value: 30 + , settingsManager :: Maybe Manager + -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' + , settingsFdCacheDuration :: Int + -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0 + , settingsFileInfoCacheDuration :: Int + -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsBeforeMainLoop :: IO () - -- ^ Code to run after the listening socket is ready but before entering - -- the main event loop. Useful for signaling to tests that they can start - -- running, or to drop permissions after binding to a restricted port. - -- - -- Default: do nothing. - -- - -- Since 1.3.6 - + -- ^ Code to run after the listening socket is ready but before entering + -- the main event loop. Useful for signaling to tests that they can start + -- running, or to drop permissions after binding to a restricted port. + -- + -- Default: do nothing. + -- + -- Since 1.3.6 , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO () - -- ^ Code to fork a new thread to accept a connection. - -- - -- This may be useful if you need OS bound threads, or if - -- you wish to develop an alternative threading model. - -- - -- Default: void . forkIOWithUnmask - -- - -- Since 3.0.4 - + -- ^ Code to fork a new thread to accept a connection. + -- + -- This may be useful if you need OS bound threads, or if + -- you wish to develop an alternative threading model. + -- + -- Default: 'defaultFork' + -- + -- Since 3.0.4 + , settingsAccept :: Socket -> IO (Socket, SockAddr) + -- ^ Code to accept a new connection. + -- + -- Useful if you need to provide connected sockets from something other + -- than a standard accept call. + -- + -- Default: 'defaultAccept' + -- + -- Since 3.3.24 , settingsNoParsePath :: Bool - -- ^ Perform no parsing on the rawPathInfo. - -- - -- This is useful for writing HTTP proxies. - -- - -- Default: False - -- - -- Since 2.0.3 + -- ^ Perform no parsing on the rawPathInfo. + -- + -- This is useful for writing HTTP proxies. + -- + -- Default: False + -- + -- Since 2.0.3 , settingsInstallShutdownHandler :: IO () -> IO () + -- ^ An action to install a handler (e.g. Unix signal handler) + -- to close a listen socket. + -- The first argument is an action to close the listen socket. + -- + -- Default: no action + -- + -- Since 3.0.1 , settingsServerName :: ByteString - -- ^ Default server name if application does not set one. - -- - -- Since 3.0.2 + -- ^ Default server name if application does not set one. + -- + -- Since 3.0.2 , settingsMaximumBodyFlush :: Maybe Int - -- ^ See @setMaximumBodyFlush@. - -- - -- Since 3.0.3 + -- ^ See @setMaximumBodyFlush@. + -- + -- Since 3.0.3 , settingsProxyProtocol :: ProxyProtocol - -- ^ Specify usage of the PROXY protocol. - -- - -- Since 3.0.5. + -- ^ Specify usage of the PROXY protocol. + -- + -- Since 3.0.5 , settingsSlowlorisSize :: Int - -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048 - -- - -- Since 3.1.2. + -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048 + -- + -- Since 3.1.2 , settingsHTTP2Enabled :: Bool - -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True - -- - -- Since 3.1.7. + -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True + -- + -- Since 3.1.7 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO () - -- ^ A log function. Default: no action. - -- - -- Since 3.X.X. + -- ^ A log function. Default: no action. + -- + -- Since 3.1.10 + , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO () + -- ^ A HTTP/2 server push log function. Default: no action. + -- + -- Since 3.2.7 + , settingsGracefulShutdownTimeout :: Maybe Int + -- ^ An optional timeout to limit the time (in seconds) waiting for + -- a graceful shutdown of the web server. + -- + -- Since 3.2.8 + , settingsGracefulCloseTimeout1 :: Int + -- ^ A timeout to limit the time (in milliseconds) waiting for + -- FIN for HTTP/1.x. 0 means uses immediate close. + -- Default: 0. + -- + -- Since 3.3.5 + , settingsGracefulCloseTimeout2 :: Int + -- ^ A timeout to limit the time (in milliseconds) waiting for + -- FIN for HTTP/2. 0 means uses immediate close. + -- Default: 2000. + -- + -- Since 3.3.5 + , settingsMaxTotalHeaderLength :: Int + -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x. + -- + -- Since 3.3.8 + , settingsAltSvc :: Maybe ByteString + -- ^ Specify the header value of Alternative Services (AltSvc:). + -- + -- Default: Nothing + -- + -- Since 3.3.11 + , settingsMaxBuilderResponseBufferSize :: Int + -- ^ Determines the maxium buffer size when sending `Builder` responses + -- (See `responseBuilder`). + -- + -- When sending a builder response warp uses a 16 KiB buffer to write the + -- builder to. When that buffer is too small to fit the builder warp will + -- free it and create a new one that will fit the builder. + -- + -- To protect against allocating too large a buffer warp will error if the + -- builder requires more than this maximum. + -- + -- Default: 1049_000_000 = 1 MiB. + -- + -- Since 3.3.22 + , settingsConnectionCounter :: Maybe Counter + -- ^ A counter for tracking open connections. + -- Use 'makeSettingsAndCounter' to create settings with a counter, + -- then use 'getCount' on the returned 'Counter' to read the current value. + -- + -- Default: 'Nothing' (warp creates an internal counter) + -- + -- /DEPRECATED in favor of 'settingsServerState'/ + -- + -- Since 3.4.11 + , settingsServerState :: Maybe ServerState + -- ^ Internal read-only server state. + -- Use 'makeSettingsAndServerState' to gain access to the state of the server. + -- Using functions like 'currentOpenConnections' or 'currentShuttingDownState' + -- to gain insight into the current state of the server. + -- + -- Default: 'Nothing' (warp creates its own internal state) + -- + -- Since 3.4.13 } -- | Specify usage of the PROXY protocol. -data ProxyProtocol = ProxyProtocolNone - -- ^ See @setProxyProtocolNone@. - | ProxyProtocolRequired - -- ^ See @setProxyProtocolRequired@. - | ProxyProtocolOptional - -- ^ See @setProxyProtocolOptional@. +data ProxyProtocol + = -- | See @setProxyProtocolNone@. + ProxyProtocolNone + | -- | See @setProxyProtocolRequired@. + ProxyProtocolRequired + | -- | See @setProxyProtocolOptional@. + ProxyProtocolOptional +-- | Internal read-only state of the server +-- +-- Since 3.4.13 +data ServerState = ServerState + { serverConnectionCounter :: Counter + , serverShuttingDown :: ShuttingDown + } + +-- | Takes 'Settings' and either returns the 'ServerState' +-- that was already in there, or creates a new 'ServerState'. +-- +-- The returned 'Settings' will always contain a 'ServerState'. +-- +-- This makes it idempotent if care is taken that the @oldSettings@ +-- are not used after using this function. +-- +-- Since 3.4.13 +makeServerState :: Settings -> IO (ServerState, Settings) +makeServerState oldSettings = + case settingsServerState oldSettings of + Just serverState -> pure (serverState, oldSettings) + Nothing -> do + serverState <- newServerState + let counter = serverConnectionCounter serverState + pure + ( serverState + , oldSettings + { settingsServerState = Just serverState + , settingsConnectionCounter = Just counter + } + ) + +-- | Initialize a 'ServerState' +-- +-- Since 3.4.13 +newServerState :: IO ServerState +newServerState = do + counter <- newCounter + shuttingDown <- newShuttingDown + pure + ServerState + { serverConnectionCounter = counter + , serverShuttingDown = shuttingDown + } + +-- | Get the currently open connections of the server. +-- +-- Since 3.4.13 +currentOpenConnections :: ServerState -> IO Int +currentOpenConnections = getCount . serverConnectionCounter + +-- | Get the currently open connections of the server in an 'STM' transaction. +-- +-- Since 3.4.13 +currentOpenConnectionsSTM :: ServerState -> STM Int +currentOpenConnectionsSTM = getCountSTM . serverConnectionCounter + +-- | Check if the server is currently shutting down. +-- +-- > False: Server is not shutting down +-- > True: Server is shutting down or has shut down. +-- +-- Since 3.4.13 +currentShuttingDownState :: ServerState -> IO Bool +currentShuttingDownState = readShuttingDown . serverShuttingDown + +-- | Check if the server is currently shutting down in an 'STM' transaction. +-- +-- (This way you can have a thread wait for server shutdown with 'Control.Concurrent.STM.retry') +-- +-- > False: Server is not shutting down +-- > True: Server is shutting down or has shut down. +-- +-- Since 3.4.13 +currentShuttingDownStateSTM :: ServerState -> STM Bool +currentShuttingDownStateSTM = readShuttingDownSTM . serverShuttingDown + -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings -defaultSettings = Settings - { settingsPort = 3000 - , settingsHost = "*4" - , settingsOnException = defaultOnException - , settingsOnExceptionResponse = defaultOnExceptionResponse - , settingsOnOpen = const $ return True - , settingsOnClose = const $ return () - , settingsTimeout = 30 - , settingsManager = Nothing - , settingsFdCacheDuration = 0 - , settingsFileInfoCacheDuration = 0 - , settingsBeforeMainLoop = return () - , settingsFork = void . forkIOWithUnmask - , settingsNoParsePath = False - , settingsInstallShutdownHandler = const $ return () - , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version - , settingsMaximumBodyFlush = Just 8192 - , settingsProxyProtocol = ProxyProtocolNone - , settingsSlowlorisSize = 2048 - , settingsHTTP2Enabled = True - , settingsLogger = \_ _ _ -> return () - } +defaultSettings = + Settings + { settingsPort = 3000 + , settingsHost = "*4" + , settingsOnException = defaultOnException + , settingsOnExceptionResponse = defaultOnExceptionResponse + , settingsOnOpen = const $ return True + , settingsOnClose = const $ return () + , settingsTimeout = 30 + , settingsManager = Nothing + , settingsFdCacheDuration = 0 + , settingsFileInfoCacheDuration = 0 + , settingsBeforeMainLoop = return () + , settingsFork = defaultFork + , settingsAccept = defaultAccept + , settingsNoParsePath = False + , settingsInstallShutdownHandler = const $ return () + , settingsServerName = C8.pack $ "Warp/" ++ warpVersion + , settingsMaximumBodyFlush = Just 8192 + , settingsProxyProtocol = ProxyProtocolNone + , settingsSlowlorisSize = 2048 + , settingsHTTP2Enabled = True + , settingsLogger = \_ _ _ -> return () + , settingsServerPushLogger = \_ _ _ -> return () + , settingsGracefulShutdownTimeout = Nothing + , settingsGracefulCloseTimeout1 = 0 + , settingsGracefulCloseTimeout2 = 2000 + , settingsMaxTotalHeaderLength = 50 * 1024 + , settingsAltSvc = Nothing + , settingsMaxBuilderResponseBufferSize = 1049000000 + , settingsConnectionCounter = Nothing + , settingsServerState = Nothing + } +-- | Create 'defaultSettings' with a connection counter. +-- Use 'getCount' on the returned 'Counter' to check open connections. +-- +-- /DEPRECATED in favor of 'makeSettingsAndServerState'/ +-- +-- Since 3.4.11 +makeSettingsAndCounter :: IO (Counter, Settings) +makeSettingsAndCounter = do + (serverState, settings) <- makeSettingsAndServerState + pure (serverConnectionCounter serverState, settings) + +-- | Create 'defaultSettings' with a 'ServerState'. +-- Use functions like 'currentOpenConnections' and 'currentShuttingDownState' +-- to gain insight into the state of the server. +-- +-- Since 3.4.13 +makeSettingsAndServerState :: IO (ServerState, Settings) +makeSettingsAndServerState = makeServerState defaultSettings + -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur -- under the normal course of the web server running. @@ -144,11 +356,11 @@ -- Since 2.1.3 defaultShouldDisplayException :: SomeException -> Bool defaultShouldDisplayException se - | Just ThreadKilled <- fromException se = False | Just (_ :: InvalidRequest) <- fromException se = False | Just (ioeGetErrorType -> et) <- fromException se - , et == ResourceVanished || et == InvalidArgument = False - | Just TimeoutThread <- fromException se = False + , et == ResourceVanished || et == InvalidArgument = + False + | isAsyncException se = False | otherwise = True -- | Printing an exception to standard error @@ -157,16 +369,40 @@ -- Since: 3.1.0 defaultOnException :: Maybe Request -> SomeException -> IO () defaultOnException _ e = - when (defaultShouldDisplayException e) - $ TIO.hPutStrLn stderr $ T.pack $ show e + when (defaultShouldDisplayException e) $ + TIO.hPutStrLn stderr $ + T.pack $ + show e --- | Sending 400 for bad requests. Sending 500 for internal server errors. --- +-- | Sending 400 for bad requests. +-- Sending 500 for internal server errors. -- Since: 3.1.0 +-- Sending 413 for too large payload. +-- Sending 431 for too large headers. +-- Since 3.2.27 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e - | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request" - | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong" + | isAsyncException e = throw e + | Just PayloadTooLarge <- fromException e = + responseLBS + H.status413 + [(H.hContentType, "text/plain; charset=utf-8")] + "Payload too large" + | Just RequestHeaderFieldsTooLarge <- fromException e = + responseLBS + H.status431 + [(H.hContentType, "text/plain; charset=utf-8")] + "Request header fields too large" + | Just (_ :: InvalidRequest) <- fromException e = + responseLBS + H.badRequest400 + [(H.hContentType, "text/plain; charset=utf-8")] + "Bad Request" + | otherwise = + responseLBS + H.internalServerError500 + [(H.hContentType, "text/plain; charset=utf-8")] + "Something went wrong" -- | Exception handler for the debugging purpose. -- 500, text/plain, a showed exception. @@ -174,6 +410,48 @@ -- Since: 2.0.3.2 exceptionResponseForDebug :: SomeException -> Response exceptionResponseForDebug e = - responseBuilder H.internalServerError500 - [(H.hContentType, "text/plain; charset=utf-8")] - $ byteString . S8.pack $ "Exception: " ++ show e + responseBuilder + H.internalServerError500 + [(H.hContentType, "text/plain; charset=utf-8")] + $ "Exception: " <> Builder.stringUtf8 (show e) + +-- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler. +-- +-- Since Warp will always install its own exception handler in forked threads, this provides +-- a minor optimization. +-- +-- For inspiration of this function, see @rawForkIO@ in the @async@ package. +-- +-- @since 3.3.17 +defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO () +defaultFork io = + IO $ \s0 -> +#if __GLASGOW_HASKELL__ >= 904 + case io unsafeUnmask of + IO io' -> + case fork# io' s0 of + (# s1, _tid #) -> (# s1, () #) +#else + case fork# (io unsafeUnmask) s0 of + (# s1, _tid #) -> (# s1, () #) +#endif + +-- | Standard "accept" call for a listening socket. +-- +-- @since 3.3.24 +defaultAccept :: Socket -> IO (Socket, SockAddr) +defaultAccept = +#if WINDOWS + windowsThreadBlockHack . accept +#else + accept +#endif + +-- | The version of Warp. +warpVersion :: String +warpVersion = +#ifdef INCLUDE_WARP_VERSION + showVersion Paths_warp.version +#else + "unknown" +#endif diff --git a/Network/Wai/Handler/Warp/ShuttingDown.hs b/Network/Wai/Handler/Warp/ShuttingDown.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/ShuttingDown.hs @@ -0,0 +1,34 @@ +-- Most important is to not export the data constructor from this module +-- and to not expose 'writeShuttingDown' to the end user. +module Network.Wai.Handler.Warp.ShuttingDown ( + ShuttingDown, + newShuttingDown, + readShuttingDown, + readShuttingDownSTM, + writeShuttingDown, +) where + +import Control.Concurrent.STM ( + STM, + TVar, + atomically, + newTVarIO, + readTVar, + readTVarIO, + writeTVar, + ) + +newtype ShuttingDown = ShuttingDown (TVar Bool) + +newShuttingDown :: IO ShuttingDown +newShuttingDown = ShuttingDown <$> newTVarIO False + +readShuttingDown :: ShuttingDown -> IO Bool +readShuttingDown (ShuttingDown var) = readTVarIO var + +readShuttingDownSTM :: ShuttingDown -> STM Bool +readShuttingDownSTM (ShuttingDown var) = readTVar var + +writeShuttingDown :: ShuttingDown -> Bool -> IO () +writeShuttingDown (ShuttingDown var) b = + atomically $ writeTVar var b diff --git a/Network/Wai/Handler/Warp/Timeout.hs b/Network/Wai/Handler/Warp/Timeout.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/Timeout.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Network.Wai.Handler.Warp.Timeout ( - -- ** Types - Manager - , TimeoutAction - , Handle - -- ** Manager - , initialize - , stopManager - , killManager - , withManager - -- ** Registration - , register - , registerKillThread - -- ** Control - , tickle - , cancel - , pause - , resume - -- ** Exceptions - , TimeoutThread (..) - ) where - -import Control.Concurrent (myThreadId) -import qualified Control.Exception as E -import Control.Reaper -import Data.Typeable (Typeable) -import Network.Wai.Handler.Warp.IORef (IORef) -import qualified Network.Wai.Handler.Warp.IORef as I - ----------------------------------------------------------------- - --- | A timeout manager -type Manager = Reaper [Handle] Handle - --- | An action to be performed on timeout. -type TimeoutAction = IO () - --- | A handle used by 'Manager' -data Handle = Handle !(IORef TimeoutAction) !(IORef State) - -data State = Active -- Manager turns it to Inactive. - | Inactive -- Manager removes it with timeout action. - | Paused -- Manager does not change it. - | Canceled -- Manager removes it without timeout action. - ----------------------------------------------------------------- - --- | Creating timeout manager which works every N micro seconds --- where N is the first argument. -initialize :: Int -> IO Manager -initialize timeout = mkReaper defaultReaperSettings - { reaperAction = mkListAction prune - , reaperDelay = timeout - } - where - prune m@(Handle actionRef stateRef) = do - state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x)) - case state of - Inactive -> do - onTimeout <- I.readIORef actionRef - onTimeout `E.catch` ignoreAll - return Nothing - Canceled -> return Nothing - _ -> return $ Just m - - inactivate Active = Inactive - inactivate x = x - ----------------------------------------------------------------- - --- | Stopping timeout manager with onTimeout fired. -stopManager :: Manager -> IO () -stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire) - where - fire (Handle actionRef _) = do - onTimeout <- I.readIORef actionRef - onTimeout `E.catch` ignoreAll - -ignoreAll :: E.SomeException -> IO () -ignoreAll _ = return () - --- | Killing timeout manager immediately without firing onTimeout. -killManager :: Manager -> IO () -killManager = reaperKill - ----------------------------------------------------------------- - --- | Registering a timeout action. -register :: Manager -> TimeoutAction -> IO Handle -register mgr onTimeout = do - actionRef <- I.newIORef onTimeout - stateRef <- I.newIORef Active - let h = Handle actionRef stateRef - reaperAdd mgr h - return h - --- | Registering a timeout action of killing this thread. -registerKillThread :: Manager -> IO Handle -registerKillThread m = do - -- If we hold ThreadId, the stack and data of the thread is leaked. - -- If we hold Weak ThreadId, the stack is released. However, its - -- data is still leaked probably because of a bug of GHC. - -- So, let's just use ThreadId and release ThreadId by - -- overriding the timeout action by "cancel". - tid <- myThreadId - register m $ E.throwTo tid TimeoutThread - -data TimeoutThread = TimeoutThread - deriving Typeable -instance E.Exception TimeoutThread -instance Show TimeoutThread where - show TimeoutThread = "Thread killed by Warp's timeout reaper" - ----------------------------------------------------------------- - --- | Setting the state to active. --- 'Manager' turns active to inactive repeatedly. -tickle :: Handle -> IO () -tickle (Handle _ stateRef) = I.writeIORef stateRef Active - --- | Setting the state to canceled. --- 'Manager' eventually removes this without timeout action. -cancel :: Handle -> IO () -cancel (Handle actionRef stateRef) = do - I.writeIORef actionRef (return ()) -- ensuring to release ThreadId - I.writeIORef stateRef Canceled - --- | Setting the state to paused. --- 'Manager' does not change the value. -pause :: Handle -> IO () -pause (Handle _ stateRef) = I.writeIORef stateRef Paused - --- | Setting the paused state to active. --- This is an alias to 'tickle'. -resume :: Handle -> IO () -resume = tickle - ----------------------------------------------------------------- - --- | Call the inner function with a timeout manager. -withManager :: Int -- ^ timeout in microseconds - -> (Manager -> IO a) - -> IO a -withManager timeout f = do - -- FIXME when stopManager is available, use it - man <- initialize timeout - f man diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.Types where -import Control.Exception -import Data.ByteString (ByteString) +import Control.Concurrent.STM (TVar) +import qualified Control.Exception as E import qualified Data.ByteString as S -import Data.IORef (IORef, readIORef, writeIORef, newIORef) -import Data.Typeable (Typeable) -import Data.Word (Word16, Word8) -import Foreign.Ptr (Ptr) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +#ifdef MIN_VERSION_crypton_x509 +import Data.X509 +#endif +import Network.Socket (SockAddr) +import Network.Socket.BufferPool +import System.Posix.Types (Fd) +import qualified System.TimeManager as T + import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I -import qualified Network.Wai.Handler.Warp.Timeout as T - -#ifndef WINDOWS -import System.Posix.Types (Fd) -#endif +import Network.Wai.Handler.Warp.Imports ---------------------------------------------------------------- @@ -33,14 +33,19 @@ ---------------------------------------------------------------- -- | Error types for bad 'Request'. -data InvalidRequest = NotEnoughLines [String] - | BadFirstLine String - | NonHttp - | IncompleteHeaders - | ConnectionClosedByPeer - | OverLargeHeader - | BadProxyHeader String - deriving (Eq, Typeable) +data InvalidRequest + = NotEnoughLines [String] + | BadFirstLine String + | NonHttp + | IncompleteHeaders + | ConnectionClosedByPeer + | OverLargeHeader + | BadProxyHeader String + | -- | Since 3.3.22 + PayloadTooLarge + | -- | Since 3.3.22 + RequestHeaderFieldsTooLarge + deriving (Eq) instance Show InvalidRequest where show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs @@ -48,80 +53,104 @@ show NonHttp = "Warp: Request line specified a non-HTTP request" show IncompleteHeaders = "Warp: Request headers did not finish transmission" show ConnectionClosedByPeer = "Warp: Client closed connection prematurely" - show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection." + show OverLargeHeader = + "Warp: Request headers too large, possible memory attack detected. Closing connection." show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s + show RequestHeaderFieldsTooLarge = "Request header fields too large" + show PayloadTooLarge = "Payload too large" -instance Exception InvalidRequest +instance E.Exception InvalidRequest ---------------------------------------------------------------- -#ifdef WINDOWS -type Fd = () -#endif +-- | Exception thrown if something goes wrong while in the midst of +-- sending a response, since the status code can't be altered at that +-- point. +-- +-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe +-- or irrecoverable. +newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody E.SomeException + deriving (Show) +instance E.Exception ExceptionInsideResponseBody + +---------------------------------------------------------------- + -- | Data type to abstract file identifiers. -- On Unix, a file descriptor would be specified to make use of -- the file descriptor cache. -- -- Since: 3.1.0 -data FileId = FileId { - fileIdPath :: FilePath - , fileIdFd :: Maybe Fd - } +data FileId = FileId + { fileIdPath :: FilePath + , fileIdFd :: Maybe Fd + } -- | fileid, offset, length, hook action, HTTP headers -- -- Since: 3.1.0 type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO () --- | Type for read buffer pool -type BufferPool = IORef ByteString - --- | Type for buffer -type Buffer = Ptr Word8 - --- | Type for buffer size -type BufSize = Int - --- | Type for the action to receive input data -type Recv = IO ByteString +-- | A write buffer of a specified size +-- containing bytes and a way to free the buffer. +data WriteBuffer = WriteBuffer + { bufBuffer :: Buffer + , bufSize :: !BufSize + -- ^ The size of the write buffer. + , bufFree :: IO () + -- ^ Free the allocated buffer. Warp guarantees it will only be + -- called once, and no other functions will be called after it. + } --- | Type for the action to receive input data with a buffer. --- The result boolean indicates whether or not the buffer is fully filled. type RecvBuf = Buffer -> BufSize -> IO Bool -- | Data type to manipulate IO actions for connections. -- This is used to abstract IO actions for plain HTTP and HTTP over TLS. -data Connection = Connection { - -- | This is not used at this moment. - connSendMany :: [ByteString] -> IO () - -- | The sending function. - , connSendAll :: ByteString -> IO () - -- | The sending function for files in HTTP/1.1. - , connSendFile :: SendFile - -- | The connection closing function. - , connClose :: IO () - -- | The connection receiving function. This returns "" for EOF. - , connRecv :: Recv - -- | The connection receiving function. This tries to fill the buffer. - -- This returns when the buffer is filled or reaches EOF. - , connRecvBuf :: RecvBuf - -- | The write buffer. - , connWriteBuffer :: Buffer - -- | The size of the write buffer. - , connBufferSize :: BufSize +data Connection = Connection + { connSendMany :: [ByteString] -> IO () + -- ^ This is not used at this moment. + , connSendAll :: ByteString -> IO () + -- ^ The sending function. + , connSendFile :: SendFile + -- ^ The sending function for files in HTTP/1.1. + , connClose :: IO () + -- ^ The connection closing function. Warp guarantees it will only be + -- called once. Other functions (like 'connRecv') may be called after + -- 'connClose' is called. + , connRecv :: Recv + -- ^ The connection receiving function. This returns "" for EOF or exceptions. + , connRecvBuf :: RecvBuf + -- ^ Obsoleted. + , connWriteBuffer :: IORef WriteBuffer + -- ^ Reference to a write buffer. When during sending of a 'Builder' + -- response it's detected the current 'WriteBuffer' is too small it will be + -- freed and a new bigger buffer will be created and written to this + -- reference. + , connHTTP2 :: IORef Bool + -- ^ Is this connection HTTP/2? + , connMySockAddr :: SockAddr + , connAppsInProgress :: TVar Int + -- ^ Amount of apps currently in progress on this connection. + -- + -- /HTTP2 can handle more than one request concurrently/ + -- + -- @since 3.4.13 } +getConnHTTP2 :: Connection -> IO Bool +getConnHTTP2 = readIORef . connHTTP2 + +setConnHTTP2 :: Connection -> Bool -> IO () +setConnHTTP2 = writeIORef . connHTTP2 + ---------------------------------------------------------------- --- | Internal information. -data InternalInfo = InternalInfo { - threadHandle :: T.Handle - , timeoutManager :: T.Manager - , fdCacher :: Maybe F.MutableFdCache - , fileInfo :: FilePath -> IO I.FileInfo - , dateCacher :: D.DateCache - } +data InternalInfo = InternalInfo + { timeoutManager :: T.Manager + , getDate :: IO D.GMTDate + , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh) + , getFileInfo :: FilePath -> IO I.FileInfo + } ---------------------------------------------------------------- @@ -147,7 +176,7 @@ readSource' (Source _ func) = func leftoverSource :: Source -> ByteString -> IO () -leftoverSource (Source ref _) bs = writeIORef ref bs +leftoverSource (Source ref _) = writeIORef ref readLeftoverSource :: Source -> IO ByteString readLeftoverSource (Source ref _) = readIORef ref @@ -155,14 +184,39 @@ ---------------------------------------------------------------- -- | What kind of transport is used for this connection? -data Transport = TCP -- ^ Plain channel: TCP - | TLS { - tlsMajorVersion :: Int - , tlsMinorVersion :: Int - , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301 - , tlsChiperID :: Word16 - } -- ^ Encrypted channel: TLS or SSL +data Transport + = -- | Plain channel: TCP + TCP + | TLS + { tlsMajorVersion :: Int + , tlsMinorVersion :: Int + , tlsNegotiatedProtocol :: Maybe ByteString + -- ^ The result of Application Layer Protocol Negociation in RFC 7301 + , tlsChiperID :: Word16 + -- ^ Encrypted channel: TLS or SSL +#ifdef MIN_VERSION_crypton_x509 + , tlsClientCertificate :: Maybe CertificateChain +#endif + } + | QUIC + { quicNegotiatedProtocol :: Maybe ByteString + , quicChiperID :: Word16 +#ifdef MIN_VERSION_crypton_x509 + , quicClientCertificate :: Maybe CertificateChain +#endif + } isTransportSecure :: Transport -> Bool isTransportSecure TCP = False -isTransportSecure _ = True +isTransportSecure _ = True + +isTransportQUIC :: Transport -> Bool +isTransportQUIC QUIC{} = True +isTransportQUIC _ = False + +#ifdef MIN_VERSION_crypton_x509 +getTransportClientCertificate :: Transport -> Maybe CertificateChain +getTransportClientCertificate TCP = Nothing +getTransportClientCertificate (TLS _ _ _ _ cc) = cc +getTransportClientCertificate (QUIC _ _ cc) = cc +#endif diff --git a/Network/Wai/Handler/Warp/Windows.hs b/Network/Wai/Handler/Warp/Windows.hs --- a/Network/Wai/Handler/Warp/Windows.hs +++ b/Network/Wai/Handler/Warp/Windows.hs @@ -1,21 +1,28 @@ {-# LANGUAGE CPP #-} -module Network.Wai.Handler.Warp.Windows - ( windowsThreadBlockHack - ) where +module Network.Wai.Handler.Warp.Windows ( + windowsThreadBlockHack, +) where + #if WINDOWS -import Control.Exception import Control.Concurrent.MVar import Control.Concurrent -import Control.Monad +import qualified Control.Exception +import GHC.Conc (labelThread) + +-- | Allow main socket listening thread to be interrupted on Windows platform +-- +-- @since 3.2.17 windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack act = do - var <- newEmptyMVar :: IO (MVar (Either SomeException a)) - void . forkIO $ try act >>= putMVar var + var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a)) + -- Catch and rethrow even async exceptions, so don't bother with UnliftIO + threadId <- forkIO $ Control.Exception.try act >>= putMVar var + labelThread threadId "Windows Thread Block Hack (warp)" res <- takeMVar var case res of - Left e -> throwIO e + Left e -> Control.Exception.throwIO e Right r -> return r #else windowsThreadBlockHack :: IO a -> IO a diff --git a/Network/Wai/Handler/Warp/WithApplication.hs b/Network/Wai/Handler/Warp/WithApplication.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/WithApplication.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Handler.Warp.WithApplication ( + withApplication, + withApplicationSettings, + testWithApplication, + testWithApplicationSettings, + openFreePort, + withFreePort, +) where + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Exception as E +import Control.Monad (when) +import Data.Streaming.Network (bindRandomPortTCP) +import Network.Socket +import Network.Wai +import Network.Wai.Handler.Warp.Run +import Network.Wai.Handler.Warp.Settings +import Network.Wai.Handler.Warp.Types + +-- | Runs the given 'Application' on a free port. Passes the port to the given +-- operation and executes it, while the 'Application' is running. Shuts down the +-- server before returning. +-- +-- @since 3.2.4 +withApplication :: IO Application -> (Port -> IO a) -> IO a +withApplication = withApplicationSettings defaultSettings + +-- | 'withApplication' with given 'Settings'. This will ignore the port value +-- set by 'setPort' in 'Settings'. +-- +-- @since 3.2.7 +withApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a +withApplicationSettings settings' mkApp action = do + app <- mkApp + withFreePort $ \(port, sock) -> do + started <- mkWaiter + let settings = + settings' + { settingsBeforeMainLoop = + notify started () >> settingsBeforeMainLoop settings' + } + result <- + race + (runSettingsSocket settings sock app) + (waitFor started >> action port) + case result of + Left () -> E.throwIO $ E.ErrorCall "Unexpected: runSettingsSocket exited" + Right x -> return x + +-- | Same as 'withApplication' but with different exception handling: If the +-- given 'Application' throws an exception, 'testWithApplication' will re-throw +-- the exception to the calling thread, possibly interrupting the execution of +-- the given operation. +-- +-- This is handy for running tests against an 'Application' over a real network +-- port. When running tests, it's useful to let exceptions thrown by your +-- 'Application' propagate to the main thread of the test-suite. +-- +-- __The exception handling makes this function unsuitable for use in production.__ +-- Use 'withApplication' instead. +-- +-- @since 3.2.4 +testWithApplication :: IO Application -> (Port -> IO a) -> IO a +testWithApplication = testWithApplicationSettings defaultSettings + +-- | 'testWithApplication' with given 'Settings'. +-- +-- @since 3.2.7 +testWithApplicationSettings + :: Settings -> IO Application -> (Port -> IO a) -> IO a +testWithApplicationSettings settings mkApp action = do + callingThread <- myThreadId + app <- mkApp + let wrappedApp request respond = + app request respond `E.catch` \e -> do + when + (defaultShouldDisplayException e) + (throwTo callingThread e) + E.throwIO e + withApplicationSettings settings (return wrappedApp) action + +data Waiter a = Waiter + { notify :: a -> IO () + , waitFor :: IO a + } + +mkWaiter :: IO (Waiter a) +mkWaiter = do + mvar <- newEmptyMVar + return + Waiter + { notify = putMVar mvar + , waitFor = readMVar mvar + } + +-- | Opens a socket on a free port and returns both port and socket. +-- +-- @since 3.2.4 +openFreePort :: IO (Port, Socket) +openFreePort = bindRandomPortTCP "127.0.0.1" + +-- | Like 'openFreePort' but closes the socket before exiting. +withFreePort :: ((Port, Socket) -> IO a) -> IO a +withFreePort = E.bracket openFreePort (close . snd) diff --git a/bench/Parser.hs b/bench/Parser.hs --- a/bench/Parser.hs +++ b/bench/Parser.hs @@ -1,23 +1,26 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Exception (throwIO, throw) +import Control.Exception (throw, throwIO) import Control.Monad import qualified Data.ByteString as S ---import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B (unpack) -import qualified Network.HTTP.Types as H -import Network.Wai.Handler.Warp.Types -import Prelude hiding (lines) - +import qualified Data.ByteString.Char8 as B (pack, unpack) import Data.ByteString.Internal -import Data.Word +import Data.IORef (atomicModifyIORef', newIORef) +import qualified Data.List as L +import Data.Word8 import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable +import qualified Network.HTTP.Types as H +import Prelude hiding (lines) +import Network.Wai.Handler.Warp.Request (FirstRequest (..), headerLines) +import Network.Wai.Handler.Warp.Types + import Criterion.Main -- $setup @@ -29,20 +32,31 @@ main = do let requestLine1 = "GET http://www.example.com HTTP/1.1" let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0" - defaultMain [ - bgroup "requestLine1" [ - bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1 - , bench "parseRequestLine2" $ parseRequestLine2 requestLine1 - , bench "parseRequestLine1" $ parseRequestLine1 requestLine1 - , bench "parseRequestLine0" $ parseRequestLine0 requestLine1 - ] - , bgroup "requestLine2" [ - bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2 - , bench "parseRequestLine2" $ parseRequestLine2 requestLine2 - , bench "parseRequestLine1" $ parseRequestLine1 requestLine2 - , bench "parseRequestLine0" $ parseRequestLine0 requestLine2 - ] - ] + defaultMain + [ bgroup + "requestLine1" + [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1 + , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1 + , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1 + , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1 + ] + , bgroup + "requestLine2" + [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2 + , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2 + , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2 + , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2 + ] + , bgroup + "parsing request" + [ bench "new parsing 4" $ whnfAppIO testIt (chunkRequest 4) + , bench "new parsing 10" $ whnfAppIO testIt (chunkRequest 10) + , bench "new parsing 25" $ whnfAppIO testIt (chunkRequest 25) + , bench "new parsing 100" $ whnfAppIO testIt (chunkRequest 100) + ] + ] + where + testIt req = producer req >>= headerLines 800 FirstRequest ---------------------------------------------------------------- @@ -56,26 +70,29 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp -parseRequestLine3 :: ByteString - -> (H.Method - ,ByteString -- Path - ,ByteString -- Query - ,H.HttpVersion) +parseRequestLine3 + :: ByteString + -> ( H.Method + , ByteString -- Path + , ByteString -- Query + , H.HttpVersion + ) parseRequestLine3 requestLine = ret where - (!method,!rest) = S.breakByte 32 requestLine -- ' ' - (!pathQuery,!httpVer') - | rest == "" = throw badmsg - | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' ' - (!path,!query) = S.breakByte 63 pathQuery -- '?' + (!method, !rest) = S.break (== _space) requestLine + (!pathQuery, !httpVer') + | rest == "" = throw badmsg + | otherwise = S.break (== _space) (S.drop 1 rest) + (!path, !query) = S.break (== _question) pathQuery !httpVer = S.drop 1 httpVer' - (!http,!ver) - | httpVer == "" = throw badmsg - | otherwise = S.breakByte 47 httpVer -- '/' - !hv | http /= "HTTP" = throw NonHttp - | ver == "/1.1" = H.http11 - | otherwise = H.http10 - !ret = (method,path,query,hv) + (!http, !ver) + | httpVer == "" = throw badmsg + | otherwise = S.break (== _slash) httpVer + !hv + | http /= "HTTP" = throw NonHttp + | ver == "/1.1" = H.http11 + | otherwise = H.http10 + !ret = (method, path, query, hv) badmsg = BadFirstLine $ B.unpack requestLine ---------------------------------------------------------------- @@ -90,24 +107,27 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp -parseRequestLine2 :: ByteString - -> IO (H.Method - ,ByteString -- Path - ,ByteString -- Query - ,H.HttpVersion) +parseRequestLine2 + :: ByteString + -> IO + ( H.Method + , ByteString -- Path + , ByteString -- Query + , H.HttpVersion + ) parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len - pathptr0 <- memchr methodptr 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 @@ -115,17 +135,16 @@ 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 check :: Ptr Word8 -> Int -> Word8 -> IO () @@ -133,19 +152,18 @@ 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 minor <- peek $ httpptr `plusPtr` 7 - if major == (49 :: Word8) && minor == (49 :: Word8) then - return H.http11 - else - return H.http10 + if major == _1 && minor == _1 + then return H.http11 + else return H.http10 bs ptr p0 p1 = PS fptr o l where o = p0 `minusPtr` ptr @@ -163,23 +181,29 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp -parseRequestLine1 :: ByteString - -> IO (H.Method - ,ByteString -- Path - ,ByteString -- Query - ,H.HttpVersion) +parseRequestLine1 + :: ByteString + -> IO + ( H.Method + , ByteString -- Path + , ByteString -- Query + , H.HttpVersion + ) parseRequestLine1 requestLine = do - let (!method,!rest) = S.breakByte 32 requestLine -- ' ' - (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' ' + let (!method, !rest) = S.break (== _space) requestLine + (!pathQuery, !httpVer') = S.break (== _space) (S.drop 1 rest) !httpVer = S.drop 1 httpVer' when (rest == "" || httpVer == "") $ - throwIO $ BadFirstLine $ B.unpack requestLine - let (!path,!query) = S.breakByte 63 pathQuery -- '?' - (!http,!ver) = S.breakByte 47 httpVer -- '/' + throwIO $ + BadFirstLine $ + B.unpack requestLine + let (!path, !query) = S.break (== _question) pathQuery + (!http, !ver) = S.break (== _slash) httpVer when (http /= "HTTP") $ throwIO NonHttp - let !hv | ver == "/1.1" = H.http11 - | otherwise = H.http10 - return $! (method,path,query,hv) + let !hv + | ver == "/1.1" = H.http11 + | otherwise = H.http10 + return $! (method, path, query, hv) ---------------------------------------------------------------- @@ -193,23 +217,68 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp -parseRequestLine0 :: ByteString - -> IO (H.Method - ,ByteString -- Path - ,ByteString -- Query - ,H.HttpVersion) +parseRequestLine0 + :: ByteString + -> IO + ( H.Method + , ByteString -- Path + , ByteString -- Query + , H.HttpVersion + ) parseRequestLine0 s = - case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- ' - (method':query:http'') -> do + case filter (not . S.null) $ S.splitWith (\c -> c == _space || c == _tab) s of + (method' : query : http'') -> do let !method = method' !http' = S.concat http'' (!hfirst, !hsecond) = S.splitAt 5 http' if hfirst == "HTTP/" - then let (!rpath, !qstring) = S.breakByte 63 query -- '?' + then + let (!rpath, !qstring) = S.break (== _question) query !hv = case hsecond of "1.1" -> H.http11 _ -> H.http10 - in return $! (method, rpath, qstring, hv) - else throwIO NonHttp + in return $! (method, rpath, qstring, hv) + else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s + +producer :: [ByteString] -> IO Source +producer a = do + ref <- newIORef a + mkSource $ + atomicModifyIORef' ref $ \case + [] -> ([], S.empty) + b : bs -> (bs, b) + +chunkRequest :: Int -> [ByteString] +chunkRequest chunkAmount = + go basicRequest + where + len = L.length basicRequest + chunkSize = (len `div` chunkAmount) + 1 + go [] = [] + go xs = + let (a, b) = L.splitAt chunkSize xs + in B.pack a : go b + +-- Random google search request +basicRequest :: String +basicRequest = + mconcat + [ "GET /search?q=test&sca_esv=600090652&source=hp&uact=5&oq=test&sclient=gws-wiz HTTP/3\r\n" + , "Host: www.google.com\r\n" + , "User-Agent: Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:121.0) Gecko/20100101 Firefox/121.0\r\n" + , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8\r\n" + , "Accept-Language: en-US,en;q=0.5\r\n" + , "Accept-Encoding: gzip, deflate, br\r\n" + , "Referer: https://www.google.com/\r\n" + , "Alt-Used: www.google.com\r\n" + , "Connection: keep-alive\r\n" + , "Cookie: CONSENT=PENDING+252\r\n" + , "Upgrade-Insecure-Requests: 1\r\n" + , "Sec-Fetch-Dest: document\r\n" + , "Sec-Fetch-Mode: navigate\r\n" + , "Sec-Fetch-Site: same-origin\r\n" + , "Sec-Fetch-User: ?1\r\n" + , "TE: trailers\r\n\r\n" + ] diff --git a/test/BufferPoolSpec.hs b/test/BufferPoolSpec.hs deleted file mode 100644 --- a/test/BufferPoolSpec.hs +++ /dev/null @@ -1,47 +0,0 @@ -module BufferPoolSpec where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B (ByteString(PS)) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Marshal.Utils (copyBytes) -import Foreign.Ptr (plusPtr) - -import Test.Hspec (Spec, hspec, shouldBe, describe, it) - -import Network.Wai.Handler.Warp.Buffer - ( bufferSize - , newBufferPool - , withBufferPool - ) -import Network.Wai.Handler.Warp.Types (Buffer, BufSize) - -main :: IO () -main = hspec spec - --- Two ByteStrings each big enough to fill a 'bufferSize' buffer (16K). -wantData, otherData :: B.ByteString -wantData = B.replicate bufferSize 0xac -otherData = B.replicate bufferSize 0x77 - -spec :: Spec -spec = describe "withBufferPool" $ do - it "does not clobber buffers" $ do - pool <- newBufferPool - -- 'pool' contains B.empty; prime it to contain a real buffer. - _ <- withBufferPool pool $ const $ return 0 - -- 'pool' contains a 16K buffer; fill it with \xac and keep the result. - got <- withBufferPool pool $ blitBuffer wantData - got `shouldBe` wantData - -- 'pool' should now be empty and reallocate, rather than clobber the - -- previous buffer. - _ <- withBufferPool pool $ blitBuffer otherData - got `shouldBe` wantData - --- Fill the Buffer with the contents of the ByteString and return the number of --- bytes written. To be used with 'withBufferPool'. -blitBuffer :: B.ByteString -> (Buffer, BufSize) -> IO Int -blitBuffer (B.PS fp off len) (dst, len') = withForeignPtr fp $ \ptr -> do - let src = ptr `plusPtr` off - n = min len len' - copyBytes dst src n - return n diff --git a/test/ConduitSpec.hs b/test/ConduitSpec.hs --- a/test/ConduitSpec.hs +++ b/test/ConduitSpec.hs @@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} + module ConduitSpec (main, spec) where +import Control.Monad (replicateM) +import qualified Data.ByteString as S +import Data.IORef as I import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.Types -import Control.Monad (replicateM) import Test.Hspec -import Data.IORef as I -import qualified Data.ByteString as S main :: IO () main = hspec spec @@ -14,25 +15,25 @@ spec :: Spec spec = describe "conduit" $ do it "IsolatedBSSource" $ do - ref <- newIORef $ map S.singleton [1..50] + ref <- newIORef $ map S.singleton [1 .. 50] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty - y:z -> do + y : z -> do writeIORef ref z return y isrc <- mkISource src 40 x <- replicateM 20 $ readISource isrc - S.concat x `shouldBe` S.pack [1..20] + S.concat x `shouldBe` S.pack [1 .. 20] y <- replicateM 40 $ readISource isrc - S.concat y `shouldBe` S.pack [21..40] + S.concat y `shouldBe` S.pack [21 .. 40] z <- replicateM 40 $ readSource src - S.concat z `shouldBe` S.pack [41..50] + S.concat z `shouldBe` S.pack [41 .. 50] it "chunkedSource" $ do - ref <- newIORef $ "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH" + ref <- newIORef "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH" src <- mkSource $ do x <- readIORef ref writeIORef ref S.empty @@ -45,17 +46,18 @@ y <- replicateM 15 $ readSource src S.concat y `shouldBe` "BLAH" it "chunk boundaries" $ do - ref <- newIORef - [ "5\r\n" - , "12345\r\n3\r" - , "\n678\r\n0\r\n" - , "\r\nBLAH" - ] + ref <- + newIORef + [ "5\r\n" + , "12345\r\n3\r" + , "\n678\r\n0\r\n" + , "\r\nBLAH" + ] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty - y:z -> do + y : z -> do writeIORef ref z return y csrc <- mkCSource src diff --git a/test/ConnectionSpec.hs b/test/ConnectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/ConnectionSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ConnectionSpec (spec) where + +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import RunSpec (withApp, withMySocket, msWrite, msRead) +import Test.Hspec +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 + +spec :: Spec +spec = describe "Connection header" $ do + it "sends Connection: close when response implies close (HTTP/1.0 Keep-Alive, no Content-Length)" $ do + let app _ f = f $ responseLBS status200 [] "foo" + withApp defaultSettings app $ withMySocket $ \ms -> do + -- HTTP/1.0 defaults to close. We ask for Keep-Alive. + -- But we provide no Content-Length in response. + -- So Warp should decide to close (because it can't keep alive without length or chunking), + -- and MUST send "Connection: close" to inform the client. + msWrite ms "GET / HTTP/1.0\r\nConnection: Keep-Alive\r\n\r\n" + + -- We expect the connection to be closed by the server, so reading a large amount + -- should return whatever was sent and then finish. + response <- msRead ms 4096 + + let headers = parseHeaders response + lookup "Connection" headers `shouldBe` Just "close" + + describe "HTTP/1.1 Connection: close behavior" $ do + it "sends Connection: close for HEAD request without Content-Length" $ do + -- Response has no Content-Length and is not chunked (HEAD implies no body). + -- In HTTP/1.1 this requires closing the connection to delimit the response (or rather, lack of persistence info). + let app _ f = f $ responseBuilder status200 [] "foo" + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "HEAD / HTTP/1.1\r\nHost: localhost\r\n\r\n" + response <- msRead ms 4096 + let headers = parseHeaders response + lookup "Connection" headers `shouldBe` Just "close" + + it "sends Connection: close when request has Connection: close (200 OK)" $ do + let app _ f = f $ responseLBS status200 [] "foo" + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n" + response <- msRead ms 4096 + let headers = parseHeaders response + lookup "Connection" headers `shouldBe` Just "close" + + it "sends Connection: close when request has Connection: close (204 No Content)" $ do + let app _ f = f $ responseLBS status204 [] "" + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n" + response <- msRead ms 4096 + let headers = parseHeaders response + lookup "Connection" headers `shouldBe` Just "close" + + it "sends Connection: close when request has Connection: close (500 Internal Server Error)" $ do + let app _ f = f $ responseLBS status500 [] "error" + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n" + response <- msRead ms 4096 + let headers = parseHeaders response + lookup "Connection" headers `shouldBe` Just "close" +parseHeaders :: ByteString -> [(ByteString, ByteString)] +parseHeaders bs = + let lines = S8.lines bs + -- Drop status line + headerLines = takeWhile (not . S8.null . S8.filter (/= '\r')) $ drop 1 lines + parseLine line = + let (k, v) = S8.break (== ':') line + v' = S8.takeWhile (/= '\r') v + in (k, S8.dropWhile (== ' ') $ S8.drop 1 v') + in map parseLine headerLines diff --git a/test/ExceptionSpec.hs b/test/ExceptionSpec.hs --- a/test/ExceptionSpec.hs +++ b/test/ExceptionSpec.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module ExceptionSpec (main, spec) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif +import Control.Concurrent.Async (withAsync) +import Control.Exception import Control.Monad +import qualified Data.Streaming.Network as N import Network.HTTP.Types hiding (Header) -import Network.Wai hiding (Response) -import Network.Wai.Internal (Request(..)) +import Network.Socket (close) +import Network.Wai hiding (Response, responseStatus) import Network.Wai.Handler.Warp +import Network.Wai.Internal (Request (..)) import Test.Hspec -import Control.Exception -import qualified Data.Streaming.Network as N -import Control.Concurrent.Async (withAsync) -import Network.Socket (sClose) import HTTP @@ -24,13 +25,13 @@ withTestServer :: (Int -> IO a) -> IO a withTestServer inner = bracket (N.bindRandomPortTCP "127.0.0.1") - (sClose . snd) + (close . snd) $ \(prt, lsocket) -> do - withAsync (runSettingsSocket defaultSettings lsocket testApp) - $ \_ -> inner prt + withAsync (runSettingsSocket defaultSettings lsocket testApp) $ + \_ -> inner prt testApp :: Application -testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f +testApp (Network.Wai.Internal.Request{pathInfo = [x]}) f | x == "statusError" = f $ responseLBS undefined [] "foo" | x == "headersError" = @@ -43,24 +44,25 @@ void $ fail "ioException" f $ responseLBS ok200 [] "foo" testApp _ f = - f $ responseLBS ok200 [] "foo" + f $ responseLBS ok200 [] "foo" spec :: Spec spec = describe "responds even if there is an exception" $ do - {- Disabling these tests. We can consider forcing evaluation in Warp. - it "statusError" $ do - sc <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError" - sc `shouldBe` (5,0,0) - it "headersError" $ do - sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError" - sc `shouldBe` (5,0,0) - it "headerError" $ do - sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError" - sc `shouldBe` (5,0,0) - it "bodyError" $ do - sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError" - sc `shouldBe` (5,0,0) - -} - it "ioException" $ withTestServer $ \prt -> do - sc <- rspCode <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException") - sc `shouldBe` (5,0,0) + {- Disabling these tests. We can consider forcing evaluation in Warp. + it "statusError" $ do + sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError" + sc `shouldBe` internalServerError500 + it "headersError" $ do + sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError" + sc `shouldBe` internalServerError500 + it "headerError" $ do + sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError" + sc `shouldBe` internalServerError500 + it "bodyError" $ do + sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError" + sc `shouldBe` internalServerError500 + -} + it "ioException" $ withTestServer $ \prt -> do + sc <- + responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException") + sc `shouldBe` internalServerError500 diff --git a/test/FdCacheSpec.hs b/test/FdCacheSpec.hs --- a/test/FdCacheSpec.hs +++ b/test/FdCacheSpec.hs @@ -6,7 +6,7 @@ #ifndef WINDOWS import Data.IORef import Network.Wai.Handler.Warp.FdCache -import System.Posix.IO (fdRead) +import System.Posix.IO.ByteString (fdRead) import System.Posix.Types (Fd(..)) main :: IO () @@ -16,8 +16,8 @@ spec = describe "withFdCache" $ do it "clean up Fd" $ do ref <- newIORef (Fd (-1)) - withFdCache 30000000 $ \(Just mfc) -> do - (fd,_) <- getFd mfc "warp.cabal" + withFdCache 30000000 $ \getFd -> do + (Just fd,_) <- getFd "warp.cabal" writeIORef ref fd nfd <- readIORef ref fdRead nfd 1 `shouldThrow` anyIOException diff --git a/test/FileSpec.hs b/test/FileSpec.hs --- a/test/FileSpec.hs +++ b/test/FileSpec.hs @@ -2,44 +2,131 @@ module FileSpec (main, spec) where +import Data.ByteString +import Data.String (fromString) import Network.HTTP.Types import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec main :: IO () main = hspec spec -testFileRange :: String - -> RequestHeaders -> FilePath - -> RspFileInfo - -> Spec -testFileRange desc reqhs file ans = it desc $ do - finfo <- getInfo file - let WithBody s hs off len = ans - hs' = ("Last-Modified",fileInfoDate finfo) : hs - ans' = WithBody s hs' off len - conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans' +changeHeaders + :: (ResponseHeaders -> ResponseHeaders) -> RspFileInfo -> RspFileInfo +changeHeaders f rfi = + case rfi of + WithBody s hs off len -> WithBody s (f hs) off len + other -> other +getHeaders :: RspFileInfo -> ResponseHeaders +getHeaders rfi = + case rfi of + WithBody _ hs _ _ -> hs + _ -> [] + +testFileRange + :: String + -> RequestHeaders + -> RspFileInfo + -> Spec +testFileRange desc reqhs ans = it desc $ do + finfo <- getInfo "attic/hex" + let f = (:) ("Last-Modified", fileInfoDate finfo) + hs = getHeaders ans + ans' = changeHeaders f ans + conditionalRequest + finfo + [] + methodGet + (indexResponseHeader hs) + (indexRequestHeader reqhs) + `shouldBe` ans' + +farPast, farFuture :: ByteString +farPast = "Thu, 01 Jan 1970 00:00:00 GMT" +farFuture = "Sun, 05 Oct 3000 00:00:00 GMT" + +regularBody :: RspFileInfo +regularBody = WithBody ok200 [("Content-Length", "16"), ("Accept-Ranges", "bytes")] 0 16 + +make206Body :: Integer -> Integer -> RspFileInfo +make206Body start len = + WithBody status206 [crHeader, lenHeader, ("Accept-Ranges", "bytes")] start len + where + lenHeader = ("Content-Length", fromString $ show len) + crHeader = + ( "Content-Range" + , fromString $ "bytes " <> show start <> "-" <> show (start + len - 1) <> "/16" + ) + spec :: Spec spec = do describe "conditionalRequest" $ do testFileRange "gets a file size from file system" - [] "attic/hex" - $ WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16 + [] + regularBody testFileRange "gets a file size from file system and handles Range and returns Partical Content" - [("Range","bytes=2-14")] "attic/hex" - $ WithBody status206 [("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")] 2 13 + [("Range", "bytes=2-14")] + $ make206Body 2 13 testFileRange "truncates end point of range to file size" - [("Range","bytes=10-20")] "attic/hex" - $ WithBody status206 [("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")] 10 6 + [("Range", "bytes=10-20")] + $ make206Body 10 6 testFileRange "gets a file size from file system and handles Range and returns OK if Range means the entire" - [("Range:","bytes=0-15")] "attic/hex" - $ WithBody status200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16 - + [("Range:", "bytes=0-15")] + regularBody + testFileRange + "returns a 412 if the file has been changed in the meantime" + [("If-Unmodified-Since", farPast)] + $ WithoutBody status412 + testFileRange + "gets a file if the file has not been changed in the meantime" + [("If-Unmodified-Since", farFuture)] + regularBody + testFileRange + "ignores the If-Unmodified-Since header if an If-Match header is also present" + [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast)] + regularBody + testFileRange + "still gives only a range, even after conditionals" + [ ("If-Match", "SomeETag") + , ("If-Unmodified-Since", farPast) + , ("Range", "bytes=10-20") + ] + $ make206Body 10 6 + testFileRange + "gets a file if the file has been changed in the meantime" + [("If-Modified-Since", farPast)] + regularBody + testFileRange + "returns a 304 if the file has not been changed in the meantime" + [("If-Modified-Since", farFuture)] + $ WithoutBody status304 + testFileRange + "ignores the If-Modified-Since header if an If-None-Match header is also present" + [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture)] + regularBody + testFileRange + "still gives only a range, even after conditionals" + [ ("If-None-Match", "SomeETag") + , ("If-Modified-Since", farFuture) + , ("Range", "bytes=10-13") + ] + $ make206Body 10 4 + testFileRange + "gives the a range, if the condition is met" + [ ("If-Range", fileInfoDate (unsafePerformIO $ getInfo "attic/hex")) + , ("Range", "bytes=2-7") + ] + $ make206Body 2 6 + testFileRange + "gives the entire body and ignores the Range header if the condition isn't met" + [("If-Range", farPast), ("Range", "bytes=2-7")] + regularBody diff --git a/test/GracefulShutdownSpec.hs b/test/GracefulShutdownSpec.hs new file mode 100644 --- /dev/null +++ b/test/GracefulShutdownSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +module GracefulShutdownSpec (spec) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception (bracket) +import Control.Monad (void) +import Network.HTTP.Client +import Network.HTTP.Types (ok200, status200) +import Network.Socket (close) +import Network.Wai (responseLBS) +import Network.Wai.Handler.Warp +import System.Timeout (timeout) +import Test.Hspec + +spec :: Spec +spec = describe "graceful shutdown" $ + it "serves the request in flight, then closes keep-alive connections and exits" $ do + shutdownSignal <- newEmptyMVar + allowResponse <- newEmptyMVar + receivedRequests <- newQSemN 0 + allowSecondRequest <- newEmptyMVar + + let installShutdownHandler closeListenSocket = + void . forkIO $ do + readMVar shutdownSignal + closeListenSocket + + settings = + setInstallShutdownHandler installShutdownHandler defaultSettings + + app _ respond = do + -- signal 1 received request + signalQSemN receivedRequests 1 + -- block until signaled + readMVar allowResponse + respond $ responseLBS status200 [("Content-Length", "0")] "" + + client sendRequest = do + -- first request should return OK + response <- sendRequest + responseStatus response `shouldBe` ok200 + lookup "Connection" (responseHeaders response) `shouldBe` Just "close" + -- wait with the second request + void $ readMVar allowSecondRequest + -- second request should end with connection refused + sendRequest `shouldThrow` connectionRefused + + bracket openFreePort (close . snd) $ \(testPort, sock) -> + withAsync (runSettingsSocket settings sock app) $ \server -> do + manager <- newManager defaultManagerSettings + request <- parseRequest ("http://127.0.0.1:" ++ show testPort) + withAsync + -- start all clients + ( replicateConcurrently_ numClients $ + client (httpNoBody request manager) + ) + $ \clients -> do + -- wait for all clients to send requests + waitQSemN receivedRequests numClients + -- shutdown the server before serving requests + putMVar shutdownSignal () + -- wait a little - otherwise some requests might not get + -- Connection: close response header + threadDelay 100_000 + -- let requests be handled + putMVar allowResponse () + -- server should exit + timeout 5_000_000 (wait server) + >>= maybe (expectationFailure "Timeout waiting for server shutdown") pure + -- let clients proceed with the second request + putMVar allowSecondRequest () + -- wait for all clients and propagate any exceptions + wait clients + where + -- set number of clients to the number of keep-alive connections + numClients = managerConnCount defaultManagerSettings + connectionRefused = \case + (HttpExceptionRequest _ (ConnectionFailure _)) -> True + _ -> False diff --git a/test/HTTP.hs b/test/HTTP.hs --- a/test/HTTP.hs +++ b/test/HTTP.hs @@ -1,43 +1,41 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module HTTP ( - sendGET - , sendGETwH - , sendHEAD - , sendHEADwH - , rspBody - , rspCode - , rspHeaders - , getHeaderValue - , HeaderName(..) - , mkHeader - ) where + sendGET, + sendGETwH, + sendHEAD, + sendHEADwH, + responseBody, + responseStatus, + responseHeaders, + getHeaderValue, + HeaderName, +) where -import Network.HTTP -import Network.Stream +import Data.ByteString +import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Client +import Network.HTTP.Types -sendGET :: String -> IO (Response String) +sendGET :: String -> IO (Response BL.ByteString) sendGET url = sendGETwH url [] -sendGETwH :: String -> [Header] -> IO (Response String) -sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr } +sendGETwH :: String -> [Header] -> IO (Response BL.ByteString) +sendGETwH url hdr = do + manager <- newManager defaultManagerSettings + request <- parseRequest url + let request' = request{requestHeaders = hdr} + response <- httpLbs request' manager + return response -sendHEAD :: String -> IO (Response String) +sendHEAD :: String -> IO (Response BL.ByteString) sendHEAD url = sendHEADwH url [] -sendHEADwH :: String -> [Header] -> IO (Response String) -sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr } - -unResult :: IO (Result (Response String)) -> IO (Response String) -unResult action = do - res <- action - case res of - Right rsp -> return rsp - Left _ -> error "Connection error" - -getHeaderValue :: HasHeaders a => HeaderName -> a -> Maybe String -getHeaderValue key r = case retrieveHeaders key r of - [] -> Nothing - x:_ -> Just $ hdrValue x +sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString) +sendHEADwH url hdr = do + manager <- newManager defaultManagerSettings + request <- parseRequest url + let request' = request{requestHeaders = hdr, method = methodHead} + response <- httpLbs request' manager + return response -deriving instance Eq Header +getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString +getHeaderValue = lookup diff --git a/test/MultiMapSpec.hs b/test/MultiMapSpec.hs deleted file mode 100644 --- a/test/MultiMapSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -module MultiMapSpec where - -import Network.Wai.Handler.Warp.MultiMap -import Test.Hspec -import Test.QuickCheck (property) - -type Alist = [(Int,Char)] - -spec :: Spec -spec = do - describe "fromList" $ do - it "generates a valid tree" $ property $ \xs -> - valid $ fromList (xs :: Alist) - describe "toSortedList" $ do - it "generated a sorted list" $ property $ \xs -> - ordered $ toSortedList $ fromList (xs :: Alist) - describe "search" $ do - it "acts as the list model" $ property $ \x xs -> - search x (fromList xs) == lookup x (xs :: Alist) - describe "fromSortedList" $ do - it "generates a valid tree" $ property $ \xs -> - valid . fromSortedList . toSortedList . fromList $ (xs :: Alist) - it "maintains the tree with toSortedList" $ property $ \xs -> - let t1 = fromList (xs :: Alist) - t2 = fromSortedList $ toSortedList t1 - in t1 == t2 - -ordered :: Ord a => [(a, b)] -> Bool -ordered (x:y:xys) = fst x <= fst y && ordered (y:xys) -ordered _ = True diff --git a/test/PackIntSpec.hs b/test/PackIntSpec.hs new file mode 100644 --- /dev/null +++ b/test/PackIntSpec.hs @@ -0,0 +1,14 @@ +module PackIntSpec (spec) where + +import qualified Data.ByteString.Char8 as C8 +import Network.Wai.Handler.Warp.PackInt +import Test.Hspec +import Test.Hspec.QuickCheck +import qualified Test.QuickCheck as QC + +spec :: Spec +spec = describe "readInt64" $ do + prop "" $ \n -> packIntegral (abs n :: Int) == C8.pack (show (abs n)) + prop "" $ \(QC.Large n) -> + let n' = fromIntegral (abs n :: Int) + in packIntegral (n' :: Int) == C8.pack (show n') diff --git a/test/ReadIntSpec.hs b/test/ReadIntSpec.hs --- a/test/ReadIntSpec.hs +++ b/test/ReadIntSpec.hs @@ -1,9 +1,9 @@ module ReadIntSpec (main, spec) where import Data.ByteString (ByteString) -import Test.Hspec -import Network.Wai.Handler.Warp.ReadInt import qualified Data.ByteString.Char8 as B +import Network.Wai.Handler.Warp.ReadInt +import Test.Hspec import qualified Test.QuickCheck as QC main :: IO () @@ -11,7 +11,8 @@ spec :: Spec spec = describe "readInt64" $ do - it "converts ByteString to Int" $ QC.property (prop_read_show_idempotent readInt64) + it "converts ByteString to Int" $ + QC.property (prop_read_show_idempotent readInt64) -- A QuickCheck property. Test that for a number >= 0, converting it to -- a string using show and then reading the value back with the function @@ -19,7 +20,8 @@ -- The functions under test only work on Natural numbers (the Conent-Length -- field in a HTTP header is always >= 0) so we check the absolute value of -- the value that QuickCheck generates for us. -prop_read_show_idempotent :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool +prop_read_show_idempotent + :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool prop_read_show_idempotent freader x = px == freader (toByteString px) where px = abs x diff --git a/test/RequestSpec.hs b/test/RequestSpec.hs --- a/test/RequestSpec.hs +++ b/test/RequestSpec.hs @@ -1,93 +1,117 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module RequestSpec (main, spec) where +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.IORef +import Data.Monoid (Sum (..)) +import qualified Network.HTTP.Types.Header as HH +import Network.Wai.Handler.Warp.File (parseByteRanges) import Network.Wai.Handler.Warp.Request -import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges) +import Network.Wai.Handler.Warp.Settings ( + defaultSettings, + settingsMaxTotalHeaderLength, + ) import Network.Wai.Handler.Warp.Types import Test.Hspec import Test.Hspec.QuickCheck -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Network.HTTP.Types.Header as HH -import Data.IORef main :: IO () main = hspec spec +defaultMaxTotalHeaderLength :: Int +defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings + spec :: Spec spec = do - describe "headerLines" $ do - it "takes until blank" $ - blankSafe >>= (`shouldBe` ("", ["foo", "bar", "baz"])) - it "ignored leading whitespace in bodies" $ - whiteSafe >>= (`shouldBe` (" hi there", ["foo", "bar", "baz"])) - it "throws OverLargeHeader when too many" $ - tooMany `shouldThrow` overLargeHeader - it "throws OverLargeHeader when too large" $ - tooLarge `shouldThrow` overLargeHeader - it "known bad chunking behavior #239" $ do - let chunks = - [ "GET / HTTP/1.1\r\nConnection: Close\r" - , "\n\r\n" - ] - (actual, src) <- headerLinesList' chunks - leftover <- readLeftoverSource src - leftover `shouldBe` S.empty - actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"] - prop "random chunking" $ \breaks extraS -> do - let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra - extra = S8.pack extraS - chunks = loop breaks bsFull - loop [] bs = [bs, undefined] - loop (x:xs) bs = - bs1 : loop xs bs2 - where - (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs - (actual, src) <- headerLinesList' chunks - leftover <- consumeLen (length extraS) src + describe "headerLines" $ do + it "takes until blank" $ + blankSafe `shouldReturn` ("", ["foo", "bar", "baz"]) + it "ignored leading whitespace in bodies" $ + whiteSafe `shouldReturn` (" hi there", ["foo", "bar", "baz"]) + it "throws OverLargeHeader when too many" $ + tooMany `shouldThrow` overLargeHeader + it "throws OverLargeHeader when too large" $ + tooLarge `shouldThrow` overLargeHeader + it "known bad chunking behavior #239" $ do + let chunks = + [ "GET / HTTP/1.1\r\nConnection: Close\r" + , "\n\r\n" + ] + (actual, src) <- headerLinesList' chunks + leftover <- readLeftoverSource src + leftover `shouldBe` S.empty + actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"] + prop "random chunking" $ \breaks extraS -> do + let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra + extra = S8.pack extraS + chunks = loop breaks bsFull + loop [] bs = [bs, undefined] + loop (x : xs) bs = + bs1 : loop xs bs2 + where + (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs + (actual, src) <- headerLinesList' chunks + leftover <- consumeLen (length extraS) src - actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"] - leftover `shouldBe` extra - describe "parseByteRanges" $ do - let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y - test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499] - test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999] - test "bytes=-500" $ Just [HH.ByteRangeSuffix 500] - test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500] - test "foobytes=9500-" Nothing - test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] + actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"] + leftover `shouldBe` extra + describe "parseByteRanges" $ do + let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y + test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499] + test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999] + test "bytes=-500" $ Just [HH.ByteRangeSuffix 500] + test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500] + test "foobytes=9500-" Nothing + test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] - describe "headerLines" $ do - it "can handle a nomarl case" $ do - src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource - x <- headerLines src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + describe "headerLines" $ do + let parseHeaderLine chunks = do + src <- mkSourceFunc chunks >>= mkSource + x <- headerLines defaultMaxTotalHeaderLength FirstRequest src + x `shouldBe` ["Status: 200", "Content-Type: text/plain"] - it "can handle a nasty case (1)" $ do - src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource - x <- headerLines src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + it "can handle a normal case" $ + parseHeaderLine ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] - it "can handle a nasty case (1)" $ do - src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource - x <- headerLines src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + it "can handle a nasty case (1)" $ do + parseHeaderLine ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] + parseHeaderLine ["Status: 200\r\n", "Content-Type: text/plain", "\r\n\r\n"] - it "can handle a nasty case (1)" $ do - src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource - x <- headerLines src - x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + it "can handle a nasty case (2)" $ do + parseHeaderLine + ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] - it "can handle an illegal case (1)" $ do - src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource - x <- headerLines src - x `shouldBe` [] - y <- headerLines src - y `shouldBe` ["Status: 200", "Content-Type: text/plain"] + it "can handle a nasty case (3)" $ do + parseHeaderLine + ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] + it "can handle a stupid case (3)" $ + parseHeaderLine $ + S8.pack . (: []) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n" + + it "can (not) handle an illegal case (1)" $ do + let chunks = ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] + src <- mkSourceFunc chunks >>= mkSource + x <- headerLines defaultMaxTotalHeaderLength FirstRequest src + x `shouldBe` [] + y <- headerLines defaultMaxTotalHeaderLength FirstRequest src + y `shouldBe` ["Status:", " 200", "Content-Type: text/plain"] + + let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"] + headerLength = getSum $ foldMap (Sum . S.length) testLengthHeaders + testLength = headerLength - 2 -- Because the second CRLF at the end isn't counted + -- Length is 39, this shouldn't fail + it "doesn't throw on correct length" $ do + src <- mkSourceFunc testLengthHeaders >>= mkSource + x <- headerLines testLength FirstRequest src + x `shouldBe` ["Status: 200", "Content-Type: text/plain"] + -- Length is still 39, this should fail + it "throws error on correct length too long" $ do + src <- mkSourceFunc testLengthHeaders >>= mkSource + headerLines (testLength - 1) FirstRequest src `shouldThrow` (== OverLargeHeader) where blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"] whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"] @@ -107,11 +131,11 @@ x <- readIORef ref case x of [] -> return S.empty - y:z -> do + y : z -> do writeIORef ref z return y src' <- mkSource src - res <- headerLines src' + res <- headerLines defaultMaxTotalHeaderLength FirstRequest src' return (res, src') consumeLen :: Int -> Source -> IO S8.ByteString @@ -126,7 +150,7 @@ then loop front 0 else do let (x, _) = S.splitAt len bs - loop (front . (x:)) (len - S.length x) + loop (front . (x :)) (len - S.length x) overLargeHeader :: Selector InvalidRequest overLargeHeader e = e == OverLargeHeader @@ -139,7 +163,7 @@ reader ref = do xss <- readIORef ref case xss of - [] -> return S.empty - (x:xs) -> do + [] -> return S.empty + (x : xs) -> do writeIORef ref xs return x diff --git a/test/ResponseHeaderSpec.hs b/test/ResponseHeaderSpec.hs --- a/test/ResponseHeaderSpec.hs +++ b/test/ResponseHeaderSpec.hs @@ -4,6 +4,8 @@ import Data.ByteString import qualified Network.HTTP.Types as H +import Network.Wai.Handler.Warp.Header +import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.ResponseHeader import Test.Hspec @@ -11,18 +13,37 @@ main = hspec spec spec :: Spec -spec = describe "composeHeader" $ do - it "composes a HTTP header" $ - composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader +spec = do + describe "composeHeader" $ do + it "composes a HTTP header" $ + composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader + describe "addServer" $ do + it "adds Server if not exist" $ do + let hdrs = [] + rspidxhdr = indexResponseHeader hdrs + addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server", "MyServer")] + it "does not add Server if exists" $ do + let hdrs = [("Server", "MyServer")] + rspidxhdr = indexResponseHeader hdrs + addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs + it "does not add Server if empty" $ do + let hdrs = [] + rspidxhdr = indexResponseHeader hdrs + addServer "" rspidxhdr hdrs `shouldBe` hdrs + it "deletes Server " $ do + let hdrs = [("Server", "MyServer")] + rspidxhdr = indexResponseHeader hdrs + addServer "" rspidxhdr hdrs `shouldBe` [] headers :: H.ResponseHeaders -headers = [ - ("Date", "Mon, 13 Aug 2012 04:22:55 GMT") - , ("Content-Lenght", "151") - , ("Server", "Mighttpd/2.5.8") - , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT") - , ("Content-Type", "text/html") - ] +headers = + [ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT") + , ("Content-Length", "151") + , ("Server", "Mighttpd/2.5.8") + , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT") + , ("Content-Type", "text/html") + ] composedHeader :: ByteString -composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n" +composedHeader = + "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n" diff --git a/test/ResponseSpec.hs b/test/ResponseSpec.hs --- a/test/ResponseSpec.hs +++ b/test/ResponseSpec.hs @@ -6,34 +6,31 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Maybe (mapMaybe) -import Network (connectTo, PortID (PortNumber)) import Network.HTTP.Types -import Network.Wai +import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Response -import RunSpec (withApp) -import System.IO (hClose, hFlush) +import RunSpec (msRead, msWrite, withApp, withMySocket) import Test.Hspec -import HTTP - main :: IO () main = hspec spec -testRange :: S.ByteString -- ^ range value - -> String -- ^ expected output - -> Maybe String -- ^ expected content-range value - -> Spec -testRange range out crange = it title $ withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - S.hPutStr handle "GET / HTTP/1.0\r\n" - S.hPutStr handle "Range: bytes=" - S.hPutStr handle range - S.hPutStr handle "\r\n\r\n" - hFlush handle +testRange + :: S.ByteString + -- ^ range value + -> String + -- ^ expected output + -> Maybe String + -- ^ expected content-range value + -> Spec +testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.0\r\n" + msWrite ms "Range: bytes=" + msWrite ms range + msWrite ms "\r\n\r\n" threadDelay 10000 - bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024 - hClose handle + bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 last bss `shouldBe` out let hs = mapMaybe toHeader bss lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange @@ -43,21 +40,23 @@ title = show (range, out, crange) toHeader s = case break (== ':') s of - (x, ':':y) -> Just (x, dropWhile (== ' ') y) + (x, ':' : y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing -testPartial :: Integer -- ^ file size - -> Integer -- ^ offset - -> Integer -- ^ byte count - -> String -- ^ expected output - -> Spec -testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - S.hPutStr handle "GET / HTTP/1.0\r\n\r\n" - hFlush handle +testPartial + :: Integer + -- ^ file size + -> Integer + -- ^ offset + -> Integer + -- ^ byte count + -> String + -- ^ expected output + -> Spec +testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.0\r\n\r\n" threadDelay 10000 - bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024 - hClose handle + bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 out `shouldBe` last bss let hs = mapMaybe toHeader bss lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) @@ -67,19 +66,22 @@ title = show (offset, count, out) toHeader s = case break (== ':') s of - (x, ':':y) -> Just (x, dropWhile (== ' ') y) + (x, ':' : y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing - range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size + range = + "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size spec :: Spec spec = do - describe "preventing response splitting attack" $ do - it "sanitizes header values" $ do - let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello" - withApp defaultSettings app $ \port -> do - res <- sendGET $ "http://127.0.0.1:" ++ show port - getHeaderValue (HdrCustom "foo") res `shouldBe` - Just "foo bar" -- HTTP inserts two spaces for \r\n. + {- http-client does not support this. + describe "preventing response splitting attack" $ do + it "sanitizes header values" $ do + let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello" + withApp defaultSettings app $ \port -> do + res <- sendGET $ "http://127.0.0.1:" ++ show port + getHeaderValue "foo" (responseHeaders res) `shouldBe` + Just "foo bar" -- HTTP inserts two spaces for \r\n. + -} describe "sanitizeHeaderValue" $ do it "doesn't alter valid multiline header values" $ do @@ -91,7 +93,7 @@ it "discards empty lines" $ do sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar" - context "when sanitizing single occurences of \n" $ do + context "when sanitizing single occurrences of \n" $ do it "replaces \n with \r\n" $ do sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar" diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -1,29 +1,27 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module RunSpec (main, spec, withApp) where +module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where import Control.Concurrent (forkIO, killThread, threadDelay) -import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.STM +import Control.Exception (IOException, bracket, onException, try) import qualified Control.Exception as E -import Control.Exception.Lifted (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.ByteString (ByteString, hPutStr, hGetSome) +import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.IORef as I import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv) -import Network (connectTo, PortID (PortNumber)) import Network.HTTP.Types -import Network.Socket (sClose) +import Network.Socket import Network.Socket.ByteString (sendAll) -import Network.Wai -import Network.Wai.Handler.Warp -import System.IO (hFlush, hClose) +import Network.Wai hiding (responseHeaders) +import Network.Wai.Handler.Warp hiding (Counter) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec @@ -36,40 +34,89 @@ type Counter = I.IORef (Either String Int) type CounterApplication = Counter -> Application +data MySocket = MySocket + { msSocket :: !Socket + , msBuffer :: !(I.IORef ByteString) + } + +msWrite :: MySocket -> ByteString -> IO () +msWrite = sendAll . msSocket + +msRead :: MySocket -> Int -> IO ByteString +msRead (MySocket s ref) expected = do + bs <- I.readIORef ref + inner (bs :) (S.length bs) + where + inner front total = + case compare total expected of + EQ -> do + I.writeIORef ref mempty + pure $ S.concat $ front [] + GT -> do + let bs = S.concat $ front [] + (x, y) = S.splitAt expected bs + I.writeIORef ref y + pure x + LT -> do + bs <- safeRecv s 4096 + if S.null bs + then do + I.writeIORef ref mempty + pure $ S.concat $ front [] + else inner (front . (bs :)) (total + S.length bs) + +msClose :: MySocket -> IO () +msClose = Network.Socket.close . msSocket + +connectTo :: Int -> IO MySocket +connectTo port = do + s <- fst <$> getSocketTCP "127.0.0.1" port + ref <- I.newIORef mempty + return + MySocket + { msSocket = s + , msBuffer = ref + } + +withMySocket :: (MySocket -> IO a) -> Int -> IO a +withMySocket body port = bracket (connectTo port) msClose body + incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount -> - ((case ecount of + ( case ecount of Left s -> Left s - Right i -> Right $ i + 1), ()) + Right i -> Right $ i + 1 + , () + ) err :: (MonadIO m, Show a) => Counter -> a -> m () err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg readBody :: CounterApplication readBody icount req f = do - body <- consumeBody $ requestBody req + body <- consumeBody $ getRequestBodyChunk req case () of () - | pathInfo req == ["hello"] && L.fromChunks body /= "Hello" - -> err icount ("Invalid hello" :: String, body) - | requestMethod req == "GET" && L.fromChunks body /= "" - -> err icount ("Invalid GET" :: String, body) - | not $ requestMethod req `elem` ["GET", "POST"] - -> err icount ("Invalid request method (readBody)" :: String, requestMethod req) + | pathInfo req == ["hello"] && L.fromChunks body /= "Hello" -> + err icount ("Invalid hello" :: String, body) + | requestMethod req == "GET" && L.fromChunks body /= "" -> + err icount ("Invalid GET" :: String, body) + | requestMethod req `notElem` ["GET", "POST"] -> + err icount ("Invalid request method (readBody)" :: String, requestMethod req) | otherwise -> incr icount f $ responseLBS status200 [] "Read the body" ignoreBody :: CounterApplication ignoreBody icount req f = do - if (requestMethod req `elem` ["GET", "POST"]) + if requestMethod req `elem` ["GET", "POST"] then incr icount else err icount ("Invalid request method" :: String, requestMethod req) f $ responseLBS status200 [] "Ignored the body" doubleConnect :: CounterApplication doubleConnect icount req f = do - _ <- consumeBody $ requestBody req - _ <- consumeBody $ requestBody req + _ <- consumeBody $ getRequestBodyChunk req + _ <- consumeBody $ getRequestBodyChunk req incr icount f $ responseLBS status200 [] "double connect" @@ -83,33 +130,44 @@ esocket <- try $ bindPortTCP port "127.0.0.1" case esocket of Left (_ :: IOException) -> RunSpec.getPort - Right socket -> do - sClose socket + Right sock -> do + close sock return port withApp :: Settings -> Application -> (Int -> IO a) -> IO a withApp settings app f = do port <- RunSpec.getPort baton <- newEmptyMVar - let settings' = setPort port - $ setHost "127.0.0.1" - $ setBeforeMainLoop (putMVar baton ()) - settings + let settings' = + setPort port $ + setHost "127.0.0.1" $ + setBeforeMainLoop + (putMVar baton ()) + settings bracket (forkIO $ runSettings settings' app `onException` putMVar baton ()) killThread - (const $ takeMVar baton >> f port) + ( const $ do + takeMVar baton + -- use timeout to make sure we don't take too long + mres <- timeout (60 * 1000 * 1000) (f port) + case mres of + Nothing -> error "Timeout triggered, too slow!" + Just a -> pure a + ) -runTest :: Int -- ^ expected number of requests - -> CounterApplication - -> [ByteString] -- ^ chunks to send - -> IO () +runTest + :: Int + -- ^ expected number of requests + -> CounterApplication + -> [ByteString] + -- ^ chunks to send + -> IO () runTest expected app chunks = do ref <- I.newIORef (Right 0) - withApp defaultSettings (app ref) $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle - _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096 + withApp defaultSettings (app ref) $ withMySocket $ \ms -> do + forM_ chunks $ \chunk -> msWrite ms chunk + _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096 res <- I.readIORef ref case res of Left s -> error s @@ -118,18 +176,17 @@ dummyApp :: Application dummyApp _ f = f $ responseLBS status200 [] "foo" -runTerminateTest :: InvalidRequest - -> ByteString - -> IO () +runTerminateTest + :: InvalidRequest + -> ByteString + -> IO () runTerminateTest expected input = do ref <- I.newIORef Nothing let onExc _ = I.writeIORef ref . Just - withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - hPutStr handle input - hFlush handle - hClose handle - threadDelay 1000 + withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do + msWrite ms input + msClose ms -- explicitly + threadDelay 5000 res <- I.readIORef ref show res `shouldBe` show (Just expected) @@ -150,176 +207,214 @@ describe "non-pipelining" $ do it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet - it "has body, read" $ runTest 2 readBody - [ singlePostHello - , singleGet - ] - it "has body, ignore" $ runTest 2 ignoreBody - [ singlePostHello - , singleGet - ] - it "chunked body, read" $ runTest 2 readBody $ concat - [ singleChunkedPostHello - , [singleGet] - ] - it "chunked body, ignore" $ runTest 2 ignoreBody $ concat - [ singleChunkedPostHello - , [singleGet] - ] + it "has body, read" $ + runTest + 2 + readBody + [ singlePostHello + , singleGet + ] + it "has body, ignore" $ + runTest + 2 + ignoreBody + [ singlePostHello + , singleGet + ] + it "chunked body, read" $ + runTest 2 readBody $ + singleChunkedPostHello ++ [singleGet] + it "chunked body, ignore" $ + runTest 2 ignoreBody $ + singleChunkedPostHello ++ [singleGet] describe "pipelining" $ do it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet] it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet] - it "has body, read" $ runTest 2 readBody $ return $ S.concat - [ singlePostHello - , singleGet - ] - it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat - [ singlePostHello - , singleGet - ] - it "chunked body, read" $ runTest 2 readBody $ return $ S.concat - [ S.concat singleChunkedPostHello - , singleGet - ] - it "chunked body, ignore" $ runTest 2 ignoreBody $ return $ S.concat - [ S.concat singleChunkedPostHello - , singleGet - ] + it "has body, read" $ + runTest 2 readBody $ + return $ + S.concat + [ singlePostHello + , singleGet + ] + it "has body, ignore" $ + runTest 2 ignoreBody $ + return $ + S.concat + [ singlePostHello + , singleGet + ] + it "chunked body, read" $ + runTest 2 readBody $ + return $ + S.concat + [ S.concat singleChunkedPostHello + , singleGet + ] + it "chunked body, ignore" $ + runTest 2 ignoreBody $ + return $ + S.concat + [ S.concat singleChunkedPostHello + , singleGet + ] describe "no hanging" $ do - it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello + it "has body, read" $ + runTest 1 readBody $ + map S.singleton $ + S.unpack singlePostHello it "double connect" $ runTest 1 doubleConnect [singlePostHello] describe "connection termination" $ do --- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello" - it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n" + -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello" + it "IncompleteHeaders" $ do + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r" + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n" + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r" + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-lengt" describe "special input" $ do + let appWithSocket f = do + iheaders <- I.newIORef [] + let app req respond = do + liftIO $ I.writeIORef iheaders $ requestHeaders req + respond $ responseLBS status200 [] "" + withApp defaultSettings app $ withMySocket $ f iheaders + it "multiline headers" $ do - iheaders <- I.newIORef [] - let app req f = do - liftIO $ I.writeIORef iheaders $ requestHeaders req - f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - let input = S.concat - [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" - ] - hPutStr handle input - hFlush handle - hClose handle - threadDelay 1000 + appWithSocket $ \iheaders ms -> do + let input = "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" + msWrite ms input + threadDelay 5000 headers <- I.readIORef iheaders - headers `shouldBe` - [ ("foo", "bar baz\tbin") - ] + headers + `shouldBe` [ ("foo", "bar") + , (" baz", "") + , ("\tbin", "") + ] it "no space between colon and value" $ do - iheaders <- I.newIORef [] - let app req f = do - liftIO $ I.writeIORef iheaders $ requestHeaders req - f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - let input = S.concat - [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" - ] - hPutStr handle input - hFlush handle - hClose handle - threadDelay 1000 + appWithSocket $ \iheaders ms -> do + let input = "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" + msWrite ms input + threadDelay 5000 headers <- I.readIORef iheaders - headers `shouldBe` - [ ("foo", "bar") - ] + headers `shouldBe` [("foo", "bar")] + it "does not recognize multiline headers" $ do + appWithSocket $ \iheaders ms -> do + msWrite ms "GET / HTTP/1.1\r\nfoo: and\r\n" + msWrite ms " baz as well\r\n\r\n" + threadDelay 5000 + headers <- I.readIORef iheaders + headers + `shouldBe` [ ("foo", "and") + , (" baz as well", "") + ] describe "chunked bodies" $ do it "works" $ do + countVar <- newTVarIO (0 :: Int) ifront <- I.newIORef id let app req f = do - bss <- consumeBody $ requestBody req - liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) + bss <- consumeBody $ getRequestBodyChunk req + liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) + atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - let input = S.concat - [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" - , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n" - , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" - , "b\r\nHello World\r\n0\r\n\r\n" - ] - hPutStr handle input - hFlush handle - hClose handle - threadDelay 1000 + withApp defaultSettings app $ withMySocket $ \ms -> do + let input = + S.concat + [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n" + , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + , "b\r\nHello World\r\n0\r\n\r\n" + ] + msWrite ms input + atomically $ do + count <- readTVar countVar + check $ count == 2 front <- I.readIORef ifront - front [] `shouldBe` - [ "Hello World\nBye" - , "Hello World" - ] + front [] + `shouldBe` [ "Hello World\nBye" + , "Hello World" + ] it "lots of chunks" $ do ifront <- I.newIORef id + countVar <- newTVarIO (0 :: Int) let app req f = do - bss <- consumeBody $ requestBody req - I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) + bss <- consumeBody $ getRequestBodyChunk req + I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) + atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - let input = concat $ replicate 2 $ - ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++ - (replicate 50 "5\r\n12345\r\n") ++ - ["0\r\n\r\n"] - mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input - hClose handle - threadDelay 100000 -- FIXME why does this delay need to be so high? + withApp defaultSettings app $ withMySocket $ \ms -> do + let input = + concat $ + replicate 2 $ + ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] + ++ replicate 50 "5\r\n12345\r\n" + ++ ["0\r\n\r\n"] + mapM_ (msWrite ms) input + atomically $ do + count <- readTVar countVar + check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345") + -- For some reason, the following test on Windows causes the socket + -- to be killed prematurely. Worth investigating in the future if possible. it "in chunks" $ do ifront <- I.newIORef id + countVar <- newTVarIO (0 :: Int) let app req f = do - bss <- consumeBody $ requestBody req - liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) + bss <- consumeBody $ getRequestBodyChunk req + liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) + atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - let input = S.concat - [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" - , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n" - , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" - , "b\r\nHello World\r\n0\r\n\r\n" - ] - mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input - hClose handle - threadDelay 1000 + withApp defaultSettings app $ withMySocket $ \ms -> do + let input = + S.concat + [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n" + , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" + , "b\r\nHello World\r\n0\r\n\r\n" + ] + mapM_ (msWrite ms . S.singleton) $ S.unpack input + atomically $ do + count <- readTVar countVar + check $ count == 2 front <- I.readIORef ifront - front [] `shouldBe` - [ "Hello World\nBye" - , "Hello World" - ] + front [] + `shouldBe` [ "Hello World\nBye" + , "Hello World" + ] it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do - bss <- (consumeBody $ requestBody req) `onException` - liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ()))) - liftIO $ threadDelay 4000000 `E.catch` \e -> do - I.atomicModifyIORef ifront (\front -> - ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e):) - , ())) - E.throwIO (e :: E.SomeException) - liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) + bss <- + consumeBody (getRequestBodyChunk req) + `onException` liftIO + (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted" :), ()))) + liftIO $ + threadDelay 4000000 `E.catch` \e -> do + I.atomicModifyIORef + ifront + ( \front -> + ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e) :) + , () + ) + ) + E.throwIO (e :: E.SomeException) + liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) f $ responseLBS status200 [] "" - withApp (setTimeout 1 defaultSettings) app $ \port -> do + withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2 - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - hPutStr handle "POST / HTTP/1.1\r\n" - hPutStr handle "content-length: " - hPutStr handle $ S8.pack $ show $ S.length bs - hPutStr handle "\r\n\r\n" + msWrite ms "POST / HTTP/1.1\r\n" + msWrite ms "content-length: " + msWrite ms $ S8.pack $ show $ S.length bs + msWrite ms "\r\n\r\n" threadDelay 100000 - hPutStr handle bs1 + msWrite ms bs1 threadDelay 100000 - hPutStr handle bs2 - hClose handle + msWrite ms bs2 threadDelay 5000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs @@ -335,39 +430,47 @@ loop loop doubleBS = S.concatMap $ \w -> S.pack [w, w] - withApp defaultSettings app $ \port -> do - handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port - hPutStr handle "POST / HTTP/1.1\r\n\r\n12345" - hFlush handle - timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455") - hPutStr handle "67890" - hFlush handle - timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900") - + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "POST / HTTP/1.1\r\n\r\n12345" + timeout 100000 (msRead ms 10) `shouldReturn` Just "1122334455" + msWrite ms "67890" + timeout 100000 (msRead ms 10) `shouldReturn` Just "6677889900" it "only one date and server header" $ do - let app _ f = f $ responseLBS status200 - [ ("server", "server") - , ("date", "date") - ] "" + let app _ f = + f $ + responseLBS + status200 + [ ("server", "server") + , ("date", "date") + ] + "" + getValues key = + map snd + . filter (\(key', _) -> key == key') + . responseHeaders withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port - getHeaderValue HdrServer res `shouldBe` Just "server" - getHeaderValue HdrDate res `shouldBe` Just "date" + getValues hServer res `shouldBe` ["server"] + getValues hDate res `shouldBe` ["date"] it "streaming echo #249" $ do + countVar <- newTVarIO (0 :: Int) let app req f = f $ responseStream status200 [] $ \write _ -> do - let loop = do - bs <- requestBody req - unless (S.null bs) $ do - write $ byteString bs - loop - loop - withApp defaultSettings app $ \port -> do - (socket, _addr) <- getSocketTCP "127.0.0.1" port - sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" + let loop = do + bs <- getRequestBodyChunk req + unless (S.null bs) $ do + write $ byteString bs + atomically $ modifyTVar countVar (+ 1) + loop + loop + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" threadDelay 10000 - sendAll socket "5\r\nhello\r\n0\r\n\r\n" - bs <- safeRecv socket 4096 + msWrite ms "5\r\nhello\r\n0\r\n\r\n" + atomically $ do + count <- readTVar countVar + check $ count >= 1 + bs <- safeRecv (msSocket ms) 4096 -- must not use msRead S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK" it "streaming response with length" $ do @@ -375,7 +478,7 @@ replicateM_ 4 $ write $ byteString "Hello" withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port - rspBody res `shouldBe` "HelloHelloHelloHello" + responseBody res `shouldBe` "HelloHelloHelloHello" describe "head requests" $ do let fp = "test/head-response" @@ -388,19 +491,21 @@ _ -> error "invalid path" it "builder" $ withApp defaultSettings app $ \port -> do res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"] - rspBody res `shouldBe` "" + responseBody res `shouldBe` "" it "streaming" $ withApp defaultSettings app $ \port -> do res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"] - rspBody res `shouldBe` "" + responseBody res `shouldBe` "" it "file, no range" $ withApp defaultSettings app $ \port -> do bs <- S.readFile fp res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"] - getHeaderValue HdrContentLength res `shouldBe` Just (show $ S.length bs) + getHeaderValue hContentLength (responseHeaders res) + `shouldBe` Just (S8.pack $ show $ S.length bs) it "file, with range" $ withApp defaultSettings app $ \port -> do - res <- sendHEADwH - (concat ["http://127.0.0.1:", show port, "/file"]) - [mkHeader HdrRange "bytes=0-1"] - getHeaderValue HdrContentLength res `shouldBe` Just "2" + res <- + sendHEADwH + (concat ["http://127.0.0.1:", show port, "/file"]) + [(hRange, "bytes=0-1")] + getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2" consumeBody :: IO ByteString -> IO [ByteString] consumeBody body = @@ -410,4 +515,4 @@ bs <- body if S.null bs then return $ front [] - else loop $ front . (bs:) + else loop $ front . (bs :) diff --git a/test/SendFileSpec.hs b/test/SendFileSpec.hs --- a/test/SendFileSpec.hs +++ b/test/SendFileSpec.hs @@ -20,40 +20,44 @@ spec :: Spec spec = do - describe "packHeader" $ do - it "returns how much the buffer is consumed (1)" $ - tryPackHeader 10 ["foo"] `shouldReturn` 3 - it "returns how much the buffer is consumed (2)" $ - tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6 - it "returns how much the buffer is consumed (3)" $ - tryPackHeader 10 ["0123456789"] `shouldReturn` 0 - it "returns how much the buffer is consumed (4)" $ - tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0 - it "returns how much the buffer is consumed (5)" $ - tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3 - it "returns how much the buffer is consumed (6)" $ - tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5 + describe "packHeader" $ do + it "returns how much the buffer is consumed (1)" $ + tryPackHeader 10 ["foo"] `shouldReturn` 3 + it "returns how much the buffer is consumed (2)" $ + tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6 + it "returns how much the buffer is consumed (3)" $ + tryPackHeader 10 ["0123456789"] `shouldReturn` 0 + it "returns how much the buffer is consumed (4)" $ + tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0 + it "returns how much the buffer is consumed (5)" $ + tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3 + it "returns how much the buffer is consumed (6)" $ + tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5 - it "sends headers correctly (1)" $ - tryPackHeader2 10 ["foo"] "" `shouldReturn` True - it "sends headers correctly (2)" $ - tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True - it "sends headers correctly (3)" $ - tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True - it "sends headers correctly (4)" $ - tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True - it "sends headers correctly (5)" $ - tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True - it "sends headers correctly (6)" $ - tryPackHeader2 10 ["012345678901234567890123456789012", "34"] "012345678901234567890123456789" `shouldReturn` True + it "sends headers correctly (1)" $ + tryPackHeader2 10 ["foo"] "" `shouldReturn` True + it "sends headers correctly (2)" $ + tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True + it "sends headers correctly (3)" $ + tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True + it "sends headers correctly (4)" $ + tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True + it "sends headers correctly (5)" $ + tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True + it "sends headers correctly (6)" $ + tryPackHeader2 + 10 + ["012345678901234567890123456789012", "34"] + "012345678901234567890123456789" + `shouldReturn` True - describe "readSendFile" $ do - it "sends a file correctly (1)" $ - tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess - it "sends a file correctly (2)" $ - tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess - it "sends a file correctly (3)" $ - tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess + describe "readSendFile" $ do + it "sends a file correctly (1)" $ + tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess + it "sends a file correctly (2)" $ + tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess + it "sends a file correctly (3)" $ + tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess tryPackHeader :: Int -> [ByteString] -> IO Int tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf -> @@ -95,20 +99,20 @@ checkFile :: FilePath -> ByteString -> IO Bool checkFile path bs = do exist <- doesFileExist path - if exist then do - bs' <- BS.readFile path - return $ bs == bs' - else - return $ bs == "" + if exist + then do + bs' <- BS.readFile path + return $ bs == bs' + else return $ bs == "" compareFiles :: FilePath -> FilePath -> IO ExitCode compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2 copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO () copyfile src dst off len = - IO.withBinaryFile src IO.ReadMode $ \h -> do - IO.hSeek h IO.AbsoluteSeek off - BS.hGet h (fromIntegral len) >>= BS.appendFile dst + IO.withBinaryFile src IO.ReadMode $ \h -> do + IO.hSeek h IO.AbsoluteSeek off + BS.hGet h (fromIntegral len) >>= BS.appendFile dst removeFileIfExists :: FilePath -> IO () removeFileIfExists file = do diff --git a/test/ServerStateSpec.hs b/test/ServerStateSpec.hs new file mode 100644 --- /dev/null +++ b/test/ServerStateSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ServerStateSpec where + +import Network.Wai.Handler.Warp (getServerState) +import Network.Wai.Handler.Warp.Counter (getCount, increase) +import Network.Wai.Handler.Warp.Settings ( + ServerState (..), + currentOpenConnections, + currentShuttingDownState, + defaultSettings, + makeServerState, + newServerState, + ) +import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown) +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "ServerState" $ do + it "has the correct initialization" $ do + ss <- newServerState + currentOpenConnections ss `shouldReturn` 0 + currentShuttingDownState ss `shouldReturn` False + describe "makeServerState" $ do + it "has the same state in settings" $ do + (outerSS, set) <- makeServerState defaultSettings + case getServerState set of + Nothing -> expectationFailure "'makeServerState' should set the 'ServerState'" + Just innerSS -> do + let bothCount i = do + a <- currentOpenConnections outerSS + b <- currentOpenConnections innerSS + (a, b) `shouldBe` (i, i) + increase $ serverConnectionCounter outerSS + bothCount 1 + increase $ serverConnectionCounter innerSS + bothCount 2 + let bothDown bool = do + a <- currentShuttingDownState outerSS + b <- currentShuttingDownState innerSS + (a, b) `shouldBe` (bool, bool) + writeShuttingDown (serverShuttingDown outerSS) True + bothDown True + writeShuttingDown (serverShuttingDown innerSS) False + bothDown False + it "is idempotent" $ do + let incAndCheck ss i = do + increase $ serverConnectionCounter ss + currentOpenConnections ss `shouldReturn` i + (ss1, set1) <- makeServerState defaultSettings + incAndCheck ss1 1 + (ss2, _set2) <- makeServerState set1 + incAndCheck ss2 2 + incAndCheck ss1 3 diff --git a/test/WithApplicationSpec.hs b/test/WithApplicationSpec.hs new file mode 100644 --- /dev/null +++ b/test/WithApplicationSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module WithApplicationSpec where + +import Control.Exception +import Network.HTTP.Types +import Network.Wai +import System.Environment +import System.Process +import Test.Hspec + +import Network.Wai.Handler.Warp.WithApplication + +-- All these tests assume the "curl" process can be called directly. +spec :: Spec +spec = do + runIO $ do + unsetEnv "http_proxy" + unsetEnv "https_proxy" + describe "\"curl\" dependency" $ + let msg = + "All \"WithApplication\" tests assume the \"curl\" process can be called directly." + underline = replicate (length msg) '^' + in it (msg ++ "\n " ++ underline) True + describe "withApplication" $ do + it "runs a wai Application while executing the given action" $ do + let mkApp = return $ \_request respond -> respond $ responseLBS ok200 [] "foo" + withApplication mkApp $ \port -> do + output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" + output `shouldBe` "foo" + + it "does not propagate exceptions from the server to the executing thread" $ do + let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo" + withApplication mkApp $ \port -> do + output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" + output `shouldContain` "Something went wron" + + describe "testWithApplication" $ do + it "propagates exceptions from the server to the executing thread" $ do + let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo" + testWithApplication + mkApp + ( \port -> do + readProcess "curl" ["-s", "localhost:" ++ show port] "" + ) + `shouldThrow` (errorCall "foo") diff --git a/test/inputFile b/test/inputFile new file mode 100644 --- /dev/null +++ b/test/inputFile @@ -0,0 +1,100 @@ +A acid +abacus major +abacus pythagoricus +A battery +abbey counter +abbey laird +abbey lands +abbey lubber +abbot cloth +Abbott papyrus +abb wool +A-b-c book +A-b-c method +abdomino-uterotomy +Abdul-baha +a-be +aberrant duct +aberration constant +abiding place +able-bodied +able-bodiedness +able-minded +able-mindedness +able seaman +aboli fruit +A bond +Abor-miri +a-borning +about-face +about ship +about-sledge +above-cited +above-found +above-given +above-mentioned +above-named +above-quoted +above-reported +above-said +above-water +above-written +Abraham-man +abraum salts +abraxas stone +Abri audit culture +abruptly acuminate +abruptly pinnate +absciss layer +absence state +absentee voting +absent-minded +absent-mindedly +absent-mindedness +absent treatment +absent voter +Absent voting +absinthe green +absinthe oil +absorption bands +absorption circuit +absorption coefficient +absorption current +absorption dynamometer +absorption factor +absorption lines +absorption pipette +absorption screen +absorption spectrum +absorption system +A b station +abstinence theory +abstract group +Abt system +abundance declaree +aburachan seed +abutment arch +abutment pier +abutting joint +acacia veld +academy blue +academy board +academy figure +acajou balsam +acanthosis nigricans +acanthus family +acanthus leaf +acaroid resin +Acca larentia +acceleration note +accelerator nerve +accent mark +acceptance bill +acceptance house +acceptance supra protest +acceptor supra protest +accession book +accession number +accession service +access road +accident insurance diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,191 +1,356 @@ -Name: warp -Version: 3.1.12 -Synopsis: A fast, light-weight web server for WAI applications. -License: MIT -License-file: LICENSE -Author: Michael Snoyman, Kazu Yamamoto, Matt Brown -Maintainer: michael@snoyman.com -Homepage: http://github.com/yesodweb/wai -Category: Web, Yesod -Build-Type: Simple -Cabal-Version: >=1.8 -Stability: Stable -description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. - For HTTP\/2, Warp supports direct and ALPN (in TLS) - but not upgrade. - API docs and the README are available at - . -extra-source-files: attic/hex - ChangeLog.md - README.md - test/head-response +cabal-version: >=1.10 +name: warp +version: 3.4.14 +license: MIT +license-file: LICENSE +maintainer: michael@snoyman.com +author: Michael Snoyman, Kazu Yamamoto, Matt Brown +stability: Stable +homepage: https://github.com/yesodweb/wai +synopsis: A fast, light-weight web server for WAI applications. +description: + HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. + For HTTP\/2, Warp supports direct and ALPN (in TLS) + but not upgrade. + API docs and the README are available at + . -Flag network-bytestring - Default: False +category: Web, Yesod +build-type: Simple +extra-source-files: + attic/hex + ChangeLog.md + README.md + test/head-response + test/inputFile -Flag allow-sendfilefd - Description: Allow use of sendfileFd (not available on GNU/kFreeBSD) - Default: True +source-repository head + type: git + location: https://github.com/yesodweb/wai.git + subdir: warp -Flag warp-debug - Description: print debug output. not suitable for production - Default: False +flag network-bytestring + default: False -Library - Build-Depends: base >= 3 && < 5 - , array - , auto-update >= 0.1.3 && < 0.2 - , blaze-builder >= 0.4 - , bytestring >= 0.9.1.4 - , bytestring-builder - , case-insensitive >= 0.2 - , containers - , ghc-prim - , http-types >= 0.8.5 - , iproute >= 1.3.1 - , http2 >= 1.3 && < 1.4 - , simple-sendfile >= 0.2.7 && < 0.3 - , unix-compat >= 0.2 - , wai >= 3.0.4 && < 3.1 - , text - , streaming-commons >= 0.1.10 - , vault >= 0.3 - , stm >= 2.3 - , word8 - , hashable - , unordered-containers - , http-date - if flag(network-bytestring) - Build-Depends: network >= 2.2.1.5 && < 2.2.3 - , network-bytestring >= 0.1.3 && < 0.1.4 - else - Build-Depends: network >= 2.3 - Exposed-modules: Network.Wai.Handler.Warp - Network.Wai.Handler.Warp.Internal - Other-modules: Network.Wai.Handler.Warp.Buffer - Network.Wai.Handler.Warp.Conduit - Network.Wai.Handler.Warp.Counter - Network.Wai.Handler.Warp.Date - Network.Wai.Handler.Warp.FdCache - Network.Wai.Handler.Warp.File - Network.Wai.Handler.Warp.FileInfoCache - Network.Wai.Handler.Warp.HTTP2 - Network.Wai.Handler.Warp.HTTP2.EncodeFrame - Network.Wai.Handler.Warp.HTTP2.HPACK - Network.Wai.Handler.Warp.HTTP2.Manager - Network.Wai.Handler.Warp.HTTP2.Receiver - Network.Wai.Handler.Warp.HTTP2.Request - Network.Wai.Handler.Warp.HTTP2.Sender - Network.Wai.Handler.Warp.HTTP2.Types - Network.Wai.Handler.Warp.HTTP2.Worker - Network.Wai.Handler.Warp.Header - Network.Wai.Handler.Warp.IO - Network.Wai.Handler.Warp.IORef - Network.Wai.Handler.Warp.ReadInt - Network.Wai.Handler.Warp.Recv - Network.Wai.Handler.Warp.Request - Network.Wai.Handler.Warp.RequestHeader - Network.Wai.Handler.Warp.Response - Network.Wai.Handler.Warp.ResponseHeader - Network.Wai.Handler.Warp.Run - Network.Wai.Handler.Warp.SendFile - Network.Wai.Handler.Warp.Settings - Network.Wai.Handler.Warp.Timeout - Network.Wai.Handler.Warp.Types - Network.Wai.Handler.Warp.Windows - Paths_warp - Ghc-Options: -Wall +flag allow-sendfilefd + description: Allow use of sendfileFd (not available on GNU/kFreeBSD) - if flag(warp-debug) - Cpp-Options: -DWARP_DEBUG - if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) - Cpp-Options: -DSENDFILEFD - if os(windows) - Cpp-Options: -DWINDOWS - Build-Depends: time - else - Build-Depends: unix - Other-modules: Network.Wai.Handler.Warp.MultiMap +flag include-warp-version + description: + Exposes the version in Network.Wai.Handler.Warp.warpVersion. + This adds a dependency on Paths_warp so application binaries may + reference subpaths of GHC. For nix users this may result in binaries + with a large transitive runtime dependency closure that includes GHC + itself. + default: True + manual: True -Test-Suite doctest - Type: exitcode-stdio-1.0 - HS-Source-Dirs: test - Ghc-Options: -threaded -Wall - Main-Is: doctests.hs - Build-Depends: base - , doctest >= 0.10.1 +flag warp-debug + description: print debug output. not suitable for production + default: False -Test-Suite spec - Main-Is: Spec.hs - Other-modules: BufferPoolSpec - ConduitSpec - ExceptionSpec - FdCacheSpec - FileSpec - MultiMapSpec - ReadIntSpec - RequestSpec - ResponseHeaderSpec - ResponseSpec - RunSpec - SendFileSpec - HTTP - Hs-Source-Dirs: test, . - Type: exitcode-stdio-1.0 +flag x509 + description: + Adds a dependency on the x509 library to enable getting TLS client certificates. - Ghc-Options: -Wall - Build-Depends: base >= 4 && < 5 - , array - , auto-update - , blaze-builder >= 0.4 - , bytestring >= 0.9.1.4 - , bytestring-builder - , case-insensitive >= 0.2 - , ghc-prim - , HTTP - , http-types >= 0.8.5 - , iproute >= 1.3.1 - , lifted-base >= 0.1 - , simple-sendfile >= 0.2.4 && < 0.3 - , transformers >= 0.2.2 - , unix-compat >= 0.2 - , wai >= 3.0.4 && < 3.1 - , network - , HUnit - , QuickCheck - , hspec >= 1.3 - , time - , text - , streaming-commons >= 0.1.10 - , async - , vault - , stm >= 2.3 - , directory - , process - , containers - , http2 >= 1.3 - , word8 - , hashable - , unordered-containers - , http-date +library + exposed-modules: + Network.Wai.Handler.Warp + Network.Wai.Handler.Warp.Internal - if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) - Cpp-Options: -DSENDFILEFD - Build-Depends: unix - if os(windows) - Cpp-Options: -DWINDOWS + other-modules: + Network.Wai.Handler.Warp.Buffer + Network.Wai.Handler.Warp.Conduit + Network.Wai.Handler.Warp.Counter + Network.Wai.Handler.Warp.Date + Network.Wai.Handler.Warp.FdCache + Network.Wai.Handler.Warp.File + Network.Wai.Handler.Warp.FileInfoCache + Network.Wai.Handler.Warp.HTTP1 + Network.Wai.Handler.Warp.HTTP2 + Network.Wai.Handler.Warp.HTTP2.File + Network.Wai.Handler.Warp.HTTP2.PushPromise + Network.Wai.Handler.Warp.HTTP2.Request + Network.Wai.Handler.Warp.HTTP2.Response + Network.Wai.Handler.Warp.HTTP2.Types + Network.Wai.Handler.Warp.HashMap + Network.Wai.Handler.Warp.Header + Network.Wai.Handler.Warp.IO + Network.Wai.Handler.Warp.Imports + Network.Wai.Handler.Warp.PackInt + Network.Wai.Handler.Warp.ReadInt + Network.Wai.Handler.Warp.Request + Network.Wai.Handler.Warp.RequestHeader + Network.Wai.Handler.Warp.Response + Network.Wai.Handler.Warp.ResponseHeader + Network.Wai.Handler.Warp.Run + Network.Wai.Handler.Warp.SendFile + Network.Wai.Handler.Warp.Settings + Network.Wai.Handler.Warp.ShuttingDown + Network.Wai.Handler.Warp.Types + Network.Wai.Handler.Warp.Windows + Network.Wai.Handler.Warp.WithApplication -Benchmark parser - Type: exitcode-stdio-1.0 - Main-Is: Parser.hs - HS-Source-Dirs: bench . - Build-Depends: base - , bytestring - , criterion - , http-types - , network - , network + if flag(include-warp-version) + other-modules: Paths_warp -Source-Repository head - Type: git - Location: git://github.com/yesodweb/wai.git + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.12 && <5, + array, + auto-update >=0.2.2 && <0.3, + async >= 2, + bsb-http-chunked <0.1, + bytestring >=0.9.1.4, + case-insensitive >=0.2, + containers, + hashable, + http-date, + http-types >=0.12, + http2 >=5.4 && <5.5, + iproute >=1.3.1, + recv >=0.1.0 && <0.2.0, + simple-sendfile >=0.2.7 && <0.3, + stm >=2.3, + streaming-commons >=0.1.10, + text, + time-manager >=0.2 && <0.4, + vault >=0.3, + wai >=3.2.4 && <3.3, + word8 + + if flag(x509) + build-depends: crypton-x509 + + if impl(ghc <8) + build-depends: semigroups + + if flag(network-bytestring) + build-depends: + network >=2.2.1.5 && <2.2.3, + network-bytestring >=0.1.3 && <0.1.4 + + else + build-depends: network >=2.3 + + if flag(warp-debug) + cpp-options: -DWARP_DEBUG + + if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd)) + cpp-options: -DSENDFILEFD + + if os(windows) + cpp-options: -DWINDOWS + build-depends: + time, + unix-compat >=0.2 + + else + other-modules: Network.Wai.Handler.Warp.MultiMap + build-depends: unix + + if impl(ghc >=8) + default-extensions: Strict StrictData + + if flag(include-warp-version) + cpp-options: -DINCLUDE_WARP_VERSION + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: doctests.hs + buildable: False + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -threaded -Wall + build-depends: + base >=4.8 && <5, + doctest >=0.10.1 + + if os(windows) + buildable: False + + if impl(ghc >=8) + default-extensions: Strict StrictData + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test . + other-modules: + ConduitSpec + ConnectionSpec + ExceptionSpec + FdCacheSpec + FileSpec + GracefulShutdownSpec + HTTP + PackIntSpec + ReadIntSpec + RequestSpec + ResponseHeaderSpec + ResponseSpec + RunSpec + SendFileSpec + ServerStateSpec + WithApplicationSpec + Network.Wai.Handler.Warp + Network.Wai.Handler.Warp.Internal + Network.Wai.Handler.Warp.Buffer + Network.Wai.Handler.Warp.Conduit + Network.Wai.Handler.Warp.Counter + Network.Wai.Handler.Warp.Date + Network.Wai.Handler.Warp.FdCache + Network.Wai.Handler.Warp.File + Network.Wai.Handler.Warp.FileInfoCache + Network.Wai.Handler.Warp.HTTP1 + Network.Wai.Handler.Warp.HTTP2 + Network.Wai.Handler.Warp.HTTP2.File + Network.Wai.Handler.Warp.HTTP2.PushPromise + Network.Wai.Handler.Warp.HTTP2.Request + Network.Wai.Handler.Warp.HTTP2.Response + Network.Wai.Handler.Warp.HTTP2.Types + Network.Wai.Handler.Warp.HashMap + Network.Wai.Handler.Warp.Header + Network.Wai.Handler.Warp.IO + Network.Wai.Handler.Warp.Imports + Network.Wai.Handler.Warp.PackInt + Network.Wai.Handler.Warp.ReadInt + Network.Wai.Handler.Warp.Request + Network.Wai.Handler.Warp.RequestHeader + Network.Wai.Handler.Warp.Response + Network.Wai.Handler.Warp.ResponseHeader + Network.Wai.Handler.Warp.Run + Network.Wai.Handler.Warp.SendFile + Network.Wai.Handler.Warp.Settings + Network.Wai.Handler.Warp.ShuttingDown + Network.Wai.Handler.Warp.Types + Network.Wai.Handler.Warp.Windows + Network.Wai.Handler.Warp.WithApplication + + if flag(include-warp-version) + other-modules: Paths_warp + + default-language: Haskell2010 + ghc-options: -Wall -threaded + build-depends: + base >=4.8 && <5, + QuickCheck, + array, + auto-update, + async, + bsb-http-chunked <0.1, + bytestring >=0.9.1.4, + case-insensitive >=0.2, + containers, + directory, + hashable, + hspec >=1.3, + http-client, + http-date, + http-types >=0.12, + http2 >=5.4 && <5.5, + iproute >=1.3.1, + network, + process, + recv >=0.1.0 && <0.2.0, + simple-sendfile >=0.2.4 && <0.3, + stm >=2.3, + streaming-commons >=0.1.10, + text, + time-manager, + vault, + wai >=3.2.2.1 && <3.3, + -- workaround: this should be unnecessary + warp, + word8 + + if flag(x509) + build-depends: crypton-x509 + + if impl(ghc <8) + build-depends: + semigroups, + transformers + + if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd)) + cpp-options: -DSENDFILEFD + + if os(windows) + cpp-options: -DWINDOWS + build-depends: + time, + unix-compat >=0.2 + + else + other-modules: Network.Wai.Handler.Warp.MultiMap + build-depends: unix + + if impl(ghc >=8) + default-extensions: Strict StrictData + +benchmark parser + type: exitcode-stdio-1.0 + main-is: Parser.hs + hs-source-dirs: bench . + other-modules: + Network.Wai.Handler.Warp.Conduit + Network.Wai.Handler.Warp.Counter + Network.Wai.Handler.Warp.Date + Network.Wai.Handler.Warp.FdCache + Network.Wai.Handler.Warp.FileInfoCache + Network.Wai.Handler.Warp.HashMap + Network.Wai.Handler.Warp.Header + Network.Wai.Handler.Warp.Imports + Network.Wai.Handler.Warp.MultiMap + Network.Wai.Handler.Warp.ReadInt + Network.Wai.Handler.Warp.Request + Network.Wai.Handler.Warp.RequestHeader + Network.Wai.Handler.Warp.Settings + Network.Wai.Handler.Warp.Types + + if flag(include-warp-version) + other-modules: Paths_warp + + default-language: Haskell2010 + build-depends: + base >=4.8 && <5, + array, + auto-update, + bytestring, + case-insensitive, + containers, + criterion, + hashable, + http-date, + http-types, + network, + network, + recv, + stm, + streaming-commons, + text, + time-manager, + vault, + wai, + word8 + + if flag(x509) + build-depends: crypton-x509 + + if impl(ghc <8) + build-depends: semigroups + + if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd)) + cpp-options: -DSENDFILEFD + build-depends: unix + + if os(windows) + cpp-options: -DWINDOWS + build-depends: + time, + unix-compat >=0.2 + + if impl(ghc >=8) + default-extensions: Strict StrictData