diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,14 +1,67 @@ +# ChangeLog for wai + +## 3.2.5 + +* Add a `requestSendEarlyHints :: [Header] -> IO ()` field to `Request` for sending `103 Early Hints` responses. [#1085](https://github.com/yesodweb/wai/pull/1085) + +## 3.2.4 + +* Add helpers for modifying request headers: `modifyRequest` and `mapRequestHeaders`. [#710](https://github.com/yesodweb/wai/pull/710) [#952](https://github.com/yesodweb/wai/pull/952) +* Small documentation adjustments like adding more `@since` markers. [#952](https://github.com/yesodweb/wai/pull/952) +* Add `setRequestBodyChunks` to mirror `getRequestBodyChunk` and avoid deprecation warnings when using `requestBody` as a setter. [#949](https://github.com/yesodweb/wai/pull/949) +* Overhaul documentation of `Middleware`. [#858](https://github.com/yesodweb/wai/pull/858) + +## 3.2.3 + +* Add documentation recommending streaming request bodies. [#818](https://github.com/yesodweb/wai/pull/818) +* Add two functions, `consumeRequestBodyStrict` and `consumeRequestBodyLazy`, + that are synonyms for `strictRequestBody` and `lazyRequestBody`. [#818](https://github.com/yesodweb/wai/pull/818) + +## 3.2.2.1 + +* Fix missing reexport of `getRequestBodyChunk` [#753](https://github.com/yesodweb/wai/issues/753) + +## 3.2.2 + +* Deprecate `requestBody` in favor of the more clearly named `getRequestBodyChunk`. [#726](https://github.com/yesodweb/wai/pull/726) + +## 3.2.1.2 + +* Remove dependency on blaze-builder [#683](https://github.com/yesodweb/wai/pull/683) + +## 3.2.1.1 + +* Relax upper bound on bytestring-builder + +## 3.2.1 + +* add mapResponseStatus [#532](https://github.com/yesodweb/wai/pull/532) + +## 3.2.0.1 + +* Add missing changelog entry + +## 3.2.0 + +* Major version up due to breaking changes. We chose 3.2.0, not 3.1.0 + for consistency with Warp 3.2.0. +* The `Network.Wai.HTTP2` module was removed. +* `tryGetFileSize`, `hContentRange`, `hAcceptRanges`, `contentRangeHeader` and + `chooseFilePart`, `adjustForFilePart` and `parseByteRanges` were removed + from the `Network.Wai.Internal` module. +* New fields for `Request`: `requestHeaderReferer` and `requestHeaderUserAgent`. + ## 3.0.5.0 -* Avoid using the IsString Builder instance +* Avoid using the `IsString` Builder instance ## 3.0.4.0 -* A new module Network.Wai.HTTP2 is exported. +* A new module `Network.Wai.HTTP2` is exported. ## 3.0.3.0 -* mapResponseHeaders, ifRequest and modifyResponse are exported. +* `mapResponseHeaders`, `ifRequest` and `modifyResponse` are exported. ## 3.0.2.3 diff --git a/Network/Wai.hs b/Network/Wai.hs --- a/Network/Wai.hs +++ b/Network/Wai.hs @@ -1,107 +1,136 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} -{-| +-- Ignore deprecations, because this module needs to use the deprecated requestBody to construct a response. +{-# OPTIONS_GHC -fno-warn-deprecations #-} -This module defines a generic web application interface. It is a common -protocol between web servers and web applications. +-- | +-- +-- This module defines a generic web application interface. It is a common +-- protocol between web servers and web applications. +-- +-- The overriding design principles here are performance and generality. To +-- address performance, this library uses a streaming interface for request and +-- response bodies, paired with bytestring's 'Builder' type. The advantages of a +-- streaming API over lazy IO have been debated elsewhere and so will not be +-- addressed here. However, helper functions like 'responseLBS' allow you to +-- continue using lazy IO if you so desire. +-- +-- Generality is achieved by removing many variables commonly found in similar +-- projects that are not universal to all servers. The goal is that the 'Request' +-- object contains only data which is meaningful in all circumstances. +-- +-- Please remember when using this package that, while your application may +-- compile without a hitch against many different servers, there are other +-- considerations to be taken when moving to a new backend. For example, if you +-- transfer from a CGI application to a FastCGI one, you might suddenly find you +-- have a memory leak. Conversely, a FastCGI application would be well served to +-- preload all templates from disk when first starting; this would kill the +-- performance of a CGI application. +-- +-- This package purposely provides very little functionality. You can find various +-- middlewares, backends and utilities on Hackage. Some of the most commonly used +-- include: +-- +-- [warp] +-- +-- [wai-extra] +module Network.Wai ( + -- * Types + Application, + Middleware, + ResponseReceived, -The overriding design principles here are performance and generality. To -address performance, this library is built on top of the conduit and -blaze-builder packages. The advantages of conduits over lazy IO have been -debated elsewhere and so will not be addressed here. However, helper functions -like 'responseLBS' allow you to continue using lazy IO if you so desire. + -- * Request + Request, + defaultRequest, + RequestBodyLength (..), -Generality is achieved by removing many variables commonly found in similar -projects that are not universal to all servers. The goal is that the 'Request' -object contains only data which is meaningful in all circumstances. + -- ** Request accessors + requestMethod, + httpVersion, + rawPathInfo, + rawQueryString, + requestHeaders, + isSecure, + remoteHost, + pathInfo, + queryString, + getRequestBodyChunk, + requestBody, + vault, + requestBodyLength, + requestHeaderHost, + requestHeaderRange, + requestHeaderReferer, + requestHeaderUserAgent, + requestSendEarlyHints, + -- $streamingRequestBodies + strictRequestBody, + consumeRequestBodyStrict, + lazyRequestBody, + consumeRequestBodyLazy, -Please remember when using this package that, while your application may -compile without a hitch against many different servers, there are other -considerations to be taken when moving to a new backend. For example, if you -transfer from a CGI application to a FastCGI one, you might suddenly find you -have a memory leak. Conversely, a FastCGI application would be well served to -preload all templates from disk when first starting; this would kill the -performance of a CGI application. + -- ** Request modifiers + setRequestBodyChunks, + mapRequestHeaders, -This package purposely provides very little functionality. You can find various -middlewares, backends and utilities on Hackage. Some of the most commonly used -include: + -- * Response + Response, + StreamingBody, + FilePart (..), -[warp] + -- ** Response composers + responseFile, + responseBuilder, + responseLBS, + responseStream, + responseRaw, -[wai-extra] + -- ** Response accessors + responseStatus, + responseHeaders, -[wai-test] + -- ** Response modifiers + responseToStream, + mapResponseHeaders, + mapResponseStatus, --} -module Network.Wai - ( - -- * Types - Application - , Middleware - , ResponseReceived - -- * Request - , Request - , defaultRequest - , RequestBodyLength (..) - -- ** Request accessors - , requestMethod - , httpVersion - , rawPathInfo - , rawQueryString - , requestHeaders - , isSecure - , remoteHost - , pathInfo - , queryString - , requestBody - , vault - , requestBodyLength - , requestHeaderHost - , requestHeaderRange - , strictRequestBody - , lazyRequestBody - -- * Response - , Response - , StreamingBody - , FilePart (..) - -- ** Response composers - , responseFile - , responseBuilder - , responseLBS - , responseStream - , responseRaw - -- ** Response accessors - , responseStatus - , responseHeaders - -- ** Response modifiers - , responseToStream - , mapResponseHeaders - -- * Middleware composition - , ifRequest - , modifyResponse - ) where + -- * Middleware composition + ifRequest, + modifyRequest, + modifyResponse, +) where -import Blaze.ByteString.Builder (Builder, fromLazyByteString) -import Blaze.ByteString.Builder (fromByteString) -import Control.Monad (unless) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L +import Control.Monad (unless) +import qualified Data.ByteString as B +import Data.ByteString.Builder ( + Builder, + byteString, + lazyByteString, + ) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Internal (defaultChunkSize) import qualified Data.ByteString.Lazy.Internal as LI -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Data.ByteString.Lazy.Char8 () -import Data.Function (fix) -import Data.Monoid (mempty) -import qualified Network.HTTP.Types as H -import Network.Socket (SockAddr (SockAddrInet)) -import Network.Wai.Internal -import qualified System.IO as IO -import System.IO.Unsafe (unsafeInterleaveIO) +import Data.Function (fix) +import qualified Network.HTTP.Types as H +import Network.Socket (SockAddr (SockAddrInet)) +import Network.Wai.Internal +import qualified System.IO as IO +import System.IO.Unsafe (unsafeInterleaveIO) ---------------------------------------------------------------- -- | Creating 'Response' from a file. -responseFile :: H.Status -> H.ResponseHeaders -> FilePath -> Maybe FilePart -> Response +-- +-- Server implementations like @warp@ might disregard the t'Status' when +-- using 'responseFile', since the server might rework the response based on +-- headers or presence/absence of the file. +-- @warp@ does not do do any extra processing when sending file parts, though, +-- so be mindful of how each server implementation handles file responses. +-- +-- /The above was written when @warp-3.4.14@ was the newest version/ +-- +-- @since 2.0.0 +responseFile + :: H.Status -> H.ResponseHeaders -> FilePath -> Maybe FilePart -> Response responseFile = ResponseFile -- | Creating 'Response' from 'Builder'. @@ -119,21 +148,25 @@ -- -- A2. No. If the ByteStrings are small, then they will be copied into a larger -- buffer, which should be a performance gain overall (less system calls). If --- they are already large, then blaze-builder uses an InsertByteString --- instruction to avoid copying. +-- they are already large, then an insert operation is used +-- to avoid copying. -- -- Q3. Doesn't this prevent us from creating comet-style servers, since data -- will be cached? -- --- A3. You can force blaze-builder to output a ByteString before it is an +-- A3. You can force a Builder to output a ByteString before it is an -- optimal size by sending a flush command. +-- +-- @since 2.0.0 responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response responseBuilder = ResponseBuilder -- | Creating 'Response' from 'L.ByteString'. This is a wrapper for -- 'responseBuilder'. +-- +-- @since 0.3.0 responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response -responseLBS s h = ResponseBuilder s h . fromLazyByteString +responseLBS s h = ResponseBuilder s h . lazyByteString -- | Creating 'Response' from a stream of values. -- @@ -147,20 +180,21 @@ -- (putStrLn \"Allocating scarce resource\") -- (putStrLn \"Cleaning up\") -- $ respond $ responseStream status200 [] $ \\write flush -> do --- write $ fromByteString \"Hello\\n\" +-- write $ byteString \"Hello\\n\" -- flush --- write $ fromByteString \"World\\n\" +-- write $ byteString \"World\\n\" -- @ -- -- Note that in some cases you can use @bracket@ from inside @responseStream@ -- as well. However, placing the call on the outside allows your status value -- and response headers to depend on the scarce resource. -- --- Since 3.0.0 -responseStream :: H.Status - -> H.ResponseHeaders - -> StreamingBody - -> Response +-- @since 3.0.0 +responseStream + :: H.Status + -> H.ResponseHeaders + -> StreamingBody + -> Response responseStream = ResponseStream -- | Create a response for a raw application. This is useful for \"upgrade\" @@ -173,34 +207,42 @@ -- In the event that you read from the request body before returning a -- @responseRaw@, behavior is undefined. -- --- Since 2.1.0 -responseRaw :: (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) - -> Response - -> Response +-- @since 2.1.0 +responseRaw + :: (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) + -> Response + -> Response responseRaw = ResponseRaw ---------------------------------------------------------------- -- | Accessing 'H.Status' in 'Response'. +-- +-- @since 1.2.0 responseStatus :: Response -> H.Status -responseStatus (ResponseFile s _ _ _) = s -responseStatus (ResponseBuilder s _ _ ) = s -responseStatus (ResponseStream s _ _ ) = s -responseStatus (ResponseRaw _ res ) = responseStatus res +responseStatus (ResponseFile s _ _ _) = s +responseStatus (ResponseBuilder s _ _) = s +responseStatus (ResponseStream s _ _) = s +responseStatus (ResponseRaw _ res) = responseStatus res -- | Accessing 'H.ResponseHeaders' in 'Response'. +-- +-- @since 2.0.0 responseHeaders :: Response -> H.ResponseHeaders -responseHeaders (ResponseFile _ hs _ _) = hs -responseHeaders (ResponseBuilder _ hs _ ) = hs -responseHeaders (ResponseStream _ hs _ ) = hs -responseHeaders (ResponseRaw _ res) = responseHeaders res +responseHeaders (ResponseFile _ hs _ _) = hs +responseHeaders (ResponseBuilder _ hs _) = hs +responseHeaders (ResponseStream _ hs _) = hs +responseHeaders (ResponseRaw _ res) = responseHeaders res -- | Converting the body information in 'Response' to a 'StreamingBody'. -responseToStream :: Response - -> ( H.Status - , H.ResponseHeaders - , (StreamingBody -> IO a) -> IO a - ) +-- +-- @since 3.0.0 +responseToStream + :: Response + -> ( H.Status + , H.ResponseHeaders + , (StreamingBody -> IO a) -> IO a + ) responseToStream (ResponseStream s h b) = (s, h, ($ b)) responseToStream (ResponseFile s h fp (Just part)) = ( s @@ -212,7 +254,7 @@ bs <- B.hGetSome handle defaultChunkSize unless (B.null bs) $ do let x = B.take remaining bs - sendChunk $ fromByteString x + sendChunk $ byteString x loop $ remaining - B.length x loop $ fromIntegral $ filePartByteCount part ) @@ -220,10 +262,10 @@ ( s , h , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> - withBody $ \sendChunk _flush -> fix $ \loop -> do + withBody $ \sendChunk _flush -> fix $ \loop -> do bs <- B.hGetSome handle defaultChunkSize unless (B.null bs) $ do - sendChunk $ fromByteString bs + sendChunk $ byteString bs loop ) responseToStream (ResponseBuilder s h b) = @@ -231,12 +273,24 @@ responseToStream (ResponseRaw _ res) = responseToStream res -- | Apply the provided function to the response header list of the Response. -mapResponseHeaders :: (H.ResponseHeaders -> H.ResponseHeaders) -> Response -> Response +-- +-- @since 3.0.3.0 +mapResponseHeaders + :: (H.ResponseHeaders -> H.ResponseHeaders) -> Response -> Response mapResponseHeaders f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2 mapResponseHeaders f (ResponseBuilder s h b) = ResponseBuilder s (f h) b mapResponseHeaders f (ResponseStream s h b) = ResponseStream s (f h) b mapResponseHeaders _ r@(ResponseRaw _ _) = r +-- | Apply the provided function to the response status of the Response. +-- +-- @since 3.2.1 +mapResponseStatus :: (H.Status -> H.Status) -> Response -> Response +mapResponseStatus f (ResponseFile s h b1 b2) = ResponseFile (f s) h b1 b2 +mapResponseStatus f (ResponseBuilder s h b) = ResponseBuilder (f s) h b +mapResponseStatus f (ResponseStream s h b) = ResponseStream (f s) h b +mapResponseStatus _ r@(ResponseRaw _ _) = r + ---------------------------------------------------------------- -- | The WAI application. @@ -252,86 +306,300 @@ -- (putStrLn \"Cleaning up\") -- (respond $ responseLBS status200 [] \"Hello World\") -- @ -type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived - +type Application = + Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -- | A default, blank request. -- --- Since 2.0.0 +-- @since 2.0.0 defaultRequest :: Request -defaultRequest = Request - { requestMethod = H.methodGet - , httpVersion = H.http10 - , rawPathInfo = B.empty - , rawQueryString = B.empty - , requestHeaders = [] - , isSecure = False - , remoteHost = SockAddrInet 0 0 - , pathInfo = [] - , queryString = [] - , requestBody = return B.empty - , vault = mempty - , requestBodyLength = KnownLength 0 - , requestHeaderHost = Nothing - , requestHeaderRange = Nothing - } - +defaultRequest = + Request + { requestMethod = H.methodGet + , httpVersion = H.http10 + , rawPathInfo = B.empty + , rawQueryString = B.empty + , requestHeaders = [] + , isSecure = False + , remoteHost = SockAddrInet 0 0 + , pathInfo = [] + , queryString = [] + , requestBody = return B.empty + , vault = mempty + , requestBodyLength = KnownLength 0 + , requestHeaderHost = Nothing + , requestHeaderRange = Nothing + , requestHeaderReferer = Nothing + , requestHeaderUserAgent = Nothing + , requestSendEarlyHints = \_ -> return () + } --- | Middleware is a component that sits between the server and application. It --- can do such tasks as GZIP encoding or response caching. What follows is the --- general definition of middleware, though a middleware author should feel --- free to modify this. +-- | A @Middleware@ is a component that sits between the server and application. -- --- As an example of an alternate type for middleware, suppose you write a --- function to load up session information. The session information is simply a --- string map \[(String, String)\]. A logical type signature for this middleware --- might be: +-- It can modify both the 'Request' and 'Response', +-- to provide simple transformations that are required for all (or most of) +-- your web server’s routes. -- --- @ loadSession :: ([(String, String)] -> Application) -> Application @ +-- = Users of middleware -- --- Here, instead of taking a standard 'Application' as its first argument, the --- middleware takes a function which consumes the session information as well. +-- If you are trying to apply one or more 'Middleware's to your 'Application', +-- just call them as functions. +-- +-- For example, if you have @corsMiddleware@ and @authorizationMiddleware@, +-- and you want to authorize first, you can do: +-- +-- @ +-- let allMiddleware app = authorizationMiddleware (corsMiddleware app) +-- @ +-- +-- to get a new 'Middleware', which first authorizes, then sets, CORS headers. +-- The “outer” middleware is called first. +-- +-- You can also chain them via '(.)': +-- +-- @ +-- let allMiddleware = +-- authorizationMiddleware +-- . corsMiddleware +-- . … more middleware here … +-- @ +-- +-- Then, once you have an @app :: Application@, you can wrap it +-- in your middleware: +-- +-- @ +-- let myApp = allMiddleware app :: Application +-- @ +-- +-- and run it as usual: +-- +-- @ +-- Warp.run port myApp +-- @ +-- +-- = Authors of middleware +-- +-- When fully expanded, 'Middleware' has the type signature: +-- +-- > (Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived) -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +-- +-- or if we shorten to @type Respond = Response -> IO ResponseReceived@: +-- +-- > (Request -> Respond -> IO ResponseReceived) -> Request -> Respond -> IO ResponseReceived +-- +-- so a middleware definition takes 3 arguments, an inner application, a request and a response callback. +-- +-- Compare with the type of a simple `Application`: +-- +-- > Request -> Respond -> IO ResponseReceived +-- +-- It takes the 'Request' and @Respond@, but not the extra application. +-- +-- Said differently, a middleware has the power of a normal 'Application' +-- — it can inspect the 'Request' and return a 'Response' — +-- but it can (and in many cases it /should/) also call the 'Application' which was passed to it. +-- +-- == Modifying the 'Request' +-- +-- A lot of middleware just looks at the request and does something based on its values. +-- +-- For example, the @authorizationMiddleware@ from above could look at the @Authorization@ +-- HTTP header and run verification logic against the database. +-- +-- @ +-- authorizationMiddleware app req respond = do +-- case verifyJWT ('requestHeaders' req) of +-- InvalidJWT err -> respond (invalidJWTResponse err) +-- ValidJWT -> app req respond +-- @ +-- +-- Notice how the inner app is called when the validation was successful. +-- If it was not, we can respond +-- e.g. with , +-- by constructing a 'Response' with 'responseLBS' and passing it to @respond@. +-- +-- == Passing arguments to and from your 'Middleware' +-- +-- Middleware must often be configurable. +-- Let’s say you have a type @JWTSettings@ that you want to be passed to the middleware. +-- Simply pass an extra argument to your middleware. Then your middleware type turns into: +-- +-- @ +-- authorizationMiddleware :: JWTSettings -> Application -> Request -> Respond -> IO ResponseReceived +-- authorizationMiddleware jwtSettings req respond = +-- case verifyJWT jwtSettings ('requestHeaders' req) of +-- InvalidJWT err -> respond (invalidJWTResponse err) +-- ValidJWT -> app req respond +-- @ +-- +-- or alternatively: +-- +-- @ +-- authorizationMiddleware :: JWTSettings -> Middleware +-- @ +-- +-- Perhaps less intuitively, you can also /pass on/ data from middleware to the wrapped 'Application': +-- +-- @ +-- authorizationMiddleware :: JWTSettings -> (JWT -> Application) -> Request -> Respond -> IO ResponseReceived +-- authorizationMiddleware jwtSettings req respond = +-- case verifyJWT jwtSettings ('requestHeaders' req) of +-- InvalidJWT err -> respond (invalidJWTResponse err) +-- ValidJWT jwt -> app jwt req respond +-- @ +-- +-- although then, chaining different middleware has to take this extra argument into account: +-- +-- @ +-- let finalApp = +-- authorizationMiddleware +-- (\\jwt -> corsMiddleware +-- (… more middleware here … +-- (app jwt))) +-- @ +-- +-- == Modifying the 'Response' +-- +-- 'Middleware' can also modify the 'Response' that is returned by the inner application. +-- +-- This is done by taking the @respond@ callback, using it to define a new @respond'@, +-- and passing this new @respond'@ to the @app@: +-- +-- @ +-- gzipMiddleware app req respond = do +-- let respond' resp = do +-- resp' <- gzipResponseBody resp +-- respond resp' +-- app req respond' +-- @ +-- +-- However, modifying the response (especially the response body) is not trivial, +-- so in order to get a sense of how to do it (dealing with the type of 'responseToStream'), +-- it’s best to look at an example, for example . type Middleware = Application -> Application +-- | Apply a function that modifies a request as a 'Middleware' +-- +-- @since 3.2.4 +modifyRequest :: (Request -> Request) -> Middleware +modifyRequest f app = app . f --- | apply a function that modifies a response as a 'Middleware' +-- | Apply a function that modifies a response as a 'Middleware' +-- +-- @since 3.0.3.0 modifyResponse :: (Response -> Response) -> Middleware modifyResponse f app req respond = app req $ respond . f - --- | conditionally apply a 'Middleware' +-- | Conditionally apply a 'Middleware' +-- +-- @since 3.0.3.0 ifRequest :: (Request -> Bool) -> Middleware -> Middleware -ifRequest rpred middle app req | rpred req = middle app req - | otherwise = app req - +ifRequest rpred middle app req + | rpred req = middle app req + | otherwise = app req +-- $streamingRequestBodies +-- +-- == Streaming Request Bodies +-- +-- WAI is designed for streaming in request bodies, which allows you to process them incrementally. +-- You can stream in the request body using functions like 'getRequestBodyChunk', +-- the @wai-conduit@ package, or Yesod's @rawRequestBody@. +-- +-- In the normal case, incremental processing is more efficient, since it +-- reduces maximum total memory usage. +-- In the worst case, it helps protect your server against denial-of-service (DOS) attacks, in which +-- an attacker sends huge request bodies to your server. +-- +-- Consider these tips to avoid reading the entire request body into memory: +-- +-- * Look for library functions that support incremental processing. Sometimes these will use streaming +-- libraries like @conduit@, @pipes@, or @streaming@. +-- * Any attoparsec parser supports streaming input. For an example of this, see the +-- "Data.Conduit.Attoparsec" module in @conduit-extra@. +-- * Consider streaming directly to a file on disk. For an example of this, see the +-- "Data.Conduit.Binary" module in @conduit-extra@. +-- * If you need to direct the request body to multiple destinations, you can stream to both those +-- destinations at the same time. +-- For example, if you wanted to run an HMAC on the request body as well as parse it into JSON, +-- you could use Conduit's @zipSinks@ to send the data to @cryptonite-conduit@'s 'sinkHMAC' and +-- @aeson@'s Attoparsec parser. +-- * If possible, avoid processing large data on your server at all. +-- For example, instead of uploading a file to your server and then to AWS S3, +-- you can have the browser upload directly to S3. +-- +-- That said, sometimes it is convenient, or even necessary to read the whole request body into memory. +-- For these purposes, functions like 'strictRequestBody' or 'lazyRequestBody' can be used. +-- When this is the case, consider these strategies to mitigating potential DOS attacks: +-- +-- * Set a limit on the request body size you allow. +-- If certain endpoints need larger bodies, whitelist just those endpoints for the large size. +-- Be especially cautious about endpoints that don't require authentication, since these are easier to DOS. +-- You can accomplish this with @wai-extra@'s @requestSizeLimitMiddleware@ or Yesod's @maximumContentLength@. +-- * Consider rate limiting not just on total requests, but also on total bytes sent in. +-- * Consider using services that allow you to identify and blacklist attackers. +-- * Minimize the amount of time the request body stays in memory. +-- * If you need to share request bodies across middleware and your application, you can do so using Wai's 'vault'. +-- If you do this, remove the request body from the vault as soon as possible. +-- +-- Warning: Incremental processing will not always be sufficient to prevent a DOS attack. +-- For example, if an attacker sends you a JSON body with a 2MB long string inside, +-- even if you process the body incrementally, you'll still end up with a 2MB-sized 'Text'. +-- +-- To mitigate this, employ some of the countermeasures listed above, +-- and try to reject such payloads as early as possible in your codebase. -- | Get the request body as a lazy ByteString. However, do /not/ use any lazy -- I\/O, instead reading the entire body into memory strictly. -- --- Since 3.0.1 +-- Note: Since this function consumes the request body, future calls to it will return the empty string. +-- +-- @since 3.0.1 strictRequestBody :: Request -> IO L.ByteString strictRequestBody req = loop id where loop front = do - bs <- requestBody req + bs <- getRequestBodyChunk req if B.null bs then return $ front LI.Empty else loop (front . LI.Chunk bs) +-- | Synonym for 'strictRequestBody'. +-- This function name is meant to signal the non-idempotent nature of 'strictRequestBody'. +-- +-- @since 3.2.3 +consumeRequestBodyStrict :: Request -> IO L.ByteString +consumeRequestBodyStrict = strictRequestBody + -- | Get the request body as a lazy ByteString. This uses lazy I\/O under the -- surface, and therefore all typical warnings regarding lazy I/O apply. -- --- Since 1.4.1 +-- Note: Since this function consumes the request body, future calls to it will return the empty string. +-- +-- @since 1.4.1 lazyRequestBody :: Request -> IO L.ByteString lazyRequestBody req = loop where loop = unsafeInterleaveIO $ do - bs <- requestBody req + bs <- getRequestBodyChunk req if B.null bs then return LI.Empty else do bss <- loop return $ LI.Chunk bs bss + +-- | Synonym for 'lazyRequestBody'. +-- This function name is meant to signal the non-idempotent nature of 'lazyRequestBody'. +-- +-- @since 3.2.3 +consumeRequestBodyLazy :: Request -> IO L.ByteString +consumeRequestBodyLazy = lazyRequestBody + +-- | Apply the provided function to the request header list of the 'Request'. +-- +-- @since 3.2.4 +mapRequestHeaders + :: (H.RequestHeaders -> H.RequestHeaders) -> Request -> Request +mapRequestHeaders f request = request{requestHeaders = f (requestHeaders request)} diff --git a/Network/Wai/HTTP2.hs b/Network/Wai/HTTP2.hs deleted file mode 100644 --- a/Network/Wai/HTTP2.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | An HTTP\/2-aware variant of the 'Network.Wai.Application' type. Compared --- to the original, this exposes the new functionality of server push and --- trailers, allows stream fragments to be sent in the form of file ranges, and --- allows the stream body to produce a value to be used in constructing the --- trailers. Existing @Applications@ can be faithfully upgraded to HTTP\/2 --- with 'promoteApplication' or served transparently over both protocols with --- the normal Warp 'Network.Wai.Handler.Warp.run' family of functions. --- --- An 'HTTP2Application' takes a 'Request' and a 'PushFunc' and produces a --- 'Responder' that will push any associated resources and send the response --- body. The response is always a stream of 'Builder's and file chunks. --- Equivalents of the 'Network.Wai.responseBuilder' family of functions are --- provided for creating 'Responder's conveniently. --- --- Pushed streams are handled by an IO action that triggers a server push. It --- returns @True@ if the @PUSH_PROMISE@ frame was sent, @False@ if not. Note --- this means it will still return @True@ if the client reset or ignored the --- stream. This gives handlers the freedom to implement their own heuristics --- for whether to actually push a resource, while also allowing middleware and --- frameworks to trigger server pushes automatically. - -module Network.Wai.HTTP2 - ( - -- * Applications - HTTP2Application - -- * Responder - , Responder(..) - , RespondFunc - , Body - , Chunk(..) - , Trailers - -- * Server push - , PushFunc - , PushPromise(..) - , promiseHeaders - -- * Conveniences - , promoteApplication - -- ** Responders - , respond - , respondCont - , respondIO - , respondFile - , respondFilePart - , respondNotFound - , respondWith - -- ** Stream Bodies - , streamFilePart - , streamBuilder - , streamSimple - ) where - -import Blaze.ByteString.Builder (Builder) -import Blaze.ByteString.Builder.ByteString (fromByteString) -import Control.Exception (Exception, throwIO) -import Control.Monad.Trans.Cont (ContT(..)) -import Data.ByteString (ByteString) -#if __GLASGOW_HASKELL__ < 709 -import Data.Functor ((<$>)) -#endif -import Data.IORef (newIORef, readIORef, writeIORef) -#if __GLASGOW_HASKELL__ < 709 -import Data.Monoid (mempty) -#endif -import Data.Typeable (Typeable) -import qualified Network.HTTP.Types as H - -import Network.Wai (Application) -import Network.Wai.Internal - ( FilePart(..) - , Request(requestHeaders) - , Response(..) - , ResponseReceived(..) - , StreamingBody - , adjustForFilePart - , chooseFilePart - , tryGetFileSize - ) - --- | Headers sent after the end of a data stream, as defined by section 4.1.2 of --- the HTTP\/1.1 spec (RFC 7230), and section 8.1 of the HTTP\/2 spec. -type Trailers = [H.Header] - --- | The synthesized request and headers of a pushed stream. -data PushPromise = PushPromise - { promisedMethod :: H.Method - , promisedPath :: ByteString - , promisedAuthority :: ByteString - , promisedScheme :: ByteString - , promisedHeader :: H.RequestHeaders - } - --- | The HTTP\/2-aware equivalent of 'Network.Wai.Application'. -type HTTP2Application = Request -> PushFunc -> Responder - --- | Part of a streaming response -- either a 'Builder' or a range of a file. -data Chunk = FileChunk FilePath FilePart | BuilderChunk Builder - --- | The streaming body of a response. Equivalent to --- 'Network.Wai.StreamingBody' except that it can also write file ranges and --- return the stream's trailers. -type Body = (Chunk -> IO ()) -> IO () -> IO Trailers - --- | Given to 'Responders'; provide a status, headers, and a stream body, and --- we'll give you a token proving you called the 'RespondFunc'. -type RespondFunc s = H.Status -> H.ResponseHeaders -> Body -> IO s - --- | The result of an 'HTTP2Application'; or, alternately, an application --- that's independent of the request. This is a continuation-passing style --- function that first provides a response by calling the given respond --- function, then returns the request's 'Trailers'. --- --- The respond function is similar to the one in 'Network.Wai.Application', but --- it only takes a streaming body, the status and headers are curried, and it --- also produces trailers for the stream. -newtype Responder = Responder - { runResponder :: forall s. RespondFunc s -> IO s } - --- | A function given to an 'HTTP2Application' to initiate a server-pushed --- stream. Its argument is the same as the result of an 'HTTP2Application', so --- you can either implement the response inline, or call your own application --- to create the response. --- --- The result is 'True' if the @PUSH_PROMISE@ frame will be sent, or 'False' if --- it will not. This can happen if server push is disabled, the concurrency --- limit of server-initiated streams is reached, or the associated stream has --- already been closed. --- --- This function shall ensure that stream data provided after it returns will --- be sent after the @PUSH_PROMISE@ frame, so that servers can implement the --- requirement that any pushed stream for a resource be initiated before --- sending DATA frames that reference it. -type PushFunc = PushPromise -> Responder -> IO Bool - --- | Create the 'H.RequestHeaders' corresponding to the given 'PushPromise'. --- --- This is primarily useful for WAI handlers like Warp, and application --- implementers are unlikely to use it directly. -promiseHeaders :: PushPromise -> H.RequestHeaders -promiseHeaders p = - [ (":method", promisedMethod p) - , (":path", promisedPath p) - , (":authority", promisedAuthority p) - , (":scheme", promisedScheme p) - ] ++ promisedHeader p - --- | Create a response body consisting of a single range of a file. Does not --- set Content-Length or Content-Range headers. For that, use --- 'respondFilePart' or 'respondFile'. -streamFilePart :: FilePath -> FilePart -> Body -streamFilePart path part write _ = write (FileChunk path part) >> return [] - --- | Respond with a single range of a file, adding the Accept-Ranges, --- Content-Length and Content-Range headers and changing the status to 206 as --- appropriate. --- --- If you want the range to be inferred automatically from the Range header, --- use 'respondFile' instead. On the other hand, if you want to avoid the --- automatic header and status adjustments, use 'respond' and 'streamFilePart' --- directly. -respondFilePart :: H.Status -> H.ResponseHeaders -> FilePath -> FilePart -> Responder -respondFilePart s h path part = Responder $ \k -> do - let (s', h') = adjustForFilePart s h part - k s' h' $ streamFilePart path part - --- | Serve the requested range of the specified file (based on the Range --- header), using the given 'H.Status' and 'H.ResponseHeaders' as a base. If --- the file is not accessible, the status will be replaced with 404 and a --- default not-found message will be served. If a partial file is requested, --- the status will be replaced with 206 and the Content-Range header will be --- added. The Content-Length header will always be added. -respondFile :: H.Status -> H.ResponseHeaders -> FilePath -> H.RequestHeaders -> Responder -respondFile s h path reqHdrs = Responder $ \k -> do - fileSize <- tryGetFileSize path - case fileSize of - Left _ -> runResponder (respondNotFound h) k - Right size -> runResponder (respondFileExists s h path size reqHdrs) k - --- As 'respondFile', but with prior knowledge of the file's existence and size. -respondFileExists :: H.Status -> H.ResponseHeaders -> FilePath -> Integer -> H.RequestHeaders -> Responder -respondFileExists s h path size reqHdrs = - respondFilePart s h path $ chooseFilePart size $ lookup H.hRange reqHdrs - --- | Respond with a minimal 404 page with the given headers. -respondNotFound :: H.ResponseHeaders -> Responder -respondNotFound h = Responder $ \k -> k H.notFound404 h' $ - streamBuilder $ fromByteString "File not found." - where - contentType = (H.hContentType, "text/plain; charset=utf-8") - h' = contentType:filter ((/=H.hContentType) . fst) h - --- | Construct a 'Responder' that will just call the 'RespondFunc' with the --- given arguments. -respond :: H.Status -> H.ResponseHeaders -> Body -> Responder -respond s h b = Responder $ \k -> k s h b - --- | Fold the given bracketing action into a 'Responder'. Note the first --- argument is isomorphic to @Codensity IO a@ or @forall s. ContT s IO a@, and --- is the type of a partially-applied 'Control.Exception.bracket' or --- @with@-style function. --- --- > respondWith (bracket acquire release) $ --- > \x -> respondNotFound [("x", show x)] --- --- is equivalent to --- --- > Responder $ \k -> bracket acquire release $ --- > \x -> runResponder (respondNotFound [("x", show x)] k --- --- This is morally equivalent to ('>>=') on 'Codensity' 'IO'. -respondWith :: (forall s. (a -> IO s) -> IO s) -> (a -> Responder) -> Responder -respondWith with f = respondCont $ f <$> ContT with - --- | Fold the 'ContT' into the contained 'Responder'. -respondCont :: (forall r. ContT r IO Responder) -> Responder -respondCont cont = Responder $ \k -> runContT cont $ \r -> runResponder r k - --- | Fold the 'IO' into the contained 'Responder'. -respondIO :: IO Responder -> Responder -respondIO io = Responder $ \k -> io >>= \r -> runResponder r k - --- | Create a response body consisting of a single builder. -streamBuilder :: Builder -> Body -streamBuilder builder write _ = write (BuilderChunk builder) >> return [] - --- | Create a response body of a stream of 'Builder's. -streamSimple :: StreamingBody -> Body -streamSimple body write flush = body (write . BuilderChunk) flush >> return [] - --- | Use a normal WAI 'Response' to send the response. Useful if you're --- sharing code between HTTP\/2 applications and HTTP\/1 applications. --- --- The 'Request' is used to determine the right file range to serve for --- 'ResponseFile'. -promoteResponse :: Request -> Response -> Responder -promoteResponse req response = case response of - (ResponseBuilder s h b) -> - Responder $ \k -> k s h (streamBuilder b) - (ResponseStream s h body) -> - Responder $ \k -> k s h (streamSimple body) - (ResponseRaw _ fallback) -> promoteResponse req fallback - (ResponseFile s h path mpart) -> maybe - (respondFile s h path $ requestHeaders req) - (respondFilePart s h path) - mpart - --- | An 'Network.Wai.Application' we tried to promote neither called its --- respond action nor raised; this is only possible if it imported the --- 'ResponseReceived' constructor and used it to lie about having called the --- action. -data RespondNeverCalled = RespondNeverCalled deriving (Show, Typeable) - -instance Exception RespondNeverCalled - --- | Promote a normal WAI 'Application' to an 'HTTP2Application' by ignoring --- the HTTP/2-specific features. -promoteApplication :: Application -> HTTP2Application -promoteApplication app req _ = Responder $ \k -> do - -- In HTTP2Applications, the Responder is required to ferry a value of - -- arbitrary type from the RespondFunc back to the caller of the - -- application, but in Application the type is fixed to ResponseReceived. - -- To add this extra power to an Application, we have to squirrel it away - -- in an IORef as a hack. - ref <- newIORef Nothing - let k' r = do - writeIORef ref . Just =<< runResponder (promoteResponse req r) k - return ResponseReceived - ResponseReceived <- app req k' - readIORef ref >>= maybe (throwIO RespondNeverCalled) return diff --git a/Network/Wai/Internal.hs b/Network/Wai/Internal.hs --- a/Network/Wai/Internal.hs +++ b/Network/Wai/Internal.hs @@ -1,151 +1,177 @@ -{-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_HADDOCK not-home #-} + -- | Internal constructors and helper functions. Note that no guarantees are -- given for stability of these interfaces. module Network.Wai.Internal where -import Blaze.ByteString.Builder (Builder) -import Control.Exception (IOException, try) -import qualified Data.ByteString as B hiding (pack) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Char8 as B (pack, readInteger) -import qualified Data.ByteString.Lazy as L -#if __GLASGOW_HASKELL__ < 709 -import Data.Functor ((<$>)) -#endif -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Typeable (Typeable) -import Data.Vault.Lazy (Vault) -import Data.Word (Word64) -import qualified Network.HTTP.Types as H -import qualified Network.HTTP.Types.Header as HH -import Network.Socket (SockAddr) -import Numeric (showInt) -import Data.List (intercalate) -import qualified System.PosixCompat.Files as P +import qualified Data.ByteString as B +import Data.ByteString.Builder (Builder) +import Data.List (intercalate) +import Data.Text (Text) +import Data.Vault.Lazy (Vault) +import Data.Word (Word64) +import qualified Network.HTTP.Types as H +import Network.Socket (SockAddr) -- | Information on the request sent by the client. This abstracts away the -- details of the underlying implementation. -data Request = Request { - -- | Request method such as GET. - requestMethod :: H.Method - -- | HTTP version such as 1.1. - , httpVersion :: H.HttpVersion - -- | Extra path information sent by the client. The meaning varies slightly - -- depending on backend; in a standalone server setting, this is most likely - -- all information after the domain name. In a CGI application, this would be - -- the information following the path to the CGI executable itself. - -- - -- Middlewares and routing tools should not modify this raw value, as it may - -- be used for such things as creating redirect destinations by applications. - -- Instead, if you are writing a middleware or routing framework, modify the - -- @pathInfo@ instead. This is the approach taken by systems like Yesod - -- subsites. - -- - -- /Note/: At the time of writing this documentation, there is at least one - -- system (@Network.Wai.UrlMap@ from @wai-extra@) that does not follow the - -- above recommendation. Therefore, it is recommended that you test the - -- behavior of your application when using @rawPathInfo@ and any form of - -- library that might modify the @Request@. - , rawPathInfo :: B.ByteString - -- | If no query string was specified, this should be empty. This value - -- /will/ include the leading question mark. - -- Do not modify this raw value - modify queryString instead. - , rawQueryString :: B.ByteString - -- | A list of headers (a pair of key and value) in an HTTP request. - , requestHeaders :: H.RequestHeaders - -- | Was this request made over an SSL connection? - -- - -- Note that this value will /not/ tell you if the client originally made - -- this request over SSL, but rather whether the current connection is SSL. - -- The distinction lies with reverse proxies. In many cases, the client will - -- connect to a load balancer over SSL, but connect to the WAI handler - -- without SSL. In such a case, 'isSecure' will be 'False', but from a user - -- perspective, there is a secure connection. - , isSecure :: Bool - -- | The client\'s host information. - , remoteHost :: SockAddr - -- | Path info in individual pieces - the URL without a hostname/port and - -- without a query string, split on forward slashes. - , pathInfo :: [Text] - -- | Parsed query string information. - , queryString :: H.Query - -- | Get the next chunk of the body. Returns 'B.empty' when the - -- body is fully consumed. - , requestBody :: IO B.ByteString - -- | A location for arbitrary data to be shared by applications and middleware. - , vault :: Vault - -- | The size of the request body. In the case of a chunked request body, - -- this may be unknown. - -- - -- Since 1.4.0 - , requestBodyLength :: RequestBodyLength - -- | The value of the Host header in a HTTP request. - -- - -- Since 2.0.0 - , requestHeaderHost :: Maybe B.ByteString - -- | The value of the Range header in a HTTP request. - -- - -- Since 2.0.0 - , requestHeaderRange :: Maybe B.ByteString - } - deriving (Typeable) +{-# DEPRECATED + requestBody + "requestBody's name is misleading because it only gets a partial chunk of the body. Use getRequestBodyChunk instead when getting the field, and setRequestBodyChunks when setting the field." + #-} -instance Show Request where - show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a,b) <- fields] ++ "}" - where - fields = - [("requestMethod",show requestMethod) - ,("httpVersion",show httpVersion) - ,("rawPathInfo",show rawPathInfo) - ,("rawQueryString",show rawQueryString) - ,("requestHeaders",show requestHeaders) - ,("isSecure",show isSecure) - ,("remoteHost",show remoteHost) - ,("pathInfo",show pathInfo) - ,("queryString",show queryString) - ,("requestBody","") - ,("vault","") - ,("requestBodyLength",show requestBodyLength) - ,("requestHeaderHost",show requestHeaderHost) - ,("requestHeaderRange",show requestHeaderRange) - ] +data Request = Request + { requestMethod :: H.Method + -- ^ Request method such as GET. + , httpVersion :: H.HttpVersion + -- ^ HTTP version such as 1.1. + , rawPathInfo :: B.ByteString + -- ^ Extra path information sent by the client. The meaning varies slightly + -- depending on backend; in a standalone server setting, this is most likely + -- all information after the domain name. In a CGI application, this would be + -- the information following the path to the CGI executable itself. + -- + -- Middlewares and routing tools should not modify this raw value, as it may + -- be used for such things as creating redirect destinations by applications. + -- Instead, if you are writing a middleware or routing framework, modify the + -- @pathInfo@ instead. This is the approach taken by systems like Yesod + -- subsites. + -- + -- /Note/: At the time of writing this documentation, there is at least one + -- system (@Network.Wai.UrlMap@ from @wai-extra@) that does not follow the + -- above recommendation. Therefore, it is recommended that you test the + -- behavior of your application when using @rawPathInfo@ and any form of + -- library that might modify the @Request@. + , rawQueryString :: B.ByteString + -- ^ If no query string was specified, this should be empty. This value + -- /will/ include the leading question mark. + -- Do not modify this raw value - modify queryString instead. + , requestHeaders :: H.RequestHeaders + -- ^ A list of headers (a pair of key and value) in an HTTP request. + , isSecure :: Bool + -- ^ Was this request made over an SSL connection? + -- + -- Note that this value will /not/ tell you if the client originally made + -- this request over SSL, but rather whether the current connection is SSL. + -- The distinction lies with reverse proxies. In many cases, the client will + -- connect to a load balancer over SSL, but connect to the WAI handler + -- without SSL. In such a case, 'isSecure' will be 'False', but from a user + -- perspective, there is a secure connection. + , remoteHost :: SockAddr + -- ^ The client\'s host information. + , pathInfo :: [Text] + -- ^ Path info in individual pieces - the URL without a hostname/port and + -- without a query string, split on forward slashes. + , queryString :: H.Query + -- ^ Parsed query string information. + , requestBody :: IO B.ByteString + -- ^ Get the next chunk of the body. Returns 'B.empty' when the + -- body is fully consumed. Since 3.2.2, this is deprecated in favor of 'getRequestBodyChunk'. + , vault :: Vault + -- ^ A location for arbitrary data to be shared by applications and middleware. + , requestBodyLength :: RequestBodyLength + -- ^ The size of the request body. In the case of a chunked request body, + -- this may be unknown. + -- + -- @since 1.4.0 + , requestHeaderHost :: Maybe B.ByteString + -- ^ The value of the Host header in a HTTP request. + -- + -- @since 2.0.0 + , requestHeaderRange :: Maybe B.ByteString + -- ^ The value of the Range header in a HTTP request. + -- + -- @since 2.0.0 + , requestHeaderReferer :: Maybe B.ByteString + -- ^ The value of the Referer header in a HTTP request. + -- + -- @since 3.2.0 + , requestHeaderUserAgent :: Maybe B.ByteString + -- ^ The value of the User-Agent header in a HTTP request. + -- + -- @since 3.2.0 + , requestSendEarlyHints :: H.ResponseHeaders -> IO () + -- ^ Send a @103 Early Hints@ informational response carrying the given + -- headers, ahead of the final response. This lets a client (typically over + -- HTTP\/2) start fetching resources named in @Link@ headers while the final + -- response is still being produced. + -- + -- A handler (e.g. Warp over HTTP\/2) that supports early hints installs an + -- action here; otherwise it is a no-op. + -- + -- @since 3.2.5 + } +-- | Get the next chunk of the body. Returns 'B.empty' when the +-- body is fully consumed. +-- +-- @since 3.2.2 +getRequestBodyChunk :: Request -> IO B.ByteString +getRequestBodyChunk = requestBody +-- | Set the 'requestBody' attribute on a request without triggering a +-- deprecation warning. +-- +-- The supplied IO action should return the next chunk of the body each time it +-- is called and 'B.empty' when it has been fully consumed. +-- +-- @since 3.2.4 +setRequestBodyChunks :: IO B.ByteString -> Request -> Request +setRequestBodyChunks requestBody r = + r{requestBody = requestBody} + +instance Show Request where + show Request{..} = "Request {" ++ intercalate ", " [a ++ " = " ++ b | (a, b) <- fields] ++ "}" + where + fields = + [ ("requestMethod", show requestMethod) + , ("httpVersion", show httpVersion) + , ("rawPathInfo", show rawPathInfo) + , ("rawQueryString", show rawQueryString) + , ("requestHeaders", show requestHeaders) + , ("isSecure", show isSecure) + , ("remoteHost", show remoteHost) + , ("pathInfo", show pathInfo) + , ("queryString", show queryString) + , ("requestBody", "") + , ("vault", "") + , ("requestBodyLength", show requestBodyLength) + , ("requestHeaderHost", show requestHeaderHost) + , ("requestHeaderRange", show requestHeaderRange) + ] + data Response = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart) | ResponseBuilder H.Status H.ResponseHeaders Builder | ResponseStream H.Status H.ResponseHeaders StreamingBody | ResponseRaw (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) Response - deriving Typeable -- | Represents a streaming HTTP response body. It's a function of two -- parameters; the first parameter provides a means of sending another chunk of -- data, and the second parameter provides a means of flushing the data to the -- client. -- --- Since 3.0.0 +-- @since 3.0.0 type StreamingBody = (Builder -> IO ()) -> IO () -> IO () -- | The size of the request body. In the case of chunked bodies, the size will -- not be known. -- --- Since 1.4.0 -data RequestBodyLength = ChunkedBody | KnownLength Word64 deriving Show +-- @since 1.4.0 +data RequestBodyLength = ChunkedBody | KnownLength Word64 deriving (Show) -- | Information on which part to be sent. -- Sophisticated application handles Range (and If-Range) then -- create 'FilePart'. +-- +-- @since 0.4.0 data FilePart = FilePart - { filePartOffset :: Integer + { filePartOffset :: Integer , filePartByteCount :: Integer - , filePartFileSize :: Integer - } deriving Show + , filePartFileSize :: Integer + } + deriving (Show) -- | A special datatype to indicate that the WAI handler has received the -- response. This is to avoid the need for Rank2Types in the definition of @@ -154,94 +180,5 @@ -- It is /highly/ advised that only WAI handlers import and use the data -- constructor for this data type. -- --- Since 3.0.0 +-- @since 3.0.0 data ResponseReceived = ResponseReceived - deriving Typeable - --- | Look up the size of a file in 'Right' or the 'IOException' in 'Left'. -tryGetFileSize :: FilePath -> IO (Either IOException Integer) -tryGetFileSize path = - fmap (fromIntegral . P.fileSize) <$> try (P.getFileStatus path) - --- | \"Content-Range\". -hContentRange :: H.HeaderName -hContentRange = "Content-Range" - --- | \"Accept-Ranges\". -hAcceptRanges :: H.HeaderName -hAcceptRanges = "Accept-Ranges" - --- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' --- for the range specified. -contentRangeHeader :: Integer -> Integer -> Integer -> H.Header -contentRangeHeader beg end total = (hContentRange, range) - where - range = B.pack - -- building with ShowS - $ 'b' : 'y': 't' : 'e' : 's' : ' ' - : (if beg > end then ('*':) else - showInt beg - . ('-' :) - . showInt end) - ( '/' - : showInt total "") - --- | Given the full size of a file and optionally a Range header value, --- determine the range to serve by parsing the range header and obeying it, or --- serving the whole file if it's absent or malformed. -chooseFilePart :: Integer -> Maybe B.ByteString -> FilePart -chooseFilePart size Nothing = FilePart 0 size size -chooseFilePart size (Just range) = case parseByteRanges range >>= listToMaybe of - -- Range is broken - Nothing -> FilePart 0 size size - Just hrange -> checkRange hrange - where - checkRange (H.ByteRangeFrom beg) = fromRange beg (size - 1) - checkRange (H.ByteRangeFromTo beg end) = fromRange beg (min (size - 1) end) - checkRange (H.ByteRangeSuffix count) = fromRange (max 0 (size - count)) (size - 1) - - fromRange beg end = FilePart beg (end - beg + 1) size - --- | Adjust the given 'H.Status' and 'H.ResponseHeaders' based on the given --- 'FilePart'. This means replacing the status with 206 if the response is --- partial, and adding the Content-Length and Accept-Ranges (always) and --- Content-Range (if appropriate) headers. -adjustForFilePart :: H.Status -> H.ResponseHeaders -> FilePart -> (H.Status, H.ResponseHeaders) -adjustForFilePart s h part = (s', h'') - where - off = filePartOffset part - len = filePartByteCount part - size = filePartFileSize part - - contentRange = contentRangeHeader off (off + len - 1) size - lengthBS = L.toStrict $ B.toLazyByteString $ B.integerDec len - s' = if filePartByteCount part /= size then H.partialContent206 else s - h' = (H.hContentLength, lengthBS):(hAcceptRanges, "bytes"):h - h'' = (if len == size then id else (contentRange:)) h' - --- | Parse the value of a Range header into a 'HH.ByteRanges'. -parseByteRanges :: B.ByteString -> Maybe HH.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 (HH.ByteRangeSuffix (negate i), bs3) - else do - bs4 <- stripPrefix "-" bs3 - case B.readInteger bs4 of - Just (j, bs5) | j >= i -> Just (HH.ByteRangeFromTo i j, bs5) - _ -> Just (HH.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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -67,7 +67,7 @@ An `Application` maps `Request`s to `Response`s: ghci> :info Application - type Application = Request -> IO Response + type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived Depending on the path info provided with each `Request` we can serve different `Response`s: diff --git a/test/Network/WaiSpec.hs b/test/Network/WaiSpec.hs --- a/test/Network/WaiSpec.hs +++ b/test/Network/WaiSpec.hs @@ -1,15 +1,16 @@ +{-# LANGUAGE LambdaCase #-} + module Network.WaiSpec (spec) where -import Test.Hspec -import Test.Hspec.QuickCheck (prop) -import Network.Wai -import Network.Wai.Internal (Request (Request)) -import Data.IORef -import Data.Monoid +import Control.Monad (forM_) import qualified Data.ByteString as S +import Data.ByteString.Builder (Builder, toLazyByteString, word8) import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (toByteString, Builder, fromWord8) -import Control.Monad (forM_) +import Data.IORef +import Data.Word (Word8) +import Network.Wai +import Test.Hspec +import Test.Hspec.QuickCheck (prop) spec :: Spec spec = do @@ -24,17 +25,20 @@ flush :: IO () flush = return () streamingBody add flush - fmap toByteString $ readIORef builderRef + L.toStrict . toLazyByteString <$> readIORef builderRef prop "responseLBS" $ \bytes -> do body <- getBody $ responseLBS undefined undefined $ L.pack bytes body `shouldBe` S.pack bytes prop "responseBuilder" $ \bytes -> do - body <- getBody $ responseBuilder undefined undefined - $ mconcat $ map fromWord8 bytes + body <- + getBody $ + responseBuilder undefined undefined $ + mconcat $ + map word8 bytes body `shouldBe` S.pack bytes prop "responseStream" $ \chunks -> do body <- getBody $ responseStream undefined undefined $ \sendChunk _ -> - forM_ chunks $ \chunk -> sendChunk $ mconcat $ map fromWord8 chunk + forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk body `shouldBe` S.concat (map S.pack chunks) it "responseFile total" $ do let fp = "wai.cabal" @@ -47,38 +51,37 @@ let total = S.length totalBS offset = abs offset' `mod` total count = abs count' `mod` (total - offset) - body <- getBody $ responseFile undefined undefined fp $ Just FilePart - { filePartOffset = fromIntegral offset - , filePartByteCount = fromIntegral count - , filePartFileSize = fromIntegral total - } + body <- + getBody $ + responseFile undefined undefined fp $ + Just + FilePart + { filePartOffset = fromIntegral offset + , filePartByteCount = fromIntegral count + , filePartFileSize = fromIntegral total + } let expected = S.take count $ S.drop offset totalBS body `shouldBe` expected describe "lazyRequestBody" $ do prop "works" $ \chunks -> do - ref <- newIORef $ map S.pack $ filter (not . null) chunks - let req = Request - { requestBody = atomicModifyIORef ref $ \bss -> - case bss of - [] -> ([], S.empty) - x:y -> (y, x) - } + req <- mkRequestFromChunks chunks body <- lazyRequestBody req body `shouldBe` L.fromChunks (map S.pack chunks) it "is lazy" $ do - let req = Request - { requestBody = error "requestBody" - } + let req = setRequestBodyChunks (error "requestBody") defaultRequest _ <- lazyRequestBody req return () describe "strictRequestBody" $ do prop "works" $ \chunks -> do - ref <- newIORef $ map S.pack $ filter (not . null) chunks - let req = Request - { requestBody = atomicModifyIORef ref $ \bss -> - case bss of - [] -> ([], S.empty) - x:y -> (y, x) - } + req <- mkRequestFromChunks chunks body <- strictRequestBody req body `shouldBe` L.fromChunks (map S.pack chunks) + +mkRequestFromChunks :: [[Word8]] -> IO Request +mkRequestFromChunks chunks = do + ref <- newIORef $ map S.pack $ filter (not . null) chunks + pure $ + flip setRequestBodyChunks defaultRequest $ + atomicModifyIORef ref $ \case + [] -> ([], S.empty) + x : y -> (y, x) diff --git a/wai.cabal b/wai.cabal --- a/wai.cabal +++ b/wai.cabal @@ -1,8 +1,10 @@ +Cabal-Version: >=1.10 Name: wai -Version: 3.0.5.0 +Version: 3.2.5 Synopsis: Web Application Interface. Description: Provides a common protocol for communication between web applications and web servers. -description: API docs and the README are available at . + . + API docs and the README are available at . License: MIT License-file: LICENSE Author: Michael Snoyman @@ -10,43 +12,36 @@ Homepage: https://github.com/yesodweb/wai Category: Web Build-Type: Simple -Cabal-Version: >=1.8 Stability: Stable extra-source-files: README.md ChangeLog.md Source-repository head type: git - location: git://github.com/yesodweb/wai.git + location: https://github.com/yesodweb/wai.git + subdir: wai Library - Build-Depends: base >= 4 && < 5 - , bytestring >= 0.10 - , bytestring-builder >= 0.10.4.0 && < 0.10.7 - , blaze-builder >= 0.2.1.4 && < 0.5 + default-language: Haskell2010 + Build-Depends: base >= 4.12 && < 5 + , bytestring >= 0.10.4 , network >= 2.2.1.5 , http-types >= 0.7 , text >= 0.7 - , transformers >= 0.0 - , unix-compat >= 0.2 , vault >= 0.3 && < 0.4 Exposed-modules: Network.Wai - Network.Wai.HTTP2 Network.Wai.Internal ghc-options: -Wall test-suite test + default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs type: exitcode-stdio-1.0 - ghc-options: -threaded + ghc-options: -threaded -Wall cpp-options: -DTEST - build-depends: base + build-depends: base >= 4.8 && < 5 , wai , hspec - , blaze-builder , bytestring other-modules: Network.WaiSpec - -source-repository head - type: git - location: git://github.com/yesodweb/wai.git + build-tool-depends: hspec-discover:hspec-discover