warp-3.3.31/0000755000000000000000000000000007346545000010743 5ustar0000000000000000warp-3.3.31/ChangeLog.md0000644000000000000000000003770307346545000013126 0ustar0000000000000000# ChangeLog for warp ## 3.3.31 * Supporting http2 v5.0. ## 3.3.30 * Length of `ResponseBuilder` responses will now also be passed to the logger. [#946](https://github.com/yesodweb/wai/pull/946) * Using `If-(None-)Match` headers simultaneously with `If-(Un)Modified-Since` headers now follow the RFC 9110 standard. So `If-(Un)Modified-Since` headers will be correctly ignored if their respective `-Match` counterpart is also present in the request headers. [#945](https://github.com/yesodweb/wai/pull/945) * Fixed adding superfluous `Server` header when using HTTP/2.0 if response already has it. [#943](https://github.com/yesodweb/wai/pull/943) ## 3.3.29 * Preparing coming "http2" v4.2.0. ## 3.3.28 * Fix for the "-x509" flag [#935](https://github.com/yesodweb/wai/pull/935) ## 3.3.27 * Fixing busy loop due to eMFILE [#933](https://github.com/yesodweb/wai/pull/933) ## 3.3.26 * Using crypton instead of cryptonite. [#931](https://github.com/yesodweb/wai/pull/931) ## 3.3.25 * Catching up the signature change of openFd in the unix package v2.8. [#926](https://github.com/yesodweb/wai/pull/926) ## 3.3.24 * Switching the version of the "recv" package from 0.0.x to 0.1.x. ## 3.3.23 * Add `setAccept` for hooking the socket `accept` call. [#912](https://github.com/yesodweb/wai/pull/912) * Removed some package dependencies from test suite [#902](https://github.com/yesodweb/wai/pull/902) * Factored out `Network.Wai.Handler.Warp.Recv` to its own package `recv`. [#899](https://github.com/yesodweb/wai/pull/899) ## 3.3.22 * Creating a bigger buffer when the current one is too small to fit the Builder [#895](https://github.com/yesodweb/wai/pull/895) * Using InvalidRequest instead of HTTP2Error [#890](https://github.com/yesodweb/wai/pull/890) ## 3.3.21 * Support GHC 9.4 [#889](https://github.com/yesodweb/wai/pull/889) ## 3.3.20 * Adding "x509" flag. [#871](https://github.com/yesodweb/wai/pull/871) ## 3.3.19 * Allowing the eMFILE exception in acceptNewConnection. [#831](https://github.com/yesodweb/wai/pull/831) ## 3.3.18 * Tidy up HashMap and MultiMap [#864](https://github.com/yesodweb/wai/pull/864) * Support GHC 9.2 [#863](https://github.com/yesodweb/wai/pull/863) ## 3.3.17 * Modify exception handling to swallow async exceptions in forked thread [#850](https://github.com/yesodweb/wai/issues/850) * Switch default forking function to not install the global exception handler (minor optimization) [#851](https://github.com/yesodweb/wai/pull/851) ## 3.3.16 * Move exception handling over to `unliftio` for better async exception support [#845](https://github.com/yesodweb/wai/issues/845) ## 3.3.15 * Using http2 v3. ## 3.3.14 * Drop support for GHC < 8.2. * Fix header length calculation for `settingsMaxTotalHeaderLength` [#838](https://github.com/yesodweb/wai/pull/838) * UTF-8 encoding in `exceptionResponseForDebug`. [#836](https://github.com/yesodweb/wai/pull/836) ## 3.3.13 * pReadMaker is exported from the Internal module. ## 3.3.12 * Fixing HTTP/2 logging relating to status and push. * Adding QUIC constructor to Transport. ## 3.3.11 * Adding setAltSvc. [#801](https://github.com/yesodweb/wai/pull/801) * Fixing timeout of builder for HTTP/1.1. [#800](https://github.com/yesodweb/wai/pull/800) * `http2server` and `withII` are exported from `Internal` module. ## 3.3.10 * Convert ResourceVanished error to ConnectionClosedByPeer exception [#795](https://github.com/yesodweb/wai/pull/795) * Expand the documentation for `setTimeout`. [#796](https://github.com/yesodweb/wai/pull/796) ## 3.3.9 * Don't insert Last-Modified: if exists. [#791](https://github.com/yesodweb/wai/pull/791) ## 3.3.8 * Maximum header size is configurable. [#781](https://github.com/yesodweb/wai/pull/781) * Ignoring an exception from shutdown (gracefulClose). ## 3.3.7 * InvalidArgument (Bad file descriptor) is ignored in `receive`. [#787](https://github.com/yesodweb/wai/pull/787) ## 3.3.6 * Fixing a bug of thread killed in the case of event source with HTTP/2 (fixing #692 and #785) * New APIs: clientCertificate to get client's certificate [#783](https://github.com/yesodweb/wai/pull/783) ## 3.3.5 * New APIs: setGracefulCloseTimeout1 and setGracefulCloseTimeout2. For HTTP/1.x, connections are closed immediately by default. gracefullClose is used for HTTP/2 by default. [#782](https://github.com/yesodweb/wai/pull/782) ## 3.3.4 * Setting isSecure of HTTP/2 correctly. ## 3.3.3 * Calling setOnException in HTTP/2. [#771](https://github.com/yesodweb/wai/pull/771) ## 3.3.2 * Fixing a bug of HTTP/2 without fd cache. ## 3.3.1 * Using gracefullClose of network 3.1.1 or later if available. * If the first line of an HTTP request is really invalid, don't send an error response ## 3.3.0 * Switching from the original implementation to HTTP/2 server library. [#754](https://github.com/yesodweb/wai/pull/754) * Breaking change: The type of `http2dataTrailers` is now `HTTP2Data -> TrailersMaker`. ## 3.2.28 * Using the Strict and StrictData language extensions for GHC >8. [#752](https://github.com/yesodweb/wai/pull/752) * System.TimeManager is now in a separate package: time-manager. [#750](https://github.com/yesodweb/wai/pull/750) * Fixing a bug of ALPN. * Introducing the half closed state for HTTP/2. [#717](https://github.com/yesodweb/wai/pull/717) ## 3.2.27 * Internally, use `lookupEnv` instead of `getEnvironment` to get the value of the `PORT` environment variable [#736](https://github.com/yesodweb/wai/pull/736) * Throw 413 for too large payload * Throw 431 for too large headers [#741](https://github.com/yesodweb/wai/pull/741) * Use exception response handler in HTTP/2 & improve connection preservation in HTTP/1.x if uncaught exceptions are thrown in an `Application`. [#738](https://github.com/yesodweb/wai/pull/738) ## 3.2.26 * Support network package version 3 ## 3.2.25 * Removing Connection: and Transfer-Encoding: from HTTP/2 response header [#707](https://github.com/yesodweb/wai/pull/707) ## 3.2.24 * Fix HTTP2 unwanted GoAways on late WindowUpdate frames. [#711](https://github.com/yesodweb/wai/pull/711) ## 3.2.23 * Log real requsts when an app throws an error. [#698](https://github.com/yesodweb/wai/pull/698) ## 3.2.22 * Fixing large request body in HTTP/2. ## 3.2.21 * Fixing HTTP/2's timeout handler in request's vault. ## 3.2.20 * Fixing large request body in HTTP/2 [#593](https://github.com/yesodweb/wai/issues/593) ## 3.2.19 * Fixing 0-byte request body in HTTP/2 [#597](https://github.com/yesodweb/wai/issues/597) [#679](https://github.com/yesodweb/wai/issues/679) ## 3.2.18.2 * Replace dependency on `blaze-builder` with `bsb-http-chunked` ## 3.2.18.1 * Fix benchmark compilation [#681](https://github.com/yesodweb/wai/issues/681) ## 3.2.18 * Make `testWithApplicationSettings` actually use the settings passed. [#677](https://github.com/yesodweb/wai/pull/677). ## 3.2.17 * Add support for windows thread block hack and closeOnExec to TLS. [#674](https://github.com/yesodweb/wai/pull/674). ## 3.2.16 * In `testWithApplication`, don't `throwTo` ignorable exceptions [#671](https://github.com/yesodweb/wai/issues/671), and reuse `bindRandomPortTCP` ## 3.2.15 * Address space leak from exception handlers [#649](https://github.com/yesodweb/wai/issues/649) ## 3.2.14 * Support streaming-commons 0.2 * Warnings cleanup ## 3.2.13 * Tickling HTTP/2 timer. [624](https://github.com/yesodweb/wai/pull/624) * Guarantee atomicity of WINDOW_UPDATE increments [622](https://github.com/yesodweb/wai/pull/622) * Relax HTTP2 headers check [621](https://github.com/yesodweb/wai/pull/621) ## 3.2.12 * If an empty string is set by setServerName, the Server header is not included in response headers [#619](https://github.com/yesodweb/wai/issues/619) ## 3.2.11.2 * Don't throw exceptions when closing a keep-alive connection [#618](https://github.com/yesodweb/wai/issues/618) ## 3.2.11.1 * Move exception handling to top of thread (fixes [#613](https://github.com/yesodweb/wai/issues/613)) ## 3.2.11 * Fixing 10 HTTP2 bugs pointed out by h2spec v2. ## 3.2.10 * Add `connFree` to `Connection`. Close socket connections on timeout triggered. Timeout exceptions extend from `SomeAsyncException`. [#602](https://github.com/yesodweb/wai/pull/602) [#605](https://github.com/yesodweb/wai/pull/605) ## 3.2.9 * Fixing a space leak. [#586](https://github.com/yesodweb/wai/pull/586) ## 3.2.8 * Fixing HTTP2 requestBodyLength. [#573](https://github.com/yesodweb/wai/pull/573) * Making HTTP/2 :path optional for the CONNECT method. [#572](https://github.com/yesodweb/wai/pull/572) * Adding new APIs for HTTP/2 trailers: http2dataTrailers and modifyHTTP2Data [#566](https://github.com/yesodweb/wai/pull/566) ## 3.2.7 * Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data [#510](https://github.com/yesodweb/wai/pull/510) * Better accept(2) error handling [#553](https://github.com/yesodweb/wai/pull/553) * Adding getGracefulShutdownTimeout. * Add {test,}withApplicationSettings [#531](https://github.com/yesodweb/wai/pull/531) ## 3.2.6 * Using token based APIs of http2 1.6. ## 3.2.5 * Ignoring errors from setSocketOption. [#526](https://github.com/yesodweb/wai/issues/526). ## 3.2.4 * Added `withApplication`, `testWithApplication`, and `openFreePort` * Fixing reaper delay value of file info cache. ## 3.2.3 * Using http2 v1.5.x which much improves the performance of HTTP/2. * To get rid of the bottleneck of ByteString's (==), a new logic to compare header names is introduced. ## 3.2.2 * Throwing errno for pread [#499](https://github.com/yesodweb/wai/issues/499). * Makeing compilable on Windows [#505](https://github.com/yesodweb/wai/issues/505). ## 3.2.1 * Add back `warpVersion` ## 3.2.0 * Major version up due to breaking changes. This is because the HTTP/2 code was started over with Warp 3.1.3 due to performance issue [#470](https://github.com/yesodweb/wai/issues/470). * runHTTP2, runHTTP2Env, runHTTP2Settings and runHTTP2SettingsSocket were removed from the Network.Wai.Handler.Warp module. * The performance of HTTP/2 was drastically improved. Now the performance of HTTP/2 is almost the same as that of HTTP/1.1. * The logic to handle files in HTTP/2 is now identical to that in HTTP/1.1. * Internal stuff was removed from the Network.Wai.Handler.Warp module according to [the plan](http://www.yesodweb.com/blog/2015/06/cleaning-up-warp-apis). ## 3.1.12 * Setting lower bound for auto-update [#495](https://github.com/yesodweb/wai/issues/495) ## 3.1.11 * Providing a new API: killManager. * Preventing space leaks due to Weak ThreadId [#488](https://github.com/yesodweb/wai/issues/488) * Setting upper bound for http2. ## 3.1.10 * `setFileInfoCacheDuration` * `setLogger` * `FileInfo`/`getFileInfo` * Fix: warp-tls strips out the Host request header [#478](https://github.com/yesodweb/wai/issues/478) ## 3.1.9 * Using the new priority queue based on PSQ provided by http2 lib again. ## 3.1.8 * Using the new priority queue based on PSQ provided by http2 lib. ## 3.1.7 * A concatenated Cookie header is prepended to the headers to ensure that it flows pseudo headers. [#454](https://github.com/yesodweb/wai/pull/454) * Providing a new settings: `setHTTP2Disabled` [#450](https://github.com/yesodweb/wai/pull/450) ## 3.1.6 * Adding back http-types 0.8 support [#449](https://github.com/yesodweb/wai/pull/449) ## 3.1.5 * Using http-types v0.9. * Fixing build on OpenBSD. [#428](https://github.com/yesodweb/wai/pull/428) [#440](https://github.com/yesodweb/wai/pull/440) * Fixing build on Windows. [#438](https://github.com/yesodweb/wai/pull/438) ## 3.1.4 * Using newer http2 library to prevent change table size attacks. * API for HTTP/2 server push and trailers. [#426](https://github.com/yesodweb/wai/pull/426) * Preventing response splitting attacks. [#435](https://github.com/yesodweb/wai/pull/435) * Concatenating multiple Cookie: headers in HTTP/2. ## 3.1.3 * Warp now supports blaze-builder v0.4 or later only. * HTTP/2 code was improved: dynamic priority change, efficient queuing and sender loop continuation. [#423](https://github.com/yesodweb/wai/pull/423) [#424](https://github.com/yesodweb/wai/pull/424) ## 3.1.2 * Configurable Slowloris size [#418](https://github.com/yesodweb/wai/pull/418) ## 3.1.1 * Fixing a bug of HTTP/2 when no FD cache is used [#411](https://github.com/yesodweb/wai/pull/411) * Fixing a buffer-pool bug [#406](https://github.com/yesodweb/wai/pull/406) [#407](https://github.com/yesodweb/wai/pull/407) ## 3.1.0 * Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399) * Cleaning up APIs [#387](https://github.com/yesodweb/wai/issues/387) ## 3.0.13.1 * Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375) ## 3.0.13 * Turn off file descriptor cache by default [#371](https://github.com/yesodweb/wai/issues/371) ## 3.0.12.1 * Fix for: HEAD requests returning non-empty entity body [#369](https://github.com/yesodweb/wai/issues/369) ## 3.0.12 * Only conditionally produce HTTP 100 Continue ## 3.0.11 * Better HEAD support for files [#357](https://github.com/yesodweb/wai/pull/357) ## 3.0.10 * Fix [missing `IORef` tweak](https://github.com/yesodweb/wai/issues/351) * Disable timeouts as soon as request body is fully consumed. This addresses the common case of a non-chunked request body. Previously, we would wait until a zero-length `ByteString` is returned, but that is suboptimal for some cases. For more information, see [issue 351](https://github.com/yesodweb/wai/issues/351). * Add `pauseTimeout` function ## 3.0.9.3 * Don't serve a 416 status code for 0-length files [keter issue #75](https://github.com/snoyberg/keter/issues/75) * Don't serve content-length for 416 responses [#346](https://github.com/yesodweb/wai/issues/346) ## 3.0.9.2 Fix support for old versions of bytestring ## 3.0.9.1 Add support for blaze-builder 0.4 ## 3.0.9 * Add runEnv: like run but uses $PORT [#334](https://github.com/yesodweb/wai/pull/334) ## 3.0.5.2 * [Pass the Request to settingsOnException handlers when available. #326](https://github.com/yesodweb/wai/pull/326) ## 3.0.5 Support for PROXY protocol, such as used by Amazon ELB TCP. This is useful since, for example, Amazon ELB HTTP does *not* have support for Websockets. More information on the protocol [is available from Amazon](http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol). ## 3.0.4 Added `setFork`. ## 3.0.3 Modify flushing of request bodies. Previously, regardless of the size of the request body, the entire body would be flushed. When uploading large files to a web app that does not accept such files (e.g., returns a 413 too large status), browsers would still send the entire request body and the servers will still receive it. The new behavior is to detect if there is a large amount of data still to be consumed and, if so, immediately terminate the connection. In the case of chunked request bodies, up to a maximum number of bytes is consumed before the connection is terminated. This is controlled by the new setting `setMaximumBodyFlush`. A value of @Nothing@ will return the original behavior of flushing the entire body. ## 3.0.0 WAI no longer uses conduit for its streaming interface. ## 2.1.0 The `onOpen` and `onClose` settings now provide the `SockAddr` of the client, and `onOpen` can return a `Bool` which will close the connection. The `responseRaw` response has been added, which provides a more elegant way to handle WebSockets than the previous `settingsIntercept`. The old settings accessors have been deprecated in favor of new setters, which will allow settings changes to be made in the future without breaking backwards compatibility. ## 2.0.0 ResourceT is not used anymore. Request and Response is now abstract data types. To use their constructors, Internal module should be imported. ## 1.3.9 Support for byte range requests. ## 1.3.7 Sockets now have `FD_CLOEXEC` set on them. This behavior is more secure, and the change should not affect the vast majority of use cases. However, it appeared that this is buggy and is fixed in 2.0.0. warp-3.3.31/LICENSE0000644000000000000000000000207507346545000011754 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. warp-3.3.31/Network/Wai/Handler/0000755000000000000000000000000007346545000014471 5ustar0000000000000000warp-3.3.31/Network/Wai/Handler/Warp.hs0000644000000000000000000004443507346545000015750 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} --------------------------------------------------------- -- -- Module : Network.Wai.Handler.Warp -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Stable -- Portability : portable -- -- A fast, light-weight HTTP server handler for WAI. -- --------------------------------------------------------- -- | A fast, light-weight HTTP server handler for WAI. -- -- HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2, -- Warp supports direct and ALPN (in TLS) but not upgrade. -- -- Note on slowloris timeouts: to prevent slowloris attacks, timeouts are used -- at various points in request receiving and response sending. One interesting -- corner case is partial request body consumption; in that case, Warp's -- timeout handling is still in effect, and the timeout will not be triggered -- again. Therefore, it is recommended that once you start consuming the -- request body, you either: -- -- * consume the entire body promptly -- -- * call the 'pauseTimeout' function -- -- For more information, see . -- -- module Network.Wai.Handler.Warp ( -- * Run a Warp server -- | All of these automatically serve the same 'Application' over HTTP\/1, -- HTTP\/1.1, and HTTP\/2. run , runEnv , runSettings , runSettingsSocket -- * Settings , Settings , defaultSettings -- ** Setters , setPort , setHost , setOnException , setOnExceptionResponse , setOnOpen , setOnClose , setTimeout , setManager , setFdCacheDuration , setFileInfoCacheDuration , setBeforeMainLoop , setNoParsePath , setInstallShutdownHandler , setServerName , setMaximumBodyFlush , setFork , setAccept , setProxyProtocolNone , setProxyProtocolRequired , setProxyProtocolOptional , setSlowlorisSize , setHTTP2Disabled , setLogger , setServerPushLogger , setGracefulShutdownTimeout , setGracefulCloseTimeout1 , setGracefulCloseTimeout2 , setMaxTotalHeaderLength , setAltSvc , setMaxBuilderResponseBufferSize -- ** Getters , getPort , getHost , getOnOpen , getOnClose , getOnException , getGracefulShutdownTimeout , getGracefulCloseTimeout1 , getGracefulCloseTimeout2 -- ** Exception handler , defaultOnException , defaultShouldDisplayException -- ** Exception response handler , defaultOnExceptionResponse , exceptionResponseForDebug -- * Data types , HostPreference , Port , InvalidRequest (..) -- * Utilities , pauseTimeout , FileInfo(..) , getFileInfo #ifdef MIN_VERSION_crypton_x509 , clientCertificate #endif , withApplication , withApplicationSettings , testWithApplication , testWithApplicationSettings , openFreePort -- * Version , warpVersion -- * HTTP/2 -- ** HTTP2 data , HTTP2Data , http2dataPushPromise , http2dataTrailers , defaultHTTP2Data , getHTTP2Data , setHTTP2Data , modifyHTTP2Data -- ** Push promise , PushPromise , promisedPath , promisedFile , promisedResponseHeaders , promisedWeight , defaultPushPromise ) where import UnliftIO.Exception (SomeException, throwIO) import Data.Streaming.Network (HostPreference) import qualified Data.Vault.Lazy as Vault #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif import qualified Network.HTTP.Types as H import Network.Socket (Socket, SockAddr) import Network.Wai (Request, Response, vault) import System.TimeManager import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data) 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 (warpVersion) import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types hiding (getFileInfo) import Network.Wai.Handler.Warp.WithApplication -- | Port to listen on. Default value: 3000 -- -- Since 2.1.0 setPort :: Port -> Settings -> Settings setPort x y = y { settingsPort = x } -- | Interface to bind to. Default value: HostIPv4 -- -- Since 2.1.0 setHost :: HostPreference -> Settings -> Settings setHost x y = y { settingsHost = x } -- | What to do with exceptions thrown by either the application or server. -- Default: 'defaultOnException' -- -- Since 2.1.0 setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings setOnException x y = y { settingsOnException = x } -- | A function to create a `Response` when an exception occurs. -- Default: 'defaultOnExceptionResponse' -- -- Note that an application can handle its own exceptions without interfering with Warp: -- -- > myApp :: Application -- > myApp request respond = innerApp `catch` onError -- > where -- > onError = respond . response500 request -- > -- > response500 :: Request -> SomeException -> Response -- > response500 req someEx = responseLBS status500 -- ... -- -- Since 2.1.0 setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings setOnExceptionResponse x y = y { settingsOnExceptionResponse = x } -- | What to do when a connection is opened. When 'False' is returned, the -- connection is closed immediately. Otherwise, the connection is going on. -- Default: always returns 'True'. -- -- Since 2.1.0 setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings setOnOpen x y = y { settingsOnOpen = x } -- | What to do when a connection is closed. Default: do nothing. -- -- Since 2.1.0 setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings setOnClose x y = y { settingsOnClose = x } -- | "Slow-loris" timeout lower-bound value in seconds. Connections where -- network progress is made less frequently than this may be closed. In -- practice many connections may be allowed to go without progress for up to -- twice this amount of time. Note that this timeout is not applied to -- application code, only network progress. -- -- Default value: 30 -- -- Since 2.1.0 setTimeout :: Int -> Settings -> Settings setTimeout x y = y { settingsTimeout = x } -- | Use an existing timeout manager instead of spawning a new one. If used, -- 'settingsTimeout' is ignored. -- -- Since 2.1.0 setManager :: Manager -> Settings -> Settings setManager x y = y { settingsManager = Just x } -- | Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. -- -- The FD cache is an optimization that is useful for servers dealing with -- static files. However, if files are being modified, it can cause incorrect -- results in some cases. Therefore, we disable it by default. If you know that -- your files will be static or you prefer performance to file consistency, -- it's recommended to turn this on; a reasonable value for those cases is 10. -- Enabling this cache results in drastic performance improvement for file -- transfers. -- -- Default value: 0, was previously 10 -- -- Since 3.0.13 setFdCacheDuration :: Int -> Settings -> Settings setFdCacheDuration x y = y { settingsFdCacheDuration = x } -- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. -- -- The file information cache is an optimization that is useful for servers dealing with -- static files. However, if files are being modified, it can cause incorrect -- results in some cases. Therefore, we disable it by default. If you know that -- your files will be static or you prefer performance to file consistency, -- it's recommended to turn this on; a reasonable value for those cases is 10. -- Enabling this cache results in drastic performance improvement for file -- transfers. -- -- Default value: 0 setFileInfoCacheDuration :: Int -> Settings -> Settings setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x } -- | Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start -- running, or to drop permissions after binding to a restricted port. -- -- Default: do nothing. -- -- Since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings setBeforeMainLoop x y = y { settingsBeforeMainLoop = x } -- | Perform no parsing on the rawPathInfo. -- -- This is useful for writing HTTP proxies. -- -- Default: False -- -- Since 2.1.0 setNoParsePath :: Bool -> Settings -> Settings setNoParsePath x y = y { settingsNoParsePath = x } -- | Get the listening port. -- -- Since 2.1.1 getPort :: Settings -> Port getPort = settingsPort -- | Get the interface to bind to. -- -- Since 2.1.1 getHost :: Settings -> HostPreference getHost = settingsHost -- | Get the action on opening connection. getOnOpen :: Settings -> SockAddr -> IO Bool getOnOpen = settingsOnOpen -- | Get the action on closeing connection. getOnClose :: Settings -> SockAddr -> IO () getOnClose = settingsOnClose -- | Get the exception handler. getOnException :: Settings -> Maybe Request -> SomeException -> IO () getOnException = settingsOnException -- | Get the graceful shutdown timeout -- -- Since 3.2.8 getGracefulShutdownTimeout :: Settings -> Maybe Int getGracefulShutdownTimeout = settingsGracefulShutdownTimeout -- | A code to install shutdown handler. -- -- For instance, this code should set up a UNIX signal -- handler. The handler should call the first argument, -- which closes the listen socket, at shutdown. -- -- Example usage: -- -- @ -- settings :: IO () -> 'Settings' -- settings shutdownAction = 'setInstallShutdownHandler' shutdownHandler 'defaultSettings' -- __where__ -- shutdownHandler closeSocket = -- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing' -- @ -- -- Note that by default, the graceful shutdown mode lasts indefinitely -- (see 'setGracefulShutdownTimeout'). If you install a signal handler as above, -- upon receiving that signal, the custom shutdown action will run /and/ all -- outstanding requests will be handled. -- -- You may instead prefer to do one or both of the following: -- -- * Only wait a finite amount of time for outstanding requests to complete, -- using 'setGracefulShutdownTimeout'. -- * Only catch one signal, so the second hard-kills the Warp server, using -- 'System.Posix.Signals.CatchOnce'. -- -- Default: does not install any code. -- -- Since 3.0.1 setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x } -- | Default server name to be sent as the \"Server:\" header -- if an application does not set one. -- If an empty string is set, the \"Server:\" header is not sent. -- This is true even if an application set one. -- -- Since 3.0.2 setServerName :: ByteString -> Settings -> Settings setServerName x y = y { settingsServerName = x } -- | The maximum number of bytes to flush from an unconsumed request body. -- -- By default, Warp does not flush the request body so that, if a large body is -- present, the connection is simply terminated instead of wasting time and -- bandwidth on transmitting it. However, some clients do not deal with that -- situation well. You can either change this setting to @Nothing@ to flush the -- entire body in all cases, or in your application ensure that you always -- consume the entire request body. -- -- Default: 8192 bytes. -- -- Since 3.0.3 setMaximumBodyFlush :: Maybe Int -> Settings -> Settings setMaximumBodyFlush x y | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive" | otherwise = y { settingsMaximumBodyFlush = x } -- | Code to fork a new thread to accept a connection. -- -- This may be useful if you need OS bound threads, or if -- you wish to develop an alternative threading model. -- -- Default: void . forkIOWithUnmask -- -- Since 3.0.4 setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings setFork fork' s = s { settingsFork = fork' } -- | Code to accept a new connection. -- -- Useful if you need to provide connected sockets from something other -- than a standard accept call. -- -- Default: 'defaultAccept' -- -- Since 3.3.24 setAccept :: (Socket -> IO (Socket, SockAddr)) -> Settings -> Settings setAccept accept' s = s { settingsAccept = accept' } -- | Do not use the PROXY protocol. -- -- Since 3.0.5 setProxyProtocolNone :: Settings -> Settings setProxyProtocolNone y = y { settingsProxyProtocol = ProxyProtocolNone } -- | Require PROXY header. -- -- This is for cases where a "dumb" TCP/SSL proxy is being used, which cannot -- add an @X-Forwarded-For@ HTTP header field but has enabled support for the -- PROXY protocol. -- -- See and -- . -- -- Only the human-readable header format (version 1) is supported. The binary -- header format (version 2) is /not/ supported. -- -- Since 3.0.5 setProxyProtocolRequired :: Settings -> Settings setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired } -- | Use the PROXY header if it exists, but also accept -- connections without the header. See 'setProxyProtocolRequired'. -- -- WARNING: This is contrary to the PROXY protocol specification and -- using it can indicate a security problem with your -- architecture if the web server is directly accessible -- to the public, since it would allow easy IP address -- spoofing. However, it can be useful in some cases, -- such as if a load balancer health check uses regular -- HTTP without the PROXY header, but proxied -- connections /do/ include the PROXY header. -- -- Since 3.0.5 setProxyProtocolOptional :: Settings -> Settings setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional } -- | Size in bytes read to prevent Slowloris attacks. Default value: 2048 -- -- Since 3.1.2 setSlowlorisSize :: Int -> Settings -> Settings setSlowlorisSize x y = y { settingsSlowlorisSize = x } -- | Disable HTTP2. -- -- Since 3.1.7 setHTTP2Disabled :: Settings -> Settings setHTTP2Disabled y = y { settingsHTTP2Enabled = False } -- | Setting a log function. -- -- Since 3.X.X setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -- ^ request, status, maybe file-size -> Settings -> Settings setLogger lgr y = y { settingsLogger = lgr } -- | Setting a log function for HTTP/2 server push. -- -- Since: 3.2.7 setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size -> Settings -> Settings setServerPushLogger lgr y = y { settingsServerPushLogger = lgr } -- | Set the graceful shutdown timeout. A timeout of `Nothing' will -- wait indefinitely, and a number, if provided, will be treated as seconds -- to wait for requests to finish, before shutting down the server entirely. -- -- Graceful shutdown mode is entered when the server socket is closed; see -- 'setInstallShutdownHandler' for an example of how this could be done in -- response to a UNIX signal. -- -- Since 3.2.8 setGracefulShutdownTimeout :: Maybe Int -> Settings -> Settings setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time } -- | Set the maximum header size that Warp will tolerate when using HTTP/1.x. -- -- Since 3.3.8 setMaxTotalHeaderLength :: Int -> Settings -> Settings setMaxTotalHeaderLength maxTotalHeaderLength settings = settings { settingsMaxTotalHeaderLength = maxTotalHeaderLength } -- | Setting the header value of Alternative Services (AltSvc:). -- -- Since 3.3.11 setAltSvc :: ByteString -> Settings -> Settings setAltSvc altsvc settings = settings { settingsAltSvc = Just altsvc } -- | Set the maximum buffer size for sending `Builder` responses. -- -- Since 3.3.22 setMaxBuilderResponseBufferSize :: Int -> Settings -> Settings setMaxBuilderResponseBufferSize maxRspBufSize settings = settings { settingsMaxBuilderResponseBufferSize = maxRspBufSize } -- | Explicitly pause the slowloris timeout. -- -- This is useful for cases where you partially consume a request body. For -- more information, see -- -- Since 3.0.10 pauseTimeout :: Request -> IO () pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault -- | Getting file information of the target file. -- -- This function first uses a stat(2) or similar system call -- to obtain information of the target file, then registers -- it into the internal cache. -- From the next time, the information is obtained -- from the cache. This reduces the overhead to call the system call. -- The internal cache is refreshed every duration specified by -- 'setFileInfoCacheDuration'. -- -- This function throws an 'IO' exception if the information is not -- available. For instance, the target file does not exist. -- If this function is used an a Request generated by a WAI -- backend besides Warp, it also throws an 'IO' exception. -- -- Since 3.1.10 getFileInfo :: Request -> FilePath -> IO FileInfo getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault -- | A timeout to limit the time (in milliseconds) waiting for -- FIN for HTTP/1.x. 0 means uses immediate close. -- Default: 0. -- -- Since 3.3.5 setGracefulCloseTimeout1 :: Int -> Settings -> Settings setGracefulCloseTimeout1 x y = y { settingsGracefulCloseTimeout1 = x } -- | A timeout to limit the time (in milliseconds) waiting for -- FIN for HTTP/1.x. 0 means uses immediate close. -- -- Since 3.3.5 getGracefulCloseTimeout1 :: Settings -> Int getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1 -- | A timeout to limit the time (in milliseconds) waiting for -- FIN for HTTP/2. 0 means uses immediate close. -- Default: 2000. -- -- Since 3.3.5 setGracefulCloseTimeout2 :: Int -> Settings -> Settings setGracefulCloseTimeout2 x y = y { settingsGracefulCloseTimeout2 = x } -- | A timeout to limit the time (in milliseconds) waiting for -- FIN for HTTP/2. 0 means uses immediate close. -- -- Since 3.3.5 getGracefulCloseTimeout2 :: Settings -> Int getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2 #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 warp-3.3.31/Network/Wai/Handler/Warp/0000755000000000000000000000000007346545000015402 5ustar0000000000000000warp-3.3.31/Network/Wai/Handler/Warp/Buffer.hs0000644000000000000000000000316107346545000017150 0ustar0000000000000000module Network.Wai.Handler.Warp.Buffer ( createWriteBuffer , allocateBuffer , freeBuffer , toBuilderBuffer , bufferIO ) where import Data.IORef (IORef, readIORef) import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..)) import Foreign.ForeignPtr import Foreign.Marshal.Alloc (mallocBytes, free) import Foreign.Ptr (plusPtr) import Network.Socket.BufferPool import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -- | Allocate a buffer of the given size and wrap it in a 'WriteBuffer' -- containing that size and a finalizer. createWriteBuffer :: BufSize -> IO WriteBuffer createWriteBuffer size = do bytes <- allocateBuffer size return WriteBuffer { bufBuffer = bytes, bufSize = size, bufFree = freeBuffer bytes } ---------------------------------------------------------------- -- | Allocating a buffer with malloc(). allocateBuffer :: Int -> IO Buffer allocateBuffer = mallocBytes -- | Releasing a buffer with free(). freeBuffer :: Buffer -> IO () freeBuffer = free ---------------------------------------------------------------- -- -- Utilities -- toBuilderBuffer :: IORef WriteBuffer -> IO B.Buffer toBuilderBuffer writeBufferRef = do writeBuffer <- readIORef writeBufferRef let ptr = bufBuffer writeBuffer size = bufSize writeBuffer fptr <- newForeignPtr_ ptr return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size) bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO () bufferIO ptr siz io = do fptr <- newForeignPtr_ ptr io $ PS fptr 0 siz warp-3.3.31/Network/Wai/Handler/Warp/Conduit.hs0000644000000000000000000001305307346545000017345 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Conduit where import UnliftIO (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -- | Contains a @Source@ and a byte count that is still to be read in. data ISource = ISource !Source !(I.IORef Int) mkISource :: Source -> Int -> IO ISource mkISource src cnt = do ref <- I.newIORef cnt return $! ISource src ref -- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the -- specified number of bytes to be passed downstream. All leftovers should be -- retained within the @Source@. If there are not enough bytes available, -- throws a @ConnectionClosedByPeer@ exception. readISource :: ISource -> IO ByteString readISource (ISource src ref) = do count <- I.readIORef ref if count == 0 then return S.empty else do bs <- readSource src -- If no chunk available, then there aren't enough bytes in the -- stream. Throw a ConnectionClosedByPeer when (S.null bs) $ throwIO ConnectionClosedByPeer let -- How many of the bytes in this chunk to send downstream toSend = min count (S.length bs) -- How many bytes will still remain to be sent downstream count' = count - toSend case () of () -- 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 let (x, y) = S.splitAt toSend bs leftoverSource src y assert (count' == 0) $ I.writeIORef ref count' return x ---------------------------------------------------------------- data CSource = CSource !Source !(I.IORef ChunkState) data ChunkState = NeedLen | NeedLenNewline | HaveLen Word | DoneChunking deriving Show mkCSource :: Source -> IO CSource mkCSource src = do ref <- I.newIORef NeedLen return $! CSource src ref readCSource :: CSource -> IO ByteString readCSource (CSource src ref) = do mlen <- I.readIORef ref go mlen where withLen 0 bs = do leftoverSource src bs dropCRLF yield' S.empty DoneChunking withLen len bs | S.null bs = do -- FIXME should this throw an exception if len > 0? I.writeIORef ref DoneChunking return S.empty | otherwise = case S.length bs `compare` fromIntegral len of EQ -> yield' bs NeedLenNewline LT -> yield' bs $ HaveLen $ len - fromIntegral (S.length bs) GT -> do let (x, y) = S.splitAt (fromIntegral len) bs leftoverSource src y yield' x NeedLenNewline yield' bs mlen = do I.writeIORef ref mlen return bs dropCRLF = do bs <- readSource src case S.uncons bs of Nothing -> return () Just (13, bs') -> dropLF bs' Just (10, bs') -> leftoverSource src bs' Just _ -> 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 go NeedLen = getLen go NeedLenNewline = dropCRLF >> getLen go (HaveLen 0) = do -- Drop the final CRLF dropCRLF I.writeIORef ref DoneChunking return S.empty go (HaveLen len) = do bs <- readSource src withLen len bs go DoneChunking = return S.empty -- Get the length from the source, and then pass off control to withLen getLen = do bs <- readSource src if S.null bs then do I.writeIORef ref $ assert False $ HaveLen 0 return S.empty else do (x, y) <- case S.break (== 10) 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 | otherwise -> return (x, y) let w = S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $ S.takeWhile isHexDigit x let y' = S.drop 1 y y'' <- if S.null y' then readSource src else return y' withLen w y'' hexToWord w | w < 58 = w - 48 | w < 71 = w - 55 | otherwise = w - 87 isHexDigit :: Word8 -> Bool isHexDigit w = w >= 48 && w <= 57 || w >= 65 && w <= 70 || w >= 97 && w <= 102 warp-3.3.31/Network/Wai/Handler/Warp/Counter.hs0000644000000000000000000000117307346545000017357 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Counter ( Counter , newCounter , waitForZero , increase , decrease ) where import Control.Concurrent.STM import Network.Wai.Handler.Warp.Imports newtype Counter = Counter (TVar Int) newCounter :: IO Counter newCounter = Counter <$> newTVarIO 0 waitForZero :: Counter -> IO () waitForZero (Counter ref) = atomically $ do x <- readTVar ref when (x > 0) retry increase :: Counter -> IO () increase (Counter ref) = atomically $ modifyTVar' ref $ \x -> x + 1 decrease :: Counter -> IO () decrease (Counter ref) = atomically $ modifyTVar' ref $ \x -> x - 1 warp-3.3.31/Network/Wai/Handler/Warp/Date.hs0000644000000000000000000000213307346545000016612 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Date ( withDateCache , GMTDate ) where import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate) import Data.ByteString import Network.HTTP.Date #if WINDOWS import Data.Time (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Foreign.C.Types (CTime(..)) #else import System.Posix (epochTime) #endif -- | The type of the Date header value. type GMTDate = ByteString -- | Creating 'DateCache' and executing the action. withDateCache :: (IO GMTDate -> IO a) -> IO a withDateCache action = initialize >>= action initialize :: IO (IO GMTDate) initialize = mkAutoUpdate defaultUpdateSettings { updateAction = formatHTTPDate <$> getCurrentHTTPDate } #ifdef WINDOWS uToH :: UTCTime -> HTTPDate uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds getCurrentHTTPDate :: IO HTTPDate getCurrentHTTPDate = uToH <$> getCurrentTime #else getCurrentHTTPDate :: IO HTTPDate getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime #endif warp-3.3.31/Network/Wai/Handler/Warp/FdCache.hs0000644000000000000000000001037107346545000017215 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} -- | File descriptor cache to avoid locks in kernel. module Network.Wai.Handler.Warp.FdCache ( withFdCache , Fd , Refresh #ifndef WINDOWS , openFile , closeFile , setFileCloseOnExec #endif ) where #ifndef WINDOWS import UnliftIO.Exception (bracket) import Control.Reaper import Data.IORef import Network.Wai.Handler.Warp.MultiMap as MM import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption) #endif import System.Posix.Types (Fd) ---------------------------------------------------------------- -- | An action to activate a Fd cache entry. type Refresh = IO () getFdNothing :: FilePath -> IO (Maybe Fd, Refresh) getFdNothing _ = return (Nothing, return ()) ---------------------------------------------------------------- -- | Creating 'MutableFdCache' and executing the action in the second -- argument. The first argument is a cache duration in second. withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a #ifdef WINDOWS withFdCache _ action = action getFdNothing #else withFdCache 0 action = action getFdNothing withFdCache duration action = bracket (initialize duration) terminate (action . getFd) ---------------------------------------------------------------- data Status = Active | Inactive newtype MutableStatus = MutableStatus (IORef Status) status :: MutableStatus -> IO Status status (MutableStatus ref) = readIORef ref newActiveStatus :: IO MutableStatus newActiveStatus = MutableStatus <$> newIORef Active refresh :: MutableStatus -> Refresh refresh (MutableStatus ref) = writeIORef ref Active inactive :: MutableStatus -> IO () inactive (MutableStatus ref) = writeIORef ref Inactive ---------------------------------------------------------------- data FdEntry = FdEntry !Fd !MutableStatus openFile :: FilePath -> IO Fd openFile path = do #if MIN_VERSION_unix(2,8,0) fd <- openFd path ReadOnly defaultFileFlags{nonBlock=False} #else fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=False} #endif setFileCloseOnExec fd return fd closeFile :: Fd -> IO () closeFile = closeFd newFdEntry :: FilePath -> IO FdEntry newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus setFileCloseOnExec :: Fd -> IO () setFileCloseOnExec fd = setFdOption fd CloseOnExec True ---------------------------------------------------------------- type FdCache = MultiMap FdEntry -- | Mutable Fd cacher. newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry)) fdCache :: MutableFdCache -> IO FdCache fdCache (MutableFdCache reaper) = reaperRead reaper look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry) look mfc path = MM.lookup path <$> fdCache mfc ---------------------------------------------------------------- -- The first argument is a cache duration in second. initialize :: Int -> IO MutableFdCache initialize duration = MutableFdCache <$> mkReaper settings where settings = defaultReaperSettings { reaperAction = clean , reaperDelay = duration , reaperCons = uncurry insert , reaperNull = isEmpty , reaperEmpty = empty } clean :: FdCache -> IO (FdCache -> FdCache) clean old = do new <- pruneWith old prune return $ merge new where prune (_,FdEntry fd mst) = status mst >>= act where act Active = inactive mst >> return True act Inactive = closeFd fd >> return False ---------------------------------------------------------------- terminate :: MutableFdCache -> IO () terminate (MutableFdCache reaper) = do !t <- reaperStop reaper mapM_ (closeIt . snd) $ toList t where closeIt (FdEntry fd _) = closeFd fd ---------------------------------------------------------------- -- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher. getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh) getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get where get Nothing = do ent@(FdEntry fd mst) <- newFdEntry path reaperAdd reaper (path,ent) return (Just fd, refresh mst) get (Just (FdEntry fd mst)) = do refresh mst return (Just fd, refresh mst) #endif warp-3.3.31/Network/Wai/Handler/Warp/File.hs0000644000000000000000000001564107346545000016624 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.File ( RspFileInfo(..) , conditionalRequest , addContentHeadersForFilePart , H.parseByteRanges ) where import Data.Array ((!)) import qualified Data.ByteString.Char8 as C8 (pack) import Network.HTTP.Date import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H import Network.Wai import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.PackInt -- $setup -- >>> import Test.QuickCheck ---------------------------------------------------------------- data RspFileInfo = WithoutBody H.Status | WithBody H.Status H.ResponseHeaders Integer Integer deriving (Eq,Show) ---------------------------------------------------------------- conditionalRequest :: I.FileInfo -> H.ResponseHeaders -> H.Method -> IndexedHeader -- ^ Response -> IndexedHeader -- ^ Request -> RspFileInfo conditionalRequest finfo hs0 method rspidx reqidx = case condition of nobody@(WithoutBody _) -> nobody WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size !hs = case rspidx ! fromEnum ResLastModified of Just _ -> hs1 Nothing -> (H.hLastModified,date) : hs1 in WithBody s hs off len where !mtime = I.fileInfoTime finfo !size = I.fileInfoSize finfo !date = I.fileInfoDate finfo -- According to RFC 9110: -- "A recipient cache or origin server MUST evaluate the request -- preconditions defined by this specification in the following order: -- - If-Match -- - If-Unmodified-Since -- - If-None-Match -- - If-Modified-Since -- - If-Range -- -- We don't actually implement the If-(None-)Match logic, but -- we also don't want to block middleware or applications from -- using ETags. And sending If-(None-)Match headers in a request -- to a server that doesn't use them is requester's problem. !mcondition = ifunmodified reqidx mtime <|> ifmodified reqidx mtime method <|> ifrange reqidx mtime method size !condition = fromMaybe (unconditional reqidx size) mcondition ---------------------------------------------------------------- ifModifiedSince :: IndexedHeader -> Maybe HTTPDate ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate ifRange :: IndexedHeader -> Maybe HTTPDate ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate ---------------------------------------------------------------- ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo ifmodified reqidx mtime method = do date <- ifModifiedSince reqidx -- According to RFC 9110: -- "A recipient MUST ignore If-Modified-Since if the request -- contains an If-None-Match header field; [...]" guard . isNothing $ reqidx ! fromEnum ReqIfNoneMatch -- "A recipient MUST ignore the If-Modified-Since header field -- if [...] the request method is neither GET nor HEAD." guard $ method == H.methodGet || method == H.methodHead guard $ date == mtime || date > mtime Just $ WithoutBody H.notModified304 ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo ifunmodified reqidx mtime = do date <- ifUnmodifiedSince reqidx -- According to RFC 9110: -- "A recipient MUST ignore If-Unmodified-Since if the request -- contains an If-Match header field; [...]" guard . isNothing $ reqidx ! fromEnum ReqIfMatch guard $ date /= mtime && date < mtime Just $ WithoutBody H.preconditionFailed412 -- TODO: Should technically also strongly match on ETags. ifrange :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo ifrange reqidx mtime method size = do -- According to RFC 9110: -- "When the method is GET and both Range and If-Range are -- present, evaluate the If-Range precondition:" date <- ifRange reqidx rng <- reqidx ! fromEnum ReqRange guard $ method == H.methodGet return $ if date == mtime then parseRange rng size else WithBody H.ok200 [] 0 size unconditional :: IndexedHeader -> Integer -> RspFileInfo unconditional reqidx = case reqidx ! fromEnum ReqRange of Nothing -> WithBody H.ok200 [] 0 Just rng -> parseRange rng ---------------------------------------------------------------- parseRange :: ByteString -> Integer -> RspFileInfo parseRange rng size = case H.parseByteRanges rng of Nothing -> WithoutBody H.requestedRangeNotSatisfiable416 Just [] -> WithoutBody H.requestedRangeNotSatisfiable416 Just (r:_) -> let (!beg, !end) = checkRange r size !len = end - beg + 1 s = if beg == 0 && end == size - 1 then H.ok200 else H.partialContent206 in WithBody s [] beg len checkRange :: H.ByteRange -> Integer -> (Integer, Integer) checkRange (H.ByteRangeFrom beg) size = (beg, size - 1) checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end) checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1) ---------------------------------------------------------------- -- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' -- for the range specified. contentRangeHeader :: Integer -> Integer -> Integer -> H.Header contentRangeHeader beg end total = (H.hContentRange, range) where range = C8.pack -- building with ShowS $ 'b' : 'y': 't' : 'e' : 's' : ' ' : (if beg > end then ('*':) else showInt beg . ('-' :) . showInt end) ( '/' : showInt total "") addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders addContentHeaders hs off len size | len == size = hs' | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size in ctrng:hs' where !lengthBS = packIntegral len !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges,"bytes") : hs -- | -- -- >>> addContentHeadersForFilePart [] (FilePart 2 10 16) -- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")] -- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) -- [("Content-Length","16"),("Accept-Ranges","bytes")] addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders addContentHeadersForFilePart hs part = addContentHeaders hs off len size where off = filePartOffset part len = filePartByteCount part size = filePartFileSize part warp-3.3.31/Network/Wai/Handler/Warp/FileInfoCache.hs0000644000000000000000000000703707346545000020364 0ustar0000000000000000{-# LANGUAGE RecordWildCards, CPP #-} module Network.Wai.Handler.Warp.FileInfoCache ( FileInfo(..) , withFileInfoCache , getInfo -- test purpose only ) where import Control.Reaper import Network.HTTP.Date #if WINDOWS import System.PosixCompat.Files #else import System.Posix.Files #endif import qualified UnliftIO (onException, bracket, throwIO) import Network.Wai.Handler.Warp.HashMap (HashMap) import qualified Network.Wai.Handler.Warp.HashMap as M import Network.Wai.Handler.Warp.Imports ---------------------------------------------------------------- -- | File information. data FileInfo = FileInfo { fileInfoName :: !FilePath , fileInfoSize :: !Integer , fileInfoTime :: HTTPDate -- ^ Modification time , fileInfoDate :: ByteString -- ^ Modification time in the GMT format } deriving (Eq, Show) data Entry = Negative | Positive FileInfo type Cache = HashMap Entry type FileInfoCache = Reaper Cache (FilePath,Entry) ---------------------------------------------------------------- -- | Getting the file information corresponding to the file. getInfo :: FilePath -> IO FileInfo getInfo path = do fs <- getFileStatus path -- file access let regular = not (isDirectory fs) readable = fileMode fs `intersectFileModes` ownerReadMode /= 0 if regular && readable then do let time = epochTimeToHTTPDate $ modificationTime fs date = formatHTTPDate time size = fromIntegral $ fileSize fs info = FileInfo { fileInfoName = path , fileInfoSize = size , fileInfoTime = time , fileInfoDate = date } return info else UnliftIO.throwIO (userError "FileInfoCache:getInfo") getInfoNaive :: FilePath -> IO FileInfo getInfoNaive = getInfo ---------------------------------------------------------------- getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo getAndRegisterInfo reaper@Reaper{..} path = do cache <- reaperRead case M.lookup path cache of Just Negative -> UnliftIO.throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x Nothing -> positive reaper path `UnliftIO.onException` negative reaper path positive :: FileInfoCache -> FilePath -> IO FileInfo positive Reaper{..} path = do info <- getInfo path reaperAdd (path, Positive info) return info negative :: FileInfoCache -> FilePath -> IO FileInfo negative Reaper{..} path = do reaperAdd (path, Negative) UnliftIO.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 getInfoNaive withFileInfoCache duration action = UnliftIO.bracket (initialize duration) terminate (action . getAndRegisterInfo) initialize :: Int -> IO FileInfoCache initialize duration = mkReaper settings where settings = defaultReaperSettings { reaperAction = override , reaperDelay = duration , reaperCons = \(path,v) -> M.insert path v , reaperNull = M.isEmpty , reaperEmpty = M.empty } override :: Cache -> IO (Cache -> Cache) override _ = return $ const M.empty terminate :: FileInfoCache -> IO () terminate x = void $ reaperStop x warp-3.3.31/Network/Wai/Handler/Warp/HTTP1.hs0000644000000000000000000002262607346545000016606 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.HTTP1 ( http1 ) where import "iproute" Data.IP (toHostAddress, toHostAddress6) import qualified Control.Concurrent as Conc (yield) import qualified UnliftIO import UnliftIO (SomeException, fromException, throwIO) import qualified Data.ByteString as BS import Data.Char (chr) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Network.Socket (SockAddr(SockAddrInet, SockAddrInet6)) import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import qualified System.TimeManager as T 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 (== 0x0d) seg -- 0x0d == CR maybeAddr = case BS.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 (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 True `UnliftIO.catchAny` 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 () | 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 `UnliftIO.catchAny` \e -> do settingsOnException settings (Just req) e -- Don't throw the error again to prevent calling settingsOnException twice. return False -- 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 False to http1 (which -- in turn passes in False 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 when keepAlive $ loop False processRequest :: Settings -> InternalInfo -> Connection -> Application -> T.Handle -> IORef Bool -> Source -> Request -> Maybe (IORef Int) -> IndexedHeader -> IO ByteString -> IO Bool 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 <- UnliftIO.tryAny $ 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' | 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 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 else return False 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 warp-3.3.31/Network/Wai/Handler/Warp/HTTP2.hs0000644000000000000000000001330207346545000016576 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.HTTP2 ( http2 , http2server ) where import qualified Data.ByteString as BS import Data.IORef (IORef, newIORef, writeIORef, readIORef) import qualified Data.IORef as I 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 qualified UnliftIO import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.HTTP2.PushPromise import Network.Wai.Handler.Warp.HTTP2.Request import Network.Wai.Handler.Warp.HTTP2.Response import Network.Wai.Handler.Warp.Imports import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- http2 :: S.Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> ByteString -> IO () http2 settings ii conn transport app peersa th bs = do istatus <- newIORef False 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 istatus (S.settingsSlowlorisSize settings) rawRecvN sendBS x = connSendAll conn x >> T.tickle th conf = H2.Config { confWriteBuffer = bufBuffer writeBuffer , confBufferSize = bufSize writeBuffer , confSendAll = sendBS , confReadN = recvN , confPositionReadMaker = pReadMaker ii , confTimeoutManager = timeoutManager ii #if MIN_VERSION_http2(4,2,0) , confMySockAddr = connMySockAddr conn , confPeerSockAddr = peersa #endif } checkTLS setConnHTTP2 conn True H2.run H2.defaultServerConfig conf $ http2server settings ii transport peersa app where checkTLS = case transport of TCP -> return () -- direct tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS" tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3 -- | Converting WAI application to the server type of http2 library. -- -- Since 3.3.11 http2server :: S.Settings -> InternalInfo -> Transport -> SockAddr -> Application -> H2.Server http2server settings ii transport addr app h2req0 aux0 response = do req <- toWAIRequest h2req0 aux0 ref <- I.newIORef Nothing eResponseReceived <- UnliftIO.tryAny $ 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 -> 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 -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString) wrappedRecvN th istatus slowlorisSize readN bufsize = do bs <- UnliftIO.handleAny handler $ readN bufsize unless (BS.null bs) $ do writeIORef istatus True -- 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 >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th return bs where handler :: UnliftIO.SomeException -> IO ByteString handler _ = return "" -- connClose must not be called here since Run:fork calls it goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO () goaway Connection{..} etype debugmsg = connSendAll bytestream where einfo = H2.encodeInfo id 0 frame = H2.GoAwayFrame 0 etype debugmsg bytestream = H2.encodeFrame einfo frame warp-3.3.31/Network/Wai/Handler/Warp/HTTP2/0000755000000000000000000000000007346545000016243 5ustar0000000000000000warp-3.3.31/Network/Wai/Handler/Warp/HTTP2/File.hs0000644000000000000000000000161207346545000017456 0ustar0000000000000000{-# 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 warp-3.3.31/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs0000644000000000000000000000242007346545000021053 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.HTTP2.PushPromise where import qualified UnliftIO 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 = case mh2data of Nothing -> [] Just h2data -> http2dataPushPromise h2data catMaybes <$> mapM (fromPushPromise ii) pp fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise) fromPushPromise ii (PushPromise path file rsphdr w) = do efinfo <- UnliftIO.tryIO $ getFileInfo ii file case efinfo of Left (_ex :: UnliftIO.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 warp-3.3.31/Network/Wai/Handler/Warp/HTTP2/Request.hs0000644000000000000000000001215407346545000020232 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.HTTP2.Request ( toRequest , getHTTP2Data , setHTTP2Data , modifyHTTP2Data ) where import Control.Arrow (first) import qualified Data.ByteString.Char8 as C8 import Data.IORef import qualified Data.Vault.Lazy as Vault import Network.HPACK import Network.HPACK.Token import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Internal (Request(..)) import System.IO.Unsafe (unsafePerformIO) import qualified System.TimeManager as T import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey) #ifdef MIN_VERSION_crypton_x509 import Network.Wai.Handler.Warp.Request (getClientCertificateKey) #endif import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import Network.Wai.Handler.Warp.Types type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> Transport -> IO Request ---------------------------------------------------------------- http30 :: H.HttpVersion http30 = H.HttpVersion 3 0 toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq toRequest ii settings addr ht bodylen body th transport = do ref <- newIORef Nothing toRequest' ii settings addr ref ht bodylen body th transport toRequest' :: InternalInfo -> S.Settings -> SockAddr -> IORef (Maybe HTTP2Data) -> ToReq toRequest' ii settings addr ref (reqths,reqvt) bodylen body th transport = return req where !req = Request { 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 , requestBody = body , vault = vaultValue , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen , requestHeaderHost = mHost <|> mAuth , requestHeaderRange = mRange , requestHeaderReferer = mReferer , requestHeaderUserAgent = mUserAgent } headers = map (first tokenKey) ths where ths = case mHost of Just _ -> reqths Nothing -> case mAuth of Just auth -> (tokenHost, auth) : reqths _ -> reqths !mPath = getHeaderValue tokenPath reqvt -- SHOULD !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD !mHost = getHeaderValue tokenHost reqvt !mRange = getHeaderValue tokenRange reqvt !mReferer = getHeaderValue tokenReferer reqvt !mUserAgent = getHeaderValue tokenUserAgent reqvt -- CONNECT request will have ":path" omitted, use ":authority" as unparsed -- path instead so that it will have consistent behavior compare to HTTP 1.0 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth) !path = H.extractPath unparsedPath !rawPath = if S.settingsNoParsePath settings then unparsedPath else path -- fixme: pauseTimeout. th is not available here. !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii) $ Vault.insert getHTTP2DataKey (readIORef ref) $ Vault.insert setHTTP2DataKey (writeIORef ref) $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref) $ Vault.insert pauseTimeoutKey (T.pause th) #ifdef MIN_VERSION_crypton_x509 $ Vault.insert getClientCertificateKey (getTransportClientCertificate transport) #endif Vault.empty getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data)) getHTTP2DataKey = unsafePerformIO Vault.newKey {-# NOINLINE getHTTP2DataKey #-} -- | Getting 'HTTP2Data' through vault of the request. -- Warp uses this to receive 'HTTP2Data' from 'Middleware'. -- -- Since: 3.2.7 getHTTP2Data :: Request -> IO (Maybe HTTP2Data) getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of Nothing -> return Nothing Just getter -> getter setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ()) setHTTP2DataKey = unsafePerformIO Vault.newKey {-# NOINLINE setHTTP2DataKey #-} -- | Setting 'HTTP2Data' through vault of the request. -- 'Application' or 'Middleware' should use this. -- -- Since: 3.2.7 setHTTP2Data :: Request -> Maybe HTTP2Data -> IO () setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of Nothing -> return () Just setter -> setter mh2d modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()) modifyHTTP2DataKey = unsafePerformIO Vault.newKey {-# NOINLINE modifyHTTP2DataKey #-} -- | Modifying 'HTTP2Data' through vault of the request. -- 'Application' or 'Middleware' should use this. -- -- Since: 3.2.8 modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO () modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of Nothing -> return () Just modify -> modify func warp-3.3.31/Network/Wai/Handler/Warp/HTTP2/Response.hs0000644000000000000000000001245507346545000020404 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.HTTP2.Response ( fromResponse ) where 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 (responseFile, responseBuilder, responseStream) import Network.Wai.Internal (Response(..)) import qualified UnliftIO import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data) import Network.Wai.Handler.Warp.HTTP2.Types 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 <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of Left (_ex :: UnliftIO.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 warp-3.3.31/Network/Wai/Handler/Warp/HTTP2/Types.hs0000644000000000000000000000430107346545000017701 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.HTTP2.Types where import qualified Data.ByteString as BS import qualified Network.HTTP.Types as H import Network.HTTP2.Frame import qualified Network.HTTP2.Server as H2 import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- isHTTP2 :: Transport -> Bool isHTTP2 TCP = False isHTTP2 tls = useHTTP2 where useHTTP2 = case tlsNegotiatedProtocol tls of Nothing -> False Just proto -> "h2" `BS.isPrefixOf` proto ---------------------------------------------------------------- -- | HTTP/2 specific data. -- -- Since: 3.2.7 data HTTP2Data = HTTP2Data { -- | Accessor for 'PushPromise' in 'HTTP2Data'. -- -- Since: 3.2.7 http2dataPushPromise :: [PushPromise] -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'. -- -- Since: 3.2.8 but the type changed in 3.3.0 , http2dataTrailers :: H2.TrailersMaker } -- | Default HTTP/2 specific data. -- -- Since: 3.2.7 defaultHTTP2Data :: HTTP2Data defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker -- | HTTP/2 push promise or sever push. -- This allows files only for backward-compatibility -- while the HTTP/2 library supports other types. -- -- Since: 3.2.7 data PushPromise = PushPromise { -- | Accessor for a URL path in 'PushPromise'. -- E.g. \"\/style\/default.css\". -- -- Since: 3.2.7 promisedPath :: ByteString -- | Accessor for 'FilePath' in 'PushPromise'. -- E.g. \"FILE_PATH/default.css\". -- -- Since: 3.2.7 , promisedFile :: FilePath -- | Accessor for 'H.ResponseHeaders' in 'PushPromise' -- \"content-type\" must be specified. -- Default value: []. -- -- -- Since: 3.2.7 , promisedResponseHeaders :: H.ResponseHeaders -- | Accessor for 'Weight' in 'PushPromise'. -- Default value: 16. -- -- Since: 3.2.7 , promisedWeight :: Weight } deriving (Eq,Ord,Show) -- | Default push promise. -- -- Since: 3.2.7 defaultPushPromise :: PushPromise defaultPushPromise = PushPromise "" "" [] 16 warp-3.3.31/Network/Wai/Handler/Warp/HashMap.hs0000644000000000000000000000221507346545000017257 0ustar0000000000000000module 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 pathwarp-3.3.31/Network/Wai/Handler/Warp/Header.hs0000644000000000000000000000751507346545000017136 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.Wai.Handler.Warp.Header where import Data.Array import Data.Array.ST import qualified Data.ByteString as BS import Data.CaseInsensitive (foldedCase) import Network.HTTP.Types import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -- | Array for a set of HTTP headers. type IndexedHeader = Array Int (Maybe HeaderValue) ---------------------------------------------------------------- indexRequestHeader :: RequestHeaders -> IndexedHeader indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex data RequestHeaderIndex = ReqContentLength | ReqTransferEncoding | ReqExpect | ReqConnection | ReqRange | ReqHost | ReqIfModifiedSince | ReqIfUnmodifiedSince | ReqIfRange | ReqReferer | ReqUserAgent | ReqIfMatch | ReqIfNoneMatch deriving (Enum,Bounded) -- | The size for 'IndexedHeader' for HTTP Request. -- From 0 to this corresponds to: -- -- - \"Content-Length\" -- - \"Transfer-Encoding\" -- - \"Expect\" -- - \"Connection\" -- - \"Range\" -- - \"Host\" -- - \"If-Modified-Since\" -- - \"If-Unmodified-Since\" -- - \"If-Range\" -- - \"Referer\" -- - \"User-Agent\" -- - \"If-Match\" -- - \"If-None-Match\" requestMaxIndex :: Int requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex) requestKeyIndex :: HeaderName -> Int requestKeyIndex hn = case BS.length bs of 4 | bs == "host" -> fromEnum ReqHost 5 | bs == "range" -> fromEnum ReqRange 6 | bs == "expect" -> fromEnum ReqExpect 7 | bs == "referer" -> fromEnum ReqReferer 8 | bs == "if-range" -> fromEnum ReqIfRange | bs == "if-match" -> fromEnum ReqIfMatch 10 | bs == "user-agent" -> fromEnum ReqUserAgent | bs == "connection" -> fromEnum ReqConnection 13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch 14 | bs == "content-length" -> fromEnum ReqContentLength 17 | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince 19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince _ -> -1 where bs = foldedCase hn defaultIndexRequestHeader :: IndexedHeader defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0..requestMaxIndex]] ---------------------------------------------------------------- indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex data ResponseHeaderIndex = ResContentLength | ResServer | ResDate | ResLastModified deriving (Enum,Bounded) -- | The size for 'IndexedHeader' for HTTP Response. responseMaxIndex :: Int responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex) responseKeyIndex :: HeaderName -> Int responseKeyIndex hn = case BS.length bs of 4 | bs == "date" -> fromEnum ResDate 6 | bs == "server" -> fromEnum ResServer 13 | bs == "last-modified" -> fromEnum ResLastModified 14 | bs == "content-length" -> fromEnum ResContentLength _ -> -1 where bs = foldedCase hn ---------------------------------------------------------------- traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader traverseHeader hdr maxidx getIndex = runSTArray $ do arr <- newArray (0,maxidx) Nothing mapM_ (insert arr) hdr return arr where insert arr (key,val) | idx == -1 = return () | otherwise = writeArray arr idx (Just val) where idx = getIndex key warp-3.3.31/Network/Wai/Handler/Warp/IO.hs0000644000000000000000000000411607346545000016247 0ustar0000000000000000module Network.Wai.Handler.Warp.IO where import Control.Exception (mask_) import Data.ByteString.Builder (Builder) import Data.ByteString.Builder.Extra (Next (Chunk, Done, More), runBuilder) import Data.IORef (IORef, readIORef, writeIORef) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types toBufIOWith :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer toBufIOWith maxRspBufSize writeBufferRef io builder = do writeBuffer <- readIORef writeBufferRef loop writeBuffer firstWriter 0 where firstWriter = runBuilder builder loop writeBuffer writer bytesSent = do let buf = bufBuffer writeBuffer size = bufSize writeBuffer (len, signal) <- writer buf size bufferIO buf len io let totalBytesSent = toInteger len + bytesSent case signal of Done -> return totalBytesSent More minSize next | size < minSize -> do when (minSize > maxRspBufSize) $ error $ "Sending a Builder response required a buffer of size " ++ show minSize ++ " which is bigger than the specified maximum of " ++ show maxRspBufSize ++ "!" -- The current WriteBuffer is too small to fit the next -- batch of bytes from the Builder so we free it and -- create a new bigger one. Freeing the current buffer, -- creating a new one and writing it to the IORef need -- to be performed atomically to prevent both double -- frees and missed frees. So we mask async exceptions: biggerWriteBuffer <- mask_ $ do bufFree writeBuffer biggerWriteBuffer <- createWriteBuffer minSize writeIORef writeBufferRef biggerWriteBuffer return biggerWriteBuffer loop biggerWriteBuffer next totalBytesSent | otherwise -> loop writeBuffer next totalBytesSent Chunk bs next -> do io bs loop writeBuffer next totalBytesSent warp-3.3.31/Network/Wai/Handler/Warp/Imports.hs0000644000000000000000000000104307346545000017371 0ustar0000000000000000module 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 ) where import Control.Applicative 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 warp-3.3.31/Network/Wai/Handler/Warp/Internal.hs0000644000000000000000000000501507346545000017513 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Internal ( -- * Settings Settings (..) , ProxyProtocol(..) -- * Low level run functions , runSettingsConnection , runSettingsConnectionMaker , runSettingsConnectionMakerSecure , Transport (..) -- * Connection , Connection (..) , socketConnection -- ** Receive , Recv , RecvBuf -- ** Buffer , Buffer , BufSize , WriteBuffer(..) , createWriteBuffer , allocateBuffer , freeBuffer , copy -- ** Sendfile , FileId (..) , SendFile , sendFile , readSendFile -- * Version , warpVersion -- * Data types , InternalInfo (..) , HeaderValue , IndexedHeader , requestMaxIndex -- * Time out manager -- | -- -- In order to provide slowloris protection, Warp provides timeout handlers. We -- follow these rules: -- -- * A timeout is created when a connection is opened. -- -- * When all request headers are read, the timeout is tickled. -- -- * Every time at least the slowloris size settings number of bytes of the request -- body are read, the timeout is tickled. -- -- * The timeout is paused while executing user code. This will apply to both -- the application itself, and a ResponseSource response. The timeout is -- resumed as soon as we return from user code. -- -- * Every time data is successfully sent to the client, the timeout is tickled. , module System.TimeManager -- * File descriptor cache , module Network.Wai.Handler.Warp.FdCache -- * File information cache , module Network.Wai.Handler.Warp.FileInfoCache -- * Date , module Network.Wai.Handler.Warp.Date -- * Request and response , Source , recvRequest , sendResponse -- * Platform dependent helper functions , setSocketCloseOnExec , windowsThreadBlockHack -- * Misc , http2server , withII , pReadMaker ) where import Network.Socket.BufferPool import System.TimeManager import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2 import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types import Network.Wai.Handler.Warp.Windows warp-3.3.31/Network/Wai/Handler/Warp/MultiMap.hs0000644000000000000000000000515207346545000017471 0ustar0000000000000000module Network.Wai.Handler.Warp.MultiMap ( MultiMap , isEmpty , empty , singleton , insert , Network.Wai.Handler.Warp.MultiMap.lookup , pruneWith , toList , merge ) where import Control.Monad (filterM) import Data.Hashable (hash) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I import Data.Semigroup import Prelude -- Silence redundant import warnings ---------------------------------------------------------------- -- | 'MultiMap' is used as a cache of file descriptors. -- Since multiple threads could open file descriptors for -- the same file simultaneously, there could be multiple entries -- for one file. -- Since hash values of file paths are used as outer keys, -- collison would happen for multiple file paths. -- Because only positive entries are stored, -- Malicious attack cannot cause the inner list to blow up. -- So, lists are good enough. newtype MultiMap v = MultiMap (IntMap [(FilePath,v)]) ---------------------------------------------------------------- -- | O(1) empty :: MultiMap v empty = MultiMap I.empty -- | O(1) isEmpty :: MultiMap v -> Bool isEmpty (MultiMap mm) = I.null mm ---------------------------------------------------------------- -- | O(1) singleton :: FilePath -> v -> MultiMap v singleton path v = MultiMap $ I.singleton (hash path) [(path,v)] ---------------------------------------------------------------- -- | O(M) where M is the number of entries per file lookup :: FilePath -> MultiMap v -> Maybe v lookup path (MultiMap mm) = case I.lookup (hash path) mm of Nothing -> Nothing Just s -> Prelude.lookup path s ---------------------------------------------------------------- -- | O(log n) insert :: FilePath -> v -> MultiMap v -> MultiMap v insert path v (MultiMap mm) = MultiMap $ I.insertWith (<>) (hash path) [(path,v)] mm ---------------------------------------------------------------- -- | O(n) toList :: MultiMap v -> [(FilePath,v)] toList (MultiMap mm) = concatMap snd $ I.toAscList mm ---------------------------------------------------------------- -- | O(n) pruneWith :: MultiMap v -> ((FilePath,v) -> IO Bool) -> IO (MultiMap v) pruneWith (MultiMap mm) action = I.foldrWithKey go (pure . MultiMap) mm I.empty where go h s cont acc = do rs <- filterM action s case rs of [] -> cont acc _ -> cont $! I.insert h rs acc ---------------------------------------------------------------- -- O(n + m) where N is the size of the second argument merge :: MultiMap v -> MultiMap v -> MultiMap v merge (MultiMap m1) (MultiMap m2) = MultiMap $ I.unionWith (<>) m1 m2 warp-3.3.31/Network/Wai/Handler/Warp/PackInt.hs0000644000000000000000000000307707346545000017276 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Network.Wai.Handler.Warp.PackInt where import Data.ByteString.Internal (unsafeCreate) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke) import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Imports -- $setup -- >>> import Data.ByteString.Char8 as C8 -- >>> import Test.QuickCheck (Large(..)) -- | -- -- prop> packIntegral (abs n) == C8.pack (show (abs n)) -- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == C8.pack (show n') 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 (48 + 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 = 48 + fromIntegral n !s = fromIntegral $ H.statusCode status (!q0,!r0) = s `divMod` 10 (!q1,!r1) = q0 `divMod` 10 !r2 = q1 `mod` 10 warp-3.3.31/Network/Wai/Handler/Warp/ReadInt.hs0000644000000000000000000000200507346545000017261 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} -- Copyright : Erik de Castro Lopo -- License : BSD3 module Network.Wai.Handler.Warp.ReadInt ( readInt , readInt64 ) where import qualified Data.ByteString as S import Network.Wai.Handler.Warp.Imports hiding (readInt) {-# INLINE readInt #-} readInt :: Integral a => ByteString -> a readInt bs = fromIntegral $ readInt64 bs -- This function is used to parse the Content-Length field of HTTP headers and -- is a performance hot spot. It should only be replaced with something -- significantly and provably faster. -- -- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we -- use Int64 here and then make a generic 'readInt' that allows conversion to -- Int and Integer. {-# NOINLINE readInt64 #-} readInt64 :: ByteString -> Int64 readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (c - 48)) 0 $ S.takeWhile isDigit bs isDigit :: Word8 -> Bool isDigit w = w >= 48 && w <= 57 warp-3.3.31/Network/Wai/Handler/Warp/Request.hs0000644000000000000000000003104507346545000017371 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Request ( recvRequest , headerLines , pauseTimeoutKey , getFileInfoKey #ifdef MIN_VERSION_crypton_x509 , getClientCertificateKey #endif , NoKeepAliveRequest (..) ) where import qualified Control.Concurrent as Conc (yield) import UnliftIO (throwIO, Exception) import Data.Array ((!)) 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 Data.Typeable (Typeable) import qualified Data.Vault.Lazy as Vault #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif 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 Prelude hiding (lines) import System.IO.Unsafe (unsafePerformIO) import qualified System.TimeManager as Timeout 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, settingsMaxTotalHeaderLength) ---------------------------------------------------------------- -- | Receiving a HTTP request from 'Connection' and parsing its header -- to create 'Request'. recvRequest :: Bool -- ^ first request on this connection? -> 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 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 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te -- 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 = 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) ---------------------------------------------------------------- headerLines :: Int -> Bool -> Source -> IO [ByteString] headerLines maxTotalHeaderLength firstRequest src = do bs <- readSource src if S.null bs -- 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. then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest else push maxTotalHeaderLength src (THStatus 0 0 id id) bs data NoKeepAliveRequest = NoKeepAliveRequest deriving (Show, Typeable) instance Exception NoKeepAliveRequest ---------------------------------------------------------------- handleExpect :: Connection -> H.HttpVersion -> Maybe HeaderValue -> IO () handleExpect conn ver (Just "100-continue") = do connSendAll conn continue Conc.yield where continue | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n" | otherwise = "HTTP/1.0 100 Continue\r\n\r\n" handleExpect _ _ _ = return () ---------------------------------------------------------------- bodyAndSource :: Source -> 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) where len = toLength cl bodyLen = KnownLength $ fromIntegral len chunked = isChunked te toLength :: Maybe HeaderValue -> Int toLength Nothing = 0 toLength (Just bs) = readInt bs isChunked :: Maybe HeaderValue -> Bool isChunked (Just bs) = CI.foldCase bs == "chunked" isChunked _ = False ---------------------------------------------------------------- timeoutBody :: Maybe (I.IORef Int) -- ^ remaining -> Timeout.Handle -> IO ByteString -> IO () -> IO (IO ByteString) timeoutBody remainingRef timeoutHandle rbody handle100Continue = do isFirstRef <- I.newIORef True let checkEmpty = case remainingRef of Nothing -> return . S.null Just ref -> \bs -> if S.null bs then return True else do x <- I.readIORef ref return $! x <= 0 return $ do isFirst <- I.readIORef isFirstRef when isFirst $ do -- Only check if we need to produce the 100 Continue status -- when asking for the first chunk of the body handle100Continue -- Timeout handling was paused after receiving the full request -- headers. Now we need to resume it to avoid a slowloris -- attack during request body sending. Timeout.resume timeoutHandle I.writeIORef isFirstRef False bs <- rbody -- As soon as we finish receiving the request body, whether -- because the application is not interested in more bytes, or -- because there is no more data available, pause the timeout -- handler again. isEmpty <- checkEmpty bs when isEmpty (Timeout.pause timeoutHandle) return bs ---------------------------------------------------------------- type BSEndo = ByteString -> ByteString type BSEndoList = [ByteString] -> [ByteString] data THStatus = THStatus !Int -- running total byte count (excluding current header chunk) !Int -- current header chunk byte count BSEndoList -- previously parsed lines BSEndo -- bytestrings to be prepended ---------------------------------------------------------------- {- FIXME close :: Sink ByteString IO a close = throwIO IncompleteHeaders -} push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString] push maxTotalHeaderLength src (THStatus totalLen chunkLen lines prepend) bs' -- Too many bytes | currentTotal > maxTotalHeaderLength = throwIO OverLargeHeader | otherwise = push' mNL where currentTotal = totalLen + chunkLen -- bs: current header chunk, plus maybe (parts of) next header bs = prepend bs' bsLen = S.length bs -- Maybe newline -- Returns: Maybe -- ( length of this chunk up to newline -- , position of newline in relation to entire current header -- , is this part of a multiline header -- ) mNL = do -- 10 is the code point for newline (\n) chunkNL <- S.elemIndex 10 bs' let headerNL = chunkNL + S.length (prepend "") chunkNLlen = chunkNL + 1 -- check if there are two more bytes in the bs -- if so, see if the second of those is a horizontal space if bsLen > headerNL + 1 then let c = S.index bs (headerNL + 1) b = case headerNL of 0 -> True 1 -> S.index bs 0 == 13 _ -> False isMultiline = not b && (c == 32 || c == 9) in Just (chunkNLlen, headerNL, isMultiline) else Just (chunkNLlen, headerNL, False) {-# INLINE push' #-} push' :: Maybe (Int, 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 maxTotalHeaderLength src status bst where prepend' = S.append bs thisChunkLen = S.length bs' newChunkLen = chunkLen + thisChunkLen status = THStatus totalLen newChunkLen lines prepend' -- Found a newline, but next line continues as a multiline header push' (Just (chunkNLlen, end, True)) = push maxTotalHeaderLength src status rest where rest = S.drop (end + 1) bs prepend' = S.append (SU.unsafeTake (checkCR bs end) bs) -- If we'd just update the entire current chunk up to newline -- we wouldn't count all the dropped newlines in between. -- So update 'chunkLen' with current chunk up to newline -- and use 'chunkLen' later on to add to 'totalLen'. newChunkLen = chunkLen + chunkNLlen status = THStatus totalLen newChunkLen lines prepend' -- Found a newline at position end. push' (Just (chunkNLlen, end, False)) -- leftover | S.null line = do when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs) return (lines []) -- more headers | otherwise = let lines' = lines . (line:) newTotalLength = totalLen + chunkLen + chunkNLlen status = THStatus newTotalLength 0 lines' id in if start < bsLen then -- more bytes in this chunk, push again let bs'' = SU.unsafeDrop start bs in push maxTotalHeaderLength src status bs'' else do -- no more bytes in this chunk, ask for more bst <- readSource' src when (S.null bs) $ throwIO IncompleteHeaders push maxTotalHeaderLength src status bst where start = end + 1 -- start of next chunk line = SU.unsafeTake (checkCR bs end) bs {-# INLINE checkCR #-} checkCR :: ByteString -> Int -> Int checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR (\r) where !p = pos - 1 pauseTimeoutKey :: Vault.Key (IO ()) pauseTimeoutKey = unsafePerformIO Vault.newKey {-# NOINLINE pauseTimeoutKey #-} getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo) getFileInfoKey = unsafePerformIO Vault.newKey {-# NOINLINE getFileInfoKey #-} #ifdef MIN_VERSION_crypton_x509 getClientCertificateKey :: Vault.Key (Maybe CertificateChain) getClientCertificateKey = unsafePerformIO Vault.newKey {-# NOINLINE getClientCertificateKey #-} #endif warp-3.3.31/Network/Wai/Handler/Warp/RequestHeader.hs0000644000000000000000000001074007346545000020501 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.RequestHeader ( parseHeaderLines ) where import UnliftIO (throwIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 (unpack) import Data.ByteString.Internal (memchr) import qualified Data.CaseInsensitive as CI import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr) import Foreign.Storable (peek) import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types -- $setup -- >>> :set -XOverloadedStrings ---------------------------------------------------------------- parseHeaderLines :: [ByteString] -> IO (H.Method ,ByteString -- Path ,ByteString -- Path, parsed ,ByteString -- Query ,H.HttpVersion ,H.RequestHeaders ) parseHeaderLines [] = throwIO $ NotEnoughLines [] parseHeaderLines (firstLine:otherLines) = do (method, path', query, httpversion) <- parseRequestLine firstLine let path = H.extractPath path' hdr = map parseHeader otherLines return (method, path', path, query, httpversion, hdr) ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine "GET " -- *** Exception: Warp: Invalid first line of request: "GET " -- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: Warp: Request line specified a non-HTTP request -- >>> parseRequestLine "PRI * HTTP/2.0" -- ("PRI","*","",HTTP/2.0) parseRequestLine :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len pathptr0 <- memchr methodptr 32 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 -- ' ' when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1 lim2 = fromIntegral (httpptr0 `minusPtr` pathptr) checkHTTP httpptr !hv <- httpVersion httpptr queryptr <- memchr pathptr 63 lim2 -- '?' let !method = bs ptr methodptr pathptr0 !path | queryptr == nullPtr = bs ptr pathptr httpptr0 | otherwise = bs ptr pathptr queryptr !query | queryptr == nullPtr = S.empty | otherwise = bs ptr queryptr httpptr0 return (method,path,query,hv) where baderr = BadFirstLine $ C8.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO () check p n w = do w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do check httpptr 0 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 -- '.' 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 return version bs ptr p0 p1 = PS fptr o l where o = p0 `minusPtr` ptr l = p1 `minusPtr` p0 ---------------------------------------------------------------- -- | -- -- >>> parseHeader "Content-Length:47" -- ("Content-Length","47") -- >>> parseHeader "Accept-Ranges: bytes" -- ("Accept-Ranges","bytes") -- >>> parseHeader "Host: example.com:8080" -- ("Host","example.com:8080") -- >>> parseHeader "NoSemiColon" -- ("NoSemiColon","") parseHeader :: ByteString -> H.Header parseHeader s = let (k, rest) = S.break (== 58) s -- ':' rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest in (CI.mk k, rest') warp-3.3.31/Network/Wai/Handler/Warp/Response.hs0000644000000000000000000004232307346545000017540 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.Response ( sendResponse , sanitizeHeaderValue -- for testing , warpVersion , hasBody , replaceHeader , addServer -- testing , addAltSvc ) where import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator) import qualified UnliftIO import Data.Array ((!)) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString, Builder) import Data.ByteString.Builder.Extra (flush) import qualified Data.ByteString.Char8 as C8 import qualified Data.CaseInsensitive as CI import Data.Function (on) import Data.List (deleteBy) import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy) import Data.Version (showVersion) import Data.Word8 (_cr, _lf) import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H import Network.Wai import Network.Wai.Internal import qualified Paths_warp import qualified System.TimeManager as T import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.IO (toBufIOWith) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.ResponseHeader import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types -- $setup -- >>> :set -XOverloadedStrings ---------------------------------------------------------------- -- | Sending a HTTP response to 'Connection' according to 'Response'. -- -- Applications/middlewares MUST provide a proper 'H.ResponseHeaders'. -- so that inconsistency does not happen. -- No header is deleted by this function. -- -- Especially, Applications/middlewares MUST provide a proper -- Content-Type. They MUST NOT provide -- Content-Length, Content-Range, and Transfer-Encoding -- because they are inserted, when necessary, -- regardless they already exist. -- This function does not insert Content-Encoding. It's middleware's -- responsibility. -- -- The Date and Server header is added if not exist -- in HTTP response header. -- -- There are three basic APIs to create 'Response': -- -- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response'] -- HTTP response body is created from 'Builder'. -- Transfer-Encoding: chunked is used in HTTP/1.1. -- -- ['responseStream' :: 'H.Status' -> 'H.ResponseHeaders' -> 'StreamingBody' -> 'Response'] -- HTTP response body is created from 'Builder'. -- Transfer-Encoding: chunked is used in HTTP/1.1. -- -- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response'] -- No header is added and no Transfer-Encoding: is applied. -- -- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response'] -- HTTP response body is sent (by sendfile(), if possible) for GET method. -- HTTP response body is not sent by HEAD method. -- Content-Length and Content-Range are automatically -- added into the HTTP response header if necessary. -- If Content-Length and Content-Range exist in the HTTP response header, -- they would cause inconsistency. -- \"Accept-Ranges: bytes\" is also inserted. -- -- Applications are categorized into simple and sophisticated. -- Sophisticated applications should specify 'Just' to -- 'Maybe' 'FilePart'. They should treat the conditional request -- by themselves. A proper 'Status' (200 or 206) must be provided. -- -- Simple applications should specify 'Nothing' to -- 'Maybe' 'FilePart'. The size of the specified file is obtained -- by disk access or from the file info cache. -- If-Modified-Since, If-Unmodified-Since, If-Range and Range -- are processed. Since a proper status is chosen, 'Status' is -- ignored. Last-Modified is inserted. sendResponse :: Settings -> Connection -> InternalInfo -> T.Handle -> Request -- ^ HTTP request. -> 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 hs <- 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 T.tickle th return ret else do _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody logger req s Nothing T.tickle th return isPersist where defServer = settingsServerName settings logger = settingsLogger settings maxRspBufSize = settingsMaxBuilderResponseBufferSize settings ver = httpVersion req s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0 getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr (isPersist,isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked) method = requestMethod req isHead = method == H.methodHead rsp = case response of ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th) ResponseBuilder _ _ b | isHead -> RspNoBody | otherwise -> RspBuilder b needsChunked ResponseStream _ _ fb | isHead -> RspNoBody | otherwise -> RspStream fb needsChunked ResponseRaw raw _ -> RspRaw raw src -- Make sure we don't hang on to 'response' (avoid space leak) !ret = case response of ResponseFile {} -> isPersist ResponseBuilder {} -> isKeepAlive ResponseStream {} -> isKeepAlive ResponseRaw {} -> False ---------------------------------------------------------------- sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders sanitizeHeaders = map (sanitize <$>) where sanitize v | containsNewlines v = sanitizeHeaderValue v -- slow path | otherwise = v -- fast path {-# INLINE containsNewlines #-} containsNewlines :: ByteString -> Bool containsNewlines = S.any (\w -> w == _cr || w == _lf) {-# INLINE sanitizeHeaderValue #-} sanitizeHeaderValue :: ByteString -> ByteString sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of [] -> "" x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs) where addSpaceIfMissing line = case C8.uncons line of Nothing -> Nothing Just (first, _) | first == ' ' || first == '\t' -> Just line | otherwise -> Just $ " " <> line ---------------------------------------------------------------- data Rsp = RspNoBody | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ()) | RspBuilder Builder Bool | RspStream StreamingBody Bool | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) ---------------------------------------------------------------- sendRsp :: Connection -> InternalInfo -> T.Handle -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> IndexedHeader -- Response -> Int -- maxBuilderResponseBufferSize -> H.Method -> Rsp -> IO (Maybe H.Status, Maybe Integer) ---------------------------------------------------------------- sendRsp conn _ _ ver s hs _ _ _ RspNoBody = do -- Not adding Content-Length. -- User agents treats it as Content-Length: 0. composeHeader ver s hs >>= connSendAll conn return (Just s, Nothing) ---------------------------------------------------------------- sendRsp conn _ th ver s hs _ maxRspBufSize _ (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy | needsChunked = header <> chunkedTransferEncoding body <> chunkedTransferTerminator | otherwise = header <> body writeBufferRef = connWriteBuffer conn len <- toBufIOWith maxRspBufSize writeBufferRef (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy return (Just s, Just len) ---------------------------------------------------------------- sendRsp conn _ th ver s hs _ _ _ (RspStream streamingBody needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy $ toBuilderBuffer $ connWriteBuffer conn let send builder = do popper <- recv builder let loop = do bs <- popper unless (S.null bs) $ do sendFragment conn th bs loop loop sendChunk | needsChunked = send . chunkedTransferEncoding | otherwise = send send header streamingBody sendChunk (sendChunk flush) when needsChunked $ send chunkedTransferTerminator mbs <- finish maybe (return ()) (sendFragment conn th) mbs return (Just s, Nothing) -- fixme: can we tell the actual sent bytes? ---------------------------------------------------------------- sendRsp conn _ th _ _ _ _ _ _ (RspRaw withApp src) = do withApp recv send return (Nothing, Nothing) where recv = do bs <- src unless (S.null bs) $ T.tickle th return bs send bs = connSendAll conn bs >> T.tickle th ---------------------------------------------------------------- -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value. sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just part) _ isHead hook) = sendRspFile2XX conn ii th ver s0 hs rspidxhdr maxRspBufSize method path beg len isHead hook where beg = filePartOffset part len = filePartByteCount part hs = addContentHeadersForFilePart hs0 part ---------------------------------------------------------------- -- Simple WAI applications. -- Status is ignored sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize method (RspFile path Nothing reqidxhdr isHead hook) = do efinfo <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of Left (_ex :: UnliftIO.IOException) -> #ifdef WARP_DEBUG print _ex >> #endif sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method Right finfo -> case conditionalRequest finfo hs0 method rspidxhdr reqidxhdr of WithoutBody s -> sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize method RspNoBody WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len isHead hook ---------------------------------------------------------------- sendRspFile2XX :: Connection -> InternalInfo -> T.Handle -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> IndexedHeader -> Int -> H.Method -> FilePath -> Integer -> Integer -> Bool -> IO () -> IO (Maybe H.Status, Maybe Integer) sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len isHead hook | isHead = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody | otherwise = do lheader <- composeHeader ver s hs (mfd, fresher) <- getFd ii path let fid = FileId path mfd hook' = hook >> fresher connSendFile conn fid beg len hook' [lheader] return (Just s, Just len) sendRspFile404 :: Connection -> InternalInfo -> T.Handle -> H.HttpVersion -> H.ResponseHeaders -> IndexedHeader -> Int -> H.Method -> IO (Maybe H.Status, Maybe Integer) sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method (RspBuilder body True) where s = H.notFound404 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" ---------------------------------------------------------------- ---------------------------------------------------------------- -- | Use 'connSendAll' to send this data while respecting timeout rules. sendFragment :: Connection -> T.Handle -> ByteString -> IO () sendFragment Connection { connSendAll = send } th bs = do T.resume th send bs T.pause th -- We pause timeouts before passing control back to user code. This ensures -- that a timeout will only ever be executed when Warp is in control. We -- also make sure to resume the timeout after the completion of user code -- so that we can kill idle connections. ---------------------------------------------------------------- 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 where ver = httpVersion req conn = reqidxhdr ! fromEnum ReqConnection checkPersist11 (Just x) | CI.foldCase x == "close" = False checkPersist11 _ = True checkPersist10 (Just x) | CI.foldCase x == "keep-alive" = True checkPersist10 _ = False checkChunk :: Request -> Bool checkChunk req = httpVersion req == H.http11 ---------------------------------------------------------------- -- Used for ResponseBuilder and ResponseSource. -- Don't use this for ResponseFile since this logic does not fit -- for ResponseFile. For instance, isKeepAlive should be True in some cases -- even if the response header does not have Content-Length. -- -- Content-Length is specified by a reverse proxy. -- Note that CGI does not specify Content-Length. infoFromResponse :: IndexedHeader -> (Bool,Bool) -> (Bool,Bool) infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked) where needsChunked = isChunked && not hasLength isKeepAlive = isPersist && (isChunked || hasLength) hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength ---------------------------------------------------------------- hasBody :: H.Status -> Bool hasBody s = sc /= 204 && sc /= 304 && sc >= 200 where sc = H.statusCode s ---------------------------------------------------------------- addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of Nothing -> do gmtdate <- getdate return $ (H.hDate, gmtdate) : hdrs Just _ -> return hdrs ---------------------------------------------------------------- -- | The version of Warp. warpVersion :: String warpVersion = showVersion Paths_warp.version {-# 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 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 ---------------------------------------------------------------- composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder composeHeaderBuilder ver s hs True = byteString <$> composeHeader ver s (addTransferEncoding hs) composeHeaderBuilder ver s hs False = byteString <$> composeHeader ver s hs warp-3.3.31/Network/Wai/Handler/Warp/ResponseHeader.hs0000644000000000000000000000464307346545000020654 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where import qualified Data.ByteString as S import Data.ByteString.Internal (create) import qualified Data.CaseInsensitive as CI import Data.List (foldl') import Foreign.Ptr import GHC.Storable import qualified Network.HTTP.Types as H import Network.Socket.BufferPool (copy) import Network.Wai.Handler.Warp.Imports ---------------------------------------------------------------- composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do ptr1 <- copyStatus ptr httpversion status ptr2 <- copyHeaders ptr1 responseHeaders void $ copyCRLF ptr2 where !len = 17 + slen + foldl' fieldLength 0 responseHeaders fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4 !slen = S.length $ H.statusMessage status httpVer11 :: ByteString httpVer11 = "HTTP/1.1 " httpVer10 :: ByteString httpVer10 = "HTTP/1.0 " {-# INLINE copyStatus #-} copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) copyStatus !ptr !httpversion !status = do ptr1 <- copy ptr httpVer writeWord8OffPtr ptr1 0 (zero + fromIntegral r2) writeWord8OffPtr ptr1 1 (zero + fromIntegral r1) writeWord8OffPtr ptr1 2 (zero + fromIntegral r0) writeWord8OffPtr ptr1 3 spc ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status) copyCRLF ptr2 where httpVer | httpversion == H.HttpVersion 1 1 = httpVer11 | otherwise = httpVer10 (q0,r0) = H.statusCode status `divMod` 10 (q1,r1) = q0 `divMod` 10 r2 = q1 `mod` 10 {-# INLINE copyHeaders #-} copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8) copyHeaders !ptr [] = return ptr copyHeaders !ptr (h:hs) = do ptr1 <- copyHeader ptr h copyHeaders ptr1 hs {-# INLINE copyHeader #-} copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8) copyHeader !ptr (k,v) = do ptr1 <- copy ptr (CI.original k) writeWord8OffPtr ptr1 0 colon writeWord8OffPtr ptr1 1 spc ptr2 <- copy (ptr1 `plusPtr` 2) v copyCRLF ptr2 {-# INLINE copyCRLF #-} copyCRLF :: Ptr Word8 -> IO (Ptr Word8) copyCRLF !ptr = do writeWord8OffPtr ptr 0 cr writeWord8OffPtr ptr 1 lf return $! ptr `plusPtr` 2 zero :: Word8 zero = 48 spc :: Word8 spc = 32 colon :: Word8 colon = 58 cr :: Word8 cr = 13 lf :: Word8 lf = 10 warp-3.3.31/Network/Wai/Handler/Warp/Run.hs0000644000000000000000000003543007346545000016507 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where import Control.Arrow (first) import qualified Control.Exception import Control.Exception (allowInterrupt) import qualified Data.ByteString as S import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno(..), eCONNABORTED) import GHC.IO.Exception (IOException(..), IOErrorType(..)) import Network.Socket (Socket, close, withSocketsDo, SockAddr, setSocketOption, SocketOption(..), getSocketName) #if MIN_VERSION_network(3,1,1) import Network.Socket (gracefulClose) #endif import Network.Socket.BufferPool import qualified Network.Socket.ByteString as Sock import Network.Wai import System.Environment (lookupEnv) import System.IO.Error (ioeGetErrorType) import qualified System.TimeManager as T import System.Timeout (timeout) import qualified UnliftIO import UnliftIO (toException) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Counter import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.HTTP1 (http1) import Network.Wai.Handler.Warp.HTTP2 (http2) import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2) import Network.Wai.Handler.Warp.Imports hiding (readInt) import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types #if WINDOWS import Network.Wai.Handler.Warp.Windows #else import Network.Socket (fdSocket) #endif -- | Creating 'Connection' for plain HTTP based on a given socket. socketConnection :: Settings -> Socket -> IO Connection #if MIN_VERSION_network(3,1,1) socketConnection set s = do #else socketConnection _ s = do #endif bufferPool <- newBufferPool 2048 16384 writeBuffer <- createWriteBuffer 16384 writeBufferRef <- newIORef writeBuffer isH2 <- newIORef False -- HTTP/1.x mysa <- getSocketName s 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 `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () #else , connClose = close s #endif , connRecv = receive' s bufferPool , connRecvBuf = \_ _ -> return True -- obsoleted , connWriteBuffer = writeBufferRef , connHTTP2 = isH2 , connMySockAddr = mysa } where receive' sock pool = UnliftIO.handleIO handler $ receive sock pool where handler :: UnliftIO.IOException -> IO ByteString handler e | ioeGetErrorType e == InvalidArgument = return "" | otherwise = UnliftIO.throwIO e sendfile writeBufferRef fid offset len hook headers = do writeBuffer <- readIORef writeBufferRef sendFile s (bufBuffer writeBuffer) (bufSize writeBuffer) sendall fid offset len hook headers sendall = sendAll' s sendAll' sock bs = UnliftIO.handleJust (\ e -> if ioeGetErrorType e == ResourceVanished then Just ConnectionClosedByPeer else Nothing) UnliftIO.throwIO $ Sock.sendAll sock bs -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO () run p = runSettings defaultSettings { settingsPort = p } -- | Run an 'Application' on the port present in the @PORT@ -- environment variable. Uses the 'Port' given when the variable is unset. -- This calls 'runSettings' with 'defaultSettings'. -- -- Since 3.0.9 runEnv :: Port -> Application -> IO () runEnv p app = do mp <- lookupEnv "PORT" maybe (run p app) runReadPort mp where runReadPort :: String -> IO () runReadPort sp = case reads sp of ((p', _):_) -> run p' app _ -> fail $ "Invalid value in $PORT: " ++ sp -- | Run an 'Application' with the given 'Settings'. -- This opens a listen socket on the port defined in 'Settings' and -- calls 'runSettingsSocket'. runSettings :: Settings -> Application -> IO () runSettings set app = withSocketsDo $ UnliftIO.bracket (bindPortTCP (settingsPort set) (settingsHost set)) close (\socket -> do setSocketCloseOnExec socket runSettingsSocket set socket app) -- | This installs a shutdown handler for the given socket and -- calls 'runSettingsConnection' with the default connection setup action -- which handles plain (non-cipher) HTTP. -- When the listen socket in the second argument is closed, all live -- connections are gracefully shut down. -- -- The supplied socket can be a Unix named socket, which -- can be used when reverse HTTP proxying into your application. -- -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO () runSettingsSocket set@Settings{settingsAccept = accept'} socket app = do settingsInstallShutdownHandler set closeListenSocket runSettingsConnection set getConn app where getConn = do (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX. setSocketOption s NoDelay 1 `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () conn <- socketConnection set s return (conn, sa) closeListenSocket = close socket -- | The connection setup action would be expensive. A good example -- is initialization of TLS. -- So, this converts the connection setup action to the connection maker -- which will be executed after forking a new worker thread. -- Then this calls 'runSettingsConnectionMaker' with the connection maker. -- This allows the expensive computations to be performed -- in a separate worker thread instead of the main server loop. -- -- Since 1.3.5 runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app where getConnMaker = do (conn, sa) <- getConn return (return conn, sa) -- | This modifies the connection maker so that it returns 'TCP' for 'Transport' -- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'. runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () runSettingsConnectionMaker x y = runSettingsConnectionMakerSecure x (toTCP <$> y) where toTCP = first ((, TCP) <$>) ---------------------------------------------------------------- -- | The core run function which takes 'Settings', -- a connection maker and 'Application'. -- The connection maker can return a connection of either plain HTTP -- or HTTP over TLS. -- -- Since 2.1.4 runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO () runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set counter <- newCounter withII set $ acceptConnection set getConnMaker app counter -- | 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 $ \fdc -> I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do let ii = InternalInfo tm dc fdc fic action ii where !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000 !timeoutInSeconds = settingsTimeout set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm Nothing -> UnliftIO.bracket (T.initialize timeoutInSeconds) T.stopManager f -- Note that there is a thorough discussion of the exception safety of the -- following code at: https://github.com/yesodweb/wai/issues/146 -- -- We need to make sure of two things: -- -- 1. Asynchronous exceptions are not blocked entirely in the main loop. -- Doing so would make it impossible to kill the Warp thread. -- -- 2. Once a connection maker is received via acceptNewConnection, the -- connection is guaranteed to be closed, even in the presence of -- async exceptions. -- -- Our approach is explained in the comments below. acceptConnection :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> Counter -> InternalInfo -> IO () acceptConnection set getConnMaker app counter ii = do -- First mask all exceptions in acceptLoop. This is necessary to -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose. -- -- acceptLoop can be broken by closing the listening socket. void $ UnliftIO.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 -- acceptNewConnection will try to receive the next incoming -- request. It returns a /connection maker/, not a connection, -- since in some circumstances creating a working connection -- from a raw socket may be an expensive operation, and this -- expensive work should not be performed in the main event -- loop. An example of something expensive would be TLS -- negotiation. mx <- acceptNewConnection case mx of Nothing -> return () Just (mkConn, addr) -> do fork set mkConn addr app counter ii acceptLoop acceptNewConnection = do ex <- UnliftIO.tryIO getConnMaker case ex of Right x -> return $ Just x Left e -> do let eConnAborted = getErrno eCONNABORTED getErrno (Errno cInt) = cInt if ioe_errno e == Just eConnAborted then acceptNewConnection else do settingsOnException set Nothing $ toException e return Nothing -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown). fork :: Settings -> IO (Connection, Transport) -> SockAddr -> Application -> Counter -> InternalInfo -> IO () fork set mkConn addr app counter ii = settingsFork set $ \unmask -> -- Call the user-supplied on exception code if any -- exceptions are thrown. -- -- Intentionally using Control.Exception.handle, since we want to -- catch all exceptions and avoid them from propagating, even -- async exceptions. See: -- https://github.com/yesodweb/wai/issues/850 Control.Exception.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. UnliftIO.bracket mkConn cleanUp (serve unmask) where cleanUp (conn, _) = connClose conn `UnliftIO.finally` do writeBuffer <- readIORef $ connWriteBuffer conn bufFree writeBuffer -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit. serve unmask (conn, transport) = UnliftIO.bracket register cancel $ \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 UnliftIO.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 where register = T.registerKillThread (timeoutManager ii) (connClose conn) cancel = T.cancel onOpen adr = increase counter >> settingsOnOpen set adr onClose adr _ = decrease counter >> settingsOnClose set adr serveConnection :: Connection -> InternalInfo -> T.Handle -> SockAddr -> Transport -> Settings -> Application -> IO () serveConnection conn ii th origAddr transport settings app = do -- fixme: Upgrading to HTTP/2 should be supported. (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 http2 settings ii conn transport app origAddr th bs else do http1 settings ii conn transport app origAddr th bs -- | Set flag FileCloseOnExec flag on a socket (on Unix) -- -- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs -- -- @since 3.2.17 setSocketCloseOnExec :: Socket -> IO () #if WINDOWS setSocketCloseOnExec _ = return () #else setSocketCloseOnExec socket = do #if MIN_VERSION_network(3,0,0) fd <- fdSocket socket #else let fd = fdSocket socket #endif F.setFileCloseOnExec $ fromIntegral fd #endif gracefulShutdown :: Settings -> Counter -> IO () gracefulShutdown set counter = case settingsGracefulShutdownTimeout set of Nothing -> waitForZero counter (Just seconds) -> void (timeout (seconds * microsPerSecond) (waitForZero counter)) where microsPerSecond = 1000000 warp-3.3.31/Network/Wai/Handler/Warp/SendFile.hs0000644000000000000000000001074707346545000017440 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Network.Wai.Handler.Warp.SendFile ( sendFile , readSendFile , packHeader -- for testing #ifndef WINDOWS , positionRead #endif ) where import qualified Data.ByteString as BS import Network.Socket (Socket) import Network.Socket.BufferPool #ifdef WINDOWS import Foreign.ForeignPtr (newForeignPtr_) import Foreign.Ptr (plusPtr) import qualified System.IO as IO #else import qualified UnliftIO import Foreign.C.Error (throwErrno) import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr) import Network.Sendfile import Network.Wai.Handler.Warp.FdCache (openFile, closeFile) import System.Posix.Types #endif import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD. -- This makes use of the file descriptor cache. -- For other OSes, this is identical to 'readSendFile'. -- -- Since: 3.1.0 sendFile :: Socket -> Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile #ifdef SENDFILEFD sendFile s _ _ _ fid off len act hdr = case mfid of -- settingsFdCacheDuration is 0 Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr where mfid = fileIdFd fid path = fileIdPath fid #else sendFile _ = readSendFile #endif ---------------------------------------------------------------- packHeader :: Buffer -> BufSize -> (ByteString -> IO ()) -> IO () -> [ByteString] -> Int -> IO Int packHeader _ _ _ _ [] n = return n packHeader buf siz send hook (bs:bss) n | len < room = do let dst = buf `plusPtr` n void $ copy dst bs packHeader buf siz send hook bss (n + len) | otherwise = do let dst = buf `plusPtr` n (bs1, bs2) = BS.splitAt room bs void $ copy dst bs1 bufferIO buf siz send hook packHeader buf siz send hook (bs2:bss) 0 where len = BS.length bs room = siz - n mini :: Int -> Integer -> Int mini i n | fromIntegral i < n = i | otherwise = fromIntegral n -- | Function to send a file based on pread()\/send() for Unix. -- This makes use of the file descriptor cache. -- For Windows, this is emulated by 'Handle'. -- -- Since: 3.1.0 #ifdef WINDOWS readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers = do hn <- packHeader buf siz send hook headers 0 let room = siz - hn buf' = buf `plusPtr` hn IO.withBinaryFile path IO.ReadMode $ \h -> do IO.hSeek h IO.AbsoluteSeek off0 n <- IO.hGetBufSome h buf' (mini room len0) bufferIO buf (hn + n) send hook let n' = fromIntegral n fptr <- newForeignPtr_ buf loop h fptr (len0 - n') where path = fileIdPath fid loop h fptr len | len <= 0 = return () | otherwise = do n <- IO.hGetBufSome h buf (mini siz len) when (n /= 0) $ do let bs = PS fptr 0 n n' = fromIntegral n send bs hook loop h fptr (len - n') #else readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers = UnliftIO.bracket setup teardown $ \fd -> do hn <- packHeader buf siz send hook headers 0 let room = siz - hn buf' = buf `plusPtr` hn n <- positionRead fd buf' (mini room len0) off0 bufferIO buf (hn + n) send hook let n' = fromIntegral n loop fd (len0 - n') (off0 + n') where path = fileIdPath fid setup = case fileIdFd fid of Just fd -> return fd Nothing -> openFile path teardown fd = case fileIdFd fid of Just _ -> return () Nothing -> closeFile fd loop fd len off | len <= 0 = return () | otherwise = do n <- positionRead fd buf (mini siz len) off bufferIO buf n send let n' = fromIntegral n hook loop fd (len - n') (off + n') positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int positionRead fd buf siz off = do bytes <- fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off) when (bytes < 0) $ throwErrno "positionRead" return bytes foreign import ccall unsafe "pread" c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize #endif warp-3.3.31/Network/Wai/Handler/Warp/Settings.hs0000644000000000000000000002734107346545000017545 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ImpredicativeTypes, CPP #-} {-# LANGUAGE MagicHash, UnboxedTuples #-} module Network.Wai.Handler.Warp.Settings where import GHC.IO (unsafeUnmask, IO (IO)) import GHC.Prim (fork#) import UnliftIO (SomeException, fromException) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Builder as Builder 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(..), AsyncException (ThreadKilled)) import qualified Network.HTTP.Types as H import Network.Socket (Socket, SockAddr, accept) import Network.Wai import qualified Paths_warp import System.IO (stderr) import System.IO.Error (ioeGetErrorType) import System.TimeManager import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types #if WINDOWS import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack) #endif -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create a 'Settings' value, use 'defaultSettings' -- and the various \'set\' functions to modify individual fields. For example: -- -- > setTimeout 20 defaultSettings data Settings = Settings { settingsPort :: Port -- ^ Port to listen on. Default value: 3000 , settingsHost :: HostPreference -- ^ Default value: HostIPv4 , settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , settingsOnExceptionResponse :: SomeException -> Response -- ^ A function to create `Response` when an exception occurs. -- -- Default: 500, text/plain, \"Something went wrong\" -- -- Since 2.0.3 , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'. , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing. , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsBeforeMainLoop :: IO () -- ^ Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start -- running, or to drop permissions after binding to a restricted port. -- -- Default: do nothing. -- -- Since 1.3.6 , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO () -- ^ Code to fork a new thread to accept a connection. -- -- This may be useful if you need OS bound threads, or if -- you wish to develop an alternative threading model. -- -- Default: 'defaultFork' -- -- Since 3.0.4 , settingsAccept :: Socket -> IO (Socket, SockAddr) -- ^ Code to accept a new connection. -- -- Useful if you need to provide connected sockets from something other -- than a standard accept call. -- -- Default: 'defaultAccept' -- -- Since 3.3.24 , settingsNoParsePath :: Bool -- ^ Perform no parsing on the rawPathInfo. -- -- This is useful for writing HTTP proxies. -- -- Default: False -- -- Since 2.0.3 , settingsInstallShutdownHandler :: IO () -> IO () -- ^ An action to install a handler (e.g. Unix signal handler) -- to close a listen socket. -- The first argument is an action to close the listen socket. -- -- Default: no action -- -- Since 3.0.1 , settingsServerName :: ByteString -- ^ Default server name if application does not set one. -- -- Since 3.0.2 , settingsMaximumBodyFlush :: Maybe Int -- ^ See @setMaximumBodyFlush@. -- -- Since 3.0.3 , settingsProxyProtocol :: ProxyProtocol -- ^ Specify usage of the PROXY protocol. -- -- Since 3.0.5 , settingsSlowlorisSize :: Int -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048 -- -- Since 3.1.2 , settingsHTTP2Enabled :: Bool -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True -- -- Since 3.1.7 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO () -- ^ A log function. Default: no action. -- -- 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 } -- | Specify usage of the PROXY protocol. data ProxyProtocol = ProxyProtocolNone -- ^ See @setProxyProtocolNone@. | ProxyProtocolRequired -- ^ See @setProxyProtocolRequired@. | ProxyProtocolOptional -- ^ See @setProxyProtocolOptional@. -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings defaultSettings = Settings { settingsPort = 3000 , settingsHost = "*4" , settingsOnException = defaultOnException , settingsOnExceptionResponse = defaultOnExceptionResponse , settingsOnOpen = const $ return True , settingsOnClose = const $ return () , settingsTimeout = 30 , settingsManager = Nothing , settingsFdCacheDuration = 0 , settingsFileInfoCacheDuration = 0 , settingsBeforeMainLoop = return () , settingsFork = defaultFork , settingsAccept = defaultAccept , settingsNoParsePath = False , settingsInstallShutdownHandler = const $ return () , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version , 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 } -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur -- under the normal course of the web server running. -- -- Since 2.1.3 defaultShouldDisplayException :: SomeException -> Bool defaultShouldDisplayException se | Just ThreadKilled <- fromException se = False | Just (_ :: InvalidRequest) <- fromException se = False | Just (ioeGetErrorType -> et) <- fromException se , et == ResourceVanished || et == InvalidArgument = False | Just TimeoutThread <- fromException se = False | otherwise = True -- | Printing an exception to standard error -- if `defaultShouldDisplayException` returns `True`. -- -- Since: 3.1.0 defaultOnException :: Maybe Request -> SomeException -> IO () defaultOnException _ e = when (defaultShouldDisplayException e) $ TIO.hPutStrLn stderr $ T.pack $ show e -- | Sending 400 for bad requests. -- Sending 500 for internal server errors. -- Since: 3.1.0 -- Sending 413 for too large payload. -- Sending 431 for too large headers. -- Since 3.2.27 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e | Just PayloadTooLarge <- fromException e = responseLBS H.status413 [(H.hContentType, "text/plain; charset=utf-8")] "Payload too large" | Just RequestHeaderFieldsTooLarge <- fromException e = responseLBS H.status431 [(H.hContentType, "text/plain; charset=utf-8")] "Request header fields too large" | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request" | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong" -- | Exception handler for the debugging purpose. -- 500, text/plain, a showed exception. -- -- Since: 2.0.3.2 exceptionResponseForDebug :: SomeException -> Response exceptionResponseForDebug e = responseBuilder H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] $ "Exception: " <> Builder.stringUtf8 (show e) -- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler. -- -- Since Warp will always install its own exception handler in forked threads, this provides -- a minor optimization. -- -- For inspiration of this function, see @rawForkIO@ in the @async@ package. -- -- @since 3.3.17 defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO () defaultFork io = #if __GLASGOW_HASKELL__ >= 904 IO $ \s0 -> case io unsafeUnmask of IO io' -> case (fork# io' s0) of (# s1, _tid #) -> (# s1, () #) #else IO $ \s0 -> 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 warp-3.3.31/Network/Wai/Handler/Warp/Types.hs0000644000000000000000000001647607346545000017060 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.Types where import qualified UnliftIO import qualified Data.ByteString as S import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.Typeable (Typeable) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif import Network.Socket (SockAddr) import Network.Socket.BufferPool import System.Posix.Types (Fd) import qualified System.TimeManager as T import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.Imports ---------------------------------------------------------------- -- | TCP port number. type Port = Int ---------------------------------------------------------------- -- | The type for header value used with 'HeaderName'. type HeaderValue = ByteString ---------------------------------------------------------------- -- | Error types for bad 'Request'. data InvalidRequest = NotEnoughLines [String] | BadFirstLine String | NonHttp | IncompleteHeaders | ConnectionClosedByPeer | OverLargeHeader | BadProxyHeader String | PayloadTooLarge -- ^ Since 3.3.22 | RequestHeaderFieldsTooLarge -- ^ Since 3.3.22 deriving (Eq, Typeable) instance Show InvalidRequest where show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs show (BadFirstLine s) = "Warp: Invalid first line of request: " ++ show s show NonHttp = "Warp: Request line specified a non-HTTP request" show IncompleteHeaders = "Warp: Request headers did not finish transmission" show ConnectionClosedByPeer = "Warp: Client closed connection prematurely" show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection." show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s show RequestHeaderFieldsTooLarge = "Request header fields too large" show PayloadTooLarge = "Payload too large" instance UnliftIO.Exception InvalidRequest ---------------------------------------------------------------- -- | Exception thrown if something goes wrong while in the midst of -- sending a response, since the status code can't be altered at that -- point. -- -- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe -- or irrecoverable. newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody UnliftIO.SomeException deriving (Show, Typeable) instance UnliftIO.Exception ExceptionInsideResponseBody ---------------------------------------------------------------- -- | Data type to abstract file identifiers. -- On Unix, a file descriptor would be specified to make use of -- the file descriptor cache. -- -- Since: 3.1.0 data FileId = FileId { fileIdPath :: FilePath , fileIdFd :: Maybe Fd } -- | fileid, offset, length, hook action, HTTP headers -- -- Since: 3.1.0 type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- | A write buffer of a specified size -- containing bytes and a way to free the buffer. data WriteBuffer = WriteBuffer { bufBuffer :: Buffer -- | The size of the write buffer. , bufSize :: !BufSize -- | Free the allocated buffer. Warp guarantees it will only be -- called once, and no other functions will be called after it. , bufFree :: IO () } 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. Warp guarantees it will only be -- called once. Other functions (like 'connRecv') may be called after -- 'connClose' is called. , connClose :: IO () -- | The connection receiving function. This returns "" for EOF or exceptions. , connRecv :: Recv -- | Obsoleted. , connRecvBuf :: RecvBuf -- | 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. , connWriteBuffer :: IORef WriteBuffer -- | Is this connection HTTP/2? , connHTTP2 :: IORef Bool , connMySockAddr :: SockAddr } getConnHTTP2 :: Connection -> IO Bool getConnHTTP2 conn = readIORef (connHTTP2 conn) setConnHTTP2 :: Connection -> Bool -> IO () setConnHTTP2 conn b = writeIORef (connHTTP2 conn) b ---------------------------------------------------------------- data InternalInfo = InternalInfo { timeoutManager :: T.Manager , getDate :: IO D.GMTDate , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh) , getFileInfo :: FilePath -> IO I.FileInfo } ---------------------------------------------------------------- -- | Type for input streaming. data Source = Source !(IORef ByteString) !(IO ByteString) mkSource :: IO ByteString -> IO Source mkSource func = do ref <- newIORef S.empty return $! Source ref func readSource :: Source -> IO ByteString readSource (Source ref func) = do bs <- readIORef ref if S.null bs then func else do writeIORef ref S.empty return bs -- | Read from a Source, ignoring any leftovers. readSource' :: Source -> IO ByteString readSource' (Source _ func) = func leftoverSource :: Source -> ByteString -> IO () leftoverSource (Source ref _) bs = writeIORef ref bs readLeftoverSource :: Source -> IO ByteString readLeftoverSource (Source ref _) = readIORef ref ---------------------------------------------------------------- -- | 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 #ifdef MIN_VERSION_crypton_x509 , tlsClientCertificate :: Maybe CertificateChain #endif } -- ^ Encrypted channel: TLS or SSL | QUIC { quicNegotiatedProtocol :: Maybe ByteString , quicChiperID :: Word16 #ifdef MIN_VERSION_crypton_x509 , quicClientCertificate :: Maybe CertificateChain #endif } isTransportSecure :: Transport -> Bool isTransportSecure TCP = False isTransportSecure _ = True isTransportQUIC :: Transport -> Bool isTransportQUIC QUIC{} = True isTransportQUIC _ = False #ifdef MIN_VERSION_crypton_x509 getTransportClientCertificate :: Transport -> Maybe CertificateChain getTransportClientCertificate TCP = Nothing getTransportClientCertificate (TLS _ _ _ _ cc) = cc getTransportClientCertificate (QUIC _ _ cc) = cc #endif warp-3.3.31/Network/Wai/Handler/Warp/Windows.hs0000644000000000000000000000147107346545000017373 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Windows ( windowsThreadBlockHack ) where #if WINDOWS import Control.Concurrent.MVar import Control.Concurrent import qualified Control.Exception import Network.Wai.Handler.Warp.Imports -- | Allow main socket listening thread to be interrupted on Windows platform -- -- @since 3.2.17 windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack act = do var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a)) -- Catch and rethrow even async exceptions, so don't bother with UnliftIO void . forkIO $ Control.Exception.try act >>= putMVar var res <- takeMVar var case res of Left e -> Control.Exception.throwIO e Right r -> return r #else windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack = id #endif warp-3.3.31/Network/Wai/Handler/Warp/WithApplication.hs0000644000000000000000000000670307346545000021043 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.WithApplication ( withApplication, withApplicationSettings, testWithApplication, testWithApplicationSettings, openFreePort, withFreePort, ) where import Control.Concurrent import qualified UnliftIO import UnliftIO.Async 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 () -> UnliftIO.throwString "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 `UnliftIO.catchAny` \ e -> do when (defaultShouldDisplayException e) (throwTo callingThread e) UnliftIO.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 = UnliftIO.bracket openFreePort (close . snd) warp-3.3.31/README.md0000644000000000000000000000026707346545000012227 0ustar0000000000000000# Warp Warp is a server library for HTTP/1.x and HTTP/2 based WAI(Web Application Interface in Haskell). For more information, see [Warp](http://www.aosabook.org/en/posa/warp.html). warp-3.3.31/Setup.lhs0000644000000000000000000000016207346545000012552 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain warp-3.3.31/attic/0000755000000000000000000000000007346545000012047 5ustar0000000000000000warp-3.3.31/attic/hex0000644000000000000000000000002007346545000012546 0ustar00000000000000000123456789abcdefwarp-3.3.31/bench/0000755000000000000000000000000007346545000012022 5ustar0000000000000000warp-3.3.31/bench/Parser.hs0000644000000000000000000001730007346545000013613 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Main where 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 UnliftIO.Exception (throwIO, impureThrow) import Data.ByteString.Internal import Data.Word import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable #if MIN_VERSION_gauge(0, 2, 0) import Gauge #else import Gauge.Main #endif -- $setup -- >>> :set -XOverloadedStrings ---------------------------------------------------------------- main :: IO () main = do let requestLine1 = "GET http://www.example.com HTTP/1.1" let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0" defaultMain [ bgroup "requestLine1" [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1 , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1 , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1 , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1 ] , bgroup "requestLine2" [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2 , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2 , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2 , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2 ] ] ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine3 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine3 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine3 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine3 :: ByteString -> (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine3 requestLine = ret where (!method,!rest) = S.break (== 32) requestLine -- ' ' (!pathQuery,!httpVer') | rest == "" = impureThrow badmsg | otherwise = S.break (== 32) (S.drop 1 rest) -- ' ' (!path,!query) = S.break (== 63) pathQuery -- '?' !httpVer = S.drop 1 httpVer' (!http,!ver) | httpVer == "" = impureThrow badmsg | otherwise = S.break (== 47) httpVer -- '/' !hv | http /= "HTTP" = impureThrow NonHttp | ver == "/1.1" = H.http11 | otherwise = H.http10 !ret = (method,path,query,hv) badmsg = BadFirstLine $ B.unpack requestLine ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine2 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine2 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine2 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine2 :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len pathptr0 <- memchr methodptr 32 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 -- ' ' when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1 lim2 = fromIntegral (httpptr0 `minusPtr` pathptr) checkHTTP httpptr !hv <- httpVersion httpptr queryptr <- memchr pathptr 63 lim2 -- '?' let !method = bs ptr methodptr pathptr0 !path | queryptr == nullPtr = bs ptr pathptr httpptr0 | otherwise = bs ptr pathptr queryptr !query | queryptr == nullPtr = S.empty | otherwise = bs ptr queryptr httpptr0 return (method,path,query,hv) where baderr = BadFirstLine $ B.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO () check p n w = do w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do check httpptr 0 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 -- '.' 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 bs ptr p0 p1 = PS fptr o l where o = p0 `minusPtr` ptr l = p1 `minusPtr` p0 ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine1 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine1 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine1 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine1 :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine1 requestLine = do let (!method,!rest) = S.break (== 32) requestLine -- ' ' (!pathQuery,!httpVer') = S.break (== 32) (S.drop 1 rest) -- ' ' !httpVer = S.drop 1 httpVer' when (rest == "" || httpVer == "") $ throwIO $ BadFirstLine $ B.unpack requestLine let (!path,!query) = S.break (== 63) pathQuery -- '?' (!http,!ver) = S.break (== 47) httpVer -- '/' when (http /= "HTTP") $ throwIO NonHttp let !hv | ver == "/1.1" = H.http11 | otherwise = H.http10 return $! (method,path,query,hv) ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine0 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine0 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine0 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine0 :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine0 s = case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- ' (method':query:http'') -> do let !method = method' !http' = S.concat http'' (!hfirst, !hsecond) = S.splitAt 5 http' if hfirst == "HTTP/" then let (!rpath, !qstring) = S.break (== 63) query -- '?' !hv = case hsecond of "1.1" -> H.http11 _ -> H.http10 in return $! (method, rpath, qstring, hv) else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s warp-3.3.31/test/0000755000000000000000000000000007346545000011722 5ustar0000000000000000warp-3.3.31/test/ConduitSpec.hs0000644000000000000000000000362407346545000014503 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ConduitSpec (main, spec) where 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 spec :: Spec spec = describe "conduit" $ do it "IsolatedBSSource" $ do ref <- newIORef $ map S.singleton [1..50] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty y:z -> do writeIORef ref z return y isrc <- mkISource src 40 x <- replicateM 20 $ readISource isrc S.concat x `shouldBe` S.pack [1..20] y <- replicateM 40 $ readISource isrc S.concat y `shouldBe` S.pack [21..40] z <- replicateM 40 $ readSource src S.concat z `shouldBe` S.pack [41..50] it "chunkedSource" $ do ref <- newIORef "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH" src <- mkSource $ do x <- readIORef ref writeIORef ref S.empty return x csrc <- mkCSource src x <- replicateM 15 $ readCSource csrc S.concat x `shouldBe` "12345678" y <- replicateM 15 $ readSource src S.concat y `shouldBe` "BLAH" it "chunk boundaries" $ do ref <- newIORef [ "5\r\n" , "12345\r\n3\r" , "\n678\r\n0\r\n" , "\r\nBLAH" ] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty y:z -> do writeIORef ref z return y csrc <- mkCSource src x <- replicateM 15 $ readCSource csrc S.concat x `shouldBe` "12345678" y <- replicateM 15 $ readSource src S.concat y `shouldBe` "BLAH" warp-3.3.31/test/ExceptionSpec.hs0000644000000000000000000000442007346545000015027 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module ExceptionSpec (main, spec) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad import Network.HTTP.Types hiding (Header) import Network.Wai hiding (Response, responseStatus) import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp import Test.Hspec import UnliftIO.Exception import qualified Data.Streaming.Network as N import UnliftIO.Async (withAsync) import Network.Socket (close) import HTTP main :: IO () main = hspec spec withTestServer :: (Int -> IO a) -> IO a withTestServer inner = bracket (N.bindRandomPortTCP "127.0.0.1") (close . snd) $ \(prt, lsocket) -> do withAsync (runSettingsSocket defaultSettings lsocket testApp) $ \_ -> inner prt testApp :: Application testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f | x == "statusError" = f $ responseLBS undefined [] "foo" | x == "headersError" = f $ responseLBS ok200 undefined "foo" | x == "headerError" = f $ responseLBS ok200 [undefined] "foo" | x == "bodyError" = f $ responseLBS ok200 [] undefined | x == "ioException" = do void $ fail "ioException" f $ responseLBS ok200 [] "foo" testApp _ f = f $ responseLBS ok200 [] "foo" spec :: Spec spec = describe "responds even if there is an exception" $ do {- Disabling these tests. We can consider forcing evaluation in Warp. it "statusError" $ do sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError" sc `shouldBe` internalServerError500 it "headersError" $ do sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError" sc `shouldBe` internalServerError500 it "headerError" $ do sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError" sc `shouldBe` internalServerError500 it "bodyError" $ do sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError" sc `shouldBe` internalServerError500 -} it "ioException" $ withTestServer $ \prt -> do sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException") sc `shouldBe` internalServerError500 warp-3.3.31/test/FdCacheSpec.hs0000644000000000000000000000111707346545000014346 0ustar0000000000000000{-# LANGUAGE CPP #-} module FdCacheSpec where import Test.Hspec #ifndef WINDOWS import Data.IORef import Network.Wai.Handler.Warp.FdCache import System.Posix.IO (fdRead) import System.Posix.Types (Fd(..)) main :: IO () main = hspec spec spec :: Spec spec = describe "withFdCache" $ do it "clean up Fd" $ do ref <- newIORef (Fd (-1)) withFdCache 30000000 $ \getFd -> do (Just fd,_) <- getFd "warp.cabal" writeIORef ref fd nfd <- readIORef ref fdRead nfd 1 `shouldThrow` anyIOException #else spec :: Spec spec = return () #endif warp-3.3.31/test/FileSpec.hs0000644000000000000000000001043507346545000013753 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module FileSpec (main, spec) where import Data.ByteString import Data.String (fromString) import Network.HTTP.Types import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import System.IO.Unsafe (unsafePerformIO) import Test.Hspec main :: IO () main = hspec spec changeHeaders :: (ResponseHeaders -> ResponseHeaders) -> RspFileInfo -> RspFileInfo changeHeaders f rfi = case rfi of WithBody s hs off len -> WithBody s (f hs) off len other -> other getHeaders :: RspFileInfo -> ResponseHeaders getHeaders rfi = case rfi of WithBody _ hs _ _ -> hs _ -> [] testFileRange :: String -> RequestHeaders -> RspFileInfo -> Spec testFileRange desc reqhs ans = it desc $ do finfo <- getInfo "attic/hex" let f = (:) ("Last-Modified", fileInfoDate finfo) hs = getHeaders ans ans' = changeHeaders f ans conditionalRequest finfo [] methodGet (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans' farPast, farFuture :: ByteString farPast = "Thu, 01 Jan 1970 00:00:00 GMT" farFuture = "Sun, 05 Oct 3000 00:00:00 GMT" regularBody :: RspFileInfo regularBody = WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16 make206Body :: Integer -> Integer -> RspFileInfo make206Body start len = WithBody status206 [crHeader, lenHeader, ("Accept-Ranges","bytes")] start len where lenHeader = ("Content-Length", fromString $ show len) crHeader = ("Content-Range", fromString $ "bytes " <> show start <> "-" <> show (start + len - 1) <> "/16") spec :: Spec spec = do describe "conditionalRequest" $ do testFileRange "gets a file size from file system" [] regularBody testFileRange "gets a file size from file system and handles Range and returns Partical Content" [("Range","bytes=2-14")] $ make206Body 2 13 testFileRange "truncates end point of range to file size" [("Range","bytes=10-20")] $ make206Body 10 6 testFileRange "gets a file size from file system and handles Range and returns OK if Range means the entire" [("Range:","bytes=0-15")] regularBody testFileRange "returns a 412 if the file has been changed in the meantime" [("If-Unmodified-Since", farPast)] $ WithoutBody status412 testFileRange "gets a file if the file has not been changed in the meantime" [("If-Unmodified-Since", farFuture)] regularBody testFileRange "ignores the If-Unmodified-Since header if an If-Match header is also present" [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast)] regularBody testFileRange "still gives only a range, even after conditionals" [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast), ("Range","bytes=10-20")] $ make206Body 10 6 testFileRange "gets a file if the file has been changed in the meantime" [("If-Modified-Since", farPast)] regularBody testFileRange "returns a 304 if the file has not been changed in the meantime" [("If-Modified-Since", farFuture)] $ WithoutBody status304 testFileRange "ignores the If-Modified-Since header if an If-None-Match header is also present" [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture)] regularBody testFileRange "still gives only a range, even after conditionals" [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture), ("Range","bytes=10-13")] $ make206Body 10 4 testFileRange "gives the a range, if the condition is met" [("If-Range", fileInfoDate (unsafePerformIO $ getInfo "attic/hex")), ("Range","bytes=2-7")] $ make206Body 2 6 testFileRange "gives the entire body and ignores the Range header if the condition isn't met" [("If-Range", farPast), ("Range","bytes=2-7")] regularBody warp-3.3.31/test/HTTP.hs0000644000000000000000000000214507346545000013037 0ustar0000000000000000module HTTP ( sendGET , sendGETwH , sendHEAD , sendHEADwH , responseBody , responseStatus , responseHeaders , getHeaderValue , HeaderName ) where import Network.HTTP.Client import Network.HTTP.Types import Data.ByteString import qualified Data.ByteString.Lazy as BL sendGET :: String -> IO (Response BL.ByteString) sendGET url = sendGETwH url [] sendGETwH :: String -> [Header] -> IO (Response BL.ByteString) sendGETwH url hdr = do manager <- newManager defaultManagerSettings request <- parseRequest url let request' = request { requestHeaders = hdr } response <- httpLbs request' manager return response sendHEAD :: String -> IO (Response BL.ByteString) sendHEAD url = sendHEADwH url [] sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString) sendHEADwH url hdr = do manager <- newManager defaultManagerSettings request <- parseRequest url let request' = request { requestHeaders = hdr, method = methodHead } response <- httpLbs request' manager return response getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString getHeaderValue = lookup warp-3.3.31/test/ReadIntSpec.hs0000644000000000000000000000172507346545000014424 0ustar0000000000000000module 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 qualified Test.QuickCheck as QC main :: IO () main = hspec spec spec :: Spec spec = describe "readInt64" $ do it "converts ByteString to Int" $ QC.property (prop_read_show_idempotent readInt64) -- A QuickCheck property. Test that for a number >= 0, converting it to -- a string using show and then reading the value back with the function -- under test returns the original value. -- The functions under test only work on Natural numbers (the Conent-Length -- field in a HTTP header is always >= 0) so we check the absolute value of -- the value that QuickCheck generates for us. prop_read_show_idempotent :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool prop_read_show_idempotent freader x = px == freader (toByteString px) where px = abs x toByteString = B.pack . show warp-3.3.31/test/RequestSpec.hs0000644000000000000000000001432207346545000014523 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} module RequestSpec (main, spec) where import Network.Wai.Handler.Warp.File (parseByteRanges) import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Types import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings) 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 `shouldReturn` ("", ["foo", "bar", "baz"]) it "ignored leading whitespace in bodies" $ whiteSafe `shouldReturn` (" hi there", ["foo", "bar", "baz"]) it "throws OverLargeHeader when too many" $ tooMany `shouldThrow` overLargeHeader it "throws OverLargeHeader when too large" $ tooLarge `shouldThrow` overLargeHeader it "known bad chunking behavior #239" $ do let chunks = [ "GET / HTTP/1.1\r\nConnection: Close\r" , "\n\r\n" ] (actual, src) <- headerLinesList' chunks leftover <- readLeftoverSource src leftover `shouldBe` S.empty actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"] prop "random chunking" $ \breaks extraS -> do let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra extra = S8.pack extraS chunks = loop breaks bsFull loop [] bs = [bs, undefined] loop (x:xs) bs = bs1 : loop xs bs2 where (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs (actual, src) <- headerLinesList' chunks leftover <- consumeLen (length extraS) src actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"] leftover `shouldBe` extra describe "parseByteRanges" $ do let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499] test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999] test "bytes=-500" $ Just [HH.ByteRangeSuffix 500] test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500] test "foobytes=9500-" Nothing test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] describe "headerLines" $ do it "can handle a normal case" $ do src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource x <- headerLines defaultMaxTotalHeaderLength True 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 defaultMaxTotalHeaderLength True 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 defaultMaxTotalHeaderLength True src x `shouldBe` ["Status: 200", "Content-Type: text/plain"] 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 defaultMaxTotalHeaderLength True src x `shouldBe` ["Status: 200", "Content-Type: text/plain"] it "can handle an illegal case (1)" $ do src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource x <- headerLines defaultMaxTotalHeaderLength True src x `shouldBe` [] y <- headerLines defaultMaxTotalHeaderLength True src y `shouldBe` ["Status: 200", "Content-Type: text/plain"] -- Length is 39, this shouldn't fail let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"] it "doesn't throw on correct length" $ do src <- mkSourceFunc testLengthHeaders >>= mkSource x <- headerLines 39 True 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 38 True src `shouldThrow` (== OverLargeHeader) where blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"] whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"] tooMany = headerLinesList $ repeat "f\n" tooLarge = headerLinesList $ repeat "f" headerLinesList :: [S8.ByteString] -> IO (S8.ByteString, [S8.ByteString]) headerLinesList orig = do (res, src) <- headerLinesList' orig leftover <- readLeftoverSource src return (leftover, res) headerLinesList' :: [S8.ByteString] -> IO ([S8.ByteString], Source) headerLinesList' orig = do ref <- newIORef orig let src = do x <- readIORef ref case x of [] -> return S.empty y:z -> do writeIORef ref z return y src' <- mkSource src res <- headerLines defaultMaxTotalHeaderLength True src' return (res, src') consumeLen :: Int -> Source -> IO S8.ByteString consumeLen len0 src = loop id len0 where loop front len | len <= 0 = return $ S.concat $ front [] | otherwise = do bs <- readSource src if S.null bs then loop front 0 else do let (x, _) = S.splitAt len bs loop (front . (x:)) (len - S.length x) overLargeHeader :: Selector InvalidRequest overLargeHeader e = e == OverLargeHeader mkSourceFunc :: [S8.ByteString] -> IO (IO S8.ByteString) mkSourceFunc bss = do ref <- newIORef bss return $ reader ref where reader ref = do xss <- readIORef ref case xss of [] -> return S.empty (x:xs) -> do writeIORef ref xs return x warp-3.3.31/test/ResponseHeaderSpec.hs0000644000000000000000000000340707346545000016004 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ResponseHeaderSpec (main, spec) where import Data.ByteString import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.ResponseHeader import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Header import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = do describe "composeHeader" $ do it "composes a HTTP header" $ composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader describe "addServer" $ do it "adds Server if not exist" $ do let hdrs = [] rspidxhdr = indexResponseHeader hdrs addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server","MyServer")] it "does not add Server if exists" $ do let hdrs = [("Server","MyServer")] rspidxhdr = indexResponseHeader hdrs addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs it "does not add Server if empty" $ do let hdrs = [] rspidxhdr = indexResponseHeader hdrs addServer "" rspidxhdr hdrs `shouldBe` hdrs it "deletes Server " $ do let hdrs = [("Server","MyServer")] rspidxhdr = indexResponseHeader hdrs addServer "" rspidxhdr hdrs `shouldBe` [] headers :: H.ResponseHeaders headers = [ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT") , ("Content-Length", "151") , ("Server", "Mighttpd/2.5.8") , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT") , ("Content-Type", "text/html") ] composedHeader :: ByteString composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n" warp-3.3.31/test/ResponseSpec.hs0000644000000000000000000001007707346545000014674 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ResponseSpec (main, spec) where import Control.Concurrent (threadDelay) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Maybe (mapMaybe) import Network.HTTP.Types import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Response import RunSpec (withApp, msWrite, msRead, withMySocket) import Test.Hspec main :: IO () main = hspec spec testRange :: S.ByteString -- ^ range value -> String -- ^ expected output -> Maybe String -- ^ expected content-range value -> Spec testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "GET / HTTP/1.0\r\n" msWrite ms "Range: bytes=" msWrite ms range msWrite ms "\r\n\r\n" threadDelay 10000 bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 last bss `shouldBe` out let hs = mapMaybe toHeader bss lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) where app _ = ($ responseFile status200 [] "attic/hex" Nothing) title = show (range, out, crange) toHeader s = case break (== ':') s of (x, ':':y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing testPartial :: Integer -- ^ file size -> Integer -- ^ offset -> Integer -- ^ byte count -> String -- ^ expected output -> Spec testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "GET / HTTP/1.0\r\n\r\n" threadDelay 10000 bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 out `shouldBe` last bss let hs = mapMaybe toHeader bss lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) lookup "Content-Range" hs `shouldBe` Just range where app _ = ($ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size) title = show (offset, count, out) toHeader s = case break (== ':') s of (x, ':':y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size spec :: Spec spec = do {- 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 sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar" it "adds missing spaces after \r\n" $ do sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar" it "discards empty lines" $ do sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar" context "when sanitizing single occurrences of \n" $ do it "replaces \n with \r\n" $ do sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar" it "adds missing spaces after \n" $ do sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar" it "discards single occurrences of \r" $ do sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar" describe "range requests" $ do testRange "2-3" "23" $ Just "2-3/16" testRange "5-" "56789abcdef" $ Just "5-15/16" testRange "5-8" "5678" $ Just "5-8/16" testRange "-3" "def" $ Just "13-15/16" testRange "16-" "" $ Just "*/16" testRange "-17" "0123456789abcdef" Nothing describe "partial files" $ do testPartial 16 2 2 "23" testPartial 16 0 2 "01" testPartial 16 3 8 "3456789a" warp-3.3.31/test/RunSpec.hs0000644000000000000000000004506307346545000013645 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) import Control.Concurrent.STM import qualified UnliftIO.Exception as E import UnliftIO.Exception (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.IORef as I import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv) import Network.HTTP.Types import Network.Socket import Network.Socket.ByteString (sendAll) import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec import HTTP main :: IO () main = hspec spec type Counter = I.IORef (Either String Int) type CounterApplication = Counter -> Application data MySocket = MySocket { msSocket :: !Socket , msBuffer :: !(I.IORef ByteString) } msWrite :: MySocket -> ByteString -> IO () msWrite = sendAll . msSocket msRead :: MySocket -> Int -> IO ByteString msRead (MySocket s ref) expected = do bs <- I.readIORef ref inner (bs:) (S.length bs) where inner front total = case compare total expected of EQ -> do I.writeIORef ref mempty pure $ S.concat $ front [] GT -> do let bs = S.concat $ front [] (x, y) = S.splitAt expected bs I.writeIORef ref y pure x LT -> do bs <- safeRecv s 4096 if S.null bs then do I.writeIORef ref mempty pure $ S.concat $ front [] else inner (front . (bs:)) (total + S.length bs) msClose :: MySocket -> IO () msClose = Network.Socket.close . msSocket connectTo :: Int -> IO MySocket connectTo port = do s <- fst <$> getSocketTCP "127.0.0.1" port ref <- I.newIORef mempty return MySocket { msSocket = s , msBuffer = ref } withMySocket :: (MySocket -> IO a) -> Int -> IO a withMySocket body port = bracket (connectTo port) msClose body incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount -> (case ecount of Left s -> Left s Right i -> Right $ i + 1, ()) err :: (MonadIO m, Show a) => Counter -> a -> m () err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg readBody :: CounterApplication readBody icount req f = do body <- consumeBody $ getRequestBodyChunk req case () of () | pathInfo req == ["hello"] && L.fromChunks body /= "Hello" -> err icount ("Invalid hello" :: String, body) | requestMethod req == "GET" && L.fromChunks body /= "" -> err icount ("Invalid GET" :: String, body) | requestMethod req `notElem` ["GET", "POST"] -> err icount ("Invalid request method (readBody)" :: String, requestMethod req) | otherwise -> incr icount f $ responseLBS status200 [] "Read the body" ignoreBody :: CounterApplication ignoreBody icount req f = do if requestMethod req `elem` ["GET", "POST"] then incr icount else err icount ("Invalid request method" :: String, requestMethod req) f $ responseLBS status200 [] "Ignored the body" doubleConnect :: CounterApplication doubleConnect icount req f = do _ <- consumeBody $ getRequestBodyChunk req _ <- consumeBody $ getRequestBodyChunk req incr icount f $ responseLBS status200 [] "double connect" nextPort :: I.IORef Int nextPort = unsafePerformIO $ I.newIORef 5000 {-# NOINLINE nextPort #-} getPort :: IO Int getPort = do port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p) esocket <- try $ bindPortTCP port "127.0.0.1" case esocket of Left (_ :: IOException) -> RunSpec.getPort Right sock -> do close sock return port withApp :: Settings -> Application -> (Int -> IO a) -> IO a withApp settings app f = do port <- RunSpec.getPort baton <- newEmptyMVar let settings' = setPort port $ setHost "127.0.0.1" $ setBeforeMainLoop (putMVar baton ()) settings bracket (forkIO $ runSettings settings' app `onException` putMVar baton ()) killThread (const $ do takeMVar baton -- use timeout to make sure we don't take too long mres <- timeout (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 expected app chunks = do ref <- I.newIORef (Right 0) withApp defaultSettings (app ref) $ withMySocket $ \ms -> do forM_ chunks $ \chunk -> msWrite ms chunk _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096 res <- I.readIORef ref case res of Left s -> error s Right i -> i `shouldBe` expected dummyApp :: Application dummyApp _ f = f $ responseLBS status200 [] "foo" runTerminateTest :: InvalidRequest -> ByteString -> IO () runTerminateTest expected input = do ref <- I.newIORef Nothing let onExc _ = I.writeIORef ref . Just withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do msWrite ms input msClose ms -- explicitly threadDelay 5000 res <- I.readIORef ref show res `shouldBe` show (Just expected) singleGet :: ByteString singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" singlePostHello :: ByteString singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello" singleChunkedPostHello :: [ByteString] singleChunkedPostHello = [ "POST /hello HTTP/1.1\r\nHost: localhost\r\nTransfer-Encoding: chunked\r\n\r\n" , "5\r\nHello\r\n0\r\n" ] spec :: Spec spec = do describe "non-pipelining" $ do it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet it "has body, read" $ runTest 2 readBody [ singlePostHello , singleGet ] it "has body, ignore" $ runTest 2 ignoreBody [ singlePostHello , singleGet ] it "chunked body, read" $ runTest 2 readBody $ singleChunkedPostHello ++ [singleGet] it "chunked body, ignore" $ runTest 2 ignoreBody $ singleChunkedPostHello ++ [singleGet] describe "pipelining" $ do it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet] it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet] it "has body, read" $ runTest 2 readBody $ return $ S.concat [ singlePostHello , singleGet ] it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat [ singlePostHello , singleGet ] it "chunked body, read" $ runTest 2 readBody $ return $ S.concat [ S.concat singleChunkedPostHello , singleGet ] it "chunked body, ignore" $ runTest 2 ignoreBody $ return $ S.concat [ S.concat singleChunkedPostHello , singleGet ] describe "no hanging" $ do it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello it "double connect" $ runTest 1 doubleConnect [singlePostHello] describe "connection termination" $ do -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello" it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n" describe "special input" $ do it "multiline headers" $ do iheaders <- I.newIORef [] let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" ] msWrite ms input threadDelay 5000 headers <- I.readIORef iheaders headers `shouldBe` [ ("foo", "bar baz\tbin") ] it "no space between colon and value" $ do iheaders <- I.newIORef [] let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" ] msWrite ms input threadDelay 5000 headers <- I.readIORef iheaders headers `shouldBe` [ ("foo", "bar") ] describe "chunked bodies" $ do it "works" $ do countVar <- newTVarIO (0 :: Int) ifront <- I.newIORef id let app req f = do bss <- consumeBody $ getRequestBodyChunk req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n" , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ] msWrite ms input atomically $ do count <- readTVar countVar check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` [ "Hello World\nBye" , "Hello World" ] it "lots of chunks" $ do ifront <- I.newIORef id countVar <- newTVarIO (0 :: Int) let app req f = do bss <- consumeBody $ getRequestBodyChunk req I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do let input = concat $ replicate 2 $ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++ replicate 50 "5\r\n12345\r\n" ++ ["0\r\n\r\n"] mapM_ (msWrite ms) input atomically $ do count <- readTVar countVar check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345") -- For some reason, the following test on Windows causes the socket -- to be killed prematurely. Worth investigating in the future if possible. it "in chunks" $ do ifront <- I.newIORef id countVar <- newTVarIO (0 :: Int) let app req f = do bss <- consumeBody $ getRequestBodyChunk req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n" , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ] mapM_ (msWrite ms . S.singleton) $ S.unpack input atomically $ do count <- readTVar countVar check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` [ "Hello World\nBye" , "Hello World" ] it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do bss <- consumeBody (getRequestBodyChunk req) `onException` liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ()))) liftIO $ threadDelay 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 $ withMySocket $ \ms -> do let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2 msWrite ms "POST / HTTP/1.1\r\n" msWrite ms "content-length: " msWrite ms $ S8.pack $ show $ S.length bs msWrite ms "\r\n\r\n" threadDelay 100000 msWrite ms bs1 threadDelay 100000 msWrite ms bs2 threadDelay 5000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs describe "raw body" $ do it "works" $ do let app _req f = do let backup = responseLBS status200 [] "Not raw" f $ flip responseRaw backup $ \src sink -> do let loop = do bs <- src unless (S.null bs) $ do sink $ doubleBS bs loop loop doubleBS = S.concatMap $ \w -> S.pack [w, w] withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "POST / HTTP/1.1\r\n\r\n12345" timeout 100000 (msRead ms 10) `shouldReturn` Just "1122334455" msWrite ms "67890" timeout 100000 (msRead ms 10) `shouldReturn` Just "6677889900" it "only one date and server header" $ do let app _ f = f $ responseLBS status200 [ ("server", "server") , ("date", "date") ] "" getValues key = map snd . filter (\(key', _) -> key == key') . responseHeaders withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port getValues hServer res `shouldBe` ["server"] getValues hDate res `shouldBe` ["date"] it "streaming echo #249" $ do countVar <- newTVarIO (0 :: Int) let app req f = f $ responseStream status200 [] $ \write _ -> do let loop = do bs <- getRequestBodyChunk req unless (S.null bs) $ do write $ byteString bs atomically $ modifyTVar countVar (+ 1) loop loop withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" threadDelay 10000 msWrite ms "5\r\nhello\r\n0\r\n\r\n" atomically $ do count <- readTVar countVar check $ count >= 1 bs <- safeRecv (msSocket ms) 4096 -- must not use msRead S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK" it "streaming response with length" $ do let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do replicateM_ 4 $ write $ byteString "Hello" withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port responseBody res `shouldBe` "HelloHelloHelloHello" describe "head requests" $ do let fp = "test/head-response" let app req f = f $ case pathInfo req of ["builder"] -> responseBuilder status200 [] $ error "should never be evaluated" ["streaming"] -> responseStream status200 [] $ \write _ -> write $ error "should never be evaluated" ["file"] -> responseFile status200 [] fp Nothing _ -> error "invalid path" it "builder" $ withApp defaultSettings app $ \port -> do res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"] responseBody res `shouldBe` "" it "streaming" $ withApp defaultSettings app $ \port -> do res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"] responseBody res `shouldBe` "" it "file, no range" $ withApp defaultSettings app $ \port -> do bs <- S.readFile fp res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"] getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs) it "file, with range" $ withApp defaultSettings app $ \port -> do res <- sendHEADwH (concat ["http://127.0.0.1:", show port, "/file"]) [(hRange, "bytes=0-1")] getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2" consumeBody :: IO ByteString -> IO [ByteString] consumeBody body = loop id where loop front = do bs <- body if S.null bs then return $ front [] else loop $ front . (bs:) warp-3.3.31/test/SendFileSpec.hs0000644000000000000000000001034307346545000014563 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module SendFileSpec where import Control.Monad (when) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Types import System.Directory import System.Exit import qualified System.IO as IO import System.Process (system) import Test.Hspec import UnliftIO.Exception main :: IO () main = hspec spec spec :: Spec spec = do describe "packHeader" $ do it "returns how much the buffer is consumed (1)" $ tryPackHeader 10 ["foo"] `shouldReturn` 3 it "returns how much the buffer is consumed (2)" $ tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6 it "returns how much the buffer is consumed (3)" $ tryPackHeader 10 ["0123456789"] `shouldReturn` 0 it "returns how much the buffer is consumed (4)" $ tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0 it "returns how much the buffer is consumed (5)" $ tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3 it "returns how much the buffer is consumed (6)" $ tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5 it "sends headers correctly (1)" $ tryPackHeader2 10 ["foo"] "" `shouldReturn` True it "sends headers correctly (2)" $ tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True it "sends headers correctly (3)" $ tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True it "sends headers correctly (4)" $ tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True it "sends headers correctly (5)" $ tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True it "sends headers correctly (6)" $ tryPackHeader2 10 ["012345678901234567890123456789012", "34"] "012345678901234567890123456789" `shouldReturn` True describe "readSendFile" $ do it "sends a file correctly (1)" $ tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess it "sends a file correctly (2)" $ tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess it "sends a file correctly (3)" $ tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess tryPackHeader :: Int -> [ByteString] -> IO Int tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf -> packHeader buf siz send hook hdrs 0 where send _ = return () hook = return () tryPackHeader2 :: Int -> [ByteString] -> ByteString -> IO Bool tryPackHeader2 siz hdrs ans = bracket setup teardown $ \buf -> do _ <- packHeader buf siz send hook hdrs 0 checkFile outputFile ans where setup = allocateBuffer siz teardown buf = freeBuffer buf >> removeFileIfExists outputFile outputFile = "tempfile" send = BS.appendFile outputFile hook = return () tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO ExitCode tryReadSendFile siz off len hdrs = bracket setup teardown $ \buf -> do mapM_ (BS.appendFile expectedFile) hdrs copyfile inputFile expectedFile off len readSendFile buf siz send fid off len hook hdrs compareFiles expectedFile outputFile where hook = return () setup = allocateBuffer siz teardown buf = do freeBuffer buf removeFileIfExists outputFile removeFileIfExists expectedFile inputFile = "test/inputFile" outputFile = "outputFile" expectedFile = "expectedFile" fid = FileId inputFile Nothing send = BS.appendFile outputFile checkFile :: FilePath -> ByteString -> IO Bool checkFile path bs = do exist <- doesFileExist path if exist then do bs' <- BS.readFile path return $ bs == bs' else return $ bs == "" compareFiles :: FilePath -> FilePath -> IO ExitCode compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2 copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO () copyfile src dst off len = IO.withBinaryFile src IO.ReadMode $ \h -> do IO.hSeek h IO.AbsoluteSeek off BS.hGet h (fromIntegral len) >>= BS.appendFile dst removeFileIfExists :: FilePath -> IO () removeFileIfExists file = do exist <- doesFileExist file when exist $ removeFile file warp-3.3.31/test/Spec.hs0000644000000000000000000000005407346545000013147 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} warp-3.3.31/test/WithApplicationSpec.hs0000644000000000000000000000331307346545000016170 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module WithApplicationSpec where import Network.HTTP.Types import Network.Wai import System.Environment import System.Process import Test.Hspec import UnliftIO.Exception 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 -> throwString "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 -> throwString "foo" testWithApplication mkApp (\ port -> do readProcess "curl" ["-s", "localhost:" ++ show port] "") `shouldThrow` (\(StringException str _) -> str == "foo") warp-3.3.31/test/doctests.hs0000644000000000000000000000007607346545000014111 0ustar0000000000000000import Test.DocTest main :: IO () main = doctest ["Network"] warp-3.3.31/test/head-response0000644000000000000000000000002107346545000014373 0ustar0000000000000000This is the body warp-3.3.31/test/inputFile0000644000000000000000000000270207346545000013605 0ustar0000000000000000A 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 warp-3.3.31/warp.cabal0000644000000000000000000002554007346545000012706 0ustar0000000000000000Name: warp Version: 3.3.31 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.10 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 test/inputFile Flag network-bytestring Default: False Flag allow-sendfilefd Description: Allow use of sendfileFd (not available on GNU/kFreeBSD) Default: True Flag warp-debug Description: print debug output. not suitable for production Default: False Flag x509 Description: Adds a dependency on the x509 library to enable getting TLS client certificates. Default: True Library Build-Depends: base >= 4.12 && < 5 , array , auto-update >= 0.1.3 && < 0.2 , bsb-http-chunked < 0.1 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2 , containers , ghc-prim , hashable , http-date , http-types >= 0.12 , http2 >= 5.0 && < 5.1 , 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 , vault >= 0.3 , wai >= 3.2 && < 3.3 , word8 , unliftio 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 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.HashMap 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.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.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication Paths_warp Ghc-Options: -Wall 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 , unix-compat >= 0.2 else Build-Depends: unix Other-modules: Network.Wai.Handler.Warp.MultiMap if impl(ghc >= 8) Default-Extensions: Strict StrictData Default-Language: Haskell2010 Test-Suite doctest buildable: False Type: exitcode-stdio-1.0 HS-Source-Dirs: test Ghc-Options: -threaded -Wall Main-Is: doctests.hs Build-Depends: base >= 4.8 && < 5 , doctest >= 0.10.1 if os(windows) Buildable: False if impl(ghc >= 8) Default-Extensions: Strict StrictData Default-Language: Haskell2010 Test-Suite spec Main-Is: Spec.hs Other-modules: ConduitSpec ExceptionSpec FdCacheSpec FileSpec ReadIntSpec RequestSpec ResponseHeaderSpec ResponseSpec RunSpec SendFileSpec WithApplicationSpec HTTP Network.Wai.Handler.Warp 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.MultiMap Network.Wai.Handler.Warp.PackInt Network.Wai.Handler.Warp.ReadInt Network.Wai.Handler.Warp.Request Network.Wai.Handler.Warp.RequestHeader Network.Wai.Handler.Warp.Response Network.Wai.Handler.Warp.ResponseHeader Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication Paths_warp Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 Ghc-Options: -Wall -threaded Build-Tool-Depends: hspec-discover:hspec-discover Build-Depends: base >= 4.8 && < 5 , QuickCheck , array , auto-update , bsb-http-chunked < 0.1 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2 , containers , directory , ghc-prim , hashable , hspec >= 1.3 , http-client , http-date , http-types >= 0.12 , http2 >= 5.0 && < 5.1 , 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 , word8 , unliftio if flag(x509) Build-Depends: crypton-x509 if impl(ghc < 8) Build-Depends: semigroups , transformers if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD if os(windows) Cpp-Options: -DWINDOWS Build-Depends: time , unix-compat >= 0.2 else Build-Depends: unix Other-modules: Network.Wai.Handler.Warp.MultiMap if impl(ghc >= 8) Default-Extensions: Strict StrictData Default-Language: Haskell2010 Benchmark parser Type: exitcode-stdio-1.0 Main-Is: Parser.hs other-modules: Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HashMap Network.Wai.Handler.Warp.Imports Network.Wai.Handler.Warp.MultiMap Network.Wai.Handler.Warp.Types HS-Source-Dirs: bench . Build-Depends: base >= 4.8 && < 5 , auto-update , bytestring , containers , gauge , hashable , http-date , http-types , network , network , recv , time-manager , unliftio if flag(x509) Build-Depends: crypton-x509 if impl(ghc < 8) Build-Depends: semigroups if (os(linux) || os(freebsd) || os(darwin)) && 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 Default-Language: Haskell2010 Source-Repository head Type: git Location: git://github.com/yesodweb/wai.git