warp 3.2.28 → 3.4.14
raw patch · 61 files changed
Files
- ChangeLog.md +276/−0
- Network/Wai/Handler/Warp.hs +272/−111
- Network/Wai/Handler/Warp/Buffer.hs +28/−78
- Network/Wai/Handler/Warp/Conduit.hs +46/−43
- Network/Wai/Handler/Warp/Counter.hs +40/−12
- Network/Wai/Handler/Warp/Date.hs +15/−7
- Network/Wai/Handler/Warp/FdCache.hs +47/−31
- Network/Wai/Handler/Warp/File.hs +122/−71
- Network/Wai/Handler/Warp/FileInfoCache.hs +64/−50
- Network/Wai/Handler/Warp/HTTP1.hs +306/−0
- Network/Wai/Handler/Warp/HTTP2.hs +135/−46
- Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs +0/−34
- Network/Wai/Handler/Warp/HTTP2/File.hs +25/−149
- Network/Wai/Handler/Warp/HTTP2/HPACK.hs +0/−130
- Network/Wai/Handler/Warp/HTTP2/Manager.hs +0/−95
- Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +33/−0
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +0/−418
- Network/Wai/Handler/Warp/HTTP2/Request.hs +78/−51
- Network/Wai/Handler/Warp/HTTP2/Response.hs +152/−0
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +0/−536
- Network/Wai/Handler/Warp/HTTP2/Types.hs +27/−320
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +0/−331
- Network/Wai/Handler/Warp/HashMap.hs +4/−10
- Network/Wai/Handler/Warp/Header.hs +65/−42
- Network/Wai/Handler/Warp/IO.hs +39/−19
- Network/Wai/Handler/Warp/Imports.hs +28/−16
- Network/Wai/Handler/Warp/Internal.hs +82/−37
- Network/Wai/Handler/Warp/MultiMap.hs +40/−60
- Network/Wai/Handler/Warp/PackInt.hs +9/−18
- Network/Wai/Handler/Warp/ReadInt.hs +10/−42
- Network/Wai/Handler/Warp/Recv.hs +0/−139
- Network/Wai/Handler/Warp/Request.hs +216/−174
- Network/Wai/Handler/Warp/RequestHeader.hs +42/−37
- Network/Wai/Handler/Warp/Response.hs +253/−156
- Network/Wai/Handler/Warp/ResponseHeader.hs +19/−28
- Network/Wai/Handler/Warp/Run.hs +339/−363
- Network/Wai/Handler/Warp/SendFile.hs +66/−59
- Network/Wai/Handler/Warp/Settings.hs +380/−128
- Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
- Network/Wai/Handler/Warp/Types.hs +117/−73
- Network/Wai/Handler/Warp/Windows.hs +11/−8
- Network/Wai/Handler/Warp/WithApplication.hs +54/−51
- bench/Parser.hs +157/−93
- test/BufferPoolSpec.hs +0/−47
- test/ConduitSpec.hs +18/−16
- test/ConnectionSpec.hs +74/−0
- test/ExceptionSpec.hs +29/−27
- test/FdCacheSpec.hs +1/−1
- test/FileSpec.hs +106/−19
- test/GracefulShutdownSpec.hs +83/−0
- test/HTTP.hs +14/−14
- test/PackIntSpec.hs +14/−0
- test/ReadIntSpec.hs +6/−4
- test/RequestSpec.hs +97/−73
- test/ResponseHeaderSpec.hs +14/−46
- test/ResponseSpec.hs +42/−36
- test/RunSpec.hs +265/−219
- test/SendFileSpec.hs +44/−40
- test/ServerStateSpec.hs +58/−0
- test/WithApplicationSpec.hs +36/−35
- warp.cabal +343/−261
ChangeLog.md view
@@ -1,3 +1,279 @@+# ChangeLog for warp++## 3.4.14++* Important bugfix to not deadlock on empty file descriptors if the cause of+ the file descriptor exhaustion is outside of the server's control.+ (i.e. the server does not have any running connections and can't use a file+ descriptor to create the next connection)+ [#1084](https://github.com/yesodweb/wai/pull/1084)++## 3.4.13.1++* Bugfix to fall back to "blocking `recv`" when on Windows systems and when+ using `network < 3.2.2`.+ [#1077](https://github.com/yesodweb/wai/pull/1077)++## 3.4.13++* Change graceful shutdown logic to stop accepting data from idle connections,+ but to wait for busy `Application`s, adding `Connection: close` headers to+ responses if the server is shutting down.+ This should make sure the server doesn't wait for idle keep-alive connections.+* Expose a broader way to access internal state like the open connection `Counter`+ and whether the server is currently `ShuttingDown` or not.+ Users can use `makeSettingsAndServerState` to get a `ServerState` while+ making `defaultSettings`.+ [#1071](https://github.com/yesodweb/wai/pull/1071)++## 3.4.12++* Respond with `Connection: close` header if connection is to be closed after a request.+ [#958](https://github.com/yesodweb/wai/pull/958)++## 3.4.11++* Expose a way to access the open connection `Counter` with `makeSettingsAndCounter`,+ and `getCount` to be able to monitor the current open connections.+* Added getter function to get the open connection counter from the `Settings` with+ `getOpenConnectionCounter`.+ [#1050](https://github.com/yesodweb/wai/pull/1050)++## 3.4.10++* Using newest dependencies++## 3.4.9++* New flag `include-warp-version` can be disabled to remove dependency on `Paths_warp`.+ [#1044](https://github.com/yesodweb/wai/pull/1044)++## 3.4.8++* Label the internal hack thread on Windows used to make socket+ listening interruptible.++## 3.4.7++* Using time-manager >= 0.2.++## 3.4.6++* Using `withHandle` of time-manager.++## 3.4.5++* Rethrowing asynchronous exceptions and preventing callsing+ `connClose` twice.+ [#1013](https://github.com/yesodweb/wai/pull/1013)++## 3.4.4++* Removing `unliftio`.++## 3.4.3++* Waiting untill the number of FDs desreases on EMFILE.+ [#1009](https://github.com/yesodweb/wai/pull/1009)++## 3.4.2++* serveConnection is re-exported from the Internal module.+ [#1007](https://github.com/yesodweb/wai/pull/1007)++## 3.4.1++* Using time-manager v0.1.0, and auto-update v0.2.0.+ [#986](https://github.com/yesodweb/wai/pull/986)++## 3.4.0++* Reworked request lines (`CRLF`) parsing: [#968](https://github.com/yesodweb/wai/pulls)+ * We do not accept multiline headers anymore.+ ([`RFC 7230`](https://www.rfc-editor.org/rfc/rfc7230#section-3.2.4) deprecated it 10 years ago)+ * Reworked request lines (`CRLF`) parsing to not unnecessarily copy bytestrings.+* Using http2 v5.1.0.+* `fourmolu` is used as an official formatter.++## 3.3.31++* Supporting http2 v5.0.++## 3.3.30++* Length of `ResponseBuilder` responses will now also be passed to the logger.+ [#946](https://github.com/yesodweb/wai/pull/946)+* Using `If-(None-)Match` headers simultaneously with `If-(Un)Modified-Since` headers now+ follow the RFC 9110 standard. So `If-(Un)Modified-Since` headers will be correctly ignored+ if their respective `-Match` counterpart is also present in the request headers.+ [#945](https://github.com/yesodweb/wai/pull/945)+* Fixed adding superfluous `Server` header when using HTTP/2.0 if response already has it.+ [#943](https://github.com/yesodweb/wai/pull/943)++## 3.3.29++* Preparing coming "http2" v4.2.0.++## 3.3.28++* Fix for the "-x509" flag+ [#935](https://github.com/yesodweb/wai/pull/935)++## 3.3.27++* Fixing busy loop due to eMFILE+ [#933](https://github.com/yesodweb/wai/pull/933)++## 3.3.26++* Using crypton instead of cryptonite.+ [#931](https://github.com/yesodweb/wai/pull/931)++## 3.3.25++* Catching up the signature change of openFd in the unix package v2.8.+ [#926](https://github.com/yesodweb/wai/pull/926)++## 3.3.24++* Switching the version of the "recv" package from 0.0.x to 0.1.x.++## 3.3.23++* Add `setAccept` for hooking the socket `accept` call.+ [#912](https://github.com/yesodweb/wai/pull/912)+* Removed some package dependencies from test suite+ [#902](https://github.com/yesodweb/wai/pull/902)+* Factored out `Network.Wai.Handler.Warp.Recv` to its own package `recv`.+ [#899](https://github.com/yesodweb/wai/pull/899)++## 3.3.22++* Creating a bigger buffer when the current one is too small to fit the Builder+ [#895](https://github.com/yesodweb/wai/pull/895)+* Using InvalidRequest instead of HTTP2Error+ [#890](https://github.com/yesodweb/wai/pull/890)++## 3.3.21++* Support GHC 9.4 [#889](https://github.com/yesodweb/wai/pull/889)++## 3.3.20++* Adding "x509" flag.+ [#871](https://github.com/yesodweb/wai/pull/871)++## 3.3.19++* Allowing the eMFILE exception in acceptNewConnection.+ [#831](https://github.com/yesodweb/wai/pull/831)++## 3.3.18++* Tidy up HashMap and MultiMap [#864](https://github.com/yesodweb/wai/pull/864)+* Support GHC 9.2 [#863](https://github.com/yesodweb/wai/pull/863)++## 3.3.17++* Modify exception handling to swallow async exceptions in forked thread [#850](https://github.com/yesodweb/wai/issues/850)+* Switch default forking function to not install the global exception handler (minor optimization) [#851](https://github.com/yesodweb/wai/pull/851)++## 3.3.16++* Move exception handling over to `unliftio` for better async exception support [#845](https://github.com/yesodweb/wai/issues/845)++## 3.3.15++* Using http2 v3.++## 3.3.14++* Drop support for GHC < 8.2.+* Fix header length calculation for `settingsMaxTotalHeaderLength`+ [#838](https://github.com/yesodweb/wai/pull/838)+* UTF-8 encoding in `exceptionResponseForDebug`.+ [#836](https://github.com/yesodweb/wai/pull/836)++## 3.3.13++* pReadMaker is exported from the Internal module.++## 3.3.12++* Fixing HTTP/2 logging relating to status and push.+* Adding QUIC constructor to Transport.++## 3.3.11++* Adding setAltSvc.+ [#801](https://github.com/yesodweb/wai/pull/801)+* Fixing timeout of builder for HTTP/1.1.+ [#800](https://github.com/yesodweb/wai/pull/800)+* `http2server` and `withII` are exported from `Internal` module.++## 3.3.10++* Convert ResourceVanished error to ConnectionClosedByPeer exception+ [#795](https://github.com/yesodweb/wai/pull/795)+* Expand the documentation for `setTimeout`.+ [#796](https://github.com/yesodweb/wai/pull/796)++## 3.3.9++* Don't insert Last-Modified: if exists.+ [#791](https://github.com/yesodweb/wai/pull/791)++## 3.3.8++* Maximum header size is configurable.+ [#781](https://github.com/yesodweb/wai/pull/781)+* Ignoring an exception from shutdown (gracefulClose).++## 3.3.7++* InvalidArgument (Bad file descriptor) is ignored in `receive`.+ [#787](https://github.com/yesodweb/wai/pull/787)++## 3.3.6++* Fixing a bug of thread killed in the case of event source with+ HTTP/2 (fixing #692 and #785)+* New APIs: clientCertificate to get client's certificate+ [#783](https://github.com/yesodweb/wai/pull/783)++## 3.3.5++* New APIs: setGracefulCloseTimeout1 and setGracefulCloseTimeout2.+ For HTTP/1.x, connections are closed immediately by default.+ gracefullClose is used for HTTP/2 by default.+ [#782](https://github.com/yesodweb/wai/pull/782)++## 3.3.4++* Setting isSecure of HTTP/2 correctly.++## 3.3.3++* Calling setOnException in HTTP/2.+ [#771](https://github.com/yesodweb/wai/pull/771)++## 3.3.2++* Fixing a bug of HTTP/2 without fd cache.++## 3.3.1++* Using gracefullClose of network 3.1.1 or later if available.+* If the first line of an HTTP request is really invalid,+ don't send an error response++## 3.3.0++* Switching from the original implementation to HTTP/2 server library.+ [#754](https://github.com/yesodweb/wai/pull/754)+* Breaking change: The type of `http2dataTrailers` is now+ `HTTP2Data -> TrailersMaker`.+ ## 3.2.28 * Using the Strict and StrictData language extensions for GHC >8.
Network/Wai/Handler/Warp.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} ---------------------------------------------------------@@ -34,104 +34,157 @@ -- * call the 'pauseTimeout' function -- -- For more information, see <https://github.com/yesodweb/wai/issues/351>.------ module Network.Wai.Handler.Warp ( -- * Run a Warp server+ -- | All of these automatically serve the same 'Application' over HTTP\/1, -- HTTP\/1.1, and HTTP\/2.- run- , runEnv- , runSettings- , runSettingsSocket+ run,+ runEnv,+ runSettings,+ runSettingsSocket,+ -- * Settings- , Settings- , defaultSettings+ Settings,+ defaultSettings,+ -- ** Setters- , setPort- , setHost- , setOnException- , setOnExceptionResponse- , setOnOpen- , setOnClose- , setTimeout- , setManager- , setFdCacheDuration- , setFileInfoCacheDuration- , setBeforeMainLoop- , setNoParsePath- , setInstallShutdownHandler- , setServerName- , setMaximumBodyFlush- , setFork- , setProxyProtocolNone- , setProxyProtocolRequired- , setProxyProtocolOptional- , setSlowlorisSize- , setHTTP2Disabled- , setLogger- , setServerPushLogger- , setGracefulShutdownTimeout+ 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+ getPort,+ getHost,+ getOnOpen,+ getOnClose,+ getOnException,+ getGracefulShutdownTimeout,+ getGracefulCloseTimeout1,+ getGracefulCloseTimeout2,+ getOpenConnectionCounter,+ getServerState,++ -- ** Internal server state+ --+ -- Creating 'Settings' with insight into the internal state of the server.+ --+ -- When using 'makeSettingsAndServerState', you will receive the 'ServerState'+ -- that will be used by @warp@ so that you can query things like the+ -- 'currentOpenConnections', and 'currentShuttingDownState'.+ ServerState,+ makeSettingsAndServerState,+ currentOpenConnections,+ currentShuttingDownState,++ -- *** STM versions+ currentOpenConnectionsSTM,+ currentShuttingDownStateSTM,++ -- ** Connection counter+ --+ -- /Deprecated in favor of 'ServerState'/+ makeSettingsAndCounter,+ Counter,+ getCount,+ -- ** Exception handler- , defaultOnException- , defaultShouldDisplayException+ defaultOnException,+ defaultShouldDisplayException,+ -- ** Exception response handler- , defaultOnExceptionResponse- , exceptionResponseForDebug+ defaultOnExceptionResponse,+ exceptionResponseForDebug,+ -- * Data types- , HostPreference- , Port- , InvalidRequest (..)+ HostPreference,+ Port,+ InvalidRequest (..),+ -- * Utilities- , pauseTimeout- , FileInfo(..)- , getFileInfo- , withApplication- , withApplicationSettings- , testWithApplication- , testWithApplicationSettings- , openFreePort+ pauseTimeout,+ FileInfo (..),+ getFileInfo,+#ifdef MIN_VERSION_crypton_x509+ clientCertificate,+#endif+ withApplication,+ withApplicationSettings,+ testWithApplication,+ testWithApplicationSettings,+ openFreePort,+ -- * Version- , warpVersion+ warpVersion,+ -- * HTTP/2+ -- ** HTTP2 data- , HTTP2Data- , http2dataPushPromise- , http2dataTrailers- , defaultHTTP2Data- , getHTTP2Data- , setHTTP2Data- , modifyHTTP2Data+ HTTP2Data,+ http2dataPushPromise,+ http2dataTrailers,+ defaultHTTP2Data,+ getHTTP2Data,+ setHTTP2Data,+ modifyHTTP2Data,+ -- ** Push promise- , PushPromise- , promisedPath- , promisedFile- , promisedResponseHeaders- , promisedWeight- , defaultPushPromise- ) where+ PushPromise,+ promisedPath,+ promisedFile,+ promisedResponseHeaders,+ promisedWeight,+ defaultPushPromise,+) where -import Control.Exception (SomeException, throwIO) import Data.Streaming.Network (HostPreference) import qualified Data.Vault.Lazy as Vault+import Control.Exception (SomeException, throwIO)+#ifdef MIN_VERSION_crypton_x509+import Data.X509+#endif import qualified Network.HTTP.Types as H-import Network.Socket (SockAddr)+import Network.Socket (SockAddr, Socket) import Network.Wai (Request, Response, vault) import System.TimeManager +import Network.Wai.Handler.Warp.Counter (Counter, getCount) import Network.Wai.Handler.Warp.FileInfoCache-import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)+import Network.Wai.Handler.Warp.HTTP2.Request (+ getHTTP2Data,+ modifyHTTP2Data,+ setHTTP2Data,+ ) import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Request-import Network.Wai.Handler.Warp.Response (warpVersion) import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types hiding (getFileInfo)@@ -141,20 +194,21 @@ -- -- Since 2.1.0 setPort :: Port -> Settings -> Settings-setPort x y = y { settingsPort = x }+setPort x y = y{settingsPort = x} -- | Interface to bind to. Default value: HostIPv4 -- -- Since 2.1.0 setHost :: HostPreference -> Settings -> Settings-setHost x y = y { settingsHost = x }+setHost x y = y{settingsHost = x} -- | What to do with exceptions thrown by either the application or server. -- Default: 'defaultOnException' -- -- Since 2.1.0-setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings-setOnException x y = y { settingsOnException = x }+setOnException+ :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings+setOnException x y = y{settingsOnException = x} -- | A function to create a `Response` when an exception occurs. -- Default: 'defaultOnExceptionResponse'@@ -171,7 +225,7 @@ -- -- Since 2.1.0 setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings-setOnExceptionResponse x y = y { settingsOnExceptionResponse = x }+setOnExceptionResponse x y = y{settingsOnExceptionResponse = x} -- | What to do when a connection is opened. When 'False' is returned, the -- connection is closed immediately. Otherwise, the connection is going on.@@ -179,26 +233,32 @@ -- -- Since 2.1.0 setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings-setOnOpen x y = y { settingsOnOpen = x }+setOnOpen x y = y{settingsOnOpen = x} -- | What to do when a connection is closed. Default: do nothing. -- -- Since 2.1.0 setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings-setOnClose x y = y { settingsOnClose = x }+setOnClose x y = y{settingsOnClose = x} --- | Timeout value in seconds. Default value: 30+-- | "Slow-loris" timeout lower-bound value in seconds. Connections where+-- network progress is made less frequently than this may be closed. In+-- practice many connections may be allowed to go without progress for up to+-- twice this amount of time. Note that this timeout is not applied to+-- application code, only network progress. --+-- Default value: 30+-- -- Since 2.1.0 setTimeout :: Int -> Settings -> Settings-setTimeout x y = y { settingsTimeout = x }+setTimeout x y = y{settingsTimeout = x} -- | Use an existing timeout manager instead of spawning a new one. If used, -- 'settingsTimeout' is ignored. -- -- Since 2.1.0 setManager :: Manager -> Settings -> Settings-setManager x y = y { settingsManager = Just x }+setManager x y = y{settingsManager = Just x} -- | Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. --@@ -214,7 +274,7 @@ -- -- Since 3.0.13 setFdCacheDuration :: Int -> Settings -> Settings-setFdCacheDuration x y = y { settingsFdCacheDuration = x }+setFdCacheDuration x y = y{settingsFdCacheDuration = x} -- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. --@@ -228,7 +288,7 @@ -- -- Default value: 0 setFileInfoCacheDuration :: Int -> Settings -> Settings-setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }+setFileInfoCacheDuration x y = y{settingsFileInfoCacheDuration = x} -- | Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start@@ -238,7 +298,7 @@ -- -- Since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings-setBeforeMainLoop x y = y { settingsBeforeMainLoop = x }+setBeforeMainLoop x y = y{settingsBeforeMainLoop = x} -- | Perform no parsing on the rawPathInfo. --@@ -248,7 +308,7 @@ -- -- Since 2.1.0 setNoParsePath :: Bool -> Settings -> Settings-setNoParsePath x y = y { settingsNoParsePath = x }+setNoParsePath x y = y{settingsNoParsePath = x} -- | Get the listening port. --@@ -298,7 +358,7 @@ -- -- 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 custon shutdown action will run /and/ all+-- 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:@@ -312,7 +372,7 @@ -- -- Since 3.0.1 setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings-setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x }+setInstallShutdownHandler x y = y{settingsInstallShutdownHandler = x} -- | Default server name to be sent as the \"Server:\" header -- if an application does not set one.@@ -321,7 +381,7 @@ -- -- Since 3.0.2 setServerName :: ByteString -> Settings -> Settings-setServerName x y = y { settingsServerName = x }+setServerName x y = y{settingsServerName = x} -- | The maximum number of bytes to flush from an unconsumed request body. --@@ -338,7 +398,7 @@ setMaximumBodyFlush :: Maybe Int -> Settings -> Settings setMaximumBodyFlush x y | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive"- | otherwise = y { settingsMaximumBodyFlush = x }+ | otherwise = y{settingsMaximumBodyFlush = x} -- | Code to fork a new thread to accept a connection. --@@ -348,14 +408,26 @@ -- Default: void . forkIOWithUnmask -- -- Since 3.0.4-setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings-setFork fork' s = s { settingsFork = fork' }+setFork+ :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings+setFork fork' s = s{settingsFork = fork'} +-- | Code to accept a new connection.+--+-- Useful if you need to provide connected sockets from something other+-- than a standard accept call.+--+-- Default: 'defaultAccept'+--+-- Since 3.3.24+setAccept :: (Socket -> IO (Socket, SockAddr)) -> Settings -> Settings+setAccept accept' s = s{settingsAccept = accept'}+ -- | Do not use the PROXY protocol. -- -- Since 3.0.5 setProxyProtocolNone :: Settings -> Settings-setProxyProtocolNone y = y { settingsProxyProtocol = ProxyProtocolNone }+setProxyProtocolNone y = y{settingsProxyProtocol = ProxyProtocolNone} -- | Require PROXY header. --@@ -371,14 +443,14 @@ -- -- Since 3.0.5 setProxyProtocolRequired :: Settings -> Settings-setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired }+setProxyProtocolRequired y = y{settingsProxyProtocol = ProxyProtocolRequired} -- | Use the PROXY header if it exists, but also accept -- connections without the header. See 'setProxyProtocolRequired'. -- -- WARNING: This is contrary to the PROXY protocol specification and -- using it can indicate a security problem with your--- architecture if the web server is directly accessable+-- architecture if the web server is directly accessible -- to the public, since it would allow easy IP address -- spoofing. However, it can be useful in some cases, -- such as if a load balancer health check uses regular@@ -387,35 +459,39 @@ -- -- Since 3.0.5 setProxyProtocolOptional :: Settings -> Settings-setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional }+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 }+setSlowlorisSize x y = y{settingsSlowlorisSize = x} -- | Disable HTTP2. -- -- Since 3.1.7 setHTTP2Disabled :: Settings -> Settings-setHTTP2Disabled y = y { settingsHTTP2Enabled = False }+setHTTP2Disabled y = y{settingsHTTP2Enabled = False} -- | Setting a log function. -- -- Since 3.X.X-setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -- ^ request, status, maybe file-size- -> Settings- -> Settings-setLogger lgr y = y { settingsLogger = lgr }+setLogger+ :: (Request -> H.Status -> Maybe Integer -> IO ())+ -- ^ request, status, maybe file-size+ -> Settings+ -> Settings+setLogger lgr y = y{settingsLogger = lgr} -- | Setting a log function for HTTP/2 server push. -- -- Since: 3.2.7-setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size- -> Settings- -> Settings-setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }+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@@ -426,10 +502,33 @@ -- response to a UNIX signal. -- -- Since 3.2.8-setGracefulShutdownTimeout :: Maybe Int- -> Settings -> Settings-setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }+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@@ -456,4 +555,66 @@ -- -- Since 3.1.10 getFileInfo :: Request -> FilePath -> IO FileInfo-getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault+getFileInfo =+ fromMaybe (\_ -> throwIO (userError "getFileInfo"))+ . Vault.lookup getFileInfoKey+ . vault++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/1.x. 0 means uses immediate close.+-- Default: 0.+--+-- Since 3.3.5+setGracefulCloseTimeout1 :: Int -> Settings -> Settings+setGracefulCloseTimeout1 x y = y{settingsGracefulCloseTimeout1 = x}++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/1.x. 0 means uses immediate close.+--+-- Since 3.3.5+getGracefulCloseTimeout1 :: Settings -> Int+getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/2. 0 means uses immediate close.+-- Default: 2000.+--+-- Since 3.3.5+setGracefulCloseTimeout2 :: Int -> Settings -> Settings+setGracefulCloseTimeout2 x y = y{settingsGracefulCloseTimeout2 = x}++-- | A timeout to limit the time (in milliseconds) waiting for+-- FIN for HTTP/2. 0 means uses immediate close.+--+-- Since 3.3.5+getGracefulCloseTimeout2 :: Settings -> Int+getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2++-- | Get the connection counter, if one was configured.+-- Use 'getCount' on the returned 'Counter' to read the current value.+--+-- See 'makeSettingsAndCounter' to create settings with a counter.+--+-- /DEPRECATED in favor of 'getServerState'/+--+-- Since 3.4.11+getOpenConnectionCounter :: Settings -> Maybe Counter+getOpenConnectionCounter = settingsConnectionCounter++-- | Get the 'ServerState', if one was configured.+-- Use things like 'currentOpenConnections' and 'currentShuttingDownState' to+-- query information about the current state of the server.+--+-- See 'makeSettingsAndServerState' to create 'Settings' with a 'ServerState'.+--+-- Since 3.4.12+getServerState :: Settings -> Maybe ServerState+getServerState = settingsServerState++#ifdef MIN_VERSION_crypton_x509+-- | Getting information of client certificate.+--+-- Since 3.3.5+clientCertificate :: Request -> Maybe CertificateChain+clientCertificate = join . Vault.lookup getClientCertificateKey . vault+#endif
Network/Wai/Handler/Warp/Buffer.hs view
@@ -1,38 +1,37 @@-{-# LANGUAGE BangPatterns #-}- module Network.Wai.Handler.Warp.Buffer (- bufferSize- , allocateBuffer- , freeBuffer- , mallocBS- , newBufferPool- , withBufferPool- , toBuilderBuffer- , copy- , bufferIO- ) where+ createWriteBuffer,+ allocateBuffer,+ freeBuffer,+ toBuilderBuffer,+ bufferIO,+) where -import qualified Data.ByteString as BS-import Data.ByteString.Internal (memcpy)-import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)-import Data.IORef (newIORef, readIORef, writeIORef)+import Data.IORef (IORef, readIORef) import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..)) import Foreign.ForeignPtr-import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree)-import Foreign.Ptr (castPtr, plusPtr)+import Foreign.Marshal.Alloc (free, mallocBytes)+import Foreign.Ptr (plusPtr)+import Network.Socket.BufferPool import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- --- | The default size of the write buffer: 16384 (2^14 = 1024 * 16).--- This is the maximum size of TLS record.--- This is also the maximum size of HTTP/2 frame payload--- (excluding frame header).-bufferSize :: BufSize-bufferSize = 16384+-- | Allocate a buffer of the given size and wrap it in a 'WriteBuffer'+-- containing that size and a finalizer.+createWriteBuffer :: BufSize -> IO WriteBuffer+createWriteBuffer size = do+ bytes <- allocateBuffer size+ return+ WriteBuffer+ { bufBuffer = bytes+ , bufSize = size+ , bufFree = freeBuffer bytes+ } +----------------------------------------------------------------+ -- | Allocating a buffer with malloc(). allocateBuffer :: Int -> IO Buffer allocateBuffer = mallocBytes@@ -42,66 +41,17 @@ freeBuffer = free ------------------------------------------------------------------largeBufferSize :: Int-largeBufferSize = 16384--minBufferSize :: Int-minBufferSize = 2048--newBufferPool :: IO BufferPool-newBufferPool = newIORef BS.empty--mallocBS :: Int -> IO ByteString-mallocBS size = do- ptr <- allocateBuffer size- fptr <- newForeignPtr finalizerFree ptr- return $! PS fptr 0 size-{-# INLINE mallocBS #-}--usefulBuffer :: ByteString -> Bool-usefulBuffer buffer = BS.length buffer >= minBufferSize-{-# INLINE usefulBuffer #-}--getBuffer :: BufferPool -> IO ByteString-getBuffer pool = do- buffer <- readIORef pool- if usefulBuffer buffer then return buffer else mallocBS largeBufferSize-{-# INLINE getBuffer #-}--putBuffer :: BufferPool -> ByteString -> IO ()-putBuffer pool buffer = writeIORef pool buffer-{-# INLINE putBuffer #-}--withForeignBuffer :: ByteString -> ((Buffer, BufSize) -> IO Int) -> IO Int-withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s, l)-{-# INLINE withForeignBuffer #-}--withBufferPool :: BufferPool -> ((Buffer, BufSize) -> IO Int) -> IO ByteString-withBufferPool pool f = do- buffer <- getBuffer pool- consumed <- withForeignBuffer buffer f- putBuffer pool $! unsafeDrop consumed buffer- return $! unsafeTake consumed buffer-{-# INLINE withBufferPool #-}------------------------------------------------------------------ -- -- Utilities -- -toBuilderBuffer :: Buffer -> BufSize -> IO B.Buffer-toBuilderBuffer ptr size = do+toBuilderBuffer :: IORef WriteBuffer -> IO B.Buffer+toBuilderBuffer writeBufferRef = do+ writeBuffer <- readIORef writeBufferRef+ let ptr = bufBuffer writeBuffer+ size = bufSize writeBuffer fptr <- newForeignPtr_ ptr return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)---- | Copying the bytestring to the buffer.--- This function returns the point where the next copy should start.-copy :: Buffer -> ByteString -> IO Buffer-copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do- memcpy ptr (p `plusPtr` o) (fromIntegral l)- return $! ptr `plusPtr` l-{-# INLINE copy #-} bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO () bufferIO ptr siz io = do
Network/Wai/Handler/Warp/Conduit.hs view
@@ -2,9 +2,10 @@ module Network.Wai.Handler.Warp.Conduit where -import Control.Exception+import Control.Exception (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I+import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types@@ -29,46 +30,44 @@ if count == 0 then return S.empty else do+ bs <- readSource src - bs <- readSource src+ -- If no chunk available, then there aren't enough bytes in the+ -- stream. Throw a ConnectionClosedByPeer+ when (S.null bs) $ throwIO ConnectionClosedByPeer - -- If no chunk available, then there aren't enough bytes in the- -- stream. Throw a ConnectionClosedByPeer- when (S.null bs) $ throwIO ConnectionClosedByPeer+ let -- How many of the bytes in this chunk to send downstream+ toSend = min count (S.length bs)+ -- How many bytes will still remain to be sent downstream+ count' = count - toSend - let -- How many of the bytes in this chunk to send downstream- toSend = min count (S.length bs)- -- How many bytes will still remain to be sent downstream- count' = count - toSend- case () of- ()- -- The expected count is greater than the size of the+ I.writeIORef ref count'++ if count' > 0+ then -- The expected count is greater than the size of the -- chunk we just read. Send the entire chunk -- downstream, and then loop on this function for the -- next chunk.- | count' > 0 -> do- I.writeIORef ref count' return bs-- -- Some of the bytes in this chunk should not be sent- -- downstream. Split up the chunk into the sent and- -- not-sent parts, add the not-sent parts onto the new- -- source, and send the rest of the chunk downstream.- | otherwise -> do+ else do+ -- Some of the bytes in this chunk should not be sent+ -- downstream. Split up the chunk into the sent and+ -- not-sent parts, add the not-sent parts onto the new+ -- source, and send the rest of the chunk downstream. let (x, y) = S.splitAt toSend bs leftoverSource src y- assert (count' == 0) $ I.writeIORef ref count'- return x+ assert (count' == 0) $ return x ---------------------------------------------------------------- data CSource = CSource !Source !(I.IORef ChunkState) -data ChunkState = NeedLen- | NeedLenNewline- | HaveLen Word- | DoneChunking- deriving Show+data ChunkState+ = NeedLen+ | NeedLenNewline+ | HaveLen Word+ | DoneChunking+ deriving (Show) mkCSource :: Source -> IO CSource mkCSource src = do@@ -106,17 +105,19 @@ bs <- readSource src case S.uncons bs of Nothing -> return ()- Just (13, bs') -> dropLF bs'- Just (10, bs') -> leftoverSource src bs'- Just _ -> leftoverSource src bs+ Just (w8, bs')+ | w8 == _cr -> dropLF bs'+ | w8 == _lf -> leftoverSource src bs'+ | otherwise -> leftoverSource src bs dropLF bs = case S.uncons bs of Nothing -> do bs2 <- readSource' src unless (S.null bs2) $ dropLF bs2- Just (10, bs') -> leftoverSource src bs'- Just _ -> leftoverSource src bs+ Just (w8, bs') ->+ leftoverSource src $+ if w8 == _lf then bs' else bs go NeedLen = getLen go NeedLenNewline = dropCRLF >> getLen@@ -139,17 +140,18 @@ return S.empty else do (x, y) <-- case S.break (== 10) bs of+ case S.break (== _lf) bs of (x, y) | S.null y -> do bs2 <- readSource' src- return $ if S.null bs2- then (x, y)- else S.break (== 10) $ bs `S.append` bs2+ return $+ if S.null bs2+ then (x, y)+ else S.break (== _lf) $ bs `S.append` bs2 | otherwise -> return (x, y) let w =- S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0- $ S.takeWhile isHexDigit x+ S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $+ S.takeWhile isHexDigit x let y' = S.drop 1 y y'' <-@@ -159,11 +161,12 @@ withLen w y'' hexToWord w- | w < 58 = w - 48- | w < 71 = w - 55+ | w <= _9 = w - _0+ | w <= _F = w - 55 | otherwise = w - 87 isHexDigit :: Word8 -> Bool-isHexDigit w = w >= 48 && w <= 57- || w >= 65 && w <= 70- || w >= 97 && w <= 102+isHexDigit w =+ w >= _0 && w <= _9+ || w >= _A && w <= _F+ || w >= _a && w <= _f
Network/Wai/Handler/Warp/Counter.hs view
@@ -1,30 +1,58 @@ {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Counter (- Counter- , newCounter- , waitForZero- , increase- , decrease- ) where+ Counter,+ newCounter,+ HasDecreased (..),+ waitForZero,+ increase,+ decrease,+ waitForDecreased,+ getCount,+ getCountSTM,+) where 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- unless (x == 0) retry+waitForZero (Counter var) = atomically $ do+ x <- readTVar var+ when (x > 0) retry +data HasDecreased = HasDecreased | NoConnections+ deriving (Eq, Show)++waitForDecreased :: Counter -> IO HasDecreased+waitForDecreased (Counter var) = do+ n0 <- atomically $ readTVar var+ if n0 <= 0+ then pure NoConnections+ else atomically $ do+ n <- readTVar var+ check (n < n0)+ pure HasDecreased+ increase :: Counter -> IO ()-increase (Counter ref) = atomically $ modifyTVar' ref $ \x -> x + 1+increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1 decrease :: Counter -> IO ()-decrease (Counter ref) = atomically $ modifyTVar' ref $ \x -> x - 1+decrease (Counter var) = atomically $ modifyTVar' var $ \x -> x - 1++-- | Get the current count of open connections.+--+-- Since 3.4.11+getCount :: Counter -> IO Int+getCount (Counter var) = readTVarIO var++-- | Get the current count in an 'STM' transaction.+--+-- Since 3.4.13+getCountSTM :: Counter -> STM Int+getCountSTM (Counter tvar) = readTVar tvar
Network/Wai/Handler/Warp/Date.hs view
@@ -1,11 +1,16 @@ {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Date (- withDateCache- , GMTDate- ) where+ withDateCache,+ GMTDate,+) where -import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)+import Control.AutoUpdate (+ defaultUpdateSettings,+ mkAutoUpdate,+ updateAction,+ updateThreadName,+ ) import Data.ByteString import Network.HTTP.Date @@ -25,9 +30,12 @@ withDateCache action = initialize >>= action initialize :: IO (IO GMTDate)-initialize = mkAutoUpdate defaultUpdateSettings {- updateAction = formatHTTPDate <$> getCurrentHTTPDate- }+initialize =+ mkAutoUpdate+ defaultUpdateSettings+ { updateAction = formatHTTPDate <$> getCurrentHTTPDate+ , updateThreadName = "Date cacher (AutoUpdate)"+ } #ifdef WINDOWS uToH :: UTCTime -> HTTPDate
Network/Wai/Handler/Warp/FdCache.hs view
@@ -1,24 +1,32 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} -- | File descriptor cache to avoid locks in kernel.- module Network.Wai.Handler.Warp.FdCache (- withFdCache- , Fd- , Refresh+ withFdCache,+ Fd,+ Refresh, #ifndef WINDOWS- , openFile- , closeFile- , setFileCloseOnExec+ closeFile,+ openFile,+ setFileCloseOnExec, #endif- ) where+) where #ifndef WINDOWS-import Control.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)+import System.Posix.IO (+ FdOption (CloseOnExec),+ OpenFileFlags (..),+ OpenMode (ReadOnly),+ closeFd,+ defaultFileFlags,+ openFd,+ setFdOption,+ )+import Control.Exception (bracket) #endif import System.Posix.Types (Fd) @@ -33,15 +41,17 @@ ---------------------------------------------------------------- -- | Creating 'MutableFdCache' and executing the action in the second--- argument. The first argument is a cache duration in second.+-- argument. The first argument is a cache duration in microseconds. withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a #ifdef WINDOWS-withFdCache _ action = action getFdNothing+withFdCache _ action = action getFdNothing #else-withFdCache 0 action = action getFdNothing-withFdCache duration action = bracket (initialize duration)- terminate- (action . getFd)+withFdCache 0 action = action getFdNothing+withFdCache duration action =+ bracket+ (initialize duration)+ terminate+ (action . getFd) ---------------------------------------------------------------- @@ -67,7 +77,11 @@ openFile :: FilePath -> IO Fd openFile path = do- fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=False}+#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 @@ -85,7 +99,7 @@ type FdCache = MultiMap FdEntry -- | Mutable Fd cacher.-newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath, FdEntry)) fdCache :: MutableFdCache -> IO FdCache fdCache (MutableFdCache reaper) = reaperRead reaper@@ -95,27 +109,29 @@ ---------------------------------------------------------------- --- The first argument is a cache duration in second.+-- The first argument is a cache duration in microseconds. initialize :: Int -> IO MutableFdCache initialize duration = MutableFdCache <$> mkReaper settings where- settings = defaultReaperSettings {- reaperAction = clean- , reaperDelay = duration- , reaperCons = uncurry insert- , reaperNull = isEmpty- , reaperEmpty = empty- }+ settings =+ defaultReaperSettings+ { reaperAction = clean+ , reaperDelay = duration+ , reaperCons = uncurry insert+ , reaperNull = isEmpty+ , reaperEmpty = empty+ , reaperThreadName = "Fd cacher (Reaper) "+ } clean :: FdCache -> IO (FdCache -> FdCache) clean old = do new <- pruneWith old prune return $ merge new where- prune (_,FdEntry fd mst) = status mst >>= act+ prune (_, FdEntry fd mst) = status mst >>= act where- act Active = inactive mst >> return True- act Inactive = closeFd fd >> return False+ act Active = inactive mst >> return True+ act Inactive = closeFd fd >> return False ---------------------------------------------------------------- @@ -134,7 +150,7 @@ where get Nothing = do ent@(FdEntry fd mst) <- newFdEntry path- reaperAdd reaper (path,ent)+ reaperAdd reaper (path, ent) return (Just fd, refresh mst) get (Just (FdEntry fd mst)) = do refresh mst
Network/Wai/Handler/Warp/File.hs view
@@ -1,13 +1,13 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.File (- RspFileInfo(..)- , conditionalRequest- , addContentHeadersForFilePart- , H.parseByteRanges- ) where+ RspFileInfo (..),+ conditionalRequest,+ addContentHeadersForFilePart,+ H.parseByteRanges,+) where import Data.Array ((!)) import qualified Data.ByteString.Char8 as C8 (pack)@@ -21,33 +21,53 @@ 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)+data RspFileInfo+ = WithoutBody H.Status+ | WithBody H.Status H.ResponseHeaders Integer Integer+ deriving (Eq, Show) ---------------------------------------------------------------- -conditionalRequest :: I.FileInfo- -> H.ResponseHeaders -> IndexedHeader- -> RspFileInfo-conditionalRequest finfo hs0 reqidx = case condition of+conditionalRequest+ :: I.FileInfo+ -> H.ResponseHeaders+ -> H.Method+ -> IndexedHeader+ -- ^ Response+ -> IndexedHeader+ -- ^ Request+ -> RspFileInfo+conditionalRequest finfo hs0 method rspidx reqidx = case condition of nobody@(WithoutBody _) -> nobody- WithBody s _ off len -> let !hs = (H.hLastModified,date) :- addContentHeaders hs0 off len size- in WithBody s hs off len+ WithBody s _ off len ->+ let !hs1 = addContentHeaders hs0 off len size+ !hs = case rspidx ! fromEnum ResLastModified of+ Just _ -> hs1+ Nothing -> (H.hLastModified, date) : hs1+ in WithBody s hs off len where !mtime = I.fileInfoTime finfo- !size = I.fileInfoSize finfo- !date = I.fileInfoDate finfo- !mcondition = ifmodified reqidx size mtime- <|> ifunmodified reqidx size mtime- <|> ifrange reqidx size mtime+ !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 ----------------------------------------------------------------@@ -63,51 +83,68 @@ ---------------------------------------------------------------- -ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo-ifmodified reqidx size mtime = do+ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo+ifmodified reqidx mtime method = do date <- ifModifiedSince reqidx- return $ if date /= mtime- then unconditional reqidx size- else WithoutBody H.notModified304+ -- According to RFC 9110:+ -- "A recipient MUST ignore If-Modified-Since if the request+ -- contains an If-None-Match header field; [...]"+ guard . isNothing $ reqidx ! fromEnum ReqIfNoneMatch+ -- "A recipient MUST ignore the If-Modified-Since header field+ -- if [...] the request method is neither GET nor HEAD."+ guard $ method == H.methodGet || method == H.methodHead+ guard $ date == mtime || date > mtime+ Just $ WithoutBody H.notModified304 -ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo-ifunmodified reqidx size mtime = do+ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo+ifunmodified reqidx mtime = do date <- ifUnmodifiedSince reqidx- return $ if date == mtime- then unconditional reqidx size- else WithoutBody H.preconditionFailed412+ -- According to RFC 9110:+ -- "A recipient MUST ignore If-Unmodified-Since if the request+ -- contains an If-Match header field; [...]"+ guard . isNothing $ reqidx ! fromEnum ReqIfMatch+ guard $ date /= mtime && date < mtime+ Just $ WithoutBody H.preconditionFailed412 -ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo-ifrange reqidx size mtime = do+-- TODO: Should technically also strongly match on ETags.+ifrange :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo+ifrange reqidx mtime method size = do+ -- According to RFC 9110:+ -- "When the method is GET and both Range and If-Range are+ -- present, evaluate the If-Range precondition:" date <- ifRange reqidx- rng <- reqidx ! fromEnum ReqRange- return $ if date == mtime- then parseRange rng size- else WithBody H.ok200 [] 0 size+ rng <- reqidx ! fromEnum ReqRange+ guard $ method == H.methodGet+ return $+ if date == mtime+ then parseRange rng size+ else WithBody H.ok200 [] 0 size unconditional :: IndexedHeader -> Integer -> RspFileInfo-unconditional reqidx size = case reqidx ! fromEnum ReqRange of- Nothing -> WithBody H.ok200 [] 0 size- Just rng -> parseRange rng size+unconditional reqidx =+ case reqidx ! fromEnum ReqRange of+ Nothing -> WithBody H.ok200 [] 0+ Just rng -> parseRange rng ---------------------------------------------------------------- parseRange :: ByteString -> Integer -> RspFileInfo parseRange rng size = case 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+ 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)+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) ---------------------------------------------------------------- @@ -116,24 +153,37 @@ 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 "")+ 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+ :: 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'+ | 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+ !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges, "bytes") : hs -- | --@@ -141,7 +191,8 @@ -- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")] -- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) -- [("Content-Length","16"),("Accept-Ranges","bytes")]-addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders+addContentHeadersForFilePart+ :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders addContentHeadersForFilePart hs part = addContentHeaders hs off len size where off = filePartOffset part
Network/Wai/Handler/Warp/FileInfoCache.hs view
@@ -1,15 +1,20 @@-{-# LANGUAGE RecordWildCards, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} module Network.Wai.Handler.Warp.FileInfoCache (- FileInfo(..)- , withFileInfoCache- , getInfo -- test purpose only- ) where+ FileInfo (..),+ withFileInfoCache,+ getInfo, -- test purpose only+) where -import Control.Exception as E+import Control.Exception (bracket, onException, throwIO) import Control.Reaper import Network.HTTP.Date+#if WINDOWS import System.PosixCompat.Files+#else+import System.Posix.Files+#endif import Network.Wai.Handler.Warp.HashMap (HashMap) import qualified Network.Wai.Handler.Warp.HashMap as M@@ -18,16 +23,19 @@ ---------------------------------------------------------------- -- | File information.-data FileInfo = FileInfo {- fileInfoName :: !FilePath- , fileInfoSize :: !Integer- , fileInfoTime :: HTTPDate -- ^ Modification time- , fileInfoDate :: ByteString -- ^ Modification time in the GMT format- } deriving (Eq, Show)+data FileInfo = FileInfo+ { fileInfoName :: !FilePath+ , fileInfoSize :: !Integer+ , fileInfoTime :: HTTPDate+ -- ^ Modification time+ , fileInfoDate :: ByteString+ -- ^ Modification time in the GMT format+ }+ deriving (Eq, Show) data Entry = Negative | Positive FileInfo type Cache = HashMap Entry-type FileInfoCache = Reaper Cache (FilePath,Entry)+type FileInfoCache = Reaper Cache (FilePath, Entry) ---------------------------------------------------------------- @@ -37,19 +45,20 @@ fs <- getFileStatus path -- file access let regular = not (isDirectory fs) readable = fileMode fs `intersectFileModes` ownerReadMode /= 0- if regular && readable then do- let time = epochTimeToHTTPDate $ modificationTime fs- date = formatHTTPDate time- size = fromIntegral $ fileSize fs- info = FileInfo {- fileInfoName = path- , fileInfoSize = size- , fileInfoTime = time- , fileInfoDate = date- }- return info- else- throwIO (userError "FileInfoCache:getInfo")+ if regular && readable+ then do+ let time = epochTimeToHTTPDate $ modificationTime fs+ date = formatHTTPDate time+ size = fromIntegral $ fileSize fs+ info =+ FileInfo+ { fileInfoName = path+ , fileInfoSize = size+ , fileInfoTime = time+ , fileInfoDate = date+ }+ return info+ else throwIO (userError "FileInfoCache:getInfo") getInfoNaive :: FilePath -> IO FileInfo getInfoNaive = getInfo@@ -57,49 +66,54 @@ ---------------------------------------------------------------- getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo-getAndRegisterInfo reaper@Reaper{..} path = do- cache <- reaperRead+getAndRegisterInfo reaper path = do+ cache <- reaperRead reaper case M.lookup path cache of- Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")+ Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x- Nothing -> positive reaper path- `E.onException` negative reaper path+ Nothing ->+ positive reaper path+ `onException` negative reaper path positive :: FileInfoCache -> FilePath -> IO FileInfo-positive Reaper{..} path = do+positive reaper path = do info <- getInfo path- reaperAdd (path, Positive info)+ reaperAdd reaper (path, Positive info) return info negative :: FileInfoCache -> FilePath -> IO FileInfo-negative Reaper{..} path = do- reaperAdd (path, Negative)+negative reaper path = do+ reaperAdd reaper (path, Negative) throwIO (userError "FileInfoCache:negative") ---------------------------------------------------------------- -- | Creating a file information cache -- and executing the action in the second argument.--- The first argument is a cache duration in second.-withFileInfoCache :: Int- -> ((FilePath -> IO FileInfo) -> IO a)- -> IO a-withFileInfoCache 0 action = action getInfoNaive+-- The first argument is a cache duration in microseconds.+withFileInfoCache+ :: Int+ -> ((FilePath -> IO FileInfo) -> IO a)+ -> IO a+withFileInfoCache 0 action = action getInfoNaive withFileInfoCache duration action =- E.bracket (initialize duration)- terminate- (action . getAndRegisterInfo)+ 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- }+ settings =+ defaultReaperSettings+ { reaperAction = override+ , reaperDelay = duration+ , reaperCons = \(path, v) -> M.insert path v+ , reaperNull = M.isEmpty+ , reaperEmpty = M.empty+ , reaperThreadName = "File info cacher (Reaper)"+ } override :: Cache -> IO (Cache -> Cache) override _ = return $ const M.empty
+ Network/Wai/Handler/Warp/HTTP1.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP1 (+ http1,+) where++import qualified Control.Concurrent as Conc (yield)+import Control.Exception (SomeException, catch, fromException, throwIO, try)+import qualified Data.ByteString as BS+import Data.Char (chr)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Word8 (_cr, _space)+import Network.Socket (SockAddr (SockAddrInet, SockAddrInet6))+import Network.Wai+import Network.Wai.Internal (ResponseReceived (ResponseReceived))+import qualified System.TimeManager as T+import "iproute" Data.IP (toHostAddress, toHostAddress6)++import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Imports hiding (readInt)+import Network.Wai.Handler.Warp.ReadInt+import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types++http1+ :: Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> ByteString+ -> IO ()+http1 settings ii conn transport app origAddr th bs0 = do+ istatus <- newIORef True+ src <- mkSource (wrappedRecv conn istatus (settingsSlowlorisSize settings))+ leftoverSource src bs0+ addr <- getProxyProtocolAddr src+ http1server settings ii conn transport app addr th istatus src+ where+ wrappedRecv Connection{connRecv = recv} istatus slowlorisSize = do+ bs <- recv+ unless (BS.null bs) $ do+ writeIORef istatus True+ when (BS.length bs >= slowlorisSize) $ T.tickle th+ return bs++ getProxyProtocolAddr src =+ case settingsProxyProtocol settings of+ ProxyProtocolNone ->+ return origAddr+ ProxyProtocolRequired -> do+ seg <- readSource src+ parseProxyProtocolHeader src seg+ ProxyProtocolOptional -> do+ seg <- readSource src+ if BS.isPrefixOf "PROXY " seg+ then parseProxyProtocolHeader src seg+ else do+ leftoverSource src seg+ return origAddr++ parseProxyProtocolHeader src seg = do+ let (header, seg') = BS.break (== _cr) seg+ maybeAddr = case BS.split _space header of+ ["PROXY", "TCP4", clientAddr, _, clientPort, _] ->+ case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of+ [a] ->+ Just+ ( SockAddrInet+ (readInt clientPort)+ (toHostAddress a)+ )+ _ -> Nothing+ ["PROXY", "TCP6", clientAddr, _, clientPort, _] ->+ case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of+ [a] ->+ Just+ ( SockAddrInet6+ (readInt clientPort)+ 0+ (toHostAddress6 a)+ 0+ )+ _ -> Nothing+ ("PROXY" : "UNKNOWN" : _) ->+ Just origAddr+ _ ->+ Nothing+ case maybeAddr of+ Nothing -> throwIO (BadProxyHeader (decodeAscii header))+ Just a -> do+ leftoverSource src (BS.drop 2 seg') -- drop CRLF+ return a++ decodeAscii = map (chr . fromEnum) . BS.unpack++http1server+ :: Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> IORef Bool+ -> Source+ -> IO ()+http1server settings ii conn transport app addr th istatus src =+ loop FirstRequest `catch` handler+ where+ handler e+ -- See comment below referencing+ -- https://github.com/yesodweb/wai/issues/618+ | Just NoKeepAliveRequest <- fromException e = return ()+ -- No valid request+ | Just (BadFirstLine _) <- fromException e = return ()+ | isAsyncException e = throwIO e+ | otherwise = do+ _ <-+ sendErrorResponse+ settings+ ii+ conn+ th+ istatus+ defaultRequest{remoteHost = addr}+ e+ throwIO e++ loop firstRequest = do+ (req, mremainingRef, idxhdr, nextBodyFlush) <-+ recvRequest firstRequest settings conn ii th addr src transport+ keepAlive <-+ processRequest+ settings+ ii+ conn+ app+ th+ istatus+ src+ req+ mremainingRef+ idxhdr+ nextBodyFlush+ `catch` \e -> do+ settingsOnException settings (Just req) e+ -- Don't throw the error again to prevent calling settingsOnException twice.+ return CloseConnection++ -- When doing a keep-alive connection, the other side may just+ -- close the connection. We don't want to treat that as an+ -- exceptional situation, so we pass in SubsequentRequest to http1 (which+ -- in turn passes in SubsequentRequest to recvRequest), indicating that+ -- this is not the first request. If, when trying to read the+ -- request headers, no data is available, recvRequest will+ -- throw a NoKeepAliveRequest exception, which we catch here+ -- and ignore. See: https://github.com/yesodweb/wai/issues/618++ case keepAlive of+ ReuseConnection -> loop SubsequentRequest+ CloseConnection -> return ()++data ReuseConnection = ReuseConnection | CloseConnection++processRequest+ :: Settings+ -> InternalInfo+ -> Connection+ -> Application+ -> T.Handle+ -> IORef Bool+ -> Source+ -> Request+ -> Maybe (IORef Int)+ -> IndexedHeader+ -> IO ByteString+ -> IO ReuseConnection+processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush = do+ -- Let the application run for as long as it wants+ T.pause th++ -- In the event that some scarce resource was acquired during+ -- creating the request, we need to make sure that we don't get+ -- an async exception before calling the ResponseSource.+ keepAliveRef <- newIORef $ error "keepAliveRef not filled"+ r <- try $ app req $ \res -> do+ T.resume th+ -- FIXME consider forcing evaluation of the res here to+ -- send more meaningful error messages to the user.+ -- However, it may affect performance.+ writeIORef istatus False+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res+ writeIORef keepAliveRef keepAlive+ return ResponseReceived+ case r of+ Right ResponseReceived -> return ()+ Left (e :: SomeException)+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'+ | isAsyncException e -> throwIO e+ | otherwise -> do+ keepAlive <- sendErrorResponse settings ii conn th istatus req e+ settingsOnException settings (Just req) e+ writeIORef keepAliveRef keepAlive++ keepAlive <- readIORef keepAliveRef++ -- We just send a Response and it takes a time to+ -- receive a Request again. If we immediately call recv,+ -- it is likely to fail and cause the IO manager to do some work.+ -- It is very costly, so we yield to another Haskell+ -- thread hoping that the next Request will arrive+ -- when this Haskell thread will be re-scheduled.+ -- This improves performance at least when+ -- the number of cores is small.+ Conc.yield++ if keepAlive+ then -- If there is an unknown or large amount of data to still be read+ -- from the request body, simple drop this connection instead of+ -- reading it all in to satisfy a keep-alive request.+ case settingsMaximumBodyFlush settings of+ Nothing -> do+ flushEntireBody nextBodyFlush+ T.resume th+ return ReuseConnection+ Just maxToRead -> do+ let tryKeepAlive = do+ -- flush the rest of the request body+ isComplete <- flushBody nextBodyFlush maxToRead+ if isComplete+ then do+ T.resume th+ return ReuseConnection+ else return CloseConnection+ case mremainingRef of+ Just ref -> do+ remaining <- readIORef ref+ if remaining <= maxToRead+ then tryKeepAlive+ else return CloseConnection+ Nothing -> tryKeepAlive+ else return CloseConnection++sendErrorResponse+ :: Settings+ -> InternalInfo+ -> Connection+ -> T.Handle+ -> IORef Bool+ -> Request+ -> SomeException+ -> IO Bool+sendErrorResponse settings ii conn th istatus req e = do+ status <- readIORef istatus+ if shouldSendErrorResponse e && status+ then+ sendResponse+ settings+ conn+ ii+ th+ req+ defaultIndexRequestHeader+ (return BS.empty)+ errorResponse+ else return False+ where+ shouldSendErrorResponse se+ | Just ConnectionClosedByPeer <- fromException se = False+ | otherwise = True+ errorResponse = settingsOnExceptionResponse settings e++flushEntireBody :: IO ByteString -> IO ()+flushEntireBody src =+ loop+ where+ loop = do+ bs <- src+ unless (BS.null bs) loop++flushBody+ :: IO ByteString+ -- ^ get next chunk+ -> Int+ -- ^ maximum to flush+ -> IO Bool+ -- ^ True == flushed the entire body, False == we didn't+flushBody src = loop+ where+ loop toRead = do+ bs <- src+ let toRead' = toRead - BS.length bs+ case () of+ ()+ | BS.null bs -> return True+ | toRead' >= 0 -> loop toRead'+ | otherwise -> return False
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -1,69 +1,158 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} -module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where+module Network.Wai.Handler.Warp.HTTP2 (+ http2,+ http2server,+) where -import Control.Concurrent (forkIO, killThread) import qualified Control.Exception as E-import Network.HTTP2+import qualified Data.ByteString as BS+import Data.IORef (readIORef)+import qualified Data.IORef as I+import GHC.Conc.Sync (labelThread, myThreadId)+import qualified Network.HTTP2.Frame as H2+import qualified Network.HTTP2.Server as H2 import Network.Socket (SockAddr)+import Network.Socket.BufferPool import Network.Wai+import Network.Wai.Internal (ResponseReceived (..))+import qualified System.TimeManager as T -import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.Manager-import Network.Wai.Handler.Warp.HTTP2.Receiver+import Network.Wai.Handler.Warp.HTTP2.File+import Network.Wai.Handler.Warp.HTTP2.PushPromise import Network.Wai.Handler.Warp.HTTP2.Request-import Network.Wai.Handler.Warp.HTTP2.Sender-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.HTTP2.Worker+import Network.Wai.Handler.Warp.HTTP2.Response import Network.Wai.Handler.Warp.Imports-import qualified Network.Wai.Handler.Warp.Settings as S (Settings)+import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()-http2 conn ii addr transport settings readN app = do+http2+ :: S.Settings+ -> InternalInfo+ -> Connection+ -> Transport+ -> Application+ -> SockAddr+ -> T.Handle+ -> ByteString+ -> IO ()+http2 settings ii conn transport app peersa th bs = do+ rawRecvN <- makeRecvN bs $ connRecv conn+ writeBuffer <- readIORef $ connWriteBuffer conn+ -- This thread becomes the sender in http2 library.+ -- In the case of event source, one request comes and one+ -- worker gets busy. But it is likely that the receiver does+ -- not receive any data at all while the sender is sending+ -- output data from the worker. It's not good enough to tickle+ -- the time handler in the receiver only. So, we should tickle+ -- the time handler in both the receiver and the sender.+ let recvN = wrappedRecvN th (S.settingsSlowlorisSize settings) rawRecvN+ sendBS x = connSendAll conn x >> T.tickle th+ conf =+ H2.defaultConfig+ { H2.confWriteBuffer = bufBuffer writeBuffer+ , H2.confBufferSize = bufSize writeBuffer+ , H2.confSendAll = sendBS+ , H2.confReadN = recvN+ , H2.confPositionReadMaker = pReadMaker ii+ , H2.confTimeoutManager = timeoutManager ii+ , H2.confMySockAddr = connMySockAddr conn+ , H2.confPeerSockAddr = peersa+ , H2.confReadNTimeout = True+ } checkTLS- ok <- checkPreface- when ok $ do- ctx <- newContext- -- Workers, worker manager and timer manager- mgr <- start settings- let responder = response settings ctx mgr- action = worker ctx settings app responder- setAction mgr action- -- The number of workers is 3.- -- This was carefully chosen based on a lot of benchmarks.- -- If it is 1, we cannot avoid head-of-line blocking.- -- If it is large, huge memory is consumed and many- -- context switches happen.- replicateM_ 3 $ spawnAction mgr- -- Receiver- let mkreq = mkRequest ii settings addr- tid <- forkIO $ frameReceiver ctx ii mkreq readN- -- Sender- -- frameSender is the main thread because it ensures to send- -- a goway frame.- frameSender ctx conn settings mgr `E.finally` do- clearContext ctx- stop mgr- killThread tid+ setConnHTTP2 conn True+ H2.run H2.defaultServerConfig conf $+ http2server "Warp HTTP/2" settings ii transport peersa app where checkTLS = case transport of TCP -> return () -- direct- tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"+ tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS" tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3- checkPreface = do- preface <- readN connectionPrefaceLength- if connectionPreface /= preface then do- goaway conn ProtocolError "Preface mismatch"- return False- else- return True +-- | Converting WAI application to the server type of http2 library.+--+-- Since 3.3.11+http2server+ :: String+ -> S.Settings+ -> InternalInfo+ -> Transport+ -> SockAddr+ -> Application+ -> H2.Server+http2server label settings ii transport addr app h2req0 aux0 response = do+ tid <- myThreadId+ labelThread tid (label ++ " http2server " ++ show addr)+ req <- toWAIRequest h2req0 aux0+ ref <- I.newIORef Nothing+ eResponseReceived <- E.try $ app req $ \rsp -> do+ (h2rsp, st, hasBody) <- fromResponse settings ii req rsp+ pps <- if hasBody then fromPushPromises ii req else return []+ I.writeIORef ref $ Just (h2rsp, pps, st)+ _ <- response h2rsp pps+ return ResponseReceived+ case eResponseReceived of+ Right ResponseReceived -> do+ Just (h2rsp, pps, st) <- I.readIORef ref+ let msiz = fromIntegral <$> H2.responseBodySize h2rsp+ logResponse req st msiz+ mapM_ (logPushPromise req) pps+ Left e+ | isAsyncException e -> E.throwIO e+ | otherwise -> do+ S.settingsOnException settings (Just req) e+ let ersp = S.settingsOnExceptionResponse settings e+ st = responseStatus ersp+ (h2rsp', _, _) <- fromResponse settings ii req ersp+ let msiz = fromIntegral <$> H2.responseBodySize h2rsp'+ _ <- response h2rsp' []+ logResponse req st msiz+ return ()+ where+ toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport+ where+ !hdr = H2.requestHeaders h2req+ !bdy = H2.getRequestBodyChunk h2req+ !bdylen = H2.requestBodySize h2req+ !th = H2.auxTimeHandle aux++ logResponse = S.settingsLogger settings++ logPushPromise req pp = logger req path siz+ where+ !logger = S.settingsServerPushLogger settings+ !path = H2.promiseRequestPath pp+ !siz = case H2.responseBodySize $ H2.promiseResponse pp of+ Nothing -> 0+ Just s -> fromIntegral s++wrappedRecvN+ :: T.Handle -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)+wrappedRecvN th slowlorisSize readN bufsize = do+ bs <- E.handle handler $ readN bufsize+ -- TODO: think about the slowloris protection in HTTP2: current code+ -- might open a slow-loris attack vector. Rather than timing we should+ -- consider limiting the per-client connections assuming that in HTTP2+ -- we should allow only few connections per host (real-world+ -- deployments with large NATs may be trickier).+ when+ (BS.length bs > 0 && BS.length bs >= slowlorisSize || bufsize <= slowlorisSize)+ $ T.tickle th+ return bs+ where+ handler :: E.SomeException -> IO ByteString+ handler = throughAsync (return "")+ -- connClose must not be called here since Run:fork calls it-goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()+goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO () goaway Connection{..} etype debugmsg = connSendAll bytestream where- bytestream = goawayFrame 0 etype debugmsg+ einfo = H2.encodeInfo id 0+ frame = H2.GoAwayFrame 0 etype debugmsg+ bytestream = H2.encodeFrame einfo frame
− Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs
@@ -1,34 +0,0 @@-module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where--import Network.HTTP2--import Network.Wai.Handler.Warp.Imports--------------------------------------------------------------------goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString-goawayFrame sid etype debugmsg = encodeFrame einfo frame- where- einfo = encodeInfo id 0- frame = GoAwayFrame sid etype debugmsg--resetFrame :: ErrorCodeId -> StreamId -> ByteString-resetFrame etype sid = encodeFrame einfo frame- where- einfo = encodeInfo id sid- frame = RSTStreamFrame etype--settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString-settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist- where- einfo = encodeInfo func 0--pingFrame :: ByteString -> ByteString-pingFrame bs = encodeFrame einfo $ PingFrame bs- where- einfo = encodeInfo setAck 0--windowUpdateFrame :: StreamId -> WindowSize -> ByteString-windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz- where- einfo = encodeInfo id sid
Network/Wai/Handler/Warp/HTTP2/File.hs view
@@ -1,157 +1,33 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-} -module Network.Wai.Handler.Warp.HTTP2.File (- RspFileInfo(..)- , conditionalRequest- , addContentHeadersForFilePart- , H.parseByteRanges- ) where--import qualified Data.ByteString.Char8 as C8 (pack)-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP.Date-import qualified Network.HTTP.Types as H-import Network.Wai--import qualified Network.Wai.Handler.Warp.FileInfoCache as I-import Network.Wai.Handler.Warp.Imports-import Network.Wai.Handler.Warp.PackInt---- $setup--- >>> import Test.QuickCheck--------------------------------------------------------------------data RspFileInfo = WithoutBody !H.Status- | WithBody !H.Status !TokenHeaderList !Integer !Integer- deriving (Eq,Show)--------------------------------------------------------------------conditionalRequest :: I.FileInfo- -> TokenHeaderList -- Response- -> ValueTable -- Request- -> RspFileInfo-conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of- nobody@(WithoutBody _) -> nobody- WithBody s _ off len -> let !hs = (tokenLastModified,date) :- addContentHeaders ths0 off len size- in WithBody s hs off len- where- !mcondition = ifmodified reqtbl size mtime- <|> ifunmodified reqtbl size mtime- <|> ifrange reqtbl size mtime- !condition = fromMaybe (unconditional reqtbl size) mcondition--------------------------------------------------------------------{-# INLINE ifModifiedSince #-}-ifModifiedSince :: ValueTable -> Maybe HTTPDate-ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate--{-# INLINE ifUnmodifiedSince #-}-ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate-ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate--{-# INLINE ifRange #-}-ifRange :: ValueTable -> Maybe HTTPDate-ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate--------------------------------------------------------------------{-# INLINE ifmodified #-}-ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo-ifmodified reqtbl size mtime = do- date <- ifModifiedSince reqtbl- return $ if date /= mtime- then unconditional reqtbl size- else WithoutBody H.notModified304--{-# INLINE ifunmodified #-}-ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo-ifunmodified reqtbl size mtime = do- date <- ifUnmodifiedSince reqtbl- return $ if date == mtime- then unconditional reqtbl size- else WithoutBody H.preconditionFailed412--{-# INLINE ifrange #-}-ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo-ifrange reqtbl size mtime = do- date <- ifRange reqtbl- rng <- getHeaderValue tokenRange reqtbl- return $ if date == mtime- then parseRange rng size- else WithBody H.ok200 [] 0 size--{-# INLINE unconditional #-}-unconditional :: ValueTable -> Integer -> RspFileInfo-unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of- Nothing -> WithBody H.ok200 [] 0 size- Just rng -> parseRange rng size--------------------------------------------------------------------{-# INLINE parseRange #-}-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--{-# INLINE checkRange #-}-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)+module Network.Wai.Handler.Warp.HTTP2.File where -----------------------------------------------------------------+import Network.HTTP2.Server -{-# INLINE contentRangeHeader #-}--- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'--- for the range specified.-contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader-contentRangeHeader beg end total = (tokenContentRange, range)- where- range = C8.pack- -- building with ShowS- $ 'b' : 'y': 't' : 'e' : 's' : ' '- : (if beg > end then ('*':) else- showInt beg- . ('-' :)- . showInt end)- ( '/'- : showInt total "")+import Network.Wai.Handler.Warp.Types -{-# INLINE addContentHeaders #-}-addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList-addContentHeaders ths off len size- | len == size = ths'- | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size- in ctrng:ths'- where- !lengthBS = packIntegral len- !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths+#ifdef WINDOWS+pReadMaker :: InternalInfo -> PositionReadMaker+pReadMaker _ = defaultPositionReadMaker+#else+import Network.Wai.Handler.Warp.FdCache+import Network.Wai.Handler.Warp.SendFile (positionRead) -{-# INLINE addContentHeadersForFilePart #-}--- |+-- | 'PositionReadMaker' based on file descriptor cache. ----- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)--- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]--- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)--- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]-addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList-addContentHeadersForFilePart hs part = addContentHeaders hs off len size+-- 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- off = filePartOffset part- len = filePartByteCount part- size = filePartFileSize part+ pread :: Fd -> PositionRead+ pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'+ where+ bytes' = fromIntegral bytes+ off' = fromIntegral off+#endif
− Network/Wai/Handler/Warp/HTTP2/HPACK.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}--module Network.Wai.Handler.Warp.HTTP2.HPACK (- hpackEncodeHeader- , hpackEncodeHeaderLoop- , hpackDecodeHeader- , just- , fixHeaders- , addHeader -- testing- , deleteUnnecessaryHeaders- ) where--import qualified Control.Exception as E-import Network.HPACK hiding (Buffer)-import Network.HPACK.Token-import Network.HTTP2--import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.Imports-import Network.Wai.Handler.Warp.PackInt-import qualified Network.Wai.Handler.Warp.Settings as S-import Network.Wai.Handler.Warp.Types---- $setup--- >>> :set -XOverloadedStrings--------------------------------------------------------------------{-# INLINE addHeader #-}-addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList-addHeader t "" _ ths- | t == tokenServer = filter ((/= tokenServer) . fst) ths-addHeader t v tbl ths = case getHeaderValue t tbl of- Nothing -> (t,v) : ths- _ -> ths--fixHeaders :: Context- -> Rspn- -> InternalInfo- -> S.Settings- -> IO TokenHeaderList-fixHeaders Context{..} rspn ii settings = do- date <- getDate ii- let !s = rspnStatus rspn- !status = packStatus s- !defServer = S.settingsServerName settings- (!ths0,tbl) = rspnHeaders rspn- !ths1 = addHeader tokenServer defServer tbl ths0- !ths2 = addHeader tokenDate date tbl ths1- !ths3 = (tokenStatus, status) : ths2- !ths4 = deleteUnnecessaryHeaders ths3 tbl- return ths4--deleteUnnecessaryHeaders :: TokenHeaderList -> ValueTable -> TokenHeaderList-deleteUnnecessaryHeaders htl0 tbl0 = loop headersToBeRemoved htl0- where- loop [] thl = thl- loop (t:ts) thl = case getHeaderValue t tbl0 of- Nothing -> thl- _ -> let !thl' = filter ((/= t) . fst) thl- in loop ts thl'--headersToBeRemoved :: [Token]-headersToBeRemoved = [ tokenConnection- , tokenTransferEncoding- -- Keep-Alive:- -- Proxy-Connection:- -- Upgrade:- ]--------------------------------------------------------------------strategy :: EncodeStrategy-strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }---- Set-Cookie: contains only one cookie value.--- So, we don't need to split it.-hpackEncodeHeader :: Context -> Buffer -> BufSize- -> TokenHeaderList- -> IO (TokenHeaderList, Int)-hpackEncodeHeader Context{..} buf siz ths =- encodeTokenHeader buf siz strategy True encodeDynamicTable ths--hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize- -> TokenHeaderList- -> IO (TokenHeaderList, Int)-hpackEncodeHeaderLoop Context{..} buf siz hs =- encodeTokenHeader buf siz strategy False encodeDynamicTable hs--------------------------------------------------------------------hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)-hpackDecodeHeader hdrblk Context{..} = do- tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl- unless (checkRequestHeader vt) $- E.throwIO $ ConnectionError ProtocolError "the header key is illegal"- return tbl- where- handl IllegalHeaderName =- E.throwIO $ ConnectionError ProtocolError "the header key is illegal"- handl _ =- E.throwIO $ ConnectionError CompressionError "cannot decompress the header"--{-# INLINE checkRequestHeader #-}-checkRequestHeader :: ValueTable -> Bool-checkRequestHeader reqvt- | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme- | isJust mStatus = False- | isNothing mMethod = False- | isNothing mScheme = False- | isNothing mPath = False- | mPath == Just "" = False- | isJust mConnection = False- | just mTE (/= "trailers") = False- | otherwise = True- where- mStatus = getHeaderValue tokenStatus reqvt- mScheme = getHeaderValue tokenScheme reqvt- mPath = getHeaderValue tokenPath reqvt- mMethod = getHeaderValue tokenMethod reqvt- mConnection = getHeaderValue tokenConnection reqvt- mTE = getHeaderValue tokenTE reqvt--{-# INLINE just #-}-just :: Maybe a -> (a -> Bool) -> Bool-just Nothing _ = False-just (Just x) p- | p x = True- | otherwise = False
− Network/Wai/Handler/Warp/HTTP2/Manager.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE CPP, BangPatterns #-}---- | A thread pool manager.--- The manager has responsibility to spawn and kill--- worker threads.-module Network.Wai.Handler.Warp.HTTP2.Manager (- Manager- , start- , setAction- , stop- , spawnAction- , addMyId- , deleteMyId- ) where--import Control.Concurrent-import Control.Concurrent.STM-import Data.Foldable-import Data.IORef-import Data.Set (Set)-import qualified Data.Set as Set-import qualified System.TimeManager as T--import Network.Wai.Handler.Warp.Imports-import Network.Wai.Handler.Warp.Settings--------------------------------------------------------------------type Action = T.Manager -> IO ()--data Command = Stop | Spawn | Add ThreadId | Delete ThreadId--data Manager = Manager (TQueue Command) (IORef Action)---- | Starting a thread pool manager.--- Its action is initially set to 'return ()' and should be set--- by 'setAction'. This allows that the action can include--- the manager itself.-start :: Settings -> IO Manager-start set = do- q <- newTQueueIO- ref <- newIORef (\_ -> return ())- timmgr <- T.initialize $ settingsTimeout set * 1000000- void $ forkIO $ go q Set.empty ref timmgr- return $ Manager q ref- where- go q !tset0 ref timmgr = do- x <- atomically $ readTQueue q- case x of- Stop -> kill tset0 >> T.killManager timmgr- Spawn -> next tset0- Add newtid -> let !tset = add newtid tset0- in go q tset ref timmgr- Delete oldtid -> let !tset = del oldtid tset0- in go q tset ref timmgr- where- next tset = do- action <- readIORef ref- newtid <- forkIO (action timmgr)- let !tset' = add newtid tset- go q tset' ref timmgr--setAction :: Manager -> Action -> IO ()-setAction (Manager _ ref) action = writeIORef ref action--stop :: Manager -> IO ()-stop (Manager q _) = atomically $ writeTQueue q Stop--spawnAction :: Manager -> IO ()-spawnAction (Manager q _) = atomically $ writeTQueue q Spawn--addMyId :: Manager -> IO ()-addMyId (Manager q _) = do- tid <- myThreadId- atomically $ writeTQueue q $ Add tid--deleteMyId :: Manager -> IO ()-deleteMyId (Manager q _) = do- tid <- myThreadId- atomically $ writeTQueue q $ Delete tid--------------------------------------------------------------------add :: ThreadId -> Set ThreadId -> Set ThreadId-add tid set = set'- where- !set' = Set.insert tid set--del :: ThreadId -> Set ThreadId -> Set ThreadId-del tid set = set'- where- !set' = Set.delete tid set--kill :: Set ThreadId -> IO ()-kill set = traverse_ killThread set
+ Network/Wai/Handler/Warp/HTTP2/PushPromise.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP2.PushPromise where++import qualified Control.Exception as E+import qualified Network.HTTP.Types as H+import qualified Network.HTTP2.Server as H2++import Network.Wai+import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)+import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.Types++fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]+fromPushPromises ii req = do+ mh2data <- getHTTP2Data req+ let pp = maybe [] http2dataPushPromise mh2data+ catMaybes <$> mapM (fromPushPromise ii) pp++fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)+fromPushPromise ii (PushPromise path file rsphdr w) = do+ efinfo <- E.try $ getFileInfo ii file+ case efinfo of+ Left (_ex :: E.IOException) -> return Nothing+ Right finfo -> do+ let !siz = fromIntegral $ fileInfoSize finfo+ !fileSpec = H2.FileSpec file 0 siz+ !rsp = H2.responseFile H.ok200 rsphdr fileSpec+ !pp = H2.pushPromise path rsp w+ return $ Just pp
− Network/Wai/Handler/Warp/HTTP2/Receiver.hs
@@ -1,418 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-}--module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where--import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C8-import Data.IORef-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2-import Network.HTTP2.Priority (toPrecedence, delete, prepare)--import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.HPACK-import Network.Wai.Handler.Warp.HTTP2.Request-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.Imports hiding (delete, insert, readInt)-import Network.Wai.Handler.Warp.ReadInt-import Network.Wai.Handler.Warp.Types--------------------------------------------------------------------frameReceiver :: Context -> InternalInfo -> MkReq -> (BufSize -> IO ByteString) -> IO ()-frameReceiver ctx ii mkreq recvN = loop 0 `E.catch` sendGoaway- where- Context{ http2settings- , streamTable- , concurrency- , continued- , clientStreamId- , inputQ- , controlQ- } = ctx- sendGoaway e- | Just (ConnectionError err msg) <- E.fromException e = do- csid <- readIORef clientStreamId- let !frame = goawayFrame csid err msg- enqueueControl controlQ $ CGoaway frame- | otherwise = return ()-- sendReset err sid = do- let !frame = resetFrame err sid- enqueueControl controlQ $ CFrame frame-- loop :: Int -> IO ()- loop !n- | n == 6 = do- yield- loop 0- | otherwise = do- hd <- recvN frameHeaderLength- if BS.null hd then- enqueueControl controlQ CFinish- else do- cont <- processStreamGuardingError $ decodeFrameHeader hd- when cont $ loop (n + 1)-- processStreamGuardingError (fid, FrameHeader{streamId})- | isResponse streamId &&- (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =- E.throwIO $ ConnectionError ProtocolError "stream id should be odd"- processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do- mx <- readIORef continued- case mx of- Nothing -> do- -- ignoring unknown frame- consume payloadLength- return True- Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"- processStreamGuardingError (FramePushPromise, _) =- E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"- processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do- settings <- readIORef http2settings- case checkFrameHeader settings typhdr of- Left h2err -> case h2err of- StreamError err sid -> do- sendReset err sid- consume payloadLength- return True- connErr -> E.throwIO connErr- Right _ -> do- ex <- E.try $ controlOrStream ftyp header- case ex of- Left (StreamError err sid) -> do- sendReset err sid- return True- Left connErr -> E.throw connErr- Right cont -> return cont-- controlOrStream ftyp header@FrameHeader{streamId, payloadLength}- | isControl streamId = do- pl <- recvN payloadLength- control ftyp header pl ctx- | otherwise = do- checkContinued- !mstrm <- getStream- pl <- recvN payloadLength- case mstrm of- Nothing -> do- -- for h2spec only- when (ftyp == FramePriority) $ do- PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl- checkPriority newpri streamId- return True -- just ignore this frame- Just strm@Stream{streamPrecedence} -> do- state <- readStreamState strm- state' <- stream ftyp header pl ctx state strm- case state' of- Open (NoBody tbl@(_,reqvt) pri) -> do- resetContinued- let mcl = readInt <$> getHeaderValue tokenContentLength reqvt- when (just mcl (/= (0 :: Int))) $- E.throwIO $ StreamError ProtocolError streamId- writeIORef streamPrecedence $ toPrecedence pri- halfClosedRemote ctx strm- !req <- mkreq tbl (Just 0, return "")- atomically $ writeTQueue inputQ $ Input strm req reqvt ii- Open (HasBody tbl@(_,reqvt) pri) -> do- resetContinued- q <- newTQueueIO- let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt- writeIORef streamPrecedence $ toPrecedence pri- bodyLength <- newIORef 0- setStreamState ctx strm $ Open (Body q mcl bodyLength)- readQ <- newReadBody q- bodySource <- mkSource readQ- !req <- mkreq tbl (mcl, readSource bodySource)- atomically $ writeTQueue inputQ $ Input strm req reqvt ii- s@(Open Continued{}) -> do- setContinued- setStreamState ctx strm s- HalfClosedRemote -> do- resetContinued- halfClosedRemote ctx strm- s -> do -- Idle, Open Body, Closed- resetContinued- setStreamState ctx strm s- return True- where- setContinued = writeIORef continued (Just streamId)- resetContinued = writeIORef continued Nothing- checkContinued = do- mx <- readIORef continued- case mx of- Nothing -> return ()- Just sid- | sid == streamId && ftyp == FrameContinuation -> return ()- | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"- getStream = do- mstrm0 <- search streamTable streamId- case mstrm0 of- js@(Just strm0) -> do- when (ftyp == FrameHeaders) $ do- st <- readStreamState strm0- when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream"- -- Priority made an idele stream- when (isIdle st) $ opened ctx strm0- return js- Nothing- | isResponse streamId -> return Nothing- | otherwise -> do- csid <- readIORef clientStreamId- if streamId <= csid then -- consider the stream closed- if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then- return Nothing -- will be ignored- else- E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"- else do -- consider the stream idle- when (ftyp `notElem` [FrameHeaders,FramePriority]) $- E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp)- when (ftyp == FrameHeaders) $ do- writeIORef clientStreamId streamId- cnt <- readIORef concurrency- -- Checking the limitation of concurrency- when (cnt >= maxConcurrency) $- E.throwIO $ StreamError RefusedStream streamId- ws <- initialWindowSize <$> readIORef http2settings- newstrm <- newStream streamId (fromIntegral ws)- when (ftyp == FrameHeaders) $ opened ctx newstrm- insert streamTable streamId newstrm- return $ Just newstrm-- consume = void . recvN--maxConcurrency :: Int-maxConcurrency = recommendedConcurrency--initialFrame :: ByteString-initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]--------------------------------------------------------------------control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool-control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do- SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs- case checkSettingsList alist of- Just x -> E.throwIO x- Nothing -> return ()- -- HTTP/2 Setting from a browser- unless (testAck flags) $ do- oldws <- initialWindowSize <$> readIORef http2settings- modifyIORef' http2settings $ \old -> updateSettings old alist- newws <- initialWindowSize <$> readIORef http2settings- let diff = newws - oldws- when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable- let !frame = settingsFrame setAck []- sent <- readIORef firstSettings- let !setframe- | sent = CSettings frame alist- | otherwise = CSettings0 initialFrame frame alist- unless sent $ writeIORef firstSettings True- enqueueControl controlQ setframe- return True--control FramePing FrameHeader{flags} bs Context{controlQ} =- if testAck flags then- return True -- just ignore- else do- let !frame = pingFrame bs- enqueueControl controlQ $ CFrame frame- return True--control FrameGoAway _ _ Context{controlQ} = do- enqueueControl controlQ CFinish- return False--control FrameWindowUpdate header bs Context{connectionWindow} = do- WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs- !w <- atomically $ do- w0 <- readTVar connectionWindow- let !w1 = w0 + n- writeTVar connectionWindow w1- return w1- when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"- return True--control _ _ _ _ =- -- must not reach here- return False--------------------------------------------------------------------{-# INLINE guardIt #-}-guardIt :: Either HTTP2Error a -> IO a-guardIt x = case x of- Left err -> E.throwIO err- Right frame -> return frame---{-# INLINE checkPriority #-}-checkPriority :: Priority -> StreamId -> IO ()-checkPriority p me- | dep == me = E.throwIO $ StreamError ProtocolError me- | otherwise = return ()- where- dep = streamDependency p--stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState-stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do- HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs- pri <- case mp of- Nothing -> return defaultPriority- Just p -> do- checkPriority p streamNumber- return p- let !endOfStream = testEndStream flags- !endOfHeader = testEndHeader flags- if endOfHeader then do- tbl <- hpackDecodeHeader frag ctx -- fixme- return $ if endOfStream then- Open (NoBody tbl pri)- else- Open (HasBody tbl pri)- else do- let !siz = BS.length frag- return $ Open $ Continued [frag] siz 1 endOfStream pri--stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do- -- trailer is not supported.- -- let's read and ignore it.- HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs- let !endOfStream = testEndStream flags- if endOfStream then do- atomically $ writeTQueue q ""- return HalfClosedRemote- else- -- we don't support continuation here.- E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"---- ignore data-frame except for flow-control when we're done locally-stream FrameData- FrameHeader{flags,payloadLength}- _bs- Context{controlQ} s@(HalfClosedLocal _)- Stream{streamNumber} = do- let !endOfStream = testEndStream flags- when (payloadLength /= 0) $ do- let !frame1 = windowUpdateFrame 0 payloadLength- !frame2 = windowUpdateFrame streamNumber payloadLength- !frame = frame1 `BS.append` frame2- enqueueControl controlQ $ CFrame frame- if endOfStream then do- return HalfClosedRemote- else- return s--stream FrameData- header@FrameHeader{flags,payloadLength,streamId}- bs- Context{controlQ} s@(Open (Body q mcl bodyLength))- Stream{streamNumber} = do- DataFrame body <- guardIt $ decodeDataFrame header bs- let !endOfStream = testEndStream flags- len0 <- readIORef bodyLength- let !len = len0 + payloadLength- writeIORef bodyLength len- when (payloadLength /= 0) $ do- let !frame1 = windowUpdateFrame 0 payloadLength- !frame2 = windowUpdateFrame streamNumber payloadLength- !frame = frame1 `BS.append` frame2- enqueueControl controlQ $ CFrame frame- atomically $ writeTQueue q body- if endOfStream then do- case mcl of- Nothing -> return ()- Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId- atomically $ writeTQueue q ""- return HalfClosedRemote- else- return s--stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do- let !endOfHeader = testEndHeader flags- !rfrags' = frag : rfrags- !siz' = siz + BS.length frag- !n' = n + 1- when (siz' > 51200) $ -- fixme: hard coding: 50K- E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"- when (n' > 10) $ -- fixme: hard coding- E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"- if endOfHeader then do- let !hdrblk = BS.concat $ reverse rfrags'- tbl <- hpackDecodeHeader hdrblk ctx- return $ if endOfStream then- Open (NoBody tbl pri)- else- Open (HasBody tbl pri)- else- return $ Open $ Continued rfrags' siz' n' endOfStream pri--stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do- WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs- !w <- atomically $ do- w0 <- readTVar streamWindow- let !w1 = w0 + n- writeTVar streamWindow w1- return w1- when (isWindowOverflow w) $- E.throwIO $ StreamError FlowControlError streamId- return s--stream FrameRSTStream header bs ctx _ strm = do- RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs- let !cc = Reset e- closed ctx strm cc- return $ Closed cc -- will be written to streamState again--stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do- PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs- checkPriority newpri streamNumber- oldpre <- readIORef streamPrecedence- let !newpre = toPrecedence newpri- writeIORef streamPrecedence newpre- if isIdle s then do- n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))- -- fixme hard coding- when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"- prepare outputQ streamNumber newpri- else do- mx <- delete outputQ streamNumber oldpre- case mx of- Nothing -> return ()- Just out -> enqueueOutput outputQ out- return s---- this ordering is important-stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"-stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"--- Ignore frames to streams we have just reset, per section 5.1.-stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st-stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId-stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId--------------------------------------------------------------------{-# INLINE newReadBody #-}-newReadBody :: TQueue ByteString -> IO (IO ByteString)-newReadBody q = do- ref <- newIORef False- return $ readBody q ref--{-# INLINE readBody #-}-readBody :: TQueue ByteString -> IORef Bool -> IO ByteString-readBody q ref = do- eof <- readIORef ref- if eof then- return ""- else do- bs <- atomically $ readTQueue q- when (bs == "") $ writeIORef ref True- return bs
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.HTTP2.Request (- mkRequest- , MkReq- , getHTTP2Data- , setHTTP2Data- , modifyHTTP2Data- ) where+ toRequest,+ getHTTP2Data,+ setHTTP2Data,+ modifyHTTP2Data,+) where import Control.Arrow (first) import qualified Data.ByteString.Char8 as C8@@ -18,52 +17,74 @@ 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)-import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)+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 MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request)+type ToReq =+ (TokenHeaderList, ValueTable)+ -> Maybe Int+ -> IO ByteString+ -> T.Handle+ -> Transport+ -> IO Request -mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq-mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do+----------------------------------------------------------------++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- mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)+ toRequest' ii settings addr ref ht bodylen body th transport -mkRequest' :: InternalInfo -> S.Settings -> SockAddr- -> IORef (Maybe HTTP2Data)- -> MkReq-mkRequest' ii settings addr ref (reqths,reqvt) (bodylen,body) = return req+toRequest'+ :: InternalInfo+ -> S.Settings+ -> SockAddr+ -> IORef (Maybe HTTP2Data)+ -> ToReq+toRequest' ii settings addr ref (reqths, reqvt) bodylen body th transport =+ -- setting 'requestBody' with 'setRequestBodyChunks' to avoid warnings+ return $! setRequestBodyChunks body req where- !req = Request {- requestMethod = colonMethod- , httpVersion = http2ver- , rawPathInfo = rawPath- , pathInfo = H.decodePathSegments path- , rawQueryString = query- , queryString = H.parseQuery query- , requestHeaders = headers- , isSecure = True- , remoteHost = addr- , requestBody = body- , vault = vaultValue- , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen- , requestHeaderHost = mHost <|> mAuth- , requestHeaderRange = mRange- , requestHeaderReferer = mReferer- , requestHeaderUserAgent = mUserAgent- }+ !req =+ defaultRequest+ { requestMethod = colonMethod+ , httpVersion = if isTransportQUIC transport then http30 else H.http20+ , rawPathInfo = rawPath+ , pathInfo = H.decodePathSegments path+ , rawQueryString = query+ , queryString = H.parseQuery query+ , requestHeaders = headers+ , isSecure = isTransportSecure transport+ , remoteHost = addr+ , vault = vaultValue+ , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen+ , requestHeaderHost = mHost <|> mAuth+ , requestHeaderRange = mRange+ , requestHeaderReferer = mReferer+ , requestHeaderUserAgent = mUserAgent+ } headers = map (first tokenKey) ths where ths = case mHost of- Just _ -> reqths+ Just _ -> reqths Nothing -> case mAuth of- Just auth -> (tokenHost, auth) : reqths- _ -> reqths+ Just auth -> (tokenHost, auth) : reqths+ _ -> reqths !mPath = getHeaderValue tokenPath reqvt -- SHOULD !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD@@ -73,14 +94,20 @@ !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)+ (unparsedPath, query) = C8.break (== '?') $ fromJust (mPath <|> mAuth) !path = H.extractPath unparsedPath !rawPath = if S.settingsNoParsePath settings then unparsedPath else path- !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)- $ Vault.insert getHTTP2DataKey (readIORef ref)- $ Vault.insert setHTTP2DataKey (writeIORef ref)- $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)- Vault.empty+ -- 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@@ -92,8 +119,8 @@ -- Since: 3.2.7 getHTTP2Data :: Request -> IO (Maybe HTTP2Data) getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of- Nothing -> return Nothing- Just getter -> getter+ Nothing -> return Nothing+ Just getter -> getter setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ()) setHTTP2DataKey = unsafePerformIO Vault.newKey@@ -105,8 +132,8 @@ -- 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+ Nothing -> return ()+ Just setter -> setter mh2d modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()) modifyHTTP2DataKey = unsafePerformIO Vault.newKey@@ -118,5 +145,5 @@ -- 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+ Nothing -> return ()+ Just modify -> modify func
+ Network/Wai/Handler/Warp/HTTP2/Response.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP2.Response (+ fromResponse,+) where++import qualified Control.Exception as E+import qualified Data.ByteString.Builder as BB+import qualified Data.List as L (find)+import qualified Network.HTTP.Types as H+import qualified Network.HTTP2.Server as H2+import Network.Wai hiding (responseBuilder, responseFile, responseStream)+import Network.Wai.Internal (Response (..))++import Network.Wai.Handler.Warp.File+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)+import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.Header+import qualified Network.Wai.Handler.Warp.Response as R+import qualified Network.Wai.Handler.Warp.Settings as S+import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++fromResponse+ :: S.Settings+ -> InternalInfo+ -> Request+ -> Response+ -> IO (H2.Response, H.Status, Bool)+fromResponse settings ii req rsp = do+ date <- getDate ii+ rspst@(h2rsp, st, hasBody) <- case rsp of+ ResponseFile st rsphdr path mpart -> do+ let rsphdr' = add date rsphdr+ responseFile st rsphdr' method path mpart ii reqhdr+ ResponseBuilder st rsphdr builder -> do+ let rsphdr' = add date rsphdr+ return $ responseBuilder st rsphdr' method builder+ ResponseStream st rsphdr strmbdy -> do+ let rsphdr' = add date rsphdr+ return $ responseStream st rsphdr' method strmbdy+ _ -> error "ResponseRaw is not supported in HTTP/2"+ mh2data <- getHTTP2Data req+ case mh2data of+ Nothing -> return rspst+ Just h2data -> do+ let !trailers = http2dataTrailers h2data+ !h2rsp' = H2.setResponseTrailersMaker h2rsp trailers+ return (h2rsp', st, hasBody)+ where+ !method = requestMethod req+ !reqhdr = requestHeaders req+ !server = S.settingsServerName settings+ add date rsphdr =+ let hasServerHdr = L.find ((== H.hServer) . fst) rsphdr+ addSVR =+ maybe ((H.hServer, server) :) (const id) hasServerHdr+ in R.addAltSvc settings $+ (H.hDate, date) : addSVR rsphdr++----------------------------------------------------------------++responseFile+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> FilePath+ -> Maybe FilePart+ -> InternalInfo+ -> H.RequestHeaders+ -> IO (H2.Response, H.Status, Bool)+responseFile st rsphdr _ _ _ _ _+ | noBody st = return $ responseNoBody st rsphdr+responseFile st rsphdr method path (Just fp) _ _ =+ return $ responseFile2XX st rsphdr method fileSpec+ where+ !off' = fromIntegral $ filePartOffset fp+ !bytes' = fromIntegral $ filePartByteCount fp+ !fileSpec = H2.FileSpec path off' bytes'+responseFile _ rsphdr method path Nothing ii reqhdr = do+ efinfo <- E.try $ getFileInfo ii path+ case efinfo of+ Left (_ex :: E.IOException) -> return $ response404 rsphdr+ Right finfo -> do+ let reqidx = indexRequestHeader reqhdr+ rspidx = indexResponseHeader rsphdr+ case conditionalRequest finfo rsphdr method rspidx reqidx of+ WithoutBody s -> return $ responseNoBody s rsphdr+ WithBody s rsphdr' off bytes -> do+ let !off' = fromIntegral off+ !bytes' = fromIntegral bytes+ !fileSpec = H2.FileSpec path off' bytes'+ return $ responseFile2XX s rsphdr' method fileSpec++----------------------------------------------------------------++responseFile2XX+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> H2.FileSpec+ -> (H2.Response, H.Status, Bool)+responseFile2XX st rsphdr method fileSpec+ | method == H.methodHead = responseNoBody st rsphdr+ | otherwise = (H2.responseFile st rsphdr fileSpec, st, True)++----------------------------------------------------------------++responseBuilder+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> BB.Builder+ -> (H2.Response, H.Status, Bool)+responseBuilder st rsphdr method builder+ | method == H.methodHead || noBody st = responseNoBody st rsphdr+ | otherwise = (H2.responseBuilder st rsphdr builder, st, True)++----------------------------------------------------------------++responseStream+ :: H.Status+ -> H.ResponseHeaders+ -> H.Method+ -> StreamingBody+ -> (H2.Response, H.Status, Bool)+responseStream st rsphdr method strmbdy+ | method == H.methodHead || noBody st = responseNoBody st rsphdr+ | otherwise = (H2.responseStreaming st rsphdr strmbdy, st, True)++----------------------------------------------------------------++responseNoBody :: H.Status -> H.ResponseHeaders -> (H2.Response, H.Status, Bool)+responseNoBody st rsphdr = (H2.responseNoBody st rsphdr, st, False)++----------------------------------------------------------------++response404 :: H.ResponseHeaders -> (H2.Response, H.Status, Bool)+response404 rsphdr = (h2rsp, st, True)+ where+ h2rsp = H2.responseBuilder st rsphdr' body+ st = H.notFound404+ !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr+ !body = BB.byteString "File not found"++----------------------------------------------------------------++noBody :: H.Status -> Bool+noBody = not . R.hasBody
− Network/Wai/Handler/Warp/HTTP2/Sender.hs
@@ -1,536 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns, CPP #-}-{-# LANGUAGE NamedFieldPuns #-}--module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where--import Control.Concurrent.STM-import qualified Control.Exception as E-import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder.Extra as B-import Data.IORef-import Foreign.Ptr (Ptr, plusPtr)-import Foreign.Storable (poke)-import Network.HPACK (setLimitForEncoding, toHeaderTable)-import Network.HTTP2-import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)-import Network.Wai--#ifdef WINDOWS-import qualified System.IO as IO-#else-import Network.Wai.Handler.Warp.FdCache-import Network.Wai.Handler.Warp.SendFile (positionRead)-import qualified System.TimeManager as T-#endif--import Network.Wai.Handler.Warp.Buffer-import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.HPACK-import Network.Wai.Handler.Warp.HTTP2.Manager (Manager)-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.Imports hiding (readInt)-import qualified Network.Wai.Handler.Warp.Settings as S-import Network.Wai.Handler.Warp.Types--------------------------------------------------------------------data Leftover = LZero- | LOne B.BufferWriter- | LTwo ByteString B.BufferWriter--------------------------------------------------------------------{-# INLINE getStreamWindowSize #-}-getStreamWindowSize :: Stream -> IO WindowSize-getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow--{-# INLINE waitStreamWindowSize #-}-waitStreamWindowSize :: Stream -> IO ()-waitStreamWindowSize Stream{streamWindow} = atomically $ do- w <- readTVar streamWindow- check (w > 0)--{-# INLINE waitStreaming #-}-waitStreaming :: TBQueue a -> IO ()-waitStreaming tbq = atomically $ do- isEmpty <- isEmptyTBQueue tbq- check (not isEmpty)--data Switch = C Control- | O (StreamId,Precedence,Output)- | Flush--frameSender :: Context -> Connection -> S.Settings -> Manager -> IO ()-frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}- conn@Connection{connWriteBuffer,connBufferSize,connSendAll}- settings mgr = loop 0 `E.catch` ignore- where- dequeue off = do- isEmpty <- isEmptyTQueue controlQ- if isEmpty then do- w <- readTVar connectionWindow- check (w > 0)- emp <- isEmptySTM outputQ- if emp then- if off /= 0 then return Flush else retry- else- O <$> dequeueSTM outputQ- else- C <$> readTQueue controlQ-- loop off = do- x <- atomically $ dequeue off- case x of- C ctl -> do- when (off /= 0) $ flushN off- off' <- control ctl off- when (off' >= 0) $ loop off'- O (_,pre,out) -> do- let strm = outputStream out- writeIORef (streamPrecedence strm) pre- off' <- outputOrEnqueueAgain out off- case off' of- 0 -> loop 0- _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding- | otherwise -> loop off'- Flush -> flushN off >> loop 0-- control CFinish _ = return (-1)- control (CGoaway frame) _ = connSendAll frame >> return (-1)- control (CFrame frame) _ = connSendAll frame >> return 0- control (CSettings frame alist) _ = do- connSendAll frame- setLimit alist- return 0- control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case- let !buf = connWriteBuffer `plusPtr` off- !off' = off + BS.length frame1 + BS.length frame2- buf' <- copy buf frame1- void $ copy buf' frame2- setLimit alist- return off'-- {-# INLINE setLimit #-}- setLimit alist = case lookup SettingsHeaderTableSize alist of- Nothing -> return ()- Just siz -> setLimitForEncoding siz encodeDynamicTable-- output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do- -- Data frame payload- let !buf = connWriteBuffer `plusPtr` off0- !siz = connBufferSize - off0- Next datPayloadLen mnext <- curr buf siz lim- off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D- maybeEnqueueNext out mnext- return off-- output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do- -- Header frame and Continuation frame- let !sid = streamNumber strm- !endOfStream = case rspn of- RspnNobody _ _ -> True- _ -> False- ths <- fixHeaders ctx rspn ii settings- kvlen <- headerContinue sid ths endOfStream off0- off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen- case rspn of- RspnNobody _ _ -> do- halfClosedLocal ctx strm Finished- return off- RspnFile _ _ path mpart -> do- -- Data frame payload- let payloadOff = off + frameHeaderLength- Next datPayloadLen mnext <-- fillFileBodyGetNext conn ii payloadOff lim path mpart- off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D- maybeEnqueueNext out mnext- return off'- RspnBuilder _ _ builder -> do- -- Data frame payload- let payloadOff = off + frameHeaderLength- Next datPayloadLen mnext <-- fillBuilderBodyGetNext conn ii payloadOff lim builder- off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D- maybeEnqueueNext out mnext- return off'- RspnStreaming _ _ tbq -> do- let payloadOff = off + frameHeaderLength- Next datPayloadLen mnext <-- fillStreamBodyGetNext conn payloadOff lim tbq strm- off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D- maybeEnqueueNext out mnext- return off'-- output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do- -- Creating a push promise header- -- Frame id should be associated stream id from the client.- let !sid = streamNumber strm- len <- pushPromise pid sid ths off0- off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len- output out{ outputType = ORspn } off lim-- output _ _ _ = undefined -- never reach-- outputOrEnqueueAgain out off = E.handle resetStream $ do- state <- readStreamState strm- if isHalfClosedLocal state then- return off- else case out of- Output _ _ _ wait _ OWait -> do- -- Checking if all push are done.- let out' = out {- outputHook = return ()- , outputType = ORspn- }- forkAndEnqueueWhenReady wait outputQ out' mgr- return off- _ -> case mtbq of- Just tbq -> checkStreaming tbq- _ -> checkStreamWindowSize- where- strm = outputStream out- mtbq = outputMaybeTBQueue out- checkStreaming tbq = do- isEmpty <- atomically $ isEmptyTBQueue tbq- if isEmpty then do- forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr- return off- else- checkStreamWindowSize- checkStreamWindowSize = do- sws <- getStreamWindowSize strm- if sws == 0 then do- forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr- return off- else do- cws <- atomically $ readTVar connectionWindow -- not 0- let !lim = min cws sws- output out off lim- resetStream e = do- closed ctx strm (ResetByMe e)- let !rst = resetFrame InternalError $ streamNumber strm- enqueueControl controlQ $ CFrame rst- return off-- {-# INLINE flushN #-}- -- Flush the connection buffer to the socket, where the first 'n' bytes of- -- the buffer are filled.- flushN :: Int -> IO ()- flushN n = bufferIO connWriteBuffer n connSendAll-- headerContinue sid ths endOfStream off = do- let !offkv = off + frameHeaderLength- let !bufkv = connWriteBuffer `plusPtr` offkv- !limkv = connBufferSize - offkv- (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths- let flag0 = case hs of- [] -> setEndHeader defaultFlags- _ -> defaultFlags- flag = if endOfStream then setEndStream flag0 else flag0- let buf = connWriteBuffer `plusPtr` off- fillFrameHeader FrameHeaders kvlen sid flag buf- continue sid kvlen hs-- !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength- !headerPayloadLim = connBufferSize - frameHeaderLength-- continue _ kvlen [] = return kvlen- continue sid kvlen ths = do- flushN $ kvlen + frameHeaderLength- -- Now off is 0- (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths- when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"- let flag = case ths' of- [] -> setEndHeader defaultFlags- _ -> defaultFlags- fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer- continue sid kvlen' ths'-- {-# INLINE maybeEnqueueNext #-}- -- Re-enqueue the stream in the output queue.- maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()- maybeEnqueueNext _ Nothing = return ()- maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'- where- !out' = out { outputType = ONext next }-- {-# INLINE sendHeadersIfNecessary #-}- -- Send headers if there is not room for a 1-byte data frame, and return- -- the offset of the next frame's first header byte.- sendHeadersIfNecessary off- -- True if the connection buffer has room for a 1-byte data frame.- | off + frameHeaderLength < connBufferSize = return off- | otherwise = do- flushN off- return 0-- fillDataHeader strm@Stream{streamWindow,streamNumber}- off datPayloadLen mnext tell getH2D = do- -- Data frame header- mh2d <- getH2D- let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of- Nothing -> ([], True)- Just ts -> (ts, null ts)- !buf = connWriteBuffer `plusPtr` off- !off' = off + frameHeaderLength + datPayloadLen- !noMoreBody = isNothing mnext- flag | noMoreBody && noTrailers = setEndStream defaultFlags- | otherwise = defaultFlags- fillFrameHeader FrameData datPayloadLen streamNumber flag buf- off'' <- handleEndOfBody noMoreBody off' noTrailers trailers- atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)- atomically $ modifyTVar' streamWindow (subtract datPayloadLen)- return off''- where- handleTrailers True off0 _ = return off0- handleTrailers _ off0 trailers = do- (ths,_) <- toHeaderTable trailers- kvlen <- headerContinue streamNumber ths True off0- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen- handleEndOfBody True off0 noTrailers trailers = do- off1 <- handleTrailers noTrailers off0 trailers- void tell- halfClosedLocal ctx strm Finished- return off1- handleEndOfBody False off0 _ _ = return off0--- pushPromise pid sid ths off = do- let !offsid = off + frameHeaderLength- !bufsid = connWriteBuffer `plusPtr` offsid- poke32 bufsid $ fromIntegral sid- let !offkv = offsid + 4- !bufkv = connWriteBuffer `plusPtr` offkv- !limkv = connBufferSize - offkv- (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths- let !flag = setEndHeader defaultFlags -- No EndStream flag- !buf = connWriteBuffer `plusPtr` off- !len = kvlen + 4- fillFrameHeader FramePushPromise len pid flag buf- return len-- {-# INLINE fillFrameHeader #-}- fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf- where- hinfo = FrameHeader len flag sid-- {-# INLINE ignore #-}- ignore :: E.SomeException -> IO ()- ignore _ = return ()--------------------------------------------------------------------{--ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)-ResponseBuilder Status ResponseHeaders Builder-ResponseStream Status ResponseHeaders StreamingBody-ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response--}--fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next-fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}- _ off lim bb = do- let datBuf = connWriteBuffer `plusPtr` off- room = min (connBufferSize - off) lim- (len, signal) <- B.runBuilder bb datBuf room- return $ nextForBuilder len signal--fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next-#ifdef WINDOWS-fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}- _ off lim path mpart = do- let datBuf = connWriteBuffer `plusPtr` off- room = min (connBufferSize - off) lim- (start, bytes) <- fileStartEnd path mpart- -- fixme: how to close Handle? GC does it at this moment.- hdl <- IO.openBinaryFile path IO.ReadMode- IO.hSeek hdl IO.AbsoluteSeek start- len <- IO.hGetBufSome hdl datBuf (mini room bytes)- let bytes' = bytes - fromIntegral len- -- fixme: connWriteBuffer connBufferSize- return $ nextForFile len hdl bytes' (return ())-#else-fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}- ii off lim path mpart = do- (mfd, refresh') <- getFd ii path- (fd, refresh) <- case mfd of- Nothing -> do- fd' <- openFile path- th <- T.register (timeoutManager ii) (closeFile fd')- return (fd', T.tickle th)- Just fd -> return (fd, refresh')- let datBuf = connWriteBuffer `plusPtr` off- room = min (connBufferSize - off) lim- (start, bytes) <- fileStartEnd path mpart- len <- positionRead fd datBuf (mini room bytes) start- refresh- let len' = fromIntegral len- return $ nextForFile len fd (start + len') (bytes - len') refresh-#endif--fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)-fileStartEnd _ (Just part) =- return (filePartOffset part, filePartByteCount part)-fileStartEnd _ _ = error "fileStartEnd"--------------------------------------------------------------------fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next-fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}- off lim sq strm = do- let datBuf = connWriteBuffer `plusPtr` off- room = min (connBufferSize - off) lim- (leftover, cont, len) <- runStreamBuilder datBuf room sq- return $ nextForStream sq strm leftover cont len--------------------------------------------------------------------fillBufBuilder :: Leftover -> DynaNext-fillBufBuilder leftover buf0 siz0 lim = do- let payloadBuf = buf0 `plusPtr` frameHeaderLength- room = min (siz0 - frameHeaderLength) lim- case leftover of- LZero -> error "fillBufBuilder: LZero"- LOne writer -> do- (len, signal) <- writer payloadBuf room- getNext len signal- LTwo bs writer- | BS.length bs <= room -> do- buf1 <- copy payloadBuf bs- let len1 = BS.length bs- (len2, signal) <- writer buf1 (room - len1)- getNext (len1 + len2) signal- | otherwise -> do- let (bs1,bs2) = BS.splitAt room bs- void $ copy payloadBuf bs1- getNext room (B.Chunk bs2 writer)- where- getNext l s = return $ nextForBuilder l s--nextForBuilder :: BytesFilled -> B.Next -> Next-nextForBuilder len B.Done- = Next len Nothing-nextForBuilder len (B.More _ writer)- = Next len $ Just (fillBufBuilder (LOne writer))-nextForBuilder len (B.Chunk bs writer)- = Next len $ Just (fillBufBuilder (LTwo bs writer))--------------------------------------------------------------------runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence- -> IO (Leftover, Bool, BytesFilled)-runStreamBuilder buf0 room0 sq = loop buf0 room0 0- where- loop !buf !room !total = do- mbuilder <- atomically $ tryReadTBQueue sq- case mbuilder of- Nothing -> return (LZero, True, total)- Just (SBuilder builder) -> do- (len, signal) <- B.runBuilder builder buf room- let !total' = total + len- case signal of- B.Done -> loop (buf `plusPtr` len) (room - len) total'- B.More _ writer -> return (LOne writer, True, total')- B.Chunk bs writer -> return (LTwo bs writer, True, total')- Just SFlush -> return (LZero, True, total)- Just SFinish -> return (LZero, False, total)--fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext-fillBufStream leftover0 sq strm buf0 siz0 lim0 = do- let payloadBuf = buf0 `plusPtr` frameHeaderLength- room0 = min (siz0 - frameHeaderLength) lim0- case leftover0 of- LZero -> do- (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq- getNext leftover cont len- LOne writer -> write writer payloadBuf room0 0- LTwo bs writer- | BS.length bs <= room0 -> do- buf1 <- copy payloadBuf bs- let len = BS.length bs- write writer buf1 (room0 - len) len- | otherwise -> do- let (bs1,bs2) = BS.splitAt room0 bs- void $ copy payloadBuf bs1- getNext (LTwo bs2 writer) True room0- where- getNext l b r = return $ nextForStream sq strm l b r- write writer1 buf room sofar = do- (len, signal) <- writer1 buf room- case signal of- B.Done -> do- (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq- let !total = sofar + len + extra- getNext leftover cont total- B.More _ writer -> do- let !total = sofar + len- getNext (LOne writer) True total- B.Chunk bs writer -> do- let !total = sofar + len- getNext (LTwo bs writer) True total--nextForStream :: TBQueue Sequence -> Stream- -> Leftover -> Bool -> BytesFilled- -> Next-nextForStream _ _ _ False len = Next len Nothing-nextForStream sq strm leftOrZero True len =- Next len $ Just (fillBufStream leftOrZero sq strm)--------------------------------------------------------------------#ifdef WINDOWS-fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext-fillBufFile h bytes refresh buf siz lim = do- let payloadBuf = buf `plusPtr` frameHeaderLength- room = min (siz - frameHeaderLength) lim- len <- IO.hGetBufSome h payloadBuf room- refresh- let bytes' = bytes - fromIntegral len- return $ nextForFile len h bytes' refresh--nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next-nextForFile 0 _ _ _ = Next 0 Nothing-nextForFile len _ 0 _ = Next len Nothing-nextForFile len h bytes refresh =- Next len $ Just (fillBufFile h bytes refresh)-#else-fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext-fillBufFile fd start bytes refresh buf siz lim = do- let payloadBuf = buf `plusPtr` frameHeaderLength- room = min (siz - frameHeaderLength) lim- len <- positionRead fd payloadBuf (mini room bytes) start- let len' = fromIntegral len- refresh- return $ nextForFile len fd (start + len') (bytes - len') refresh--nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next-nextForFile 0 _ _ _ _ = Next 0 Nothing-nextForFile len _ _ 0 _ = Next len Nothing-nextForFile len fd start bytes refresh =- Next len $ Just (fillBufFile fd start bytes refresh)-#endif--{-# INLINE mini #-}-mini :: Int -> Integer -> Int-mini i n- | fromIntegral i < n = i- | otherwise = fromIntegral n---------------------------------------------------------------------poke32 :: Ptr Word8 -> Word32 -> IO ()-poke32 ptr i = do- poke ptr w0- poke8 ptr 1 w1- poke8 ptr 2 w2- poke8 ptr 3 w3- where- w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)- w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)- w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)- w3 = fromIntegral (i .&. 0xff)- poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()- poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -1,371 +1,78 @@-{-# LANGUAGE OverloadedStrings, CPP #-}-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.HTTP2.Types where -import Control.Concurrent (forkIO)-import Control.Concurrent.STM-import Control.Exception (SomeException, bracket) import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import Data.IORef-import Data.IntMap.Strict (IntMap, IntMap)-import qualified Data.IntMap.Strict as M-import Network.HPACK hiding (Buffer) import qualified Network.HTTP.Types as H-import Network.HTTP2-import Network.HTTP2.Priority-import Network.Wai (Request, FilePart)+import Network.HTTP2.Frame+import qualified Network.HTTP2.Server as H2 -import Network.Wai.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -http2ver :: H.HttpVersion-http2ver = H.HttpVersion 2 0- isHTTP2 :: Transport -> Bool isHTTP2 TCP = False isHTTP2 tls = useHTTP2 where useHTTP2 = case tlsNegotiatedProtocol tls of- Nothing -> False+ Nothing -> False Just proto -> "h2" `BS.isPrefixOf` proto ---------------------------------------------------------------- -data Input = Input Stream Request ValueTable InternalInfo--------------------------------------------------------------------type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next--type BytesFilled = Int--data Next = Next !BytesFilled (Maybe DynaNext)--data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)- | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)- | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder- | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)--rspnStatus :: Rspn -> H.Status-rspnStatus (RspnNobody s _) = s-rspnStatus (RspnStreaming s _ _) = s-rspnStatus (RspnBuilder s _ _) = s-rspnStatus (RspnFile s _ _ _ ) = s--rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)-rspnHeaders (RspnNobody _ t) = t-rspnHeaders (RspnStreaming _ t _) = t-rspnHeaders (RspnBuilder _ t _) = t-rspnHeaders (RspnFile _ t _ _ ) = t--data Output = Output {- outputStream :: !Stream- , outputRspn :: !Rspn- , outputII :: !InternalInfo- , outputHook :: IO () -- OPush: wait for done, O*: telling done- , outputH2Data :: IO (Maybe HTTP2Data)- , outputType :: !OutputType- }--data OutputType = ORspn- | OWait- | OPush !TokenHeaderList !StreamId -- associated stream id from client- | ONext !DynaNext--outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)-outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq-outputMaybeTBQueue _ = Nothing--data Control = CFinish- | CGoaway !ByteString- | CFrame !ByteString- | CSettings !ByteString !SettingsList- | CSettings0 !ByteString !ByteString !SettingsList--------------------------------------------------------------------data Sequence = SFinish- | SFlush- | SBuilder Builder---------------------------------------------------------------------- | The context for HTTP/2 connection.-data Context = Context {- -- HTTP/2 settings received from a browser- http2settings :: !(IORef Settings)- , firstSettings :: !(IORef Bool)- , streamTable :: !StreamTable- , concurrency :: !(IORef Int)- , priorityTreeSize :: !(IORef Int)- -- | RFC 7540 says "Other frames (from any stream) MUST NOT- -- occur between the HEADERS frame and any CONTINUATION- -- frames that might follow". This field is used to implement- -- this requirement.- , continued :: !(IORef (Maybe StreamId))- , clientStreamId :: !(IORef StreamId)- , serverStreamId :: !(IORef StreamId)- , inputQ :: !(TQueue Input)- , outputQ :: !(PriorityTree Output)- , controlQ :: !(TQueue Control)- , encodeDynamicTable :: !DynamicTable- , decodeDynamicTable :: !DynamicTable- -- the connection window for data from a server to a browser.- , connectionWindow :: !(TVar WindowSize)- }--------------------------------------------------------------------newContext :: IO Context-newContext = Context <$> newIORef defaultSettings- <*> newIORef False- <*> newStreamTable- <*> newIORef 0- <*> newIORef 0- <*> newIORef Nothing- <*> newIORef 0- <*> newIORef 0- <*> newTQueueIO- <*> newPriorityTree- <*> newTQueueIO- <*> newDynamicTableForEncoding defaultDynamicTableSize- <*> newDynamicTableForDecoding defaultDynamicTableSize 4096- <*> newTVarIO defaultInitialWindowSize--clearContext :: Context -> IO ()-clearContext _ctx = return ()--------------------------------------------------------------------data OpenState =- JustOpened- | Continued [HeaderBlockFragment]- !Int -- Total size- !Int -- The number of continuation frames- !Bool -- End of stream- !Priority- | NoBody (TokenHeaderList,ValueTable) !Priority- | HasBody (TokenHeaderList,ValueTable) !Priority- | Body !(TQueue ByteString)- !(Maybe Int) -- received Content-Length- -- compared the body length for error checking- !(IORef Int) -- actual body length--data ClosedCode = Finished- | Killed- | Reset !ErrorCodeId- | ResetByMe SomeException- deriving Show--data StreamState =- Idle- | Open !OpenState- | HalfClosedRemote- | HalfClosedLocal !ClosedCode- | Closed !ClosedCode- | Reserved--isIdle :: StreamState -> Bool-isIdle Idle = True-isIdle _ = False--isOpen :: StreamState -> Bool-isOpen Open{} = True-isOpen _ = False--isHalfClosedRemote :: StreamState -> Bool-isHalfClosedRemote HalfClosedRemote = True-isHalfClosedRemote (Closed _) = True-isHalfClosedRemote _ = False--isHalfClosedLocal :: StreamState -> Bool-isHalfClosedLocal (HalfClosedLocal _) = True-isHalfClosedLocal (Closed _) = True-isHalfClosedLocal _ = False--isClosed :: StreamState -> Bool-isClosed Closed{} = True-isClosed _ = False--instance Show StreamState where- show Idle = "Idle"- show Open{} = "Open"- show HalfClosedRemote = "HalfClosedRemote"- show (HalfClosedLocal e) = "HalfClosedLocal: " ++ show e- show (Closed e) = "Closed: " ++ show e- show Reserved = "Reserved"--------------------------------------------------------------------data Stream = Stream {- streamNumber :: !StreamId- , streamState :: !(IORef StreamState)- , streamWindow :: !(TVar WindowSize)- , streamPrecedence :: !(IORef Precedence)- }--instance Show Stream where- show s = show (streamNumber s)--newStream :: StreamId -> WindowSize -> IO Stream-newStream sid win = Stream sid <$> newIORef Idle- <*> newTVarIO win- <*> newIORef defaultPrecedence--newPushStream :: Context -> WindowSize -> Precedence -> IO Stream-newPushStream Context{serverStreamId} win pre = do- sid <- atomicModifyIORef' serverStreamId inc2- Stream sid <$> newIORef Reserved- <*> newTVarIO win- <*> newIORef pre- where- inc2 x = let !x' = x + 2 in (x', x')--------------------------------------------------------------------{-# INLINE readStreamState #-}-readStreamState :: Stream -> IO StreamState-readStreamState Stream{streamState} =- readIORef streamState--{-# INLINE setStreamState #-}-setStreamState :: Context -> Stream -> StreamState -> IO ()-setStreamState _ Stream{streamState} val = writeIORef streamState val--opened :: Context -> Stream -> IO ()-opened ctx@Context{concurrency} strm = do- atomicModifyIORef' concurrency (\x -> (x+1,()))- setStreamState ctx strm (Open JustOpened)--halfClosedRemote :: Context -> Stream -> IO ()-halfClosedRemote ctx stream@Stream{streamState} = do- !closingCode <- atomicModifyIORef streamState closeHalf- case closingCode of- Nothing -> return ()- Just cc -> closed ctx stream cc- where- closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)- closeHalf x@(Closed _) = (x, Nothing)- closeHalf (HalfClosedLocal cc) = (Closed cc, Just cc)- closeHalf _ = (HalfClosedRemote, Nothing)--halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()-halfClosedLocal ctx stream@Stream{streamState} cc = do- shouldFinalize <- atomicModifyIORef streamState closeHalf- when shouldFinalize $- closed ctx stream cc- where- closeHalf :: StreamState -> (StreamState, Bool)- closeHalf x@(Closed _) = (x, False)- closeHalf HalfClosedRemote = (Closed cc, True)- closeHalf _ = (HalfClosedLocal cc, False)--closed :: Context -> Stream -> ClosedCode -> IO ()-closed ctx@Context{concurrency,streamTable} strm@Stream{streamNumber} cc = do- remove streamTable streamNumber- -- TODO: prevent double-counting- atomicModifyIORef' concurrency (\x -> (x-1,()))- setStreamState ctx strm (Closed cc) -- anyway--------------------------------------------------------------------newtype StreamTable = StreamTable (IORef (IntMap Stream))--newStreamTable :: IO StreamTable-newStreamTable = StreamTable <$> newIORef M.empty--insert :: StreamTable -> M.Key -> Stream -> IO ()-insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->- let !m' = M.insert k v m- in (m', ())--remove :: StreamTable -> M.Key -> IO ()-remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->- let !m' = M.delete k m- in (m', ())--search :: StreamTable -> M.Key -> IO (Maybe Stream)-search (StreamTable ref) k = M.lookup k <$> readIORef ref--updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()-updateAllStreamWindow adst (StreamTable ref) = do- strms <- M.elems <$> readIORef ref- forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst--{-# INLINE forkAndEnqueueWhenReady #-}-forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()-forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->- void . forkIO $ do- wait- enqueueOutput outQ out- where- setup = addMyId mgr- teardown _ = deleteMyId mgr--{-# INLINE enqueueOutput #-}-enqueueOutput :: PriorityTree Output -> Output -> IO ()-enqueueOutput outQ out = do- let Stream{..} = outputStream out- pre <- readIORef streamPrecedence- enqueue outQ streamNumber pre out--{-# INLINE enqueueControl #-}-enqueueControl :: TQueue Control -> Control -> IO ()-enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl------------------------------------------------------------------- -- | HTTP/2 specific data. -- -- Since: 3.2.7-data HTTP2Data = HTTP2Data {- -- | Accessor for 'PushPromise' in 'HTTP2Data'.+data HTTP2Data = HTTP2Data+ { http2dataPushPromise :: [PushPromise]+ -- ^ Accessor for 'PushPromise' in 'HTTP2Data'. -- -- Since: 3.2.7- http2dataPushPromise :: [PushPromise]- -- Since: 3.2.8- , http2dataTrailers :: H.ResponseHeaders- } deriving (Eq,Show)+ , http2dataTrailers :: H2.TrailersMaker+ -- ^ Accessor for 'H2.TrailersMaker' in 'HTTP2Data'.+ --+ -- Since: 3.2.8 but the type changed in 3.3.0+ } -- | Default HTTP/2 specific data. -- -- Since: 3.2.7 defaultHTTP2Data :: HTTP2Data-defaultHTTP2Data = HTTP2Data [] []+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'.+data PushPromise = PushPromise+ { promisedPath :: ByteString+ -- ^ Accessor for a URL path in 'PushPromise'. -- E.g. \"\/style\/default.css\". -- -- Since: 3.2.7- promisedPath :: ByteString- -- | Accessor for 'FilePath' in 'PushPromise'.+ , promisedFile :: FilePath+ -- ^ Accessor for 'FilePath' in 'PushPromise'. -- E.g. \"FILE_PATH/default.css\". -- -- Since: 3.2.7- , promisedFile :: FilePath- -- | Accessor for 'H.ResponseHeaders' in 'PushPromise'+ , promisedResponseHeaders :: H.ResponseHeaders+ -- ^ 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'.+ , promisedWeight :: Weight+ -- ^ Accessor for 'Weight' in 'PushPromise'. -- Default value: 16. -- -- Since: 3.2.7- , promisedWeight :: Weight- } deriving (Eq,Ord,Show)+ }+ deriving (Eq, Ord, Show) -- | Default push promise. --
− Network/Wai/Handler/Warp/HTTP2/Worker.hs
@@ -1,331 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}--module Network.Wai.Handler.Warp.HTTP2.Worker (- Responder- , response- , worker- ) where--import Control.Concurrent.STM-import Control.Exception (SomeException(..), AsyncException(..))-import qualified Control.Exception as E-import Data.ByteString.Builder (byteString)-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.HTTP2-import Network.HTTP2.Priority-import Network.Wai-import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..), getRequestBodyChunk)-import qualified System.TimeManager as T--import Network.Wai.Handler.Warp.FileInfoCache-import Network.Wai.Handler.Warp.HTTP2.EncodeFrame-import Network.Wai.Handler.Warp.HTTP2.File-import Network.Wai.Handler.Warp.HTTP2.Manager-import Network.Wai.Handler.Warp.HTTP2.Request-import Network.Wai.Handler.Warp.HTTP2.Types-import Network.Wai.Handler.Warp.Imports hiding (insert)-import Network.Wai.Handler.Warp.Request (pauseTimeoutKey)-import qualified Network.Wai.Handler.Warp.Response as R-import qualified Network.Wai.Handler.Warp.Settings as S-import Network.Wai.Handler.Warp.Types---------------------------------------------------------------------- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.--- This type implements the second argument (Response -> IO ResponseReceived)--- with extra arguments.-type Responder = InternalInfo- -> T.Handle- -> ValueTable -- for Request- -> ThreadContinue- -> Stream- -> Request- -> Response- -> IO ResponseReceived--pushStream :: Context -> S.Settings- -> StreamId -> ValueTable -> Request -> InternalInfo- -> Maybe HTTP2Data- -> IO (OutputType, IO ())-pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())-pushStream ctx@Context{http2settings,outputQ,streamTable}- settings pid reqvt req ii (Just h2d)- | len == 0 = return (ORspn, return ())- | otherwise = do- pushable <- enablePush <$> readIORef http2settings- if pushable then do- tvar <- newTVarIO 0- lim <- push tvar pps0 0- if lim == 0 then- return (ORspn, return ())- else- return (OWait, waiter lim tvar)- else- return (ORspn, return ())- where- !pps0 = http2dataPushPromise h2d- !len = length pps0- !pushLogger = S.settingsServerPushLogger settings- increment tvar = atomically $ modifyTVar' tvar (+1)- waiter lim tvar = atomically $ do- n <- readTVar tvar- check (n >= lim)- !h2data = getHTTP2Data req- push _ [] !n = return (n :: Int)- push tvar (pp:pps) !n = do- let !file = promisedFile pp- efinfo <- E.try $ getFileInfo ii file- case efinfo of- Left (_ex :: E.IOException) -> push tvar pps n- Right (FileInfo _ size _ date) -> do- ws <- initialWindowSize <$> readIORef http2settings- let !w = promisedWeight pp- !pri = defaultPriority { weight = w }- !pre = toPrecedence pri- strm <- newPushStream ctx ws pre- let !sid = streamNumber strm- insert streamTable sid strm- (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)- let !scheme = fromJust $ getHeaderValue tokenScheme reqvt- -- fixme: this value can be Nothing- !auth = fromJust (getHeaderValue tokenHost reqvt- <|> getHeaderValue tokenAuthority reqvt)- !path = promisedPath pp- !promisedRequest = [(tokenMethod, H.methodGet)- ,(tokenScheme, scheme)- ,(tokenAuthority, auth)- ,(tokenPath, path)]- !part = FilePart 0 size size- !rsp = RspnFile H.ok200 (ths,vt) file (Just part)- !ths = (tokenLastModified,date) :- addContentHeadersForFilePart ths0 part- pushLogger req path size- let !ot = OPush promisedRequest pid- !out = Output strm rsp ii (increment tvar) h2data ot- enqueueOutput outputQ out- push tvar pps (n + 1)----- | This function is passed to workers.--- They also pass 'Response's from 'Application's to this function.--- This function enqueues commands for the HTTP/2 sender.-response :: S.Settings -> Context -> Manager -> Responder-response settings ctx@Context{outputQ} mgr ii th reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of- ResponseStream s0 hs0 strmbdy- | noBody s0 -> responseNoBody s0 hs0- | isHead -> responseNoBody s0 hs0- | otherwise -> getHTTP2Data req- >>= pushStream ctx settings sid reqvt req ii- >>= responseStreaming s0 hs0 strmbdy- ResponseBuilder s0 hs0 b- | noBody s0 -> responseNoBody s0 hs0- | isHead -> responseNoBody s0 hs0- | otherwise -> getHTTP2Data req- >>= pushStream ctx settings sid reqvt req ii- >>= responseBuilderBody s0 hs0 b- ResponseFile s0 hs0 p mp- | noBody s0 -> responseNoBody s0 hs0- | otherwise -> getHTTP2Data req- >>= pushStream ctx settings sid reqvt req ii- >>= responseFileXXX s0 hs0 p mp- ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"- where- noBody = not . R.hasBody- !isHead = requestMethod req == H.methodHead- !logger = S.settingsLogger settings- sid = streamNumber strm- !h2data = getHTTP2Data req-- -- Ideally, log messages should be written when responses are- -- actually sent. But there is no way to keep good memory usage- -- (resist to Request leak) and throughput. By compromise,- -- log message are written here even the window size of streams- -- is 0.-- responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s-- responseNoBody' s tbl = do- logger req s Nothing- setThreadContinue tconf True- let !rspn = RspnNobody s tbl- !out = Output strm rspn ii (return ()) h2data ORspn- enqueueOutput outputQ out- return ResponseReceived-- responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do- logger req s Nothing- setThreadContinue tconf True- tbl <- toHeaderTable hs0- let !rspn = RspnBuilder s tbl bdy- !out = Output strm rspn ii tell h2data rspnOrWait- enqueueOutput outputQ out- return ResponseReceived-- responseFileXXX _ hs0 path Nothing aux = do- efinfo <- E.try $ getFileInfo ii path- case efinfo of- Left (_ex :: E.IOException) -> response404 hs0- Right finfo -> do- (rspths0,vt) <- toHeaderTable hs0- case conditionalRequest finfo rspths0 reqvt of- WithoutBody s -> responseNoBody s hs0- WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux-- responseFileXXX s0 hs0 path mpart aux = do- tbl <- toHeaderTable hs0- responseFile2XX s0 tbl path mpart aux-- responseFile2XX s tbl path mpart (rspnOrWait,tell)- | isHead = do- logger req s Nothing- responseNoBody' s tbl- | otherwise = do- logger req s (filePartByteCount <$> mpart)- setThreadContinue tconf True- let !rspn = RspnFile s tbl path mpart- !out = Output strm rspn ii tell h2data rspnOrWait- enqueueOutput outputQ out- return ResponseReceived-- response404 hs0 = responseBuilderBody s hs body (ORspn, return ())- where- s = H.notFound404- hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0- body = byteString "File not found"-- responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do- logger req s0 Nothing- -- We must not exit this WAI application.- -- If the application exits, streaming would be also closed.- -- So, this work occupies this thread.- --- -- We need to increase the number of workers.- spawnAction mgr- -- After this work, this thread stops to decease- -- the number of workers.- setThreadContinue tconf False- -- Since 'StreamingBody' is loop, we cannot control it.- -- So, let's serialize 'Builder' with a designated queue.- tbq <- newTBQueueIO 10 -- fixme: hard coding: 10- tbl <- toHeaderTable hs0- let !rspn = RspnStreaming s0 tbl tbq- !out = Output strm rspn ii tell h2data rspnOrWait- enqueueOutput outputQ out- let push b = do- T.pause th- atomically $ writeTBQueue tbq (SBuilder b)- T.resume th- flush = atomically $ writeTBQueue tbq SFlush- _ <- strmbdy push flush- atomically $ writeTBQueue tbq SFinish- deleteMyId mgr- return ResponseReceived--worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO ()-worker ctx@Context{inputQ,controlQ} set app responder tm = do- sinfo <- newStreamInfo- tcont <- newThreadContinue- let timeoutAction = return () -- cannot close the shared connection- E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont- where- go sinfo tcont th = do- setThreadContinue tcont True- ex <- E.try $ do- T.pause th- inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ- setStreamInfo sinfo inp- T.resume th- T.tickle th- let !body = getRequestBodyChunk req- !body' = do- T.pause th- bs <- body- T.resume th- return bs- !vaultValue = Vault.insert pauseTimeoutKey (T.pause th) $ vault req- !req' = req { vault = vaultValue, requestBody = body' }- mr <- E.try $ app req' $ responder ii th reqvt tcont strm req'- case mr of- Right ok -> return ok- Left e@(SomeException _)- | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e'- | otherwise -> responder ii th reqvt tcont strm req' (S.settingsOnExceptionResponse set e)- cont1 <- case ex of- Right ResponseReceived -> return True- Left e@(SomeException _)- -- killed by the local worker manager- | Just ThreadKilled <- E.fromException e -> return False- -- killed by the local timeout manager- | Just T.TimeoutThread <- E.fromException e -> do- cleanup sinfo Nothing- return True- | otherwise -> do- cleanup sinfo $ Just e- return True- cont2 <- getThreadContinue tcont- clearStreamInfo sinfo- when (cont1 && cont2) $ go sinfo tcont th- cleanup sinfo me = do- minp <- getStreamInfo sinfo- case minp of- Nothing -> return ()- Just (Input strm req _reqvt _ii) -> do- closed ctx strm Killed- let !frame = resetFrame InternalError (streamNumber strm)- enqueueControl controlQ $ CFrame frame- case me of- Nothing -> return ()- Just e -> S.settingsOnException set (Just req) e---------------------------------------------------------------------- | It would nice if responders could return values to workers.--- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.--- It is not wise to change this type.--- So, a reference is shared by a responder and its worker.--- The reference refers a value of this type as a return value.--- If 'True', the worker continue to serve requests.--- Otherwise, the worker get finished.-newtype ThreadContinue = ThreadContinue (IORef Bool)--{-# INLINE newThreadContinue #-}-newThreadContinue :: IO ThreadContinue-newThreadContinue = ThreadContinue <$> newIORef True--{-# INLINE setThreadContinue #-}-setThreadContinue :: ThreadContinue -> Bool -> IO ()-setThreadContinue (ThreadContinue ref) x = writeIORef ref x--{-# INLINE getThreadContinue #-}-getThreadContinue :: ThreadContinue -> IO Bool-getThreadContinue (ThreadContinue ref) = readIORef ref---------------------------------------------------------------------- | The type to store enough information for 'settingsOnException'.-newtype StreamInfo = StreamInfo (IORef (Maybe Input))--{-# INLINE newStreamInfo #-}-newStreamInfo :: IO StreamInfo-newStreamInfo = StreamInfo <$> newIORef Nothing--{-# INLINE clearStreamInfo #-}-clearStreamInfo :: StreamInfo -> IO ()-clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing--{-# INLINE setStreamInfo #-}-setStreamInfo :: StreamInfo -> Input -> IO ()-setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp--{-# INLINE getStreamInfo #-}-getStreamInfo :: StreamInfo -> IO (Maybe Input)-getStreamInfo (StreamInfo ref) = readIORef ref
Network/Wai/Handler/Warp/HashMap.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- module Network.Wai.Handler.Warp.HashMap where import Data.Hashable (hash)@@ -30,13 +28,9 @@ ---------------------------------------------------------------- insert :: FilePath -> v -> HashMap v -> HashMap v-insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm- where- !h = hash path- !m = M.singleton path v- f = M.union -- fimxe+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 h hm >>= M.lookup path- where- !h = hash path+lookup path (HashMap hm) = I.lookup (hash path) hm >>= M.lookup path
Network/Wai/Handler/Warp/Header.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.Header where @@ -20,56 +21,77 @@ indexRequestHeader :: RequestHeaders -> IndexedHeader indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex -data RequestHeaderIndex = ReqContentLength- | ReqTransferEncoding- | ReqExpect- | ReqConnection- | ReqRange- | ReqHost- | ReqIfModifiedSince- | ReqIfUnmodifiedSince- | ReqIfRange- | ReqReferer- | ReqUserAgent- deriving (Enum,Bounded)+data RequestHeaderIndex+ = ReqContentLength+ | ReqTransferEncoding+ | ReqExpect+ | ReqConnection+ | ReqRange+ | ReqHost+ | ReqIfModifiedSince+ | ReqIfUnmodifiedSince+ | ReqIfRange+ | ReqReferer+ | ReqUserAgent+ | ReqIfMatch+ | ReqIfNoneMatch+ deriving (Enum, Bounded) -- | The size for 'IndexedHeader' for HTTP Request.--- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",--- \"Expect\", \"Connection\", \"Range\", \"Host\",--- \"If-Modified-Since\", \"If-Unmodified-Since\" and \"If-Range\".+-- From 0 to this corresponds to:+--+-- - \"Content-Length\"+-- - \"Transfer-Encoding\"+-- - \"Expect\"+-- - \"Connection\"+-- - \"Range\"+-- - \"Host\"+-- - \"If-Modified-Since\"+-- - \"If-Unmodified-Since\"+-- - \"If-Range\"+-- - \"Referer\"+-- - \"User-Agent\"+-- - \"If-Match\"+-- - \"If-None-Match\" requestMaxIndex :: Int requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex) requestKeyIndex :: HeaderName -> Int requestKeyIndex hn = case BS.length bs of- 4 -> if bs == "host" then fromEnum ReqHost else -1- 5 -> if bs == "range" then fromEnum ReqRange else -1- 6 -> if bs == "expect" then fromEnum ReqExpect else -1- 7 -> if bs == "referer" then fromEnum ReqReferer else -1- 8 -> if bs == "if-range" then fromEnum ReqIfRange else -1- 10 -> if bs == "user-agent" then fromEnum ReqUserAgent else- if bs == "connection" then fromEnum ReqConnection else -1- 14 -> if bs == "content-length" then fromEnum ReqContentLength else -1- 17 -> if bs == "transfer-encoding" then fromEnum ReqTransferEncoding else- if bs == "if-modified-since" then fromEnum ReqIfModifiedSince- else -1- 19 -> if bs == "if-unmodified-since" then fromEnum ReqIfUnmodifiedSince else -1- _ -> -1+ 4 | bs == "host" -> fromEnum ReqHost+ 5 | bs == "range" -> fromEnum ReqRange+ 6 | bs == "expect" -> fromEnum ReqExpect+ 7 | bs == "referer" -> fromEnum ReqReferer+ 8+ | bs == "if-range" -> fromEnum ReqIfRange+ | bs == "if-match" -> fromEnum ReqIfMatch+ 10+ | bs == "user-agent" -> fromEnum ReqUserAgent+ | bs == "connection" -> fromEnum ReqConnection+ 13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch+ 14 | bs == "content-length" -> fromEnum ReqContentLength+ 17+ | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding+ | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince+ 19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince+ _ -> -1 where bs = foldedCase hn defaultIndexRequestHeader :: IndexedHeader-defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]+defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0 .. requestMaxIndex]] ---------------------------------------------------------------- indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex -data ResponseHeaderIndex = ResContentLength- | ResServer- | ResDate- deriving (Enum,Bounded)+data ResponseHeaderIndex+ = ResContentLength+ | ResServer+ | ResDate+ | ResLastModified+ deriving (Enum, Bounded) -- | The size for 'IndexedHeader' for HTTP Response. responseMaxIndex :: Int@@ -77,10 +99,11 @@ responseKeyIndex :: HeaderName -> Int responseKeyIndex hn = case BS.length bs of- 4 -> if bs == "date" then fromEnum ResDate else -1- 6 -> if bs == "server" then fromEnum ResServer else -1- 14 -> if bs == "content-length" then fromEnum ResContentLength else -1- _ -> -1+ 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 @@ -88,12 +111,12 @@ traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader traverseHeader hdr maxidx getIndex = runSTArray $ do- arr <- newArray (0,maxidx) Nothing+ arr <- newArray (0, maxidx) Nothing mapM_ (insert arr) hdr return arr where- insert arr (key,val)- | idx == -1 = return ()- | otherwise = writeArray arr idx (Just val)+ insert arr (key, val)+ | idx == -1 = return ()+ | otherwise = writeArray arr idx (Just val) where idx = getIndex key
Network/Wai/Handler/Warp/IO.hs view
@@ -1,30 +1,50 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}- module Network.Wai.Handler.Warp.IO where +import Control.Exception (mask_) import Data.ByteString.Builder (Builder)-import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk))-+import Data.ByteString.Builder.Extra (Next (Chunk, Done, More), runBuilder)+import Data.IORef (IORef, readIORef, writeIORef) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types -toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()-toBufIOWith buf !size io builder = loop firstWriter+toBufIOWith+ :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer+toBufIOWith maxRspBufSize writeBufferRef io builder = do+ writeBuffer <- readIORef writeBufferRef+ loop writeBuffer firstWriter 0 where firstWriter = runBuilder builder- runIO len = bufferIO buf len io- loop writer = do+ loop writeBuffer writer bytesSent = do+ let buf = bufBuffer writeBuffer+ size = bufSize writeBuffer (len, signal) <- writer buf size+ bufferIO buf len io+ let totalBytesSent = toInteger len + bytesSent case signal of- Done -> runIO len- More minSize next- | size < minSize -> error "toBufIOWith: BufferFull: minSize"- | otherwise -> do- runIO len- loop next- Chunk bs next -> do- runIO len- io bs- loop next+ Done -> return totalBytesSent+ More minSize next+ | size < minSize -> do+ when (minSize > maxRspBufSize) $+ error $+ "Sending a Builder response required a buffer of size "+ ++ show minSize+ ++ " which is bigger than the specified maximum of "+ ++ show maxRspBufSize+ ++ "!"+ -- The current WriteBuffer is too small to fit the next+ -- batch of bytes from the Builder so we free it and+ -- create a new bigger one. Freeing the current buffer,+ -- creating a new one and writing it to the IORef need+ -- to be performed atomically to prevent both double+ -- frees and missed frees. So we mask async exceptions:+ biggerWriteBuffer <- mask_ $ do+ bufFree writeBuffer+ biggerWriteBuffer <- createWriteBuffer minSize+ writeIORef writeBufferRef biggerWriteBuffer+ return biggerWriteBuffer+ loop biggerWriteBuffer next totalBytesSent+ | otherwise -> loop writeBuffer next totalBytesSent+ Chunk bs next -> do+ io bs+ loop writeBuffer next totalBytesSent
Network/Wai/Handler/Warp/Imports.hs view
@@ -1,27 +1,39 @@ module Network.Wai.Handler.Warp.Imports (- ByteString(..)- , NonEmpty(..)- , module Control.Applicative- , module Control.Monad- , module Data.Bits- , module Data.List- , module Data.Int- , module Data.Monoid- , module Data.Ord- , module Data.Word- , module Data.Maybe- , module Numeric- ) where+ ByteString (..),+ NonEmpty (..),+ module Control.Applicative,+ module Control.Monad,+ module Data.Bits,+ module Data.Int,+ module Data.Monoid,+ module Data.Ord,+ module Data.Word,+ module Data.Maybe,+ module Numeric,+ throughAsync,+ isAsyncException,+) where import Control.Applicative+import Control.Exception import Control.Monad import Data.Bits-import Data.ByteString.Internal (ByteString(..))+import Data.ByteString.Internal (ByteString (..)) import Data.Int-import Data.List-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Monoid import Data.Ord import Data.Word import Numeric++isAsyncException :: Exception e => e -> Bool+isAsyncException e =+ case fromException (toException e) of+ Just (SomeAsyncException _) -> True+ Nothing -> False++throughAsync :: IO a -> SomeException -> IO a+throughAsync action (SomeException e)+ | isAsyncException e = throwIO e+ | otherwise = action
Network/Wai/Handler/Warp/Internal.hs view
@@ -1,41 +1,71 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} +-- |+-- __IMPORTANT NOTICE__+--+-- This module exports internals mainly to provide the @warp-tls@ package+-- with tools to implement what it needs to. This module\/API should /NOT/ be+-- expected to remain stable at all, even between minor releases.+--+-- If you see a use case for these functions or types for other purposes,+-- please create an issue in the repository so that we might add it to the+-- main 'Network.Wai.Handler.Warp' API. module Network.Wai.Handler.Warp.Internal ( -- * Settings- Settings (..)- , ProxyProtocol(..)+ Settings (..),+ ProxyProtocol (..),+ makeSettingsAndCounter,+ makeSettingsAndServerState,++ -- ** Connection counter+ Counter,+ getCount,++ -- ** Server state+ ServerState,+ makeServerState,+ -- * Low level run functions- , runSettingsConnection- , runSettingsConnectionMaker- , runSettingsConnectionMakerSecure- , Transport (..)+ runSettingsConnection,+ runSettingsConnectionMaker,+ runSettingsConnectionMakerSecure,+ Transport (..),+ -- * Connection- , Connection (..)- , socketConnection+ Connection (..),+ socketConnection,+ -- ** Receive- , Recv- , RecvBuf- , makePlainReceiveN+ Recv,+ makeGracefulRecv,+ RecvBuf,+ -- ** Buffer- , Buffer- , BufSize- , bufferSize- , allocateBuffer- , freeBuffer- , copy+ Buffer,+ BufSize,+ WriteBuffer (..),+ createWriteBuffer,+ allocateBuffer,+ freeBuffer,+ copy,+ -- ** Sendfile- , FileId (..)- , SendFile- , sendFile- , readSendFile+ FileId (..),+ SendFile,+ sendFile,+ readSendFile,+ -- * Version- , warpVersion+ warpVersion,+ -- * Data types- , InternalInfo (..)- , HeaderValue- , IndexedHeader- , requestMaxIndex+ InternalInfo (..),+ HeaderValue,+ IndexedHeader,+ requestMaxIndex,+ -- * Time out manager+ -- | -- -- In order to provide slowloris protection, Warp provides timeout handlers. We@@ -53,30 +83,45 @@ -- 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+ module System.TimeManager,+ -- * File descriptor cache- , module Network.Wai.Handler.Warp.FdCache+ module Network.Wai.Handler.Warp.FdCache,+ -- * File information cache- , module Network.Wai.Handler.Warp.FileInfoCache+ module Network.Wai.Handler.Warp.FileInfoCache,+ -- * Date- , module Network.Wai.Handler.Warp.Date+ module Network.Wai.Handler.Warp.Date,+ -- * Request and response- , Source- , recvRequest- , sendResponse+ Source,+ FirstRequest (..),+ recvRequest,+ sendResponse,+ -- * Platform dependent helper functions- , setSocketCloseOnExec- , windowsThreadBlockHack- ) where+ setSocketCloseOnExec,+ windowsThreadBlockHack, + -- * Misc+ http2server,+ withII,+ serveConnection,+ pReadMaker,+) where++import Network.Socket.BufferPool import System.TimeManager import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Counter (Counter, getCount) import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.FileInfoCache+import Network.Wai.Handler.Warp.HTTP2+import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.Header-import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Run
Network/Wai/Handler/Warp/MultiMap.hs view
@@ -1,17 +1,16 @@-{-# LANGUAGE BangPatterns #-}- module Network.Wai.Handler.Warp.MultiMap (- MultiMap- , isEmpty- , empty- , singleton- , insert- , Network.Wai.Handler.Warp.MultiMap.lookup- , pruneWith- , toList- , merge- ) where+ 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@@ -20,22 +19,22 @@ ---------------------------------------------------------------- --- | 'MultiMap' is used for cache of file descriptors.--- Since multiple threads would open file descriptors for--- the same file simultaneously, multiple entries must--- be contained for the file.--- Since hash values of file pathes are used as outer keys,--- collison would happen for multiple file pathes.--- Becase only positive entries are contained,--- a bad guy cannot be cause the hash collision intentinally.+-- | '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)])+newtype MultiMap v = MultiMap (IntMap [(FilePath, v)]) ---------------------------------------------------------------- -- | O(1) empty :: MultiMap v-empty = MultiMap $ I.empty+empty = MultiMap I.empty -- | O(1) isEmpty :: MultiMap v -> Bool@@ -45,67 +44,48 @@ -- | O(1) singleton :: FilePath -> v -> MultiMap v-singleton path v = MultiMap mm- where- !h = hash path- !mm = I.singleton h [(path,v)]+singleton path v = MultiMap $ I.singleton (hash path) [(path, v)] ---------------------------------------------------------------- --- | O(N)+-- | O(M) where M is the number of entries per file lookup :: FilePath -> MultiMap v -> Maybe v-lookup path (MultiMap mm) = case I.lookup h mm of+lookup path (MultiMap mm) = case I.lookup (hash path) mm of Nothing -> Nothing- Just s -> Prelude.lookup path s- where- !h = hash path+ Just s -> Prelude.lookup path s ---------------------------------------------------------------- -- | O(log n) insert :: FilePath -> v -> MultiMap v -> MultiMap v-insert path v (MultiMap mm) = MultiMap mm'- where- !h = hash path- !mm' = I.insertWith (<>) h [(path,v)] mm+insert path v (MultiMap mm) =+ MultiMap $+ I.insertWith (<>) (hash path) [(path, v)] mm ---------------------------------------------------------------- -- | O(n)-toList :: MultiMap v -> [(FilePath,v)]+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 = MultiMap <$> mm'+pruneWith+ :: MultiMap v+ -> ((FilePath, v) -> IO Bool)+ -> IO (MultiMap v)+pruneWith (MultiMap mm) action =+ I.foldrWithKey go (pure . MultiMap) mm I.empty where- !mm' = I.fromAscList <$> go (I.toDescList mm) []- go [] !acc = return acc- go ((h,s):kss) !acc = do- rs <- prune action s+ go h s cont acc = do+ rs <- filterM action s case rs of- [] -> go kss acc- _ -> go kss ((h,rs) : acc)+ [] -> 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 mm- where- !mm = I.unionWith (<>) m1 m2--------------------------------------------------------------------prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]-prune action xs0 = go xs0- where- go [] = return []- go (x:xs) = do- keep <- action x- rs <- go xs- return $ if keep then x:rs else rs+merge (MultiMap m1) (MultiMap m2) = MultiMap $ I.unionWith (<>) m1 m2
Network/Wai/Handler/Warp/PackInt.hs view
@@ -1,23 +1,16 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.PackInt where import Data.ByteString.Internal (unsafeCreate)+import Data.Word8 (_0) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke) import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Imports --- $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"@@ -28,10 +21,9 @@ 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)+ let (d, r) = i `divMod` 10+ poke p (_0 + fromIntegral r) when (d /= 0) $ go d (p `plusPtr` (-1))- {-# SPECIALIZE packIntegral :: Int -> ByteString #-} {-# SPECIALIZE packIntegral :: Integer -> ByteString #-} @@ -41,16 +33,15 @@ -- "200" -- >>> packStatus H.preconditionFailed412 -- "412"- packStatus :: H.Status -> ByteString packStatus status = unsafeCreate 3 $ \p -> do- poke p (toW8 r2)+ 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+ toW8 n = _0 + fromIntegral n !s = fromIntegral $ H.statusCode status- (!q0,!r0) = s `divMod` 10- (!q1,!r1) = q0 `divMod` 10+ (!q0, !r0) = s `divMod` 10+ (!q1, !r1) = q0 `divMod` 10 !r2 = q1 `mod` 10
Network/Wai/Handler/Warp/ReadInt.hs view
@@ -1,26 +1,22 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} -- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com> -- License : BSD3 module Network.Wai.Handler.Warp.ReadInt (- readInt- , readInt64- ) where---- This function lives in its own file because the MagicHash pragma interacts--- poorly with the CPP pragma.+ readInt,+ readInt64,+) where import qualified Data.ByteString as S-import GHC.Prim-import GHC.Types-import GHC.Word+import Data.Word8 (isDigit, _0) import Network.Wai.Handler.Warp.Imports hiding (readInt) {-# INLINE readInt #-}++-- | Will 'takeWhile isDigit' and return the parsed 'Integral'. readInt :: Integral a => ByteString -> a readInt bs = fromIntegral $ readInt64 bs @@ -34,34 +30,6 @@ {-# NOINLINE readInt64 #-} readInt64 :: ByteString -> Int64-readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (mhDigitToInt c)) 0- $ S.takeWhile isDigit bs--data Table = Table !Addr#--{-# NOINLINE mhDigitToInt #-}-mhDigitToInt :: Word8 -> Int-mhDigitToInt (W8# i) = I# (word2Int# (indexWord8OffAddr# addr (word2Int# i)))- where- !(Table addr) = table- table :: Table- table = Table- "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--isDigit :: Word8 -> Bool-isDigit w = w >= 48 && w <= 57+readInt64 bs =+ S.foldl' (\ !i !c -> i * 10 + fromIntegral (c - _0)) 0 $+ S.takeWhile isDigit bs
− Network/Wai/Handler/Warp/Recv.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Network.Wai.Handler.Warp.Recv (- receive- , receiveBuf- , makeReceiveN- , makePlainReceiveN- , spell- ) where--import qualified Control.Exception as E-import qualified Data.ByteString as BS-import Data.IORef-import Foreign.C.Error (eAGAIN, getErrno, throwErrno)-import Foreign.C.Types-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, castPtr, plusPtr)-import GHC.Conc (threadWaitRead)-import Network.Socket (Socket, fdSocket)-import System.Posix.Types (Fd(..))--import Network.Wai.Handler.Warp.Buffer-import Network.Wai.Handler.Warp.Imports-import Network.Wai.Handler.Warp.Types--#ifdef mingw32_HOST_OS-import GHC.IO.FD (FD(..), readRawBufferPtr)-import Network.Wai.Handler.Warp.Windows-#endif--------------------------------------------------------------------makeReceiveN :: ByteString -> Recv -> RecvBuf -> IO (BufSize -> IO ByteString)-makeReceiveN bs0 recv recvBuf = do- ref <- newIORef bs0- return $ receiveN ref recv recvBuf---- | This function returns a receiving function--- based on two receiving functions.--- The returned function efficiently manages received data--- which is initialized by the first argument.--- The returned function may allocate a byte string with malloc().-makePlainReceiveN :: Socket -> ByteString -> IO (BufSize -> IO ByteString)-makePlainReceiveN s bs0 = do- ref <- newIORef bs0- pool <- newBufferPool- return $ receiveN ref (receive s pool) (receiveBuf s)--receiveN :: IORef ByteString -> Recv -> RecvBuf -> BufSize -> IO ByteString-receiveN ref recv recvBuf size = E.handle handler $ do- cached <- readIORef ref- (bs, leftover) <- spell cached size recv recvBuf- writeIORef ref leftover- return bs- where- handler :: E.SomeException -> IO ByteString- handler _ = return ""--------------------------------------------------------------------spell :: ByteString -> BufSize -> IO ByteString -> RecvBuf -> IO (ByteString, ByteString)-spell init0 siz0 recv recvBuf- | siz0 <= len0 = return $ BS.splitAt siz0 init0- -- fixme: hard coding 4096- | siz0 <= 4096 = loop [init0] (siz0 - len0)- | otherwise = do- bs@(PS fptr _ _) <- mallocBS siz0- withForeignPtr fptr $ \ptr -> do- ptr' <- copy ptr init0- full <- recvBuf ptr' (siz0 - len0)- if full then- return (bs, "")- else- return ("", "") -- fixme- where- len0 = BS.length init0- loop bss siz = do- bs <- recv- let len = BS.length bs- if len == 0 then- return ("", "")- else if len >= siz then do- let (consume, leftover) = BS.splitAt siz bs- ret = BS.concat $ reverse (consume : bss)- return (ret, leftover)- else do- let bss' = bs : bss- siz' = siz - len- loop bss' siz'--receive :: Socket -> BufferPool -> Recv-receive sock pool = withBufferPool pool $ \ (ptr, size) -> do-#if MIN_VERSION_network(3,0,0)- fd <- fdSocket sock-#else- let fd = fdSocket sock-#endif- let size' = fromIntegral size- fromIntegral <$> receiveloop fd ptr size'--receiveBuf :: Socket -> RecvBuf-receiveBuf sock buf0 siz0 = do-#if MIN_VERSION_network(3,0,0)- fd <- fdSocket sock-#else- let fd = fdSocket sock-#endif- loop fd buf0 siz0- where- loop _ _ 0 = return True- loop fd buf siz = do- n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz)- -- fixme: what should we do in the case of n == 0- if n == 0 then- return False- else- loop fd (buf `plusPtr` n) (siz - n)--receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt-receiveloop sock ptr size = do-#ifdef mingw32_HOST_OS- bytes <- windowsThreadBlockHack $ fromIntegral <$> readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size-#else- bytes <- c_recv sock (castPtr ptr) size 0-#endif- if bytes == -1 then do- errno <- getErrno- if errno == eAGAIN then do- threadWaitRead (Fd sock)- receiveloop sock ptr size- else- throwErrno "receiveloop"- else- return bytes---- fixme: the type of the return value-foreign import ccall unsafe "recv"- c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
Network/Wai/Handler/Warp/Request.hs view
@@ -1,185 +1,209 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Request (- recvRequest- , headerLines- , pauseTimeoutKey- , getFileInfoKey- , NoKeepAliveRequest (..)- ) where+ FirstRequest(..),+ recvRequest,+ headerLines,+ pauseTimeoutKey,+ getFileInfoKey,+#ifdef MIN_VERSION_crypton_x509+ getClientCertificateKey,+#endif+ NoKeepAliveRequest (..),+) where import qualified Control.Concurrent as Conc (yield)-import Control.Exception (throwIO, 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+import Data.Word8 (_cr, _lf)+#ifdef MIN_VERSION_crypton_x509+import Data.X509+#endif+import Control.Exception (Exception, throwIO) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.Types import Network.Wai.Internal-import Prelude hiding (lines) import System.IO.Unsafe (unsafePerformIO) import qualified System.TimeManager as Timeout+import Prelude hiding (lines) import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header-import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)+import Network.Wai.Handler.Warp.Imports hiding (readInt) import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader-import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)+import Network.Wai.Handler.Warp.Settings (+ Settings,+ settingsMaxTotalHeaderLength,+ settingsNoParsePath,+ ) ---------------------------------------------------------------- --- FIXME come up with good values here-maxTotalHeaderLength :: Int-maxTotalHeaderLength = 50 * 1024------------------------------------------------------------------+-- | first request on this connection?+data FirstRequest = FirstRequest | SubsequentRequest -- | Receiving a HTTP request from 'Connection' and parsing its header -- to create 'Request'.-recvRequest :: Bool -- ^ first request on this connection?- -> Settings- -> Connection- -> InternalInfo- -> Timeout.Handle- -> SockAddr -- ^ Peer's address.- -> Source -- ^ Where HTTP request comes from.- -> IO (Request- ,Maybe (I.IORef Int)- ,IndexedHeader- ,IO ByteString) -- ^- -- 'Request' passed to 'Application',- -- how many bytes remain to be consumed, if known- -- 'IndexedHeader' of HTTP request for internal use,- -- Body producing action used for flushing the request body--recvRequest firstRequest settings conn ii th addr src = do- hdrlines <- headerLines firstRequest src- (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines+recvRequest+ :: FirstRequest+ -> Settings+ -> Connection+ -> InternalInfo+ -> Timeout.Handle+ -> SockAddr+ -- ^ Peer's address.+ -> Source+ -- ^ Where HTTP request comes from.+ -> Transport+ -> IO+ ( Request+ , Maybe (I.IORef Int)+ , IndexedHeader+ , IO ByteString+ )+ -- ^+ -- 'Request' passed to 'Application',+ -- how many bytes remain to be consumed, if known+ -- 'IndexedHeader' of HTTP request for internal use,+ -- Body producing action used for flushing the request body+recvRequest firstRequest settings conn ii th addr src transport = do+ hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src+ (method, unparsedPath, path, query, httpversion, hdr) <-+ parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr expect = idxhdr ! fromEnum ReqExpect- cl = idxhdr ! fromEnum ReqContentLength- te = idxhdr ! fromEnum ReqTransferEncoding handle100Continue = handleExpect conn httpversion expect- rawPath = if settingsNoParsePath settings then unparsedPath else path- vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)- $ Vault.insert getFileInfoKey (getFileInfo ii)- Vault.empty- (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te+ (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr -- body producing function which will produce '100-continue', if needed rbody' <- timeoutBody remainingRef th rbody handle100Continue -- body producing function which will never produce 100-continue rbodyFlush <- timeoutBody remainingRef th rbody (return ())- let req = Request {- requestMethod = method- , httpVersion = httpversion- , pathInfo = H.decodePathSegments path- , rawPathInfo = rawPath- , rawQueryString = query- , queryString = H.parseQuery query- , requestHeaders = hdr- , isSecure = False- , remoteHost = addr- , requestBody = rbody'- , vault = vaultValue- , requestBodyLength = bodyLength- , requestHeaderHost = idxhdr ! fromEnum ReqHost- , requestHeaderRange = idxhdr ! fromEnum ReqRange- , requestHeaderReferer = idxhdr ! fromEnum ReqReferer- , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent- }+ let rawPath = if settingsNoParsePath settings then unparsedPath else path+ vaultValue =+ Vault.insert pauseTimeoutKey (Timeout.pause th)+ . Vault.insert getFileInfoKey (getFileInfo ii)+#ifdef MIN_VERSION_crypton_x509+ . Vault.insert getClientCertificateKey (getTransportClientCertificate transport)+#endif+ $ Vault.empty+ req =+ Request+ { requestMethod = method+ , httpVersion = httpversion+ , pathInfo = H.decodePathSegments path+ , rawPathInfo = rawPath+ , rawQueryString = query+ , queryString = H.parseQuery query+ , requestHeaders = hdr+ , isSecure = isTransportSecure transport+ , remoteHost = addr+ , requestBody = rbody'+ , vault = vaultValue+ , requestBodyLength = bodyLength+ , requestHeaderHost = idxhdr ! fromEnum ReqHost+ , requestHeaderRange = idxhdr ! fromEnum ReqRange+ , requestHeaderReferer = idxhdr ! fromEnum ReqReferer+ , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent+ } return (req, remainingRef, idxhdr, rbodyFlush) ---------------------------------------------------------------- -headerLines :: Bool -> Source -> IO [ByteString]-headerLines firstRequest src = do+headerLines :: Int -> FirstRequest -> 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+ then -- When we're working on a keep-alive connection and trying to -- get the second or later request, we don't want to treat the -- lack of data as a real exception. See the http1 function in -- the Run module for more details.- then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest- else push src (THStatus 0 id id) bs + case firstRequest of+ FirstRequest -> throwIO ConnectionClosedByPeer+ SubsequentRequest -> throwIO NoKeepAliveRequest+ else push maxTotalHeaderLength src (THStatus 0 0 id id) bs+ data NoKeepAliveRequest = NoKeepAliveRequest- deriving (Show, Typeable)+ deriving (Show) instance Exception NoKeepAliveRequest ---------------------------------------------------------------- -handleExpect :: Connection- -> H.HttpVersion- -> Maybe HeaderValue- -> IO ()+handleExpect+ :: Connection+ -> H.HttpVersion+ -> Maybe HeaderValue+ -> IO () handleExpect conn ver (Just "100-continue") = do connSendAll conn continue Conc.yield where continue- | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n"- | otherwise = "HTTP/1.0 100 Continue\r\n\r\n"-handleExpect _ _ _ = return ()+ | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n"+ | otherwise = "HTTP/1.0 100 Continue\r\n\r\n"+handleExpect _ _ _ = return () ---------------------------------------------------------------- -bodyAndSource :: Source- -> Maybe HeaderValue -- ^ content length- -> Maybe HeaderValue -- ^ transfer-encoding- -> IO (IO ByteString- ,Maybe (I.IORef Int)- ,RequestBodyLength- )-bodyAndSource src cl te- | chunked = do- csrc <- mkCSource src- return (readCSource csrc, Nothing, ChunkedBody)- | otherwise = do- isrc@(ISource _ remaining) <- mkISource src len- return (readISource isrc, Just remaining, bodyLen)+bodyAndSource+ :: Source+ -> IndexedHeader+ -> IO+ ( IO ByteString+ , Maybe (I.IORef Int)+ , RequestBodyLength+ )+bodyAndSource src idxhdr+ | chunked = do+ csrc <- mkCSource src+ return (readCSource csrc, Nothing, ChunkedBody)+ | otherwise = do+ let len = toLength $ idxhdr ! fromEnum ReqContentLength+ bodyLen = KnownLength $ fromIntegral len+ isrc@(ISource _ remaining) <- mkISource src len+ return (readISource isrc, Just remaining, bodyLen) where- len = toLength cl- bodyLen = KnownLength $ fromIntegral len- chunked = isChunked te+ chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding toLength :: Maybe HeaderValue -> Int-toLength Nothing = 0+toLength Nothing = 0 toLength (Just bs) = readInt bs isChunked :: Maybe HeaderValue -> Bool isChunked (Just bs) = CI.foldCase bs == "chunked"-isChunked _ = False+isChunked _ = False ---------------------------------------------------------------- -timeoutBody :: Maybe (I.IORef Int) -- ^ remaining- -> Timeout.Handle- -> IO ByteString- -> IO ()- -> IO (IO ByteString)+timeoutBody+ :: Maybe (I.IORef Int)+ -- ^ remaining+ -> Timeout.Handle+ -> IO ByteString+ -> IO ()+ -> IO (IO ByteString) timeoutBody remainingRef timeoutHandle rbody handle100Continue = do isFirstRef <- I.newIORef True let checkEmpty = case remainingRef of Nothing -> return . S.null- Just ref -> \bs -> if S.null bs- then return True- else do- x <- I.readIORef ref- return $! x <= 0+ Just ref -> \bs ->+ if S.null bs+ then return True+ else do+ x <- I.readIORef ref+ return $! x <= 0 return $ do isFirst <- I.readIORef isFirstRef@@ -207,13 +231,15 @@ ---------------------------------------------------------------- -type BSEndo = ByteString -> ByteString+type BSEndo = S.ByteString -> S.ByteString type BSEndoList = [ByteString] -> [ByteString] -data THStatus = THStatus- {-# UNPACK #-} !Int -- running total byte count- BSEndoList -- previously parsed lines- BSEndo -- bytestrings to be prepended+data THStatus+ = THStatus+ Int -- running total byte count (excluding current header chunk)+ Int -- current header chunk byte count+ BSEndoList -- previously parsed lines+ BSEndo -- bytestrings to be prepended ---------------------------------------------------------------- @@ -222,75 +248,85 @@ close = throwIO IncompleteHeaders -} -push :: Source -> THStatus -> ByteString -> IO [ByteString]-push src (THStatus len lines prepend) bs'+-- | Assumes the 'ByteString' is never 'S.null'+push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]+push maxTotalHeaderLength src (THStatus totalLen chunkLen reqLines prepend) bs+ -- Newline found at index 'ix'+ | Just ix <- S.elemIndex _lf bs = do -- Too many bytes- | len > maxTotalHeaderLength = throwIO OverLargeHeader- | otherwise = push' mnl+ when (currentTotal > maxTotalHeaderLength) $ throwIO OverLargeHeader+ newlineFound ix+ -- No newline found+ | otherwise = do+ -- Early easy abort+ when (currentTotal + bsLen > maxTotalHeaderLength) $ throwIO OverLargeHeader+ withNewChunk noNewlineFound where- bs = prepend bs' bsLen = S.length bs- mnl = do- nl <- S.elemIndex 10 bs- -- check if there are two more bytes in the bs- -- if so, see if the second of those is a horizontal space- if bsLen > nl + 1 then- let c = S.index bs (nl + 1)- b = case nl of- 0 -> True- 1 -> S.index bs 0 == 13- _ -> False- in Just (nl, not b && (c == 32 || c == 9))- else- Just (nl, False)-- {-# INLINE push' #-}- push' :: Maybe (Int, Bool) -> IO [ByteString]- -- No newline find in this chunk. Add it to the prepend,- -- update the length, and continue processing.- push' Nothing = do- bst <- readSource' src- when (S.null bst) $ throwIO IncompleteHeaders- push src status bst- where- len' = len + bsLen- prepend' = S.append bs- status = THStatus len' lines prepend'- -- Found a newline, but next line continues as a multiline header- push' (Just (end, True)) = push src status rest- where- rest = S.drop (end + 1) bs- prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)- len' = len + end- status = THStatus len' lines prepend'- -- Found a newline at position end.- push' (Just (end, False))- -- leftover- | S.null line = do- when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs)- return (lines [])- -- more headers- | otherwise = let len' = len + start- lines' = lines . (line:)- status = THStatus len' lines' id- in if start < bsLen then- -- more bytes in this chunk, push again- let bs'' = SU.unsafeDrop start bs- in push src status bs''- else do- -- no more bytes in this chunk, ask for more- bst <- readSource' src- when (S.null bs) $ throwIO IncompleteHeaders- push src status bst+ currentTotal = totalLen + chunkLen+ {-# INLINE withNewChunk #-}+ withNewChunk :: (S.ByteString -> IO a) -> IO a+ withNewChunk f = do+ newChunk <- readSource' src+ when (S.null newChunk) $ throwIO IncompleteHeaders+ f newChunk+ {-# INLINE noNewlineFound #-}+ noNewlineFound newChunk+ -- The chunk split the CRLF in half+ | SU.unsafeLast bs == _cr && S.head newChunk == _lf =+ let bs' = SU.unsafeDrop 1 newChunk+ in if bsLen == 1 && chunkLen == 0+ -- first part is only CRLF, we're done+ then do+ when (not $ S.null bs') $ leftoverSource src bs'+ pure $ reqLines []+ else do+ rest <- if S.null bs'+ -- new chunk is only LF, we need more to check for multiline+ then withNewChunk pure+ else pure bs'+ let status = addLine (bsLen + 1) (SU.unsafeTake (bsLen - 1) bs)+ push maxTotalHeaderLength src status rest+ -- chunk and keep going+ | otherwise = do+ let newChunkTotal = chunkLen + bsLen+ newPrepend = prepend . (bs <>)+ status = THStatus totalLen newChunkTotal reqLines newPrepend+ push maxTotalHeaderLength src status newChunk+ {-# INLINE newlineFound #-}+ newlineFound ix+ -- Is end of headers+ | chunkLen == 0 && startsWithLF = do+ let rest = SU.unsafeDrop end bs+ when (not $ S.null rest) $ leftoverSource src rest+ pure $ reqLines []+ | otherwise = do+ -- LF is on last byte+ let p = ix - 1+ chunk =+ if ix > 0 && SU.unsafeIndex bs p == _cr then p else ix+ status = addLine end (SU.unsafeTake chunk bs)+ continue = push maxTotalHeaderLength src status+ if end == bsLen+ then withNewChunk continue+ else continue $ SU.unsafeDrop end bs where- start = end + 1 -- start of next chunk- line = SU.unsafeTake (checkCR bs end) bs+ end = ix + 1+ startsWithLF =+ case ix of+ 0 -> True+ 1 -> SU.unsafeHead bs == _cr+ _ -> False+ -- addLine: take the current chunk and, if there's nothing to prepend,+ -- add straight to 'reqLines', otherwise first prepend then add.+ {-# INLINE addLine #-}+ addLine len chunk =+ let newTotal = currentTotal + len+ newLine =+ if chunkLen == 0 then chunk else prepend chunk+ in THStatus newTotal 0 (reqLines . (newLine:)) id+{- HLint ignore push "Use unless" -} -{-# INLINE checkCR #-}-checkCR :: ByteString -> Int -> Int-checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR- where- !p = pos - 1 pauseTimeoutKey :: Vault.Key (IO ()) pauseTimeoutKey = unsafePerformIO Vault.newKey@@ -299,3 +335,9 @@ getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo) getFileInfoKey = unsafePerformIO Vault.newKey {-# NOINLINE getFileInfoKey #-}++#ifdef MIN_VERSION_crypton_x509+getClientCertificateKey :: Vault.Key (Maybe CertificateChain)+getClientCertificateKey = unsafePerformIO Vault.newKey+{-# NOINLINE getClientCertificateKey #-}+#endif
Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.RequestHeader (- parseHeaderLines- ) where+ parseHeaderLines,+) where import Control.Exception (throwIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 (unpack) import Data.ByteString.Internal (memchr) import qualified Data.CaseInsensitive as CI+import Data.Word8 import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)+import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr) import Foreign.Storable (peek) import qualified Network.HTTP.Types as H @@ -22,16 +23,18 @@ ---------------------------------------------------------------- -parseHeaderLines :: [ByteString]- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Path, parsed- ,ByteString -- Query- ,H.HttpVersion- ,H.RequestHeaders- )+parseHeaderLines+ :: [ByteString]+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Path, parsed+ , ByteString -- Query+ , H.HttpVersion+ , H.RequestHeaders+ ) parseHeaderLines [] = throwIO $ NotEnoughLines []-parseHeaderLines (firstLine:otherLines) = do+parseHeaderLines (firstLine : otherLines) = do (method, path', query, httpversion) <- parseRequestLine firstLine let path = H.extractPath path' hdr = map parseHeader otherLines@@ -51,24 +54,27 @@ -- *** Exception: Warp: Request line specified a non-HTTP request -- >>> parseRequestLine "PRI * HTTP/2.0" -- ("PRI","*","",HTTP/2.0)-parseRequestLine :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len - pathptr0 <- memchr methodptr 32 lim0 -- ' '+ pathptr0 <- memchr methodptr _space lim0 when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ throwIO baderr let pathptr = pathptr0 `plusPtr` 1 lim1 = fromIntegral (limptr `minusPtr` pathptr0) - httpptr0 <- memchr pathptr 32 lim1 -- ' '+ httpptr0 <- memchr pathptr _space lim1 when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1@@ -76,17 +82,17 @@ checkHTTP httpptr !hv <- httpVersion httpptr- queryptr <- memchr pathptr 63 lim2 -- '?'+ queryptr <- memchr pathptr _question lim2 let !method = bs ptr methodptr pathptr0 !path- | queryptr == nullPtr = bs ptr pathptr httpptr0- | otherwise = bs ptr pathptr queryptr+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr !query- | queryptr == nullPtr = S.empty- | otherwise = bs ptr queryptr httpptr0+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0 - return (method,path,query,hv)+ return (method, path, query, hv) where baderr = BadFirstLine $ C8.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO ()@@ -94,19 +100,19 @@ w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do- check httpptr 0 72 -- 'H'- check httpptr 1 84 -- 'T'- check httpptr 2 84 -- 'T'- check httpptr 3 80 -- 'P'- check httpptr 4 47 -- '/'- check httpptr 6 46 -- '.'+ check httpptr 0 _H+ check httpptr 1 _T+ check httpptr 2 _T+ check httpptr 3 _P+ check httpptr 4 _slash+ check httpptr 6 _period httpVersion httpptr = do major <- peek (httpptr `plusPtr` 5) :: IO Word8 minor <- peek (httpptr `plusPtr` 7) :: IO Word8 let version- | major == 49 = if minor == 49 then H.http11 else H.http10- | major == 50 && minor == 48 = H.HttpVersion 2 0- | otherwise = H.http10+ | major == _1 = if minor == _1 then H.http11 else H.http10+ | major == _2 && minor == _0 = H.http20+ | otherwise = H.http10 return version bs ptr p0 p1 = PS fptr o l where@@ -125,9 +131,8 @@ -- ("Host","example.com:8080") -- >>> parseHeader "NoSemiColon" -- ("NoSemiColon","")- parseHeader :: ByteString -> H.Header parseHeader s =- let (k, rest) = S.break (== 58) s -- ':'- rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest+ let (k, rest) = S.break (== _colon) s+ rest' = S.dropWhile (\c -> c == _space || c == _tab) $ S.drop 1 rest in (CI.mk k, rest')
Network/Wai/Handler/Warp/Response.hs view
@@ -1,35 +1,42 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.Response (- sendResponse- , sanitizeHeaderValue -- for testing- , warpVersion- , hasBody- , replaceHeader- , addServer -- testing- ) where+ sendResponse,+ sanitizeHeaderValue, -- for testing+ -- Provided here for backwards compatibility.+ warpVersion,+ hasBody,+ replaceHeader,+ addServer, -- testing+ addAltSvc,+) where -import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator) import qualified Control.Exception as E import Data.Array ((!)) import qualified Data.ByteString as S-import Data.ByteString.Builder (byteString, Builder)+import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Builder.Extra (flush)+import Data.ByteString.Builder.HTTP.Chunked (+ chunkedTransferEncoding,+ chunkedTransferTerminator,+ ) import qualified Data.ByteString.Char8 as C8 import qualified Data.CaseInsensitive as CI import Data.Function (on)-import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)-import Data.Version (showVersion)-import Data.Word8 (_cr, _lf)+import Data.List (deleteBy)+import Data.Streaming.ByteString.Builder (+ newByteStringBuilderRecv,+ reuseBufferStrategy,+ )+import Data.Word8 (_cr, _lf, _space, _tab) import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H import Network.Wai import Network.Wai.Internal-import qualified Paths_warp import qualified System.TimeManager as T import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)@@ -93,68 +100,84 @@ -- -- Simple applications should specify 'Nothing' to -- 'Maybe' 'FilePart'. The size of the specified file is obtained--- by disk access or from the file infor cache.+-- by disk access or from the file info cache. -- If-Modified-Since, If-Unmodified-Since, If-Range and Range -- are processed. Since a proper status is chosen, 'Status' is -- ignored. Last-Modified is inserted.--sendResponse :: Settings- -> Connection- -> InternalInfo- -> 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+ -> 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 <- addServerAndDate hs0- if hasBody s then do- -- The response to HEAD does not have body.- -- But to handle the conditional requests defined RFC 7232 and- -- to generate appropriate content-length, content-range,- -- and status, the response to HEAD is processed here.- --- -- See definition of rsp below for proper body stripping.- (ms, mlen) <- sendRsp conn ii ver s hs rsp- case ms of- Nothing -> return ()- Just realStatus -> logger req realStatus mlen- T.tickle th- return ret- else do- _ <- sendRsp conn ii ver s hs RspNoBody- logger req s Nothing- T.tickle th- return isPersist+ isShuttingDown <-+ case settingsServerState settings of+ Just serverState -> currentShuttingDownState serverState+ -- Should never be reached!+ -- (cf. 'makeServerState' in 'runSettingsConnectionMakerSecure')+ Nothing -> pure False+ let shouldPersist =+ not isShuttingDown && if hasBody s then ret else isPersist+ addConnection hs =+ if shouldPersist then hs else (H.hConnection, "close") : hs+ hs <- addConnection . addAltSvc settings <$> addServerAndDate hs0+ if hasBody s+ then do+ -- The response to HEAD does not have body.+ -- But to handle the conditional requests defined RFC 7232 and+ -- to generate appropriate content-length, content-range,+ -- and status, the response to HEAD is processed here.+ --+ -- See definition of rsp below for proper body stripping.+ (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method rsp+ case ms of+ Nothing -> return ()+ Just realStatus -> logger req realStatus mlen+ else do+ _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody+ logger req s Nothing+ T.tickle th+ return shouldPersist where defServer = settingsServerName settings logger = settingsLogger settings+ maxRspBufSize = settingsMaxBuilderResponseBufferSize settings ver = httpVersion req s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0 getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr- (isPersist,isChunked0) = infoFromRequest req reqidxhdr+ (isPersist, isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0- (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)- isHead = requestMethod req == H.methodHead+ (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist, isChunked)+ method = requestMethod req+ isHead = method == H.methodHead rsp = case response of- ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)+ ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr (T.tickle th) ResponseBuilder _ _ b- | isHead -> RspNoBody- | otherwise -> RspBuilder b needsChunked+ | isHead -> RspNoBody+ | otherwise -> RspBuilder b needsChunked ResponseStream _ _ fb- | isHead -> RspNoBody- | otherwise -> RspStream fb needsChunked th- ResponseRaw raw _ -> RspRaw raw src (T.tickle th)+ | 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+ ResponseFile{} -> isPersist+ ResponseBuilder{} -> isKeepAlive+ ResponseStream{} -> isKeepAlive+ ResponseRaw{} -> False ---------------------------------------------------------------- @@ -162,8 +185,8 @@ sanitizeHeaders = map (sanitize <$>) where sanitize v- | containsNewlines v = sanitizeHeaderValue v -- slow path- | otherwise = v -- fast path+ | containsNewlines v = sanitizeHeaderValue v -- slow path+ | otherwise = v -- fast path {-# INLINE containsNewlines #-} containsNewlines :: ByteString -> Bool@@ -172,36 +195,41 @@ {-# 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+ addSpaceIfMissing line = case S.uncons line of+ Nothing -> Nothing Just (first, _)- | first == ' ' || first == '\t' -> Just line- | otherwise -> Just $ " " <> line+ | first == _space || first == _tab -> Just line+ | otherwise -> Just $ _space `S.cons` line ---------------------------------------------------------------- -data Rsp = RspNoBody- | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ())- | RspBuilder Builder Bool- | RspStream StreamingBody Bool T.Handle- | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())+data Rsp+ = RspNoBody+ | RspFile FilePath (Maybe FilePart) IndexedHeader (IO ())+ | RspBuilder Builder Bool+ | RspStream StreamingBody Bool+ | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) ---------------------------------------------------------------- -sendRsp :: Connection- -> InternalInfo- -> H.HttpVersion- -> H.Status- -> H.ResponseHeaders- -> Rsp- -> IO (Maybe H.Status, Maybe Integer)-+sendRsp+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> IndexedHeader -- Response+ -> Int -- maxBuilderResponseBufferSize+ -> H.Method+ -> Rsp+ -> IO (Maybe H.Status, Maybe Integer) ---------------------------------------------------------------- -sendRsp conn _ ver s hs RspNoBody = do+sendRsp conn _ _ ver s hs _ _ _ RspNoBody = do -- Not adding Content-Length. -- User agents treats it as Content-Length: 0. composeHeader ver s hs >>= connSendAll conn@@ -209,23 +237,32 @@ ---------------------------------------------------------------- -sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do+sendRsp conn _ th ver s hs _ maxRspBufSize _ (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy- | needsChunked = header <> chunkedTransferEncoding body- <> chunkedTransferTerminator- | otherwise = header <> body- buffer = connWriteBuffer conn- size = connBufferSize conn- toBufIOWith buffer size (connSendAll conn) hdrBdy- return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?+ | needsChunked =+ header+ <> chunkedTransferEncoding body+ <> chunkedTransferTerminator+ | otherwise = header <> body+ writeBufferRef = connWriteBuffer conn+ len <-+ toBufIOWith+ maxRspBufSize+ writeBufferRef+ (\bs -> connSendAll conn bs >> T.tickle th)+ hdrBdy+ return (Just s, Just len) ---------------------------------------------------------------- -sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do+sendRsp conn _ th ver s hs _ _ _ (RspStream streamingBody needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked- (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy- $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)+ (recv, finish) <-+ newByteStringBuilderRecv $+ reuseBufferStrategy $+ toBuilderBuffer $+ connWriteBuffer conn let send builder = do popper <- recv builder let loop = do@@ -246,22 +283,35 @@ ---------------------------------------------------------------- -sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do+sendRsp conn _ th _ _ _ _ _ _ (RspRaw withApp src) = do withApp recv send return (Nothing, Nothing) where recv = do bs <- src- unless (S.null bs) tickle+ unless (S.null bs) $ T.tickle th return bs- send bs = connSendAll conn bs >> tickle+ send bs = connSendAll conn bs >> T.tickle th ---------------------------------------------------------------- -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value.-sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =- sendRspFile2XX conn ii ver s0 hs path beg len isHead hook+sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just part) _ hook) =+ sendRspFile2XX+ conn+ ii+ th+ ver+ s0+ hs+ rspidxhdr+ maxRspBufSize+ method+ path+ beg+ len+ hook where beg = filePartOffset part len = filePartByteCount part@@ -271,50 +321,86 @@ -- Simple WAI applications. -- Status is ignored-sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do+sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize method (RspFile path Nothing reqidxhdr hook) = do efinfo <- E.try $ getFileInfo ii path case efinfo of Left (_ex :: E.IOException) -> #ifdef WARP_DEBUG- print _ex >>+ print _ex >> #endif- sendRspFile404 conn ii ver hs0- Right finfo -> case conditionalRequest finfo hs0 idxhdr of- WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody- WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook+ sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method+ Right finfo -> case conditionalRequest finfo hs0 method rspidxhdr reqidxhdr of+ WithoutBody s ->+ sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize method RspNoBody+ WithBody s hs beg len ->+ sendRspFile2XX+ conn+ ii+ th+ ver+ s+ hs+ rspidxhdr+ maxRspBufSize+ method+ path+ beg+ len+ hook ---------------------------------------------------------------- -sendRspFile2XX :: Connection- -> InternalInfo- -> H.HttpVersion- -> H.Status- -> H.ResponseHeaders- -> FilePath- -> Integer- -> Integer- -> Bool- -> IO ()- -> IO (Maybe H.Status, Maybe Integer)-sendRspFile2XX conn ii ver s hs path beg len isHead hook- | isHead = sendRsp conn ii ver s hs RspNoBody- | otherwise = do- lheader <- composeHeader ver s hs- (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)+sendRspFile2XX+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> IndexedHeader+ -> Int+ -> H.Method+ -> FilePath+ -> Integer+ -> Integer+ -> IO ()+ -> IO (Maybe H.Status, Maybe Integer)+sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len hook+ | method == H.methodHead =+ sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody+ | otherwise = do+ lheader <- composeHeader ver s hs+ (mfd, fresher) <- getFd ii path+ let fid = FileId path mfd+ hook' = hook >> fresher+ connSendFile conn fid beg len hook' [lheader]+ return (Just s, Just len) -sendRspFile404 :: Connection- -> InternalInfo- -> H.HttpVersion- -> H.ResponseHeaders- -> IO (Maybe H.Status, Maybe Integer)-sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)+sendRspFile404+ :: Connection+ -> InternalInfo+ -> T.Handle+ -> H.HttpVersion+ -> H.ResponseHeaders+ -> IndexedHeader+ -> Int+ -> H.Method+ -> IO (Maybe H.Status, Maybe Integer)+sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method =+ sendRsp+ conn+ ii+ th+ ver+ s+ hs+ rspidxhdr+ maxRspBufSize+ method+ (RspBuilder body True) where s = H.notFound404- hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0+ hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" ----------------------------------------------------------------@@ -322,34 +408,39 @@ -- | Use 'connSendAll' to send this data while respecting timeout rules. sendFragment :: Connection -> T.Handle -> ByteString -> IO ()-sendFragment Connection { connSendAll = send } th bs = do+sendFragment Connection{connSendAll = send} th bs = do T.resume th send bs T.pause th- -- We pause timeouts before passing control back to user code. This ensures- -- that a timeout will only ever be executed when Warp is in control. We- -- also make sure to resume the timeout after the completion of user code- -- so that we can kill idle connections. +-- We pause timeouts before passing control back to user code. This ensures+-- that a timeout will only ever be executed when Warp is in control. We+-- also make sure to resume the timeout after the completion of user code+-- so that we can kill idle connections.+ ---------------------------------------------------------------- -infoFromRequest :: Request -> IndexedHeader -> (Bool -- isPersist- ,Bool) -- isChunked+infoFromRequest+ :: Request+ -> IndexedHeader+ -> ( Bool -- isPersist+ , Bool -- isChunked+ ) infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req) checkPersist :: Request -> IndexedHeader -> Bool checkPersist req reqidxhdr | ver == H.http11 = checkPersist11 conn- | otherwise = checkPersist10 conn+ | otherwise = checkPersist10 conn where ver = httpVersion req conn = reqidxhdr ! fromEnum ReqConnection checkPersist11 (Just x)- | CI.foldCase x == "close" = False- checkPersist11 _ = True+ | CI.foldCase x == "close" = False+ checkPersist11 _ = True checkPersist10 (Just x) | CI.foldCase x == "keep-alive" = True- checkPersist10 _ = False+ checkPersist10 _ = False checkChunk :: Request -> Bool checkChunk req = httpVersion req == H.http11@@ -363,8 +454,8 @@ -- -- Content-Length is specified by a reverse proxy. -- Note that CGI does not specify Content-Length.-infoFromResponse :: IndexedHeader -> (Bool,Bool) -> (Bool,Bool)-infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked)+infoFromResponse :: IndexedHeader -> (Bool, Bool) -> (Bool, Bool)+infoFromResponse rspidxhdr (isPersist, isChunked) = (isKeepAlive, needsChunked) where needsChunked = isChunked && not hasLength isKeepAlive = isPersist && (isChunked || hasLength)@@ -373,9 +464,10 @@ ---------------------------------------------------------------- hasBody :: H.Status -> Bool-hasBody s = sc /= 204- && sc /= 304- && sc >= 200+hasBody s =+ sc /= 204+ && sc /= 304+ && sc >= 200 where sc = H.statusCode s @@ -384,7 +476,8 @@ addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs -addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate+ :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of Nothing -> do gmtdate <- getdate@@ -393,31 +486,35 @@ ---------------------------------------------------------------- --- | The version of Warp.-warpVersion :: String-warpVersion = showVersion Paths_warp.version- {-# INLINE addServer #-}-addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders+addServer+ :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders addServer "" rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of Nothing -> hdrs- _ -> filter ((/= H.hServer) . fst) hdrs+ _ -> filter ((/= H.hServer) . fst) hdrs addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of Nothing -> (H.hServer, serverName) : hdrs- _ -> hdrs+ _ -> hdrs +addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders+addAltSvc settings hs = case settingsAltSvc settings of+ Nothing -> hs+ Just v -> ("Alt-Svc", v) : hs+ ---------------------------------------------------------------- -- | -- -- >>> replaceHeader "Content-Type" "new" [("content-type","old")] -- [("Content-Type","new")]-replaceHeader :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders-replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs+replaceHeader+ :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders+replaceHeader k v hdrs = (k, v) : deleteBy ((==) `on` fst) (k, v) hdrs ---------------------------------------------------------------- -composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder+composeHeaderBuilder+ :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder composeHeaderBuilder ver s hs True = byteString <$> composeHeader ver s (addTransferEncoding hs) composeHeaderBuilder ver s hs False =
Network/Wai/Handler/Warp/ResponseHeader.hs view
@@ -1,16 +1,18 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where import qualified Data.ByteString as S import Data.ByteString.Internal (create) import qualified Data.CaseInsensitive as CI+import Data.List (foldl')+import Data.Word8 import Foreign.Ptr import GHC.Storable import qualified Network.HTTP.Types as H+import Network.Socket.BufferPool (copy) -import Network.Wai.Handler.Warp.Buffer (copy) import Network.Wai.Handler.Warp.Imports ----------------------------------------------------------------@@ -22,7 +24,7 @@ void $ copyCRLF ptr2 where !len = 17 + slen + foldl' fieldLength 0 responseHeaders- fieldLength !l (!k,!v) = l + S.length (CI.original k) + S.length v + 4+ fieldLength !l (!k, !v) = l + S.length (CI.original k) + S.length v + 4 !slen = S.length $ H.statusMessage status httpVer11 :: ByteString@@ -35,50 +37,39 @@ copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) copyStatus !ptr !httpversion !status = do ptr1 <- copy ptr httpVer- writeWord8OffPtr ptr1 0 (zero + fromIntegral r2)- writeWord8OffPtr ptr1 1 (zero + fromIntegral r1)- writeWord8OffPtr ptr1 2 (zero + fromIntegral r0)- writeWord8OffPtr ptr1 3 spc+ writeWord8OffPtr ptr1 0 (_0 + fromIntegral r2)+ writeWord8OffPtr ptr1 1 (_0 + fromIntegral r1)+ writeWord8OffPtr ptr1 2 (_0 + fromIntegral r0)+ writeWord8OffPtr ptr1 3 _space ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status) copyCRLF ptr2 where httpVer- | httpversion == H.HttpVersion 1 1 = httpVer11- | otherwise = httpVer10- (q0,r0) = H.statusCode status `divMod` 10- (q1,r1) = q0 `divMod` 10+ | httpversion == H.HttpVersion 1 1 = httpVer11+ | otherwise = httpVer10+ (q0, r0) = H.statusCode status `divMod` 10+ (q1, r1) = q0 `divMod` 10 r2 = q1 `mod` 10 {-# INLINE copyHeaders #-} copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8) copyHeaders !ptr [] = return ptr-copyHeaders !ptr (h:hs) = do+copyHeaders !ptr (h : hs) = do ptr1 <- copyHeader ptr h copyHeaders ptr1 hs {-# INLINE copyHeader #-} copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8)-copyHeader !ptr (k,v) = do+copyHeader !ptr (k, v) = do ptr1 <- copy ptr (CI.original k)- writeWord8OffPtr ptr1 0 colon- writeWord8OffPtr ptr1 1 spc+ writeWord8OffPtr ptr1 0 _colon+ writeWord8OffPtr ptr1 1 _space ptr2 <- copy (ptr1 `plusPtr` 2) v copyCRLF ptr2 {-# INLINE copyCRLF #-} copyCRLF :: Ptr Word8 -> IO (Ptr Word8) copyCRLF !ptr = do- writeWord8OffPtr ptr 0 cr- writeWord8OffPtr ptr 1 lf+ writeWord8OffPtr ptr 0 _cr+ writeWord8OffPtr ptr 1 _lf return $! ptr `plusPtr` 2--zero :: Word8-zero = 48-spc :: Word8-spc = 32-colon :: Word8-colon = 58-cr :: Word8-cr = 13-lf :: Word8-lf = 10
Network/Wai/Handler/Warp/Run.hs view
@@ -1,77 +1,174 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where -import "iproute" Data.IP (toHostAddress, toHostAddress6) import Control.Arrow (first)-import qualified Control.Concurrent as Conc (yield)-import Control.Exception as E+import Control.Concurrent.STM (+ TVar,+ atomically,+ check,+ modifyTVar',+ newTVarIO,+ readTVar,+ )+import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.Char (chr)-import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')+import Data.Functor (($>))+import Data.IORef (newIORef, readIORef, IORef, writeIORef) import Data.Streaming.Network (bindPortTCP)-import Foreign.C.Error (Errno(..), eCONNABORTED)-import GHC.IO.Exception (IOException(..))-import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))+import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE)+import GHC.Conc.Sync (labelThread, myThreadId)+import GHC.IO.Exception (IOErrorType (..), IOException (..))+import Network.Socket (+ SockAddr,+ Socket,+ SocketOption (..),+ close,+#if !WINDOWS+ fdSocket,+#if MIN_VERSION_network(3,2,2)+ waitReadSocketSTM,+#endif+#endif+ getSocketName,+ setSocketOption,+ withSocketsDo,+ )+#if MIN_VERSION_network(3,1,1)+import Network.Socket (gracefulClose)+#endif+import Network.Socket.BufferPool import qualified Network.Socket.ByteString as Sock import Network.Wai-import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import System.Environment (lookupEnv)-import System.Timeout (timeout)+import System.IO.Error (ioeGetErrorType) import qualified System.TimeManager as T+import System.Timeout (timeout) -import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Buffer (createWriteBuffer) import Network.Wai.Handler.Warp.Counter import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I-import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)-import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.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.ReadInt-import Network.Wai.Handler.Warp.Recv-import Network.Wai.Handler.Warp.Request-import Network.Wai.Handler.Warp.Response-import Network.Wai.Handler.Warp.SendFile+import Network.Wai.Handler.Warp.SendFile (sendFile) import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown) import Network.Wai.Handler.Warp.Types --#if WINDOWS-import Network.Wai.Handler.Warp.Windows+-- | Creating 'Connection' for plain HTTP based on a given socket.+--+-- (N.B. make sure the 'Settings' have an initialized 'ServerState' to guarantee+-- a graceful shutdown)+socketConnection :: Settings -> Socket -> IO Connection+socketConnection set s = do+ (ss, _) <- makeServerState set+ bufferPool <- newBufferPool 2048 16384+ writeBuffer <- createWriteBuffer 16384+ writeBufferRef <- newIORef writeBuffer+ isH2 <- newIORef False -- HTTP/1.x+ mysa <- getSocketName s+ appsInProgress <- newTVarIO 0+ return+ Connection+ { connSendMany = Sock.sendMany s+ , connSendAll = sendall+ , connSendFile = sendfile writeBufferRef+#if MIN_VERSION_network(3,1,1)+ , connClose = do+ h2 <- readIORef isH2+ let tm =+ if h2+ then settingsGracefulCloseTimeout2 set+ else settingsGracefulCloseTimeout1 set+ if tm == 0+ then close s+ else gracefulClose s tm `E.catch` throughAsync (return ()) #else-import Network.Socket (fdSocket)+ , connClose = close s #endif+ , connRecv = receive' bufferPool ss appsInProgress+ , connRecvBuf = \_ _ -> return True -- obsoleted+ , connWriteBuffer = writeBufferRef+ , connHTTP2 = isH2+ , connMySockAddr = mysa+ , connAppsInProgress = appsInProgress+ }+ where+ receive' bufferPool ss appsInProgress =+ E.handle handler $ makeGracefulRecv s bufferPool ss appsInProgress+ where+ handler :: E.IOException -> IO ByteString+ handler e+ | ioeGetErrorType e == InvalidArgument = return ""+ | otherwise = E.throwIO e --- | Creating 'Connection' for plain HTTP based on a given socket.-socketConnection :: Socket -> IO Connection-socketConnection s = do- bufferPool <- newBufferPool- writeBuf <- allocateBuffer bufferSize- let sendall = Sock.sendAll s- return Connection {- connSendMany = Sock.sendMany s- , connSendAll = sendall- , connSendFile = sendFile s writeBuf bufferSize sendall- , connClose = close s- , connFree = freeBuffer writeBuf- , connRecv = receive s bufferPool- , connRecvBuf = receiveBuf s- , connWriteBuffer = writeBuf- , connBufferSize = bufferSize- }+ sendfile writeBufferRef fid offset len hook headers = do+ writeBuffer <- readIORef writeBufferRef+ sendFile+ s+ (bufBuffer writeBuffer)+ (bufSize writeBuffer)+ sendall+ fid+ offset+ len+ hook+ headers + sendall = sendAll' s++ sendAll' sock bs =+ E.handleJust+ ( \e ->+ if ioeGetErrorType e == ResourceVanished+ then Just ConnectionClosedByPeer+ else Nothing+ )+ E.throwIO+ $ Sock.sendAll sock bs++-- | Create a 'Recv' using 'Network.Socket.BufferPool.Recv.receive', but make+-- it non-blocking with 'waitReadSocketSTM' /AND/ cut off receiving any bytes+-- when the server is shutting down and there are no more 'Application's+-- actively using this 'Socket'.+makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv+makeGracefulRecv sock pool ss appsInProgress = do+ sockWait <-+#if !WINDOWS && MIN_VERSION_network(3,2,2)+ waitReadSocketSTM sock+#else+ -- FIXME: 'waitReadSocketSTM' doesn't work on WINDOWS, and actually+ -- blocks indefinitely, so we fall back to going straight to 'recv'.+ pure (pure ())+#endif+ isShuttingDown <- atomically $+ -- when shutting down+ (checkShutdown $> True)+ <|>+ -- else wait for socket readiness and do non-blocking read+ (sockWait $> False)+ if isShuttingDown then pure "" else recv+ where+ recv = receive sock pool+ checkShutdown = do+ check =<< currentShuttingDownStateSTM ss+ check . (<= 0) =<< readTVar appsInProgress+ -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO ()-run p = runSettings defaultSettings { settingsPort = p }+run 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.@@ -83,24 +180,25 @@ mp <- lookupEnv "PORT" maybe (run p app) runReadPort mp- where runReadPort :: String -> IO () runReadPort sp = case reads sp of- ((p', _):_) -> run p' app+ ((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 $- bracket- (bindPortTCP (settingsPort set) (settingsHost set))- close- (\socket -> do- setSocketCloseOnExec socket- runSettingsSocket set socket app)+runSettings set app =+ withSocketsDo $+ E.bracket+ (bindPortTCP (settingsPort set) (settingsHost set))+ close+ ( \socket -> do+ setSocketCloseOnExec socket+ runSettingsSocket set socket app+ ) -- | This installs a shutdown handler for the given socket and -- calls 'runSettingsConnection' with the default connection setup action@@ -114,20 +212,17 @@ -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO ()-runSettingsSocket set socket app = do- settingsInstallShutdownHandler set closeListenSocket- runSettingsConnection set getConn app+runSettingsSocket oldSettings@Settings{settingsAccept = accept'} socket app = do+ settingsInstallShutdownHandler oldSettings closeListenSocket+ (_, newSettings) <- makeServerState oldSettings+ runSettingsConnection newSettings (getConn newSettings) app where- getConn = do-#if WINDOWS- (s, sa) <- windowsThreadBlockHack $ accept socket-#else- (s, sa) <- accept socket-#endif+ getConn set = do+ (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX.- setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()- conn <- socketConnection s+ setSocketOption s NoDelay 1 `E.catch` throughAsync (return ())+ conn <- socketConnection set s return (conn, sa) closeListenSocket = close socket@@ -141,20 +236,22 @@ -- in a separate worker thread instead of the main server loop. -- -- Since 1.3.5-runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()+runSettingsConnection+ :: Settings -> IO (Connection, SockAddr) -> Application -> IO () runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app where getConnMaker = do- (conn, sa) <- getConn- return (return conn, sa)+ (conn, sa) <- getConn+ return (return conn, sa) -- | This modifies the connection maker so that it returns 'TCP' for 'Transport' -- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.-runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()+runSettingsConnectionMaker+ :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () runSettingsConnectionMaker x y = runSettingsConnectionMakerSecure x (toTCP <$> y) where- toTCP = first ((, TCP) <$>)+ toTCP = first ((,TCP) <$>) ---------------------------------------------------------------- @@ -164,29 +261,37 @@ -- 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 $ acceptConnection set getConnMaker app counter- where- withII action =- withTimeoutManager $ \tm ->- D.withDateCache $ \dc ->- F.withFdCache fdCacheDurationInSeconds $ \fdc ->- I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do- let ii = InternalInfo tm dc fdc fic- action ii+runSettingsConnectionMakerSecure+ :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()+runSettingsConnectionMakerSecure oldSettings getConnMaker app = do+ settingsBeforeMainLoop oldSettings+ (ServerState{serverConnectionCounter}, newSettings) <- makeServerState oldSettings+ withII newSettings $ \ii ->+ initFdExhaustionRef >>=+ acceptConnection newSettings getConnMaker app serverConnectionCounter ii - !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000- !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000- !timeoutInSeconds = settingsTimeout set * 1000000+-- | Running an action with internal info.+--+-- Since 3.3.11+withII :: Settings -> (InternalInfo -> IO a) -> IO a+withII set action =+ withTimeoutManager $ \tm ->+ D.withDateCache $ \dc ->+ F.withFdCache fdCacheDurationInMicroseconds $ \fdc ->+ I.withFileInfoCache fdFileInfoDurationInMicroseconds $ \fic -> do+ let ii = InternalInfo tm dc fdc fic+ action ii+ where+ !fdCacheDurationInMicroseconds = settingsFdCacheDuration set * 1000000+ !fdFileInfoDurationInMicroseconds = settingsFileInfoCacheDuration set * 1000000+ !timeoutInMicroseconds = settingsTimeout set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm- Nothing -> bracket- (T.initialize timeoutInSeconds)- T.stopManager- f+ Nothing ->+ E.bracket+ (T.initialize timeoutInMicroseconds)+ T.stopManager+ f -- Note that there is a thorough discussion of the exception safety of the -- following code at: https://github.com/yesodweb/wai/issues/146@@ -201,19 +306,24 @@ -- 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+acceptConnection+ :: Settings+ -> IO (IO (Connection, Transport), SockAddr)+ -> Application+ -> Counter+ -> InternalInfo+ -> IORef FdExhaustion+ -- ^ This ref will be used to "debounce" the call to 'settingsOnException'+ -- when we hit an 'IOError' with 'eMFILE' in the case that Warp is not+ -- the reason the file descriptors are exhausted.+ -> IO ()+acceptConnection set getConnMaker app counter ii fdRef = do -- First mask all exceptions in acceptLoop. This is necessary to -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose. --- -- acceptLoop can be broken by closing the listing socket.- void $ mask_ acceptLoop+ -- acceptLoop can be broken by closing the listening socket.+ void $ E.mask_ acceptLoop -- In some cases, we want to stop Warp here without graceful shutdown. -- So, async exceptions are allowed here. -- That's why `finally` is not used.@@ -221,7 +331,7 @@ where acceptLoop = do -- Allow async exceptions before receiving the next connection maker.- allowInterrupt+ E.allowInterrupt -- acceptNewConnection will try to receive the next incoming -- request. It returns a /connection maker/, not a connection,@@ -232,40 +342,73 @@ -- negotiation. mx <- acceptNewConnection case mx of- Nothing -> return ()+ Nothing -> return () Just (mkConn, addr) -> do fork set mkConn addr app counter ii acceptLoop acceptNewConnection = do- ex <- try getConnMaker+ ex <- E.try getConnMaker case ex of- Right x -> return $ Just x+ Right x -> do+ -- Important to mark the exhaustion issue to be resolved+ -- when we get connections again.+ resetFdExhaustion fdRef+ return $ Just x Left e -> do- let eConnAborted = getErrno eCONNABORTED- getErrno (Errno cInt) = cInt- if ioe_errno e == Just eConnAborted- then acceptNewConnection- else do- settingsOnException set Nothing $ toException e+ let getErrno (Errno cInt) = cInt+ isErrno err = ioe_errno e == Just (getErrno err)+ if | isErrno eCONNABORTED -> do+ -- Important to mark the exhaustion issue to be resolved+ resetFdExhaustion fdRef+ acceptNewConnection+ -- Keep in mind to reset the ref when anything other+ -- than this branch runs+ | isErrno eMFILE -> do+ handleFdExhaustion e+ acceptNewConnection+ | otherwise -> do+ -- Maybe not important to mark the exhaustion issue+ -- as resolved here, but just for completeness' sake.+ resetFdExhaustion fdRef+ settingsOnException set Nothing $ E.toException e return Nothing + handleFdExhaustion e = do+ fdExhaustion <- readIORef fdRef+ -- If file descriptors are exhausted while Warp has+ -- no current connections, 'settingsOnException' would+ -- get called an enormous amount of times per second.+ when (fdExhaustion /= FdExhausted) $+ settingsOnException set Nothing $ E.toException e+ hasDecreased <- waitForDecreased counter+ -- If we get 'NoConnections', that means the file+ -- descriptor exhaustion is outside of our control.+ -- We flag it so that 'settingsOnException' doesn't get+ -- called until the exhaustion issue is resolved.+ when (hasDecreased == NoConnections) $ setFdExhaustion fdRef+ -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown).-fork :: Settings- -> IO (Connection, Transport)- -> SockAddr- -> Application- -> Counter- -> InternalInfo- -> IO ()-fork set mkConn addr app counter ii = settingsFork set $ \unmask ->+fork+ :: Settings+ -> IO (Connection, Transport)+ -> SockAddr+ -> Application+ -> Counter+ -> InternalInfo+ -> IO ()+fork set mkConn addr app counter ii = settingsFork set $ \unmask -> do+ tid <- myThreadId+ labelThread tid "Warp just forked" -- Call the user-supplied on exception code if any -- exceptions are thrown.- handle (settingsOnException set Nothing) .- -- Allocate a new IORef indicating whether the connection has been- -- closed, to avoid double-freeing a connection- withClosedRef $ \ref ->+ --+ -- Intentionally using Control.Exception.handle, since we want to+ -- catch all exceptions and avoid them from propagating, even+ -- async exceptions. See:+ -- https://github.com/yesodweb/wai/issues/850+ E.handle (settingsOnException set Nothing) $ -- Run the connection maker to get a new connection, and ensure -- that the connection is closed. If the mkConn call throws an -- exception, we will leak the connection. If the mkConn call is@@ -276,263 +419,77 @@ -- We grab the connection before registering timeouts since the -- timeouts will be useless during connection creation, due to the -- fact that async exceptions are still masked.- bracket mkConn (cleanUp ref) (serve unmask ref)+ E.bracket mkConn cleanUp (serve unmask) where- withClosedRef inner = newIORef False >>= inner-- closeConn ref conn = do- isClosed <- atomicModifyIORef' ref $ \x -> (True, x)- unless isClosed $ connClose conn-- cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn+ cleanUp (conn, _) =+ connClose conn `E.finally` do+ writeBuffer <- readIORef $ connWriteBuffer conn+ bufFree writeBuffer -- We need to register a timeout handler for this thread, and- -- cancel that handler as soon as we exit. We additionally close- -- the connection immediately in case the child thread catches the- -- async exception or performs some long-running cleanup action.- serve unmask ref (conn, transport) = bracket register cancel $ \th -> do+ -- cancel that handler as soon as we exit.+ serve unmask (conn, transport) = T.withHandleKillThread (timeoutManager ii) (return ()) $ \th -> do -- We now have fully registered a connection close handler in -- the case of all exceptions, so it is safe to once again -- allow async exceptions.- unmask .+ unmask+ . -- Call the user-supplied code for connection open and -- close events- bracket (onOpen addr) (onClose addr) $ \goingon ->- -- Actually serve this connection. bracket with closeConn- -- above ensures the connection is closed.- when goingon $ serveConnection conn ii th addr transport set app- where- register = T.registerKillThread (timeoutManager ii)- (closeConn ref conn)- cancel = T.cancel+ E.bracket (onOpen addr) (onClose addr)+ $ \goingon ->+ -- Actually serve this connection. bracket with closeConn+ -- above ensures the connection is closed.+ when goingon $ serveConnection conn ii th addr transport set app - onOpen adr = increase counter >> settingsOnOpen set adr+ onOpen adr = increase counter >> settingsOnOpen set adr onClose adr _ = decrease counter >> settingsOnClose set adr -serveConnection :: Connection- -> InternalInfo- -> T.Handle- -> SockAddr- -> Transport- -> Settings- -> Application- -> IO ()+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)- istatus <- newIORef False- if settingsHTTP2Enabled settings && h2 then do- rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)- let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN- -- fixme: origAddr- http2 conn ii origAddr transport settings recvN app- else do- src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))- writeIORef istatus True- leftoverSource src bs- addr <- getProxyProtocolAddr src- http1 True addr istatus src `E.catch` \e ->- case fromException e of- -- See comment below referencing- -- https://github.com/yesodweb/wai/issues/618- Just NoKeepAliveRequest -> return ()- Nothing -> do- _ <- sendErrorResponse (dummyreq addr) istatus e- throwIO e-- where- getProxyProtocolAddr src =- case settingsProxyProtocol settings of- ProxyProtocolNone ->- return origAddr- ProxyProtocolRequired -> do- seg <- readSource src- parseProxyProtocolHeader src seg- ProxyProtocolOptional -> do- seg <- readSource src- if S.isPrefixOf "PROXY " seg- then parseProxyProtocolHeader src seg- else do leftoverSource src seg- return origAddr-- parseProxyProtocolHeader src seg = do- let (header,seg') = S.break (== 0x0d) seg -- 0x0d == CR- maybeAddr = case S.split 0x20 header of -- 0x20 == space- ["PROXY","TCP4",clientAddr,_,clientPort,_] ->- case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of- [a] -> Just (SockAddrInet (readInt clientPort)- (toHostAddress a))- _ -> Nothing- ["PROXY","TCP6",clientAddr,_,clientPort,_] ->- case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of- [a] -> Just (SockAddrInet6 (readInt clientPort)- 0- (toHostAddress6 a)- 0)- _ -> Nothing- ("PROXY":"UNKNOWN":_) ->- Just origAddr- _ ->- Nothing- case maybeAddr of- Nothing -> throwIO (BadProxyHeader (decodeAscii header))- Just a -> do leftoverSource src (S.drop 2 seg') -- drop CRLF- return a-- decodeAscii = map (chr . fromEnum) . S.unpack-- shouldSendErrorResponse se- | Just ConnectionClosedByPeer <- fromException se = False- | otherwise = True-- sendErrorResponse req istatus e = do- status <- readIORef istatus- if shouldSendErrorResponse e && status- then do- sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)- else return False-- dummyreq addr = defaultRequest { remoteHost = addr }-- errorResponse e = settingsOnExceptionResponse settings e-- http1 firstRequest addr istatus src = do- (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src- let req = req' { isSecure = isTransportSecure transport }- keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush- `E.catch` \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 $ http1 False addr istatus src-- processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do- -- Let the application run for as long as it wants- T.pause th-- -- In the event that some scarce resource was acquired during- -- creating the request, we need to make sure that we don't get- -- an async exception before calling the ResponseSource.- keepAliveRef <- newIORef $ error "keepAliveRef not filled"- r <- E.try $ app req $ \res -> do- T.resume th- -- FIXME consider forcing evaluation of the res here to- -- send more meaningful error messages to the user.- -- However, it may affect performance.- writeIORef istatus False- keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res- writeIORef keepAliveRef keepAlive- return ResponseReceived- case r of- Right ResponseReceived -> return ()- Left e@(SomeException _)- | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'- | otherwise -> do- keepAlive <- sendErrorResponse req istatus 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--flushEntireBody :: IO ByteString -> IO ()-flushEntireBody src =- loop- where- loop = do- bs <- src- unless (S.null bs) loop--flushBody :: IO ByteString -- ^ get next chunk- -> Int -- ^ maximum to flush- -> IO Bool -- ^ True == flushed the entire body, False == we didn't-flushBody src =- loop+ tid <- myThreadId+ (h2, bs) <-+ if isHTTP2 transport+ then return (True, "")+ else do+ bs0 <- recv4 ""+ if "PRI " `S.isPrefixOf` bs0+ then return (True, bs0)+ else return (False, bs0)+ let appsInProgress = connAppsInProgress conn+ app' req rsp =+ E.bracket_+ (atomically $ modifyTVar' appsInProgress $ (+ 1))+ (atomically $ modifyTVar' appsInProgress $ \i -> (i - 1))+ $ app req rsp+ if settingsHTTP2Enabled settings && h2+ then do+ labelThread tid ("Warp HTTP/2 " ++ show origAddr)+ http2 settings ii conn transport app' origAddr th bs+ else do+ labelThread tid ("Warp HTTP/1.1 " ++ show origAddr)+ http1 settings ii conn transport app' origAddr th bs where- loop toRead = do- bs <- src- let toRead' = toRead - S.length bs- case () of- ()- | S.null bs -> return True- | toRead' >= 0 -> loop toRead'- | otherwise -> return False--wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString-wrappedRecv Connection { connRecv = recv } th istatus slowlorisSize = do- bs <- recv- unless (S.null bs) $ do- writeIORef istatus True- when (S.length bs >= slowlorisSize) $ T.tickle th- return bs--wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)-wrappedRecvN th istatus slowlorisSize readN bufsize = do- bs <- readN bufsize- unless (S.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 (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th- return bs+ recv4 bs0 = do+ bs1 <- connRecv conn+ if S.null bs1 then+ return bs0+ else do+ -- In the case where bs0 is "", (<>) is called unnecessarily.+ -- But we adopt this logic for simplicity.+ let bs2 = bs0 <> bs1+ if S.length bs2 >= 4+ then return bs2+ else recv4 bs2 -- | Set flag FileCloseOnExec flag on a socket (on Unix) --@@ -553,10 +510,29 @@ #endif gracefulShutdown :: Settings -> Counter -> IO ()-gracefulShutdown set counter =+gracefulShutdown set counter = do+ setShuttingDown case settingsGracefulShutdownTimeout set of Nothing -> waitForZero counter (Just seconds) -> void (timeout (seconds * microsPerSecond) (waitForZero counter))- where microsPerSecond = 1000000+ where+ microsPerSecond = 1000000+ setShuttingDown =+ case settingsServerState set of+ Nothing -> pure ()+ Just ServerState{serverShuttingDown} ->+ writeShuttingDown serverShuttingDown True++data FdExhaustion = NoFdIssue | FdExhausted+ deriving (Eq, Show)++initFdExhaustionRef :: IO (IORef FdExhaustion)+initFdExhaustionRef = newIORef NoFdIssue++resetFdExhaustion :: IORef FdExhaustion -> IO ()+resetFdExhaustion = flip writeIORef NoFdIssue++setFdExhaustion :: IORef FdExhaustion -> IO ()+setFdExhaustion = flip writeIORef FdExhausted
Network/Wai/Handler/Warp/SendFile.hs view
@@ -1,23 +1,25 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-} module Network.Wai.Handler.Warp.SendFile (- sendFile- , readSendFile- , packHeader -- for testing+ sendFile,+ readSendFile,+ packHeader, -- for testing #ifndef WINDOWS- , positionRead+ positionRead, #endif- ) where+) where import 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 Control.Exception+import qualified Control.Exception as E import Foreign.C.Error (throwErrno) import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr)@@ -41,8 +43,8 @@ #ifdef SENDFILEFD sendFile s _ _ _ fid off len act hdr = case mfid of -- settingsFdCacheDuration is 0- Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr- Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr+ Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr+ Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr where mfid = fileIdFd fid path = fileIdPath fid@@ -52,31 +54,35 @@ ---------------------------------------------------------------- -packHeader :: Buffer -> BufSize -> (ByteString -> IO ())- -> IO () -> [ByteString]- -> Int- -> IO Int-packHeader _ _ _ _ [] n = return n-packHeader buf siz send hook (bs:bss) n- | len < room = do- let dst = buf `plusPtr` n- void $ copy dst bs- packHeader buf siz send hook bss (n + len)- | otherwise = do- let dst = buf `plusPtr` n- (bs1, bs2) = BS.splitAt room bs- void $ copy dst bs1- bufferIO buf siz send- hook- packHeader buf siz send hook (bs2:bss) 0+packHeader+ :: Buffer+ -> BufSize+ -> (ByteString -> IO ())+ -> IO ()+ -> [ByteString]+ -> Int+ -> IO Int+packHeader _ _ _ _ [] n = return n+packHeader buf siz send hook (bs : bss) n+ | len < room = do+ let dst = buf `plusPtr` n+ void $ copy dst bs+ packHeader buf siz send hook bss (n + len)+ | otherwise = do+ let dst = buf `plusPtr` n+ (bs1, bs2) = BS.splitAt room bs+ void $ copy dst bs1+ bufferIO buf siz send+ hook+ packHeader buf siz send hook (bs2 : bss) 0 where len = BS.length bs room = siz - n mini :: Int -> Integer -> Int mini i n- | fromIntegral i < n = i- | otherwise = fromIntegral n+ | fromIntegral i < n = i+ | otherwise = fromIntegral n -- | Function to send a file based on pread()\/send() for Unix. -- This makes use of the file descriptor cache.@@ -100,50 +106,51 @@ where path = fileIdPath fid loop h fptr len- | len <= 0 = return ()- | otherwise = do- n <- IO.hGetBufSome h buf (mini siz len)- when (n /= 0) $ do- let bs = PS fptr 0 n- n' = fromIntegral n- send bs- hook- loop h fptr (len - n')+ | len <= 0 = return ()+ | otherwise = do+ n <- IO.hGetBufSome h buf (mini siz len)+ when (n /= 0) $ do+ let bs = PS fptr 0 n+ n' = fromIntegral n+ send bs+ hook+ loop h fptr (len - n') #else readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers =- bracket setup teardown $ \fd -> do- hn <- packHeader buf siz send hook headers 0- let room = siz - hn- buf' = buf `plusPtr` hn- n <- positionRead fd buf' (mini room len0) off0- bufferIO buf (hn + n) send- hook- let n' = fromIntegral n- loop fd (len0 - n') (off0 + n')+ E.bracket setup teardown $ \fd -> do+ hn <- packHeader buf siz send hook headers 0+ let room = siz - hn+ buf' = buf `plusPtr` hn+ n <- positionRead fd buf' (mini room len0) off0+ bufferIO buf (hn + n) send+ hook+ let n' = fromIntegral n+ loop fd (len0 - n') (off0 + n') where path = fileIdPath fid setup = case fileIdFd fid of- Just fd -> return fd- Nothing -> openFile path+ Just fd -> return fd+ Nothing -> openFile path teardown fd = case fileIdFd fid of- Just _ -> return ()- Nothing -> closeFile fd+ Just _ -> return ()+ Nothing -> closeFile fd loop fd len off- | len <= 0 = return ()- | otherwise = do- n <- positionRead fd buf (mini siz len) off- bufferIO buf n send- let n' = fromIntegral n- hook- loop fd (len - n') (off + n')+ | len <= 0 = return ()+ | otherwise = do+ n <- positionRead fd buf (mini siz len) off+ bufferIO buf n send+ let n' = fromIntegral n+ hook+ loop fd (len - n') (off + n') positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int positionRead fd buf siz off = do- bytes <- fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off)+ bytes <-+ fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off) when (bytes < 0) $ throwErrno "positionRead" return bytes foreign import ccall unsafe "pread"- c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize+ c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize #endif
Network/Wai/Handler/Warp/Settings.hs view
@@ -1,31 +1,49 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}-{-# LANGUAGE PatternGuards, RankNTypes #-}-{-# LANGUAGE ImpredicativeTypes, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ViewPatterns #-} module Network.Wai.Handler.Warp.Settings where -import Control.Concurrent (forkIOWithUnmask)-import Control.Exception-import Data.ByteString.Builder (byteString)+import Control.Concurrent.STM (STM)+import Control.Exception (SomeException (..), fromException, throw)+import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as C8-import Data.ByteString.Lazy (fromStrict) import Data.Streaming.Network (HostPreference) import qualified Data.Text as T import qualified Data.Text.IO as TIO-import Data.Version (showVersion)-import GHC.IO.Exception (IOErrorType(..))+import GHC.Exts (fork#)+import GHC.IO (IO (IO), unsafeUnmask)+import GHC.IO.Exception (IOErrorType (..)) import qualified Network.HTTP.Types as H-import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) )-import Network.Socket (SockAddr)+import Network.Socket (SockAddr, Socket, 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.Counter (Counter, getCount, newCounter, getCountSTM) import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ ) import Network.Wai.Handler.Warp.Types+#if WINDOWS+import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack)+#endif +#ifdef INCLUDE_WARP_VERSION+import Data.Version (showVersion)+import qualified Paths_warp+#endif+ -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create a 'Settings' value, use 'defaultSettings'@@ -33,120 +51,304 @@ -- -- > setTimeout 20 defaultSettings data Settings = Settings- { settingsPort :: Port -- ^ Port to listen on. Default value: 3000- , settingsHost :: HostPreference -- ^ Default value: HostIPv4- , settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.+ { settingsPort :: Port+ -- ^ Port to listen on. Default value: 3000+ , settingsHost :: HostPreference+ -- ^ Default value: HostIPv4+ , settingsOnException :: Maybe Request -> SomeException -> IO ()+ -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , settingsOnExceptionResponse :: SomeException -> Response- -- ^ A function to create `Response` when an exception occurs.- --- -- Default: 500, text/plain, \"Something went wrong\"- --- -- Since 2.0.3- , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.- , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing.- , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30- , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'- , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0- , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0+ -- ^ A function to create `Response` when an exception occurs.+ --+ -- Default: 500, text/plain, \"Something went wrong\"+ --+ -- Since 2.0.3+ , settingsOnOpen :: SockAddr -> IO Bool+ -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.+ , settingsOnClose :: SockAddr -> IO ()+ -- ^ What to do when a connection is close. Default: do nothing.+ , settingsTimeout :: Int+ -- ^ Timeout value in seconds. Default value: 30+ , settingsManager :: Maybe Manager+ -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'+ , settingsFdCacheDuration :: Int+ -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0+ , settingsFileInfoCacheDuration :: Int+ -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsBeforeMainLoop :: IO ()- -- ^ Code to run after the listening socket is ready but before entering- -- the main event loop. Useful for signaling to tests that they can start- -- running, or to drop permissions after binding to a restricted port.- --- -- Default: do nothing.- --- -- Since 1.3.6-+ -- ^ Code to run after the listening socket is ready but before entering+ -- the main event loop. Useful for signaling to tests that they can start+ -- running, or to drop permissions after binding to a restricted port.+ --+ -- Default: do nothing.+ --+ -- Since 1.3.6 , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()- -- ^ Code to fork a new thread to accept a connection.- --- -- This may be useful if you need OS bound threads, or if- -- you wish to develop an alternative threading model.- --- -- Default: void . forkIOWithUnmask- --- -- Since 3.0.4-+ -- ^ Code to fork a new thread to accept a connection.+ --+ -- This may be useful if you need OS bound threads, or if+ -- you wish to develop an alternative threading model.+ --+ -- Default: 'defaultFork'+ --+ -- Since 3.0.4+ , settingsAccept :: Socket -> IO (Socket, SockAddr)+ -- ^ Code to accept a new connection.+ --+ -- Useful if you need to provide connected sockets from something other+ -- than a standard accept call.+ --+ -- Default: 'defaultAccept'+ --+ -- Since 3.3.24 , settingsNoParsePath :: Bool- -- ^ Perform no parsing on the rawPathInfo.- --- -- This is useful for writing HTTP proxies.- --- -- Default: False- --- -- Since 2.0.3+ -- ^ Perform no parsing on the rawPathInfo.+ --+ -- This is useful for writing HTTP proxies.+ --+ -- Default: False+ --+ -- Since 2.0.3 , settingsInstallShutdownHandler :: IO () -> IO ()+ -- ^ An action to install a handler (e.g. Unix signal handler)+ -- to close a listen socket.+ -- The first argument is an action to close the listen socket.+ --+ -- Default: no action+ --+ -- Since 3.0.1 , settingsServerName :: ByteString- -- ^ Default server name if application does not set one.- --- -- Since 3.0.2+ -- ^ Default server name if application does not set one.+ --+ -- Since 3.0.2 , settingsMaximumBodyFlush :: Maybe Int- -- ^ See @setMaximumBodyFlush@.- --- -- Since 3.0.3+ -- ^ See @setMaximumBodyFlush@.+ --+ -- Since 3.0.3 , settingsProxyProtocol :: ProxyProtocol- -- ^ Specify usage of the PROXY protocol.- --- -- Since 3.0.5.+ -- ^ Specify usage of the PROXY protocol.+ --+ -- Since 3.0.5 , settingsSlowlorisSize :: Int- -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048- --- -- Since 3.1.2.+ -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048+ --+ -- Since 3.1.2 , settingsHTTP2Enabled :: Bool- -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True- --- -- Since 3.1.7.+ -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True+ --+ -- Since 3.1.7 , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()- -- ^ A log function. Default: no action.- --- -- Since 3.X.X.+ -- ^ A log function. Default: no action.+ --+ -- Since 3.1.10 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()- -- ^ A HTTP/2 server push log function. Default: no action.- --- -- Since 3.X.X.+ -- ^ 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+ -- ^ An optional timeout to limit the time (in seconds) waiting for+ -- a graceful shutdown of the web server.+ --+ -- Since 3.2.8+ , settingsGracefulCloseTimeout1 :: Int+ -- ^ A timeout to limit the time (in milliseconds) waiting for+ -- FIN for HTTP/1.x. 0 means uses immediate close.+ -- Default: 0.+ --+ -- Since 3.3.5+ , settingsGracefulCloseTimeout2 :: Int+ -- ^ A timeout to limit the time (in milliseconds) waiting for+ -- FIN for HTTP/2. 0 means uses immediate close.+ -- Default: 2000.+ --+ -- Since 3.3.5+ , settingsMaxTotalHeaderLength :: Int+ -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.+ --+ -- Since 3.3.8+ , settingsAltSvc :: Maybe ByteString+ -- ^ Specify the header value of Alternative Services (AltSvc:).+ --+ -- Default: Nothing+ --+ -- Since 3.3.11+ , settingsMaxBuilderResponseBufferSize :: Int+ -- ^ Determines the maxium buffer size when sending `Builder` responses+ -- (See `responseBuilder`).+ --+ -- When sending a builder response warp uses a 16 KiB buffer to write the+ -- builder to. When that buffer is too small to fit the builder warp will+ -- free it and create a new one that will fit the builder.+ --+ -- To protect against allocating too large a buffer warp will error if the+ -- builder requires more than this maximum.+ --+ -- Default: 1049_000_000 = 1 MiB.+ --+ -- Since 3.3.22+ , settingsConnectionCounter :: Maybe Counter+ -- ^ A counter for tracking open connections.+ -- Use 'makeSettingsAndCounter' to create settings with a counter,+ -- then use 'getCount' on the returned 'Counter' to read the current value.+ --+ -- Default: 'Nothing' (warp creates an internal counter)+ --+ -- /DEPRECATED in favor of 'settingsServerState'/+ --+ -- Since 3.4.11+ , settingsServerState :: Maybe ServerState+ -- ^ Internal read-only server state.+ -- Use 'makeSettingsAndServerState' to gain access to the state of the server.+ -- Using functions like 'currentOpenConnections' or 'currentShuttingDownState'+ -- to gain insight into the current state of the server.+ --+ -- Default: 'Nothing' (warp creates its own internal state)+ --+ -- Since 3.4.13 } -- | Specify usage of the PROXY protocol.-data ProxyProtocol = ProxyProtocolNone- -- ^ See @setProxyProtocolNone@.- | ProxyProtocolRequired- -- ^ See @setProxyProtocolRequired@.- | ProxyProtocolOptional- -- ^ See @setProxyProtocolOptional@.+data ProxyProtocol+ = -- | See @setProxyProtocolNone@.+ ProxyProtocolNone+ | -- | See @setProxyProtocolRequired@.+ ProxyProtocolRequired+ | -- | See @setProxyProtocolOptional@.+ ProxyProtocolOptional +-- | Internal read-only state of the server+--+-- Since 3.4.13+data ServerState = ServerState+ { serverConnectionCounter :: Counter+ , serverShuttingDown :: ShuttingDown+ }++-- | Takes 'Settings' and either returns the 'ServerState'+-- that was already in there, or creates a new 'ServerState'.+--+-- The returned 'Settings' will always contain a 'ServerState'.+--+-- This makes it idempotent if care is taken that the @oldSettings@+-- are not used after using this function.+--+-- Since 3.4.13+makeServerState :: Settings -> IO (ServerState, Settings)+makeServerState oldSettings =+ case settingsServerState oldSettings of+ Just serverState -> pure (serverState, oldSettings)+ Nothing -> do+ serverState <- newServerState+ let counter = serverConnectionCounter serverState+ pure+ ( serverState+ , oldSettings+ { settingsServerState = Just serverState+ , settingsConnectionCounter = Just counter+ }+ )++-- | Initialize a 'ServerState'+--+-- Since 3.4.13+newServerState :: IO ServerState+newServerState = do+ counter <- newCounter+ shuttingDown <- newShuttingDown+ pure+ ServerState+ { serverConnectionCounter = counter+ , serverShuttingDown = shuttingDown+ }++-- | Get the currently open connections of the server.+--+-- Since 3.4.13+currentOpenConnections :: ServerState -> IO Int+currentOpenConnections = getCount . serverConnectionCounter++-- | Get the currently open connections of the server in an 'STM' transaction.+--+-- Since 3.4.13+currentOpenConnectionsSTM :: ServerState -> STM Int+currentOpenConnectionsSTM = getCountSTM . serverConnectionCounter++-- | Check if the server is currently shutting down.+--+-- > False: Server is not shutting down+-- > True: Server is shutting down or has shut down.+--+-- Since 3.4.13+currentShuttingDownState :: ServerState -> IO Bool+currentShuttingDownState = readShuttingDown . serverShuttingDown++-- | Check if the server is currently shutting down in an 'STM' transaction.+--+-- (This way you can have a thread wait for server shutdown with 'Control.Concurrent.STM.retry')+--+-- > False: Server is not shutting down+-- > True: Server is shutting down or has shut down.+--+-- Since 3.4.13+currentShuttingDownStateSTM :: ServerState -> STM Bool+currentShuttingDownStateSTM = readShuttingDownSTM . serverShuttingDown+ -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings-defaultSettings = Settings- { settingsPort = 3000- , settingsHost = "*4"- , settingsOnException = defaultOnException- , settingsOnExceptionResponse = defaultOnExceptionResponse- , settingsOnOpen = const $ return True- , settingsOnClose = const $ return ()- , settingsTimeout = 30- , settingsManager = Nothing- , settingsFdCacheDuration = 0- , settingsFileInfoCacheDuration = 0- , settingsBeforeMainLoop = return ()- , settingsFork = void . forkIOWithUnmask- , settingsNoParsePath = False- , settingsInstallShutdownHandler = const $ return ()- , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version- , settingsMaximumBodyFlush = Just 8192- , settingsProxyProtocol = ProxyProtocolNone- , settingsSlowlorisSize = 2048- , settingsHTTP2Enabled = True- , settingsLogger = \_ _ _ -> return ()- , settingsServerPushLogger = \_ _ _ -> return ()- , settingsGracefulShutdownTimeout = Nothing- }+defaultSettings =+ Settings+ { settingsPort = 3000+ , settingsHost = "*4"+ , settingsOnException = defaultOnException+ , settingsOnExceptionResponse = defaultOnExceptionResponse+ , settingsOnOpen = const $ return True+ , settingsOnClose = const $ return ()+ , settingsTimeout = 30+ , settingsManager = Nothing+ , settingsFdCacheDuration = 0+ , settingsFileInfoCacheDuration = 0+ , settingsBeforeMainLoop = return ()+ , settingsFork = defaultFork+ , settingsAccept = defaultAccept+ , settingsNoParsePath = False+ , settingsInstallShutdownHandler = const $ return ()+ , settingsServerName = C8.pack $ "Warp/" ++ warpVersion+ , settingsMaximumBodyFlush = Just 8192+ , settingsProxyProtocol = ProxyProtocolNone+ , settingsSlowlorisSize = 2048+ , settingsHTTP2Enabled = True+ , settingsLogger = \_ _ _ -> return ()+ , settingsServerPushLogger = \_ _ _ -> return ()+ , settingsGracefulShutdownTimeout = Nothing+ , settingsGracefulCloseTimeout1 = 0+ , settingsGracefulCloseTimeout2 = 2000+ , settingsMaxTotalHeaderLength = 50 * 1024+ , settingsAltSvc = Nothing+ , settingsMaxBuilderResponseBufferSize = 1049000000+ , settingsConnectionCounter = Nothing+ , settingsServerState = Nothing+ } +-- | Create 'defaultSettings' with a connection counter.+-- Use 'getCount' on the returned 'Counter' to check open connections.+--+-- /DEPRECATED in favor of 'makeSettingsAndServerState'/+--+-- Since 3.4.11+makeSettingsAndCounter :: IO (Counter, Settings)+makeSettingsAndCounter = do+ (serverState, settings) <- makeSettingsAndServerState+ pure (serverConnectionCounter serverState, settings)++-- | Create 'defaultSettings' with a 'ServerState'.+-- Use functions like 'currentOpenConnections' and 'currentShuttingDownState'+-- to gain insight into the state of the server.+--+-- Since 3.4.13+makeSettingsAndServerState :: IO (ServerState, Settings)+makeSettingsAndServerState = makeServerState defaultSettings+ -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur -- under the normal course of the web server running.@@ -154,11 +356,11 @@ -- Since 2.1.3 defaultShouldDisplayException :: SomeException -> Bool defaultShouldDisplayException se- | Just ThreadKilled <- fromException se = False | Just (_ :: InvalidRequest) <- fromException se = False | Just (ioeGetErrorType -> et) <- fromException se- , et == ResourceVanished || et == InvalidArgument = False- | Just TimeoutThread <- fromException se = False+ , et == ResourceVanished || et == InvalidArgument =+ False+ | isAsyncException se = False | otherwise = True -- | Printing an exception to standard error@@ -167,8 +369,10 @@ -- Since: 3.1.0 defaultOnException :: Maybe Request -> SomeException -> IO () defaultOnException _ e =- when (defaultShouldDisplayException e)- $ TIO.hPutStrLn stderr $ T.pack $ show e+ when (defaultShouldDisplayException e) $+ TIO.hPutStrLn stderr $+ T.pack $+ show e -- | Sending 400 for bad requests. -- Sending 500 for internal server errors.@@ -178,21 +382,27 @@ -- Since 3.2.27 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e- | Just (_ :: InvalidRequest) <-- fromException e = responseLBS H.badRequest400- [(H.hContentType, "text/plain; charset=utf-8")]- "Bad Request"- | Just (ConnectionError (UnknownErrorCode 413) t) <-- fromException e = responseLBS H.status413- [(H.hContentType, "text/plain; charset=utf-8")]- (fromStrict t)- | Just (ConnectionError (UnknownErrorCode 431) t) <-- fromException e = responseLBS H.status431- [(H.hContentType, "text/plain; charset=utf-8")]- (fromStrict t)- | otherwise = responseLBS H.internalServerError500- [(H.hContentType, "text/plain; charset=utf-8")]- "Something went wrong"+ | isAsyncException e = throw e+ | Just PayloadTooLarge <- fromException e =+ responseLBS+ H.status413+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Payload too large"+ | Just RequestHeaderFieldsTooLarge <- fromException e =+ responseLBS+ H.status431+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Request header fields too large"+ | Just (_ :: InvalidRequest) <- fromException e =+ responseLBS+ H.badRequest400+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Bad Request"+ | otherwise =+ responseLBS+ H.internalServerError500+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Something went wrong" -- | Exception handler for the debugging purpose. -- 500, text/plain, a showed exception.@@ -200,6 +410,48 @@ -- Since: 2.0.3.2 exceptionResponseForDebug :: SomeException -> Response exceptionResponseForDebug e =- responseBuilder H.internalServerError500- [(H.hContentType, "text/plain; charset=utf-8")]- $ byteString . C8.pack $ "Exception: " ++ show e+ responseBuilder+ H.internalServerError500+ [(H.hContentType, "text/plain; charset=utf-8")]+ $ "Exception: " <> Builder.stringUtf8 (show e)++-- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler.+--+-- Since Warp will always install its own exception handler in forked threads, this provides+-- a minor optimization.+--+-- For inspiration of this function, see @rawForkIO@ in the @async@ package.+--+-- @since 3.3.17+defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()+defaultFork io =+ IO $ \s0 ->+#if __GLASGOW_HASKELL__ >= 904+ case io unsafeUnmask of+ IO io' ->+ case fork# io' s0 of+ (# s1, _tid #) -> (# s1, () #)+#else+ case fork# (io unsafeUnmask) s0 of+ (# s1, _tid #) -> (# s1, () #)+#endif++-- | Standard "accept" call for a listening socket.+--+-- @since 3.3.24+defaultAccept :: Socket -> IO (Socket, SockAddr)+defaultAccept =+#if WINDOWS+ windowsThreadBlockHack . accept+#else+ accept+#endif++-- | The version of Warp.+warpVersion :: String+warpVersion =+#ifdef INCLUDE_WARP_VERSION+ showVersion Paths_warp.version+#else+ "unknown"+#endif
+ Network/Wai/Handler/Warp/ShuttingDown.hs view
@@ -0,0 +1,34 @@+-- Most important is to not export the data constructor from this module+-- and to not expose 'writeShuttingDown' to the end user.+module Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ writeShuttingDown,+) where++import Control.Concurrent.STM (+ STM,+ TVar,+ atomically,+ newTVarIO,+ readTVar,+ readTVarIO,+ writeTVar,+ )++newtype ShuttingDown = ShuttingDown (TVar Bool)++newShuttingDown :: IO ShuttingDown+newShuttingDown = ShuttingDown <$> newTVarIO False++readShuttingDown :: ShuttingDown -> IO Bool+readShuttingDown (ShuttingDown var) = readTVarIO var++readShuttingDownSTM :: ShuttingDown -> STM Bool+readShuttingDownSTM (ShuttingDown var) = readTVar var++writeShuttingDown :: ShuttingDown -> Bool -> IO ()+writeShuttingDown (ShuttingDown var) b =+ atomically $ writeTVar var b
Network/Wai/Handler/Warp/Types.hs view
@@ -1,14 +1,17 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.Types where -import Control.Exception+import Control.Concurrent.STM (TVar)+import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.IORef (IORef, readIORef, writeIORef, newIORef)-import Data.Typeable (Typeable)-import Foreign.Ptr (Ptr)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+#ifdef MIN_VERSION_crypton_x509+import Data.X509+#endif+import Network.Socket (SockAddr)+import Network.Socket.BufferPool import System.Posix.Types (Fd) import qualified System.TimeManager as T @@ -30,14 +33,19 @@ ---------------------------------------------------------------- -- | Error types for bad 'Request'.-data InvalidRequest = NotEnoughLines [String]- | BadFirstLine String- | NonHttp- | IncompleteHeaders- | ConnectionClosedByPeer- | OverLargeHeader- | BadProxyHeader String- deriving (Eq, Typeable)+data InvalidRequest+ = NotEnoughLines [String]+ | BadFirstLine String+ | NonHttp+ | IncompleteHeaders+ | ConnectionClosedByPeer+ | OverLargeHeader+ | BadProxyHeader String+ | -- | Since 3.3.22+ PayloadTooLarge+ | -- | Since 3.3.22+ RequestHeaderFieldsTooLarge+ deriving (Eq) instance Show InvalidRequest where show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs@@ -45,10 +53,13 @@ show NonHttp = "Warp: Request line specified a non-HTTP request" show IncompleteHeaders = "Warp: Request headers did not finish transmission" show ConnectionClosedByPeer = "Warp: Client closed connection prematurely"- show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection."+ show OverLargeHeader =+ "Warp: Request headers too large, possible memory attack detected. Closing connection." show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s+ show RequestHeaderFieldsTooLarge = "Request header fields too large"+ show PayloadTooLarge = "Payload too large" -instance Exception InvalidRequest+instance E.Exception InvalidRequest ---------------------------------------------------------------- @@ -58,11 +69,10 @@ -- -- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe -- or irrecoverable.--newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException- deriving (Show, Typeable)+newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody E.SomeException+ deriving (Show) -instance Exception ExceptionInsideResponseBody+instance E.Exception ExceptionInsideResponseBody ---------------------------------------------------------------- @@ -71,67 +81,76 @@ -- the file descriptor cache. -- -- Since: 3.1.0-data FileId = FileId {- fileIdPath :: FilePath- , fileIdFd :: Maybe Fd- }+data FileId = FileId+ { fileIdPath :: FilePath+ , fileIdFd :: Maybe Fd+ } -- | fileid, offset, length, hook action, HTTP headers -- -- Since: 3.1.0 type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO () --- | Type for read buffer pool-type BufferPool = IORef ByteString---- | Type for buffer-type Buffer = Ptr Word8---- | Type for buffer size-type BufSize = Int---- | Type for the action to receive input data-type Recv = IO ByteString+-- | A write buffer of a specified size+-- containing bytes and a way to free the buffer.+data WriteBuffer = WriteBuffer+ { bufBuffer :: Buffer+ , bufSize :: !BufSize+ -- ^ The size of the write buffer.+ , bufFree :: IO ()+ -- ^ Free the allocated buffer. Warp guarantees it will only be+ -- called once, and no other functions will be called after it.+ } --- | Type for the action to receive input data with a buffer.--- The result boolean indicates whether or not the buffer is fully filled. type RecvBuf = Buffer -> BufSize -> IO Bool -- | Data type to manipulate IO actions for connections. -- This is used to abstract IO actions for plain HTTP and HTTP over TLS.-data Connection = Connection {- -- | This is not used at this moment.- connSendMany :: [ByteString] -> IO ()- -- | The sending function.- , connSendAll :: ByteString -> IO ()- -- | The sending function for files in HTTP/1.1.- , connSendFile :: SendFile- -- | The connection closing function. Warp guarantees it will only be+data Connection = Connection+ { connSendMany :: [ByteString] -> IO ()+ -- ^ This is not used at this moment.+ , connSendAll :: ByteString -> IO ()+ -- ^ The sending function.+ , connSendFile :: SendFile+ -- ^ The sending function for files in HTTP/1.1.+ , connClose :: IO ()+ -- ^ The connection closing function. Warp guarantees it will only be -- called once. Other functions (like 'connRecv') may be called after -- 'connClose' is called.- , connClose :: IO ()- -- | Free any buffers allocated. Warp guarantees it will only be- -- called once, and no other functions will be called after it.- , connFree :: IO ()- -- | The connection receiving function. This returns "" for EOF.- , connRecv :: Recv- -- | The connection receiving function. This tries to fill the buffer.- -- This returns when the buffer is filled or reaches EOF.- , connRecvBuf :: RecvBuf- -- | The write buffer.- , connWriteBuffer :: Buffer- -- | The size of the write buffer.- , connBufferSize :: BufSize+ , connRecv :: Recv+ -- ^ The connection receiving function. This returns "" for EOF or exceptions.+ , connRecvBuf :: RecvBuf+ -- ^ Obsoleted.+ , connWriteBuffer :: IORef WriteBuffer+ -- ^ Reference to a write buffer. When during sending of a 'Builder'+ -- response it's detected the current 'WriteBuffer' is too small it will be+ -- freed and a new bigger buffer will be created and written to this+ -- reference.+ , connHTTP2 :: IORef Bool+ -- ^ Is this connection HTTP/2?+ , connMySockAddr :: SockAddr+ , connAppsInProgress :: TVar Int+ -- ^ Amount of apps currently in progress on this connection.+ --+ -- /HTTP2 can handle more than one request concurrently/+ --+ -- @since 3.4.13 } +getConnHTTP2 :: Connection -> IO Bool+getConnHTTP2 = readIORef . connHTTP2++setConnHTTP2 :: Connection -> Bool -> IO ()+setConnHTTP2 = writeIORef . connHTTP2+ ---------------------------------------------------------------- -data InternalInfo = InternalInfo {- timeoutManager :: T.Manager- , getDate :: IO D.GMTDate- , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)- , getFileInfo :: FilePath -> IO I.FileInfo- }+data InternalInfo = InternalInfo+ { timeoutManager :: T.Manager+ , getDate :: IO D.GMTDate+ , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)+ , getFileInfo :: FilePath -> IO I.FileInfo+ } ---------------------------------------------------------------- @@ -157,7 +176,7 @@ readSource' (Source _ func) = func leftoverSource :: Source -> ByteString -> IO ()-leftoverSource (Source ref _) bs = writeIORef ref bs+leftoverSource (Source ref _) = writeIORef ref readLeftoverSource :: Source -> IO ByteString readLeftoverSource (Source ref _) = readIORef ref@@ -165,14 +184,39 @@ ---------------------------------------------------------------- -- | What kind of transport is used for this connection?-data Transport = TCP -- ^ Plain channel: TCP- | TLS {- tlsMajorVersion :: Int- , tlsMinorVersion :: Int- , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301- , tlsChiperID :: Word16- } -- ^ Encrypted channel: TLS or SSL+data Transport+ = -- | Plain channel: TCP+ TCP+ | TLS+ { tlsMajorVersion :: Int+ , tlsMinorVersion :: Int+ , tlsNegotiatedProtocol :: Maybe ByteString+ -- ^ The result of Application Layer Protocol Negociation in RFC 7301+ , tlsChiperID :: Word16+ -- ^ Encrypted channel: TLS or SSL+#ifdef MIN_VERSION_crypton_x509+ , tlsClientCertificate :: Maybe CertificateChain+#endif+ }+ | QUIC+ { quicNegotiatedProtocol :: Maybe ByteString+ , quicChiperID :: Word16+#ifdef MIN_VERSION_crypton_x509+ , quicClientCertificate :: Maybe CertificateChain+#endif+ } isTransportSecure :: Transport -> Bool isTransportSecure TCP = False-isTransportSecure _ = True+isTransportSecure _ = True++isTransportQUIC :: Transport -> Bool+isTransportQUIC QUIC{} = True+isTransportQUIC _ = False++#ifdef MIN_VERSION_crypton_x509+getTransportClientCertificate :: Transport -> Maybe CertificateChain+getTransportClientCertificate TCP = Nothing+getTransportClientCertificate (TLS _ _ _ _ cc) = cc+getTransportClientCertificate (QUIC _ _ cc) = cc+#endif
Network/Wai/Handler/Warp/Windows.hs view
@@ -1,25 +1,28 @@ {-# LANGUAGE CPP #-}-module Network.Wai.Handler.Warp.Windows- ( windowsThreadBlockHack- ) where +module Network.Wai.Handler.Warp.Windows (+ windowsThreadBlockHack,+) where+ #if WINDOWS-import Control.Exception import Control.Concurrent.MVar import Control.Concurrent+import qualified Control.Exception -import Network.Wai.Handler.Warp.Imports+import GHC.Conc (labelThread) -- | Allow main socket listening thread to be interrupted on Windows platform -- -- @since 3.2.17 windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack act = do- var <- newEmptyMVar :: IO (MVar (Either SomeException a))- void . forkIO $ try act >>= putMVar var+ var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a))+ -- Catch and rethrow even async exceptions, so don't bother with UnliftIO+ threadId <- forkIO $ Control.Exception.try act >>= putMVar var+ labelThread threadId "Windows Thread Block Hack (warp)" res <- takeMVar var case res of- Left e -> throwIO e+ Left e -> Control.Exception.throwIO e Right r -> return r #else windowsThreadBlockHack :: IO a -> IO a
Network/Wai/Handler/Warp/WithApplication.hs view
@@ -1,23 +1,24 @@ {-# LANGUAGE OverloadedStrings #-}+ module Network.Wai.Handler.Warp.WithApplication (- withApplication,- withApplicationSettings,- testWithApplication,- testWithApplicationSettings,- openFreePort,- withFreePort,+ withApplication,+ withApplicationSettings,+ testWithApplication,+ testWithApplicationSettings,+ openFreePort,+ withFreePort, ) where -import Control.Concurrent-import Control.Concurrent.Async-import Control.Exception-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+import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as E+import Control.Monad (when)+import Data.Streaming.Network (bindRandomPortTCP)+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp.Run+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types -- | Runs the given 'Application' on a free port. Passes the port to the given -- operation and executes it, while the 'Application' is running. Shuts down the@@ -33,20 +34,21 @@ -- @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 () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"- Right x -> return x+ app <- mkApp+ withFreePort $ \(port, sock) -> do+ started <- mkWaiter+ let settings =+ settings'+ { settingsBeforeMainLoop =+ notify started () >> settingsBeforeMainLoop settings'+ }+ result <-+ race+ (runSettingsSocket settings sock app)+ (waitFor started >> action port)+ case result of+ Left () -> E.throwIO $ E.ErrorCall "Unexpected: runSettingsSocket exited"+ Right x -> return x -- | Same as 'withApplication' but with different exception handling: If the -- given 'Application' throws an exception, 'testWithApplication' will re-throw@@ -67,31 +69,32 @@ -- | 'testWithApplication' with given 'Settings'. -- -- @since 3.2.7-testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a+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 `catch` \ e -> do- when- (defaultShouldDisplayException e)- (throwTo callingThread e)- throwIO e- withApplicationSettings settings (return wrappedApp) action+ callingThread <- myThreadId+ app <- mkApp+ let wrappedApp request respond =+ app request respond `E.catch` \e -> do+ when+ (defaultShouldDisplayException e)+ (throwTo callingThread e)+ E.throwIO e+ withApplicationSettings settings (return wrappedApp) action -data Waiter a- = Waiter {- notify :: a -> IO (),- waitFor :: IO a- }+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- }+ mvar <- newEmptyMVar+ return+ Waiter+ { notify = putMVar mvar+ , waitFor = readMVar mvar+ } -- | Opens a socket on a free port and returns both port and socket. --@@ -101,4 +104,4 @@ -- | Like 'openFreePort' but closes the socket before exiting. withFreePort :: ((Port, Socket) -> IO a) -> IO a-withFreePort = bracket openFreePort (close . snd)+withFreePort = E.bracket openFreePort (close . snd)
bench/Parser.hs view
@@ -1,30 +1,28 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Exception (throwIO, throw)+import Control.Exception (throw, throwIO) import Control.Monad import qualified Data.ByteString as S---import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B (unpack)-import qualified Network.HTTP.Types as H-import Network.Wai.Handler.Warp.Types-import Prelude hiding (lines)-+import qualified Data.ByteString.Char8 as B (pack, unpack) import Data.ByteString.Internal-import Data.Word+import Data.IORef (atomicModifyIORef', newIORef)+import qualified Data.List as L+import Data.Word8 import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable+import qualified Network.HTTP.Types as H+import Prelude hiding (lines) -#if MIN_VERSION_gauge(0, 2, 0)-import Gauge-#else-import Gauge.Main-#endif+import Network.Wai.Handler.Warp.Request (FirstRequest (..), headerLines)+import Network.Wai.Handler.Warp.Types +import Criterion.Main+ -- $setup -- >>> :set -XOverloadedStrings @@ -34,20 +32,31 @@ main = do let requestLine1 = "GET http://www.example.com HTTP/1.1" let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"- defaultMain [- bgroup "requestLine1" [- bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1- , bench "parseRequestLine2" $ 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- ]- ]+ defaultMain+ [ bgroup+ "requestLine1"+ [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1+ ]+ , bgroup+ "requestLine2"+ [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2+ ]+ , bgroup+ "parsing request"+ [ bench "new parsing 4" $ whnfAppIO testIt (chunkRequest 4)+ , bench "new parsing 10" $ whnfAppIO testIt (chunkRequest 10)+ , bench "new parsing 25" $ whnfAppIO testIt (chunkRequest 25)+ , bench "new parsing 100" $ whnfAppIO testIt (chunkRequest 100)+ ]+ ]+ where+ testIt req = producer req >>= headerLines 800 FirstRequest ---------------------------------------------------------------- @@ -61,26 +70,29 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine3 :: ByteString- -> (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine3+ :: ByteString+ -> ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine3 requestLine = ret where- (!method,!rest) = S.break (== 32) requestLine -- ' '- (!pathQuery,!httpVer')- | rest == "" = throw badmsg- | otherwise = S.break (== 32) (S.drop 1 rest) -- ' '- (!path,!query) = S.break (== 63) pathQuery -- '?'+ (!method, !rest) = S.break (== _space) requestLine+ (!pathQuery, !httpVer')+ | rest == "" = throw badmsg+ | otherwise = S.break (== _space) (S.drop 1 rest)+ (!path, !query) = S.break (== _question) pathQuery !httpVer = S.drop 1 httpVer'- (!http,!ver)- | httpVer == "" = throw badmsg- | otherwise = S.break (== 47) httpVer -- '/'- !hv | http /= "HTTP" = throw NonHttp- | ver == "/1.1" = H.http11- | otherwise = H.http10- !ret = (method,path,query,hv)+ (!http, !ver)+ | httpVer == "" = throw badmsg+ | otherwise = S.break (== _slash) httpVer+ !hv+ | http /= "HTTP" = throw NonHttp+ | ver == "/1.1" = H.http11+ | otherwise = H.http10+ !ret = (method, path, query, hv) badmsg = BadFirstLine $ B.unpack requestLine ----------------------------------------------------------------@@ -95,24 +107,27 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine2 :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine2+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len - pathptr0 <- memchr methodptr 32 lim0 -- ' '+ pathptr0 <- memchr methodptr _space lim0 when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ throwIO baderr let pathptr = pathptr0 `plusPtr` 1 lim1 = fromIntegral (limptr `minusPtr` pathptr0) - httpptr0 <- memchr pathptr 32 lim1 -- ' '+ httpptr0 <- memchr pathptr _space lim1 when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1@@ -120,17 +135,16 @@ checkHTTP httpptr !hv <- httpVersion httpptr- queryptr <- memchr pathptr 63 lim2 -- '?'-+ queryptr <- memchr pathptr _question lim2 let !method = bs ptr methodptr pathptr0 !path- | queryptr == nullPtr = bs ptr pathptr httpptr0- | otherwise = bs ptr pathptr queryptr+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr !query- | queryptr == nullPtr = S.empty- | otherwise = bs ptr queryptr httpptr0+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0 - return (method,path,query,hv)+ return (method, path, query, hv) where baderr = BadFirstLine $ B.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO ()@@ -138,19 +152,18 @@ w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do- check httpptr 0 72 -- 'H'- check httpptr 1 84 -- 'T'- check httpptr 2 84 -- 'T'- check httpptr 3 80 -- 'P'- check httpptr 4 47 -- '/'- check httpptr 6 46 -- '.'+ check httpptr 0 _H+ check httpptr 1 _T+ check httpptr 2 _T+ check httpptr 3 _P+ check httpptr 4 _slash+ check httpptr 6 _period httpVersion httpptr = do major <- peek $ httpptr `plusPtr` 5 minor <- peek $ httpptr `plusPtr` 7- if major == (49 :: Word8) && minor == (49 :: Word8) then- return H.http11- else- return H.http10+ if major == _1 && minor == _1+ then return H.http11+ else return H.http10 bs ptr p0 p1 = PS fptr o l where o = p0 `minusPtr` ptr@@ -168,23 +181,29 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine1 :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine1+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine1 requestLine = do- let (!method,!rest) = S.break (== 32) requestLine -- ' '- (!pathQuery,!httpVer') = S.break (== 32) (S.drop 1 rest) -- ' '+ let (!method, !rest) = S.break (== _space) requestLine+ (!pathQuery, !httpVer') = S.break (== _space) (S.drop 1 rest) !httpVer = S.drop 1 httpVer' when (rest == "" || httpVer == "") $- throwIO $ BadFirstLine $ B.unpack requestLine- let (!path,!query) = S.break (== 63) pathQuery -- '?'- (!http,!ver) = S.break (== 47) httpVer -- '/'+ throwIO $+ BadFirstLine $+ B.unpack requestLine+ let (!path, !query) = S.break (== _question) pathQuery+ (!http, !ver) = S.break (== _slash) httpVer when (http /= "HTTP") $ throwIO NonHttp- let !hv | ver == "/1.1" = H.http11- | otherwise = H.http10- return $! (method,path,query,hv)+ let !hv+ | ver == "/1.1" = H.http11+ | otherwise = H.http10+ return $! (method, path, query, hv) ---------------------------------------------------------------- @@ -198,23 +217,68 @@ -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp-parseRequestLine0 :: ByteString- -> IO (H.Method- ,ByteString -- Path- ,ByteString -- Query- ,H.HttpVersion)+parseRequestLine0+ :: ByteString+ -> IO+ ( H.Method+ , ByteString -- Path+ , ByteString -- Query+ , H.HttpVersion+ ) parseRequestLine0 s =- case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- '- (method':query:http'') -> do+ case filter (not . S.null) $ S.splitWith (\c -> c == _space || c == _tab) s of+ (method' : query : http'') -> do let !method = method' !http' = S.concat http'' (!hfirst, !hsecond) = S.splitAt 5 http' if hfirst == "HTTP/"- then let (!rpath, !qstring) = S.break (== 63) query -- '?'+ then+ let (!rpath, !qstring) = S.break (== _question) query !hv = case hsecond of "1.1" -> H.http11 _ -> H.http10- in return $! (method, rpath, qstring, hv)- else throwIO NonHttp+ in return $! (method, rpath, qstring, hv)+ else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s++producer :: [ByteString] -> IO Source+producer a = do+ ref <- newIORef a+ mkSource $+ atomicModifyIORef' ref $ \case+ [] -> ([], S.empty)+ b : bs -> (bs, b)++chunkRequest :: Int -> [ByteString]+chunkRequest chunkAmount =+ go basicRequest+ where+ len = L.length basicRequest+ chunkSize = (len `div` chunkAmount) + 1+ go [] = []+ go xs =+ let (a, b) = L.splitAt chunkSize xs+ in B.pack a : go b++-- Random google search request+basicRequest :: String+basicRequest =+ mconcat+ [ "GET /search?q=test&sca_esv=600090652&source=hp&uact=5&oq=test&sclient=gws-wiz HTTP/3\r\n"+ , "Host: www.google.com\r\n"+ , "User-Agent: Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:121.0) Gecko/20100101 Firefox/121.0\r\n"+ , "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8\r\n"+ , "Accept-Language: en-US,en;q=0.5\r\n"+ , "Accept-Encoding: gzip, deflate, br\r\n"+ , "Referer: https://www.google.com/\r\n"+ , "Alt-Used: www.google.com\r\n"+ , "Connection: keep-alive\r\n"+ , "Cookie: CONSENT=PENDING+252\r\n"+ , "Upgrade-Insecure-Requests: 1\r\n"+ , "Sec-Fetch-Dest: document\r\n"+ , "Sec-Fetch-Mode: navigate\r\n"+ , "Sec-Fetch-Site: same-origin\r\n"+ , "Sec-Fetch-User: ?1\r\n"+ , "TE: trailers\r\n\r\n"+ ]
− test/BufferPoolSpec.hs
@@ -1,47 +0,0 @@-module BufferPoolSpec where--import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B (ByteString(PS))-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Marshal.Utils (copyBytes)-import Foreign.Ptr (plusPtr)--import Test.Hspec (Spec, hspec, shouldBe, describe, it)--import Network.Wai.Handler.Warp.Buffer- ( bufferSize- , newBufferPool- , withBufferPool- )-import Network.Wai.Handler.Warp.Types (Buffer, BufSize)--main :: IO ()-main = hspec spec---- Two ByteStrings each big enough to fill a 'bufferSize' buffer (16K).-wantData, otherData :: B.ByteString-wantData = B.replicate bufferSize 0xac-otherData = B.replicate bufferSize 0x77--spec :: Spec-spec = describe "withBufferPool" $ do- it "does not clobber buffers" $ do- pool <- newBufferPool- -- 'pool' contains B.empty; prime it to contain a real buffer.- _ <- withBufferPool pool $ const $ return 0- -- 'pool' contains a 16K buffer; fill it with \xac and keep the result.- got <- withBufferPool pool $ blitBuffer wantData- got `shouldBe` wantData- -- 'pool' should now be empty and reallocate, rather than clobber the- -- previous buffer.- _ <- withBufferPool pool $ blitBuffer otherData- got `shouldBe` wantData---- Fill the Buffer with the contents of the ByteString and return the number of--- bytes written. To be used with 'withBufferPool'.-blitBuffer :: B.ByteString -> (Buffer, BufSize) -> IO Int-blitBuffer (B.PS fp off len) (dst, len') = withForeignPtr fp $ \ptr -> do- let src = ptr `plusPtr` off- n = min len len'- copyBytes dst src n- return n
test/ConduitSpec.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings #-}+ module ConduitSpec (main, spec) where +import Control.Monad (replicateM)+import qualified Data.ByteString as S+import Data.IORef as I import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.Types-import Control.Monad (replicateM) import Test.Hspec-import Data.IORef as I-import qualified Data.ByteString as S main :: IO () main = hspec spec@@ -14,25 +15,25 @@ spec :: Spec spec = describe "conduit" $ do it "IsolatedBSSource" $ do- ref <- newIORef $ map S.singleton [1..50]+ ref <- newIORef $ map S.singleton [1 .. 50] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty- y:z -> do+ y : z -> do writeIORef ref z return y isrc <- mkISource src 40 x <- replicateM 20 $ readISource isrc- S.concat x `shouldBe` S.pack [1..20]+ S.concat x `shouldBe` S.pack [1 .. 20] y <- replicateM 40 $ readISource isrc- S.concat y `shouldBe` S.pack [21..40]+ S.concat y `shouldBe` S.pack [21 .. 40] z <- replicateM 40 $ readSource src- S.concat z `shouldBe` S.pack [41..50]+ S.concat z `shouldBe` S.pack [41 .. 50] it "chunkedSource" $ do- ref <- newIORef $ "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH"+ ref <- newIORef "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH" src <- mkSource $ do x <- readIORef ref writeIORef ref S.empty@@ -45,17 +46,18 @@ y <- replicateM 15 $ readSource src S.concat y `shouldBe` "BLAH" it "chunk boundaries" $ do- ref <- newIORef- [ "5\r\n"- , "12345\r\n3\r"- , "\n678\r\n0\r\n"- , "\r\nBLAH"- ]+ ref <-+ newIORef+ [ "5\r\n"+ , "12345\r\n3\r"+ , "\n678\r\n0\r\n"+ , "\r\nBLAH"+ ] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty- y:z -> do+ y : z -> do writeIORef ref z return y csrc <- mkCSource src
+ test/ConnectionSpec.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module ConnectionSpec (spec) where++import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp+import RunSpec (withApp, withMySocket, msWrite, msRead)+import Test.Hspec+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8++spec :: Spec+spec = describe "Connection header" $ do+ it "sends Connection: close when response implies close (HTTP/1.0 Keep-Alive, no Content-Length)" $ do+ let app _ f = f $ responseLBS status200 [] "foo"+ withApp defaultSettings app $ withMySocket $ \ms -> do+ -- HTTP/1.0 defaults to close. We ask for Keep-Alive.+ -- But we provide no Content-Length in response.+ -- So Warp should decide to close (because it can't keep alive without length or chunking),+ -- and MUST send "Connection: close" to inform the client.+ msWrite ms "GET / HTTP/1.0\r\nConnection: Keep-Alive\r\n\r\n"+ + -- We expect the connection to be closed by the server, so reading a large amount + -- should return whatever was sent and then finish.+ response <- msRead ms 4096+ + let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Just "close"+ + describe "HTTP/1.1 Connection: close behavior" $ do+ it "sends Connection: close for HEAD request without Content-Length" $ do+ -- Response has no Content-Length and is not chunked (HEAD implies no body).+ -- In HTTP/1.1 this requires closing the connection to delimit the response (or rather, lack of persistence info).+ let app _ f = f $ responseBuilder status200 [] "foo"+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "HEAD / HTTP/1.1\r\nHost: localhost\r\n\r\n"+ response <- msRead ms 4096+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Just "close"+ + it "sends Connection: close when request has Connection: close (200 OK)" $ do+ let app _ f = f $ responseLBS status200 [] "foo"+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ response <- msRead ms 4096+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Just "close"+ + it "sends Connection: close when request has Connection: close (204 No Content)" $ do+ let app _ f = f $ responseLBS status204 [] ""+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ response <- msRead ms 4096+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Just "close"+ + it "sends Connection: close when request has Connection: close (500 Internal Server Error)" $ do+ let app _ f = f $ responseLBS status500 [] "error"+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ response <- msRead ms 4096+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Just "close"+parseHeaders :: ByteString -> [(ByteString, ByteString)]+parseHeaders bs = + let lines = S8.lines bs+ -- Drop status line+ headerLines = takeWhile (not . S8.null . S8.filter (/= '\r')) $ drop 1 lines+ parseLine line = + let (k, v) = S8.break (== ':') line+ v' = S8.takeWhile (/= '\r') v+ in (k, S8.dropWhile (== ' ') $ S8.drop 1 v')+ in map parseLine headerLines
test/ExceptionSpec.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module ExceptionSpec (main, spec) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif+import Control.Concurrent.Async (withAsync)+import Control.Exception import Control.Monad+import qualified Data.Streaming.Network as N import Network.HTTP.Types hiding (Header)+import Network.Socket (close) import Network.Wai hiding (Response, responseStatus)-import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp+import Network.Wai.Internal (Request (..)) import Test.Hspec-import Control.Exception-import qualified Data.Streaming.Network as N-import Control.Concurrent.Async (withAsync)-import Network.Socket (close) import HTTP @@ -26,11 +27,11 @@ (N.bindRandomPortTCP "127.0.0.1") (close . snd) $ \(prt, lsocket) -> do- withAsync (runSettingsSocket defaultSettings lsocket testApp)- $ \_ -> inner prt+ withAsync (runSettingsSocket defaultSettings lsocket testApp) $+ \_ -> inner prt testApp :: Application-testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f+testApp (Network.Wai.Internal.Request{pathInfo = [x]}) f | x == "statusError" = f $ responseLBS undefined [] "foo" | x == "headersError" =@@ -43,24 +44,25 @@ void $ fail "ioException" f $ responseLBS ok200 [] "foo" testApp _ f =- f $ responseLBS ok200 [] "foo"+ f $ responseLBS ok200 [] "foo" spec :: Spec spec = describe "responds even if there is an exception" $ do- {- Disabling these tests. We can consider forcing evaluation in Warp.- it "statusError" $ do- sc <- 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+ {- Disabling these tests. We can consider forcing evaluation in Warp.+ it "statusError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"+ sc `shouldBe` internalServerError500+ it "headersError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"+ sc `shouldBe` internalServerError500+ it "headerError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"+ sc `shouldBe` internalServerError500+ it "bodyError" $ do+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"+ sc `shouldBe` internalServerError500+ -}+ it "ioException" $ withTestServer $ \prt -> do+ sc <-+ responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")+ sc `shouldBe` internalServerError500
test/FdCacheSpec.hs view
@@ -6,7 +6,7 @@ #ifndef WINDOWS import Data.IORef import Network.Wai.Handler.Warp.FdCache-import System.Posix.IO (fdRead)+import System.Posix.IO.ByteString (fdRead) import System.Posix.Types (Fd(..)) main :: IO ()
test/FileSpec.hs view
@@ -2,44 +2,131 @@ module FileSpec (main, spec) where +import Data.ByteString+import Data.String (fromString) import Network.HTTP.Types import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header+import System.IO.Unsafe (unsafePerformIO) import Test.Hspec main :: IO () main = hspec spec -testFileRange :: String- -> RequestHeaders -> FilePath- -> RspFileInfo- -> Spec-testFileRange desc reqhs file ans = it desc $ do- finfo <- getInfo file- let WithBody s hs off len = ans- hs' = ("Last-Modified",fileInfoDate finfo) : hs- ans' = WithBody s hs' off len- conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'+changeHeaders+ :: (ResponseHeaders -> ResponseHeaders) -> RspFileInfo -> RspFileInfo+changeHeaders f rfi =+ case rfi of+ WithBody s hs off len -> WithBody s (f hs) off len+ other -> other +getHeaders :: RspFileInfo -> ResponseHeaders+getHeaders rfi =+ case rfi of+ WithBody _ hs _ _ -> hs+ _ -> []++testFileRange+ :: String+ -> RequestHeaders+ -> RspFileInfo+ -> Spec+testFileRange desc reqhs ans = it desc $ do+ finfo <- getInfo "attic/hex"+ let f = (:) ("Last-Modified", fileInfoDate finfo)+ hs = getHeaders ans+ ans' = changeHeaders f ans+ conditionalRequest+ finfo+ []+ methodGet+ (indexResponseHeader hs)+ (indexRequestHeader reqhs)+ `shouldBe` ans'++farPast, farFuture :: ByteString+farPast = "Thu, 01 Jan 1970 00:00:00 GMT"+farFuture = "Sun, 05 Oct 3000 00:00:00 GMT"++regularBody :: RspFileInfo+regularBody = WithBody ok200 [("Content-Length", "16"), ("Accept-Ranges", "bytes")] 0 16++make206Body :: Integer -> Integer -> RspFileInfo+make206Body start len =+ WithBody status206 [crHeader, lenHeader, ("Accept-Ranges", "bytes")] start len+ where+ lenHeader = ("Content-Length", fromString $ show len)+ crHeader =+ ( "Content-Range"+ , fromString $ "bytes " <> show start <> "-" <> show (start + len - 1) <> "/16"+ )+ spec :: Spec spec = do describe "conditionalRequest" $ do testFileRange "gets a file size from file system"- [] "attic/hex"- $ WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16+ []+ regularBody testFileRange "gets a file size from file system and handles Range and returns Partical Content"- [("Range","bytes=2-14")] "attic/hex"- $ WithBody status206 [("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")] 2 13+ [("Range", "bytes=2-14")]+ $ make206Body 2 13 testFileRange "truncates end point of range to file size"- [("Range","bytes=10-20")] "attic/hex"- $ WithBody status206 [("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")] 10 6+ [("Range", "bytes=10-20")]+ $ make206Body 10 6 testFileRange "gets a file size from file system and handles Range and returns OK if Range means the entire"- [("Range:","bytes=0-15")] "attic/hex"- $ WithBody status200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16-+ [("Range:", "bytes=0-15")]+ regularBody+ testFileRange+ "returns a 412 if the file has been changed in the meantime"+ [("If-Unmodified-Since", farPast)]+ $ WithoutBody status412+ testFileRange+ "gets a file if the file has not been changed in the meantime"+ [("If-Unmodified-Since", farFuture)]+ regularBody+ testFileRange+ "ignores the If-Unmodified-Since header if an If-Match header is also present"+ [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast)]+ regularBody+ testFileRange+ "still gives only a range, even after conditionals"+ [ ("If-Match", "SomeETag")+ , ("If-Unmodified-Since", farPast)+ , ("Range", "bytes=10-20")+ ]+ $ make206Body 10 6+ testFileRange+ "gets a file if the file has been changed in the meantime"+ [("If-Modified-Since", farPast)]+ regularBody+ testFileRange+ "returns a 304 if the file has not been changed in the meantime"+ [("If-Modified-Since", farFuture)]+ $ WithoutBody status304+ testFileRange+ "ignores the If-Modified-Since header if an If-None-Match header is also present"+ [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture)]+ regularBody+ testFileRange+ "still gives only a range, even after conditionals"+ [ ("If-None-Match", "SomeETag")+ , ("If-Modified-Since", farFuture)+ , ("Range", "bytes=10-13")+ ]+ $ make206Body 10 4+ testFileRange+ "gives the a range, if the condition is met"+ [ ("If-Range", fileInfoDate (unsafePerformIO $ getInfo "attic/hex"))+ , ("Range", "bytes=2-7")+ ]+ $ make206Body 2 6+ testFileRange+ "gives the entire body and ignores the Range header if the condition isn't met"+ [("If-Range", farPast), ("Range", "bytes=2-7")]+ regularBody
+ test/GracefulShutdownSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module GracefulShutdownSpec (spec) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception (bracket)+import Control.Monad (void)+import Network.HTTP.Client+import Network.HTTP.Types (ok200, status200)+import Network.Socket (close)+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+spec = describe "graceful shutdown" $+ it "serves the request in flight, then closes keep-alive connections and exits" $ do+ shutdownSignal <- newEmptyMVar+ allowResponse <- newEmptyMVar+ receivedRequests <- newQSemN 0+ allowSecondRequest <- newEmptyMVar++ let installShutdownHandler closeListenSocket =+ void . forkIO $ do+ readMVar shutdownSignal+ closeListenSocket++ settings =+ setInstallShutdownHandler installShutdownHandler defaultSettings++ app _ respond = do+ -- signal 1 received request+ signalQSemN receivedRequests 1+ -- block until signaled+ readMVar allowResponse+ respond $ responseLBS status200 [("Content-Length", "0")] ""++ client sendRequest = do+ -- first request should return OK+ response <- sendRequest+ responseStatus response `shouldBe` ok200+ lookup "Connection" (responseHeaders response) `shouldBe` Just "close"+ -- wait with the second request+ void $ readMVar allowSecondRequest+ -- second request should end with connection refused+ sendRequest `shouldThrow` connectionRefused++ bracket openFreePort (close . snd) $ \(testPort, sock) ->+ withAsync (runSettingsSocket settings sock app) $ \server -> do+ manager <- newManager defaultManagerSettings+ request <- parseRequest ("http://127.0.0.1:" ++ show testPort)+ withAsync+ -- start all clients+ ( replicateConcurrently_ numClients $+ client (httpNoBody request manager)+ )+ $ \clients -> do+ -- wait for all clients to send requests+ waitQSemN receivedRequests numClients+ -- shutdown the server before serving requests+ putMVar shutdownSignal ()+ -- wait a little - otherwise some requests might not get+ -- Connection: close response header+ threadDelay 100_000+ -- let requests be handled+ putMVar allowResponse ()+ -- server should exit+ timeout 5_000_000 (wait server)+ >>= maybe (expectationFailure "Timeout waiting for server shutdown") pure+ -- let clients proceed with the second request+ putMVar allowSecondRequest ()+ -- wait for all clients and propagate any exceptions+ wait clients+ where+ -- set number of clients to the number of keep-alive connections+ numClients = managerConnCount defaultManagerSettings+ connectionRefused = \case+ (HttpExceptionRequest _ (ConnectionFailure _)) -> True+ _ -> False
test/HTTP.hs view
@@ -1,19 +1,19 @@ module HTTP (- sendGET- , sendGETwH- , sendHEAD- , sendHEADwH- , responseBody- , responseStatus- , responseHeaders- , getHeaderValue- , HeaderName- ) where+ 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+import Network.HTTP.Client+import Network.HTTP.Types sendGET :: String -> IO (Response BL.ByteString) sendGET url = sendGETwH url []@@ -22,7 +22,7 @@ sendGETwH url hdr = do manager <- newManager defaultManagerSettings request <- parseRequest url- let request' = request { requestHeaders = hdr }+ let request' = request{requestHeaders = hdr} response <- httpLbs request' manager return response @@ -33,7 +33,7 @@ sendHEADwH url hdr = do manager <- newManager defaultManagerSettings request <- parseRequest url- let request' = request { requestHeaders = hdr, method = methodHead }+ let request' = request{requestHeaders = hdr, method = methodHead} response <- httpLbs request' manager return response
+ test/PackIntSpec.hs view
@@ -0,0 +1,14 @@+module PackIntSpec (spec) where++import qualified Data.ByteString.Char8 as C8+import Network.Wai.Handler.Warp.PackInt+import Test.Hspec+import Test.Hspec.QuickCheck+import qualified Test.QuickCheck as QC++spec :: Spec+spec = describe "readInt64" $ do+ prop "" $ \n -> packIntegral (abs n :: Int) == C8.pack (show (abs n))+ prop "" $ \(QC.Large n) ->+ let n' = fromIntegral (abs n :: Int)+ in packIntegral (n' :: Int) == C8.pack (show n')
test/ReadIntSpec.hs view
@@ -1,9 +1,9 @@ module ReadIntSpec (main, spec) where import Data.ByteString (ByteString)-import Test.Hspec-import Network.Wai.Handler.Warp.ReadInt import qualified Data.ByteString.Char8 as B+import Network.Wai.Handler.Warp.ReadInt+import Test.Hspec import qualified Test.QuickCheck as QC main :: IO ()@@ -11,7 +11,8 @@ spec :: Spec spec = describe "readInt64" $ do- it "converts ByteString to Int" $ QC.property (prop_read_show_idempotent readInt64)+ it "converts ByteString to Int" $+ QC.property (prop_read_show_idempotent readInt64) -- A QuickCheck property. Test that for a number >= 0, converting it to -- a string using show and then reading the value back with the function@@ -19,7 +20,8 @@ -- The functions under test only work on Natural numbers (the Conent-Length -- field in a HTTP header is always >= 0) so we check the absolute value of -- the value that QuickCheck generates for us.-prop_read_show_idempotent :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool+prop_read_show_idempotent+ :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool prop_read_show_idempotent freader x = px == freader (toByteString px) where px = abs x
test/RequestSpec.hs view
@@ -1,93 +1,117 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module RequestSpec (main, spec) where +import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.IORef+import Data.Monoid (Sum (..))+import qualified Network.HTTP.Types.Header as HH import Network.Wai.Handler.Warp.File (parseByteRanges) import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Settings (+ defaultSettings,+ settingsMaxTotalHeaderLength,+ ) import Network.Wai.Handler.Warp.Types import Test.Hspec import Test.Hspec.QuickCheck-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Network.HTTP.Types.Header as HH-import Data.IORef main :: IO () main = hspec spec +defaultMaxTotalHeaderLength :: Int+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings+ spec :: Spec spec = do- describe "headerLines" $ do- it "takes until blank" $- blankSafe >>= (`shouldBe` ("", ["foo", "bar", "baz"]))- it "ignored leading whitespace in bodies" $- whiteSafe >>= (`shouldBe` (" hi there", ["foo", "bar", "baz"]))- it "throws OverLargeHeader when too many" $- tooMany `shouldThrow` overLargeHeader- it "throws OverLargeHeader when too large" $- tooLarge `shouldThrow` overLargeHeader- it "known bad chunking behavior #239" $ do- let chunks =- [ "GET / HTTP/1.1\r\nConnection: Close\r"- , "\n\r\n"- ]- (actual, src) <- headerLinesList' chunks- leftover <- readLeftoverSource src- leftover `shouldBe` S.empty- actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]- prop "random chunking" $ \breaks extraS -> do- let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra- extra = S8.pack extraS- chunks = loop breaks bsFull- loop [] bs = [bs, undefined]- loop (x:xs) bs =- bs1 : loop xs bs2- where- (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs- (actual, src) <- headerLinesList' chunks- leftover <- consumeLen (length extraS) src+ describe "headerLines" $ do+ it "takes until blank" $+ blankSafe `shouldReturn` ("", ["foo", "bar", "baz"])+ it "ignored leading whitespace in bodies" $+ whiteSafe `shouldReturn` (" hi there", ["foo", "bar", "baz"])+ it "throws OverLargeHeader when too many" $+ tooMany `shouldThrow` overLargeHeader+ it "throws OverLargeHeader when too large" $+ tooLarge `shouldThrow` overLargeHeader+ it "known bad chunking behavior #239" $ do+ let chunks =+ [ "GET / HTTP/1.1\r\nConnection: Close\r"+ , "\n\r\n"+ ]+ (actual, src) <- headerLinesList' chunks+ leftover <- readLeftoverSource src+ leftover `shouldBe` S.empty+ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]+ prop "random chunking" $ \breaks extraS -> do+ let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra+ extra = S8.pack extraS+ chunks = loop breaks bsFull+ loop [] bs = [bs, undefined]+ loop (x : xs) bs =+ bs1 : loop xs bs2+ where+ (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs+ (actual, src) <- headerLinesList' chunks+ leftover <- consumeLen (length extraS) src - actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]- leftover `shouldBe` extra- describe "parseByteRanges" $ do- let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y- test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499]- test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999]- test "bytes=-500" $ Just [HH.ByteRangeSuffix 500]- test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500]- test "foobytes=9500-" Nothing- test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1]+ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]+ leftover `shouldBe` extra+ describe "parseByteRanges" $ do+ let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y+ test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499]+ test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999]+ test "bytes=-500" $ Just [HH.ByteRangeSuffix 500]+ test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500]+ test "foobytes=9500-" Nothing+ test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] - describe "headerLines" $ do- it "can handle a nomarl case" $ do- src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource- x <- headerLines True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ describe "headerLines" $ do+ let parseHeaderLine chunks = do+ src <- mkSourceFunc chunks >>= mkSource+ x <- headerLines defaultMaxTotalHeaderLength FirstRequest src+ x `shouldBe` ["Status: 200", "Content-Type: text/plain"] - it "can handle a nasty case (1)" $ do- src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource- x <- headerLines True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a normal case" $+ parseHeaderLine ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] - it "can handle a nasty case (1)" $ do- src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource- x <- headerLines True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a nasty case (1)" $ do+ parseHeaderLine ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"]+ parseHeaderLine ["Status: 200\r\n", "Content-Type: text/plain", "\r\n\r\n"] - it "can handle a nasty case (1)" $ do- src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource- x <- headerLines True src- x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a nasty case (2)" $ do+ parseHeaderLine+ ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] - it "can handle an illegal case (1)" $ do- src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource- x <- headerLines True src- x `shouldBe` []- y <- headerLines True src- y `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ it "can handle a nasty case (3)" $ do+ parseHeaderLine+ ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] + it "can handle a stupid case (3)" $+ parseHeaderLine $+ S8.pack . (: []) <$> "Status: 200\r\nContent-Type: text/plain\r\n\r\n"++ it "can (not) handle an illegal case (1)" $ do+ let chunks = ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"]+ src <- mkSourceFunc chunks >>= mkSource+ x <- headerLines defaultMaxTotalHeaderLength FirstRequest src+ x `shouldBe` []+ y <- headerLines defaultMaxTotalHeaderLength FirstRequest src+ y `shouldBe` ["Status:", " 200", "Content-Type: text/plain"]++ let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"]+ headerLength = getSum $ foldMap (Sum . S.length) testLengthHeaders+ testLength = headerLength - 2 -- Because the second CRLF at the end isn't counted+ -- Length is 39, this shouldn't fail+ it "doesn't throw on correct length" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ x <- headerLines testLength FirstRequest src+ x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ -- Length is still 39, this should fail+ it "throws error on correct length too long" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ headerLines (testLength - 1) FirstRequest src `shouldThrow` (== OverLargeHeader) where blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"] whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]@@ -107,11 +131,11 @@ x <- readIORef ref case x of [] -> return S.empty- y:z -> do+ y : z -> do writeIORef ref z return y src' <- mkSource src- res <- headerLines True src'+ res <- headerLines defaultMaxTotalHeaderLength FirstRequest src' return (res, src') consumeLen :: Int -> Source -> IO S8.ByteString@@ -126,7 +150,7 @@ then loop front 0 else do let (x, _) = S.splitAt len bs- loop (front . (x:)) (len - S.length x)+ loop (front . (x :)) (len - S.length x) overLargeHeader :: Selector InvalidRequest overLargeHeader e = e == OverLargeHeader@@ -139,7 +163,7 @@ reader ref = do xss <- readIORef ref case xss of- [] -> return S.empty- (x:xs) -> do+ [] -> return S.empty+ (x : xs) -> do writeIORef ref xs return x
test/ResponseHeaderSpec.hs view
@@ -4,12 +4,9 @@ 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 Network.Wai.Handler.Warp.HTTP2.HPACK-import Network.HPACK-import Network.HPACK.Token+import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.ResponseHeader import Test.Hspec main :: IO ()@@ -24,9 +21,9 @@ it "adds Server if not exist" $ do let hdrs = [] rspidxhdr = indexResponseHeader hdrs- addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server","MyServer")]+ addServer "MyServer" rspidxhdr hdrs `shouldBe` [("Server", "MyServer")] it "does not add Server if exists" $ do- let hdrs = [("Server","MyServer")]+ let hdrs = [("Server", "MyServer")] rspidxhdr = indexResponseHeader hdrs addServer "MyServer2" rspidxhdr hdrs `shouldBe` hdrs it "does not add Server if empty" $ do@@ -34,48 +31,19 @@ rspidxhdr = indexResponseHeader hdrs addServer "" rspidxhdr hdrs `shouldBe` hdrs it "deletes Server " $ do- let hdrs = [("Server","MyServer")]+ let hdrs = [("Server", "MyServer")] rspidxhdr = indexResponseHeader hdrs addServer "" rspidxhdr hdrs `shouldBe` []- describe "addHeader" $ do- it "adds Server if not exist" $ do- let v = "MyServer"- hdrs = []- hdrs1 = [("Server",v)]- (thl, vt) <- toHeaderTable hdrs- (thl1, _) <- toHeaderTable hdrs1- addHeader tokenServer v vt thl `shouldBe` thl1- it "does not add Server if exists" $ do- let v = "MyServer2"- hdrs = [("Server","MyServer")]- (thl, vt) <- toHeaderTable hdrs- addHeader tokenServer v vt thl `shouldBe` thl- it "does not add Server if empty" $ do- let v = ""- hdrs = []- (thl, vt) <- toHeaderTable hdrs- addHeader tokenServer v vt thl `shouldBe` thl- it "deletes Server" $ do- let v = ""- hdrs = [("Server","MyServer")]- hdrs1 = []- (thl, vt) <- toHeaderTable hdrs- (thl1, _) <- toHeaderTable hdrs1- addHeader tokenServer v vt thl `shouldBe` thl1- it "keeps Server" $ do- let v = ""- hdrs = [("Server","MyServer"),("Content-Type","Text/HTML")]- (thl, vt) <- toHeaderTable hdrs- addHeader tokenContentType v vt thl `shouldBe` thl 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")- ]+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"+composedHeader =+ "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"
test/ResponseSpec.hs view
@@ -10,25 +10,27 @@ import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Response-import RunSpec (withApp, msClose, msWrite, msRead, connectTo)+import RunSpec (msRead, msWrite, withApp, withMySocket) import Test.Hspec main :: IO () main = hspec spec -testRange :: S.ByteString -- ^ range value- -> String -- ^ expected output- -> Maybe String -- ^ expected content-range value- -> Spec-testRange range out crange = it title $ withApp defaultSettings app $ \port -> do- handle <- connectTo port- msWrite handle "GET / HTTP/1.0\r\n"- msWrite handle "Range: bytes="- msWrite handle range- msWrite handle "\r\n\r\n"+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 handle 1024- msClose handle+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 last bss `shouldBe` out let hs = mapMaybe toHeader bss lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange@@ -38,20 +40,23 @@ title = show (range, out, crange) toHeader s = case break (== ':') s of- (x, ':':y) -> Just (x, dropWhile (== ' ') y)+ (x, ':' : y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing -testPartial :: Integer -- ^ file size- -> Integer -- ^ offset- -> Integer -- ^ byte count- -> String -- ^ expected output- -> Spec-testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do- handle <- connectTo port- msWrite handle "GET / HTTP/1.0\r\n\r\n"+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 handle 1024- msClose handle+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 out `shouldBe` last bss let hs = mapMaybe toHeader bss lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)@@ -61,21 +66,22 @@ title = show (offset, count, out) toHeader s = case break (== ':') s of- (x, ':':y) -> Just (x, dropWhile (== ' ') y)+ (x, ':' : y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing- range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size+ range =+ "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size spec :: Spec spec = do-{- 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.--}+ {- 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@@ -87,7 +93,7 @@ it "discards empty lines" $ do sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar" - context "when sanitizing single occurences of \n" $ do+ context "when sanitizing single occurrences of \n" $ do it "replaces \n with \r\n" $ do sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"
test/RunSpec.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module RunSpec (main, spec, withApp, connectTo, MySocket, msWrite, msRead, msClose) where+module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM+import Control.Exception (IOException, bracket, onException, try) import qualified Control.Exception as E-import Control.Exception.Lifted (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString)@@ -21,8 +21,7 @@ import Network.Socket import Network.Socket.ByteString (sendAll) import Network.Wai hiding (responseHeaders)-import Network.Wai.Internal (getRequestBodyChunk)-import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp hiding (Counter) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec@@ -36,49 +35,59 @@ type CounterApplication = Counter -> Application data MySocket = MySocket- { msSocket :: !Socket- , _msBuffer :: !(I.IORef ByteString)- }+ { msSocket :: !Socket+ , msBuffer :: !(I.IORef ByteString)+ } msWrite :: MySocket -> ByteString -> IO ()-msWrite ms bs = sendAll (msSocket ms) bs+msWrite = sendAll . msSocket msRead :: MySocket -> Int -> IO ByteString msRead (MySocket s ref) expected = do- bs <- I.readIORef ref- inner (bs:) (S.length bs)+ 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)+ 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 = MySocket- <$> (fst <$> getSocketTCP "127.0.0.1" port)- <*> I.newIORef mempty+connectTo port = do+ s <- fst <$> getSocketTCP "127.0.0.1" port+ ref <- I.newIORef mempty+ return+ MySocket+ { msSocket = s+ , msBuffer = ref+ } +withMySocket :: (MySocket -> IO a) -> Int -> IO a+withMySocket body port = bracket (connectTo port) msClose body+ incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->- ((case ecount of+ ( case ecount of Left s -> Left s- Right i -> Right $ i + 1), ())+ Right i -> Right $ i + 1+ , ()+ ) err :: (MonadIO m, Show a) => Counter -> a -> m () err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg@@ -88,18 +97,18 @@ body <- consumeBody $ getRequestBodyChunk req case () of ()- | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"- -> err icount ("Invalid hello" :: String, body)- | requestMethod req == "GET" && L.fromChunks body /= ""- -> err icount ("Invalid GET" :: String, body)- | not $ requestMethod req `elem` ["GET", "POST"]- -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)+ | pathInfo req == ["hello"] && L.fromChunks body /= "Hello" ->+ err icount ("Invalid hello" :: String, body)+ | requestMethod req == "GET" && L.fromChunks body /= "" ->+ err icount ("Invalid GET" :: String, body)+ | requestMethod req `notElem` ["GET", "POST"] ->+ err icount ("Invalid request method (readBody)" :: String, requestMethod req) | otherwise -> incr icount f $ responseLBS status200 [] "Read the body" ignoreBody :: CounterApplication ignoreBody icount req f = do- if (requestMethod req `elem` ["GET", "POST"])+ if requestMethod req `elem` ["GET", "POST"] then incr icount else err icount ("Invalid request method" :: String, requestMethod req) f $ responseLBS status200 [] "Ignored the body"@@ -129,29 +138,34 @@ withApp settings app f = do port <- RunSpec.getPort baton <- newEmptyMVar- let settings' = setPort port- $ setHost "127.0.0.1"- $ setBeforeMainLoop (putMVar baton ())- settings+ let settings' =+ setPort port $+ setHost "127.0.0.1" $+ setBeforeMainLoop+ (putMVar baton ())+ settings bracket (forkIO $ runSettings settings' app `onException` putMVar baton ()) killThread- (const $ do+ ( 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)+ Nothing -> error "Timeout triggered, too slow!"+ Just a -> pure a+ ) -runTest :: Int -- ^ expected number of requests- -> CounterApplication- -> [ByteString] -- ^ chunks to send- -> IO ()+runTest+ :: Int+ -- ^ expected number of requests+ -> CounterApplication+ -> [ByteString]+ -- ^ chunks to send+ -> IO () runTest expected app chunks = do ref <- I.newIORef (Right 0)- withApp defaultSettings (app ref) $ \port -> do- ms <- connectTo port+ withApp defaultSettings (app ref) $ withMySocket $ \ms -> do forM_ chunks $ \chunk -> msWrite ms chunk _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096 res <- I.readIORef ref@@ -162,17 +176,17 @@ dummyApp :: Application dummyApp _ f = f $ responseLBS status200 [] "foo" -runTerminateTest :: InvalidRequest- -> ByteString- -> IO ()+runTerminateTest+ :: InvalidRequest+ -> ByteString+ -> IO () runTerminateTest expected input = do ref <- I.newIORef Nothing let onExc _ = I.writeIORef ref . Just- withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do- handle <- connectTo port- msWrite handle input- msClose handle- threadDelay 1000+ withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do+ msWrite ms input+ msClose ms -- explicitly+ threadDelay 5000 res <- I.readIORef ref show res `shouldBe` show (Just expected) @@ -193,84 +207,108 @@ describe "non-pipelining" $ do it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet- it "has body, read" $ runTest 2 readBody- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody- [ singlePostHello- , singleGet- ]- it "chunked body, read" $ runTest 2 readBody $ concat- [ singleChunkedPostHello- , [singleGet]- ]- it "chunked body, ignore" $ runTest 2 ignoreBody $ concat- [ singleChunkedPostHello- , [singleGet]- ]+ it "has body, read" $+ runTest+ 2+ readBody+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $+ runTest+ 2+ ignoreBody+ [ singlePostHello+ , singleGet+ ]+ it "chunked body, read" $+ runTest 2 readBody $+ singleChunkedPostHello ++ [singleGet]+ it "chunked body, ignore" $+ runTest 2 ignoreBody $+ singleChunkedPostHello ++ [singleGet] describe "pipelining" $ do it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet] it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]- it "has body, read" $ runTest 2 readBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- it "chunked body, read" $ runTest 2 readBody $ return $ S.concat- [ S.concat singleChunkedPostHello- , singleGet- ]- it "chunked body, ignore" $ runTest 2 ignoreBody $ return $ S.concat- [ S.concat singleChunkedPostHello- , singleGet- ]+ it "has body, read" $+ runTest 2 readBody $+ return $+ S.concat+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $+ runTest 2 ignoreBody $+ return $+ S.concat+ [ singlePostHello+ , singleGet+ ]+ it "chunked body, read" $+ runTest 2 readBody $+ return $+ S.concat+ [ S.concat singleChunkedPostHello+ , singleGet+ ]+ it "chunked body, ignore" $+ runTest 2 ignoreBody $+ return $+ S.concat+ [ S.concat singleChunkedPostHello+ , singleGet+ ] describe "no hanging" $ do- it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello+ it "has body, read" $+ runTest 1 readBody $+ map S.singleton $+ S.unpack singlePostHello it "double connect" $ runTest 1 doubleConnect [singlePostHello] describe "connection termination" $ do--- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"- it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"+ -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"+ it "IncompleteHeaders" $ do+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r"+ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-lengt" describe "special input" $ do+ let appWithSocket f = do+ iheaders <- I.newIORef []+ let app req respond = do+ liftIO $ I.writeIORef iheaders $ requestHeaders req+ respond $ responseLBS status200 [] ""+ withApp defaultSettings app $ withMySocket $ f iheaders+ it "multiline headers" $ do- iheaders <- I.newIORef []- let app req f = do- liftIO $ I.writeIORef iheaders $ requestHeaders req- f $ responseLBS status200 [] ""- withApp defaultSettings app $ \port -> do- handle <- connectTo port- let input = S.concat- [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"- ]- msWrite handle input- msClose handle- threadDelay 1000+ appWithSocket $ \iheaders ms -> do+ let input = "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"+ msWrite ms input+ threadDelay 5000 headers <- I.readIORef iheaders- headers `shouldBe`- [ ("foo", "bar baz\tbin")- ]+ headers+ `shouldBe` [ ("foo", "bar")+ , (" baz", "")+ , ("\tbin", "")+ ] it "no space between colon and value" $ do- iheaders <- I.newIORef []- let app req f = do- liftIO $ I.writeIORef iheaders $ requestHeaders req- f $ responseLBS status200 [] ""- withApp defaultSettings app $ \port -> do- handle <- connectTo port- let input = S.concat- [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"- ]- msWrite handle input- msClose handle- threadDelay 1000+ appWithSocket $ \iheaders ms -> do+ let input = "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"+ msWrite ms input+ threadDelay 5000 headers <- I.readIORef iheaders- headers `shouldBe`- [ ("foo", "bar")- ]+ headers `shouldBe` [("foo", "bar")]+ it "does not recognize multiline headers" $ do+ appWithSocket $ \iheaders ms -> do+ msWrite ms "GET / HTTP/1.1\r\nfoo: and\r\n"+ msWrite ms " baz as well\r\n\r\n"+ threadDelay 5000+ headers <- I.readIORef iheaders+ headers+ `shouldBe` [ ("foo", "and")+ , (" baz as well", "")+ ] describe "chunked bodies" $ do it "works" $ do@@ -278,102 +316,105 @@ ifront <- I.newIORef id let app req f = do bss <- consumeBody $ getRequestBodyChunk req- liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] ""- withApp defaultSettings app $ \port -> do- handle <- connectTo port- let input = S.concat- [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"- , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "b\r\nHello World\r\n0\r\n\r\n"- ]- msWrite handle input- msClose handle+ 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+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront- front [] `shouldBe`- [ "Hello World\nBye"- , "Hello World"- ]+ front []+ `shouldBe` [ "Hello World\nBye"+ , "Hello World"+ ] it "lots of chunks" $ do ifront <- I.newIORef id countVar <- newTVarIO (0 :: Int) let app req f = do bss <- consumeBody $ getRequestBodyChunk req- I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] ""- withApp defaultSettings app $ \port -> do- handle <- connectTo port- let input = concat $ replicate 2 $- ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++- (replicate 50 "5\r\n12345\r\n") ++- ["0\r\n\r\n"]- mapM_ (msWrite handle) input- msClose handle+ 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+ 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.+ -- 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:), ())+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] ""- withApp defaultSettings app $ \port -> do- handle <- connectTo port- let input = S.concat- [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"- , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "b\r\nHello World\r\n0\r\n\r\n"- ]- mapM_ (msWrite handle) $ map S.singleton $ S.unpack input- msClose handle+ 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+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront- front [] `shouldBe`- [ "Hello World\nBye"- , "Hello World"- ]+ front []+ `shouldBe` [ "Hello World\nBye"+ , "Hello World"+ ] it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do- bss <- (consumeBody $ 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:), ())+ bss <-+ consumeBody (getRequestBodyChunk req)+ `onException` liftIO+ (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted" :), ())))+ liftIO $+ threadDelay 4000000 `E.catch` \e -> do+ I.atomicModifyIORef+ ifront+ ( \front ->+ ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e) :)+ , ()+ )+ )+ E.throwIO (e :: E.SomeException)+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ()) f $ responseLBS status200 [] ""- withApp (setTimeout 1 defaultSettings) app $ \port -> do+ withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2- handle <- connectTo port- msWrite handle "POST / HTTP/1.1\r\n"- msWrite handle "content-length: "- msWrite handle $ S8.pack $ show $ S.length bs- msWrite handle "\r\n\r\n"+ msWrite ms "POST / HTTP/1.1\r\n"+ msWrite ms "content-length: "+ msWrite ms $ S8.pack $ show $ S.length bs+ msWrite ms "\r\n\r\n" threadDelay 100000- msWrite handle bs1+ msWrite ms bs1 threadDelay 100000- msWrite handle bs2- msClose handle+ msWrite ms bs2 threadDelay 5000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs@@ -389,20 +430,24 @@ loop loop doubleBS = S.concatMap $ \w -> S.pack [w, w]- withApp defaultSettings app $ \port -> do- ms <- connectTo port+ withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "POST / HTTP/1.1\r\n\r\n12345"- timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")+ timeout 100000 (msRead ms 10) `shouldReturn` Just "1122334455" msWrite ms "67890"- timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900")+ 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+ 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"]@@ -411,22 +456,21 @@ 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 $ \port -> do- (sock, _addr) <- getSocketTCP "127.0.0.1" port- sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"+ let loop = do+ bs <- getRequestBodyChunk req+ unless (S.null bs) $ do+ write $ byteString bs+ atomically $ modifyTVar countVar (+ 1)+ loop+ loop+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" threadDelay 10000- sendAll sock "5\r\nhello\r\n0\r\n\r\n"+ msWrite ms "5\r\nhello\r\n0\r\n\r\n" atomically $ do- count <- readTVar countVar- check $ count >= 1- bs <- safeRecv sock 4096+ 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@@ -454,11 +498,13 @@ 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)+ 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")]+ 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]@@ -469,4 +515,4 @@ bs <- body if S.null bs then return $ front []- else loop $ front . (bs:)+ else loop $ front . (bs :)
test/SendFileSpec.hs view
@@ -20,40 +20,44 @@ spec :: Spec spec = do- describe "packHeader" $ do- it "returns how much the buffer is consumed (1)" $- tryPackHeader 10 ["foo"] `shouldReturn` 3- it "returns how much the buffer is consumed (2)" $- tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6- it "returns how much the buffer is consumed (3)" $- tryPackHeader 10 ["0123456789"] `shouldReturn` 0- it "returns how much the buffer is consumed (4)" $- tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0- it "returns how much the buffer is consumed (5)" $- tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3- it "returns how much the buffer is consumed (6)" $- tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5+ describe "packHeader" $ do+ it "returns how much the buffer is consumed (1)" $+ tryPackHeader 10 ["foo"] `shouldReturn` 3+ it "returns how much the buffer is consumed (2)" $+ tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6+ it "returns how much the buffer is consumed (3)" $+ tryPackHeader 10 ["0123456789"] `shouldReturn` 0+ it "returns how much the buffer is consumed (4)" $+ tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0+ it "returns how much the buffer is consumed (5)" $+ tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3+ it "returns how much the buffer is consumed (6)" $+ tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5 - it "sends headers correctly (1)" $- tryPackHeader2 10 ["foo"] "" `shouldReturn` True- it "sends headers correctly (2)" $- tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True- it "sends headers correctly (3)" $- tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True- it "sends headers correctly (4)" $- tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True- it "sends headers correctly (5)" $- tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True- it "sends headers correctly (6)" $- tryPackHeader2 10 ["012345678901234567890123456789012", "34"] "012345678901234567890123456789" `shouldReturn` True+ it "sends headers correctly (1)" $+ tryPackHeader2 10 ["foo"] "" `shouldReturn` True+ it "sends headers correctly (2)" $+ tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True+ it "sends headers correctly (3)" $+ tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True+ it "sends headers correctly (4)" $+ tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True+ it "sends headers correctly (5)" $+ tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True+ it "sends headers correctly (6)" $+ tryPackHeader2+ 10+ ["012345678901234567890123456789012", "34"]+ "012345678901234567890123456789"+ `shouldReturn` True - describe "readSendFile" $ do- it "sends a file correctly (1)" $- tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess- it "sends a file correctly (2)" $- tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess- it "sends a file correctly (3)" $- tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess+ describe "readSendFile" $ do+ it "sends a file correctly (1)" $+ tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess+ it "sends a file correctly (2)" $+ tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess+ it "sends a file correctly (3)" $+ tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess tryPackHeader :: Int -> [ByteString] -> IO Int tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf ->@@ -95,20 +99,20 @@ checkFile :: FilePath -> ByteString -> IO Bool checkFile path bs = do exist <- doesFileExist path- if exist then do- bs' <- BS.readFile path- return $ bs == bs'- else- return $ bs == ""+ if exist+ then do+ bs' <- BS.readFile path+ return $ bs == bs'+ else return $ bs == "" compareFiles :: FilePath -> FilePath -> IO ExitCode compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2 copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO () copyfile src dst off len =- IO.withBinaryFile src IO.ReadMode $ \h -> do- IO.hSeek h IO.AbsoluteSeek off- BS.hGet h (fromIntegral len) >>= BS.appendFile dst+ IO.withBinaryFile src IO.ReadMode $ \h -> do+ IO.hSeek h IO.AbsoluteSeek off+ BS.hGet h (fromIntegral len) >>= BS.appendFile dst removeFileIfExists :: FilePath -> IO () removeFileIfExists file = do
+ test/ServerStateSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module ServerStateSpec where++import Network.Wai.Handler.Warp (getServerState)+import Network.Wai.Handler.Warp.Counter (getCount, increase)+import Network.Wai.Handler.Warp.Settings (+ ServerState (..),+ currentOpenConnections,+ currentShuttingDownState,+ defaultSettings,+ makeServerState,+ newServerState,+ )+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown)+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "ServerState" $ do+ it "has the correct initialization" $ do+ ss <- newServerState+ currentOpenConnections ss `shouldReturn` 0+ currentShuttingDownState ss `shouldReturn` False+ describe "makeServerState" $ do+ it "has the same state in settings" $ do+ (outerSS, set) <- makeServerState defaultSettings+ case getServerState set of+ Nothing -> expectationFailure "'makeServerState' should set the 'ServerState'"+ Just innerSS -> do+ let bothCount i = do+ a <- currentOpenConnections outerSS+ b <- currentOpenConnections innerSS+ (a, b) `shouldBe` (i, i)+ increase $ serverConnectionCounter outerSS+ bothCount 1+ increase $ serverConnectionCounter innerSS+ bothCount 2+ let bothDown bool = do+ a <- currentShuttingDownState outerSS+ b <- currentShuttingDownState innerSS+ (a, b) `shouldBe` (bool, bool)+ writeShuttingDown (serverShuttingDown outerSS) True+ bothDown True+ writeShuttingDown (serverShuttingDown innerSS) False+ bothDown False+ it "is idempotent" $ do+ let incAndCheck ss i = do+ increase $ serverConnectionCounter ss+ currentOpenConnections ss `shouldReturn` i+ (ss1, set1) <- makeServerState defaultSettings+ incAndCheck ss1 1+ (ss2, _set2) <- makeServerState set1+ incAndCheck ss2 2+ incAndCheck ss1 3
test/WithApplicationSpec.hs view
@@ -2,44 +2,45 @@ module WithApplicationSpec where -import Control.Exception-import Network.HTTP.Types-import Network.Wai-import System.Environment-import System.Process-import Test.Hspec+import Control.Exception+import Network.HTTP.Types+import Network.Wai+import System.Environment+import System.Process+import Test.Hspec -import Network.Wai.Handler.Warp.WithApplication+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 "withApplication" $ do- it "runs a wai Application while executing the given action" $ do- let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo"- withApplication mkApp $ \ port -> do- output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""- output `shouldBe` "foo"-- it "does not propagate exceptions from the server to the executing thread" $ do- let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"- withApplication mkApp $ \ port -> do- output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""- output `shouldContain` "Something went wron"+ 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" - describe "testWithApplication" $ do- it "propagates exceptions from the server to the executing thread" $ do- let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"- (testWithApplication mkApp $ \ port -> do- readProcess "curl" ["-s", "localhost:" ++ show port] "")- `shouldThrow` (errorCall "foo")+ it "does not propagate exceptions from the server to the executing thread" $ do+ let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"+ withApplication mkApp $ \port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldContain` "Something went wron" -{- The future netwrok library will not export MkSocket.- describe "withFreePort" $ do- it "closes the socket before exiting" $ do- MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do- return sock- readMVar statusMVar `shouldReturn` Closed--}+ describe "testWithApplication" $ do+ it "propagates exceptions from the server to the executing thread" $ do+ let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"+ testWithApplication+ mkApp+ ( \port -> do+ readProcess "curl" ["-s", "localhost:" ++ show port] ""+ )+ `shouldThrow` (errorCall "foo")
warp.cabal view
@@ -1,274 +1,356 @@-Name: warp-Version: 3.2.28-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- <http://www.stackage.org/package/warp>.-extra-source-files: attic/hex- ChangeLog.md- README.md- test/head-response- test/inputFile+cabal-version: >=1.10+name: warp+version: 3.4.14+license: MIT+license-file: LICENSE+maintainer: michael@snoyman.com+author: Michael Snoyman, Kazu Yamamoto, Matt Brown+stability: Stable+homepage: https://github.com/yesodweb/wai+synopsis: A fast, light-weight web server for WAI applications.+description:+ HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.+ For HTTP\/2, Warp supports direct and ALPN (in TLS)+ but not upgrade.+ API docs and the README are available at+ <https://www.stackage.org/package/warp>. -Flag network-bytestring- Default: False+category: Web, Yesod+build-type: Simple+extra-source-files:+ attic/hex+ ChangeLog.md+ README.md+ test/head-response+ test/inputFile -Flag allow-sendfilefd- Description: Allow use of sendfileFd (not available on GNU/kFreeBSD)- Default: True+source-repository head+ type: git+ location: https://github.com/yesodweb/wai.git+ subdir: warp -Flag warp-debug- Description: print debug output. not suitable for production- Default: False+flag network-bytestring+ default: False -Library- Build-Depends: base >= 4.8 && < 5- , array- , async- , 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.11- , http2 >= 1.6 && < 1.7- , iproute >= 1.3.1- , simple-sendfile >= 0.2.7 && < 0.3- , stm >= 2.3- , streaming-commons >= 0.1.10- , text- , time-manager- , unix-compat >= 0.2- , vault >= 0.3- , wai >= 3.2 && < 3.3- , word8- 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.HTTP2- Network.Wai.Handler.Warp.HTTP2.EncodeFrame- Network.Wai.Handler.Warp.HTTP2.File- Network.Wai.Handler.Warp.HTTP2.HPACK- Network.Wai.Handler.Warp.HTTP2.Manager- Network.Wai.Handler.Warp.HTTP2.Receiver- Network.Wai.Handler.Warp.HTTP2.Request- Network.Wai.Handler.Warp.HTTP2.Sender- Network.Wai.Handler.Warp.HTTP2.Types- Network.Wai.Handler.Warp.HTTP2.Worker- Network.Wai.Handler.Warp.Header- Network.Wai.Handler.Warp.IO- Network.Wai.Handler.Warp.Imports- Network.Wai.Handler.Warp.PackInt- Network.Wai.Handler.Warp.ReadInt- Network.Wai.Handler.Warp.Recv- Network.Wai.Handler.Warp.Request- Network.Wai.Handler.Warp.RequestHeader- Network.Wai.Handler.Warp.Response- Network.Wai.Handler.Warp.ResponseHeader- Network.Wai.Handler.Warp.Run- Network.Wai.Handler.Warp.SendFile- Network.Wai.Handler.Warp.Settings- Network.Wai.Handler.Warp.Types- Network.Wai.Handler.Warp.Windows- Network.Wai.Handler.Warp.WithApplication- Paths_warp- Ghc-Options: -Wall+flag allow-sendfilefd+ description: Allow use of sendfileFd (not available on GNU/kFreeBSD) - if flag(warp-debug)- Cpp-Options: -DWARP_DEBUG- if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)- Cpp-Options: -DSENDFILEFD- if os(windows)- Cpp-Options: -DWINDOWS- Build-Depends: time- else- Build-Depends: unix- Other-modules: Network.Wai.Handler.Warp.MultiMap- if impl(ghc >= 8)- Default-Extensions: Strict StrictData- Default-Language: Haskell2010+flag include-warp-version+ description:+ Exposes the version in Network.Wai.Handler.Warp.warpVersion.+ This adds a dependency on Paths_warp so application binaries may+ reference subpaths of GHC. For nix users this may result in binaries+ with a large transitive runtime dependency closure that includes GHC+ itself.+ default: True+ manual: True -Test-Suite doctest- Type: exitcode-stdio-1.0- HS-Source-Dirs: test- Ghc-Options: -threaded -Wall- Main-Is: doctests.hs- Build-Depends: base >= 4.8 && < 5- , doctest >= 0.10.1- if os(windows)- Buildable: False- if impl(ghc >= 8)- Default-Extensions: Strict StrictData- Default-Language: Haskell2010+flag warp-debug+ description: print debug output. not suitable for production+ default: False -Test-Suite spec- Main-Is: Spec.hs- Other-modules: BufferPoolSpec- ConduitSpec- ExceptionSpec- FdCacheSpec- FileSpec- 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.HTTP2- Network.Wai.Handler.Warp.HTTP2.EncodeFrame- Network.Wai.Handler.Warp.HTTP2.File- Network.Wai.Handler.Warp.HTTP2.HPACK- Network.Wai.Handler.Warp.HTTP2.Manager- Network.Wai.Handler.Warp.HTTP2.Receiver- Network.Wai.Handler.Warp.HTTP2.Request- Network.Wai.Handler.Warp.HTTP2.Sender- Network.Wai.Handler.Warp.HTTP2.Types- Network.Wai.Handler.Warp.HTTP2.Worker- Network.Wai.Handler.Warp.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.Recv- Network.Wai.Handler.Warp.Request- Network.Wai.Handler.Warp.RequestHeader- Network.Wai.Handler.Warp.Response- Network.Wai.Handler.Warp.ResponseHeader- Network.Wai.Handler.Warp.Run- Network.Wai.Handler.Warp.SendFile- Network.Wai.Handler.Warp.Settings- Network.Wai.Handler.Warp.Types- Network.Wai.Handler.Warp.Windows- Network.Wai.Handler.Warp.WithApplication- Paths_warp+flag x509+ description:+ Adds a dependency on the x509 library to enable getting TLS client certificates. - Hs-Source-Dirs: test, .- Type: exitcode-stdio-1.0+library+ exposed-modules:+ Network.Wai.Handler.Warp+ Network.Wai.Handler.Warp.Internal - Ghc-Options: -Wall -threaded- Build-Depends: base >= 4.8 && < 5- , HUnit- , QuickCheck- , array- , async- , 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.8.5- , http2 >= 1.6 && < 1.7- , iproute >= 1.3.1- , lifted-base >= 0.1- , network- , process- , simple-sendfile >= 0.2.4 && < 0.3- , stm >= 2.3- , streaming-commons >= 0.1.10- , text- , time- , time-manager- , transformers >= 0.2.2- , unix-compat >= 0.2- , vault- , wai >= 3.2 && < 3.3- , word8- -- Build-Tool-Depends: hspec-discover:hspec-discover- if impl(ghc < 8)- Build-Depends: semigroups+ other-modules:+ Network.Wai.Handler.Warp.Buffer+ Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Counter+ Network.Wai.Handler.Warp.Date+ Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File+ Network.Wai.Handler.Warp.FileInfoCache+ Network.Wai.Handler.Warp.HTTP1+ Network.Wai.Handler.Warp.HTTP2+ Network.Wai.Handler.Warp.HTTP2.File+ Network.Wai.Handler.Warp.HTTP2.PushPromise+ Network.Wai.Handler.Warp.HTTP2.Request+ Network.Wai.Handler.Warp.HTTP2.Response+ Network.Wai.Handler.Warp.HTTP2.Types+ Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IO+ Network.Wai.Handler.Warp.Imports+ Network.Wai.Handler.Warp.PackInt+ Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Response+ Network.Wai.Handler.Warp.ResponseHeader+ Network.Wai.Handler.Warp.Run+ Network.Wai.Handler.Warp.SendFile+ Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown+ Network.Wai.Handler.Warp.Types+ Network.Wai.Handler.Warp.Windows+ Network.Wai.Handler.Warp.WithApplication - if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)- Cpp-Options: -DSENDFILEFD- Build-Depends: unix- if os(windows)- Cpp-Options: -DWINDOWS- Build-Depends: time- if impl(ghc >= 8)- Default-Extensions: Strict StrictData- Default-Language: Haskell2010+ if flag(include-warp-version)+ other-modules: Paths_warp -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- , time-manager- , unix-compat- if impl(ghc < 8)- Build-Depends: semigroups+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.12 && <5,+ array,+ auto-update >=0.2.2 && <0.3,+ async >= 2,+ bsb-http-chunked <0.1,+ bytestring >=0.9.1.4,+ case-insensitive >=0.2,+ containers,+ hashable,+ http-date,+ http-types >=0.12,+ http2 >=5.4 && <5.5,+ iproute >=1.3.1,+ recv >=0.1.0 && <0.2.0,+ simple-sendfile >=0.2.7 && <0.3,+ stm >=2.3,+ streaming-commons >=0.1.10,+ text,+ time-manager >=0.2 && <0.4,+ vault >=0.3,+ wai >=3.2.4 && <3.3,+ word8 - if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)- Cpp-Options: -DSENDFILEFD- Build-Depends: unix- if os(windows)- Cpp-Options: -DWINDOWS- Build-Depends: time- if impl(ghc >= 8)- Default-Extensions: Strict StrictData- Default-Language: Haskell2010+ if flag(x509)+ build-depends: crypton-x509 -Source-Repository head- Type: git- Location: git://github.com/yesodweb/wai.git+ if impl(ghc <8)+ build-depends: semigroups++ if flag(network-bytestring)+ build-depends:+ network >=2.2.1.5 && <2.2.3,+ network-bytestring >=0.1.3 && <0.1.4++ else+ build-depends: network >=2.3++ if flag(warp-debug)+ cpp-options: -DWARP_DEBUG++ if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd))+ cpp-options: -DSENDFILEFD++ if os(windows)+ cpp-options: -DWINDOWS+ build-depends:+ time,+ unix-compat >=0.2++ else+ other-modules: Network.Wai.Handler.Warp.MultiMap+ build-depends: unix++ if impl(ghc >=8)+ default-extensions: Strict StrictData++ if flag(include-warp-version)+ cpp-options: -DINCLUDE_WARP_VERSION++test-suite doctest+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ buildable: False+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -threaded -Wall+ build-depends:+ base >=4.8 && <5,+ doctest >=0.10.1++ if os(windows)+ buildable: False++ if impl(ghc >=8)+ default-extensions: Strict StrictData++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test .+ other-modules:+ ConduitSpec+ ConnectionSpec+ ExceptionSpec+ FdCacheSpec+ FileSpec+ GracefulShutdownSpec+ HTTP+ PackIntSpec+ ReadIntSpec+ RequestSpec+ ResponseHeaderSpec+ ResponseSpec+ RunSpec+ SendFileSpec+ ServerStateSpec+ WithApplicationSpec+ Network.Wai.Handler.Warp+ Network.Wai.Handler.Warp.Internal+ Network.Wai.Handler.Warp.Buffer+ Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Counter+ Network.Wai.Handler.Warp.Date+ Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File+ Network.Wai.Handler.Warp.FileInfoCache+ Network.Wai.Handler.Warp.HTTP1+ Network.Wai.Handler.Warp.HTTP2+ Network.Wai.Handler.Warp.HTTP2.File+ Network.Wai.Handler.Warp.HTTP2.PushPromise+ Network.Wai.Handler.Warp.HTTP2.Request+ Network.Wai.Handler.Warp.HTTP2.Response+ Network.Wai.Handler.Warp.HTTP2.Types+ Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IO+ Network.Wai.Handler.Warp.Imports+ Network.Wai.Handler.Warp.PackInt+ Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Response+ Network.Wai.Handler.Warp.ResponseHeader+ Network.Wai.Handler.Warp.Run+ Network.Wai.Handler.Warp.SendFile+ Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown+ Network.Wai.Handler.Warp.Types+ Network.Wai.Handler.Warp.Windows+ Network.Wai.Handler.Warp.WithApplication++ if flag(include-warp-version)+ other-modules: Paths_warp++ default-language: Haskell2010+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.8 && <5,+ QuickCheck,+ array,+ auto-update,+ async,+ bsb-http-chunked <0.1,+ bytestring >=0.9.1.4,+ case-insensitive >=0.2,+ containers,+ directory,+ hashable,+ hspec >=1.3,+ http-client,+ http-date,+ http-types >=0.12,+ http2 >=5.4 && <5.5,+ iproute >=1.3.1,+ network,+ process,+ recv >=0.1.0 && <0.2.0,+ simple-sendfile >=0.2.4 && <0.3,+ stm >=2.3,+ streaming-commons >=0.1.10,+ text,+ time-manager,+ vault,+ wai >=3.2.2.1 && <3.3,+ -- workaround: this should be unnecessary+ warp,+ word8++ if flag(x509)+ build-depends: crypton-x509++ if impl(ghc <8)+ build-depends:+ semigroups,+ transformers++ if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd))+ cpp-options: -DSENDFILEFD++ if os(windows)+ cpp-options: -DWINDOWS+ build-depends:+ time,+ unix-compat >=0.2++ else+ other-modules: Network.Wai.Handler.Warp.MultiMap+ build-depends: unix++ if impl(ghc >=8)+ default-extensions: Strict StrictData++benchmark parser+ type: exitcode-stdio-1.0+ main-is: Parser.hs+ hs-source-dirs: bench .+ other-modules:+ Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Counter+ Network.Wai.Handler.Warp.Date+ Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.FileInfoCache+ Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.Imports+ Network.Wai.Handler.Warp.MultiMap+ Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.Types++ if flag(include-warp-version)+ other-modules: Paths_warp++ default-language: Haskell2010+ build-depends:+ base >=4.8 && <5,+ array,+ auto-update,+ bytestring,+ case-insensitive,+ containers,+ criterion,+ hashable,+ http-date,+ http-types,+ network,+ network,+ recv,+ stm,+ streaming-commons,+ text,+ time-manager,+ vault,+ wai,+ word8++ if flag(x509)+ build-depends: crypton-x509++ if impl(ghc <8)+ build-depends: semigroups++ if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd))+ cpp-options: -DSENDFILEFD+ build-depends: unix++ if os(windows)+ cpp-options: -DWINDOWS+ build-depends:+ time,+ unix-compat >=0.2++ if impl(ghc >=8)+ default-extensions: Strict StrictData