warp-3.1.12/0000755000000000000000000000000012636712547010752 5ustar0000000000000000warp-3.1.12/ChangeLog.md0000644000000000000000000001324312636712547013126 0ustar0000000000000000## 3.1.12 * Setting lower bound for auto-update [#495](https://github.com/yesodweb/wai/issues/495) ## 3.1.11 * Providing a new API: killManager. * Preventing space leaks due to Weak ThreadId [#488](https://github.com/yesodweb/wai/issues/488) * Setting upper bound for http2. ## 3.1.10 * `setFileInfoCacheDuration` * `setLogger` * `FileInfo`/`getFileInfo` * Fix: warp-tls strips out the Host request header [#478](https://github.com/yesodweb/wai/issues/478) ## 3.1.9 * Using the new priority queue based on PSQ provided by http2 lib again. ## 3.1.8 * Using the new priority queue based on PSQ provided by http2 lib. ## 3.1.7 * A concatenated Cookie header is prepended to the headers to ensure that it flows pseudo headers. [#454](https://github.com/yesodweb/wai/pull/454) * Providing a new settings: `setHTTP2Disabled` [#450](https://github.com/yesodweb/wai/pull/450) ## 3.1.6 * Adding back http-types 0.8 support [#449](https://github.com/yesodweb/wai/pull/449) ## 3.1.5 * Using http-types v0.9. * Fixing build on OpenBSD. [#428](https://github.com/yesodweb/wai/pull/428) [#440](https://github.com/yesodweb/wai/pull/440) * Fixing build on Windows. [#438](https://github.com/yesodweb/wai/pull/438) ## 3.1.4 * Using newer http2 library to prevent change table size attacks. * API for HTTP/2 server push and trailers. [#426](https://github.com/yesodweb/wai/pull/426) * Preventing response splitting attacks. [#435](https://github.com/yesodweb/wai/pull/435) * Concatenating multiple Cookie: headers in HTTP/2. ## 3.1.3 * Warp now supports blaze-builder v0.4 or later only. * HTTP/2 code was improved: dynamic priority change, efficient queuing and sender loop continuation. [#423](https://github.com/yesodweb/wai/pull/423) [#424](https://github.com/yesodweb/wai/pull/424) ## 3.1.2 * Configurable Slowloris size [#418](https://github.com/yesodweb/wai/pull/418) ## 3.1.1 * Fixing a bug of HTTP/2 when no FD cache is used [#411](https://github.com/yesodweb/wai/pull/411) * Fixing a buffer-pool bug [#406](https://github.com/yesodweb/wai/pull/406) [#407](https://github.com/yesodweb/wai/pull/407) ## 3.1.0 * Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399) * Cleaning up APIs [#387](https://github.com/yesodweb/wai/issues/387) ## 3.0.13.1 * Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375) ## 3.0.13 * Turn off file descriptor cache by default [#371](https://github.com/yesodweb/wai/issues/371) ## 3.0.12.1 * Fix for: HEAD requests returning non-empty entity body [#369](https://github.com/yesodweb/wai/issues/369) ## 3.0.12 * Only conditionally produce HTTP 100 Continue ## 3.0.11 * Better HEAD support for files [#357](https://github.com/yesodweb/wai/pull/357) ## 3.0.10 * Fix [missing `IORef` tweak](https://github.com/yesodweb/wai/issues/351) * Disable timeouts as soon as request body is fully consumed. This addresses the common case of a non-chunked request body. Previously, we would wait until a zero-length `ByteString` is returned, but that is suboptimal for some cases. For more information, see [issue 351](https://github.com/yesodweb/wai/issues/351). * Add `pauseTimeout` function ## 3.0.9.3 * Don't serve a 416 status code for 0-length files [keter issue #75](https://github.com/snoyberg/keter/issues/75) * Don't serve content-length for 416 responses [#346](https://github.com/yesodweb/wai/issues/346) ## 3.0.9.2 Fix support for old versions of bytestring ## 3.0.9.1 Add support for blaze-builder 0.4 ## 3.0.9 * Add runEnv: like run but uses $PORT [#334](https://github.com/yesodweb/wai/pull/334) ## 3.0.5.2 * [Pass the Request to settingsOnException handlers when available. #326](https://github.com/yesodweb/wai/pull/326) ## 3.0.5 Support for PROXY protocol, such as used by Amazon ELB TCP. This is useful since, for example, Amazon ELB HTTP does *not* have support for Websockets. More information on the protocol [is available from Amazon](http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol). ## 3.0.4 Added `setFork`. ## 3.0.3 Modify flushing of request bodies. Previously, regardless of the size of the request body, the entire body would be flushed. When uploading large files to a web app that does not accept such files (e.g., returns a 413 too large status), browsers would still send the entire request body and the servers will still receive it. The new behavior is to detect if there is a large amount of data still to be consumed and, if so, immediately terminate the connection. In the case of chunked request bodies, up to a maximum number of bytes is consumed before the connection is terminated. This is controlled by the new setting `setMaximumBodyFlush`. A value of @Nothing@ will return the original behavior of flushing the entire body. ## 3.0.0 WAI no longer uses conduit for its streaming interface. ## 2.1.0 The `onOpen` and `onClose` settings now provide the `SockAddr` of the client, and `onOpen` can return a `Bool` which will close the connection. The `responseRaw` response has been added, which provides a more elegant way to handle WebSockets than the previous `settingsIntercept`. The old settings accessors have been deprecated in favor of new setters, which will allow settings changes to be made in the future without breaking backwards compatibility. ## 2.0.0 ResourceT is not used anymore. Request and Response is now abstract data types. To use their constructors, Internal module should be imported. ## 1.3.9 Support for byte range requests. ## 1.3.7 Sockets now have `FD_CLOEXEC` set on them. This behavior is more secure, and the change should not affect the vast majority of use cases. However, it appeared that this is buggy and is fixed in 2.0.0. warp-3.1.12/LICENSE0000644000000000000000000000207512636712547011763 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. warp-3.1.12/README.md0000644000000000000000000000026712636712547012236 0ustar0000000000000000# Warp Warp is a server library for HTTP/1.x and HTTP/2 based WAI(Web Application Interface in Haskell). For more information, see [Warp](http://www.aosabook.org/en/posa/warp.html). warp-3.1.12/Setup.lhs0000644000000000000000000000016212636712547012561 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain warp-3.1.12/warp.cabal0000644000000000000000000001650212636712547012713 0ustar0000000000000000Name: warp Version: 3.1.12 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE Author: Michael Snoyman, Kazu Yamamoto, Matt Brown Maintainer: michael@snoyman.com Homepage: http://github.com/yesodweb/wai Category: Web, Yesod Build-Type: Simple Cabal-Version: >=1.8 Stability: Stable description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2, Warp supports direct and ALPN (in TLS) but not upgrade. API docs and the README are available at . extra-source-files: attic/hex ChangeLog.md README.md test/head-response Flag network-bytestring Default: False Flag allow-sendfilefd Description: Allow use of sendfileFd (not available on GNU/kFreeBSD) Default: True Flag warp-debug Description: print debug output. not suitable for production Default: False Library Build-Depends: base >= 3 && < 5 , array , auto-update >= 0.1.3 && < 0.2 , blaze-builder >= 0.4 , bytestring >= 0.9.1.4 , bytestring-builder , case-insensitive >= 0.2 , containers , ghc-prim , http-types >= 0.8.5 , iproute >= 1.3.1 , http2 >= 1.3 && < 1.4 , simple-sendfile >= 0.2.7 && < 0.3 , unix-compat >= 0.2 , wai >= 3.0.4 && < 3.1 , text , streaming-commons >= 0.1.10 , vault >= 0.3 , stm >= 2.3 , word8 , hashable , unordered-containers , http-date if flag(network-bytestring) Build-Depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 else Build-Depends: network >= 2.3 Exposed-modules: Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Internal Other-modules: Network.Wai.Handler.Warp.Buffer Network.Wai.Handler.Warp.Conduit Network.Wai.Handler.Warp.Counter Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache Network.Wai.Handler.Warp.File Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HTTP2 Network.Wai.Handler.Warp.HTTP2.EncodeFrame Network.Wai.Handler.Warp.HTTP2.HPACK Network.Wai.Handler.Warp.HTTP2.Manager Network.Wai.Handler.Warp.HTTP2.Receiver Network.Wai.Handler.Warp.HTTP2.Request Network.Wai.Handler.Warp.HTTP2.Sender Network.Wai.Handler.Warp.HTTP2.Types Network.Wai.Handler.Warp.HTTP2.Worker Network.Wai.Handler.Warp.Header Network.Wai.Handler.Warp.IO Network.Wai.Handler.Warp.IORef Network.Wai.Handler.Warp.ReadInt Network.Wai.Handler.Warp.Recv Network.Wai.Handler.Warp.Request Network.Wai.Handler.Warp.RequestHeader Network.Wai.Handler.Warp.Response Network.Wai.Handler.Warp.ResponseHeader Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings Network.Wai.Handler.Warp.Timeout Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Paths_warp Ghc-Options: -Wall 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 Test-Suite doctest Type: exitcode-stdio-1.0 HS-Source-Dirs: test Ghc-Options: -threaded -Wall Main-Is: doctests.hs Build-Depends: base , doctest >= 0.10.1 Test-Suite spec Main-Is: Spec.hs Other-modules: BufferPoolSpec ConduitSpec ExceptionSpec FdCacheSpec FileSpec MultiMapSpec ReadIntSpec RequestSpec ResponseHeaderSpec ResponseSpec RunSpec SendFileSpec HTTP Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 Ghc-Options: -Wall Build-Depends: base >= 4 && < 5 , array , auto-update , blaze-builder >= 0.4 , bytestring >= 0.9.1.4 , bytestring-builder , case-insensitive >= 0.2 , ghc-prim , HTTP , http-types >= 0.8.5 , iproute >= 1.3.1 , lifted-base >= 0.1 , simple-sendfile >= 0.2.4 && < 0.3 , transformers >= 0.2.2 , unix-compat >= 0.2 , wai >= 3.0.4 && < 3.1 , network , HUnit , QuickCheck , hspec >= 1.3 , time , text , streaming-commons >= 0.1.10 , async , vault , stm >= 2.3 , directory , process , containers , http2 >= 1.3 , word8 , hashable , unordered-containers , http-date if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD Build-Depends: unix if os(windows) Cpp-Options: -DWINDOWS Benchmark parser Type: exitcode-stdio-1.0 Main-Is: Parser.hs HS-Source-Dirs: bench . Build-Depends: base , bytestring , criterion , http-types , network , network Source-Repository head Type: git Location: git://github.com/yesodweb/wai.git warp-3.1.12/attic/0000755000000000000000000000000012636712547012056 5ustar0000000000000000warp-3.1.12/attic/hex0000644000000000000000000000002012636712547012555 0ustar00000000000000000123456789abcdefwarp-3.1.12/bench/0000755000000000000000000000000012636712547012031 5ustar0000000000000000warp-3.1.12/bench/Parser.hs0000644000000000000000000001703612636712547013630 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Main where import Control.Exception (throwIO, throw) 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 Data.ByteString.Internal import Data.Word import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable import Criterion.Main -- $setup -- >>> :set -XOverloadedStrings ---------------------------------------------------------------- main :: IO () main = do let requestLine1 = "GET http://www.example.com HTTP/1.1" let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0" defaultMain [ bgroup "requestLine1" [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1 , bench "parseRequestLine2" $ parseRequestLine2 requestLine1 , bench "parseRequestLine1" $ parseRequestLine1 requestLine1 , bench "parseRequestLine0" $ parseRequestLine0 requestLine1 ] , bgroup "requestLine2" [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2 , bench "parseRequestLine2" $ parseRequestLine2 requestLine2 , bench "parseRequestLine1" $ parseRequestLine1 requestLine2 , bench "parseRequestLine0" $ parseRequestLine0 requestLine2 ] ] ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine3 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine3 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine3 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine3 :: ByteString -> (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine3 requestLine = ret where (!method,!rest) = S.breakByte 32 requestLine -- ' ' (!pathQuery,!httpVer') | rest == "" = throw badmsg | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' ' (!path,!query) = S.breakByte 63 pathQuery -- '?' !httpVer = S.drop 1 httpVer' (!http,!ver) | httpVer == "" = throw badmsg | otherwise = S.breakByte 47 httpVer -- '/' !hv | http /= "HTTP" = throw NonHttp | ver == "/1.1" = H.http11 | otherwise = H.http10 !ret = (method,path,query,hv) badmsg = BadFirstLine $ B.unpack requestLine ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine2 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine2 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine2 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine2 :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len pathptr0 <- memchr methodptr 32 lim0 -- ' ' when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ throwIO baderr let pathptr = pathptr0 `plusPtr` 1 lim1 = fromIntegral (limptr `minusPtr` pathptr0) httpptr0 <- memchr pathptr 32 lim1 -- ' ' when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1 lim2 = fromIntegral (httpptr0 `minusPtr` pathptr) checkHTTP httpptr !hv <- httpVersion httpptr queryptr <- memchr pathptr 63 lim2 -- '?' let !method = bs ptr methodptr pathptr0 !path | queryptr == nullPtr = bs ptr pathptr httpptr0 | otherwise = bs ptr pathptr queryptr !query | queryptr == nullPtr = S.empty | otherwise = bs ptr queryptr httpptr0 return (method,path,query,hv) where baderr = BadFirstLine $ B.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO () check p n w = do w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do check httpptr 0 72 -- 'H' check httpptr 1 84 -- 'T' check httpptr 2 84 -- 'T' check httpptr 3 80 -- 'P' check httpptr 4 47 -- '/' check httpptr 6 46 -- '.' httpVersion httpptr = do major <- peek $ httpptr `plusPtr` 5 minor <- peek $ httpptr `plusPtr` 7 if major == (49 :: Word8) && minor == (49 :: Word8) then return H.http11 else return H.http10 bs ptr p0 p1 = PS fptr o l where o = p0 `minusPtr` ptr l = p1 `minusPtr` p0 ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine1 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine1 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine1 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine1 :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine1 requestLine = do let (!method,!rest) = S.breakByte 32 requestLine -- ' ' (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' ' !httpVer = S.drop 1 httpVer' when (rest == "" || httpVer == "") $ throwIO $ BadFirstLine $ B.unpack requestLine let (!path,!query) = S.breakByte 63 pathQuery -- '?' (!http,!ver) = S.breakByte 47 httpVer -- '/' when (http /= "HTTP") $ throwIO NonHttp let !hv | ver == "/1.1" = H.http11 | otherwise = H.http10 return $! (method,path,query,hv) ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine0 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine0 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine0 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine0 :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine0 s = case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- ' (method':query:http'') -> do let !method = method' !http' = S.concat http'' (!hfirst, !hsecond) = S.splitAt 5 http' if hfirst == "HTTP/" then let (!rpath, !qstring) = S.breakByte 63 query -- '?' !hv = case hsecond of "1.1" -> H.http11 _ -> H.http10 in return $! (method, rpath, qstring, hv) else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s warp-3.1.12/Network/0000755000000000000000000000000012636712547012403 5ustar0000000000000000warp-3.1.12/Network/Wai/0000755000000000000000000000000012636712547013123 5ustar0000000000000000warp-3.1.12/Network/Wai/Handler/0000755000000000000000000000000012636712547014500 5ustar0000000000000000warp-3.1.12/Network/Wai/Handler/Warp.hs0000644000000000000000000003317712636712547015760 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} --------------------------------------------------------- -- -- Module : Network.Wai.Handler.Warp -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Stable -- Portability : portable -- -- A fast, light-weight HTTP server handler for WAI. -- --------------------------------------------------------- -- | A fast, light-weight HTTP server handler for WAI. -- -- HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2, -- Warp supports direct and ALPN (in TLS) but not upgrade. -- -- Note on slowloris timeouts: to prevent slowloris attacks, timeouts are used -- at various points in request receiving and response sending. One interesting -- corner case is partial request body consumption; in that case, Warp's -- timeout handling is still in effect, and the timeout will not be triggered -- again. Therefore, it is recommended that once you start consuming the -- request body, you either: -- -- * consume the entire body promptly -- -- * call the 'pauseTimeout' function -- -- For more information, see . -- -- module Network.Wai.Handler.Warp ( -- * Run a Warp server -- | All of these automatically serve the same 'Application' over HTTP\/1, -- HTTP\/1.1, and HTTP\/2. run , runEnv , runSettings , runSettingsSocket -- * Run an HTTP\/2-aware server -- | Each of these takes an HTTP\/2-aware application as well as a backup -- 'Application' to be used for HTTP\/1.1 and HTTP\/1 connections. These -- are only needed if your application needs access to HTTP\/2-specific -- features such as trailers or pushed streams. , runHTTP2 , runHTTP2Env , runHTTP2Settings , runHTTP2SettingsSocket -- * Settings , 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 -- ** Getters , getPort , getHost , getOnOpen , getOnClose , getOnException -- ** Exception handler , defaultOnException , defaultShouldDisplayException -- ** Exception response handler , defaultOnExceptionResponse , exceptionResponseForDebug -- * Data types , HostPreference (..) , Port , InvalidRequest (..) -- * Utilities , pauseTimeout , FileInfo(..) , getFileInfo -- * Internal -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal. -- ** Low level run functions , runSettingsConnection , runSettingsConnectionMaker , runSettingsConnectionMakerSecure , Transport (..) -- ** Connection , Connection (..) , socketConnection -- ** Buffer , Buffer , BufSize , bufferSize , allocateBuffer , freeBuffer -- ** Sendfile , FileId (..) , SendFile , sendFile , readSendFile -- ** Version , warpVersion -- ** Data types , InternalInfo (..) , HeaderValue , IndexedHeader , requestMaxIndex -- ** File descriptor cache , module Network.Wai.Handler.Warp.FdCache -- ** Date , module Network.Wai.Handler.Warp.Date -- ** Request and response , Source , recvRequest , sendResponse -- ** Time out manager , module Network.Wai.Handler.Warp.Timeout ) where import Control.Exception (SomeException, throwIO) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Data.Streaming.Network (HostPreference) import qualified Data.Vault.Lazy as Vault import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai (Request, Response, vault) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types -- | Port to listen on. Default value: 3000 -- -- Since 2.1.0 setPort :: Port -> Settings -> Settings setPort x y = y { settingsPort = x } -- | Interface to bind to. Default value: HostIPv4 -- -- Since 2.1.0 setHost :: HostPreference -> Settings -> Settings setHost x y = y { settingsHost = x } -- | What to do with exceptions thrown by either the application or server. -- Default: 'defaultOnException' -- -- Since 2.1.0 setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings setOnException x y = y { settingsOnException = x } -- | A function to create a `Response` when an exception occurs. -- -- Default: 'defaultOnExceptionResponse' -- -- Since 2.1.0 setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings setOnExceptionResponse x y = y { settingsOnExceptionResponse = x } -- | What to do when a connection is opened. When 'False' is returned, the -- connection is closed immediately. Otherwise, the connection is going on. -- Default: always returns 'True'. -- -- Since 2.1.0 setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings setOnOpen x y = y { settingsOnOpen = x } -- | What to do when a connection is closed. Default: do nothing. -- -- Since 2.1.0 setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings setOnClose x y = y { settingsOnClose = x } -- | Timeout value in seconds. Default value: 30 -- -- Since 2.1.0 setTimeout :: Int -> Settings -> Settings setTimeout x y = y { settingsTimeout = x } -- | Use an existing timeout manager instead of spawning a new one. If used, -- 'settingsTimeout' is ignored. -- -- Since 2.1.0 setManager :: Manager -> Settings -> Settings setManager x y = y { settingsManager = Just x } -- | Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. -- -- The FD cache is an optimization that is useful for servers dealing with -- static files. However, if files are being modified, it can cause incorrect -- results in some cases. Therefore, we disable it by default. If you know that -- your files will be static or you prefer performance to file consistency, -- it's recommended to turn this on; a reasonable value for those cases is 10. -- Enabling this cache results in drastic performance improvement for file -- transfers. -- -- Default value: 0, was previously 10 -- -- Since 3.0.13 setFdCacheDuration :: Int -> Settings -> Settings setFdCacheDuration x y = y { settingsFdCacheDuration = x } -- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. -- -- The file information cache is an optimization that is useful for servers dealing with -- static files. However, if files are being modified, it can cause incorrect -- results in some cases. Therefore, we disable it by default. If you know that -- your files will be static or you prefer performance to file consistency, -- it's recommended to turn this on; a reasonable value for those cases is 10. -- Enabling this cache results in drastic performance improvement for file -- transfers. -- -- Default value: 0 setFileInfoCacheDuration :: Int -> Settings -> Settings setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x } -- | Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start -- running, or to drop permissions after binding to a restricted port. -- -- Default: do nothing. -- -- Since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings setBeforeMainLoop x y = y { settingsBeforeMainLoop = x } -- | Perform no parsing on the rawPathInfo. -- -- This is useful for writing HTTP proxies. -- -- Default: False -- -- Since 2.1.0 setNoParsePath :: Bool -> Settings -> Settings setNoParsePath x y = y { settingsNoParsePath = x } -- | Get the listening port. -- -- Since 2.1.1 getPort :: Settings -> Port getPort = settingsPort -- | Get the interface to bind to. -- -- Since 2.1.1 getHost :: Settings -> HostPreference getHost = settingsHost -- | Get the action on opening connection. getOnOpen :: Settings -> SockAddr -> IO Bool getOnOpen = settingsOnOpen -- | Get the action on closeing connection. getOnClose :: Settings -> SockAddr -> IO () getOnClose = settingsOnClose -- | Get the exception handler. getOnException :: Settings -> Maybe Request -> SomeException -> IO () getOnException = settingsOnException -- | A code to install shutdown handler. -- -- For instance, this code should set up a UNIX signal -- handler. The handler should call the first argument, -- which close the listen socket, at shutdown. -- -- Default: does not install any code. -- -- Since 3.0.1 setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings setInstallShutdownHandler x y = y { settingsInstallShutdownHandler = x } -- | Default server name if application does not set one. -- -- Since 3.0.2 setServerName :: ByteString -> Settings -> Settings setServerName x y = y { settingsServerName = x } -- | The maximum number of bytes to flush from an unconsumed request body. -- -- By default, Warp does not flush the request body so that, if a large body is -- present, the connection is simply terminated instead of wasting time and -- bandwidth on transmitting it. However, some clients do not deal with that -- situation well. You can either change this setting to @Nothing@ to flush the -- entire body in all cases, or in your application ensure that you always -- consume the entire request body. -- -- Default: 8192 bytes. -- -- Since 3.0.3 setMaximumBodyFlush :: Maybe Int -> Settings -> Settings setMaximumBodyFlush x y | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive" | otherwise = y { settingsMaximumBodyFlush = x } -- | Code to fork a new thread to accept a connection. -- -- This may be useful if you need OS bound threads, or if -- you wish to develop an alternative threading model. -- -- Default: void . forkIOWithUnmask -- -- Since 3.0.4 setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings setFork fork' s = s { settingsFork = fork' } -- | Do not use the PROXY protocol. -- -- Since 3.0.5 setProxyProtocolNone :: Settings -> Settings setProxyProtocolNone y = y { settingsProxyProtocol = ProxyProtocolNone } -- | Require PROXY header. -- -- This is for cases where a "dumb" TCP/SSL proxy is being used, which cannot -- add an @X-Forwarded-For@ HTTP header field but has enabled support for the -- PROXY protocol. -- -- See and -- . -- -- Only the human-readable header format (version 1) is supported. The binary -- header format (version 2) is /not/ supported. -- -- Since 3.0.5 setProxyProtocolRequired :: Settings -> Settings setProxyProtocolRequired y = y { settingsProxyProtocol = ProxyProtocolRequired } -- | Use the PROXY header if it exists, but also accept -- connections without the header. See 'setProxyProtocolRequired'. -- -- WARNING: This is contrary to the PROXY protocol specification and -- using it can indicate a security problem with your -- architecture if the web server is directly accessable -- to the public, since it would allow easy IP address -- spoofing. However, it can be useful in some cases, -- such as if a load balancer health check uses regular -- HTTP without the PROXY header, but proxied -- connections /do/ include the PROXY header. -- -- Since 3.0.5 setProxyProtocolOptional :: Settings -> Settings setProxyProtocolOptional y = y { settingsProxyProtocol = ProxyProtocolOptional } -- | Size in bytes read to prevent Slowloris protection. Default value: 2048 -- -- Since 3.1.2 setSlowlorisSize :: Int -> Settings -> Settings setSlowlorisSize x y = y { settingsSlowlorisSize = x } -- | Disable HTTP2. -- -- Since 3.1.7 setHTTP2Disabled :: Settings -> Settings setHTTP2Disabled y = y { settingsHTTP2Enabled = False } -- | Setting a log function. -- -- Since 3.X.X setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -> Settings -> Settings setLogger lgr y = y { settingsLogger = lgr } -- | Explicitly pause the slowloris timeout. -- -- This is useful for cases where you partially consume a request body. For -- more information, see -- -- Since 3.0.10 pauseTimeout :: Request -> IO () pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault -- | Getting file information of the target file. -- -- This function first uses a stat(2) or similar system call -- to obtain information of the target file, then registers -- it into the internal cache. -- From the next time, the information is obtained -- from the cache. This reduces the overhead to call the system call. -- The internal cache is refreshed every duration specified by -- 'setFileInfoCacheDuration'. -- -- This function throws an 'IO' exception if the information is not -- available. For instance, the target file does not exist. -- If this function is used an a Request generated by a WAI -- backend besides Warp, it also throws an 'IO' exception. -- -- Since 3.1.10 getFileInfo :: Request -> FilePath -> IO FileInfo getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault warp-3.1.12/Network/Wai/Handler/Warp/0000755000000000000000000000000012636712547015411 5ustar0000000000000000warp-3.1.12/Network/Wai/Handler/Warp/Buffer.hs0000644000000000000000000000623412636712547017163 0ustar0000000000000000{-# LANGUAGE BangPatterns, OverloadedStrings #-} module Network.Wai.Handler.Warp.Buffer ( bufferSize , allocateBuffer , freeBuffer , mallocBS , newBufferPool , withBufferPool , toBuilderBuffer , copy , bufferIO ) where import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..), memcpy) import Data.ByteString.Unsafe (unsafeTake, unsafeDrop) import Data.IORef (newIORef, readIORef, writeIORef) import 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 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 -- | Allocating a buffer with malloc(). allocateBuffer :: Int -> IO Buffer allocateBuffer = mallocBytes -- | Releasing a buffer with free(). freeBuffer :: Buffer -> IO () 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 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 fptr <- newForeignPtr_ ptr io $ PS fptr 0 siz warp-3.1.12/Network/Wai/Handler/Warp/Conduit.hs0000644000000000000000000001322712636712547017357 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Conduit where import Control.Exception import Control.Monad (when, unless) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.IORef as I #if __GLASGOW_HASKELL__ < 709 import Data.Word (Word) #endif import Data.Word (Word8) import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -- | Contains a @Source@ and a byte count that is still to be read in. data ISource = ISource !Source !(I.IORef Int) mkISource :: Source -> Int -> IO ISource mkISource src cnt = do ref <- I.newIORef cnt return $! ISource src ref -- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the -- specified number of bytes to be passed downstream. All leftovers should be -- retained within the @Source@. If there are not enough bytes available, -- throws a @ConnectionClosedByPeer@ exception. readISource :: ISource -> IO ByteString readISource (ISource src ref) = do count <- I.readIORef ref if count == 0 then return S.empty else do bs <- readSource src -- If no chunk available, then there aren't enough bytes in the -- stream. Throw a ConnectionClosedByPeer when (S.null bs) $ throwIO ConnectionClosedByPeer let -- How many of the bytes in this chunk to send downstream toSend = min count (S.length bs) -- How many bytes will still remain to be sent downstream count' = count - toSend case () of () -- The expected count is greater than the size of the -- chunk we just read. Send the entire chunk -- downstream, and then loop on this function for the -- next chunk. | count' > 0 -> do I.writeIORef ref count' return bs -- Some of the bytes in this chunk should not be sent -- downstream. Split up the chunk into the sent and -- not-sent parts, add the not-sent parts onto the new -- source, and send the rest of the chunk downstream. | otherwise -> do let (x, y) = S.splitAt toSend bs leftoverSource src y assert (count' == 0) $ I.writeIORef ref count' return x ---------------------------------------------------------------- data CSource = CSource !Source !(I.IORef ChunkState) data ChunkState = NeedLen | NeedLenNewline | HaveLen Word | DoneChunking deriving Show mkCSource :: Source -> IO CSource mkCSource src = do ref <- I.newIORef NeedLen return $! CSource src ref readCSource :: CSource -> IO ByteString readCSource (CSource src ref) = do mlen <- I.readIORef ref go mlen where withLen 0 bs = do leftoverSource src bs dropCRLF yield' S.empty DoneChunking withLen len bs | S.null bs = do -- FIXME should this throw an exception if len > 0? I.writeIORef ref DoneChunking return S.empty | otherwise = case S.length bs `compare` fromIntegral len of EQ -> yield' bs NeedLenNewline LT -> yield' bs $ HaveLen $ len - fromIntegral (S.length bs) GT -> do let (x, y) = S.splitAt (fromIntegral len) bs leftoverSource src y yield' x NeedLenNewline yield' bs mlen = do I.writeIORef ref mlen return bs dropCRLF = do bs <- readSource src case S.uncons bs of Nothing -> return () Just (13, bs') -> dropLF bs' Just (10, bs') -> leftoverSource src bs' Just _ -> leftoverSource src bs dropLF bs = case S.uncons bs of Nothing -> do bs2 <- readSource' src unless (S.null bs2) $ dropLF bs2 Just (10, bs') -> leftoverSource src bs' Just _ -> leftoverSource src bs go NeedLen = getLen go NeedLenNewline = dropCRLF >> getLen go (HaveLen 0) = do -- Drop the final CRLF dropCRLF I.writeIORef ref DoneChunking return S.empty go (HaveLen len) = do bs <- readSource src withLen len bs go DoneChunking = return S.empty -- Get the length from the source, and then pass off control to withLen getLen = do bs <- readSource src if S.null bs then do I.writeIORef ref $ assert False $ HaveLen 0 return S.empty else do (x, y) <- case S.break (== 10) bs of (x, y) | S.null y -> do bs2 <- readSource' src return $ if S.null bs2 then (x, y) else S.break (== 10) $ bs `S.append` bs2 | otherwise -> return (x, y) let w = S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $ S.takeWhile isHexDigit x let y' = S.drop 1 y y'' <- if S.null y' then readSource src else return y' withLen w y'' hexToWord w | w < 58 = w - 48 | w < 71 = w - 55 | otherwise = w - 87 isHexDigit :: Word8 -> Bool isHexDigit w = w >= 48 && w <= 57 || w >= 65 && w <= 70 || w >= 97 && w <= 102 warp-3.1.12/Network/Wai/Handler/Warp/Counter.hs0000644000000000000000000000127212636712547017366 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Counter ( Counter , newCounter , waitForZero , increase , decrease ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Concurrent.STM import Control.Monad (unless) 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 increase :: Counter -> IO () increase (Counter ref) = atomically $ modifyTVar' ref $ \x -> x + 1 decrease :: Counter -> IO () decrease (Counter ref) = atomically $ modifyTVar' ref $ \x -> x - 1 warp-3.1.12/Network/Wai/Handler/Warp/Date.hs0000644000000000000000000000255712636712547016633 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Date ( withDateCache , getDate , DateCache , GMTDate ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate) import Data.ByteString.Char8 import Network.HTTP.Date #if WINDOWS import Data.Time (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Foreign.C.Types (CTime(..)) #else import System.Posix (epochTime) #endif -- | The type of the Date header value. type GMTDate = ByteString -- | The type of the cache of the Date header value. type DateCache = IO GMTDate -- | Creating 'DateCache' and executing the action. withDateCache :: (DateCache -> IO a) -> IO a withDateCache action = initialize >>= action initialize :: IO DateCache initialize = mkAutoUpdate defaultUpdateSettings { updateAction = formatHTTPDate <$> getCurrentHTTPDate } -- | Getting current 'GMTDate' based on 'DateCache'. getDate :: DateCache -> IO GMTDate getDate = id #ifdef WINDOWS uToH :: UTCTime -> HTTPDate uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds getCurrentHTTPDate :: IO HTTPDate getCurrentHTTPDate = uToH <$> getCurrentTime #else getCurrentHTTPDate :: IO HTTPDate getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime #endif warp-3.1.12/Network/Wai/Handler/Warp/FdCache.hs0000644000000000000000000001074712636712547017233 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} -- | File descriptor cache to avoid locks in kernel. #ifdef WINDOWS module Network.Wai.Handler.Warp.FdCache ( withFdCache , MutableFdCache , Refresh ) where type Refresh = IO () type MutableFdCache = () withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a withFdCache _ f = f Nothing #else module Network.Wai.Handler.Warp.FdCache ( withFdCache , getFd , MutableFdCache , Refresh ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception (bracket) import Data.Hashable (hash) import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.MultiMap import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd) import System.Posix.Types (Fd) import Control.Reaper ---------------------------------------------------------------- data Status = Active | Inactive newtype MutableStatus = MutableStatus (IORef Status) -- | An action to activate a Fd cache entry. type Refresh = IO () status :: MutableStatus -> IO Status status (MutableStatus ref) = readIORef ref newActiveStatus :: IO MutableStatus newActiveStatus = MutableStatus <$> newIORef Active refresh :: MutableStatus -> Refresh refresh (MutableStatus ref) = writeIORef ref Active inactive :: MutableStatus -> IO () inactive (MutableStatus ref) = writeIORef ref Inactive ---------------------------------------------------------------- data FdEntry = FdEntry !FilePath !Fd !MutableStatus newFdEntry :: FilePath -> IO FdEntry newFdEntry path = FdEntry path <$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True} <*> newActiveStatus ---------------------------------------------------------------- type Hash = Int type FdCache = MMap Hash FdEntry -- | Mutable Fd cacher. type MutableFdCache = Reaper FdCache (Hash, FdEntry) fdCache :: MutableFdCache -> IO FdCache fdCache mfc = reaperRead mfc look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry) look mfc path key = searchWith key check <$> fdCache mfc where check (One ent@(FdEntry path' _ _)) | path == path' = Just ent | otherwise = Nothing check (Tom ent@(FdEntry path' _ _) vs) | path == path' = Just ent | otherwise = check vs ---------------------------------------------------------------- -- | Creating 'MutableFdCache' and executing the action in the second -- argument. The first argument is a cache duration in second. withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a withFdCache duration action = bracket (initialize duration) terminate action ---------------------------------------------------------------- -- The first argument is a cache duration in second. initialize :: Int -> IO (Maybe MutableFdCache) initialize 0 = return Nothing initialize duration = Just <$> mkReaper defaultReaperSettings { reaperAction = clean , reaperDelay = duration , reaperCons = uncurry insert , reaperNull = isEmpty , reaperEmpty = empty } clean :: FdCache -> IO (FdCache -> FdCache) clean old = do new <- pruneWith old prune return $ merge new prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)] prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune' where prune' Active = inactive mst >> return [(k,v)] prune' Inactive = closeFd fd >> return [] prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune' where prune' Active = do inactive mst zs <- prune k vs case zs of [] -> return [(k,One ent)] [(_,zvs)] -> return [(k,Tom ent zvs)] _ -> error "prune" prune' Inactive = closeFd fd >> prune k vs ---------------------------------------------------------------- terminate :: Maybe MutableFdCache -> IO () terminate Nothing = return () terminate (Just mfc) = do !t <- reaperStop mfc mapM_ closeIt $ toList t where closeIt (_, FdEntry _ fd _) = closeFd fd ---------------------------------------------------------------- -- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher. getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh) getFd mfc path = look mfc path key >>= getFd' where key = hash path getFd' Nothing = do ent@(FdEntry _ fd mst) <- newFdEntry path reaperAdd mfc (key, ent) return (fd, refresh mst) getFd' (Just (FdEntry _ fd mst)) = do refresh mst return (fd, refresh mst) #endif warp-3.1.12/Network/Wai/Handler/Warp/File.hs0000644000000000000000000001511612636712547016630 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.File ( RspFileInfo(..) , conditionalRequest , addContentHeadersForFilePart ) where import Control.Applicative ((<|>)) import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as B hiding (pack) import qualified Data.ByteString.Char8 as B (pack, readInteger) import Network.HTTP.Date import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H import Network.Wai import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.Header import Numeric (showInt) ---------------------------------------------------------------- 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 nobody@(WithoutBody _) -> nobody WithBody s _ off len -> let hs = (H.hLastModified,date) : addContentHeaders hs0 off len size in WithBody s hs off len where mtime = I.fileInfoTime finfo size = I.fileInfoSize finfo date = I.fileInfoDate finfo mcondition = ifmodified reqidx size mtime <|> ifunmodified reqidx size mtime <|> ifrange reqidx size mtime condition = case mcondition of Nothing -> unconditional reqidx size Just x -> x ---------------------------------------------------------------- ifModifiedSince :: IndexedHeader -> Maybe HTTPDate ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate ifRange :: IndexedHeader -> Maybe HTTPDate ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate ---------------------------------------------------------------- ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo ifmodified reqidx size mtime = do date <- ifModifiedSince reqidx return $ if date /= mtime then unconditional reqidx size else WithoutBody H.notModified304 ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo ifunmodified reqidx size mtime = do date <- ifUnmodifiedSince reqidx return $ if date == mtime then unconditional reqidx size else WithoutBody H.preconditionFailed412 ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo ifrange reqidx size mtime = do date <- ifRange reqidx rng <- reqidx ! fromEnum ReqRange 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 ---------------------------------------------------------------- parseRange :: ByteString -> Integer -> RspFileInfo parseRange rng size = case parseByteRanges rng of Nothing -> WithoutBody H.requestedRangeNotSatisfiable416 Just [] -> WithoutBody H.requestedRangeNotSatisfiable416 Just (r:_) -> let (!beg, !end) = checkRange r size !len = end - beg + 1 s = if beg == 0 && end == size - 1 then H.ok200 else H.partialContent206 in WithBody s [] beg len checkRange :: H.ByteRange -> Integer -> (Integer, Integer) checkRange (H.ByteRangeFrom beg) size = (beg, size - 1) checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end) checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1) -- | Parse the value of a Range header into a 'H.ByteRanges'. parseByteRanges :: B.ByteString -> Maybe H.ByteRanges parseByteRanges bs1 = do bs2 <- stripPrefix "bytes=" bs1 (r, bs3) <- range bs2 ranges (r:) bs3 where range bs2 = do (i, bs3) <- B.readInteger bs2 if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-") then Just (H.ByteRangeSuffix (negate i), bs3) else do bs4 <- stripPrefix "-" bs3 case B.readInteger bs4 of Just (j, bs5) | j >= i -> Just (H.ByteRangeFromTo i j, bs5) _ -> Just (H.ByteRangeFrom i, bs4) ranges front bs3 | B.null bs3 = Just (front []) | otherwise = do bs4 <- stripPrefix "," bs3 (r, bs5) <- range bs4 ranges (front . (r:)) bs5 stripPrefix x y | x `B.isPrefixOf` y = Just (B.drop (B.length x) y) | otherwise = Nothing ---------------------------------------------------------------- -- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' -- for the range specified. contentRangeHeader :: Integer -> Integer -> Integer -> H.Header contentRangeHeader beg end total = ( #if MIN_VERSION_http_types(0,9,0) H.hContentRange #else "Content-Range" #endif , range) where range = B.pack -- building with ShowS $ 'b' : 'y': 't' : 'e' : 's' : ' ' : (if beg > end then ('*':) else showInt beg . ('-' :) . showInt end) ( '/' : showInt total "") addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders addContentHeaders hs off len size = hs'' where contentRange = contentRangeHeader off (off + len - 1) size !lengthBS = B.pack $ show len hs' = (H.hContentLength, lengthBS):( #if MIN_VERSION_http_types(0,9,0) H.hAcceptRanges #else "Accept-Ranges" #endif , "bytes"):hs hs'' = if len == size then hs' else contentRange:hs' -- | -- -- >>> addContentHeadersForFilePart [] (FilePart 2 10 16) -- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")] -- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) -- [("Content-Length","16"),("Accept-Ranges","bytes")] addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders addContentHeadersForFilePart hs part = addContentHeaders hs off len size where off = filePartOffset part len = filePartByteCount part size = filePartFileSize part warp-3.1.12/Network/Wai/Handler/Warp/FileInfoCache.hs0000644000000000000000000000655512636712547020377 0ustar0000000000000000{-# LANGUAGE RecordWildCards, CPP #-} module Network.Wai.Handler.Warp.FileInfoCache ( FileInfo(..) , withFileInfoCache , getInfo -- test purpose only ) where import Control.Exception as E import Control.Monad (void) import Control.Reaper import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Network.HTTP.Date import System.PosixCompat.Files ---------------------------------------------------------------- -- | File information. data FileInfo = FileInfo { fileInfoName :: !FilePath , fileInfoSize :: !Integer , fileInfoTime :: HTTPDate -- ^ Modification time , fileInfoDate :: ByteString -- ^ Modification time in the GMT format } deriving (Eq, Show) data Entry = Negative | Positive FileInfo type Cache = HashMap FilePath Entry type FileInfoCache = Reaper Cache (FilePath,Entry) ---------------------------------------------------------------- -- | Getting the file information corresponding to the file. getInfo :: FilePath -> IO FileInfo getInfo path = do fs <- getFileStatus path -- file access let regular = not (isDirectory fs) readable = fileMode fs `intersectFileModes` ownerReadMode /= 0 if regular && readable then do let time = epochTimeToHTTPDate $ modificationTime fs date = formatHTTPDate time size = fromIntegral $ fileSize fs info = FileInfo { fileInfoName = path , fileInfoSize = size , fileInfoTime = time , fileInfoDate = date } return info else throwIO (userError "FileInfoCache:getInfo") ---------------------------------------------------------------- getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo getAndRegisterInfo reaper@Reaper{..} path = do cache <- reaperRead case M.lookup path cache of Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x Nothing -> positive reaper path `E.onException` negative reaper path positive :: FileInfoCache -> FilePath -> IO FileInfo positive Reaper{..} path = do info <- getInfo path reaperAdd (path, Positive info) return info negative :: FileInfoCache -> FilePath -> IO FileInfo negative Reaper{..} path = do reaperAdd (path,Negative) throwIO (userError "FileInfoCache:negative") ---------------------------------------------------------------- -- | Creating a file information cache -- and executing the action in the second argument. -- The first argument is a cache duration in second. withFileInfoCache :: Int -> ((FilePath -> IO FileInfo) -> IO a) -> IO a withFileInfoCache 0 action = action getInfo withFileInfoCache duration action = E.bracket (initialize duration) terminate (\c -> action (getAndRegisterInfo c)) initialize :: Int -> IO FileInfoCache initialize duration = mkReaper settings where settings = defaultReaperSettings { reaperAction = override , reaperDelay = duration * 1000000 , reaperCons = uncurry M.insert , reaperNull = M.null , reaperEmpty = M.empty } override :: Cache -> IO (Cache -> Cache) override _ = return $ const M.empty terminate :: FileInfoCache -> IO () terminate x = void $ reaperStop x warp-3.1.12/Network/Wai/Handler/Warp/Header.hs0000644000000000000000000000631412636712547017141 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.Wai.Handler.Warp.Header where import Data.Array import Data.Array.ST import Network.HTTP.Types import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -- | Array for a set of HTTP headers. type IndexedHeader = Array Int (Maybe HeaderValue) ---------------------------------------------------------------- indexRequestHeader :: RequestHeaders -> IndexedHeader indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex data RequestHeaderIndex = ReqContentLength | ReqTransferEncoding | ReqExpect | ReqConnection | ReqRange | ReqHost | ReqIfModifiedSince | ReqIfUnmodifiedSince | ReqIfRange 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\". requestMaxIndex :: Int requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex) requestKeyIndex :: HeaderName -> Int requestKeyIndex "content-length" = fromEnum ReqContentLength requestKeyIndex "transfer-encoding" = fromEnum ReqTransferEncoding requestKeyIndex "expect" = fromEnum ReqExpect requestKeyIndex "connection" = fromEnum ReqConnection requestKeyIndex "range" = fromEnum ReqRange requestKeyIndex "host" = fromEnum ReqHost requestKeyIndex "if-modified-since" = fromEnum ReqIfModifiedSince requestKeyIndex "if-unmodified-since" = fromEnum ReqIfUnmodifiedSince requestKeyIndex "if-range" = fromEnum ReqIfRange requestKeyIndex _ = -1 defaultIndexRequestHeader :: IndexedHeader defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]] ---------------------------------------------------------------- indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex data ResponseHeaderIndex = ResContentLength | ResServer | ResDate deriving (Enum,Bounded) -- | The size for 'IndexedHeader' for HTTP Response. responseMaxIndex :: Int responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex) responseKeyIndex :: HeaderName -> Int responseKeyIndex "content-length" = fromEnum ResContentLength responseKeyIndex "server" = fromEnum ResServer responseKeyIndex "date" = fromEnum ResDate responseKeyIndex _ = -1 ---------------------------------------------------------------- traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader traverseHeader hdr maxidx getIndex = runSTArray $ do arr <- newArray (0,maxidx) Nothing mapM_ (insert arr) hdr return arr where insert arr (key,val) | idx == -1 = return () | otherwise = writeArray arr idx (Just val) where idx = getIndex key warp-3.1.12/Network/Wai/Handler/Warp/HTTP2.hs0000644000000000000000000000473512636712547016617 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where import Control.Concurrent (forkIO, killThread) import qualified Control.Exception as E import Control.Monad (when, unless, replicateM_) import Data.ByteString (ByteString) import Network.HTTP2 import Network.Socket (SockAddr) import Network.Wai.HTTP2 (HTTP2Application) import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.HTTP2.Receiver import Network.Wai.Handler.Warp.HTTP2.Request import Network.Wai.Handler.Warp.HTTP2.Sender import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.HTTP2.Worker import qualified Network.Wai.Handler.Warp.Settings as S (Settings) import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> HTTP2Application -> IO () http2 conn ii addr transport settings readN app = do checkTLS ok <- checkPreface when ok $ do ctx <- newContext -- Workers & Manager mgr <- start let responder = response ctx mgr action = worker ctx settings tm app responder setAction mgr action -- fixme: hard coding: 10 replicateM_ 10 $ spawnAction mgr -- Receiver let mkreq = mkRequest ii settings addr tid <- forkIO $ frameReceiver ctx mkreq readN -- Sender -- frameSender is the main thread because it ensures to send -- a goway frame. frameSender ctx conn ii settings `E.finally` do clearContext ctx stop mgr killThread tid where tm = timeoutManager ii checkTLS = case transport of TCP -> return () -- direct tls -> unless (tls12orLater tls) $ goaway conn 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 -- connClose must not be called here since Run:fork calls it goaway :: Connection -> ErrorCodeId -> ByteString -> IO () goaway Connection{..} etype debugmsg = connSendAll bytestream where bytestream = goawayFrame 0 etype debugmsg warp-3.1.12/Network/Wai/Handler/Warp/Internal.hs0000644000000000000000000000503412636712547017523 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Internal ( -- * Settings Settings (..) , ProxyProtocol(..) -- * Low level run functions , runSettingsConnection , runSettingsConnectionMaker , runSettingsConnectionMakerSecure , runServe , runServeEnv , runServeSettings , runServeSettingsSocket , runServeSettingsConnection , runServeSettingsConnectionMaker , runServeSettingsConnectionMakerSecure , Transport (..) -- * ServeConnection , ServeConnection , serveDefault , serveHTTP2 -- * Connection , Connection (..) , socketConnection -- ** Receive , Recv , RecvBuf , makePlainReceiveN -- ** Buffer , Buffer , BufSize , bufferSize , allocateBuffer , freeBuffer , copy -- ** Sendfile , FileId (..) , SendFile , sendFile , readSendFile -- * Version , warpVersion -- * Data types , InternalInfo (..) , HeaderValue , IndexedHeader , requestMaxIndex -- * Time out manager -- | -- -- In order to provide slowloris protection, Warp provides timeout handlers. We -- follow these rules: -- -- * A timeout is created when a connection is opened. -- -- * When all request headers are read, the timeout is tickled. -- -- * Every time at least the slowloris size settings number of bytes of the request -- body are read, the timeout is tickled. -- -- * The timeout is paused while executing user code. This will apply to both -- the application itself, and a ResponseSource response. The timeout is -- resumed as soon as we return from user code. -- -- * Every time data is successfully sent to the client, the timeout is tickled. , module Network.Wai.Handler.Warp.Timeout -- * File descriptor cache , module Network.Wai.Handler.Warp.FdCache -- * File information cache , module Network.Wai.Handler.Warp.FileInfoCache -- * Date , module Network.Wai.Handler.Warp.Date -- * Request and response , Source , recvRequest , sendResponse ) where import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types warp-3.1.12/Network/Wai/Handler/Warp/IO.hs0000644000000000000000000000170412636712547016256 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.IO where import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk)) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Types toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO () toBufIOWith buf !size io builder = loop firstWriter where firstWriter = runBuilder builder runIO len = bufferIO buf len io loop writer = do (len, signal) <- writer buf size 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 warp-3.1.12/Network/Wai/Handler/Warp/IORef.hs0000644000000000000000000000134412636712547016713 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif module Network.Wai.Handler.Warp.IORef ( module Data.IORef #if !MIN_VERSION_base(4,6,0) , atomicModifyIORef' #endif ) where import Data.IORef #if !MIN_VERSION_base(4,6,0) -- | Strict version of 'atomicModifyIORef'. This forces both the value stored -- in the 'IORef' as well as the value returned. atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b atomicModifyIORef' ref f = do c <- atomicModifyIORef ref (\x -> let (a, b) = f x -- Lazy application of "f" in (a, a `seq` b)) -- Lazy application of "seq" -- The following forces "a `seq` b", so it also forces "f x". c `seq` return c #endif warp-3.1.12/Network/Wai/Handler/Warp/MultiMap.hs0000644000000000000000000001516412636712547017504 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.MultiMap ( MMap , Some(..) , empty , singleton , insert , search , searchWith , isEmpty , valid , pruneWith , fromList , toList , fromSortedList , toSortedList , merge ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Data.List (foldl') ---------------------------------------------------------------- -- | One ore more list to implement multimap. data Some a = One !a | Tom !a !(Some a) -- Two or more deriving (Eq,Show) -- This is slow but assuming rarely used. snoc :: Some a -> a -> Some a snoc (One x) y = Tom x (One y) snoc (Tom x xs) y = Tom x (snoc xs y) top :: Some a -> a top (One x) = x top (Tom x _) = x ---------------------------------------------------------------- -- | Red black tree as multimap. data MMap k v = Leaf -- color is Black | Node Color !(MMap k v) !k !(Some v) !(MMap k v) deriving (Show) data Color = B -- ^ Black | R -- ^ Red deriving (Eq, Show) ---------------------------------------------------------------- instance (Eq k, Eq v) => Eq (MMap k v) where t1 == t2 = toSortedList t1 == toSortedList t2 ---------------------------------------------------------------- -- | O(log N) search :: Ord k => k -> MMap k v -> Maybe v search _ Leaf = Nothing search xk (Node _ l k v r) = case compare xk k of LT -> search xk l GT -> search xk r EQ -> Just $ top v -- | O(log N) searchWith :: Ord k => k -> (Some v -> Maybe v) -> MMap k v -> Maybe v searchWith _ _ Leaf = Nothing searchWith xk f (Node _ l k v r) = case compare xk k of LT -> searchWith xk f l GT -> searchWith xk f r EQ -> f v ---------------------------------------------------------------- -- | O(1) isEmpty :: MMap k v -> Bool isEmpty Leaf = True isEmpty _ = False -- | O(1) empty :: MMap k v empty = Leaf ---------------------------------------------------------------- -- | O(1) singleton :: Ord k => k -> v -> MMap k v singleton k v = Node B Leaf k (One v) Leaf ---------------------------------------------------------------- -- | O(log N) insert :: Ord k => k -> v -> MMap k v -> MMap k v insert kx kv t = turnB (insert' kx kv t) insert' :: Ord k => k -> v -> MMap k v -> MMap k v insert' xk xv Leaf = Node R Leaf xk (One xv) Leaf insert' xk xv (Node B l k v r) = case compare xk k of LT -> balanceL' (insert' xk xv l) k v r GT -> balanceR' l k v (insert' xk xv r) EQ -> Node B l k (snoc v xv) r insert' xk xv (Node R l k v r) = case compare xk k of LT -> Node R (insert' xk xv l) k v r GT -> Node R l k v (insert' xk xv r) EQ -> Node R l k (snoc v xv) r balanceL' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v balanceL' (Node R (Node R a xk xv b) yk yv c) zk zv d = Node R (Node B a xk xv b) yk yv (Node B c zk zv d) balanceL' (Node R a xk xv (Node R b yk yv c)) zk zv d = Node R (Node B a xk xv b) yk yv (Node B c zk zv d) balanceL' l k v r = Node B l k v r balanceR' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v balanceR' a xk xv (Node R b yk yv (Node R c zk zv d)) = Node R (Node B a xk xv b) yk yv (Node B c zk zv d) balanceR' a xk xv (Node R (Node R b yk yv c) zk zv d) = Node R (Node B a xk xv b) yk yv (Node B c zk zv d) balanceR' l xk xv r = Node B l xk xv r turnB :: MMap k v -> MMap k v turnB Leaf = error "turnB" turnB (Node _ l k v r) = Node B l k v r ---------------------------------------------------------------- -- | O(N log N) fromList :: Ord k => [(k,v)] -> MMap k v fromList = foldl' (\t (k,v) -> insert k v t) empty -- | O(N) toList :: MMap k v -> [(k,v)] toList t = inorder t [] where inorder Leaf xs = xs inorder (Node _ l k v r) xs = inorder l (pairs k v ++ inorder r xs) pairs k (One v) = [(k,v)] pairs k (Tom v vs) = (k,v) : pairs k vs ---------------------------------------------------------------- -- | O(N) -- "Constructing Red-Black Trees" by Ralf Hinze fromSortedList :: Ord k => [(k,Some v)] -> MMap k v fromSortedList = linkAll . foldr add [] data Digit k v = Uno k (Some v) (MMap k v) | Due k (Some v) (MMap k v) k (Some v) (MMap k v) deriving (Eq,Show) incr :: Digit k v -> [Digit k v] -> [Digit k v] incr (Uno k v t) [] = [Uno k v t] incr (Uno k1 v1 t1) (Uno k2 v2 t2 : ps) = Due k1 v1 t1 k2 v2 t2 : ps incr (Uno k1 v1 t1) (Due k2 v2 t2 k3 v3 t3 : ps) = Uno k1 v1 t1 : incr (Uno k2 v2 (Node B t2 k3 v3 t3)) ps incr _ _ = error "incr" add :: (k,Some v) -> [Digit k v] -> [Digit k v] add (k,v) ps = incr (Uno k v Leaf) ps linkAll :: [Digit k v] -> MMap k v linkAll = foldl' link Leaf link :: MMap k v -> Digit k v -> MMap k v link l (Uno k v t) = Node B l k v t --link l (Due k1 v1 t1 k2 v2 t2) = Node B (Node R l k1 v1 t1) k2 v2 t2 link l (Due k1 v1 t1 k2 v2 t2) = Node B l k1 v1 (Node R t1 k2 v2 t2) ---------------------------------------------------------------- -- | O(N) toSortedList :: MMap k v -> [(k,Some v)] toSortedList t = inorder t [] where inorder Leaf xs = xs inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs) ---------------------------------------------------------------- -- | O(N) pruneWith :: Ord k => MMap k v -> (k -> Some v -> IO [(k, Some v)]) -> IO (MMap k v) pruneWith t run = fromSortedList <$> inorder t [] where inorder Leaf xs = return xs inorder (Node _ l k v r) xs = do ys <- run k v zs <- inorder r xs inorder l (ys ++ zs) ---------------------------------------------------------------- -- O(N log N) where N is the size of the second argument merge :: Ord k => MMap k v -> MMap k v -> MMap k v merge base m = foldl' ins base xs where ins t (k,v) = insert k v t xs = toList m ---------------------------------------------------------------- -- for testing valid :: Ord k => MMap k v -> Bool valid t = isBalanced t && isOrdered t isBalanced :: MMap k v -> Bool isBalanced t = isBlackSame t && isRedSeparate t isBlackSame :: MMap k v -> Bool isBlackSame t = all (n==) ns where n:ns = blacks t blacks :: MMap k v -> [Int] blacks = blacks' 0 where blacks' n Leaf = [n+1] blacks' n (Node R l _ _ r) = blacks' n l ++ blacks' n r blacks' n (Node B l _ _ r) = blacks' n' l ++ blacks' n' r where n' = n + 1 isRedSeparate :: MMap k v -> Bool isRedSeparate = reds B reds :: Color -> MMap k v -> Bool reds _ Leaf = True reds R (Node R _ _ _ _) = False reds _ (Node c l _ _ r) = reds c l && reds c r isOrdered :: Ord k => MMap k v -> Bool isOrdered t = ordered $ toSortedList t where ordered [] = True ordered [_] = True ordered (x:y:xys) = fst x <= fst y && ordered (y:xys) warp-3.1.12/Network/Wai/Handler/Warp/ReadInt.hs0000644000000000000000000000514612636712547017301 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} -- Copyright : Erik de Castro Lopo -- License : BSD3 module Network.Wai.Handler.Warp.ReadInt ( readInt , readInt64 ) where -- This function lives in its own file because the MagicHash pragma interacts -- poorly with the CPP pragma. import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.Int (Int64) import GHC.Prim import GHC.Types import GHC.Word {-# INLINE readInt #-} readInt :: Integral a => ByteString -> a readInt bs = fromIntegral $ readInt64 bs -- This function is used to parse the Content-Length field of HTTP headers and -- is a performance hot spot. It should only be replaced with something -- significantly and provably faster. -- -- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we -- use Int64 here and then make a generic 'readInt' that allows conversion to -- Int and Integer. {-# NOINLINE readInt64 #-} readInt64 :: ByteString -> Int64 readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (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 warp-3.1.12/Network/Wai/Handler/Warp/Recv.hs0000644000000000000000000001034112636712547016643 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Recv ( receive , receiveBuf , makeReceiveN , makePlainReceiveN , spell ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import qualified Control.Exception as E import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) import Data.Word (Word8) import Foreign.C.Error (eAGAIN, getErrno, throwErrno) import Foreign.C.Types import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, castPtr, plusPtr) import GHC.Conc (threadWaitRead) import Network.Socket (Socket, fdSocket) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.Types import System.Posix.Types (Fd(..)) #ifdef mingw32_HOST_OS import GHC.IO.FD (FD(..), readRawBufferPtr) import Network.Wai.Handler.Warp.Windows #endif ---------------------------------------------------------------- makeReceiveN :: ByteString -> Recv -> RecvBuf -> IO (BufSize -> IO ByteString) makeReceiveN bs0 recv recvBuf = do ref <- newIORef bs0 return $ receiveN ref recv recvBuf -- | This function returns a receiving function -- based on two receiving functions. -- The returned function efficiently manages received data -- which is initialized by the first argument. -- The returned function may allocate a byte string with malloc(). makePlainReceiveN :: Socket -> ByteString -> IO (BufSize -> IO ByteString) makePlainReceiveN s bs0 = do ref <- newIORef bs0 pool <- newBufferPool return $ receiveN ref (receive s pool) (receiveBuf s) receiveN :: IORef ByteString -> Recv -> RecvBuf -> BufSize -> IO ByteString receiveN ref recv recvBuf size = E.handle handler $ do cached <- readIORef ref (bs, leftover) <- spell cached size recv recvBuf writeIORef ref leftover return bs where handler :: E.SomeException -> IO ByteString handler _ = return "" ---------------------------------------------------------------- spell :: ByteString -> BufSize -> IO ByteString -> RecvBuf -> IO (ByteString, ByteString) spell init0 siz0 recv recvBuf | siz0 <= len0 = return $ BS.splitAt siz0 init0 -- fixme: hard coding 4096 | siz0 <= 4096 = loop [init0] (siz0 - len0) | otherwise = do bs@(PS fptr _ _) <- mallocBS siz0 withForeignPtr fptr $ \ptr -> do ptr' <- copy ptr init0 full <- recvBuf ptr' (siz0 - len0) if full then return (bs, "") else return ("", "") -- fixme where len0 = BS.length init0 loop bss siz = do bs <- recv let len = BS.length bs if len == 0 then return ("", "") else if len >= siz then do let (consume, leftover) = BS.splitAt siz bs ret = BS.concat $ reverse (consume : bss) return (ret, leftover) else do let bss' = bs : bss siz' = siz - len loop bss' siz' receive :: Socket -> BufferPool -> Recv receive sock pool = withBufferPool pool $ \ (ptr, size) -> do let sock' = fdSocket sock size' = fromIntegral size fromIntegral <$> receiveloop sock' ptr size' receiveBuf :: Socket -> RecvBuf receiveBuf sock buf0 siz0 = loop buf0 siz0 where loop _ 0 = return True loop buf siz = do n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz) -- fixme: what should we do in the case of n == 0 if n == 0 then return False else loop (buf `plusPtr` n) (siz - n) fd = fdSocket sock receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt receiveloop sock ptr size = do #ifdef mingw32_HOST_OS bytes <- windowsThreadBlockHack $ fromIntegral <$> readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size #else bytes <- c_recv sock (castPtr ptr) size 0 #endif if bytes == -1 then do errno <- getErrno if errno == eAGAIN then do threadWaitRead (Fd sock) receiveloop sock ptr size else throwErrno "receiveloop" else return bytes -- fixme: the type of the return value foreign import ccall unsafe "recv" c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt warp-3.1.12/Network/Wai/Handler/Warp/Request.hs0000644000000000000000000002416612636712547017406 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Request ( recvRequest , headerLines , pauseTimeoutKey , getFileInfoKey ) where import qualified Control.Concurrent as Conc (yield) import Control.Exception (throwIO) import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU import qualified Data.CaseInsensitive as CI import qualified Data.IORef as I import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath) import qualified Network.Wai.Handler.Warp.Timeout as Timeout import Network.Wai.Handler.Warp.Types import Network.Wai.Internal import Prelude hiding (lines) import Control.Monad (when) import qualified Data.Vault.Lazy as Vault import System.IO.Unsafe (unsafePerformIO) ---------------------------------------------------------------- -- FIXME come up with good values here maxTotalHeaderLength :: Int maxTotalHeaderLength = 50 * 1024 ---------------------------------------------------------------- -- | Receiving a HTTP request from 'Connection' and parsing its header -- to create 'Request'. recvRequest :: Settings -> Connection -> InternalInfo -> SockAddr -- ^ Peer's address. -> Source -- ^ Where HTTP request comes from. -> IO (Request ,Maybe (I.IORef Int) ,IndexedHeader ,IO ByteString) -- ^ -- 'Request' passed to 'Application', -- how many bytes remain to be consumed, if known -- 'IndexedHeader' of HTTP request for internal use, -- Body producing action used for flushing the request body recvRequest settings conn ii addr src = do hdrlines <- headerLines src (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr expect = idxhdr ! fromEnum ReqExpect cl = idxhdr ! fromEnum ReqContentLength te = idxhdr ! fromEnum ReqTransferEncoding handle100Continue = handleExpect conn httpversion expect (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te -- body producing function which will produce '100-continue', if needed rbody' <- timeoutBody remainingRef th rbody handle100Continue -- body producing function which will never produce 100-continue rbodyFlush <- timeoutBody remainingRef th rbody (return ()) let req = Request { requestMethod = method , httpVersion = httpversion , pathInfo = H.decodePathSegments path , rawPathInfo = if settingsNoParsePath settings then unparsedPath else path , rawQueryString = query , queryString = H.parseQuery query , requestHeaders = hdr , isSecure = False , remoteHost = addr , requestBody = rbody' , vault = vaultValue , requestBodyLength = bodyLength , requestHeaderHost = idxhdr ! fromEnum ReqHost , requestHeaderRange = idxhdr ! fromEnum ReqRange } return (req, remainingRef, idxhdr, rbodyFlush) where th = threadHandle ii vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (fileInfo ii) Vault.empty ---------------------------------------------------------------- headerLines :: Source -> IO [ByteString] headerLines src = do bs <- readSource src if S.null bs then throwIO ConnectionClosedByPeer else push src (THStatus 0 id id) bs ---------------------------------------------------------------- handleExpect :: Connection -> H.HttpVersion -> Maybe HeaderValue -> IO () handleExpect conn ver (Just "100-continue") = do connSendAll conn continue Conc.yield where continue | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n" | otherwise = "HTTP/1.0 100 Continue\r\n\r\n" handleExpect _ _ _ = return () ---------------------------------------------------------------- bodyAndSource :: Source -> Maybe HeaderValue -- ^ content length -> Maybe HeaderValue -- ^ transfer-encoding -> IO (IO ByteString ,Maybe (I.IORef Int) ,RequestBodyLength ) bodyAndSource src cl te | chunked = do csrc <- mkCSource src return (readCSource csrc, Nothing, ChunkedBody) | otherwise = do isrc@(ISource _ remaining) <- mkISource src len return (readISource isrc, Just remaining, bodyLen) where len = toLength cl bodyLen = KnownLength $ fromIntegral len chunked = isChunked te toLength :: Maybe HeaderValue -> Int toLength Nothing = 0 toLength (Just bs) = readInt bs isChunked :: Maybe HeaderValue -> Bool isChunked (Just bs) = CI.foldCase bs == "chunked" isChunked _ = False ---------------------------------------------------------------- timeoutBody :: Maybe (I.IORef Int) -- ^ remaining -> Timeout.Handle -> IO ByteString -> IO () -> IO (IO ByteString) timeoutBody remainingRef timeoutHandle rbody handle100Continue = do isFirstRef <- I.newIORef True let checkEmpty = case remainingRef of Nothing -> return . S.null Just ref -> \bs -> if S.null bs then return True else do x <- I.readIORef ref return $! x <= 0 return $ do isFirst <- I.readIORef isFirstRef when isFirst $ do -- Only check if we need to produce the 100 Continue status -- when asking for the first chunk of the body handle100Continue -- Timeout handling was paused after receiving the full request -- headers. Now we need to resume it to avoid a slowloris -- attack during request body sending. Timeout.resume timeoutHandle I.writeIORef isFirstRef False bs <- rbody -- As soon as we finish receiving the request body, whether -- because the application is not interested in more bytes, or -- because there is no more data available, pause the timeout -- handler again. isEmpty <- checkEmpty bs when isEmpty (Timeout.pause timeoutHandle) return bs ---------------------------------------------------------------- type BSEndo = ByteString -> ByteString type BSEndoList = [ByteString] -> [ByteString] data THStatus = THStatus {-# UNPACK #-} !Int -- running total byte count BSEndoList -- previously parsed lines BSEndo -- bytestrings to be prepended ---------------------------------------------------------------- {- FIXME close :: Sink ByteString IO a close = throwIO IncompleteHeaders -} push :: Source -> THStatus -> ByteString -> IO [ByteString] push src (THStatus len lines prepend) bs' -- Too many bytes | len > maxTotalHeaderLength = throwIO OverLargeHeader | otherwise = push' mnl 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 where start = end + 1 -- start of next chunk line = SU.unsafeTake (checkCR bs end) bs {-# INLINE checkCR #-} checkCR :: ByteString -> Int -> Int checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR where !p = pos - 1 pauseTimeoutKey :: Vault.Key (IO ()) pauseTimeoutKey = unsafePerformIO Vault.newKey {-# NOINLINE pauseTimeoutKey #-} getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo) getFileInfoKey = unsafePerformIO Vault.newKey {-# NOINLINE getFileInfoKey #-} warp-3.1.12/Network/Wai/Handler/Warp/RequestHeader.hs0000644000000000000000000001115112636712547020505 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.RequestHeader ( parseHeaderLines , parseByteRanges ) where import Control.Exception (throwIO) import Control.Monad (when) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as B (unpack) import Data.ByteString.Internal (ByteString(..), memchr) import qualified Data.CaseInsensitive as CI import Data.Word (Word8) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr) import Foreign.Storable (peek) import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Types import Network.Wai.Internal (parseByteRanges) -- $setup -- >>> :set -XOverloadedStrings ---------------------------------------------------------------- parseHeaderLines :: [ByteString] -> IO (H.Method ,ByteString -- Path ,ByteString -- Path, parsed ,ByteString -- Query ,H.HttpVersion ,H.RequestHeaders ) parseHeaderLines [] = throwIO $ NotEnoughLines [] parseHeaderLines (firstLine:otherLines) = do (method, path', query, httpversion) <- parseRequestLine firstLine let path = H.extractPath path' hdr = map parseHeader otherLines return (method, path', path, query, httpversion, hdr) ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine "GET " -- *** Exception: Warp: Invalid first line of request: "GET " -- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: Warp: Request line specified a non-HTTP request -- >>> parseRequestLine "PRI * HTTP/2.0" -- ("PRI","*","",HTTP/2.0) parseRequestLine :: ByteString -> IO (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do when (len < 14) $ throwIO baderr let methodptr = ptr `plusPtr` off limptr = methodptr `plusPtr` len lim0 = fromIntegral len pathptr0 <- memchr methodptr 32 lim0 -- ' ' when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ throwIO baderr let pathptr = pathptr0 `plusPtr` 1 lim1 = fromIntegral (limptr `minusPtr` pathptr0) httpptr0 <- memchr pathptr 32 lim1 -- ' ' when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ throwIO baderr let httpptr = httpptr0 `plusPtr` 1 lim2 = fromIntegral (httpptr0 `minusPtr` pathptr) checkHTTP httpptr !hv <- httpVersion httpptr queryptr <- memchr pathptr 63 lim2 -- '?' let !method = bs ptr methodptr pathptr0 !path | queryptr == nullPtr = bs ptr pathptr httpptr0 | otherwise = bs ptr pathptr queryptr !query | queryptr == nullPtr = S.empty | otherwise = bs ptr queryptr httpptr0 return (method,path,query,hv) where baderr = BadFirstLine $ B.unpack requestLine check :: Ptr Word8 -> Int -> Word8 -> IO () check p n w = do w0 <- peek $ p `plusPtr` n when (w0 /= w) $ throwIO NonHttp checkHTTP httpptr = do check httpptr 0 72 -- 'H' check httpptr 1 84 -- 'T' check httpptr 2 84 -- 'T' check httpptr 3 80 -- 'P' check httpptr 4 47 -- '/' check httpptr 6 46 -- '.' httpVersion httpptr = do major <- peek (httpptr `plusPtr` 5) :: IO Word8 minor <- peek (httpptr `plusPtr` 7) :: IO Word8 let version | major == 49 = if minor == 49 then H.http11 else H.http10 | major == 50 && minor == 48 = H.HttpVersion 2 0 | otherwise = H.http10 return version bs ptr p0 p1 = PS fptr o l where o = p0 `minusPtr` ptr l = p1 `minusPtr` p0 ---------------------------------------------------------------- -- | -- -- >>> parseHeader "Content-Length:47" -- ("Content-Length","47") -- >>> parseHeader "Accept-Ranges: bytes" -- ("Accept-Ranges","bytes") -- >>> parseHeader "Host: example.com:8080" -- ("Host","example.com:8080") -- >>> parseHeader "NoSemiColon" -- ("NoSemiColon","") parseHeader :: ByteString -> H.Header parseHeader s = let (k, rest) = S.break (== 58) s -- ':' rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest in (CI.mk k, rest') warp-3.1.12/Network/Wai/Handler/Warp/Response.hs0000644000000000000000000004156012636712547017551 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Response ( sendResponse , sanitizeHeaderValue -- for testing , warpVersion , addDate , addServer , hasBody ) where #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_http_types #define MIN_VERSION_http_types(x,y,z) 1 #endif import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import qualified Control.Exception as E import Control.Monad (unless, when) import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Builder (byteString, Builder) import Data.ByteString.Builder.Extra (flush) import qualified Data.CaseInsensitive as CI import Data.Function (on) import Data.List (deleteBy) import Data.Maybe #if MIN_VERSION_base(4,5,0) # if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mempty) # endif import Data.Monoid ((<>)) #else import Data.Monoid (mappend, mempty) #endif import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy) import Data.Version (showVersion) import Data.Word8 (_cr, _lf) import qualified Network.HTTP.Types as H #if MIN_VERSION_http_types(0,9,0) import qualified Network.HTTP.Types.Header as H #endif import Network.Wai import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D #ifndef WINDOWS import qualified Network.Wai.Handler.Warp.FdCache as F #endif import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.IO (toBufIOWith) import Network.Wai.Handler.Warp.ResponseHeader import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types import Network.Wai.Internal import qualified Paths_warp #if !MIN_VERSION_base(4,5,0) (<>) :: Monoid m => m -> m -> m (<>) = mappend #endif -- $setup -- >>> :set -XOverloadedStrings ---------------------------------------------------------------- -- | Sending a HTTP response to 'Connection' according to 'Response'. -- -- Applications/middlewares MUST provide a proper 'H.ResponseHeaders'. -- so that inconsistency does not happen. -- No header is deleted by this function. -- -- Especially, Applications/middlewares MUST provide a proper -- Content-Type. They MUST NOT provide -- Content-Length, Content-Range, and Transfer-Encoding -- because they are inserted, when necessary, -- regardless they already exist. -- This function does not insert Content-Encoding. It's middleware's -- responsibility. -- -- The Date and Server header is added if not exist -- in HTTP response header. -- -- There are three basic APIs to create 'Response': -- -- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response'] -- HTTP response body is created from 'Builder'. -- Transfer-Encoding: chunked is used in HTTP/1.1. -- -- ['responseStream' :: 'H.Status' -> 'H.ResponseHeaders' -> 'StreamingBody' -> 'Response'] -- HTTP response body is created from 'Builder'. -- Transfer-Encoding: chunked is used in HTTP/1.1. -- -- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response'] -- No header is added and no Transfer-Encoding: is applied. -- -- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response'] -- HTTP response body is sent (by sendfile(), if possible) for GET method. -- HTTP response body is not sent by HEAD method. -- Content-Length and Content-Range are automatically -- added into the HTTP response header if necessary. -- If Content-Length and Content-Range exist in the HTTP response header, -- they would cause inconsistency. -- \"Accept-Ranges: bytes\" is also inserted. -- -- Applications are categorized into simple and sophisticated. -- Sophisticated applications should specify 'Just' to -- 'Maybe' 'FilePart'. They should treat the conditional request -- by themselves. A proper 'Status' (200 or 206) must be provided. -- -- Simple applications should specify 'Nothing' to -- 'Maybe' 'FilePart'. The size of the specified file is obtained -- by disk access or from the file infor cache. -- If-Modified-Since, If-Unmodified-Since, If-Range and Range -- are processed. Since a proper status is chosen, 'Status' is -- ignored. Last-Modified is inserted. sendResponse :: Settings -> Connection -> InternalInfo -> Request -- ^ HTTP request. -> IndexedHeader -- ^ Indexed header of HTTP request. -> IO ByteString -- ^ source from client, for raw response -> Response -- ^ HTTP response including status code and response header. -> IO Bool -- ^ Returing True if the connection is persistent. sendResponse settings conn ii req reqidxhdr src response = do hs <- addServerAndDate hs0 if hasBody s then do -- The response to HEAD does not have body. -- But to handle the conditional requests defined RFC 7232 and -- to generate appropriate content-length, content-range, -- and status, the response to HEAD is processed here. -- -- See definition of rsp below for proper body stripping. (ms, mlen) <- sendRsp conn ii ver s hs rsp case ms of Nothing -> return () Just realStatus -> logger req realStatus mlen T.tickle th return ret else do _ <- sendRsp conn ii ver s hs RspNoBody logger req s Nothing T.tickle th return isPersist where defServer = settingsServerName settings logger = settingsLogger settings ver = httpVersion req s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0 th = threadHandle ii dc = dateCacher ii addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr (isPersist,isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked) isHead = requestMethod req == H.methodHead rsp = case response of ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th) ResponseBuilder _ _ b | isHead -> RspNoBody | otherwise -> RspBuilder b needsChunked ResponseStream _ _ fb | isHead -> RspNoBody | otherwise -> RspStream fb needsChunked th ResponseRaw raw _ -> RspRaw raw src (T.tickle th) ret = case response of ResponseFile {} -> isPersist ResponseBuilder {} -> isKeepAlive ResponseStream {} -> isKeepAlive ResponseRaw {} -> False ---------------------------------------------------------------- sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders sanitizeHeaders = map (sanitize <$>) where sanitize v | containsNewlines v = sanitizeHeaderValue v -- slow path | otherwise = v -- fast path {-# INLINE containsNewlines #-} containsNewlines :: ByteString -> Bool containsNewlines = S.any (\w -> w == _cr || w == _lf) {-# INLINE sanitizeHeaderValue #-} sanitizeHeaderValue :: ByteString -> ByteString sanitizeHeaderValue v = case S8.lines $ S.filter (/= _cr) v of [] -> "" x : xs -> S8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs) where addSpaceIfMissing line = case S8.uncons line of Nothing -> Nothing Just (first, _) | first == ' ' || first == '\t' -> Just line | otherwise -> Just $ " " <> line ---------------------------------------------------------------- data Rsp = RspNoBody | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ()) | RspBuilder Builder Bool | RspStream StreamingBody Bool T.Handle | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ()) ---------------------------------------------------------------- sendRsp :: Connection -> InternalInfo -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Rsp -> IO (Maybe H.Status, Maybe Integer) ---------------------------------------------------------------- sendRsp conn _ ver s hs RspNoBody = do -- Not adding Content-Length. -- User agents treats it as Content-Length: 0. composeHeader ver s hs >>= connSendAll conn return (Just s, Nothing) ---------------------------------------------------------------- sendRsp conn _ ver s hs (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? ---------------------------------------------------------------- sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newBlazeRecv $ reuseBufferStrategy $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn) let send builder = do popper <- recv builder let loop = do bs <- popper unless (S.null bs) $ do sendFragment conn th bs loop loop sendChunk | needsChunked = send . chunkedTransferEncoding | otherwise = send send header streamingBody sendChunk (sendChunk flush) when needsChunked $ send chunkedTransferTerminator mbs <- finish maybe (return ()) (sendFragment conn th) mbs return (Just s, Nothing) -- fixme: can we tell the actual sent bytes? ---------------------------------------------------------------- sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do withApp recv send return (Nothing, Nothing) where recv = do bs <- src unless (S.null bs) tickle return bs send bs = connSendAll conn bs >> tickle ---------------------------------------------------------------- -- 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 where beg = filePartOffset part len = filePartByteCount part hs = addContentHeadersForFilePart hs0 part ---------------------------------------------------------------- -- Simple WAI applications. -- Status is ignored sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do efinfo <- E.try $ fileInfo ii path case efinfo of Left (_ex :: E.IOException) -> #ifdef WARP_DEBUG 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 ---------------------------------------------------------------- sendRspFile2XX :: Connection -> InternalInfo -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> FilePath -> Integer -> Integer -> Bool -> IO () -> IO (Maybe H.Status, Maybe Integer) sendRspFile2XX conn ii ver s hs path beg len isHead hook | isHead = sendRsp conn ii ver s hs RspNoBody | otherwise = do lheader <- composeHeader ver s hs #ifdef WINDOWS let fid = FileId path Nothing hook' = hook #else (mfd, hook') <- case fdCacher ii of -- settingsFdCacheDuration is 0 Nothing -> return (Nothing, hook) Just fdc -> do (fd, fresher) <- F.getFd fdc path return (Just fd, hook >> fresher) let fid = FileId path mfd #endif connSendFile conn fid beg len hook' [lheader] return (Just s, Just len) 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) where s = H.notFound404 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" ---------------------------------------------------------------- ---------------------------------------------------------------- -- | Use 'connSendAll' to send this data while respecting timeout rules. sendFragment :: Connection -> T.Handle -> ByteString -> IO () sendFragment Connection { connSendAll = send } th bs = do T.resume th send bs T.pause th -- We pause timeouts before passing control back to user code. This ensures -- that a timeout will only ever be executed when Warp is in control. We -- also make sure to resume the timeout after the completion of user code -- so that we can kill idle connections. ---------------------------------------------------------------- infoFromRequest :: Request -> IndexedHeader -> (Bool -- isPersist ,Bool) -- isChunked infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req) checkPersist :: Request -> IndexedHeader -> Bool checkPersist req reqidxhdr | ver == H.http11 = checkPersist11 conn | otherwise = checkPersist10 conn where ver = httpVersion req conn = reqidxhdr ! fromEnum ReqConnection checkPersist11 (Just x) | CI.foldCase x == "close" = False checkPersist11 _ = True checkPersist10 (Just x) | CI.foldCase x == "keep-alive" = True checkPersist10 _ = False checkChunk :: Request -> Bool checkChunk req = httpVersion req == H.http11 ---------------------------------------------------------------- -- Used for ResponseBuilder and ResponseSource. -- Don't use this for ResponseFile since this logic does not fit -- for ResponseFile. For instance, isKeepAlive should be True in some cases -- even if the response header does not have Content-Length. -- -- Content-Length is specified by a reverse proxy. -- Note that CGI does not specify Content-Length. infoFromResponse :: IndexedHeader -> (Bool,Bool) -> (Bool,Bool) infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked) where needsChunked = isChunked && not hasLength isKeepAlive = isPersist && (isChunked || hasLength) hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength ---------------------------------------------------------------- hasBody :: H.Status -> Bool hasBody s = sc /= 204 && sc /= 304 && sc >= 200 where sc = H.statusCode s ---------------------------------------------------------------- addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders #if MIN_VERSION_http_types(0,9,0) addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs #else addTransferEncoding hdrs = ("transfer-encoding", "chunked") : hdrs #endif addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders addDate dc rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of Nothing -> do gmtdate <- D.getDate dc return $ (H.hDate, gmtdate) : hdrs Just _ -> return hdrs ---------------------------------------------------------------- -- | The version of Warp. warpVersion :: String warpVersion = showVersion Paths_warp.version addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of Nothing -> (H.hServer, serverName) : hdrs _ -> hdrs ---------------------------------------------------------------- -- | -- -- >>> replaceHeader "Content-Type" "new" [("content-type","old")] -- [("Content-Type","new")] replaceHeader :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs ---------------------------------------------------------------- composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder composeHeaderBuilder ver s hs True = byteString <$> composeHeader ver s (addTransferEncoding hs) composeHeaderBuilder ver s hs False = byteString <$> composeHeader ver s hs warp-3.1.12/Network/Wai/Handler/Warp/ResponseHeader.hs0000644000000000000000000000472112636712547020660 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Internal (create) import qualified Data.CaseInsensitive as CI import Data.List (foldl') import Data.Word (Word8) import Foreign.Ptr import GHC.Storable import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Buffer (copy) ---------------------------------------------------------------- composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do ptr1 <- copyStatus ptr httpversion status ptr2 <- copyHeaders ptr1 responseHeaders void $ copyCRLF ptr2 where !len = 17 + slen + foldl' fieldLength 0 responseHeaders fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4 !slen = S.length $ H.statusMessage status httpVer11 :: ByteString httpVer11 = "HTTP/1.1 " httpVer10 :: ByteString httpVer10 = "HTTP/1.0 " {-# INLINE copyStatus #-} copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) copyStatus !ptr !httpversion !status = do ptr1 <- copy ptr httpVer writeWord8OffPtr ptr1 0 (zero + fromIntegral r2) writeWord8OffPtr ptr1 1 (zero + fromIntegral r1) writeWord8OffPtr ptr1 2 (zero + fromIntegral r0) writeWord8OffPtr ptr1 3 spc ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status) copyCRLF ptr2 where httpVer | httpversion == H.HttpVersion 1 1 = httpVer11 | otherwise = httpVer10 (q0,r0) = H.statusCode status `divMod` 10 (q1,r1) = q0 `divMod` 10 r2 = q1 `mod` 10 {-# INLINE copyHeaders #-} copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8) copyHeaders !ptr [] = return ptr copyHeaders !ptr (h:hs) = do ptr1 <- copyHeader ptr h copyHeaders ptr1 hs {-# INLINE copyHeader #-} copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8) copyHeader !ptr (k,v) = do ptr1 <- copy ptr (CI.original k) writeWord8OffPtr ptr1 0 colon writeWord8OffPtr ptr1 1 spc ptr2 <- copy (ptr1 `plusPtr` 2) v copyCRLF ptr2 {-# INLINE copyCRLF #-} copyCRLF :: Ptr Word8 -> IO (Ptr Word8) copyCRLF !ptr = do writeWord8OffPtr ptr 0 cr writeWord8OffPtr ptr 1 lf return $! ptr `plusPtr` 2 zero :: Word8 zero = 48 spc :: Word8 spc = 32 colon :: Word8 colon = 58 cr :: Word8 cr = 13 lf :: Word8 lf = 10 warp-3.1.12/Network/Wai/Handler/Warp/Run.hs0000644000000000000000000005540312636712547016520 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Arrow (first) import Control.Concurrent (threadDelay) import qualified Control.Concurrent as Conc (yield) import Control.Exception as E import Control.Monad (when, unless, void) import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.Char (chr) import Data.IP (toHostAddress, toHostAddress6) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP) import Network (sClose, Socket) import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6)) import qualified Network.Socket.ByteString as Sock import Network.Wai import Network.Wai.HTTP2 (HTTP2Application, promoteApplication) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Counter import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2) import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import System.Environment (getEnvironment) import System.IO.Error (isFullErrorType, ioeGetErrorType) #if WINDOWS import Network.Wai.Handler.Warp.Windows #else import System.Posix.IO (FdOption(CloseOnExec), setFdOption) import Network.Socket (fdSocket) #endif -- | Creating 'Connection' for plain HTTP based on a given socket. socketConnection :: Socket -> IO Connection socketConnection s = do bufferPool <- newBufferPool writeBuf <- allocateBuffer bufferSize let sendall = Sock.sendAll s return Connection { connSendMany = Sock.sendMany s , connSendAll = sendall , connSendFile = sendFile s writeBuf bufferSize sendall , connClose = sClose s >> freeBuffer writeBuf , connRecv = receive s bufferPool , connRecvBuf = receiveBuf s , connWriteBuffer = writeBuf , connBufferSize = bufferSize } #if __GLASGOW_HASKELL__ < 702 allowInterrupt :: IO () allowInterrupt = unblock $ return () #endif -- Composition over two arguments at once; used for runHTTP2\*. (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d f .: g = curry $ f . uncurry g -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO () run port = runServe port . serveDefault -- | Serve an 'HTTP2Application' and an 'Application' together on the given -- port. runHTTP2 :: Port -> HTTP2Application -> Application -> IO () runHTTP2 port = runServe port .: serveHTTP2 -- | The generalized form of 'run'. runServe :: Port -> ServeConnection -> IO () runServe p = runServeSettings defaultSettings { settingsPort = p } -- | Run an 'Application' on the port present in the @PORT@ -- environment variable. Uses the 'Port' given when the variable is unset. -- This calls 'runSettings' with 'defaultSettings'. -- -- Since 3.0.9 runEnv :: Port -> Application -> IO () runEnv port = runServeEnv port . serveDefault -- | The HTTP\/2-aware form of 'runEnv'. runHTTP2Env :: Port -> HTTP2Application -> Application -> IO () runHTTP2Env port = runServeEnv port .: serveHTTP2 -- | The generalized form of 'runEnv'. runServeEnv :: Port -> ServeConnection -> IO () runServeEnv p serveConn = do mp <- lookup "PORT" <$> getEnvironment maybe (runServe p serveConn) runReadPort mp where runReadPort :: String -> IO () runReadPort sp = case reads sp of ((p', _):_) -> runServe p' serveConn _ -> fail $ "Invalid value in $PORT: " ++ sp -- | Run an 'Application' with the given 'Settings'. -- This opens a listen socket on the port defined in 'Settings' and -- calls 'runSettingsSocket'. runSettings :: Settings -> Application -> IO () runSettings set = runServeSettings set . serveDefault -- | The HTTP\/2-aware form of 'runSettings'. runHTTP2Settings :: Settings -> HTTP2Application -> Application -> IO () runHTTP2Settings set = runServeSettings set .: serveHTTP2 -- | The generalized form of 'runSettings'. runServeSettings :: Settings -> ServeConnection -> IO () runServeSettings set serveConn = withSocketsDo $ bracket (bindPortTCP (settingsPort set) (settingsHost set)) sClose (\socket -> do setSocketCloseOnExec socket runServeSettingsSocket set socket serveConn) -- | This installs a shutdown handler for the given socket and -- calls 'runSettingsConnection' with the default connection setup action -- which handles plain (non-cipher) HTTP. -- When the listen socket in the second argument is closed, all live -- connections are gracefully shut down. -- -- The supplied socket can be a Unix named socket, which -- can be used when reverse HTTP proxying into your application. -- -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO () runSettingsSocket set socket = runServeSettingsSocket set socket . serveDefault -- | The HTTP\/2-aware form of 'runSettingsSocket'. runHTTP2SettingsSocket :: Settings -> Socket -> HTTP2Application -> Application -> IO () runHTTP2SettingsSocket set socket = runServeSettingsSocket set socket .: serveHTTP2 -- | The generalized form of 'runSettingsSocket'. runServeSettingsSocket :: Settings -> Socket -> ServeConnection -> IO () runServeSettingsSocket set socket serveConn = do settingsInstallShutdownHandler set closeListenSocket runServeSettingsConnection set getConn serveConn where getConn = do #if WINDOWS (s, sa) <- windowsThreadBlockHack $ accept socket #else (s, sa) <- accept socket #endif setSocketCloseOnExec s conn <- socketConnection s return (conn, sa) closeListenSocket = sClose socket -- | The connection setup action would be expensive. A good example -- is initialization of TLS. -- So, this converts the connection setup action to the connection maker -- which will be executed after forking a new worker thread. -- Then this calls 'runSettingsConnectionMaker' with the connection maker. -- This allows the expensive computations to be performed -- in a separate worker thread instead of the main server loop. -- -- Since 1.3.5 runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () runSettingsConnection set getConn = runServeSettingsConnection set getConn . serveDefault -- | The generalized form of 'runSettingsConnection'. runServeSettingsConnection :: Settings -> IO (Connection, SockAddr) -> ServeConnection -> IO () runServeSettingsConnection set getConn serveConn = runServeSettingsConnectionMaker set getConnMaker serveConn where getConnMaker = do (conn, sa) <- getConn return (return conn, sa) -- | This modifies the connection maker so that it returns 'TCP' for 'Transport' -- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'. runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () runSettingsConnectionMaker set getConnMaker = runServeSettingsConnectionMaker set getConnMaker . serveDefault -- | The generalized form of 'runSettingsConnectionMaker'. runServeSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> ServeConnection -> IO () runServeSettingsConnectionMaker x y = runServeSettingsConnectionMakerSecure x (toTCP <$> y) where toTCP = first ((, TCP) <$>) ---------------------------------------------------------------- -- | The core run function which takes 'Settings', -- a connection maker and 'Application'. -- The connection maker can return a connection of either plain HTTP -- or HTTP over TLS. -- -- Since 2.1.4 runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO () runSettingsConnectionMakerSecure set getConnMaker = runServeSettingsConnectionMakerSecure set getConnMaker . serveDefault -- | The generalized form of 'runSettingsConnectionMakerSecure'. runServeSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> ServeConnection -> IO () runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do settingsBeforeMainLoop set counter <- newCounter withII $ acceptConnection set getConnMaker serveConn counter where withII action = D.withDateCache $ \dc -> F.withFdCache fdCacheDurationInSeconds $ \fc -> I.withFileInfoCache fdFileInfoDurationInSeconds $ \get -> withTimeoutManager $ \tm -> do let ii0 = InternalInfo undefined tm fc get dc -- fixme: undefined action ii0 fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000 fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm Nothing -> bracket (T.initialize $ settingsTimeout set * 1000000) T.stopManager f -- Note that there is a thorough discussion of the exception safety of the -- following code at: https://github.com/yesodweb/wai/issues/146 -- -- We need to make sure of two things: -- -- 1. Asynchronous exceptions are not blocked entirely in the main loop. -- Doing so would make it impossible to kill the Warp thread. -- -- 2. Once a connection maker is received via acceptNewConnection, the -- connection is guaranteed to be closed, even in the presence of -- async exceptions. -- -- Our approach is explained in the comments below. acceptConnection :: Settings -> IO (IO (Connection, Transport), SockAddr) -> ServeConnection -> Counter -> InternalInfo -> IO () acceptConnection set getConnMaker serveConn counter ii0 = do -- First mask all exceptions in acceptLoop. This is necessary to -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose. void $ mask_ acceptLoop gracefulShutdown counter where acceptLoop = do -- Allow async exceptions before receiving the next connection maker. allowInterrupt -- acceptNewConnection will try to receive the next incoming -- request. It returns a /connection maker/, not a connection, -- since in some circumstances creating a working connection -- from a raw socket may be an expensive operation, and this -- expensive work should not be performed in the main event -- loop. An example of something expensive would be TLS -- negotiation. mx <- acceptNewConnection case mx of Nothing -> return () Just (mkConn, addr) -> do fork set mkConn addr serveConn counter ii0 acceptLoop acceptNewConnection = do ex <- try getConnMaker case ex of Right x -> return $ Just x Left e -> do settingsOnException set Nothing $ toException e if isFullErrorType (ioeGetErrorType e) then do -- "resource exhausted (Too many open files)" may -- happen by accept(). Wait a second hoping that -- resource will be available. threadDelay 1000000 acceptNewConnection else -- Assuming the listen socket is closed. return Nothing -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown). fork :: Settings -> IO (Connection, Transport) -> SockAddr -> ServeConnection -> Counter -> InternalInfo -> IO () fork set mkConn addr serveConn counter ii0 = settingsFork set $ \ unmask -> -- Run the connection maker to get a new connection, and ensure -- that the connection is closed. If the mkConn call throws an -- exception, we will leak the connection. If the mkConn call is -- vulnerable to attacks (e.g., Slowloris), we do nothing to -- protect the server. It is therefore vital that mkConn is well -- vetted. -- -- We grab the connection before registering timeouts since the -- timeouts will be useless during connection creation, due to the -- fact that async exceptions are still masked. bracket mkConn closeConn $ \(conn, transport) -> -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit. bracket (T.registerKillThread (timeoutManager ii0)) T.cancel $ \th -> let ii = ii0 { threadHandle = th } -- We now have fully registered a connection close handler -- in the case of all exceptions, so it is safe to one -- again allow async exceptions. in unmask . -- Call the user-supplied on exception code if any -- exceptions are thrown. handle (settingsOnException set Nothing) . -- Call the user-supplied code for connection open and close events bracket (onOpen addr) (onClose addr) $ \goingon -> -- Actually serve this connection. -- bracket with closeConn above ensures the connection is closed. when goingon $ serveConn conn ii addr transport set where closeConn (conn, _transport) = connClose conn onOpen adr = increase counter >> settingsOnOpen set adr onClose adr _ = decrease counter >> settingsOnClose set adr -- The type of a function to serve a fully-prepared connection. type ServeConnection = Connection -> InternalInfo -> SockAddr -> Transport -> Settings -> IO () -- Serve an HTTP\/2-unaware Application to a connection over any HTTP version. serveDefault :: Application -> ServeConnection serveDefault app = serveHTTP2 (promoteApplication app) app -- Serve an HTTP\/2-aware application over HTTP\/2 or a backup 'Application' -- over HTTP\/1.1 or HTTP\/1. serveHTTP2 :: HTTP2Application -> Application -> ServeConnection serveHTTP2 app2 app conn ii origAddr transport settings = do -- fixme: Upgrading to HTTP/2 should be supported. (h2,bs) <- if isHTTP2 transport then return (True, "") else do bs0 <- connRecv conn if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0 then return (True, bs0) else return (False, bs0) if settingsHTTP2Enabled settings && h2 then do recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn) -- fixme: origAddr http2 conn ii origAddr transport settings recvN app2 else do istatus <- newIORef False src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings)) writeIORef istatus True leftoverSource src bs addr <- getProxyProtocolAddr src http1 addr istatus src `E.catch` \e -> do sendErrorResponse addr istatus e throwIO (e :: SomeException) where getProxyProtocolAddr src = case settingsProxyProtocol settings of ProxyProtocolNone -> return origAddr ProxyProtocolRequired -> do seg <- readSource src parseProxyProtocolHeader src seg ProxyProtocolOptional -> do seg <- readSource src if S.isPrefixOf "PROXY " seg then parseProxyProtocolHeader src seg else do leftoverSource src seg return origAddr parseProxyProtocolHeader src seg = do let (header,seg') = S.break (== 0x0d) seg -- 0x0d == CR maybeAddr = case S.split 0x20 header of -- 0x20 == space ["PROXY","TCP4",clientAddr,_,clientPort,_] -> case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of [a] -> Just (SockAddrInet (readInt clientPort) (toHostAddress a)) _ -> Nothing ["PROXY","TCP6",clientAddr,_,clientPort,_] -> case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of [a] -> Just (SockAddrInet6 (readInt clientPort) 0 (toHostAddress6 a) 0) _ -> Nothing ("PROXY":"UNKNOWN":_) -> Just origAddr _ -> Nothing case maybeAddr of Nothing -> throwIO (BadProxyHeader (decodeAscii header)) Just a -> do leftoverSource src (S.drop 2 seg') -- drop CRLF return a decodeAscii = map (chr . fromEnum) . S.unpack th = threadHandle ii shouldSendErrorResponse se | Just ConnectionClosedByPeer <- fromException se = False | otherwise = True sendErrorResponse addr istatus e = do status <- readIORef istatus when (shouldSendErrorResponse e && status) $ void $ sendResponse settings conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e) dummyreq addr = defaultRequest { remoteHost = addr } errorResponse e = settingsOnExceptionResponse settings e http1 addr istatus src = do (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest settings conn ii addr src let req = req' { isSecure = isTransportSecure transport } keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush `E.catch` \e -> do -- Call the user-supplied exception handlers, passing the request. sendErrorResponse addr istatus e settingsOnException settings (Just req) e -- Don't throw the error again to prevent calling settingsOnException twice. return False when keepAlive $ http1 addr istatus src processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do -- Let the application run for as long as it wants T.pause th -- In the event that some scarce resource was acquired during -- creating the request, we need to make sure that we don't get -- an async exception before calling the ResponseSource. keepAliveRef <- newIORef $ error "keepAliveRef not filled" _ <- app req $ \res -> do T.resume th -- FIXME consider forcing evaluation of the res here to -- send more meaningful error messages to the user. -- However, it may affect performance. writeIORef istatus False keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res writeIORef keepAliveRef keepAlive return ResponseReceived keepAlive <- readIORef keepAliveRef -- We just send a Response and it takes a time to -- receive a Request again. If we immediately call recv, -- it is likely to fail and the IO manager works. -- It is very costly. So, we yield to another Haskell -- thread hoping that the next Request will arrive -- when this Haskell thread will be re-scheduled. -- This improves performance at least when -- the number of cores is small. Conc.yield if not keepAlive then return False else -- If there is an unknown or large amount of data to still be read -- from the request body, simple drop this connection instead of -- reading it all in to satisfy a keep-alive request. case settingsMaximumBodyFlush settings of Nothing -> do flushEntireBody nextBodyFlush T.resume th return True Just maxToRead -> do let tryKeepAlive = do -- flush the rest of the request body isComplete <- flushBody nextBodyFlush maxToRead if isComplete then do T.resume th return True else return False case mremainingRef of Just ref -> do remaining <- readIORef ref if remaining <= maxToRead then tryKeepAlive else return False Nothing -> tryKeepAlive flushEntireBody :: IO ByteString -> IO () flushEntireBody src = loop where loop = do bs <- src unless (S.null bs) loop flushBody :: IO ByteString -- ^ get next chunk -> Int -- ^ maximum to flush -> IO Bool -- ^ True == flushed the entire body, False == we didn't flushBody src = loop 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 -- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs setSocketCloseOnExec :: Socket -> IO () #if WINDOWS setSocketCloseOnExec _ = return () #else setSocketCloseOnExec socket = setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True #endif gracefulShutdown :: Counter -> IO () gracefulShutdown counter = waitForZero counter warp-3.1.12/Network/Wai/Handler/Warp/SendFile.hs0000644000000000000000000001111112636712547017431 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Network.Wai.Handler.Warp.SendFile ( sendFile , readSendFile , packHeader -- for testing #ifndef WINDOWS , positionRead #endif ) where import Control.Monad (void) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Network.Socket (Socket) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Types #ifdef WINDOWS import Control.Monad (when) import Data.ByteString.Internal (ByteString(..)) import Foreign.ForeignPtr (newForeignPtr_) import Foreign.Ptr (plusPtr) import qualified System.IO as IO #else # if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) # endif import Control.Exception import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr) import Network.Sendfile import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd) import System.Posix.Types #endif ---------------------------------------------------------------- -- | Function to send a file based on sendfile() for Linux\/Mac\/FreeBSD. -- This makes use of the file descriptor cache. -- For other OSes, this is identical to 'readSendFile'. -- -- Since: 3.1.0 sendFile :: Socket -> Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile #ifdef SENDFILEFD sendFile s _ _ _ fid off len act hdr = case mfid of -- settingsFdCacheDuration is 0 Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr Just fd -> sendfileFdWithHeader s fd (PartOfFile off len) act hdr where mfid = fileIdFd fid path = fileIdPath fid #else sendFile _ = readSendFile #endif ---------------------------------------------------------------- packHeader :: Buffer -> BufSize -> (ByteString -> IO ()) -> IO () -> [ByteString] -> Int -> IO Int packHeader _ _ _ _ [] n = return n packHeader buf siz send hook (bs:bss) n | len < room = do let dst = buf `plusPtr` n void $ copy dst bs packHeader buf siz send hook bss (n + len) | otherwise = do let dst = buf `plusPtr` n (bs1, bs2) = BS.splitAt room bs void $ copy dst bs1 bufferIO buf siz send hook packHeader buf siz send hook (bs2:bss) 0 where len = BS.length bs room = siz - n mini :: Int -> Integer -> Int mini i n | fromIntegral i < n = i | otherwise = fromIntegral n -- | Function to send a file based on pread()\/send() for Unix. -- This makes use of the file descriptor cache. -- For Windows, this is emulated by 'Handle'. -- -- Since: 3.1.0 #ifdef WINDOWS readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers = do hn <- packHeader buf siz send hook headers 0 let room = siz - hn buf' = buf `plusPtr` hn IO.withBinaryFile path IO.ReadMode $ \h -> do IO.hSeek h IO.AbsoluteSeek off0 n <- IO.hGetBufSome h buf' (mini room len0) bufferIO buf (hn + n) send hook let n' = fromIntegral n fptr <- newForeignPtr_ buf loop h fptr (len0 - n') where path = fileIdPath fid loop h fptr len | len <= 0 = return () | otherwise = do n <- IO.hGetBufSome h buf (mini siz len) when (n /= 0) $ do let bs = PS fptr 0 n n' = fromIntegral n send bs hook loop h fptr (len - n') #else readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers = bracket setup teardown $ \fd -> do hn <- packHeader buf siz send hook headers 0 let room = siz - hn buf' = buf `plusPtr` hn n <- positionRead fd buf' (mini room len0) off0 bufferIO buf (hn + n) send hook let n' = fromIntegral n loop fd (len0 - n') (off0 + n') where path = fileIdPath fid setup = case fileIdFd fid of Just fd -> return fd Nothing -> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True} teardown fd = case fileIdFd fid of Just _ -> return () Nothing -> closeFd fd loop fd len off | len <= 0 = return () | otherwise = do n <- positionRead fd buf (mini siz len) off bufferIO buf n send let n' = fromIntegral n hook loop fd (len - n') (off + n') positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int positionRead fd buf siz off = fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off) foreign import ccall unsafe "pread" c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize #endif warp-3.1.12/Network/Wai/Handler/Warp/Settings.hs0000644000000000000000000001707012636712547017552 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-} {-# LANGUAGE PatternGuards, RankNTypes #-} {-# LANGUAGE ImpredicativeTypes, CPP #-} module Network.Wai.Handler.Warp.Settings where import Control.Concurrent (forkIOWithUnmask) import Control.Exception import Control.Monad (when, void) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Builder (byteString) #if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mappend) #endif import 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 qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types import qualified Paths_warp import System.IO (stderr) import System.IO.Error (ioeGetErrorType) -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create a 'Settings' value, use 'defaultSettings' -- and the various \'set\' functions to modify individual fields. For example: -- -- > setTimeout 20 defaultSettings data Settings = Settings { settingsPort :: Port -- ^ Port to listen on. Default value: 3000 , settingsHost :: HostPreference -- ^ Default value: HostIPv4 , settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , settingsOnExceptionResponse :: SomeException -> Response -- ^ A function to create `Response` when an exception occurs. -- -- Default: 500, text/plain, \"Something went wrong\" -- -- Since 2.0.3 , settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'. , settingsOnClose :: SockAddr -> IO () -- ^ What to do when a connection is close. Default: do nothing. , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0 , settingsBeforeMainLoop :: IO () -- ^ Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start -- running, or to drop permissions after binding to a restricted port. -- -- Default: do nothing. -- -- Since 1.3.6 , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO () -- ^ Code to fork a new thread to accept a connection. -- -- This may be useful if you need OS bound threads, or if -- you wish to develop an alternative threading model. -- -- Default: void . forkIOWithUnmask -- -- Since 3.0.4 , settingsNoParsePath :: Bool -- ^ Perform no parsing on the rawPathInfo. -- -- This is useful for writing HTTP proxies. -- -- Default: False -- -- Since 2.0.3 , settingsInstallShutdownHandler :: IO () -> IO () , settingsServerName :: ByteString -- ^ Default server name if application does not set one. -- -- Since 3.0.2 , settingsMaximumBodyFlush :: Maybe Int -- ^ See @setMaximumBodyFlush@. -- -- Since 3.0.3 , settingsProxyProtocol :: ProxyProtocol -- ^ Specify usage of the PROXY protocol. -- -- Since 3.0.5. , settingsSlowlorisSize :: Int -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048 -- -- Since 3.1.2. , settingsHTTP2Enabled :: Bool -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True -- -- Since 3.1.7. , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO () -- ^ A log function. Default: no action. -- -- Since 3.X.X. } -- | Specify usage of the PROXY protocol. data ProxyProtocol = ProxyProtocolNone -- ^ See @setProxyProtocolNone@. | ProxyProtocolRequired -- ^ See @setProxyProtocolRequired@. | ProxyProtocolOptional -- ^ See @setProxyProtocolOptional@. -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings defaultSettings = Settings { settingsPort = 3000 , settingsHost = "*4" , settingsOnException = defaultOnException , settingsOnExceptionResponse = defaultOnExceptionResponse , settingsOnOpen = const $ return True , settingsOnClose = const $ return () , settingsTimeout = 30 , settingsManager = Nothing , settingsFdCacheDuration = 0 , settingsFileInfoCacheDuration = 0 , settingsBeforeMainLoop = return () , settingsFork = void . forkIOWithUnmask , settingsNoParsePath = False , settingsInstallShutdownHandler = const $ return () , settingsServerName = S8.pack $ "Warp/" ++ showVersion Paths_warp.version , settingsMaximumBodyFlush = Just 8192 , settingsProxyProtocol = ProxyProtocolNone , settingsSlowlorisSize = 2048 , settingsHTTP2Enabled = True , settingsLogger = \_ _ _ -> return () } -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur -- under the normal course of the web server running. -- -- Since 2.1.3 defaultShouldDisplayException :: SomeException -> Bool defaultShouldDisplayException se | Just ThreadKilled <- fromException se = False | Just (_ :: InvalidRequest) <- fromException se = False | Just (ioeGetErrorType -> et) <- fromException se , et == ResourceVanished || et == InvalidArgument = False | Just TimeoutThread <- fromException se = False | otherwise = True -- | Printing an exception to standard error -- if `defaultShouldDisplayException` returns `True`. -- -- Since: 3.1.0 defaultOnException :: Maybe Request -> SomeException -> IO () defaultOnException _ e = when (defaultShouldDisplayException e) $ TIO.hPutStrLn stderr $ T.pack $ show e -- | Sending 400 for bad requests. Sending 500 for internal server errors. -- -- Since: 3.1.0 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request" | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong" -- | Exception handler for the debugging purpose. -- 500, text/plain, a showed exception. -- -- Since: 2.0.3.2 exceptionResponseForDebug :: SomeException -> Response exceptionResponseForDebug e = responseBuilder H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] $ byteString . S8.pack $ "Exception: " ++ show e warp-3.1.12/Network/Wai/Handler/Warp/Timeout.hs0000644000000000000000000001076412636712547017403 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Network.Wai.Handler.Warp.Timeout ( -- ** Types Manager , TimeoutAction , Handle -- ** Manager , initialize , stopManager , killManager , withManager -- ** Registration , register , registerKillThread -- ** Control , tickle , cancel , pause , resume -- ** Exceptions , TimeoutThread (..) ) where import Control.Concurrent (myThreadId) import qualified Control.Exception as E import Control.Reaper import Data.Typeable (Typeable) import Network.Wai.Handler.Warp.IORef (IORef) import qualified Network.Wai.Handler.Warp.IORef as I ---------------------------------------------------------------- -- | A timeout manager type Manager = Reaper [Handle] Handle -- | An action to be performed on timeout. type TimeoutAction = IO () -- | A handle used by 'Manager' data Handle = Handle !(IORef TimeoutAction) !(IORef State) data State = Active -- Manager turns it to Inactive. | Inactive -- Manager removes it with timeout action. | Paused -- Manager does not change it. | Canceled -- Manager removes it without timeout action. ---------------------------------------------------------------- -- | Creating timeout manager which works every N micro seconds -- where N is the first argument. initialize :: Int -> IO Manager initialize timeout = mkReaper defaultReaperSettings { reaperAction = mkListAction prune , reaperDelay = timeout } where prune m@(Handle actionRef stateRef) = do state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x)) case state of Inactive -> do onTimeout <- I.readIORef actionRef onTimeout `E.catch` ignoreAll return Nothing Canceled -> return Nothing _ -> return $ Just m inactivate Active = Inactive inactivate x = x ---------------------------------------------------------------- -- | Stopping timeout manager with onTimeout fired. stopManager :: Manager -> IO () stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire) where fire (Handle actionRef _) = do onTimeout <- I.readIORef actionRef onTimeout `E.catch` ignoreAll ignoreAll :: E.SomeException -> IO () ignoreAll _ = return () -- | Killing timeout manager immediately without firing onTimeout. killManager :: Manager -> IO () killManager = reaperKill ---------------------------------------------------------------- -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle register mgr onTimeout = do actionRef <- I.newIORef onTimeout stateRef <- I.newIORef Active let h = Handle actionRef stateRef reaperAdd mgr h return h -- | Registering a timeout action of killing this thread. registerKillThread :: Manager -> IO Handle registerKillThread m = do -- If we hold ThreadId, the stack and data of the thread is leaked. -- If we hold Weak ThreadId, the stack is released. However, its -- data is still leaked probably because of a bug of GHC. -- So, let's just use ThreadId and release ThreadId by -- overriding the timeout action by "cancel". tid <- myThreadId register m $ E.throwTo tid TimeoutThread data TimeoutThread = TimeoutThread deriving Typeable instance E.Exception TimeoutThread instance Show TimeoutThread where show TimeoutThread = "Thread killed by Warp's timeout reaper" ---------------------------------------------------------------- -- | Setting the state to active. -- 'Manager' turns active to inactive repeatedly. tickle :: Handle -> IO () tickle (Handle _ stateRef) = I.writeIORef stateRef Active -- | Setting the state to canceled. -- 'Manager' eventually removes this without timeout action. cancel :: Handle -> IO () cancel (Handle actionRef stateRef) = do I.writeIORef actionRef (return ()) -- ensuring to release ThreadId I.writeIORef stateRef Canceled -- | Setting the state to paused. -- 'Manager' does not change the value. pause :: Handle -> IO () pause (Handle _ stateRef) = I.writeIORef stateRef Paused -- | Setting the paused state to active. -- This is an alias to 'tickle'. resume :: Handle -> IO () resume = tickle ---------------------------------------------------------------- -- | Call the inner function with a timeout manager. withManager :: Int -- ^ timeout in microseconds -> (Manager -> IO a) -> IO a withManager timeout f = do -- FIXME when stopManager is available, use it man <- initialize timeout f man warp-3.1.12/Network/Wai/Handler/Warp/Types.hs0000644000000000000000000001264212636712547017056 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Types where import Control.Exception import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.Typeable (Typeable) import Data.Word (Word16, Word8) import Foreign.Ptr (Ptr) import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I import qualified Network.Wai.Handler.Warp.Timeout as T #ifndef WINDOWS import System.Posix.Types (Fd) #endif ---------------------------------------------------------------- -- | TCP port number. type Port = Int ---------------------------------------------------------------- -- | The type for header value used with 'HeaderName'. type HeaderValue = ByteString ---------------------------------------------------------------- -- | Error types for bad 'Request'. data InvalidRequest = NotEnoughLines [String] | BadFirstLine String | NonHttp | IncompleteHeaders | ConnectionClosedByPeer | OverLargeHeader | BadProxyHeader String deriving (Eq, Typeable) instance Show InvalidRequest where show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs show (BadFirstLine s) = "Warp: Invalid first line of request: " ++ show s show NonHttp = "Warp: Request line specified a non-HTTP request" show IncompleteHeaders = "Warp: Request headers did not finish transmission" show ConnectionClosedByPeer = "Warp: Client closed connection prematurely" show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection." show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s instance Exception InvalidRequest ---------------------------------------------------------------- #ifdef WINDOWS type Fd = () #endif -- | Data type to abstract file identifiers. -- On Unix, a file descriptor would be specified to make use of -- the file descriptor cache. -- -- Since: 3.1.0 data FileId = FileId { fileIdPath :: FilePath , fileIdFd :: Maybe Fd } -- | fileid, offset, length, hook action, HTTP headers -- -- Since: 3.1.0 type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- | 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 -- | Type for the action to receive input data with a buffer. -- The result boolean indicates whether or not the buffer is fully filled. type RecvBuf = Buffer -> BufSize -> IO Bool -- | Data type to manipulate IO actions for connections. -- This is used to abstract IO actions for plain HTTP and HTTP over TLS. data Connection = Connection { -- | This is not used at this moment. connSendMany :: [ByteString] -> IO () -- | The sending function. , connSendAll :: ByteString -> IO () -- | The sending function for files in HTTP/1.1. , connSendFile :: SendFile -- | The connection closing function. , connClose :: IO () -- | The connection receiving function. This returns "" for EOF. , connRecv :: Recv -- | The connection receiving function. This tries to fill the buffer. -- This returns when the buffer is filled or reaches EOF. , connRecvBuf :: RecvBuf -- | The write buffer. , connWriteBuffer :: Buffer -- | The size of the write buffer. , connBufferSize :: BufSize } ---------------------------------------------------------------- -- | Internal information. data InternalInfo = InternalInfo { threadHandle :: T.Handle , timeoutManager :: T.Manager , fdCacher :: Maybe F.MutableFdCache , fileInfo :: FilePath -> IO I.FileInfo , dateCacher :: D.DateCache } ---------------------------------------------------------------- -- | Type for input streaming. data Source = Source !(IORef ByteString) !(IO ByteString) mkSource :: IO ByteString -> IO Source mkSource func = do ref <- newIORef S.empty return $! Source ref func readSource :: Source -> IO ByteString readSource (Source ref func) = do bs <- readIORef ref if S.null bs then func else do writeIORef ref S.empty return bs -- | Read from a Source, ignoring any leftovers. readSource' :: Source -> IO ByteString readSource' (Source _ func) = func leftoverSource :: Source -> ByteString -> IO () leftoverSource (Source ref _) bs = writeIORef ref bs readLeftoverSource :: Source -> IO ByteString readLeftoverSource (Source ref _) = readIORef ref ---------------------------------------------------------------- -- | What kind of transport is used for this connection? data Transport = TCP -- ^ Plain channel: TCP | TLS { tlsMajorVersion :: Int , tlsMinorVersion :: Int , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301 , tlsChiperID :: Word16 } -- ^ Encrypted channel: TLS or SSL isTransportSecure :: Transport -> Bool isTransportSecure TCP = False isTransportSecure _ = True warp-3.1.12/Network/Wai/Handler/Warp/Windows.hs0000644000000000000000000000106512636712547017401 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Windows ( windowsThreadBlockHack ) where #if WINDOWS import Control.Exception import Control.Concurrent.MVar import Control.Concurrent import Control.Monad windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack act = do var <- newEmptyMVar :: IO (MVar (Either SomeException a)) void . forkIO $ try act >>= putMVar var res <- takeMVar var case res of Left e -> throwIO e Right r -> return r #else windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack = id #endif warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/0000755000000000000000000000000012636712547016252 5ustar0000000000000000warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs0000644000000000000000000000205712636712547020762 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where import Data.ByteString (ByteString) import Network.HTTP2 ---------------------------------------------------------------- goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString goawayFrame sid etype debugmsg = encodeFrame einfo frame where einfo = encodeInfo id 0 frame = GoAwayFrame sid etype debugmsg resetFrame :: ErrorCodeId -> StreamId -> ByteString resetFrame etype sid = encodeFrame einfo frame where einfo = encodeInfo id sid frame = RSTStreamFrame etype settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist where einfo = encodeInfo func 0 pingFrame :: ByteString -> ByteString pingFrame bs = encodeFrame einfo $ PingFrame bs where einfo = encodeInfo setAck 0 windowUpdateFrame :: StreamId -> WindowSize -> ByteString windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz where einfo = encodeInfo id sid warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/HPACK.hs0000644000000000000000000000535112636712547017440 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} module Network.Wai.Handler.Warp.HTTP2.HPACK where import Control.Arrow (first) import qualified Control.Exception as E import qualified Data.ByteString as B import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Char8 as B8 import Data.CaseInsensitive (foldedCase) import Data.IORef (readIORef, writeIORef) import Network.HPACK import qualified Network.HTTP.Types as H import Network.HTTP2 import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Response import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types -- $setup -- >>> :set -XOverloadedStrings -- Set-Cookie: contains only one cookie value. -- So, we don't need to split it. hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> H.Status -> H.ResponseHeaders -> IO Builder hpackEncodeHeader ctx ii settings s h = do hdr1 <- addServerAndDate h let hdr2 = (":status", status) : map (first foldedCase) hdr1 hpackEncodeRawHeaders ctx hdr2 where status = B8.pack $ show $ H.statusCode $ s dc = dateCacher ii rspidxhdr = indexResponseHeader h defServer = S.settingsServerName settings addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase) hpackEncodeRawHeaders :: Context -> [(B.ByteString, B.ByteString)] -> IO Builder hpackEncodeRawHeaders Context{encodeDynamicTable} hdr = do ehdrtbl <- readIORef encodeDynamicTable (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr writeIORef encodeDynamicTable ehdrtbl' return builder ---------------------------------------------------------------- hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do hdrtbl <- readIORef decodeDynamicTable (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup writeIORef decodeDynamicTable hdrtbl' return $ concatCookie hdr where cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header" -- | -- -- >>> concatCookie [("foo","bar")] -- [("foo","bar")] -- >>> concatCookie [("cookie","a=b"),("foo","bar"),("cookie","c=d"),("cookie","e=f")] -- [("foo","bar"),("cookie","a=b; c=d; e=f")] concatCookie :: HeaderList -> HeaderList concatCookie = collect [] where collect cookies (("cookie",c):rest) = collect (cookies ++ [c]) rest collect cookies (h:rest) = h : collect cookies rest collect [] [] = [] collect cookies [] = [("cookie", B.intercalate "; " cookies)] warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/Manager.hs0000644000000000000000000000453512636712547020167 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | A thread pool manager. -- The manager has responsibility to spawn and kill -- worker threads. module Network.Wai.Handler.Warp.HTTP2.Manager ( Manager , start , setAction , stop , spawnAction , replaceWithAction ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Concurrent import Control.Concurrent.STM import Control.Monad (void) import Data.Set (Set) import qualified Data.Set as Set import Network.Wai.Handler.Warp.IORef ---------------------------------------------------------------- data Command = Stop | Spawn | Replace ThreadId data Manager = Manager (TQueue Command) (IORef (IO ())) -- | Starting a thread pool manager. -- Its action is initially set to 'return ()' and should be set -- by 'setAction'. This allows that the action can include -- the manager itself. start :: IO Manager start = do tset <- newThreadSet q <- newTQueueIO ref <- newIORef (return ()) void $ forkIO $ go q tset ref return $ Manager q ref where go q tset ref = do x <- atomically $ readTQueue q case x of Stop -> kill tset Spawn -> next Replace oldtid -> do del tset oldtid next where next = do action <- readIORef ref newtid <- forkIO action add tset newtid go q tset ref setAction :: Manager -> IO () -> IO () setAction (Manager _ ref) action = writeIORef ref action stop :: Manager -> IO () stop (Manager q _) = atomically $ writeTQueue q Stop spawnAction :: Manager -> IO () spawnAction (Manager q _) = atomically $ writeTQueue q Spawn replaceWithAction :: Manager -> ThreadId -> IO () replaceWithAction (Manager q _) tid = atomically $ writeTQueue q $ Replace tid ---------------------------------------------------------------- newtype ThreadSet = ThreadSet (IORef (Set ThreadId)) newThreadSet :: IO ThreadSet newThreadSet = ThreadSet <$> newIORef Set.empty add :: ThreadSet -> ThreadId -> IO () add (ThreadSet ref) tid = atomicModifyIORef' ref (\set -> (Set.insert tid set, ())) del :: ThreadSet -> ThreadId -> IO () del (ThreadSet ref) tid = atomicModifyIORef' ref (\set -> (Set.delete tid set, ())) kill :: ThreadSet -> IO () kill (ThreadSet ref) = Set.toList <$> readIORef ref >>= mapM_ killThread warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/Receiver.hs0000644000000000000000000003507712636712547020366 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad (when, unless, void) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Maybe (isJust) import Network.HTTP2 import Network.HTTP2.Priority import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.HPACK import Network.Wai.Handler.Warp.HTTP2.Request import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO () frameReceiver ctx mkreq recvN = loop `E.catch` sendGoaway where Context{ http2settings , streamTable , concurrency , continued , currentStreamId , inputQ , outputQ } = ctx sendGoaway e | Just (ConnectionError err msg) <- E.fromException e = do csid <- readIORef currentStreamId let frame = goawayFrame csid err msg enqueueControl outputQ 0 $ OGoaway frame | otherwise = return () sendReset err sid = do let frame = resetFrame err sid enqueueControl outputQ 0 $ OFrame frame loop = do hd <- recvN frameHeaderLength if BS.null hd then enqueueControl outputQ 0 OFinish else do cont <- processStreamGuardingError $ decodeFrameHeader hd when cont loop processStreamGuardingError (FrameHeaders, FrameHeader{streamId}) | isResponse streamId = E.throwIO $ ConnectionError ProtocolError "stream id should be odd" processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do mx <- readIORef continued case mx of Nothing -> do -- ignoring unknown frame consume payloadLength return True Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame" processStreamGuardingError (FramePushPromise, _) = E.throwIO $ ConnectionError ProtocolError "push promise is not allowed" processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do settings <- readIORef http2settings case checkFrameHeader settings typhdr of Left h2err -> case h2err of StreamError err sid -> do sendReset err sid consume payloadLength return True connErr -> E.throwIO connErr Right _ -> do ex <- E.try $ controlOrStream ftyp header case ex of Left (StreamError err sid) -> do sendReset err sid return True Left connErr -> E.throw connErr Right cont -> return cont controlOrStream ftyp header@FrameHeader{streamId, payloadLength} | isControl streamId = do pl <- recvN payloadLength control ftyp header pl ctx | otherwise = do checkContinued strm@Stream{streamState,streamContentLength,streamPrecedence} <- getStream pl <- recvN payloadLength state <- readIORef streamState state' <- stream ftyp header pl ctx state strm case state' of Open (NoBody hdr pri) -> do resetContinued case validateHeaders hdr of Just vh -> do when (isJust (vhCL vh) && vhCL vh /= Just 0) $ E.throwIO $ StreamError ProtocolError streamId writeIORef streamPrecedence $ toPrecedence pri writeIORef streamState HalfClosed let req = mkreq vh (return "") atomically $ writeTQueue inputQ $ Input strm req Nothing -> E.throwIO $ StreamError ProtocolError streamId Open (HasBody hdr pri) -> do resetContinued case validateHeaders hdr of Just vh -> do q <- newTQueueIO writeIORef streamPrecedence $ toPrecedence pri writeIORef streamState (Open (Body q)) writeIORef streamContentLength $ vhCL vh readQ <- newReadBody q bodySource <- mkSource readQ let req = mkreq vh (readSource bodySource) atomically $ writeTQueue inputQ $ Input strm req Nothing -> E.throwIO $ StreamError ProtocolError streamId s@(Open Continued{}) -> do setContinued writeIORef streamState s s -> do -- Idle, Open Body, HalfClosed, Closed resetContinued writeIORef streamState s return True where setContinued = writeIORef continued (Just streamId) resetContinued = writeIORef continued Nothing checkContinued = do mx <- readIORef continued case mx of Nothing -> return () Just sid | sid == streamId && ftyp == FrameContinuation -> return () | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow" getStream = do mstrm0 <- search streamTable streamId case mstrm0 of Just strm0 -> do when (ftyp == FrameHeaders) $ do st <- readIORef $ streamState strm0 when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed" return strm0 Nothing -> do when (ftyp `notElem` [FrameHeaders,FramePriority]) $ E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream" when (ftyp == FrameHeaders) $ do csid <- readIORef currentStreamId if streamId <= csid then E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease" else writeIORef currentStreamId streamId cnt <- readIORef concurrency when (cnt >= recommendedConcurrency) $ do -- Record that the stream is closed, rather than -- idle, so that receiving frames on it is only a -- stream error. consume payloadLength strm <- newStream concurrency streamId 0 writeIORef (streamState strm) $ Closed $ ResetByMe $ E.toException $ StreamError RefusedStream streamId insert streamTable streamId strm E.throwIO $ StreamError RefusedStream streamId ws <- initialWindowSize <$> readIORef http2settings newstrm <- newStream concurrency streamId (fromIntegral ws) when (ftyp == FrameHeaders) $ opened newstrm insert streamTable streamId newstrm return newstrm consume = void . recvN ---------------------------------------------------------------- control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool control FrameSettings header@FrameHeader{flags} bs Context{http2settings, outputQ} = do SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs case checkSettingsList alist of Just x -> E.throwIO x Nothing -> return () unless (testAck flags) $ do modifyIORef http2settings $ \old -> updateSettings old alist let frame = settingsFrame setAck [] enqueueControl outputQ 0 $ OSettings frame alist return True control FramePing FrameHeader{flags} bs Context{outputQ} = if testAck flags then E.throwIO $ ConnectionError ProtocolError "the ack flag of this ping frame must not be set" else do let frame = pingFrame bs enqueueControl outputQ 0 $ OFrame frame return True control FrameGoAway _ _ Context{outputQ} = do enqueueControl outputQ 0 OFinish return False control FrameWindowUpdate header bs Context{connectionWindow} = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs w <- (n +) <$> atomically (readTVar connectionWindow) when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31" atomically $ writeTVar connectionWindow w return True control _ _ _ _ = -- must not reach here return False ---------------------------------------------------------------- guardIt :: Either HTTP2Error a -> IO a guardIt x = case x of Left err -> E.throwIO err Right frame -> return frame checkPriority :: Priority -> StreamId -> IO () checkPriority p me | dep == me = E.throwIO $ StreamError ProtocolError me | otherwise = return () where dep = streamDependency p stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs pri <- case mp of Nothing -> return defaultPriority Just p -> do checkPriority p streamNumber return p let endOfStream = testEndStream flags endOfHeader = testEndHeader flags if endOfHeader then do hdr <- hpackDecodeHeader frag ctx return $ if endOfStream then Open (NoBody hdr pri) else Open (HasBody hdr pri) else do let !siz = BS.length frag return $ Open $ Continued [frag] siz 1 endOfStream pri stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q)) _ = do -- trailer is not supported. -- let's read and ignore it. HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs let endOfStream = testEndStream flags if endOfStream then do atomically $ writeTQueue q "" return HalfClosed else -- we don't support continuation here. E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported" stream FrameData header@FrameHeader{flags,payloadLength,streamId} bs Context{outputQ} s@(Open (Body q)) Stream{streamNumber,streamBodyLength,streamContentLength} = do DataFrame body <- guardIt $ decodeDataFrame header bs let endOfStream = testEndStream flags len0 <- readIORef streamBodyLength let !len = len0 + payloadLength writeIORef streamBodyLength len when (payloadLength /= 0) $ do let frame1 = windowUpdateFrame 0 payloadLength frame2 = windowUpdateFrame streamNumber payloadLength frame = frame1 `BS.append` frame2 enqueueControl outputQ 0 $ OFrame frame atomically $ writeTQueue q body if endOfStream then do mcl <- readIORef streamContentLength case mcl of Nothing -> return () Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId atomically $ writeTQueue q "" return HalfClosed else return s stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do let endOfHeader = testEndHeader flags rfrags' = frag : rfrags siz' = siz + BS.length frag n' = n + 1 when (siz' > 51200) $ -- fixme: hard coding: 50K E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big" when (n' > 10) $ -- fixme: hard coding E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented" if endOfHeader then do let hdrblk = BS.concat $ reverse rfrags' hdr <- hpackDecodeHeader hdrblk ctx return $ if endOfStream then Open (NoBody hdr pri) else Open (HasBody hdr pri) else return $ Open $ Continued rfrags' siz' n' endOfStream pri stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs w <- (n +) <$> atomically (readTVar streamWindow) when (isWindowOverflow w) $ E.throwIO $ StreamError FlowControlError streamId atomically $ writeTVar streamWindow w return s stream FrameRSTStream header bs _ _ strm = do RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs let cc = Reset e closed strm cc return $ Closed cc -- will be written to streamState again stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs checkPriority newpri streamNumber -- checkme: this should be tested oldpre <- readIORef streamPrecedence let !newpre = toPrecedence newpri writeIORef streamPrecedence newpre if isIdle s then do n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1)) -- fixme hard coding when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames" prepare outputQ streamNumber newpri else do mx <- delete outputQ streamNumber oldpre case mx of Nothing -> return () Just x -> enqueue outputQ streamNumber newpre x return s -- this ordering is important stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here" stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames" -- Ignore frames to streams we have just reset, per section 5.1. stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/Request.hs0000644000000000000000000001235112636712547020240 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module Network.Wai.Handler.Warp.HTTP2.Request ( mkRequest , newReadBody , MkReq , ValidHeaders(..) , validateHeaders ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Control.Concurrent.STM import Control.Monad (when) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import Data.CaseInsensitive (mk) import Data.IORef (IORef, readIORef, newIORef, writeIORef) import Data.Maybe (isJust) import qualified Data.Vault.Lazy as Vault #if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mempty) #endif import Data.Word8 (isUpper,_colon) import Network.HPACK import Network.HTTP.Types (RequestHeaders,hRange) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey) import Network.Wai.Handler.Warp.Types (InternalInfo(..)) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import qualified Network.Wai.Handler.Warp.Timeout as Timeout data ValidHeaders = ValidHeaders { vhMethod :: ByteString , vhPath :: ByteString , vhAuth :: Maybe ByteString , vhCL :: Maybe Int -- ^ Content-Length , vhHeader :: RequestHeaders } type MkReq = ValidHeaders -> IO ByteString -> Request mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq mkRequest ii settings addr (ValidHeaders m p ma _ hdr) body = req where (unparsedPath,query) = B8.break (=='?') p path = H.extractPath unparsedPath req = Request { requestMethod = m , httpVersion = http2ver , rawPathInfo = if S.settingsNoParsePath settings then unparsedPath else path , pathInfo = H.decodePathSegments path , rawQueryString = query , queryString = H.parseQuery query , requestHeaders = case ma of Nothing -> hdr Just h -> (mk "host", h) : hdr , isSecure = True , remoteHost = addr , requestBody = body , vault = vaultValue , requestBodyLength = ChunkedBody -- fixme , requestHeaderHost = ma , requestHeaderRange = lookup hRange hdr } th = threadHandle ii vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (fileInfo ii) Vault.empty ---------------------------------------------------------------- data Pseudo = Pseudo { colonMethod :: !(Maybe ByteString) , colonPath :: !(Maybe ByteString) , colonAuth :: !(Maybe ByteString) , contentLen :: !(Maybe ByteString) } emptyPseudo :: Pseudo emptyPseudo = Pseudo Nothing Nothing Nothing Nothing validateHeaders :: HeaderList -> Maybe ValidHeaders validateHeaders hs = case pseudo hs (emptyPseudo,id) of Just (Pseudo (Just m) (Just p) ma mcl, h) -> Just $ ValidHeaders m p ma (readInt <$> mcl) h _ -> Nothing where pseudo [] (p,b) = Just (p,b []) pseudo h@((k,v):kvs) (p,b) | k == ":method" = if isJust (colonMethod p) then Nothing else pseudo kvs (p { colonMethod = Just v },b) | k == ":path" = if isJust (colonPath p) then Nothing else pseudo kvs (p { colonPath = Just v },b) | k == ":authority" = if isJust (colonAuth p) then Nothing else pseudo kvs (p { colonAuth = Just v },b) | k == ":scheme" = pseudo kvs (p,b) -- fixme: how to store :scheme? | isPseudo k = Nothing | otherwise = normal h (p,b) normal [] (p,b) = Just (p,b []) normal ((k,v):kvs) (p,b) | isPseudo k = Nothing | k == "connection" = Nothing | k == "te" = if v == "trailers" then normal kvs (p, b . ((mk k,v) :)) else Nothing | k == "content-length" = normal kvs (p { contentLen = Just v }, b . ((mk k,v) :)) | k == "host" = if isJust (colonAuth p) then normal kvs (p,b) else normal kvs (p { colonAuth = Just v },b) | otherwise = case BS.find isUpper k of Nothing -> normal kvs (p, b . ((mk k,v) :)) Just _ -> Nothing isPseudo "" = False isPseudo k = BS.head k == _colon ---------------------------------------------------------------- newReadBody :: TQueue ByteString -> IO (IO ByteString) newReadBody q = do ref <- newIORef False return $ readBody q ref 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 warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/Sender.hs0000644000000000000000000004340012636712547020027 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns, CPP #-} {-# LANGUAGE NamedFieldPuns #-} module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Concurrent.MVar (putMVar) import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad (void, when) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B (int32BE) import qualified Data.ByteString.Builder.Extra as B import Data.Monoid ((<>)) import Foreign.Ptr import qualified Network.HTTP.Types as H import Network.HPACK (setLimitForEncoding) import Network.HTTP2 import Network.HTTP2.Priority import Network.Wai (FilePart(..)) import Network.Wai.HTTP2 (Trailers, promiseHeaders) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.HPACK import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.IORef import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types #ifdef WINDOWS import qualified System.IO as IO #else import Network.Wai.Handler.Warp.FdCache (getFd) import Network.Wai.Handler.Warp.SendFile (positionRead) import qualified Network.Wai.Handler.Warp.Timeout as T import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd) import System.Posix.Types (Fd) #endif ---------------------------------------------------------------- -- | The platform-specific type of an open file to stream from. On Windows we -- don't have pread, so this is just a Handle; on Unix platforms with pread, -- this is a file descriptor supplied by the fd cache. #ifdef WINDOWS type OpenFile = IO.Handle #else type OpenFile = Fd #endif data Leftover = LZero | LOne B.BufferWriter | LTwo BS.ByteString B.BufferWriter | LFile OpenFile Integer Integer (IO ()) ---------------------------------------------------------------- -- | Run the given action if the stream is not closed; handle any exceptions by -- resetting the stream. unlessClosed :: Connection -> Stream -> IO () -> IO Bool unlessClosed Connection{connSendAll} strm@Stream{streamState,streamNumber} body = E.handle resetStream $ do state <- readIORef streamState if (isClosed state) then return False else body >> return True where resetStream e = do closed strm (ResetByMe e) let rst = resetFrame InternalError streamNumber connSendAll rst return False getWindowSize :: TVar WindowSize -> TVar WindowSize -> IO WindowSize getWindowSize connWindow strmWindow = do -- Waiting that the connection window gets open. cw <- atomically $ do w <- readTVar connWindow check (w > 0) return w -- This stream window is greater than 0 thanks to the invariant. sw <- atomically $ readTVar strmWindow return $ min cw sw frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> IO () frameSender ctx@Context{outputQ,connectionWindow,encodeDynamicTable} conn@Connection{connWriteBuffer,connBufferSize,connSendAll} ii settings = go `E.catch` ignore where initialSettings = [(SettingsMaxConcurrentStreams,recommendedConcurrency)] initialFrame = settingsFrame id initialSettings bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength headerPayloadLim = connBufferSize - frameHeaderLength go = do connSendAll initialFrame loop -- ignoring the old priority because the value might be changed. loop = dequeue outputQ >>= \(_sid,pre,out) -> switch out pre ignore :: E.SomeException -> IO () ignore _ = return () switch OFinish _ = return () switch (OGoaway frame) _ = connSendAll frame switch (OSettings frame alist) _ = do connSendAll frame case lookup SettingsHeaderTableSize alist of Nothing -> return () Just siz -> do dyntbl <- readIORef encodeDynamicTable setLimitForEncoding siz dyntbl loop switch (OFrame frame) _ = do connSendAll frame loop switch (OResponse strm s h aux) pre = do writeIORef (streamPrecedence strm) pre -- fixme _ <- unlessClosed conn strm $ getWindowSize connectionWindow (streamWindow strm) >>= sendResponse strm s h aux loop switch (ONext strm curr) pre = do writeIORef (streamPrecedence strm) pre _ <- unlessClosed conn strm $ do lim <- getWindowSize connectionWindow (streamWindow strm) -- Data frame payload Next datPayloadLen mnext <- curr lim fillDataHeaderSend strm 0 datPayloadLen dispatchNext strm mnext loop switch (OPush oldStrm push mvar strm s h aux) pre = do writeIORef (streamPrecedence strm) pre -- fixme pushed <- unlessClosed conn oldStrm $ do lim <- getWindowSize connectionWindow (streamWindow strm) -- Write and send the promise. builder <- hpackEncodeCIHeaders ctx $ promiseHeaders push off <- pushContinue (streamNumber oldStrm) (streamNumber strm) builder flushN $ off + frameHeaderLength -- TODO(awpr): refactor sendResponse to be able to handle non-zero -- initial offsets and use that to potentially avoid the extra syscall. sendResponse strm s h aux lim putMVar mvar pushed loop -- Send the response headers and as much of the response as is immediately -- available; shared by normal responses and pushed streams. sendResponse :: Stream -> H.Status -> H.ResponseHeaders -> Aux -> WindowSize -> IO () sendResponse strm s h (Persist sq tvar) lim = do -- Header frame and Continuation frame let sid = streamNumber strm builder <- hpackEncodeHeader ctx ii settings s h len <- headerContinue sid builder False let total = len + frameHeaderLength (off, needSend) <- sendHeadersIfNecessary total let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillStreamBodyGetNext ii conn payloadOff lim sq tvar strm -- If no data was immediately available, avoid sending an -- empty data frame. if datPayloadLen > 0 then fillDataHeaderSend strm total datPayloadLen else when needSend $ flushN off dispatchNext strm mnext -- Send the stream's trailers and close the stream. sendTrailers :: Stream -> Trailers -> IO () sendTrailers strm trailers = do -- Trailers always indicate the end of a stream; send them in -- consecutive header+continuation frames and end the stream. Some -- clients dislike empty headers frames, so end the stream with an -- empty data frame instead, as recommended by the spec. toFlush <- case trailers of [] -> frameHeaderLength <$ fillFrameHeader FrameData 0 (streamNumber strm) (setEndStream defaultFlags) connWriteBuffer _ -> do builder <- hpackEncodeCIHeaders ctx trailers off <- headerContinue (streamNumber strm) builder True return (off + frameHeaderLength) -- 'closed' must be before 'flushN'. If not, the context would be -- switched to the receiver, resulting in the inconsistency of -- concurrency. closed strm Finished flushN toFlush -- Flush the connection buffer to the socket, where the first 'n' bytes of -- the buffer are filled. flushN :: Int -> IO () flushN n = bufferIO connWriteBuffer n connSendAll -- A flags value with the end-header flag set iff the argument is B.Done. maybeEndHeaders B.Done = setEndHeader defaultFlags maybeEndHeaders _ = defaultFlags -- Write PUSH_PROMISE and possibly CONTINUATION frames into the connection -- buffer, using the given builder as their contents; flush them to the -- socket as necessary. pushContinue sid newSid builder = do let builder' = B.int32BE (fromIntegral newSid) <> builder (len, signal) <- B.runBuilder builder' bufHeaderPayload headerPayloadLim let flag = maybeEndHeaders signal fillFrameHeader FramePushPromise len sid flag connWriteBuffer continue sid len signal -- Write HEADER and possibly CONTINUATION frames. headerContinue sid builder endOfStream = do (len, signal) <- B.runBuilder builder bufHeaderPayload headerPayloadLim let flag0 = maybeEndHeaders signal flag = if endOfStream then setEndStream flag0 else flag0 fillFrameHeader FrameHeaders len sid flag connWriteBuffer continue sid len signal continue _ len B.Done = return len continue sid len (B.More _ writer) = do flushN $ len + frameHeaderLength (len', signal') <- writer bufHeaderPayload headerPayloadLim let flag = maybeEndHeaders signal' fillFrameHeader FrameContinuation len' sid flag connWriteBuffer continue sid len' signal' continue sid len (B.Chunk bs writer) = do flushN $ len + frameHeaderLength let (bs1,bs2) = BS.splitAt headerPayloadLim bs len' = BS.length bs1 void $ copy bufHeaderPayload bs1 fillFrameHeader FrameContinuation len' sid defaultFlags connWriteBuffer if bs2 == "" then continue sid len' (B.More 0 writer) else continue sid len' (B.Chunk bs2 writer) -- True if the connection buffer has room for a 1-byte data frame. canFitDataFrame total = total + frameHeaderLength < connBufferSize -- Take the appropriate action based on the given 'Control': -- - If more output is immediately available, re-enqueue the stream in the -- output queue. -- - If the output is over and trailers are available, send them now and -- end the stream. -- - If we've drained the queue and handed the stream back to its waiter, -- do nothing. -- -- This is done after sending any part of the stream body, so it's shared -- by 'sendResponse' and @switch (ONext ...)@. dispatchNext :: Stream -> Control DynaNext -> IO () dispatchNext _ CNone = return () dispatchNext strm (CFinish trailers) = sendTrailers strm trailers dispatchNext strm (CNext next) = do let out = ONext strm next enqueueOrSpawnTemporaryWaiter strm outputQ out -- Send headers if there is not room for a 1-byte data frame, and return -- the offset of the next frame's first header byte and whether the headers -- still need to be sent. sendHeadersIfNecessary total | canFitDataFrame total = return (total, True) | otherwise = do flushN total return (0, False) fillDataHeaderSend strm otherLen datPayloadLen = do -- Data frame header let sid = streamNumber strm buf = connWriteBuffer `plusPtr` otherLen total = otherLen + frameHeaderLength + datPayloadLen fillFrameHeader FrameData datPayloadLen sid defaultFlags buf flushN total atomically $ do modifyTVar' connectionWindow (subtract datPayloadLen) modifyTVar' (streamWindow strm) (subtract datPayloadLen) fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf where hinfo = FrameHeader len flag sid ---------------------------------------------------------------- fillStreamBodyGetNext :: InternalInfo -> Connection -> Int -> WindowSize -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next fillStreamBodyGetNext ii Connection{connWriteBuffer,connBufferSize} off lim sq tvar strm = do let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (leftover, cont, len) <- runStreamBuilder ii datBuf room sq nextForStream ii connWriteBuffer connBufferSize sq tvar strm leftover cont len ---------------------------------------------------------------- runStreamBuilder :: InternalInfo -> Buffer -> BufSize -> TBQueue Sequence -> IO (Leftover, Maybe Trailers, BytesFilled) runStreamBuilder ii buf0 room0 sq = loop buf0 room0 0 where loop !buf !room !total = do mbuilder <- atomically $ tryReadTBQueue sq case mbuilder of Nothing -> return (LZero, Nothing, total) Just (SBuilder builder) -> do (len, signal) <- B.runBuilder builder buf room let !total' = total + len case signal of B.Done -> loop (buf `plusPtr` len) (room - len) total' B.More _ writer -> return (LOne writer, Nothing, total') B.Chunk bs writer -> return (LTwo bs writer, Nothing, total') Just (SFile path part) -> do (leftover, len) <- runStreamFile ii buf room path part let !total' = total + len case leftover of LZero -> loop (buf `plusPtr` len) (room - len) total' _ -> return (leftover, Nothing, total') Just SFlush -> return (LZero, Nothing, total) Just (SFinish trailers) -> return (LZero, Just trailers, total) -- | Open the file and start reading into the send buffer. runStreamFile :: InternalInfo -> Buffer -> BufSize -> FilePath -> FilePart -> IO (Leftover, BytesFilled) -- | Read the given (OS-specific) file representation into the buffer. On -- non-Windows systems this uses pread; on Windows this ignores the position -- because we use the Handle's internal read position instead (because it's not -- potentially shared with other readers). readOpenFile :: OpenFile -> Buffer -> BufSize -> Integer -> IO Int #ifdef WINDOWS runStreamFile _ buf room path part = do let start = filePartOffset part bytes = filePartByteCount part -- fixme: how to close Handle? GC does it at this moment. h <- IO.openBinaryFile path IO.ReadMode IO.hSeek h IO.AbsoluteSeek start fillBufFile buf room h start bytes (return ()) readOpenFile h buf room _ = IO.hGetBufSome h buf room #else runStreamFile ii buf room path part = do let start = filePartOffset part bytes = filePartByteCount part (fd, refresh) <- case fdCacher ii of Just fdcache -> getFd fdcache path Nothing -> do fd' <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True} th <- T.register (timeoutManager ii) (closeFd fd') return (fd', T.tickle th) fillBufFile buf room fd start bytes refresh readOpenFile = positionRead #endif -- | Read as much of the file as is currently available into the buffer, then -- return a 'Leftover' to indicate whether this file chunk has more data to -- send. If this read hit the end of the file range, return 'LZero'; otherwise -- return 'LFile' so this stream will continue reading from the file the next -- time it's pulled from the queue. fillBufFile :: Buffer -> BufSize -> OpenFile -> Integer -> Integer -> (IO ()) -> IO (Leftover, BytesFilled) fillBufFile buf room f start bytes refresh = do len <- readOpenFile f buf (mini room bytes) start refresh let len' = fromIntegral len leftover = if bytes > len' then LFile f (start + len') (bytes - len') refresh else LZero return (leftover, len) mini :: Int -> Integer -> Int mini i n | fromIntegral i < n = i | otherwise = fromIntegral n fillBufStream :: InternalInfo -> Buffer -> BufSize -> Leftover -> TBQueue Sequence -> TVar Sync -> Stream -> DynaNext fillBufStream ii buf0 siz0 leftover0 sq tvar strm lim0 = do let payloadBuf = buf0 `plusPtr` frameHeaderLength room0 = min (siz0 - frameHeaderLength) lim0 case leftover0 of LZero -> do (leftover, end, len) <- runStreamBuilder ii payloadBuf room0 sq getNext leftover end len LOne writer -> write writer payloadBuf room0 0 LTwo bs writer | BS.length bs <= room0 -> do buf1 <- copy payloadBuf bs let len = BS.length bs write writer buf1 (room0 - len) len | otherwise -> do let (bs1,bs2) = BS.splitAt room0 bs void $ copy payloadBuf bs1 getNext (LTwo bs2 writer) Nothing room0 LFile fd start bytes refresh -> do (leftover, len) <- fillBufFile payloadBuf room0 fd start bytes refresh getNext leftover Nothing len where getNext = nextForStream ii buf0 siz0 sq tvar strm write writer1 buf room sofar = do (len, signal) <- writer1 buf room case signal of B.Done -> do (leftover, end, extra) <- runStreamBuilder ii (buf `plusPtr` len) (room - len) sq let !total = sofar + len + extra getNext leftover end total B.More _ writer -> do let !total = sofar + len getNext (LOne writer) Nothing total B.Chunk bs writer -> do let !total = sofar + len getNext (LTwo bs writer) Nothing total nextForStream :: InternalInfo -> Buffer -> BufSize -> TBQueue Sequence -> TVar Sync -> Stream -> Leftover -> Maybe Trailers -> BytesFilled -> IO Next nextForStream _ _ _ _ tvar _ _ (Just trailers) len = do atomically $ writeTVar tvar $ SyncFinish return $ Next len $ CFinish trailers nextForStream ii buf siz sq tvar strm LZero Nothing len = do let out = ONext strm (fillBufStream ii buf siz LZero sq tvar strm) atomically $ writeTVar tvar $ SyncNext out return $ Next len CNone nextForStream ii buf siz sq tvar strm leftover Nothing len = return $ Next len (CNext (fillBufStream ii buf siz leftover sq tvar strm)) warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/Types.hs0000644000000000000000000002546512636712547017726 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards #-} module Network.Wai.Handler.Warp.HTTP2.Types where import Data.ByteString.Builder (Builder) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>), (<*>), pure) #endif import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar) import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Monad (void) import Control.Reaper import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.IntMap.Strict (IntMap, IntMap) import qualified Data.IntMap.Strict as M import qualified Network.HTTP.Types as H import Network.Wai (Request, FilePart) import Network.Wai.HTTP2 (PushPromise, Trailers) import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.Types import Network.HTTP2 import Network.HTTP2.Priority import Network.HPACK ---------------------------------------------------------------- http2ver :: H.HttpVersion http2ver = H.HttpVersion 2 0 isHTTP2 :: Transport -> Bool isHTTP2 TCP = False isHTTP2 tls = useHTTP2 where useHTTP2 = case tlsNegotiatedProtocol tls of Nothing -> False Just proto -> "h2-" `BS.isPrefixOf` proto || proto == "h2" ---------------------------------------------------------------- data Input = Input Stream Request ---------------------------------------------------------------- -- | The result of writing data from a stream's queue into the buffer. data Control a = CFinish Trailers -- ^ The stream has ended, and the trailers should be sent. | CNext a -- ^ The stream has more data immediately available, and we -- should re-enqueue it when the stream window becomes open. | CNone -- ^ The stream queue has been drained and we've handed it off -- to its dedicated waiter thread, which will re-enqueue it when -- more data is available. instance Show (Control a) where show (CFinish _) = "CFinish" show (CNext _) = "CNext" show CNone = "CNone" type DynaNext = WindowSize -> IO Next type BytesFilled = Int data Next = Next BytesFilled (Control DynaNext) data Output = OFinish -- ^ Terminate the connection. | OGoaway ByteString -- ^ Send a goaway frame and terminate the connection. | OSettings ByteString SettingsList -- ^ Update settings and send an ack settings frame. | OFrame ByteString -- ^ Send an entire pre-encoded frame. | OResponse Stream H.Status H.ResponseHeaders Aux -- ^ Send the headers and as much of the response as is immediately -- available. | OPush Stream PushPromise (MVar Bool) Stream H.Status H.ResponseHeaders Aux -- ^ Send a PUSH_PROMISE frame, then act like OResponse; signal the -- MVar whether the promise has been sent. | ONext Stream DynaNext -- ^ Send a chunk of the response. outputStream :: Output -> Stream outputStream (OResponse strm _ _ _) = strm outputStream (ONext strm _) = strm outputStream (OPush strm _ _ _ _ _ _) = strm outputStream _ = error "outputStream" ---------------------------------------------------------------- -- | An element on the queue between a running stream and the sender; the order -- should consist of any number of 'SFile', 'SBuilder', and 'SFlush', followed -- by a single 'SFinish'. data Sequence = SFinish Trailers -- ^ The stream is over; its trailers are provided. | SFlush -- ^ Any buffered data should be sent immediately. | SBuilder Builder -- ^ Append a chunk of data to the stream. | SFile FilePath FilePart -- ^ Append a chunk of a file's contents to the stream. -- | A message from the sender to a stream's dedicated waiter thread. data Sync = SyncNone -- ^ Nothing interesting has happened. Go back to sleep. | SyncFinish -- ^ The stream has ended. | SyncNext Output -- ^ The stream's queue has been drained; wait for more to be -- available and re-enqueue the given 'Output'. -- | Auxiliary information needed to communicate with a running stream: a queue -- of stream elements ('Sequence') and a 'TVar' connected to its waiter thread. data Aux = Persist (TBQueue Sequence) (TVar Sync) ---------------------------------------------------------------- -- | The context for HTTP/2 connection. data Context = Context { http2settings :: IORef Settings , streamTable :: StreamTable -- | Number of active streams initiated by the client; for enforcing our own -- max concurrency setting. , concurrency :: IORef Int -- | Number of active streams initiated by the server; for respecting the -- client's max concurrency setting. , pushConcurrency :: IORef Int , priorityTreeSize :: IORef Int -- | RFC 7540 says "Other frames (from any stream) MUST NOT -- occur between the HEADERS frame and any CONTINUATION -- frames that might follow". This field is used to implement -- this requirement. , continued :: IORef (Maybe StreamId) , currentStreamId :: IORef StreamId -- ^ Last client-initiated stream ID we've handled. , nextPushStreamId :: IORef StreamId -- ^ Next available server-initiated stream ID. , inputQ :: TQueue Input , outputQ :: PriorityTree Output , encodeDynamicTable :: IORef DynamicTable , decodeDynamicTable :: IORef DynamicTable , connectionWindow :: TVar WindowSize } ---------------------------------------------------------------- newContext :: IO Context newContext = Context <$> newIORef defaultSettings <*> initialize 10 -- fixme: hard coding: 10 <*> newIORef 0 <*> newIORef 0 <*> newIORef 0 <*> newIORef Nothing <*> newIORef 0 <*> newIORef 2 -- first server push stream; 0 is reserved <*> newTQueueIO <*> newPriorityTree <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef) <*> (newDynamicTableForDecoding defaultDynamicTableSize >>= newIORef) <*> newTVarIO defaultInitialWindowSize clearContext :: Context -> IO () clearContext ctx = void $ reaperStop $ streamTable ctx ---------------------------------------------------------------- data OpenState = JustOpened | Continued [HeaderBlockFragment] Int -- Total size Int -- The number of continuation frames Bool -- End of stream Priority | NoBody HeaderList Priority | HasBody HeaderList Priority | Body (TQueue ByteString) data ClosedCode = Finished | Killed | Reset ErrorCodeId | ResetByMe SomeException deriving Show data StreamState = Idle | Open OpenState | HalfClosed | Closed ClosedCode isIdle :: StreamState -> Bool isIdle Idle = True isIdle _ = False isOpen :: StreamState -> Bool isOpen Open{} = True isOpen _ = False isHalfClosed :: StreamState -> Bool isHalfClosed HalfClosed = True isHalfClosed _ = False isClosed :: StreamState -> Bool isClosed Closed{} = True isClosed _ = False instance Show StreamState where show Idle = "Idle" show Open{} = "Open" show HalfClosed = "HalfClosed" show (Closed e) = "Closed: " ++ show e ---------------------------------------------------------------- data Stream = Stream { streamNumber :: StreamId , streamState :: IORef StreamState -- Next two fields are for error checking. , streamContentLength :: IORef (Maybe Int) , streamBodyLength :: IORef Int , streamWindow :: TVar WindowSize , streamPrecedence :: IORef Precedence -- | The concurrency IORef in which this stream has been counted. The client -- and server each have separate concurrency values to respect, so pushed -- streams need to decrement a different count when they're closed. This -- should be either @concurrency ctx@ or @pushConcurrency ctx@. , concurrencyRef :: IORef Int } instance Show Stream where show s = show (streamNumber s) newStream :: IORef Int -> StreamId -> WindowSize -> IO Stream newStream ref sid win = Stream sid <$> newIORef Idle <*> newIORef Nothing <*> newIORef 0 <*> newTVarIO win <*> newIORef defaultPrecedence <*> pure ref ---------------------------------------------------------------- opened :: Stream -> IO () opened Stream{concurrencyRef,streamState} = do atomicModifyIORef' concurrencyRef (\x -> (x+1,())) writeIORef streamState (Open JustOpened) closed :: Stream -> ClosedCode -> IO () closed Stream{concurrencyRef,streamState} cc = do atomicModifyIORef' concurrencyRef (\x -> (x-1,())) writeIORef streamState (Closed cc) ---------------------------------------------------------------- type StreamTable = Reaper (IntMap Stream) (M.Key, Stream) initialize :: Int -> IO StreamTable initialize duration = mkReaper settings where settings = defaultReaperSettings { reaperAction = clean , reaperDelay = duration * 1000000 , reaperCons = uncurry M.insert , reaperNull = M.null , reaperEmpty = M.empty } clean :: IntMap Stream -> IO (IntMap Stream -> IntMap Stream) clean old = do new <- M.fromAscList <$> prune oldlist [] return $ M.union new where oldlist = M.toDescList old prune [] lst = return lst prune (x@(_,s):xs) lst = do st <- readIORef (streamState s) if isClosed st then prune xs lst else prune xs (x:lst) insert :: StreamTable -> M.Key -> Stream -> IO () insert strmtbl k v = reaperAdd strmtbl (k,v) search :: StreamTable -> M.Key -> IO (Maybe Stream) search strmtbl k = M.lookup k <$> reaperRead strmtbl -- INVARIANT: streams in the output queue have non-zero window size. enqueueWhenWindowIsOpen :: PriorityTree Output -> Output -> IO () enqueueWhenWindowIsOpen outQ out = do let Stream{..} = outputStream out atomically $ do x <- readTVar streamWindow check (x > 0) pre <- readIORef streamPrecedence enqueue outQ streamNumber pre out enqueueOrSpawnTemporaryWaiter :: Stream -> PriorityTree Output -> Output -> IO () enqueueOrSpawnTemporaryWaiter Stream{..} outQ out = do sw <- atomically $ readTVar streamWindow if sw == 0 then -- This waiter waits only for the stream window. void $ forkIO $ enqueueWhenWindowIsOpen outQ out else do pre <- readIORef streamPrecedence enqueue outQ streamNumber pre out warp-3.1.12/Network/Wai/Handler/Warp/HTTP2/Worker.hs0000644000000000000000000002472212636712547020066 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.HTTP2.Worker ( Respond , response , worker ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Concurrent import Control.Concurrent.STM import Control.Exception (Exception, SomeException(..), AsyncException(..)) import qualified Control.Exception as E import Control.Monad (void, when) import Data.Typeable import qualified Network.HTTP.Types as H import Network.HTTP2 import Network.HTTP2.Priority import Network.Wai import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.IORef import Network.Wai.HTTP2 ( Chunk(..) , HTTP2Application , PushPromise , Responder(runResponder) , RespondFunc ) import qualified Network.Wai.Handler.Warp.Settings as S import qualified Network.Wai.Handler.Warp.Timeout as T ---------------------------------------------------------------- -- | An 'HTTP2Application' takes a function of status, headers, trailers, and -- body; this type implements that by currying some internal arguments. -- -- The token type of the RespondFunc is set to be (). This is a bit -- anti-climactic, but the real benefit of the token type is that the -- application is forced to call the responder, and making it a boring type -- doesn't break that property. -- -- This is the argument to a 'Responder'. type Respond = IO () -> Stream -> RespondFunc () -- | This function is passed to workers. They also pass responses from -- 'HTTP2Application's to this function. This function enqueues commands for -- the HTTP/2 sender. response :: Context -> Manager -> ThreadContinue -> Respond response ctx mgr tconf tickle strm s h strmbdy = do -- TODO(awpr) HEAD requests will still stream. -- We must not exit this WAI application. -- If the application exits, streaming would be also closed. -- So, this work occupies this thread. -- -- We need to increase the number of workers. myThreadId >>= replaceWithAction mgr -- After this work, this thread stops to decrease the number of workers. setThreadContinue tconf False runStream ctx OResponse tickle strm s h strmbdy -- | Set up a waiter thread and run the stream body with functions to enqueue -- 'Sequence's on the stream's queue. runStream :: Context -> (Stream -> H.Status -> H.ResponseHeaders -> Aux -> Output) -> Respond runStream Context{outputQ} mkOutput tickle strm s h strmbdy = do -- Since 'Body' is loop, we cannot control it. -- So, let's serialize 'Builder' with a designated queue. sq <- newTBQueueIO 10 -- fixme: hard coding: 10 tvar <- newTVarIO SyncNone let out = mkOutput strm s h (Persist sq tvar) -- Since we must not enqueue an empty queue to the priority -- queue, we spawn a thread to ensure that the designated -- queue is not empty. void $ forkIO $ waiter tvar sq strm outputQ atomically $ writeTVar tvar $ SyncNext out let write chunk = do atomically $ writeTBQueue sq $ case chunk of BuilderChunk b -> SBuilder b FileChunk path part -> SFile path part tickle flush = atomically $ writeTBQueue sq SFlush trailers <- strmbdy write flush atomically $ writeTBQueue sq $ SFinish trailers -- | Handle abnormal termination of a stream: mark it as closed, send a reset -- frame, and call the user's 'settingsOnException' handler if applicable. cleanupStream :: Context -> S.Settings -> Stream -> Maybe Request -> Maybe SomeException -> IO () cleanupStream Context{outputQ} set strm req me = do closed strm Killed let sid = streamNumber strm frame = resetFrame InternalError sid enqueueControl outputQ sid $ OFrame frame case me of Nothing -> return () Just e -> S.settingsOnException set req e -- | Push the given 'Responder' to the client if the settings allow it -- (specifically 'enablePush' and 'maxConcurrentStreams'). Returns 'True' if -- the stream was actually pushed. -- -- This is the push function given to an 'HTTP2Application'. pushResponder :: Context -> S.Settings -> Stream -> PushPromise -> Responder -> IO Bool pushResponder ctx set strm promise responder = do let Context{ http2settings , pushConcurrency } = ctx cnt <- readIORef pushConcurrency settings <- readIORef http2settings let enabled = enablePush settings fits = maybe True (cnt <) $ maxConcurrentStreams settings canPush = fits && enabled if canPush then actuallyPushResponder ctx set strm promise responder else return False -- | Set up a pushed stream and run the 'Responder' in its own thread. Waits -- for the sender thread to handle the push request. This can fail to push the -- stream and return 'False' if the sender dequeued the push request after the -- associated stream was closed. actuallyPushResponder :: Context -> S.Settings -> Stream -> PushPromise -> Responder -> IO Bool actuallyPushResponder ctx set strm promise responder = do let Context{ http2settings , nextPushStreamId , pushConcurrency , streamTable } = ctx -- Claim the next outgoing stream. newSid <- atomicModifyIORef nextPushStreamId $ \sid -> (sid+2, sid) ws <- initialWindowSize <$> readIORef http2settings newStrm <- newStream pushConcurrency newSid ws -- Section 5.3.5 of RFC 7540 defines the weight of push promise is 16. -- But we need not to follow the spec. So, this value would change -- if necessary. writeIORef (streamPrecedence newStrm) $ toPrecedence $ defaultPriority { streamDependency = streamNumber strm } opened newStrm insert streamTable newSid newStrm -- Set up a channel for the sender to report back whether it pushed the -- stream. mvar <- newEmptyMVar let mkOutput = OPush strm promise mvar tickle = return () respond = runStream ctx mkOutput -- TODO(awpr): synthesize a Request for 'settingsOnException'? _ <- forkIO $ runResponder responder (respond tickle newStrm) `E.catch` (cleanupStream ctx set strm Nothing . Just) takeMVar mvar data Break = Break deriving (Show, Typeable) instance Exception Break worker :: Context -> S.Settings -> T.Manager -> HTTP2Application -> (ThreadContinue -> Respond) -> IO () worker ctx@Context{inputQ} set tm app respond = do tid <- myThreadId sinfo <- newStreamInfo tcont <- newThreadContinue let setup = T.register tm $ E.throwTo tid Break E.bracket setup T.cancel $ go sinfo tcont where go sinfo tcont th = do setThreadContinue tcont True ex <- E.try $ do T.pause th Input strm req <- atomically $ readTQueue inputQ setStreamInfo sinfo strm req T.resume th T.tickle th let responder = app req $ pushResponder ctx set strm runResponder responder $ respond tcont (T.tickle th) strm cont1 <- case ex of Right () -> return True Left e@(SomeException _) | Just Break <- E.fromException e -> do cleanup sinfo Nothing return True -- killed by the sender | Just ThreadKilled <- E.fromException e -> do cleanup sinfo Nothing return False | otherwise -> do cleanup sinfo (Just e) return True cont2 <- getThreadContinue tcont when (cont1 && cont2) $ go sinfo tcont th cleanup sinfo me = do m <- getStreamInfo sinfo case m of Nothing -> return () Just (strm,req) -> do cleanupStream ctx set strm (Just req) me clearStreamInfo sinfo -- | A dedicated waiter thread to re-enqueue the stream in the priority tree -- whenever output becomes available. When the sender drains the queue and -- moves on to another stream, it drops a message in the 'TVar', and this -- thread wakes up, waits for more output to become available, and re-enqueues -- the stream. waiter :: TVar Sync -> TBQueue Sequence -> Stream -> PriorityTree Output -> IO () waiter tvar sq strm outQ = do -- waiting for actions other than SyncNone mx <- atomically $ do mout <- readTVar tvar case mout of SyncNone -> retry SyncNext out -> do writeTVar tvar SyncNone return $ Just out SyncFinish -> return Nothing case mx of Nothing -> return () Just out -> do -- ensuring that the streaming queue is not empty. atomically $ do isEmpty <- isEmptyTBQueue sq when isEmpty retry -- ensuring that stream window is greater than 0. enqueueWhenWindowIsOpen outQ out waiter tvar sq strm outQ ---------------------------------------------------------------- -- | It would nice if responders could return values to workers. -- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0. -- It is not wise to change this type. -- So, a reference is shared by a 'Respond' and its worker. -- The reference refers a value of this type as a return value. -- If 'True', the worker continue to serve requests. -- Otherwise, the worker get finished. newtype ThreadContinue = ThreadContinue (IORef Bool) newThreadContinue :: IO ThreadContinue newThreadContinue = ThreadContinue <$> newIORef True setThreadContinue :: ThreadContinue -> Bool -> IO () setThreadContinue (ThreadContinue ref) x = writeIORef ref x getThreadContinue :: ThreadContinue -> IO Bool getThreadContinue (ThreadContinue ref) = readIORef ref ---------------------------------------------------------------- -- | The type to store enough information for 'settingsOnException'. newtype StreamInfo = StreamInfo (IORef (Maybe (Stream,Request))) newStreamInfo :: IO StreamInfo newStreamInfo = StreamInfo <$> newIORef Nothing clearStreamInfo :: StreamInfo -> IO () clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing setStreamInfo :: StreamInfo -> Stream -> Request -> IO () setStreamInfo (StreamInfo ref) strm req = writeIORef ref $ Just (strm,req) getStreamInfo :: StreamInfo -> IO (Maybe (Stream, Request)) getStreamInfo (StreamInfo ref) = readIORef ref warp-3.1.12/test/0000755000000000000000000000000012636712547011731 5ustar0000000000000000warp-3.1.12/test/BufferPoolSpec.hs0000644000000000000000000000316112636712547015144 0ustar0000000000000000module 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 warp-3.1.12/test/ConduitSpec.hs0000644000000000000000000000362612636712547014514 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ConduitSpec (main, spec) where import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.Types import Control.Monad (replicateM) import Test.Hspec import Data.IORef as I import qualified Data.ByteString as S main :: IO () main = hspec spec spec :: Spec spec = describe "conduit" $ do it "IsolatedBSSource" $ do ref <- newIORef $ map S.singleton [1..50] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty y:z -> do writeIORef ref z return y isrc <- mkISource src 40 x <- replicateM 20 $ readISource isrc S.concat x `shouldBe` S.pack [1..20] y <- replicateM 40 $ readISource isrc S.concat y `shouldBe` S.pack [21..40] z <- replicateM 40 $ readSource src S.concat z `shouldBe` S.pack [41..50] it "chunkedSource" $ do ref <- newIORef $ "5\r\n12345\r\n3\r\n678\r\n0\r\n\r\nBLAH" src <- mkSource $ do x <- readIORef ref writeIORef ref S.empty return x csrc <- mkCSource src x <- replicateM 15 $ readCSource csrc S.concat x `shouldBe` "12345678" y <- replicateM 15 $ readSource src S.concat y `shouldBe` "BLAH" it "chunk boundaries" $ do ref <- newIORef [ "5\r\n" , "12345\r\n3\r" , "\n678\r\n0\r\n" , "\r\nBLAH" ] src <- mkSource $ do x <- readIORef ref case x of [] -> return S.empty y:z -> do writeIORef ref z return y csrc <- mkCSource src x <- replicateM 15 $ readCSource csrc S.concat x `shouldBe` "12345678" y <- replicateM 15 $ readSource src S.concat y `shouldBe` "BLAH" warp-3.1.12/test/doctests.hs0000644000000000000000000000007612636712547014120 0ustar0000000000000000import Test.DocTest main :: IO () main = doctest ["Network"] warp-3.1.12/test/ExceptionSpec.hs0000644000000000000000000000423512636712547015042 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module ExceptionSpec (main, spec) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad import Network.HTTP.Types hiding (Header) import Network.Wai hiding (Response) import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp import Test.Hspec import Control.Exception import qualified Data.Streaming.Network as N import Control.Concurrent.Async (withAsync) import Network.Socket (sClose) import HTTP main :: IO () main = hspec spec withTestServer :: (Int -> IO a) -> IO a withTestServer inner = bracket (N.bindRandomPortTCP "127.0.0.1") (sClose . snd) $ \(prt, lsocket) -> do withAsync (runSettingsSocket defaultSettings lsocket testApp) $ \_ -> inner prt testApp :: Application testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f | x == "statusError" = f $ responseLBS undefined [] "foo" | x == "headersError" = f $ responseLBS ok200 undefined "foo" | x == "headerError" = f $ responseLBS ok200 [undefined] "foo" | x == "bodyError" = f $ responseLBS ok200 [] undefined | x == "ioException" = do void $ fail "ioException" f $ responseLBS ok200 [] "foo" testApp _ f = f $ responseLBS ok200 [] "foo" spec :: Spec spec = describe "responds even if there is an exception" $ do {- Disabling these tests. We can consider forcing evaluation in Warp. it "statusError" $ do sc <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError" sc `shouldBe` (5,0,0) it "headersError" $ do sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError" sc `shouldBe` (5,0,0) it "headerError" $ do sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError" sc `shouldBe` (5,0,0) it "bodyError" $ do sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError" sc `shouldBe` (5,0,0) -} it "ioException" $ withTestServer $ \prt -> do sc <- rspCode <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException") sc `shouldBe` (5,0,0) warp-3.1.12/test/FdCacheSpec.hs0000644000000000000000000000112312636712547014352 0ustar0000000000000000{-# LANGUAGE CPP #-} module FdCacheSpec where import Test.Hspec #ifndef WINDOWS import Data.IORef import Network.Wai.Handler.Warp.FdCache import System.Posix.IO (fdRead) import System.Posix.Types (Fd(..)) main :: IO () main = hspec spec spec :: Spec spec = describe "withFdCache" $ do it "clean up Fd" $ do ref <- newIORef (Fd (-1)) withFdCache 30000000 $ \(Just mfc) -> do (fd,_) <- getFd mfc "warp.cabal" writeIORef ref fd nfd <- readIORef ref fdRead nfd 1 `shouldThrow` anyIOException #else spec :: Spec spec = return () #endif warp-3.1.12/test/FileSpec.hs0000644000000000000000000000330212636712547013755 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module FileSpec (main, spec) where import Network.HTTP.Types import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header 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' 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 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 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 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 warp-3.1.12/test/head-response0000644000000000000000000000002112636712547014402 0ustar0000000000000000This is the body warp-3.1.12/test/HTTP.hs0000644000000000000000000000212512636712547013044 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module HTTP ( sendGET , sendGETwH , sendHEAD , sendHEADwH , rspBody , rspCode , rspHeaders , getHeaderValue , HeaderName(..) , mkHeader ) where import Network.HTTP import Network.Stream sendGET :: String -> IO (Response String) sendGET url = sendGETwH url [] sendGETwH :: String -> [Header] -> IO (Response String) sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr } sendHEAD :: String -> IO (Response String) sendHEAD url = sendHEADwH url [] sendHEADwH :: String -> [Header] -> IO (Response String) sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr } unResult :: IO (Result (Response String)) -> IO (Response String) unResult action = do res <- action case res of Right rsp -> return rsp Left _ -> error "Connection error" getHeaderValue :: HasHeaders a => HeaderName -> a -> Maybe String getHeaderValue key r = case retrieveHeaders key r of [] -> Nothing x:_ -> Just $ hdrValue x deriving instance Eq Header warp-3.1.12/test/MultiMapSpec.hs0000644000000000000000000000206012636712547014626 0ustar0000000000000000module MultiMapSpec where import Network.Wai.Handler.Warp.MultiMap import Test.Hspec import Test.QuickCheck (property) type Alist = [(Int,Char)] spec :: Spec spec = do describe "fromList" $ do it "generates a valid tree" $ property $ \xs -> valid $ fromList (xs :: Alist) describe "toSortedList" $ do it "generated a sorted list" $ property $ \xs -> ordered $ toSortedList $ fromList (xs :: Alist) describe "search" $ do it "acts as the list model" $ property $ \x xs -> search x (fromList xs) == lookup x (xs :: Alist) describe "fromSortedList" $ do it "generates a valid tree" $ property $ \xs -> valid . fromSortedList . toSortedList . fromList $ (xs :: Alist) it "maintains the tree with toSortedList" $ property $ \xs -> let t1 = fromList (xs :: Alist) t2 = fromSortedList $ toSortedList t1 in t1 == t2 ordered :: Ord a => [(a, b)] -> Bool ordered (x:y:xys) = fst x <= fst y && ordered (y:xys) ordered _ = True warp-3.1.12/test/ReadIntSpec.hs0000644000000000000000000000172512636712547014433 0ustar0000000000000000module ReadIntSpec (main, spec) where import Data.ByteString (ByteString) import Test.Hspec import Network.Wai.Handler.Warp.ReadInt import qualified Data.ByteString.Char8 as B import qualified Test.QuickCheck as QC main :: IO () main = hspec spec spec :: Spec spec = describe "readInt64" $ do it "converts ByteString to Int" $ QC.property (prop_read_show_idempotent readInt64) -- A QuickCheck property. Test that for a number >= 0, converting it to -- a string using show and then reading the value back with the function -- under test returns the original value. -- The functions under test only work on Natural numbers (the Conent-Length -- field in a HTTP header is always >= 0) so we check the absolute value of -- the value that QuickCheck generates for us. prop_read_show_idempotent :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool prop_read_show_idempotent freader x = px == freader (toByteString px) where px = abs x toByteString = B.pack . show warp-3.1.12/test/RequestSpec.hs0000644000000000000000000001240712636712547014534 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} module RequestSpec (main, spec) where import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges) 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 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 actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"] leftover `shouldBe` extra describe "parseByteRanges" $ do let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499] test "bytes=500-999" $ Just [HH.ByteRangeFromTo 500 999] test "bytes=-500" $ Just [HH.ByteRangeSuffix 500] test "bytes=9500-" $ Just [HH.ByteRangeFrom 9500] test "foobytes=9500-" Nothing test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] describe "headerLines" $ do it "can handle a nomarl case" $ do src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource x <- headerLines src x `shouldBe` ["Status: 200", "Content-Type: text/plain"] it "can handle a nasty case (1)" $ do src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource x <- headerLines src x `shouldBe` ["Status: 200", "Content-Type: text/plain"] it "can handle a nasty case (1)" $ do src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource x <- headerLines src x `shouldBe` ["Status: 200", "Content-Type: text/plain"] it "can handle a nasty case (1)" $ do src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource x <- headerLines src x `shouldBe` ["Status: 200", "Content-Type: text/plain"] it "can handle an illegal case (1)" $ do src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource x <- headerLines src x `shouldBe` [] y <- headerLines src y `shouldBe` ["Status: 200", "Content-Type: text/plain"] where blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"] whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"] tooMany = headerLinesList $ repeat "f\n" tooLarge = headerLinesList $ repeat "f" headerLinesList :: [S8.ByteString] -> IO (S8.ByteString, [S8.ByteString]) headerLinesList orig = do (res, src) <- headerLinesList' orig leftover <- readLeftoverSource src return (leftover, res) headerLinesList' :: [S8.ByteString] -> IO ([S8.ByteString], Source) headerLinesList' orig = do ref <- newIORef orig let src = do x <- readIORef ref case x of [] -> return S.empty y:z -> do writeIORef ref z return y src' <- mkSource src res <- headerLines src' return (res, src') consumeLen :: Int -> Source -> IO S8.ByteString consumeLen len0 src = loop id len0 where loop front len | len <= 0 = return $ S.concat $ front [] | otherwise = do bs <- readSource src if S.null bs then loop front 0 else do let (x, _) = S.splitAt len bs loop (front . (x:)) (len - S.length x) overLargeHeader :: Selector InvalidRequest overLargeHeader e = e == OverLargeHeader mkSourceFunc :: [S8.ByteString] -> IO (IO S8.ByteString) mkSourceFunc bss = do ref <- newIORef bss return $ reader ref where reader ref = do xss <- readIORef ref case xss of [] -> return S.empty (x:xs) -> do writeIORef ref xs return x warp-3.1.12/test/ResponseHeaderSpec.hs0000644000000000000000000000156612636712547016017 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ResponseHeaderSpec (main, spec) where import Data.ByteString import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.ResponseHeader import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = describe "composeHeader" $ do it "composes a HTTP header" $ composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader headers :: H.ResponseHeaders headers = [ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT") , ("Content-Lenght", "151") , ("Server", "Mighttpd/2.5.8") , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT") , ("Content-Type", "text/html") ] composedHeader :: ByteString composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n" warp-3.1.12/test/ResponseSpec.hs0000644000000000000000000001043412636712547014700 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ResponseSpec (main, spec) where import Control.Concurrent (threadDelay) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Maybe (mapMaybe) import Network (connectTo, PortID (PortNumber)) import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Response import RunSpec (withApp) import System.IO (hClose, hFlush) import Test.Hspec import HTTP main :: IO () main = hspec spec testRange :: S.ByteString -- ^ range value -> String -- ^ expected output -> Maybe String -- ^ expected content-range value -> Spec testRange range out crange = it title $ withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port S.hPutStr handle "GET / HTTP/1.0\r\n" S.hPutStr handle "Range: bytes=" S.hPutStr handle range S.hPutStr handle "\r\n\r\n" hFlush handle threadDelay 10000 bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024 hClose handle last bss `shouldBe` out let hs = mapMaybe toHeader bss lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) where app _ = ($ responseFile status200 [] "attic/hex" Nothing) title = show (range, out, crange) toHeader s = case break (== ':') s of (x, ':':y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing testPartial :: Integer -- ^ file size -> Integer -- ^ offset -> Integer -- ^ byte count -> String -- ^ expected output -> Spec testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port S.hPutStr handle "GET / HTTP/1.0\r\n\r\n" hFlush handle threadDelay 10000 bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024 hClose handle out `shouldBe` last bss let hs = mapMaybe toHeader bss lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) lookup "Content-Range" hs `shouldBe` Just range where app _ = ($ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size) title = show (offset, count, out) toHeader s = case break (== ':') s of (x, ':':y) -> Just (x, dropWhile (== ' ') y) _ -> Nothing range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size spec :: Spec spec = do describe "preventing response splitting attack" $ do it "sanitizes header values" $ do let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello" withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port getHeaderValue (HdrCustom "foo") res `shouldBe` Just "foo bar" -- HTTP inserts two spaces for \r\n. describe "sanitizeHeaderValue" $ do it "doesn't alter valid multiline header values" $ do sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar" it "adds missing spaces after \r\n" $ do sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar" it "discards empty lines" $ do sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar" context "when sanitizing single occurences of \n" $ do it "replaces \n with \r\n" $ do sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar" it "adds missing spaces after \n" $ do sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar" it "discards single occurrences of \r" $ do sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar" describe "range requests" $ do testRange "2-3" "23" $ Just "2-3/16" testRange "5-" "56789abcdef" $ Just "5-15/16" testRange "5-8" "5678" $ Just "5-8/16" testRange "-3" "def" $ Just "13-15/16" testRange "16-" "" $ Just "*/16" testRange "-17" "0123456789abcdef" Nothing describe "partial files" $ do testPartial 16 2 2 "23" testPartial 16 0 2 "01" testPartial 16 3 8 "3456789a" warp-3.1.12/test/RunSpec.hs0000644000000000000000000004240212636712547013646 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module RunSpec (main, spec, withApp) where import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) import qualified Control.Exception as E import Control.Exception.Lifted (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString, hPutStr, hGetSome) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.IORef as I import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv) import Network (connectTo, PortID (PortNumber)) import Network.HTTP.Types import Network.Socket (sClose) import Network.Socket.ByteString (sendAll) import Network.Wai import Network.Wai.Handler.Warp import System.IO (hFlush, hClose) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec import HTTP main :: IO () main = hspec spec type Counter = I.IORef (Either String Int) type CounterApplication = Counter -> Application incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount -> ((case ecount of Left s -> Left s Right i -> Right $ i + 1), ()) err :: (MonadIO m, Show a) => Counter -> a -> m () err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg readBody :: CounterApplication readBody icount req f = do body <- consumeBody $ requestBody 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) | otherwise -> incr icount f $ responseLBS status200 [] "Read the body" ignoreBody :: CounterApplication ignoreBody icount req f = do if (requestMethod req `elem` ["GET", "POST"]) then incr icount else err icount ("Invalid request method" :: String, requestMethod req) f $ responseLBS status200 [] "Ignored the body" doubleConnect :: CounterApplication doubleConnect icount req f = do _ <- consumeBody $ requestBody req _ <- consumeBody $ requestBody req incr icount f $ responseLBS status200 [] "double connect" nextPort :: I.IORef Int nextPort = unsafePerformIO $ I.newIORef 5000 {-# NOINLINE nextPort #-} getPort :: IO Int getPort = do port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p) esocket <- try $ bindPortTCP port "127.0.0.1" case esocket of Left (_ :: IOException) -> RunSpec.getPort Right socket -> do sClose socket return port withApp :: Settings -> Application -> (Int -> IO a) -> IO a withApp settings app f = do port <- RunSpec.getPort baton <- newEmptyMVar let settings' = setPort port $ setHost "127.0.0.1" $ setBeforeMainLoop (putMVar baton ()) settings bracket (forkIO $ runSettings settings' app `onException` putMVar baton ()) killThread (const $ takeMVar baton >> f port) runTest :: Int -- ^ expected number of requests -> CounterApplication -> [ByteString] -- ^ chunks to send -> IO () runTest expected app chunks = do ref <- I.newIORef (Right 0) withApp defaultSettings (app ref) $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096 res <- I.readIORef ref case res of Left s -> error s Right i -> i `shouldBe` expected dummyApp :: Application dummyApp _ f = f $ responseLBS status200 [] "foo" runTerminateTest :: InvalidRequest -> ByteString -> IO () runTerminateTest expected input = do ref <- I.newIORef Nothing let onExc _ = I.writeIORef ref . Just withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port hPutStr handle input hFlush handle hClose handle threadDelay 1000 res <- I.readIORef ref show res `shouldBe` show (Just expected) singleGet :: ByteString singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" singlePostHello :: ByteString singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello" singleChunkedPostHello :: [ByteString] singleChunkedPostHello = [ "POST /hello HTTP/1.1\r\nHost: localhost\r\nTransfer-Encoding: chunked\r\n\r\n" , "5\r\nHello\r\n0\r\n" ] spec :: Spec spec = do describe "non-pipelining" $ do it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet it "has body, read" $ runTest 2 readBody [ singlePostHello , singleGet ] it "has body, ignore" $ runTest 2 ignoreBody [ singlePostHello , singleGet ] it "chunked body, read" $ runTest 2 readBody $ concat [ singleChunkedPostHello , [singleGet] ] it "chunked body, ignore" $ runTest 2 ignoreBody $ concat [ singleChunkedPostHello , [singleGet] ] describe "pipelining" $ do it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet] it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet] it "has body, read" $ runTest 2 readBody $ return $ S.concat [ singlePostHello , singleGet ] it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat [ singlePostHello , singleGet ] it "chunked body, read" $ runTest 2 readBody $ return $ S.concat [ S.concat singleChunkedPostHello , singleGet ] it "chunked body, ignore" $ runTest 2 ignoreBody $ return $ S.concat [ S.concat singleChunkedPostHello , singleGet ] describe "no hanging" $ do it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello it "double connect" $ runTest 1 doubleConnect [singlePostHello] describe "connection termination" $ do -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello" it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n" describe "special input" $ do it "multiline headers" $ do iheaders <- I.newIORef [] let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" ] hPutStr handle input hFlush handle hClose handle threadDelay 1000 headers <- I.readIORef iheaders headers `shouldBe` [ ("foo", "bar baz\tbin") ] it "no space between colon and value" $ do iheaders <- I.newIORef [] let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" ] hPutStr handle input hFlush handle hClose handle threadDelay 1000 headers <- I.readIORef iheaders headers `shouldBe` [ ("foo", "bar") ] describe "chunked bodies" $ do it "works" $ do ifront <- I.newIORef id let app req f = do bss <- consumeBody $ requestBody req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n" , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ] hPutStr handle input hFlush handle hClose handle threadDelay 1000 front <- I.readIORef ifront front [] `shouldBe` [ "Hello World\nBye" , "Hello World" ] it "lots of chunks" $ do ifront <- I.newIORef id let app req f = do bss <- consumeBody $ requestBody req I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = concat $ replicate 2 $ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++ (replicate 50 "5\r\n12345\r\n") ++ ["0\r\n\r\n"] mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input hClose handle threadDelay 100000 -- FIXME why does this delay need to be so high? front <- I.readIORef ifront front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345") it "in chunks" $ do ifront <- I.newIORef id let app req f = do bss <- consumeBody $ requestBody req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port let input = S.concat [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n" , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ] mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input hClose handle threadDelay 1000 front <- I.readIORef ifront front [] `shouldBe` [ "Hello World\nBye" , "Hello World" ] it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do bss <- (consumeBody $ requestBody req) `onException` liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ()))) liftIO $ threadDelay 4000000 `E.catch` \e -> do I.atomicModifyIORef ifront (\front -> ( front . ((S8.pack $ "threadDelay interrupted: " ++ show e):) , ())) E.throwIO (e :: E.SomeException) liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) f $ responseLBS status200 [] "" withApp (setTimeout 1 defaultSettings) app $ \port -> do let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2 handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port hPutStr handle "POST / HTTP/1.1\r\n" hPutStr handle "content-length: " hPutStr handle $ S8.pack $ show $ S.length bs hPutStr handle "\r\n\r\n" threadDelay 100000 hPutStr handle bs1 threadDelay 100000 hPutStr handle bs2 hClose handle threadDelay 5000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs describe "raw body" $ do it "works" $ do let app _req f = do let backup = responseLBS status200 [] "Not raw" f $ flip responseRaw backup $ \src sink -> do let loop = do bs <- src unless (S.null bs) $ do sink $ doubleBS bs loop loop doubleBS = S.concatMap $ \w -> S.pack [w, w] withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port hPutStr handle "POST / HTTP/1.1\r\n\r\n12345" hFlush handle timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455") hPutStr handle "67890" hFlush handle timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900") it "only one date and server header" $ do let app _ f = f $ responseLBS status200 [ ("server", "server") , ("date", "date") ] "" withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port getHeaderValue HdrServer res `shouldBe` Just "server" getHeaderValue HdrDate res `shouldBe` Just "date" it "streaming echo #249" $ do let app req f = f $ responseStream status200 [] $ \write _ -> do let loop = do bs <- requestBody req unless (S.null bs) $ do write $ byteString bs loop loop withApp defaultSettings app $ \port -> do (socket, _addr) <- getSocketTCP "127.0.0.1" port sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" threadDelay 10000 sendAll socket "5\r\nhello\r\n0\r\n\r\n" bs <- safeRecv socket 4096 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK" it "streaming response with length" $ do let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do replicateM_ 4 $ write $ byteString "Hello" withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port rspBody res `shouldBe` "HelloHelloHelloHello" describe "head requests" $ do let fp = "test/head-response" let app req f = f $ case pathInfo req of ["builder"] -> responseBuilder status200 [] $ error "should never be evaluated" ["streaming"] -> responseStream status200 [] $ \write _ -> write $ error "should never be evaluated" ["file"] -> responseFile status200 [] fp Nothing _ -> error "invalid path" it "builder" $ withApp defaultSettings app $ \port -> do res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"] rspBody res `shouldBe` "" it "streaming" $ withApp defaultSettings app $ \port -> do res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"] rspBody res `shouldBe` "" it "file, no range" $ withApp defaultSettings app $ \port -> do bs <- S.readFile fp res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"] getHeaderValue HdrContentLength res `shouldBe` Just (show $ S.length bs) it "file, with range" $ withApp defaultSettings app $ \port -> do res <- sendHEADwH (concat ["http://127.0.0.1:", show port, "/file"]) [mkHeader HdrRange "bytes=0-1"] getHeaderValue HdrContentLength res `shouldBe` Just "2" consumeBody :: IO ByteString -> IO [ByteString] consumeBody body = loop id where loop front = do bs <- body if S.null bs then return $ front [] else loop $ front . (bs:) warp-3.1.12/test/SendFileSpec.hs0000644000000000000000000001034212636712547014571 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module SendFileSpec where import Control.Exception import Control.Monad (when) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Types import System.Directory import System.Exit import qualified System.IO as IO import System.Process (system) import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = do describe "packHeader" $ do it "returns how much the buffer is consumed (1)" $ tryPackHeader 10 ["foo"] `shouldReturn` 3 it "returns how much the buffer is consumed (2)" $ tryPackHeader 10 ["foo", "bar"] `shouldReturn` 6 it "returns how much the buffer is consumed (3)" $ tryPackHeader 10 ["0123456789"] `shouldReturn` 0 it "returns how much the buffer is consumed (4)" $ tryPackHeader 10 ["01234", "56789"] `shouldReturn` 0 it "returns how much the buffer is consumed (5)" $ tryPackHeader 10 ["01234567890", "12"] `shouldReturn` 3 it "returns how much the buffer is consumed (6)" $ tryPackHeader 10 ["012345678901234567890123456789012", "34"] `shouldReturn` 5 it "sends headers correctly (1)" $ tryPackHeader2 10 ["foo"] "" `shouldReturn` True it "sends headers correctly (2)" $ tryPackHeader2 10 ["foo", "bar"] "" `shouldReturn` True it "sends headers correctly (3)" $ tryPackHeader2 10 ["0123456789"] "0123456789" `shouldReturn` True it "sends headers correctly (4)" $ tryPackHeader2 10 ["01234", "56789"] "0123456789" `shouldReturn` True it "sends headers correctly (5)" $ tryPackHeader2 10 ["01234567890", "12"] "0123456789" `shouldReturn` True it "sends headers correctly (6)" $ tryPackHeader2 10 ["012345678901234567890123456789012", "34"] "012345678901234567890123456789" `shouldReturn` True describe "readSendFile" $ do it "sends a file correctly (1)" $ tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess it "sends a file correctly (2)" $ tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess it "sends a file correctly (3)" $ tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess tryPackHeader :: Int -> [ByteString] -> IO Int tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf -> packHeader buf siz send hook hdrs 0 where send _ = return () hook = return () tryPackHeader2 :: Int -> [ByteString] -> ByteString -> IO Bool tryPackHeader2 siz hdrs ans = bracket setup teardown $ \buf -> do _ <- packHeader buf siz send hook hdrs 0 checkFile outputFile ans where setup = allocateBuffer siz teardown buf = freeBuffer buf >> removeFileIfExists outputFile outputFile = "tempfile" send = BS.appendFile outputFile hook = return () tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO ExitCode tryReadSendFile siz off len hdrs = bracket setup teardown $ \buf -> do mapM_ (BS.appendFile expectedFile) hdrs copyfile inputFile expectedFile off len readSendFile buf siz send fid off len hook hdrs compareFiles expectedFile outputFile where hook = return () setup = allocateBuffer siz teardown buf = do freeBuffer buf removeFileIfExists outputFile removeFileIfExists expectedFile inputFile = "test/inputFile" outputFile = "outputFile" expectedFile = "expectedFile" fid = FileId inputFile Nothing send = BS.appendFile outputFile checkFile :: FilePath -> ByteString -> IO Bool checkFile path bs = do exist <- doesFileExist path if exist then do bs' <- BS.readFile path return $ bs == bs' else return $ bs == "" compareFiles :: FilePath -> FilePath -> IO ExitCode compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2 copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO () copyfile src dst off len = IO.withBinaryFile src IO.ReadMode $ \h -> do IO.hSeek h IO.AbsoluteSeek off BS.hGet h (fromIntegral len) >>= BS.appendFile dst removeFileIfExists :: FilePath -> IO () removeFileIfExists file = do exist <- doesFileExist file when exist $ removeFile file warp-3.1.12/test/Spec.hs0000644000000000000000000000005412636712547013156 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}