warp-3.2.8/0000755000000000000000000000000012750546070010671 5ustar0000000000000000warp-3.2.8/ChangeLog.md0000644000000000000000000001720312750546070013045 0ustar0000000000000000## 3.2.8 * Fixing HTTP2 requestBodyLength. [#573](https://github.com/yesodweb/wai/pull/573) * Making HTTP/2 :path optional for the CONNECT method. [#572](https://github.com/yesodweb/wai/pull/572) * Adding new APIs for HTTP/2 trailers: http2dataTrailers and modifyHTTP2Data [#566](https://github.com/yesodweb/wai/pull/566) ## 3.2.7 * Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data [#510](https://github.com/yesodweb/wai/pull/510) * Better accept(2) error handling [#553](https://github.com/yesodweb/wai/pull/553) * Adding getGracefulShutdownTimeout. * Add {test,}withApplicationSettings [#531](https://github.com/yesodweb/wai/pull/531) ## 3.2.6 * Using token based APIs of http2 1.6. ## 3.2.5 * Ignoring errors from setSocketOption. [#526](https://github.com/yesodweb/wai/issues/526). ## 3.2.4 * Added `withApplication`, `testWithApplication`, and `openFreePort` * Fixing reaper delay value of file info cache. ## 3.2.3 * Using http2 v1.5.x which much improves the performance of HTTP/2. * To get rid of the bottleneck of ByteString's (==), a new logic to compare header names is introduced. ## 3.2.2 * Throwing errno for pread [#499](https://github.com/yesodweb/wai/issues/499). * Makeing compilable on Windows [#505](https://github.com/yesodweb/wai/issues/505). ## 3.2.1 * Add back `warpVersion` ## 3.2.0 * Major version up due to breaking changes. This is because the HTTP/2 code was started over with Warp 3.1.3 due to performance issue [#470](https://github.com/yesodweb/wai/issues/470). * runHTTP2, runHTTP2Env, runHTTP2Settings and runHTTP2SettingsSocket were removed from the Network.Wai.Handler.Warp module. * The performance of HTTP/2 was drastically improved. Now the performance of HTTP/2 is almost the same as that of HTTP/1.1. * The logic to handle files in HTTP/2 is now identical to that in HTTP/1.1. * Internal stuff was removed from the Network.Wai.Handler.Warp module according to [the plan](http://www.yesodweb.com/blog/2015/06/cleaning-up-warp-apis). ## 3.1.12 * Setting lower bound for auto-update [#495](https://github.com/yesodweb/wai/issues/495) ## 3.1.11 * Providing a new API: killManager. * Preventing space leaks due to Weak ThreadId [#488](https://github.com/yesodweb/wai/issues/488) * Setting upper bound for http2. ## 3.1.10 * `setFileInfoCacheDuration` * `setLogger` * `FileInfo`/`getFileInfo` * Fix: warp-tls strips out the Host request header [#478](https://github.com/yesodweb/wai/issues/478) ## 3.1.9 * Using the new priority queue based on PSQ provided by http2 lib again. ## 3.1.8 * Using the new priority queue based on PSQ provided by http2 lib. ## 3.1.7 * A concatenated Cookie header is prepended to the headers to ensure that it flows pseudo headers. [#454](https://github.com/yesodweb/wai/pull/454) * Providing a new settings: `setHTTP2Disabled` [#450](https://github.com/yesodweb/wai/pull/450) ## 3.1.6 * Adding back http-types 0.8 support [#449](https://github.com/yesodweb/wai/pull/449) ## 3.1.5 * Using http-types v0.9. * Fixing build on OpenBSD. [#428](https://github.com/yesodweb/wai/pull/428) [#440](https://github.com/yesodweb/wai/pull/440) * Fixing build on Windows. [#438](https://github.com/yesodweb/wai/pull/438) ## 3.1.4 * Using newer http2 library to prevent change table size attacks. * API for HTTP/2 server push and trailers. [#426](https://github.com/yesodweb/wai/pull/426) * Preventing response splitting attacks. [#435](https://github.com/yesodweb/wai/pull/435) * Concatenating multiple Cookie: headers in HTTP/2. ## 3.1.3 * Warp now supports blaze-builder v0.4 or later only. * HTTP/2 code was improved: dynamic priority change, efficient queuing and sender loop continuation. [#423](https://github.com/yesodweb/wai/pull/423) [#424](https://github.com/yesodweb/wai/pull/424) ## 3.1.2 * Configurable Slowloris size [#418](https://github.com/yesodweb/wai/pull/418) ## 3.1.1 * Fixing a bug of HTTP/2 when no FD cache is used [#411](https://github.com/yesodweb/wai/pull/411) * Fixing a buffer-pool bug [#406](https://github.com/yesodweb/wai/pull/406) [#407](https://github.com/yesodweb/wai/pull/407) ## 3.1.0 * Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399) * Cleaning up APIs [#387](https://github.com/yesodweb/wai/issues/387) ## 3.0.13.1 * Remove dependency on the void package [#375](https://github.com/yesodweb/wai/pull/375) ## 3.0.13 * Turn off file descriptor cache by default [#371](https://github.com/yesodweb/wai/issues/371) ## 3.0.12.1 * Fix for: HEAD requests returning non-empty entity body [#369](https://github.com/yesodweb/wai/issues/369) ## 3.0.12 * Only conditionally produce HTTP 100 Continue ## 3.0.11 * Better HEAD support for files [#357](https://github.com/yesodweb/wai/pull/357) ## 3.0.10 * Fix [missing `IORef` tweak](https://github.com/yesodweb/wai/issues/351) * Disable timeouts as soon as request body is fully consumed. This addresses the common case of a non-chunked request body. Previously, we would wait until a zero-length `ByteString` is returned, but that is suboptimal for some cases. For more information, see [issue 351](https://github.com/yesodweb/wai/issues/351). * Add `pauseTimeout` function ## 3.0.9.3 * Don't serve a 416 status code for 0-length files [keter issue #75](https://github.com/snoyberg/keter/issues/75) * Don't serve content-length for 416 responses [#346](https://github.com/yesodweb/wai/issues/346) ## 3.0.9.2 Fix support for old versions of bytestring ## 3.0.9.1 Add support for blaze-builder 0.4 ## 3.0.9 * Add runEnv: like run but uses $PORT [#334](https://github.com/yesodweb/wai/pull/334) ## 3.0.5.2 * [Pass the Request to settingsOnException handlers when available. #326](https://github.com/yesodweb/wai/pull/326) ## 3.0.5 Support for PROXY protocol, such as used by Amazon ELB TCP. This is useful since, for example, Amazon ELB HTTP does *not* have support for Websockets. More information on the protocol [is available from Amazon](http://docs.aws.amazon.com/ElasticLoadBalancing/latest/DeveloperGuide/TerminologyandKeyConcepts.html#proxy-protocol). ## 3.0.4 Added `setFork`. ## 3.0.3 Modify flushing of request bodies. Previously, regardless of the size of the request body, the entire body would be flushed. When uploading large files to a web app that does not accept such files (e.g., returns a 413 too large status), browsers would still send the entire request body and the servers will still receive it. The new behavior is to detect if there is a large amount of data still to be consumed and, if so, immediately terminate the connection. In the case of chunked request bodies, up to a maximum number of bytes is consumed before the connection is terminated. This is controlled by the new setting `setMaximumBodyFlush`. A value of @Nothing@ will return the original behavior of flushing the entire body. ## 3.0.0 WAI no longer uses conduit for its streaming interface. ## 2.1.0 The `onOpen` and `onClose` settings now provide the `SockAddr` of the client, and `onOpen` can return a `Bool` which will close the connection. The `responseRaw` response has been added, which provides a more elegant way to handle WebSockets than the previous `settingsIntercept`. The old settings accessors have been deprecated in favor of new setters, which will allow settings changes to be made in the future without breaking backwards compatibility. ## 2.0.0 ResourceT is not used anymore. Request and Response is now abstract data types. To use their constructors, Internal module should be imported. ## 1.3.9 Support for byte range requests. ## 1.3.7 Sockets now have `FD_CLOEXEC` set on them. This behavior is more secure, and the change should not affect the vast majority of use cases. However, it appeared that this is buggy and is fixed in 2.0.0. warp-3.2.8/LICENSE0000644000000000000000000000207512750546070011702 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.2.8/README.md0000644000000000000000000000026712750546070012155 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.2.8/Setup.lhs0000644000000000000000000000016212750546070012500 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain warp-3.2.8/warp.cabal0000644000000000000000000001770512750546070012640 0ustar0000000000000000Name: warp Version: 3.2.8 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 test/inputFile Flag network-bytestring Default: False Flag allow-sendfilefd Description: Allow use of sendfileFd (not available on GNU/kFreeBSD) Default: True Flag warp-debug Description: print debug output. not suitable for production Default: False Library Build-Depends: base >= 3 && < 5 , array , async , 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.6 && < 1.7 , simple-sendfile >= 0.2.7 && < 0.3 , unix-compat >= 0.2 , wai >= 3.2 && < 3.3 , text , streaming-commons >= 0.1.10 , vault >= 0.3 , stm >= 2.3 , word8 , hashable , 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.HashMap Network.Wai.Handler.Warp.HTTP2 Network.Wai.Handler.Warp.HTTP2.EncodeFrame Network.Wai.Handler.Warp.HTTP2.File Network.Wai.Handler.Warp.HTTP2.HPACK Network.Wai.Handler.Warp.HTTP2.Manager Network.Wai.Handler.Warp.HTTP2.Receiver Network.Wai.Handler.Warp.HTTP2.Request Network.Wai.Handler.Warp.HTTP2.Sender Network.Wai.Handler.Warp.HTTP2.Types Network.Wai.Handler.Warp.HTTP2.Worker Network.Wai.Handler.Warp.Header Network.Wai.Handler.Warp.IO Network.Wai.Handler.Warp.IORef Network.Wai.Handler.Warp.PackInt Network.Wai.Handler.Warp.ReadInt Network.Wai.Handler.Warp.Recv Network.Wai.Handler.Warp.Request Network.Wai.Handler.Warp.RequestHeader Network.Wai.Handler.Warp.Response Network.Wai.Handler.Warp.ResponseHeader Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings Network.Wai.Handler.Warp.Some Network.Wai.Handler.Warp.Timeout Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication Paths_warp Ghc-Options: -Wall if flag(warp-debug) Cpp-Options: -DWARP_DEBUG if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD if os(windows) Cpp-Options: -DWINDOWS Build-Depends: time 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 ReadIntSpec RequestSpec ResponseHeaderSpec ResponseSpec RunSpec SendFileSpec WithApplicationSpec 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.2 && < 3.3 , network , HUnit , QuickCheck , hspec >= 1.3 , time , text , streaming-commons >= 0.1.10 , silently , async , vault , stm >= 2.3 , directory , process , containers , http2 >= 1.6 && < 1.7 , word8 , hashable , 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 , auto-update , bytestring , containers , criterion >= 1 , hashable , http-date , http-types , network , network , unix-compat if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD Build-Depends: unix if os(windows) Cpp-Options: -DWINDOWS Source-Repository head Type: git Location: git://github.com/yesodweb/wai.git warp-3.2.8/attic/0000755000000000000000000000000012750546070011775 5ustar0000000000000000warp-3.2.8/attic/hex0000644000000000000000000000002012750546070012474 0ustar00000000000000000123456789abcdefwarp-3.2.8/bench/0000755000000000000000000000000012750546070011750 5ustar0000000000000000warp-3.2.8/bench/Parser.hs0000644000000000000000000001712412750546070013545 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" $ whnfIO $ parseRequestLine2 requestLine1 , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1 , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1 ] , bgroup "requestLine2" [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2 , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2 , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2 , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2 ] ] ---------------------------------------------------------------- -- | -- -- >>> parseRequestLine3 "GET / HTTP/1.1" -- ("GET","/","",HTTP/1.1) -- >>> parseRequestLine3 "POST /cgi/search.cgi?key=foo HTTP/1.0" -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) -- >>> parseRequestLine3 "GET " -- *** Exception: BadFirstLine "GET " -- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1" -- *** Exception: NonHttp parseRequestLine3 :: ByteString -> (H.Method ,ByteString -- Path ,ByteString -- Query ,H.HttpVersion) parseRequestLine3 requestLine = ret where (!method,!rest) = S.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.2.8/Network/0000755000000000000000000000000012750546070012322 5ustar0000000000000000warp-3.2.8/Network/Wai/0000755000000000000000000000000012750546070013042 5ustar0000000000000000warp-3.2.8/Network/Wai/Handler/0000755000000000000000000000000012750546070014417 5ustar0000000000000000warp-3.2.8/Network/Wai/Handler/Warp.hs0000644000000000000000000003422612750546070015673 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} --------------------------------------------------------- -- -- Module : Network.Wai.Handler.Warp -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Stable -- Portability : portable -- -- A fast, light-weight HTTP server handler for WAI. -- --------------------------------------------------------- -- | A fast, light-weight HTTP server handler for WAI. -- -- HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2, -- Warp supports direct and ALPN (in TLS) but not upgrade. -- -- Note on slowloris timeouts: to prevent slowloris attacks, timeouts are used -- at various points in request receiving and response sending. One interesting -- corner case is partial request body consumption; in that case, Warp's -- timeout handling is still in effect, and the timeout will not be triggered -- again. Therefore, it is recommended that once you start consuming the -- request body, you either: -- -- * consume the entire body promptly -- -- * call the 'pauseTimeout' function -- -- For more information, see . -- -- module Network.Wai.Handler.Warp ( -- * Run a Warp server -- | All of these automatically serve the same 'Application' over HTTP\/1, -- HTTP\/1.1, and HTTP\/2. run , runEnv , runSettings , runSettingsSocket -- * Settings , Settings , defaultSettings -- ** Setters , setPort , setHost , setOnException , setOnExceptionResponse , setOnOpen , setOnClose , setTimeout , setManager , setFdCacheDuration , setFileInfoCacheDuration , setBeforeMainLoop , setNoParsePath , setInstallShutdownHandler , setServerName , setMaximumBodyFlush , setFork , setProxyProtocolNone , setProxyProtocolRequired , setProxyProtocolOptional , setSlowlorisSize , setHTTP2Disabled , setLogger , setServerPushLogger , setGracefulShutdownTimeout -- ** Getters , getPort , getHost , getOnOpen , getOnClose , getOnException , getGracefulShutdownTimeout -- ** Exception handler , defaultOnException , defaultShouldDisplayException -- ** Exception response handler , defaultOnExceptionResponse , exceptionResponseForDebug -- * Data types , HostPreference , Port , InvalidRequest (..) -- * Utilities , pauseTimeout , FileInfo(..) , getFileInfo , withApplication , withApplicationSettings , testWithApplication , testWithApplicationSettings , openFreePort -- * Version , warpVersion -- * HTTP/2 -- ** HTTP2 data , HTTP2Data , http2dataPushPromise , http2dataTrailers , defaultHTTP2Data , getHTTP2Data , setHTTP2Data , modifyHTTP2Data -- ** Push promise , PushPromise , promisedPath , promisedFile , promisedResponseHeaders , promisedWeight , defaultPushPromise ) where import 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.FileInfoCache import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response (warpVersion) import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data) import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types hiding (getFileInfo) import Network.Wai.Handler.Warp.WithApplication -- | Port to listen on. Default value: 3000 -- -- Since 2.1.0 setPort :: Port -> Settings -> Settings setPort x y = y { settingsPort = x } -- | Interface to bind to. Default value: HostIPv4 -- -- Since 2.1.0 setHost :: HostPreference -> Settings -> Settings setHost x y = y { settingsHost = x } -- | What to do with exceptions thrown by either the application or server. -- Default: 'defaultOnException' -- -- Since 2.1.0 setOnException :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings setOnException x y = y { settingsOnException = x } -- | A function to create a `Response` when an exception occurs. -- Default: 'defaultOnExceptionResponse' -- -- Note that an application can handle its own exceptions without interfering with Warp: -- -- > myApp :: Application -- > myApp request respond = innerApp `catch` onError -- > where -- > onError = respond . response500 request -- > -- > response500 :: Request -> SomeException -> Response -- > response500 req someEx = responseLBS status500 -- ... -- -- Since 2.1.0 setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings setOnExceptionResponse x y = y { settingsOnExceptionResponse = x } -- | What to do when a connection is opened. When 'False' is returned, the -- connection is closed immediately. Otherwise, the connection is going on. -- Default: always returns 'True'. -- -- Since 2.1.0 setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings setOnOpen x y = y { settingsOnOpen = x } -- | What to do when a connection is closed. Default: do nothing. -- -- Since 2.1.0 setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings setOnClose x y = y { settingsOnClose = x } -- | 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 -- | Get the graceful shutdown timeout -- -- Since 3.2.8 getGracefulShutdownTimeout :: Settings -> Maybe Int getGracefulShutdownTimeout = settingsGracefulShutdownTimeout -- | A code to install shutdown handler. -- -- For instance, this code should set up a UNIX signal -- handler. The handler should call the first argument, -- which closes the listen socket, at shutdown. -- -- 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 ()) -- ^ request, status, maybe file-size -> Settings -> Settings setLogger lgr y = y { settingsLogger = lgr } -- | Setting a log function for HTTP/2 server push. -- -- Since: 3.2.7 setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size -> Settings -> Settings setServerPushLogger lgr y = y { settingsServerPushLogger = lgr } -- | Set the graceful shutdown timeout. A timeout of `Nothing' will -- wait indefinitely, and a number, if provided, will be treated as seconds -- to wait for requests to finish, before shutting down the server entirely. -- -- Since 3.2.8 setGracefulShutdownTimeout :: Maybe Int -> Settings -> Settings setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time } -- | 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.2.8/Network/Wai/Handler/Warp/0000755000000000000000000000000012750546070015330 5ustar0000000000000000warp-3.2.8/Network/Wai/Handler/Warp/Buffer.hs0000644000000000000000000000623412750546070017102 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.2.8/Network/Wai/Handler/Warp/Conduit.hs0000644000000000000000000001322712750546070017276 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.2.8/Network/Wai/Handler/Warp/Counter.hs0000644000000000000000000000127212750546070017305 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.2.8/Network/Wai/Handler/Warp/Date.hs0000644000000000000000000000224112750546070016540 0ustar0000000000000000{-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Date ( withDateCache , 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 -- | Creating 'DateCache' and executing the action. withDateCache :: (IO GMTDate -> IO a) -> IO a withDateCache action = initialize >>= action initialize :: IO (IO GMTDate) initialize = mkAutoUpdate defaultUpdateSettings { updateAction = formatHTTPDate <$> getCurrentHTTPDate } #ifdef WINDOWS uToH :: UTCTime -> HTTPDate uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds getCurrentHTTPDate :: IO HTTPDate getCurrentHTTPDate = uToH <$> getCurrentTime #else getCurrentHTTPDate :: IO HTTPDate getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime #endif warp-3.2.8/Network/Wai/Handler/Warp/FdCache.hs0000644000000000000000000001056312750546070017146 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} -- | File descriptor cache to avoid locks in kernel. module Network.Wai.Handler.Warp.FdCache ( withFdCache , Fd , Refresh #ifndef WINDOWS , openFile , closeFile , setFileCloseOnExec #endif ) where #ifndef WINDOWS #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception (bracket) import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.MultiMap import Control.Reaper import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption) #endif import System.Posix.Types (Fd) ---------------------------------------------------------------- type Hash = Int -- | An action to activate a Fd cache entry. type Refresh = IO () getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh) getFdNothing _ _ = return (Nothing, return ()) ---------------------------------------------------------------- -- | Creating 'MutableFdCache' and executing the action in the second -- argument. The first argument is a cache duration in second. withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a #ifdef WINDOWS withFdCache _ action = action getFdNothing #else withFdCache 0 action = action getFdNothing withFdCache duration action = bracket (initialize duration) terminate (\mfc -> action (getFd mfc)) ---------------------------------------------------------------- data Status = Active | Inactive newtype MutableStatus = MutableStatus (IORef Status) status :: MutableStatus -> IO Status status (MutableStatus ref) = readIORef ref newActiveStatus :: IO MutableStatus newActiveStatus = MutableStatus <$> newIORef Active refresh :: MutableStatus -> Refresh refresh (MutableStatus ref) = writeIORef ref Active inactive :: MutableStatus -> IO () inactive (MutableStatus ref) = writeIORef ref Inactive ---------------------------------------------------------------- data FdEntry = FdEntry !FilePath !Fd !MutableStatus openFile :: FilePath -> IO Fd openFile path = do fd <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=False} setFileCloseOnExec fd return fd closeFile :: Fd -> IO () closeFile = closeFd newFdEntry :: FilePath -> IO FdEntry newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus setFileCloseOnExec :: Fd -> IO () setFileCloseOnExec fd = setFdOption fd CloseOnExec True ---------------------------------------------------------------- type FdCache = MMap FdEntry -- | Mutable Fd cacher. newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry)) fdCache :: MutableFdCache -> IO FdCache fdCache (MutableFdCache reaper) = reaperRead reaper look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry) look mfc path key = searchWith key check <$> fdCache mfc where check (FdEntry path' _ _) = path == path' ---------------------------------------------------------------- -- The first argument is a cache duration in second. initialize :: Int -> IO MutableFdCache initialize duration = MutableFdCache <$> mkReaper settings where settings = defaultReaperSettings { reaperAction = clean , reaperDelay = duration , reaperCons = uncurry insert , reaperNull = isEmpty , reaperEmpty = empty } clean :: FdCache -> IO (FdCache -> FdCache) clean old = do new <- pruneWith old prune return $ merge new where prune (FdEntry _ fd mst) = status mst >>= act where act Active = inactive mst >> return True act Inactive = closeFd fd >> return False ---------------------------------------------------------------- terminate :: MutableFdCache -> IO () terminate (MutableFdCache reaper) = do !t <- reaperStop reaper mapM_ closeIt $ toList t where closeIt (FdEntry _ fd _) = closeFd fd ---------------------------------------------------------------- -- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher. getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh) getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get where get Nothing = do ent@(FdEntry _ fd mst) <- newFdEntry path reaperAdd reaper (h, ent) return (Just fd, refresh mst) get (Just (FdEntry _ fd mst)) = do refresh mst return (Just fd, refresh mst) #endif warp-3.2.8/Network/Wai/Handler/Warp/File.hs0000644000000000000000000001554612750546070016556 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.File ( RspFileInfo(..) , conditionalRequest , addContentHeadersForFilePart , parseByteRanges ) where import Control.Applicative ((<|>)) import Data.Array ((!)) import qualified Data.ByteString as B hiding (pack) import qualified Data.ByteString.Char8 as B (pack, readInteger) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Network.HTTP.Date import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H import Network.Wai import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.PackInt import Numeric (showInt) #ifndef MIN_VERSION_http_types #define MIN_VERSION_http_types(x,y,z) 1 #endif -- $setup -- >>> import Test.QuickCheck ---------------------------------------------------------------- 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 = fromMaybe (unconditional reqidx size) mcondition ---------------------------------------------------------------- ifModifiedSince :: IndexedHeader -> Maybe HTTPDate ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate ifRange :: IndexedHeader -> Maybe HTTPDate ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate ---------------------------------------------------------------- ifmodified :: IndexedHeader -> 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 ---------------------------------------------------------------- contentRange :: H.HeaderName #if MIN_VERSION_http_types(0,9,0) contentRange = H.hContentRange #else contentRange = "Content-Range" #endif -- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' -- for the range specified. contentRangeHeader :: Integer -> Integer -> Integer -> H.Header contentRangeHeader beg end total = (contentRange, range) where range = B.pack -- building with ShowS $ 'b' : 'y': 't' : 'e' : 's' : ' ' : (if beg > end then ('*':) else showInt beg . ('-' :) . showInt end) ( '/' : showInt total "") acceptRange :: H.HeaderName #if MIN_VERSION_http_types(0,9,0) acceptRange = H.hAcceptRanges #else acceptRange = "Accept-Ranges" #endif addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders addContentHeaders hs off len size | len == size = hs' | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size in ctrng:hs' where !lengthBS = packIntegral len !hs' = (H.hContentLength, lengthBS) : (acceptRange,"bytes") : hs -- | -- -- >>> addContentHeadersForFilePart [] (FilePart 2 10 16) -- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")] -- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) -- [("Content-Length","16"),("Accept-Ranges","bytes")] addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders addContentHeadersForFilePart hs part = addContentHeaders hs off len size where off = filePartOffset part len = filePartByteCount part size = filePartFileSize part warp-3.2.8/Network/Wai/Handler/Warp/FileInfoCache.hs0000644000000000000000000000705612750546070020313 0ustar0000000000000000{-# LANGUAGE RecordWildCards, CPP #-} module Network.Wai.Handler.Warp.FileInfoCache ( FileInfo(..) , Hash , withFileInfoCache , getInfo -- test purpose only ) where import Control.Exception as E import Control.Monad (void) import Control.Reaper import Data.ByteString (ByteString) import Network.HTTP.Date import Network.Wai.Handler.Warp.HashMap (HashMap) import qualified Network.Wai.Handler.Warp.HashMap as M import System.PosixCompat.Files ---------------------------------------------------------------- type Hash = Int -- | 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 (Int,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") getInfoNaive :: Hash -> FilePath -> IO FileInfo getInfoNaive _ = getInfo ---------------------------------------------------------------- getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo getAndRegisterInfo reaper@Reaper{..} h path = do cache <- reaperRead case M.lookup h path cache of Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x Nothing -> positive reaper h path `E.onException` negative reaper h path positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo positive Reaper{..} h path = do info <- getInfo path reaperAdd (h, path, Positive info) return info negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo negative Reaper{..} h path = do reaperAdd (h, 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 -> ((Hash -> FilePath -> IO FileInfo) -> IO a) -> IO a withFileInfoCache 0 action = action getInfoNaive withFileInfoCache duration action = E.bracket (initialize duration) terminate (\r -> action (getAndRegisterInfo r)) initialize :: Hash -> IO FileInfoCache initialize duration = mkReaper settings where settings = defaultReaperSettings { reaperAction = override , reaperDelay = duration , reaperCons = \(h,k,v) -> M.insert h k v , 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.2.8/Network/Wai/Handler/Warp/HashMap.hs0000644000000000000000000000171712750546070017213 0ustar0000000000000000module Network.Wai.Handler.Warp.HashMap where import Data.ByteString (ByteString) import Data.Hashable (hash) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Prelude hiding (lookup) type Hash = Int newtype HashMap k v = HashMap (IntMap (Map k v)) hashByteString :: ByteString -> Hash hashByteString = hash empty :: HashMap k v empty = HashMap $ I.empty null :: HashMap k v -> Bool null (HashMap hm) = I.null hm insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm where m = M.singleton k v f = M.union -- fimxe {-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-} lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k {-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-} warp-3.2.8/Network/Wai/Handler/Warp/Header.hs0000644000000000000000000000720712750546070017062 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.Wai.Handler.Warp.Header where import Data.Array import Data.Array.ST import qualified Data.ByteString as BS import Data.CaseInsensitive (foldedCase) import Network.HTTP.Types import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -- | Array for a set of HTTP headers. type IndexedHeader = Array Int (Maybe HeaderValue) ---------------------------------------------------------------- indexRequestHeader :: RequestHeaders -> IndexedHeader indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex data RequestHeaderIndex = ReqContentLength | ReqTransferEncoding | ReqExpect | ReqConnection | ReqRange | ReqHost | ReqIfModifiedSince | ReqIfUnmodifiedSince | ReqIfRange | ReqReferer | ReqUserAgent 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 hn = case BS.length bs of 4 -> if bs == "host" then fromEnum ReqHost else -1 5 -> if bs == "range" then fromEnum ReqRange else -1 6 -> if bs == "expect" then fromEnum ReqExpect else -1 7 -> if bs == "referer" then fromEnum ReqReferer else -1 8 -> if bs == "if-range" then fromEnum ReqIfRange else -1 10 -> if bs == "user-agent" then fromEnum ReqUserAgent else if bs == "connection" then fromEnum ReqConnection else -1 14 -> if bs == "content-length" then fromEnum ReqContentLength else -1 17 -> if bs == "transfer-encoding" then fromEnum ReqTransferEncoding else if bs == "if-modified-since" then fromEnum ReqIfModifiedSince else -1 19 -> if bs == "if-unmodified-since" then fromEnum ReqIfUnmodifiedSince else -1 _ -> -1 where bs = foldedCase hn defaultIndexRequestHeader :: IndexedHeader defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]] ---------------------------------------------------------------- indexResponseHeader :: ResponseHeaders -> IndexedHeader indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex data ResponseHeaderIndex = ResContentLength | ResServer | ResDate deriving (Enum,Bounded) -- | The size for 'IndexedHeader' for HTTP Response. responseMaxIndex :: Int responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex) responseKeyIndex :: HeaderName -> Int responseKeyIndex hn = case BS.length bs of 4 -> if bs == "date" then fromEnum ResDate else -1 6 -> if bs == "server" then fromEnum ResServer else -1 14 -> if bs == "content-length" then fromEnum ResContentLength else -1 _ -> -1 where bs = foldedCase hn ---------------------------------------------------------------- traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader traverseHeader hdr maxidx getIndex = runSTArray $ do arr <- newArray (0,maxidx) Nothing mapM_ (insert arr) hdr return arr where insert arr (key,val) | idx == -1 = return () | otherwise = writeArray arr idx (Just val) where idx = getIndex key warp-3.2.8/Network/Wai/Handler/Warp/HTTP2.hs0000644000000000000000000000526212750546070016532 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 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 -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO () http2 conn ii1 addr transport settings readN app = do checkTLS ok <- checkPreface when ok $ do ctx <- newContext -- Workers, worker manager and timer manager mgr <- start settings let responder = response settings ctx mgr action = worker ctx settings app responder setAction mgr action -- The number of workers is 3. -- This was carefully chosen based on a lot of benchmarks. -- If it is 1, we cannot avoid head-of-line blocking. -- If it is large, huge memory is consumed and many -- context switches happen. replicateM_ 3 $ spawnAction mgr -- Receiver let mkreq = mkRequest ii1 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 settings mgr `E.finally` do clearContext ctx stop mgr killThread tid where 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.2.8/Network/Wai/Handler/Warp/Internal.hs0000644000000000000000000000442512750546070017445 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Internal ( -- * Settings Settings (..) , ProxyProtocol(..) -- * Low level run functions , runSettingsConnection , runSettingsConnectionMaker , runSettingsConnectionMakerSecure , Transport (..) -- * Connection , Connection (..) , socketConnection -- ** Receive , Recv , RecvBuf , 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.2.8/Network/Wai/Handler/Warp/IO.hs0000644000000000000000000000170412750546070016175 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.2.8/Network/Wai/Handler/Warp/IORef.hs0000644000000000000000000000134412750546070016632 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.2.8/Network/Wai/Handler/Warp/MultiMap.hs0000644000000000000000000000414712750546070017422 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns #-} module Network.Wai.Handler.Warp.MultiMap ( MMap , isEmpty , empty , singleton , insert , search , searchWith , pruneWith , toList , merge ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I import qualified Network.Wai.Handler.Warp.Some as S ---------------------------------------------------------------- type MMap v = IntMap (S.Some v) ---------------------------------------------------------------- -- | O(1) isEmpty :: MMap v -> Bool isEmpty = I.null -- | O(1) empty :: MMap v empty = I.empty ---------------------------------------------------------------- -- | O(1) singleton :: Int -> v -> MMap v singleton k v = I.singleton k (S.singleton v) ---------------------------------------------------------------- -- | O(log n) search :: Int -> MMap v -> Maybe v search k m = case I.lookup k m of Nothing -> Nothing Just s -> Just $! S.top s -- | O(log n) searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v searchWith k f m = case I.lookup k m of Nothing -> Nothing Just s -> S.lookupWith f s ---------------------------------------------------------------- -- | O(log n) insert :: Int -> v -> MMap v -> MMap v insert k v m = I.insertWith S.union k (S.singleton v) m ---------------------------------------------------------------- -- | O(n) toList :: MMap v -> [v] toList m = concatMap f $ I.toAscList m where f (_,s) = S.toList s ---------------------------------------------------------------- -- | O(n) pruneWith :: MMap v -> (v -> IO Bool) -> IO (MMap v) pruneWith m action = I.fromAscList <$> go (I.toDescList m) [] where go [] acc = return acc go ((k,s):kss) acc = do mt <- S.prune action s case mt of Nothing -> go kss acc Just t -> go kss ((k,t) : acc) ---------------------------------------------------------------- -- O(n + m) where N is the size of the second argument merge :: MMap v -> MMap v -> MMap v merge m1 m2 = I.unionWith S.union m1 m2 warp-3.2.8/Network/Wai/Handler/Warp/PackInt.hs0000644000000000000000000000313112750546070017213 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Network.Wai.Handler.Warp.PackInt where import Control.Monad (when) import Data.ByteString.Internal (ByteString(..), unsafeCreate) import Data.Word8 (Word8) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke) import qualified Network.HTTP.Types as H -- $setup -- >>> import Data.ByteString.Char8 as B -- >>> import Test.QuickCheck (Large(..)) -- | -- -- prop> packIntegral (abs n) == B.pack (show (abs n)) -- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == B.pack (show n') packIntegral :: Integral a => a -> ByteString packIntegral 0 = "0" packIntegral n | n < 0 = error "packIntegral" packIntegral n = unsafeCreate len go0 where n' = fromIntegral n + 1 :: Double len = ceiling $ logBase 10 n' go0 p = go n $ p `plusPtr` (len - 1) go :: Integral a => a -> Ptr Word8 -> IO () go i p = do let (d,r) = i `divMod` 10 poke p (48 + fromIntegral r) when (d /= 0) $ go d (p `plusPtr` (-1)) {-# SPECIALIZE packIntegral :: Int -> ByteString #-} {-# SPECIALIZE packIntegral :: Integer -> ByteString #-} -- | -- -- >>> packStatus H.status200 -- "200" -- >>> packStatus H.preconditionFailed412 -- "412" packStatus :: H.Status -> ByteString packStatus status = unsafeCreate 3 $ \p -> do poke p (toW8 r2) poke (p `plusPtr` 1) (toW8 r1) poke (p `plusPtr` 2) (toW8 r0) where toW8 :: Int -> Word8 toW8 n = 48 + fromIntegral n !s = fromIntegral $ H.statusCode status (!q0,!r0) = s `divMod` 10 (!q1,!r1) = q0 `divMod` 10 !r2 = q1 `mod` 10 warp-3.2.8/Network/Wai/Handler/Warp/ReadInt.hs0000644000000000000000000000514612750546070017220 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.2.8/Network/Wai/Handler/Warp/Recv.hs0000644000000000000000000001034112750546070016562 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.2.8/Network/Wai/Handler/Warp/Request.hs0000644000000000000000000002471512750546070017325 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.HashMap (hashByteString) 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 -> InternalInfo1 -> SockAddr -- ^ Peer's address. -> Source -- ^ Where HTTP request comes from. -> IO (Request ,Maybe (I.IORef Int) ,IndexedHeader ,IO ByteString ,InternalInfo) -- ^ -- '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 ii1 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 rawPath = if settingsNoParsePath settings then unparsedPath else path h = hashByteString rawPath ii = toInternalInfo ii1 h th = threadHandle ii vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (getFileInfo ii) Vault.empty (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te -- body producing function which will produce '100-continue', if needed rbody' <- timeoutBody remainingRef th rbody handle100Continue -- body producing function which will never produce 100-continue rbodyFlush <- timeoutBody remainingRef th rbody (return ()) let req = Request { requestMethod = method , httpVersion = httpversion , pathInfo = H.decodePathSegments path , rawPathInfo = rawPath , rawQueryString = query , queryString = H.parseQuery query , requestHeaders = hdr , isSecure = False , remoteHost = addr , requestBody = rbody' , vault = vaultValue , requestBodyLength = bodyLength , requestHeaderHost = idxhdr ! fromEnum ReqHost , requestHeaderRange = idxhdr ! fromEnum ReqRange , requestHeaderReferer = idxhdr ! fromEnum ReqReferer , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent } return (req, remainingRef, idxhdr, rbodyFlush, ii) ---------------------------------------------------------------- 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.2.8/Network/Wai/Handler/Warp/RequestHeader.hs0000644000000000000000000001104612750546070020427 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.RequestHeader ( parseHeaderLines ) where import Control.Exception (throwIO) import Control.Monad (when) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as B (unpack) import Data.ByteString.Internal (ByteString(..), memchr) import qualified Data.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 -- $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.2.8/Network/Wai/Handler/Warp/Response.hs0000644000000000000000000004104312750546070017464 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.Response ( sendResponse , sanitizeHeaderValue -- for testing , warpVersion , hasBody , replaceHeader ) 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 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 getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr (isPersist,isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked) isHead = requestMethod req == H.methodHead 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 $ getFileInfo 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 (mfd, fresher) <- getFd ii path let fid = FileId path mfd hook' = hook >> fresher connSendFile conn fid beg len hook' [lheader] return (Just s, Just len) sendRspFile404 :: Connection -> InternalInfo -> H.HttpVersion -> H.ResponseHeaders -> IO (Maybe H.Status, Maybe Integer) sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True) 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 :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of Nothing -> do gmtdate <- getdate return $ (H.hDate, gmtdate) : hdrs Just _ -> return hdrs ---------------------------------------------------------------- -- | The version of Warp. warpVersion :: String warpVersion = showVersion Paths_warp.version 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.2.8/Network/Wai/Handler/Warp/ResponseHeader.hs0000644000000000000000000000472112750546070020577 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.2.8/Network/Wai/Handler/Warp/Run.hs0000644000000000000000000004750512750546070016443 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# 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 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 "iproute" Data.IP (toHostAddress, toHostAddress6) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno(..), eCONNABORTED) import GHC.IO.Exception (IOException(..)) import Network (sClose, Socket) import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..)) import qualified Network.Socket.ByteString as Sock import Network.Wai 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.Timeout (timeout) #if WINDOWS import Network.Wai.Handler.Warp.Windows #else import Network.Socket (fdSocket) #endif -- | Creating 'Connection' for plain HTTP based on a given socket. socketConnection :: 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 -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO () run p = runSettings defaultSettings { settingsPort = p } -- | Run an 'Application' on the port present in the @PORT@ -- environment variable. Uses the 'Port' given when the variable is unset. -- This calls 'runSettings' with 'defaultSettings'. -- -- Since 3.0.9 runEnv :: Port -> Application -> IO () runEnv p app = do mp <- lookup "PORT" <$> getEnvironment maybe (run p app) runReadPort mp where runReadPort :: String -> IO () runReadPort sp = case reads sp of ((p', _):_) -> run p' app _ -> fail $ "Invalid value in $PORT: " ++ sp -- | Run an 'Application' with the given 'Settings'. -- This opens a listen socket on the port defined in 'Settings' and -- calls 'runSettingsSocket'. runSettings :: Settings -> Application -> IO () runSettings set app = withSocketsDo $ bracket (bindPortTCP (settingsPort set) (settingsHost set)) sClose (\socket -> do setSocketCloseOnExec socket runSettingsSocket set socket app) -- | This installs a shutdown handler for the given socket and -- calls 'runSettingsConnection' with the default connection setup action -- which handles plain (non-cipher) HTTP. -- When the listen socket in the second argument is closed, all live -- connections are gracefully shut down. -- -- The supplied socket can be a Unix named socket, which -- can be used when reverse HTTP proxying into your application. -- -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO () runSettingsSocket set socket app = do settingsInstallShutdownHandler set closeListenSocket runSettingsConnection set getConn app where getConn = do #if WINDOWS (s, sa) <- windowsThreadBlockHack $ accept socket #else (s, sa) <- accept socket #endif setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX. setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return () 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 app = runSettingsConnectionMaker set getConnMaker app where getConnMaker = do (conn, sa) <- getConn return (return conn, sa) -- | This modifies the connection maker so that it returns 'TCP' for 'Transport' -- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'. runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () runSettingsConnectionMaker x y = runSettingsConnectionMakerSecure x (toTCP <$> y) where toTCP = first ((, TCP) <$>) ---------------------------------------------------------------- -- | The core run function which takes 'Settings', -- a connection maker and 'Application'. -- The connection maker can return a connection of either plain HTTP -- or HTTP over TLS. -- -- Since 2.1.4 runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO () runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set counter <- newCounter withII0 $ acceptConnection set getConnMaker app counter where withII0 action = withTimeoutManager $ \tm -> D.withDateCache $ \dc -> F.withFdCache fdCacheDurationInSeconds $ \fdc -> I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do let ii0 = InternalInfo0 tm dc fdc fic action ii0 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000 !timeoutInSeconds = settingsTimeout set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm Nothing -> bracket (T.initialize timeoutInSeconds) T.stopManager f -- Note that there is a thorough discussion of the exception safety of the -- following code at: https://github.com/yesodweb/wai/issues/146 -- -- We need to make sure of two things: -- -- 1. Asynchronous exceptions are not blocked entirely in the main loop. -- Doing so would make it impossible to kill the Warp thread. -- -- 2. Once a connection maker is received via acceptNewConnection, the -- connection is guaranteed to be closed, even in the presence of -- async exceptions. -- -- Our approach is explained in the comments below. acceptConnection :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> Counter -> InternalInfo0 -> IO () acceptConnection set getConnMaker app 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 set counter where acceptLoop = do -- Allow async exceptions before receiving the next connection maker. allowInterrupt -- acceptNewConnection will try to receive the next incoming -- request. It returns a /connection maker/, not a connection, -- since in some circumstances creating a working connection -- from a raw socket may be an expensive operation, and this -- expensive work should not be performed in the main event -- loop. An example of something expensive would be TLS -- negotiation. mx <- acceptNewConnection case mx of Nothing -> return () Just (mkConn, addr) -> do fork set mkConn addr app counter ii0 acceptLoop acceptNewConnection = do ex <- try getConnMaker case ex of Right x -> return $ Just x Left e -> do let eConnAborted = getErrno eCONNABORTED getErrno (Errno cInt) = cInt if ioe_errno e == Just eConnAborted then acceptNewConnection else do settingsOnException set Nothing $ toException e return Nothing -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown). fork :: Settings -> IO (Connection, Transport) -> SockAddr -> Application -> Counter -> InternalInfo0 -> IO () fork set mkConn addr app 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 (timeoutManager0 ii0)) T.cancel $ \th -> let ii1 = toInternalInfo1 ii0 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 $ serveConnection conn ii1 addr transport set app where closeConn (conn, _transport) = connClose conn onOpen adr = increase counter >> settingsOnOpen set adr onClose adr _ = decrease counter >> settingsOnClose set adr serveConnection :: Connection -> InternalInfo1 -> SockAddr -> Transport -> Settings -> Application -> IO () serveConnection conn ii1 origAddr transport settings app = do -- fixme: Upgrading to HTTP/2 should be supported. (h2,bs) <- if isHTTP2 transport then return (True, "") else do bs0 <- connRecv conn if S.length bs0 >= 4 && "PRI " `S.isPrefixOf` bs0 then return (True, bs0) else return (False, bs0) if settingsHTTP2Enabled settings && h2 then do recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn) -- fixme: origAddr http2 conn ii1 origAddr transport settings recvN app 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 = threadHandle1 ii1 shouldSendErrorResponse se | Just ConnectionClosedByPeer <- fromException se = False | otherwise = True sendErrorResponse addr istatus e = do status <- readIORef istatus when (shouldSendErrorResponse e && status) $ do let ii = toInternalInfo ii1 0 -- dummy dreq = dummyreq addr void $ sendResponse settings conn ii dreq 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, ii) <- recvRequest settings conn ii1 addr src let req = req' { isSecure = isTransportSecure transport } keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii `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 ii = 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 = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket #endif gracefulShutdown :: Settings -> Counter -> IO () gracefulShutdown set counter = case settingsGracefulShutdownTimeout set of Nothing -> waitForZero counter (Just seconds) -> void (timeout (seconds * microsPerSecond) (waitForZero counter)) where microsPerSecond = 1000000 warp-3.2.8/Network/Wai/Handler/Warp/SendFile.hs0000644000000000000000000001112412750546070017354 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Network.Wai.Handler.Warp.SendFile ( sendFile , readSendFile , packHeader -- for testing #ifndef WINDOWS , positionRead #endif ) where import Control.Monad (void, when) 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 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.Error (throwErrno) import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr) import Network.Sendfile import Network.Wai.Handler.Warp.FdCache (openFile, closeFile) import System.Posix.Types #endif ---------------------------------------------------------------- -- | 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 -> openFile path teardown fd = case fileIdFd fid of Just _ -> return () Nothing -> closeFile fd loop fd len off | len <= 0 = return () | otherwise = do n <- positionRead fd buf (mini siz len) off bufferIO buf n send let n' = fromIntegral n hook loop fd (len - n') (off + n') positionRead :: Fd -> Buffer -> BufSize -> Integer -> IO Int positionRead fd buf siz off = do bytes <- fromIntegral <$> c_pread fd (castPtr buf) (fromIntegral siz) (fromIntegral off) when (bytes < 0) $ throwErrno "positionRead" return bytes foreign import ccall unsafe "pread" c_pread :: Fd -> Ptr CChar -> ByteCount -> FileOffset -> IO CSsize #endif warp-3.2.8/Network/Wai/Handler/Warp/Settings.hs0000644000000000000000000002002512750546070017463 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. , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO () -- ^ A HTTP/2 server push log function. Default: no action. -- -- Since 3.X.X. , settingsGracefulShutdownTimeout :: Maybe Int -- ^ An optional timeout to limit the time (in seconds) waiting for -- a graceful shutdown of the web server. -- -- Since 3.2.8 } -- | 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 () , settingsServerPushLogger = \_ _ _ -> return () , settingsGracefulShutdownTimeout = Nothing } -- | 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.2.8/Network/Wai/Handler/Warp/Some.hs0000644000000000000000000000310112750546070016562 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.Some ( Some , singleton , top , lookupWith , union , toList , prune ) where ---------------------------------------------------------------- -- | One ore more list to implement multimap. data Some a = One !a | Tom !a !(Some a) -- Two or more deriving (Eq,Show) {-# INLINE singleton #-} singleton :: a -> Some a singleton x = One x {-# INLINE top #-} top :: Some a -> a top (One x) = x top (Tom x _) = x {-# INLINE lookupWith #-} lookupWith :: (a -> Bool) -> Some a -> Maybe a lookupWith f s = go s where go (One x) | f x = Just x | otherwise = Nothing go (Tom x xs) | f x = Just x | otherwise = go xs {-# INLINE union #-} union :: Some a -> Some a -> Some a union s t = go s t where go (One x) u = Tom x u go (Tom x xs) u = go xs (Tom x u) {-# INLINE toList #-} toList :: Some a -> [a] toList s = go s [] where go (One x) !acc = x : acc go (Tom x xs) !acc = go xs (x : acc) {-# INLINE prune #-} prune :: (a -> IO Bool) -> Some a -> IO (Maybe (Some a)) prune act s = go s where go (One x) = do keep <- act x return $ if keep then Just (One x) else Nothing go (Tom x xs) = do keep <- act x mys <- go xs return $ if keep then case mys of Nothing -> Just (One x) Just ys -> Just (Tom x ys) else mys warp-3.2.8/Network/Wai/Handler/Warp/Timeout.hs0000644000000000000000000001076412750546070017322 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.2.8/Network/Wai/Handler/Warp/Types.hs0000644000000000000000000001436212750546070016776 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 import System.Posix.Types (Fd) ---------------------------------------------------------------- -- | 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 ---------------------------------------------------------------- -- | 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 } ---------------------------------------------------------------- type Hash = Int data InternalInfo0 = InternalInfo0 T.Manager (IO D.GMTDate) (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh)) (Hash -> FilePath -> IO I.FileInfo) timeoutManager0 :: InternalInfo0 -> T.Manager timeoutManager0 (InternalInfo0 tm _ _ _) = tm data InternalInfo1 = InternalInfo1 T.Handle T.Manager (IO D.GMTDate) (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh)) (Hash -> FilePath -> IO I.FileInfo) toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1 toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e threadHandle1 :: InternalInfo1 -> T.Handle threadHandle1 (InternalInfo1 th _ _ _ _) = th data InternalInfo = InternalInfo { threadHandle :: T.Handle , timeoutManager :: T.Manager , getDate :: IO D.GMTDate , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh) , getFileInfo :: FilePath -> IO I.FileInfo } toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h) ---------------------------------------------------------------- -- | 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.2.8/Network/Wai/Handler/Warp/Windows.hs0000644000000000000000000000106512750546070017320 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.2.8/Network/Wai/Handler/Warp/WithApplication.hs0000644000000000000000000000663512750546070020775 0ustar0000000000000000 module Network.Wai.Handler.Warp.WithApplication ( withApplication, withApplicationSettings, testWithApplication, testWithApplicationSettings, openFreePort, withFreePort, ) where import Control.Concurrent import Control.Concurrent.Async import Control.Exception import Network.Socket import Network.Wai import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types -- | Runs the given 'Application' on a free port. Passes the port to the given -- operation and executes it, while the 'Application' is running. Shuts down the -- server before returning. -- -- @since 3.2.4 withApplication :: IO Application -> (Port -> IO a) -> IO a withApplication = withApplicationSettings defaultSettings -- | 'withApplication' with given 'Settings'. This will ignore the port value -- set by 'setPort' in 'Settings'. -- -- @since 3.2.7 withApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a withApplicationSettings settings' mkApp action = do app <- mkApp withFreePort $ \ (port, sock) -> do started <- mkWaiter let settings = settings' { settingsBeforeMainLoop = notify started () >> settingsBeforeMainLoop settings' } result <- race (runSettingsSocket settings sock app) (waitFor started >> action port) case result of Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited" Right x -> return x -- | Same as 'withApplication' but with different exception handling: If the -- given 'Application' throws an exception, 'testWithApplication' will re-throw -- the exception to the calling thread, possibly interrupting the execution of -- the given operation. -- -- This is handy for running tests against an 'Application' over a real network -- port. When running tests, it's useful to let exceptions thrown by your -- 'Application' propagate to the main thread of the test-suite. -- -- __The exception handling makes this function unsuitable for use in production.__ -- Use 'withApplication' instead. -- -- @since 3.2.4 testWithApplication :: IO Application -> (Port -> IO a) -> IO a testWithApplication = testWithApplicationSettings defaultSettings -- | 'testWithApplication' with given 'Settings'. -- -- @since 3.2.7 testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a testWithApplicationSettings _settings mkApp action = do callingThread <- myThreadId app <- mkApp let wrappedApp request respond = app request respond `catch` \ e -> do throwTo callingThread (e :: SomeException) throwIO e withApplication (return wrappedApp) action data Waiter a = Waiter { notify :: a -> IO (), waitFor :: IO a } mkWaiter :: IO (Waiter a) mkWaiter = do mvar <- newEmptyMVar return $ Waiter { notify = putMVar mvar, waitFor = readMVar mvar } -- | Opens a socket on a free port and returns both port and socket. -- -- @since 3.2.4 openFreePort :: IO (Port, Socket) openFreePort = do s <- socket AF_INET Stream defaultProtocol localhost <- inet_addr "127.0.0.1" bind s (SockAddrInet aNY_PORT localhost) listen s 1 port <- socketPort s return (fromIntegral port, s) -- | Like 'openFreePort' but closes the socket before exiting. withFreePort :: ((Port, Socket) -> IO a) -> IO a withFreePort = bracket openFreePort (close . snd) warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/0000755000000000000000000000000012750546070016171 5ustar0000000000000000warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs0000644000000000000000000000205712750546070020701 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.2.8/Network/Wai/Handler/Warp/HTTP2/File.hs0000644000000000000000000001640112750546070017406 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns, RecordWildCards #-} module Network.Wai.Handler.Warp.HTTP2.File ( RspFileInfo(..) , conditionalRequest , addContentHeadersForFilePart , parseByteRanges ) where import Control.Applicative ((<|>)) import qualified Data.ByteString as B hiding (pack) import qualified Data.ByteString.Char8 as B (pack, readInteger) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Network.HTTP.Date import qualified Network.HTTP.Types as H import Network.Wai import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.PackInt import Numeric (showInt) import Network.HPACK import Network.HPACK.Token #ifndef MIN_VERSION_http_types #define MIN_VERSION_http_types(x,y,z) 1 #endif -- $setup -- >>> import Test.QuickCheck ---------------------------------------------------------------- data RspFileInfo = WithoutBody !H.Status | WithBody !H.Status !TokenHeaderList !Integer !Integer deriving (Eq,Show) ---------------------------------------------------------------- conditionalRequest :: I.FileInfo -> TokenHeaderList -- Response -> ValueTable -- Request -> RspFileInfo conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of nobody@(WithoutBody _) -> nobody WithBody s _ off len -> let !hs = (tokenLastModified,date) : addContentHeaders ths0 off len size in WithBody s hs off len where !mcondition = ifmodified reqtbl size mtime <|> ifunmodified reqtbl size mtime <|> ifrange reqtbl size mtime !condition = fromMaybe (unconditional reqtbl size) mcondition ---------------------------------------------------------------- {-# INLINE ifModifiedSince #-} ifModifiedSince :: ValueTable -> Maybe HTTPDate ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate {-# INLINE ifUnmodifiedSince #-} ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate {-# INLINE ifRange #-} ifRange :: ValueTable -> Maybe HTTPDate ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate ---------------------------------------------------------------- {-# INLINE ifmodified #-} ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo ifmodified reqtbl size mtime = do date <- ifModifiedSince reqtbl return $ if date /= mtime then unconditional reqtbl size else WithoutBody H.notModified304 {-# INLINE ifunmodified #-} ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo ifunmodified reqtbl size mtime = do date <- ifUnmodifiedSince reqtbl return $ if date == mtime then unconditional reqtbl size else WithoutBody H.preconditionFailed412 {-# INLINE ifrange #-} ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo ifrange reqtbl size mtime = do date <- ifRange reqtbl rng <- getHeaderValue tokenRange reqtbl return $ if date == mtime then parseRange rng size else WithBody H.ok200 [] 0 size {-# INLINE unconditional #-} unconditional :: ValueTable -> Integer -> RspFileInfo unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of Nothing -> WithBody H.ok200 [] 0 size Just rng -> parseRange rng size ---------------------------------------------------------------- {-# INLINE parseRange #-} parseRange :: ByteString -> Integer -> RspFileInfo parseRange rng size = case parseByteRanges rng of Nothing -> WithoutBody H.requestedRangeNotSatisfiable416 Just [] -> WithoutBody H.requestedRangeNotSatisfiable416 Just (r:_) -> let (!beg, !end) = checkRange r size !len = end - beg + 1 s = if beg == 0 && end == size - 1 then H.ok200 else H.partialContent206 in WithBody s [] beg len {-# INLINE checkRange #-} checkRange :: H.ByteRange -> Integer -> (Integer, Integer) checkRange (H.ByteRangeFrom beg) size = (beg, size - 1) checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end) checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1) {-# INLINE parseByteRanges #-} -- | 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 ---------------------------------------------------------------- {-# INLINE contentRangeHeader #-} -- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' -- for the range specified. contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader contentRangeHeader beg end total = (tokenContentRange, range) where range = B.pack -- building with ShowS $ 'b' : 'y': 't' : 'e' : 's' : ' ' : (if beg > end then ('*':) else showInt beg . ('-' :) . showInt end) ( '/' : showInt total "") {-# INLINE addContentHeaders #-} addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList addContentHeaders ths off len size | len == size = ths' | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size in ctrng:ths' where !lengthBS = packIntegral len !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths {-# INLINE addContentHeadersForFilePart #-} -- | -- -- >>> addContentHeadersForFilePart [] (FilePart 2 10 16) -- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")] -- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) -- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")] addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList addContentHeadersForFilePart hs part = addContentHeaders hs off len size where off = filePartOffset part len = filePartByteCount part size = filePartFileSize part warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/HPACK.hs0000644000000000000000000000737512750546070017367 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, BangPatterns #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards #-} module Network.Wai.Handler.Warp.HTTP2.HPACK ( hpackEncodeHeader , hpackEncodeHeaderLoop , hpackDecodeHeader , just , addNecessaryHeaders ) where import qualified Control.Exception as E import Control.Monad (unless) import Data.ByteString (ByteString) import Network.HPACK hiding (Buffer) import Network.HPACK.Token import Network.HTTP2 import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.PackInt import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types -- $setup -- >>> :set -XOverloadedStrings ---------------------------------------------------------------- {-# INLINE addHeader #-} addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList addHeader t v tbl ths = case getHeaderValue t tbl of Nothing -> (t,v) : ths Just _ -> ths addNecessaryHeaders :: Context -> Rspn -> InternalInfo -> S.Settings -> IO TokenHeaderList addNecessaryHeaders Context{..} rspn ii settings = do date <- getDate ii let !s = rspnStatus rspn !status = packStatus s !defServer = S.settingsServerName settings (!ths0,tbl) = rspnHeaders rspn !ths1 = addHeader tokenServer defServer tbl ths0 !ths2 = addHeader tokenDate date tbl ths1 !ths3 = (tokenStatus, status) : ths2 return ths3 ---------------------------------------------------------------- strategy :: EncodeStrategy strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False } -- Set-Cookie: contains only one cookie value. -- So, we don't need to split it. hpackEncodeHeader :: Context -> Buffer -> BufSize -> TokenHeaderList -> IO (TokenHeaderList, Int) hpackEncodeHeader Context{..} buf siz ths = encodeTokenHeader buf siz strategy True encodeDynamicTable ths hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> TokenHeaderList -> IO (TokenHeaderList, Int) hpackEncodeHeaderLoop Context{..} buf siz hs = encodeTokenHeader buf siz strategy False encodeDynamicTable hs ---------------------------------------------------------------- hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable) hpackDecodeHeader hdrblk Context{..} = do tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl unless (checkRequestHeader vt) $ E.throwIO $ ConnectionError ProtocolError "the header key is illegal" return tbl where handl IllegalHeaderName = E.throwIO $ ConnectionError ProtocolError "the header key is illegal" handl _ = E.throwIO $ ConnectionError CompressionError "cannot decompress the header" {-# INLINE checkRequestHeader #-} checkRequestHeader :: ValueTable -> Bool checkRequestHeader reqvt | mStatus /= Nothing = False | mMethod == Nothing = False | mAuthority == Nothing = False | mConnection /= Nothing = False | just mTE (/= "trailers") = False | just mMethod (== "CONNECT") = mPath == Nothing && mScheme == Nothing | otherwise = mPath /= Nothing where mStatus = getHeaderValue tokenStatus reqvt mScheme = getHeaderValue tokenScheme reqvt mPath = getHeaderValue tokenPath reqvt mMethod = getHeaderValue tokenMethod reqvt mAuthority = getHeaderValue tokenAuthority reqvt mConnection = getHeaderValue tokenConnection reqvt mTE = getHeaderValue tokenTE reqvt {-# INLINE just #-} just :: Maybe a -> (a -> Bool) -> Bool just Nothing _ = False just (Just x) p | p x = True | otherwise = False warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/Manager.hs0000644000000000000000000000532112750546070020100 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns #-} -- | A thread pool manager. -- The manager has responsibility to spawn and kill -- worker threads. module Network.Wai.Handler.Warp.HTTP2.Manager ( Manager , start , setAction , stop , spawnAction , addMyId , deleteMyId ) where #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 Data.Foldable import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.Timeout as T ---------------------------------------------------------------- type Action = T.Manager -> IO () data Command = Stop | Spawn | Add ThreadId | Delete ThreadId data Manager = Manager (TQueue Command) (IORef Action) -- | Starting a thread pool manager. -- Its action is initially set to 'return ()' and should be set -- by 'setAction'. This allows that the action can include -- the manager itself. start :: Settings -> IO Manager start set = do q <- newTQueueIO ref <- newIORef (\_ -> return ()) timmgr <- T.initialize $ settingsTimeout set * 1000000 void $ forkIO $ go q Set.empty ref timmgr return $ Manager q ref where go q !tset0 ref timmgr = do x <- atomically $ readTQueue q case x of Stop -> kill tset0 >> T.killManager timmgr Spawn -> next tset0 Add newtid -> let !tset = add newtid tset0 in go q tset ref timmgr Delete oldtid -> let !tset = del oldtid tset0 in go q tset ref timmgr where next tset = do action <- readIORef ref newtid <- forkIO (action timmgr) let !tset' = add newtid tset go q tset' ref timmgr setAction :: Manager -> Action -> IO () setAction (Manager _ ref) action = writeIORef ref action stop :: Manager -> IO () stop (Manager q _) = atomically $ writeTQueue q Stop spawnAction :: Manager -> IO () spawnAction (Manager q _) = atomically $ writeTQueue q Spawn addMyId :: Manager -> IO () addMyId (Manager q _) = do tid <- myThreadId atomically $ writeTQueue q $ Add tid deleteMyId :: Manager -> IO () deleteMyId (Manager q _) = do tid <- myThreadId atomically $ writeTQueue q $ Delete tid ---------------------------------------------------------------- add :: ThreadId -> Set ThreadId -> Set ThreadId add tid set = set' where !set' = Set.insert tid set del :: ThreadId -> Set ThreadId -> Set ThreadId del tid set = set' where !set' = Set.delete tid set kill :: Set ThreadId -> IO () kill set = traverse_ killThread set warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/Receiver.hs0000644000000000000000000003710212750546070020274 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 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 Network.HPACK import Network.HPACK.Token import Network.HTTP2 import Network.HTTP2.Priority (toPrecedence, delete, prepare) import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.HPACK import Network.Wai.Handler.Warp.HTTP2.Request import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO () frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway where Context{ http2settings , streamTable , concurrency , continued , clientStreamId , inputQ , controlQ } = ctx sendGoaway e | Just (ConnectionError err msg) <- E.fromException e = do csid <- readIORef clientStreamId let !frame = goawayFrame csid err msg enqueueControl controlQ $ CGoaway frame | otherwise = return () sendReset err sid = do let !frame = resetFrame err sid enqueueControl controlQ $ CFrame frame loop :: Int -> IO () loop !n | n == 6 = do yield loop 0 | otherwise = do hd <- recvN frameHeaderLength if BS.null hd then enqueueControl controlQ CFinish else do cont <- processStreamGuardingError $ decodeFrameHeader hd when cont $ loop (n + 1) processStreamGuardingError (fid, FrameHeader{streamId}) | isResponse streamId && (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) = E.throwIO $ ConnectionError ProtocolError "stream id should be odd" processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do mx <- readIORef continued case mx of Nothing -> do -- ignoring unknown frame consume payloadLength return True Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame" processStreamGuardingError (FramePushPromise, _) = E.throwIO $ ConnectionError ProtocolError "push promise is not allowed" processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do settings <- readIORef http2settings case checkFrameHeader settings typhdr of Left h2err -> case h2err of StreamError err sid -> do sendReset err sid consume payloadLength return True connErr -> E.throwIO connErr Right _ -> do ex <- E.try $ controlOrStream ftyp header case ex of Left (StreamError err sid) -> do sendReset err sid return True Left connErr -> E.throw connErr Right cont -> return cont controlOrStream ftyp header@FrameHeader{streamId, payloadLength} | isControl streamId = do pl <- recvN payloadLength control ftyp header pl ctx | otherwise = do checkContinued !mstrm <- getStream pl <- recvN payloadLength case mstrm of Nothing -> do -- for h2spec only when (ftyp == FramePriority) $ do PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl checkPriority newpri streamId return True -- just ignore this frame Just strm@Stream{streamState,streamPrecedence} -> do state <- readIORef streamState state' <- stream ftyp header pl ctx state strm case state' of Open (NoBody tbl@(_,reqvt) pri) -> do resetContinued let mcl = readInt <$> getHeaderValue tokenContentLength reqvt when (just mcl (== (0 :: Int))) $ E.throwIO $ StreamError ProtocolError streamId writeIORef streamPrecedence $ toPrecedence pri writeIORef streamState HalfClosed (!req, !ii) <- mkreq tbl (Just 0, return "") atomically $ writeTQueue inputQ $ Input strm req reqvt ii Open (HasBody tbl@(_,reqvt) pri) -> do resetContinued q <- newTQueueIO let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt writeIORef streamPrecedence $ toPrecedence pri bodyLength <- newIORef 0 writeIORef streamState $ Open (Body q mcl bodyLength) readQ <- newReadBody q bodySource <- mkSource readQ (!req, !ii) <- mkreq tbl (mcl, readSource bodySource) atomically $ writeTQueue inputQ $ Input strm req reqvt ii 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 js@(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 js Nothing | isResponse streamId -> return Nothing | otherwise -> do when (ftyp `notElem` [FrameHeaders,FramePriority]) $ E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream" csid <- readIORef clientStreamId when (streamId <= csid) $ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease" when (ftyp == FrameHeaders) $ do writeIORef clientStreamId streamId cnt <- readIORef concurrency -- Checking the limitation of concurrency when (cnt >= maxConcurrency) $ E.throwIO $ StreamError RefusedStream streamId ws <- initialWindowSize <$> readIORef http2settings newstrm <- newStream streamId (fromIntegral ws) when (ftyp == FrameHeaders) $ opened ctx newstrm insert streamTable streamId newstrm return $ Just newstrm consume = void . recvN maxConcurrency :: Int maxConcurrency = recommendedConcurrency initialFrame :: ByteString initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)] ---------------------------------------------------------------- control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ,firstSettings} = do SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs case checkSettingsList alist of Just x -> E.throwIO x Nothing -> return () -- HTTP/2 Setting from a browser unless (testAck flags) $ do modifyIORef' http2settings $ \old -> updateSettings old alist let !frame = settingsFrame setAck [] sent <- readIORef firstSettings let !setframe | sent = CSettings frame alist | otherwise = CSettings0 initialFrame frame alist unless sent $ writeIORef firstSettings True enqueueControl controlQ setframe return True control FramePing FrameHeader{flags} bs Context{controlQ} = if testAck flags then E.throwIO $ ConnectionError ProtocolError "the ack flag of this ping frame must not be set" else do let !frame = pingFrame bs enqueueControl controlQ $ CFrame frame return True control FrameGoAway _ _ Context{controlQ} = do enqueueControl controlQ CFinish return False control FrameWindowUpdate header bs Context{connectionWindow} = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs !w <- (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 ---------------------------------------------------------------- {-# INLINE guardIt #-} guardIt :: Either HTTP2Error a -> IO a guardIt x = case x of Left err -> E.throwIO err Right frame -> return frame {-# INLINE checkPriority #-} checkPriority :: Priority -> StreamId -> IO () checkPriority p me | dep == me = E.throwIO $ StreamError ProtocolError me | otherwise = return () where dep = streamDependency p stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs pri <- case mp of Nothing -> return defaultPriority Just p -> do checkPriority p streamNumber return p let !endOfStream = testEndStream flags !endOfHeader = testEndHeader flags if endOfHeader then do tbl <- hpackDecodeHeader frag ctx -- fixme return $ if endOfStream then Open (NoBody tbl pri) else Open (HasBody tbl pri) else do let !siz = BS.length frag return $ Open $ Continued [frag] siz 1 endOfStream pri stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do -- trailer is not supported. -- let's read and ignore it. HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs let !endOfStream = testEndStream flags if endOfStream then do atomically $ writeTQueue q "" return 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{controlQ} s@(Open (Body q mcl bodyLength)) Stream{streamNumber} = do DataFrame body <- guardIt $ decodeDataFrame header bs let !endOfStream = testEndStream flags len0 <- readIORef bodyLength let !len = len0 + payloadLength writeIORef bodyLength len when (payloadLength /= 0) $ do let !frame1 = windowUpdateFrame 0 payloadLength !frame2 = windowUpdateFrame streamNumber payloadLength !frame = frame1 `BS.append` frame2 enqueueControl controlQ $ CFrame frame atomically $ writeTQueue q body if endOfStream then do case mcl of Nothing -> return () Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId atomically $ writeTQueue q "" return 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' tbl <- hpackDecodeHeader hdrblk ctx return $ if endOfStream then Open (NoBody tbl pri) else Open (HasBody tbl pri) else return $ Open $ Continued rfrags' siz' n' endOfStream pri stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs !w <- (n +) <$> atomically (readTVar streamWindow) when (isWindowOverflow w) $ E.throwIO $ StreamError FlowControlError streamId atomically $ writeTVar streamWindow w return s stream FrameRSTStream header bs ctx _ strm = do RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs let !cc = Reset e closed ctx strm cc return $ Closed cc -- will be written to streamState again stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs checkPriority newpri streamNumber oldpre <- readIORef streamPrecedence let !newpre = toPrecedence newpri writeIORef streamPrecedence newpre if isIdle s then do n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1)) -- fixme hard coding when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames" prepare outputQ streamNumber newpri else do mx <- delete outputQ streamNumber oldpre case mx of Nothing -> return () Just out -> enqueueOutput outputQ out return s -- this ordering is important stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here" stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames" -- Ignore frames to streams we have just reset, per section 5.1. stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId ---------------------------------------------------------------- {-# INLINE newReadBody #-} newReadBody :: TQueue ByteString -> IO (IO ByteString) newReadBody q = do ref <- newIORef False return $ readBody q ref {-# INLINE readBody #-} readBody :: TQueue ByteString -> IORef Bool -> IO ByteString readBody q ref = do eof <- readIORef ref if eof then return "" else do bs <- atomically $ readTQueue q when (bs == "") $ writeIORef ref True return bs warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/Request.hs0000644000000000000000000001161712750546070020163 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.HTTP2.Request ( mkRequest , MkReq , getHTTP2Data , setHTTP2Data , modifyHTTP2Data ) where import Control.Applicative ((<|>)) import Control.Arrow (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import Data.Maybe (fromJust) import qualified Data.Vault.Lazy as Vault import Network.HPACK import Network.HPACK.Token import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.HashMap (hashByteString) import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import qualified Network.Wai.Handler.Warp.Timeout as Timeout import Network.Wai.Handler.Warp.Types import Network.Wai.Internal (Request(..)) import System.IO.Unsafe (unsafePerformIO) type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo) mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do ref <- newIORef Nothing mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr -> IORef (Maybe HTTP2Data) -> MkReq mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii) where !req = Request { requestMethod = colonMethod , httpVersion = http2ver , rawPathInfo = rawPath , pathInfo = H.decodePathSegments path , rawQueryString = query , queryString = H.parseQuery query , requestHeaders = headers , isSecure = True , remoteHost = addr , requestBody = body , vault = vaultValue , requestBodyLength = maybe ChunkedBody (KnownLength . fromIntegral) bodylen , requestHeaderHost = mHost <|> mAuth , requestHeaderRange = mRange , requestHeaderReferer = mReferer , requestHeaderUserAgent = mUserAgent } headers = map (first tokenKey) ths where ths = case mHost of Just _ -> reqths Nothing -> case mAuth of Just auth -> (tokenHost, auth) : reqths _ -> reqths !mPath = getHeaderValue tokenPath reqvt -- SHOULD !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD !mHost = getHeaderValue tokenHost reqvt !mRange = getHeaderValue tokenRange reqvt !mReferer = getHeaderValue tokenReferer reqvt !mUserAgent = getHeaderValue tokenUserAgent reqvt -- CONNECT request will have ":path" omitted, use ":authority" as unparsed -- path instead so that it will have consistent behavior compare to HTTP 1.0 (unparsedPath,query) = B8.break (=='?') $ fromJust (mPath <|> mAuth) !path = H.extractPath unparsedPath !rawPath = if S.settingsNoParsePath settings then unparsedPath else path !h = hashByteString rawPath !ii = toInternalInfo ii1 h !th = threadHandle ii !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (getFileInfo ii) $ Vault.insert getHTTP2DataKey (readIORef ref) $ Vault.insert setHTTP2DataKey (writeIORef ref) $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref) Vault.empty getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data)) getHTTP2DataKey = unsafePerformIO Vault.newKey {-# NOINLINE getHTTP2Data #-} -- | Getting 'HTTP2Data' through vault of the request. -- Warp uses this to receive 'HTTP2Data' from 'Middleware'. -- -- Since: 3.2.7 getHTTP2Data :: Request -> IO (Maybe HTTP2Data) getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of Nothing -> return Nothing Just getter -> getter setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ()) setHTTP2DataKey = unsafePerformIO Vault.newKey {-# NOINLINE setHTTP2Data #-} -- | Setting 'HTTP2Data' through vault of the request. -- 'Application' or 'Middleware' should use this. -- -- Since: 3.2.7 setHTTP2Data :: Request -> Maybe HTTP2Data -> IO () setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of Nothing -> return () Just setter -> setter mh2d modifyHTTP2DataKey :: Vault.Key ((Maybe HTTP2Data -> Maybe HTTP2Data) -> IO ()) modifyHTTP2DataKey = unsafePerformIO Vault.newKey {-# NOINLINE modifyHTTP2Data #-} -- | Modifying 'HTTP2Data' through vault of the request. -- 'Application' or 'Middleware' should use this. -- -- Since: 3.2.8 modifyHTTP2Data :: Request -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> IO () modifyHTTP2Data req func = case Vault.lookup modifyHTTP2DataKey (vault req) of Nothing -> return () Just modify -> modify func warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/Sender.hs0000644000000000000000000005216412750546070017755 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.STM import qualified Control.Exception as E import Control.Monad (void, when) import Data.Bits import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder.Extra as B import Data.Maybe (isNothing) import Data.Word (Word8, Word32) import Foreign.Ptr (Ptr, plusPtr) import Foreign.Storable (poke) import Network.HPACK (setLimitForEncoding, toHeaderTable) import Network.HTTP2 import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence) import Network.Wai import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.HPACK import Network.Wai.Handler.Warp.HTTP2.Manager (Manager) import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.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 import Network.Wai.Handler.Warp.SendFile (positionRead) import qualified Network.Wai.Handler.Warp.Timeout as T #endif ---------------------------------------------------------------- data Leftover = LZero | LOne B.BufferWriter | LTwo BS.ByteString B.BufferWriter ---------------------------------------------------------------- {-# INLINE getStreamWindowSize #-} getStreamWindowSize :: Stream -> IO WindowSize getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow {-# INLINE waitStreamWindowSize #-} waitStreamWindowSize :: Stream -> IO () waitStreamWindowSize Stream{streamWindow} = atomically $ do w <- readTVar streamWindow check (w > 0) {-# INLINE waitStreaming #-} waitStreaming :: TBQueue a -> IO () waitStreaming tbq = atomically $ do isEmpty <- isEmptyTBQueue tbq check (isEmpty == False) data Switch = C Control | O (StreamId,Precedence,Output) | Flush frameSender :: Context -> Connection -> S.Settings -> Manager -> IO () frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable} conn@Connection{connWriteBuffer,connBufferSize,connSendAll} settings mgr = loop 0 `E.catch` ignore where dequeue off = do isEmpty <- isEmptyTQueue controlQ if isEmpty then do w <- readTVar connectionWindow check (w > 0) emp <- isEmptySTM outputQ if emp then if off /= 0 then return Flush else retry else O <$> dequeueSTM outputQ else C <$> readTQueue controlQ loop off = do x <- atomically $ dequeue off case x of C ctl -> do when (off /= 0) $ flushN off off' <- control ctl off when (off' >= 0) $ loop off' O (_,pre,out) -> do let strm = outputStream out writeIORef (streamPrecedence strm) pre off' <- outputOrEnqueueAgain out off case off' of 0 -> loop 0 _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding | otherwise -> loop off' Flush -> flushN off >> loop 0 control CFinish _ = return (-1) control (CGoaway frame) _ = connSendAll frame >> return (-1) control (CFrame frame) _ = connSendAll frame >> return 0 control (CSettings frame alist) _ = do connSendAll frame setLimit alist return 0 control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case let !buf = connWriteBuffer `plusPtr` off !off' = off + BS.length frame1 + BS.length frame2 buf' <- copy buf frame1 void $ copy buf' frame2 setLimit alist return off' {-# INLINE setLimit #-} setLimit alist = case lookup SettingsHeaderTableSize alist of Nothing -> return () Just siz -> setLimitForEncoding siz encodeDynamicTable output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do -- Data frame payload let !buf = connWriteBuffer `plusPtr` off0 !siz = connBufferSize - off0 Next datPayloadLen mnext <- curr buf siz lim off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D maybeEnqueueNext out mnext return off output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do -- Header frame and Continuation frame let !sid = streamNumber strm !endOfStream = case rspn of RspnNobody _ _ -> True _ -> False ths <- addNecessaryHeaders ctx rspn ii settings kvlen <- headerContinue sid ths endOfStream off0 off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen case rspn of RspnNobody _ _ -> do closed ctx strm Finished return off RspnFile _ _ path mpart -> do -- Data frame payload let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillFileBodyGetNext conn ii payloadOff lim path mpart off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D maybeEnqueueNext out mnext return off' RspnBuilder _ _ builder -> do -- Data frame payload let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillBuilderBodyGetNext conn ii payloadOff lim builder off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D maybeEnqueueNext out mnext return off' RspnStreaming _ _ tbq -> do let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillStreamBodyGetNext conn payloadOff lim tbq strm off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D maybeEnqueueNext out mnext return off' output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do -- Creating a push promise header -- Frame id should be associated stream id from the client. let !sid = streamNumber strm len <- pushPromise pid sid ths off0 off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len output out{ outputType = ORspn } off lim output _ _ _ = undefined -- never reach outputOrEnqueueAgain out off = E.handle resetStream $ do state <- readIORef $ streamState strm if isClosed state then return off else case out of Output _ _ _ wait _ OWait -> do -- Checking if all push are done. let out' = out { outputHook = return () , outputType = ORspn } forkAndEnqueueWhenReady wait outputQ out' mgr return off _ -> case mtbq of Just tbq -> checkStreaming tbq _ -> checkStreamWindowSize where strm = outputStream out mtbq = outputMaybeTBQueue out checkStreaming tbq = do isEmpty <- atomically $ isEmptyTBQueue tbq if isEmpty then do forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr return off else checkStreamWindowSize checkStreamWindowSize = do sws <- getStreamWindowSize strm if sws == 0 then do forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr return off else do cws <- atomically $ readTVar connectionWindow -- not 0 let !lim = min cws sws output out off lim resetStream e = do closed ctx strm (ResetByMe e) let !rst = resetFrame InternalError $ streamNumber strm enqueueControl controlQ $ CFrame rst return off {-# INLINE flushN #-} -- Flush the connection buffer to the socket, where the first 'n' bytes of -- the buffer are filled. flushN :: Int -> IO () flushN n = bufferIO connWriteBuffer n connSendAll headerContinue sid ths endOfStream off = do let !offkv = off + frameHeaderLength let !bufkv = connWriteBuffer `plusPtr` offkv !limkv = connBufferSize - offkv (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths let flag0 = case hs of [] -> setEndHeader defaultFlags _ -> defaultFlags flag = if endOfStream then setEndStream flag0 else flag0 let buf = connWriteBuffer `plusPtr` off fillFrameHeader FrameHeaders kvlen sid flag buf continue sid kvlen hs !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength !headerPayloadLim = connBufferSize - frameHeaderLength continue _ kvlen [] = return kvlen continue sid kvlen ths = do flushN $ kvlen + frameHeaderLength -- Now off is 0 (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header" let flag = case ths' of [] -> setEndHeader defaultFlags _ -> defaultFlags fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer continue sid kvlen' ths' {-# INLINE maybeEnqueueNext #-} -- Re-enqueue the stream in the output queue. maybeEnqueueNext :: Output -> Maybe DynaNext -> IO () maybeEnqueueNext _ Nothing = return () maybeEnqueueNext out (Just next) = enqueueOutput outputQ out' where !out' = out { outputType = ONext next } {-# INLINE sendHeadersIfNecessary #-} -- Send headers if there is not room for a 1-byte data frame, and return -- the offset of the next frame's first header byte. sendHeadersIfNecessary off -- True if the connection buffer has room for a 1-byte data frame. | off + frameHeaderLength < connBufferSize = return off | otherwise = do flushN off return 0 fillDataHeader strm@Stream{streamWindow,streamNumber} off datPayloadLen mnext tell getH2D = do -- Data frame header mh2d <- getH2D let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of Nothing -> ([], True) Just ts -> (ts, null ts) !buf = connWriteBuffer `plusPtr` off !off' = off + frameHeaderLength + datPayloadLen !noMoreBody = isNothing mnext flag | noMoreBody && noTrailers = setEndStream defaultFlags | otherwise = defaultFlags fillFrameHeader FrameData datPayloadLen streamNumber flag buf off'' <- handleEndOfBody noMoreBody off' noTrailers trailers atomically $ modifyTVar' connectionWindow (subtract datPayloadLen) atomically $ modifyTVar' streamWindow (subtract datPayloadLen) return off'' where handleTrailers True off0 _ = return off0 handleTrailers _ off0 trailers = do (ths,_) <- toHeaderTable trailers kvlen <- headerContinue streamNumber ths True off0 sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen handleEndOfBody True off0 noTrailers trailers = do off1 <- handleTrailers noTrailers off0 trailers void $ tell closed ctx strm Finished return off1 handleEndOfBody False off0 _ _ = return off0 pushPromise pid sid ths off = do let !offsid = off + frameHeaderLength !bufsid = connWriteBuffer `plusPtr` offsid poke32 bufsid $ fromIntegral sid let !offkv = offsid + 4 !bufkv = connWriteBuffer `plusPtr` offkv !limkv = connBufferSize - offkv (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths let !flag = setEndHeader defaultFlags -- No EndStream flag !buf = connWriteBuffer `plusPtr` off !len = kvlen + 4 fillFrameHeader FramePushPromise len pid flag buf return len {-# INLINE fillFrameHeader #-} fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf where hinfo = FrameHeader len flag sid {-# INLINE ignore #-} ignore :: E.SomeException -> IO () ignore _ = return () ---------------------------------------------------------------- {- ResponseFile Status ResponseHeaders FilePath (Maybe FilePart) ResponseBuilder Status ResponseHeaders Builder ResponseStream Status ResponseHeaders StreamingBody ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response -} fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize} _ off lim bb = do let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (len, signal) <- B.runBuilder bb datBuf room return $ nextForBuilder len signal fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next #ifdef WINDOWS fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize} _ off lim path mpart = do let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (start, bytes) <- fileStartEnd path mpart -- fixme: how to close Handle? GC does it at this moment. hdl <- IO.openBinaryFile path IO.ReadMode IO.hSeek hdl IO.AbsoluteSeek start len <- IO.hGetBufSome hdl datBuf (mini room bytes) let bytes' = bytes - fromIntegral len -- fixme: connWriteBuffer connBufferSize return $ nextForFile len hdl bytes' (return ()) #else fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize} ii off lim path mpart = do (mfd, refresh') <- getFd ii path (fd, refresh) <- case mfd of Nothing -> do fd' <- openFile path th <- T.register (timeoutManager ii) (closeFile fd') return (fd', T.tickle th) Just fd -> return (fd, refresh') let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (start, bytes) <- fileStartEnd path mpart len <- positionRead fd datBuf (mini room bytes) start refresh let len' = fromIntegral len return $ nextForFile len fd (start + len') (bytes - len') refresh #endif fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer) fileStartEnd _ (Just part) = return (filePartOffset part, filePartByteCount part) fileStartEnd _ _ = error "fileStartEnd" ---------------------------------------------------------------- fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize} off lim sq strm = do let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (leftover, cont, len) <- runStreamBuilder datBuf room sq return $ nextForStream sq strm leftover cont len ---------------------------------------------------------------- fillBufBuilder :: Leftover -> DynaNext fillBufBuilder leftover buf0 siz0 lim = do let payloadBuf = buf0 `plusPtr` frameHeaderLength room = min (siz0 - frameHeaderLength) lim case leftover of LZero -> error "fillBufBuilder: LZero" LOne writer -> do (len, signal) <- writer payloadBuf room getNext len signal LTwo bs writer | BS.length bs <= room -> do buf1 <- copy payloadBuf bs let len1 = BS.length bs (len2, signal) <- writer buf1 (room - len1) getNext (len1 + len2) signal | otherwise -> do let (bs1,bs2) = BS.splitAt room bs void $ copy payloadBuf bs1 getNext room (B.Chunk bs2 writer) where getNext l s = return $ nextForBuilder l s nextForBuilder :: BytesFilled -> B.Next -> Next nextForBuilder len B.Done = Next len Nothing nextForBuilder len (B.More _ writer) = Next len $ Just (fillBufBuilder (LOne writer)) nextForBuilder len (B.Chunk bs writer) = Next len $ Just (fillBufBuilder (LTwo bs writer)) ---------------------------------------------------------------- runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence -> IO (Leftover, Bool, BytesFilled) runStreamBuilder buf0 room0 sq = loop buf0 room0 0 where loop !buf !room !total = do mbuilder <- atomically $ tryReadTBQueue sq case mbuilder of Nothing -> return (LZero, True, total) Just (SBuilder builder) -> do (len, signal) <- B.runBuilder builder buf room let !total' = total + len case signal of B.Done -> loop (buf `plusPtr` len) (room - len) total' B.More _ writer -> return (LOne writer, True, total') B.Chunk bs writer -> return (LTwo bs writer, True, total') Just SFlush -> return (LZero, True, total) Just SFinish -> return (LZero, False, total) fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext fillBufStream leftover0 sq strm buf0 siz0 lim0 = do let payloadBuf = buf0 `plusPtr` frameHeaderLength room0 = min (siz0 - frameHeaderLength) lim0 case leftover0 of LZero -> do (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq getNext leftover cont len LOne writer -> write writer payloadBuf room0 0 LTwo bs writer | BS.length bs <= room0 -> do buf1 <- copy payloadBuf bs let len = BS.length bs write writer buf1 (room0 - len) len | otherwise -> do let (bs1,bs2) = BS.splitAt room0 bs void $ copy payloadBuf bs1 getNext (LTwo bs2 writer) True room0 where getNext l b r = return $ nextForStream sq strm l b r write writer1 buf room sofar = do (len, signal) <- writer1 buf room case signal of B.Done -> do (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq let !total = sofar + len + extra getNext leftover cont total B.More _ writer -> do let !total = sofar + len getNext (LOne writer) True total B.Chunk bs writer -> do let !total = sofar + len getNext (LTwo bs writer) True total nextForStream :: TBQueue Sequence -> Stream -> Leftover -> Bool -> BytesFilled -> Next nextForStream _ _ _ False len = Next len Nothing nextForStream sq strm leftOrZero True len = Next len $ Just (fillBufStream leftOrZero sq strm) ---------------------------------------------------------------- #ifdef WINDOWS fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext fillBufFile h bytes refresh buf siz lim = do let payloadBuf = buf `plusPtr` frameHeaderLength room = min (siz - frameHeaderLength) lim len <- IO.hGetBufSome h payloadBuf room refresh let bytes' = bytes - fromIntegral len return $ nextForFile len h bytes' refresh nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next nextForFile 0 _ _ _ = Next 0 Nothing nextForFile len _ 0 _ = Next len Nothing nextForFile len h bytes refresh = Next len $ Just (fillBufFile h bytes refresh) #else fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext fillBufFile fd start bytes refresh buf siz lim = do let payloadBuf = buf `plusPtr` frameHeaderLength room = min (siz - frameHeaderLength) lim len <- positionRead fd payloadBuf (mini room bytes) start let len' = fromIntegral len refresh return $ nextForFile len fd (start + len') (bytes - len') refresh nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next nextForFile 0 _ _ _ _ = Next 0 Nothing nextForFile len _ _ 0 _ = Next len Nothing nextForFile len fd start bytes refresh = Next len $ Just (fillBufFile fd start bytes refresh) #endif {-# INLINE mini #-} mini :: Int -> Integer -> Int mini i n | fromIntegral i < n = i | otherwise = fromIntegral n ---------------------------------------------------------------- poke32 :: Ptr Word8 -> Word32 -> IO () poke32 ptr i = do poke ptr w0 poke8 ptr 1 w1 poke8 ptr 2 w2 poke8 ptr 3 w3 where w0 = fromIntegral ((i `shiftR` 24) .&. 0xff) w1 = fromIntegral ((i `shiftR` 16) .&. 0xff) w2 = fromIntegral ((i `shiftR` 8) .&. 0xff) w3 = fromIntegral (i .&. 0xff) poke8 :: Ptr Word8 -> Int -> Word8 -> IO () poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/Types.hs0000644000000000000000000002457512750546070017646 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.HTTP2.Types where import Data.ByteString.Builder (Builder) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>),(<*>)) #endif import Control.Concurrent (forkIO) import Control.Concurrent.STM import Control.Exception (SomeException, bracket) import Control.Monad (void) 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.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.Types import Network.HTTP2 import Network.HTTP2.Priority import Network.HPACK hiding (Buffer) ---------------------------------------------------------------- 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 ---------------------------------------------------------------- data Input = Input Stream Request ValueTable InternalInfo ---------------------------------------------------------------- type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next type BytesFilled = Int data Next = Next !BytesFilled (Maybe DynaNext) data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable) | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence) | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart) rspnStatus :: Rspn -> H.Status rspnStatus (RspnNobody s _) = s rspnStatus (RspnStreaming s _ _) = s rspnStatus (RspnBuilder s _ _) = s rspnStatus (RspnFile s _ _ _ ) = s rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable) rspnHeaders (RspnNobody _ t) = t rspnHeaders (RspnStreaming _ t _) = t rspnHeaders (RspnBuilder _ t _) = t rspnHeaders (RspnFile _ t _ _ ) = t data Output = Output { outputStream :: !Stream , outputRspn :: !Rspn , outputII :: !InternalInfo , outputHook :: IO () -- OPush: wait for done, O*: telling done , outputH2Data :: IO (Maybe HTTP2Data) , outputType :: !OutputType } data OutputType = ORspn | OWait | OPush !TokenHeaderList !StreamId -- associated stream id from client | ONext !DynaNext outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence) outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq outputMaybeTBQueue _ = Nothing data Control = CFinish | CGoaway !ByteString | CFrame !ByteString | CSettings !ByteString !SettingsList | CSettings0 !ByteString !ByteString !SettingsList ---------------------------------------------------------------- data Sequence = SFinish | SFlush | SBuilder Builder ---------------------------------------------------------------- -- | The context for HTTP/2 connection. data Context = Context { -- HTTP/2 settings received from a browser http2settings :: !(IORef Settings) , firstSettings :: !(IORef Bool) , streamTable :: !StreamTable , concurrency :: !(IORef Int) , priorityTreeSize :: !(IORef Int) -- | RFC 7540 says "Other frames (from any stream) MUST NOT -- occur between the HEADERS frame and any CONTINUATION -- frames that might follow". This field is used to implement -- this requirement. , continued :: !(IORef (Maybe StreamId)) , clientStreamId :: !(IORef StreamId) , serverStreamId :: !(IORef StreamId) , inputQ :: !(TQueue Input) , outputQ :: !(PriorityTree Output) , controlQ :: !(TQueue Control) , encodeDynamicTable :: !DynamicTable , decodeDynamicTable :: !DynamicTable -- the connection window for data from a server to a browser. , connectionWindow :: !(TVar WindowSize) } ---------------------------------------------------------------- newContext :: IO Context newContext = Context <$> newIORef defaultSettings <*> newIORef False <*> newStreamTable <*> newIORef 0 <*> newIORef 0 <*> newIORef Nothing <*> newIORef 0 <*> newIORef 0 <*> newTQueueIO <*> newPriorityTree <*> newTQueueIO <*> newDynamicTableForEncoding defaultDynamicTableSize <*> newDynamicTableForDecoding defaultDynamicTableSize 4096 <*> newTVarIO defaultInitialWindowSize clearContext :: Context -> IO () clearContext _ctx = return () ---------------------------------------------------------------- data OpenState = JustOpened | Continued [HeaderBlockFragment] !Int -- Total size !Int -- The number of continuation frames !Bool -- End of stream !Priority | NoBody (TokenHeaderList,ValueTable) !Priority | HasBody (TokenHeaderList,ValueTable) !Priority | Body !(TQueue ByteString) !(Maybe Int) -- received Content-Length -- compared the body length for error checking !(IORef Int) -- actual body length data ClosedCode = Finished | Killed | Reset !ErrorCodeId | ResetByMe SomeException deriving Show data StreamState = Idle | Open !OpenState | HalfClosed | Closed !ClosedCode | Reserved 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 show Reserved = "Reserved" ---------------------------------------------------------------- data Stream = Stream { streamNumber :: !StreamId , streamState :: !(IORef StreamState) , streamWindow :: !(TVar WindowSize) , streamPrecedence :: !(IORef Precedence) } instance Show Stream where show s = show (streamNumber s) newStream :: StreamId -> WindowSize -> IO Stream newStream sid win = Stream sid <$> newIORef Idle <*> newTVarIO win <*> newIORef defaultPrecedence newPushStream :: Context -> WindowSize -> Precedence -> IO Stream newPushStream Context{serverStreamId} win pre = do sid <- atomicModifyIORef' serverStreamId inc2 Stream sid <$> newIORef Reserved <*> newTVarIO win <*> newIORef pre where inc2 x = let !x' = x + 2 in (x', x') ---------------------------------------------------------------- opened :: Context -> Stream -> IO () opened Context{concurrency} Stream{streamState} = do atomicModifyIORef' concurrency (\x -> (x+1,())) writeIORef streamState (Open JustOpened) closed :: Context -> Stream -> ClosedCode -> IO () closed Context{concurrency,streamTable} Stream{streamState,streamNumber} cc = do remove streamTable streamNumber atomicModifyIORef' concurrency (\x -> (x-1,())) writeIORef streamState (Closed cc) -- anyway ---------------------------------------------------------------- newtype StreamTable = StreamTable (IORef (IntMap Stream)) newStreamTable :: IO StreamTable newStreamTable = StreamTable <$> newIORef M.empty insert :: StreamTable -> M.Key -> Stream -> IO () insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m -> let !m' = M.insert k v m in (m', ()) remove :: StreamTable -> M.Key -> IO () remove (StreamTable ref) k = atomicModifyIORef' ref $ \m -> let !m' = M.delete k m in (m', ()) search :: StreamTable -> M.Key -> IO (Maybe Stream) search (StreamTable ref) k = M.lookup k <$> readIORef ref {-# INLINE forkAndEnqueueWhenReady #-} forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO () forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ -> void . forkIO $ do wait enqueueOutput outQ out where setup = addMyId mgr teardown _ = deleteMyId mgr {-# INLINE enqueueOutput #-} enqueueOutput :: PriorityTree Output -> Output -> IO () enqueueOutput outQ out = do let Stream{..} = outputStream out pre <- readIORef streamPrecedence enqueue outQ streamNumber pre out {-# INLINE enqueueControl #-} enqueueControl :: TQueue Control -> Control -> IO () enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl ---------------------------------------------------------------- -- | HTTP/2 specific data. -- -- Since: 3.2.7 data HTTP2Data = HTTP2Data { -- | Accessor for 'PushPromise' in 'HTTP2Data'. -- -- Since: 3.2.7 http2dataPushPromise :: [PushPromise] -- Since: 3.2.8 , http2dataTrailers :: H.ResponseHeaders } deriving (Eq,Show) -- | Default HTTP/2 specific data. -- -- Since: 3.2.7 defaultHTTP2Data :: HTTP2Data defaultHTTP2Data = HTTP2Data [] [] -- | HTTP/2 push promise or sever push. -- -- Since: 3.2.7 data PushPromise = PushPromise { -- | Accessor for a URL path in 'PushPromise'. -- E.g. \"\/style\/default.css\". -- -- Since: 3.2.7 promisedPath :: ByteString -- | Accessor for 'FilePath' in 'PushPromise'. -- E.g. \"FILE_PATH/default.css\". -- -- Since: 3.2.7 , promisedFile :: FilePath -- | Accessor for 'H.ResponseHeaders' in 'PushPromise' -- \"content-type\" must be specified. -- Default value: []. -- -- -- Since: 3.2.7 , promisedResponseHeaders :: H.ResponseHeaders -- | Accessor for 'Weight' in 'PushPromise'. -- Default value: 16. -- -- Since: 3.2.7 , promisedWeight :: Weight } deriving (Eq,Ord,Show) -- | Default push promise. -- -- Since: 3.2.7 defaultPushPromise :: PushPromise defaultPushPromise = PushPromise "" "" [] 16 warp-3.2.8/Network/Wai/Handler/Warp/HTTP2/Worker.hs0000644000000000000000000003110312750546070017774 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.HTTP2.Worker ( Responder , response , worker ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative import Data.Monoid (mempty) #endif import Control.Applicative ((<|>)) import Data.Maybe (fromJust) import Control.Concurrent.STM import Control.Exception (SomeException(..), AsyncException(..)) import qualified Control.Exception as E import Control.Monad (when) import Data.ByteString.Builder (byteString) import qualified Network.HTTP.Types as H import Network.HTTP2 import Network.HTTP2.Priority import Network.HPACK import Network.HPACK.Token import Network.Wai import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.HTTP2.Request import Network.Wai.Handler.Warp.IORef import qualified Network.Wai.Handler.Warp.Response as R import qualified Network.Wai.Handler.Warp.Settings as S import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..)) ---------------------------------------------------------------- -- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'. -- This type implements the second argument (Response -> IO ResponseReceived) -- with extra arguments. type Responder = InternalInfo -> ValueTable -- for Request -> ThreadContinue -> Stream -> Request -> Response -> IO ResponseReceived pushStream :: Context -> S.Settings -> StreamId -> ValueTable -> Request -> InternalInfo -> Maybe HTTP2Data -> IO (OutputType, IO ()) pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ()) pushStream ctx@Context{http2settings,outputQ,streamTable} settings pid reqvt req ii (Just h2d) | len == 0 = return (ORspn, return ()) | otherwise = do pushable <- enablePush <$> readIORef http2settings if pushable then do tvar <- newTVarIO 0 lim <- push tvar pps0 0 if lim == 0 then return (ORspn, return ()) else return (OWait, waiter lim tvar) else return (ORspn, return ()) where !pps0 = http2dataPushPromise h2d !len = length pps0 !pushLogger = S.settingsServerPushLogger settings increment tvar = atomically $ modifyTVar' tvar (+1) waiter lim tvar = atomically $ do n <- readTVar tvar check (n >= lim) !h2data = getHTTP2Data req push _ [] !n = return (n :: Int) push tvar (pp:pps) !n = do let !file = promisedFile pp efinfo <- E.try $ getFileInfo ii file case efinfo of Left (_ex :: E.IOException) -> push tvar pps n Right (FileInfo _ size _ date) -> do ws <- initialWindowSize <$> readIORef http2settings let !w = promisedWeight pp !pri = defaultPriority { weight = w } !pre = toPrecedence pri strm <- newPushStream ctx ws pre let !sid = streamNumber strm insert streamTable sid strm (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp) let !scheme = fromJust $ getHeaderValue tokenScheme reqvt -- fixme: this value can be Nothing !auth = fromJust (getHeaderValue tokenHost reqvt <|> getHeaderValue tokenAuthority reqvt) !path = promisedPath pp !promisedRequest = [(tokenMethod, H.methodGet) ,(tokenScheme, scheme) ,(tokenAuthority, auth) ,(tokenPath, path)] !part = FilePart 0 size size !rsp = RspnFile H.ok200 (ths,vt) file (Just part) !ths = (tokenLastModified,date) : addContentHeadersForFilePart ths0 part pushLogger req path size let !ot = OPush promisedRequest pid !out = Output strm rsp ii (increment tvar) h2data ot enqueueOutput outputQ out push tvar pps (n + 1) -- | This function is passed to workers. -- They also pass 'Response's from 'Application's to this function. -- This function enqueues commands for the HTTP/2 sender. response :: S.Settings -> Context -> Manager -> Responder response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of ResponseStream s0 hs0 strmbdy | noBody s0 -> responseNoBody s0 hs0 | isHead -> responseNoBody s0 hs0 | otherwise -> getHTTP2Data req >>= pushStream ctx settings sid reqvt req ii >>= responseStreaming s0 hs0 strmbdy ResponseBuilder s0 hs0 b | noBody s0 -> responseNoBody s0 hs0 | isHead -> responseNoBody s0 hs0 | otherwise -> getHTTP2Data req >>= pushStream ctx settings sid reqvt req ii >>= responseBuilderBody s0 hs0 b ResponseFile s0 hs0 p mp | noBody s0 -> responseNoBody s0 hs0 | otherwise -> getHTTP2Data req >>= pushStream ctx settings sid reqvt req ii >>= responseFileXXX s0 hs0 p mp ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw" where noBody = not . R.hasBody !isHead = requestMethod req == H.methodHead !logger = S.settingsLogger settings !th = threadHandle ii sid = streamNumber strm !h2data = getHTTP2Data req -- Ideally, log messages should be written when responses are -- actually sent. But there is no way to keep good memory usage -- (resist to Request leak) and throughput. By compromise, -- log message are written here even the window size of streams -- is 0. responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s responseNoBody' s tbl = do logger req s Nothing setThreadContinue tconf True let !rspn = RspnNobody s tbl !out = Output strm rspn ii (return ()) h2data ORspn enqueueOutput outputQ out return ResponseReceived responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do logger req s Nothing setThreadContinue tconf True tbl <- toHeaderTable hs0 let !rspn = RspnBuilder s tbl bdy !out = Output strm rspn ii tell h2data rspnOrWait enqueueOutput outputQ out return ResponseReceived responseFileXXX _ hs0 path Nothing aux = do efinfo <- E.try $ getFileInfo ii path case efinfo of Left (_ex :: E.IOException) -> response404 hs0 Right finfo -> do (rspths0,vt) <- toHeaderTable hs0 case conditionalRequest finfo rspths0 reqvt of WithoutBody s -> responseNoBody s hs0 WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux responseFileXXX s0 hs0 path mpart aux = do tbl <- toHeaderTable hs0 responseFile2XX s0 tbl path mpart aux responseFile2XX s tbl path mpart (rspnOrWait,tell) | isHead = do logger req s Nothing responseNoBody' s tbl | otherwise = do logger req s (filePartByteCount <$> mpart) setThreadContinue tconf True let !rspn = RspnFile s tbl path mpart !out = Output strm rspn ii tell h2data rspnOrWait enqueueOutput outputQ out return ResponseReceived response404 hs0 = responseBuilderBody s hs body (ORspn, return ()) where s = H.notFound404 hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do logger req s0 Nothing -- We must not exit this WAI application. -- If the application exits, streaming would be also closed. -- So, this work occupies this thread. -- -- We need to increase the number of workers. spawnAction mgr -- After this work, this thread stops to decease -- the number of workers. setThreadContinue tconf False -- Since 'StreamingBody' is loop, we cannot control it. -- So, let's serialize 'Builder' with a designated queue. tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 tbl <- toHeaderTable hs0 let !rspn = RspnStreaming s0 tbl tbq !out = Output strm rspn ii tell h2data rspnOrWait enqueueOutput outputQ out let push b = do atomically $ writeTBQueue tbq (SBuilder b) T.tickle th flush = atomically $ writeTBQueue tbq SFlush _ <- strmbdy push flush atomically $ writeTBQueue tbq SFinish deleteMyId mgr return ResponseReceived worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO () worker ctx@Context{inputQ,controlQ} set app responder tm = do sinfo <- newStreamInfo tcont <- newThreadContinue E.bracket (T.registerKillThread tm) T.cancel $ go sinfo tcont where go sinfo tcont th = do setThreadContinue tcont True ex <- E.try $ do T.pause th inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ setStreamInfo sinfo inp T.resume th T.tickle th app req $ responder ii reqvt tcont strm req cont1 <- case ex of Right ResponseReceived -> return True Left e@(SomeException _) -- killed by the local worker manager | Just ThreadKilled <- E.fromException e -> return False -- killed by the local timeout manager | Just T.TimeoutThread <- E.fromException e -> do cleanup sinfo Nothing return True | otherwise -> do cleanup sinfo $ Just e return True cont2 <- getThreadContinue tcont clearStreamInfo sinfo when (cont1 && cont2) $ go sinfo tcont th cleanup sinfo me = do minp <- getStreamInfo sinfo case minp of Nothing -> return () Just (Input strm req _reqvt _ii) -> do closed ctx strm Killed let !frame = resetFrame InternalError (streamNumber strm) enqueueControl controlQ $ CFrame frame case me of Nothing -> return () Just e -> S.settingsOnException set (Just req) e ---------------------------------------------------------------- -- | It would nice if responders could return values to workers. -- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0. -- It is not wise to change this type. -- So, a reference is shared by a responder and its worker. -- The reference refers a value of this type as a return value. -- If 'True', the worker continue to serve requests. -- Otherwise, the worker get finished. newtype ThreadContinue = ThreadContinue (IORef Bool) {-# INLINE newThreadContinue #-} newThreadContinue :: IO ThreadContinue newThreadContinue = ThreadContinue <$> newIORef True {-# INLINE setThreadContinue #-} setThreadContinue :: ThreadContinue -> Bool -> IO () setThreadContinue (ThreadContinue ref) x = writeIORef ref x {-# INLINE getThreadContinue #-} getThreadContinue :: ThreadContinue -> IO Bool getThreadContinue (ThreadContinue ref) = readIORef ref ---------------------------------------------------------------- -- | The type to store enough information for 'settingsOnException'. newtype StreamInfo = StreamInfo (IORef (Maybe Input)) {-# INLINE newStreamInfo #-} newStreamInfo :: IO StreamInfo newStreamInfo = StreamInfo <$> newIORef Nothing {-# INLINE clearStreamInfo #-} clearStreamInfo :: StreamInfo -> IO () clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing {-# INLINE setStreamInfo #-} setStreamInfo :: StreamInfo -> Input -> IO () setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp {-# INLINE getStreamInfo #-} getStreamInfo :: StreamInfo -> IO (Maybe Input) getStreamInfo (StreamInfo ref) = readIORef ref warp-3.2.8/test/0000755000000000000000000000000012750546070011650 5ustar0000000000000000warp-3.2.8/test/BufferPoolSpec.hs0000644000000000000000000000316112750546070015063 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.2.8/test/ConduitSpec.hs0000644000000000000000000000362612750546070014433 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.2.8/test/doctests.hs0000644000000000000000000000007612750546070014037 0ustar0000000000000000import Test.DocTest main :: IO () main = doctest ["Network"] warp-3.2.8/test/ExceptionSpec.hs0000644000000000000000000000423512750546070014761 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.2.8/test/FdCacheSpec.hs0000644000000000000000000000112112750546070014267 0ustar0000000000000000{-# LANGUAGE CPP #-} module FdCacheSpec where import Test.Hspec #ifndef WINDOWS import Data.IORef import Network.Wai.Handler.Warp.FdCache import System.Posix.IO (fdRead) import System.Posix.Types (Fd(..)) main :: IO () main = hspec spec spec :: Spec spec = describe "withFdCache" $ do it "clean up Fd" $ do ref <- newIORef (Fd (-1)) withFdCache 30000000 $ \getFd -> do (Just fd,_) <- getFd 0 "warp.cabal" writeIORef ref fd nfd <- readIORef ref fdRead nfd 1 `shouldThrow` anyIOException #else spec :: Spec spec = return () #endif warp-3.2.8/test/FileSpec.hs0000644000000000000000000000330212750546070013674 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.2.8/test/head-response0000644000000000000000000000002112750546070014321 0ustar0000000000000000This is the body warp-3.2.8/test/HTTP.hs0000644000000000000000000000212512750546070012763 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.2.8/test/inputFile0000644000000000000000000000270212750546070013533 0ustar0000000000000000A acid abacus major abacus pythagoricus A battery abbey counter abbey laird abbey lands abbey lubber abbot cloth Abbott papyrus abb wool A-b-c book A-b-c method abdomino-uterotomy Abdul-baha a-be aberrant duct aberration constant abiding place able-bodied able-bodiedness able-minded able-mindedness able seaman aboli fruit A bond Abor-miri a-borning about-face about ship about-sledge above-cited above-found above-given above-mentioned above-named above-quoted above-reported above-said above-water above-written Abraham-man abraum salts abraxas stone Abri audit culture abruptly acuminate abruptly pinnate absciss layer absence state absentee voting absent-minded absent-mindedly absent-mindedness absent treatment absent voter Absent voting absinthe green absinthe oil absorption bands absorption circuit absorption coefficient absorption current absorption dynamometer absorption factor absorption lines absorption pipette absorption screen absorption spectrum absorption system A b station abstinence theory abstract group Abt system abundance declaree aburachan seed abutment arch abutment pier abutting joint acacia veld academy blue academy board academy figure acajou balsam acanthosis nigricans acanthus family acanthus leaf acaroid resin Acca larentia acceleration note accelerator nerve accent mark acceptance bill acceptance house acceptance supra protest acceptor supra protest accession book accession number accession service access road accident insurance warp-3.2.8/test/ReadIntSpec.hs0000644000000000000000000000172512750546070014352 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.2.8/test/RequestSpec.hs0000644000000000000000000001237612750546070014460 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} module RequestSpec (main, spec) where import Network.Wai.Handler.Warp.File (parseByteRanges) import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Types import 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.2.8/test/ResponseHeaderSpec.hs0000644000000000000000000000156612750546070015736 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.2.8/test/ResponseSpec.hs0000644000000000000000000001043412750546070014617 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.2.8/test/RunSpec.hs0000644000000000000000000004240212750546070013565 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.2.8/test/SendFileSpec.hs0000644000000000000000000001034212750546070014510 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.2.8/test/Spec.hs0000644000000000000000000000005412750546070013075 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} warp-3.2.8/test/WithApplicationSpec.hs0000644000000000000000000000332112750546070016115 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module WithApplicationSpec where import Control.Concurrent import Control.Exception import Network.HTTP.Types import Network.Socket import Network.Wai import System.IO import System.IO.Silently import System.Process import Test.Hspec import Network.Wai.Handler.Warp.WithApplication spec :: Spec spec = do describe "withApplication" $ do it "runs a wai Application while executing the given action" $ do let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo" withApplication mkApp $ \ port -> do output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" output `shouldBe` "foo" it "does not propagate exceptions from the server to the executing thread" $ hSilence [stderr] $ do let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo" withApplication mkApp $ \ port -> do output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" output `shouldContain` "Something went wron" describe "testWithApplication" $ do it "propagates exceptions from the server to the executing thread" $ hSilence [stderr] $ do let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo" (testWithApplication mkApp $ \ port -> do readProcess "curl" ["-s", "localhost:" ++ show port] "") `shouldThrow` (errorCall "foo") describe "withFreePort" $ do it "closes the socket before exiting" $ do MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do return sock readMVar statusMVar `shouldReturn` Closed