diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,73 @@ +# 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 + +## 3.0.4.0 + +* A new module `Network.Wai.HTTP2` is exported. + +## 3.0.3.0 + +* `mapResponseHeaders`, `ifRequest` and `modifyResponse` are exported. + +## 3.0.2.3 + +* Allow blaze-builder 0.4 + +## 3.0.2.2 + +* Clarify some documentation on `rawPathInfo`. [Relevant Github + discussion](https://github.com/yesodweb/wai/issues/325#issuecomment-69896780). diff --git a/Network/Wai.hs b/Network/Wai.hs --- a/Network/Wai.hs +++ b/Network/Wai.hs @@ -1,108 +1,140 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-| +-- 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 - ( -- * WAI interface - Request (..) - , Response (..) - , responseSource - , Application - , Middleware - , FilePart (..) - -- * Response body smart constructors - , responseLBS - , responseStatus - ) where + -- * Middleware composition + ifRequest, + modifyRequest, + modifyResponse, +) where +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.Typeable (Typeable) -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Binary as CB -import Blaze.ByteString.Builder (Builder, fromLazyByteString) -import Network.Socket (SockAddr) +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import qualified Data.ByteString.Lazy.Internal as LI +import Data.Function (fix) import qualified Network.HTTP.Types as H -import Data.Text (Text) -import Data.ByteString.Lazy.Char8 () -- makes it easier to use responseLBS -import Blaze.ByteString.Builder (fromByteString) -import Data.Vault (Vault) +import Network.Socket (SockAddr (SockAddrInet)) +import Network.Wai.Internal +import qualified System.IO as IO +import System.IO.Unsafe (unsafeInterleaveIO) --- | Information on the request sent by the client. This abstracts away the --- details of the underlying implementation. -data Request = Request - { requestMethod :: H.Method - , 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. - -- Do not modify this raw value- modify pathInfo instead. - , 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 - -- | Generally the host requested by the user via the Host request header. - -- Backends are free to provide alternative values as necessary. This value - -- should not be used to construct URLs. - , serverName :: B.ByteString - -- | The listening port that the server received this request on. It is - -- possible for a server to listen on a non-numeric port (i.e., Unix named - -- socket), in which case this value will be arbitrary. Like 'serverName', - -- this value should not be used in URL construction. - , serverPort :: Int - , requestHeaders :: H.RequestHeaders - -- | Was this request made over an SSL 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 - , requestBody :: C.Source (C.ResourceT IO) B.ByteString - -- | A location for arbitrary data to be shared by applications and middleware. - , vault :: Vault - } - deriving (Typeable) +---------------------------------------------------------------- --- | +-- | Creating 'Response' from a file. -- +-- 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'. +-- -- Some questions and answers about the usage of 'Builder' here: -- -- Q1. Shouldn't it be at the user's discretion to use Builders internally and @@ -116,62 +148,458 @@ -- -- 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. -data Response - = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart) - | ResponseBuilder H.Status H.ResponseHeaders Builder - | ResponseSource H.Status H.ResponseHeaders (C.Source (C.ResourceT IO) (C.Flush Builder)) - deriving Typeable +-- +-- @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 . lazyByteString + +-- | Creating 'Response' from a stream of values. +-- +-- In order to allocate resources in an exception-safe manner, you can use the +-- @bracket@ pattern outside of the call to @responseStream@. As a trivial +-- example: +-- +-- @ +-- app :: Application +-- app req respond = bracket_ +-- (putStrLn \"Allocating scarce resource\") +-- (putStrLn \"Cleaning up\") +-- $ respond $ responseStream status200 [] $ \\write flush -> do +-- write $ byteString \"Hello\\n\" +-- flush +-- 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 +responseStream = ResponseStream + +-- | Create a response for a raw application. This is useful for \"upgrade\" +-- situations such as WebSockets, where an application requests for the server +-- to grant it raw network access. +-- +-- This function requires a backup response to be provided, for the case where +-- the handler in question does not support such upgrading (e.g., CGI apps). +-- +-- 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 +responseRaw = ResponseRaw + +---------------------------------------------------------------- + +-- | Accessing 'H.Status' in 'Response'. +-- +-- @since 1.2.0 responseStatus :: Response -> H.Status -responseStatus rsp = - case rsp of - ResponseFile s _ _ _ -> s - ResponseBuilder s _ _ -> s - ResponseSource s _ _ -> s +responseStatus (ResponseFile s _ _ _) = s +responseStatus (ResponseBuilder s _ _) = s +responseStatus (ResponseStream s _ _) = s +responseStatus (ResponseRaw _ res) = responseStatus res -data FilePart = FilePart - { filePartOffset :: Integer - , filePartByteCount :: Integer - } deriving Show +-- | 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 -responseSource :: Response -> (H.Status, H.ResponseHeaders, C.Source (C.ResourceT IO) (C.Flush Builder)) -responseSource (ResponseSource s h b) = (s, h, b) -responseSource (ResponseFile s h fp (Just part)) = - (s, h, sourceFilePart part fp C.$= CL.map (C.Chunk . fromByteString)) -responseSource (ResponseFile s h fp Nothing) = - (s, h, CB.sourceFile fp C.$= CL.map (C.Chunk . fromByteString)) -responseSource (ResponseBuilder s h b) = - (s, h, CL.sourceList [C.Chunk b]) +-- | Converting the body information in 'Response' to a 'StreamingBody'. +-- +-- @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 + , h + , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> withBody $ \sendChunk _flush -> do + IO.hSeek handle IO.AbsoluteSeek $ filePartOffset part + let loop remaining | remaining <= 0 = return () + loop remaining = do + bs <- B.hGetSome handle defaultChunkSize + unless (B.null bs) $ do + let x = B.take remaining bs + sendChunk $ byteString x + loop $ remaining - B.length x + loop $ fromIntegral $ filePartByteCount part + ) +responseToStream (ResponseFile s h fp Nothing) = + ( s + , h + , \withBody -> IO.withBinaryFile fp IO.ReadMode $ \handle -> + withBody $ \sendChunk _flush -> fix $ \loop -> do + bs <- B.hGetSome handle defaultChunkSize + unless (B.null bs) $ do + sendChunk $ byteString bs + loop + ) +responseToStream (ResponseBuilder s h b) = + (s, h, \withBody -> withBody $ \sendChunk _flush -> sendChunk b) +responseToStream (ResponseRaw _ res) = responseToStream res -sourceFilePart :: C.MonadResource m => FilePart -> FilePath -> C.Source m B.ByteString -sourceFilePart (FilePart offset count) fp = - CB.sourceFileRange fp (Just offset) (Just count) +-- | Apply the provided function to the response header list of the 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 -responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response -responseLBS s h = ResponseBuilder s h . fromLazyByteString +-- | 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 -type Application = Request -> C.ResourceT IO Response +---------------------------------------------------------------- --- | 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. +-- | The WAI 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 signatures for this middleware --- might be: +-- Note that, since WAI 3.0, this type is structured in continuation passing +-- style to allow for proper safe resource handling. This was handled in the +-- past via other means (e.g., @ResourceT@). As a demonstration: -- --- @ loadSession :: ([(String, String)] -> Application) -> Application @ +-- @ +-- app :: Application +-- app req respond = bracket_ +-- (putStrLn \"Allocating scarce resource\") +-- (putStrLn \"Cleaning up\") +-- (respond $ responseLBS status200 [] \"Hello World\") +-- @ +type Application = + Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived + +-- | A default, blank request. -- --- Here, instead of taking a standard 'Application' as its first argument, the --- middleware takes a function which consumes the session information as well. +-- @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 + , requestHeaderReferer = Nothing + , requestHeaderUserAgent = Nothing + , requestSendEarlyHints = \_ -> return () + } + +-- | A @Middleware@ is a component that sits between the server and application. +-- +-- 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. +-- +-- = Users of middleware +-- +-- 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' +-- +-- @since 3.0.3.0 +modifyResponse :: (Response -> Response) -> Middleware +modifyResponse f app req respond = app req $ respond . f + +-- | 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 + +-- $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. +-- +-- 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 <- 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. +-- +-- 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 <- 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/Internal.hs b/Network/Wai/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Internal.hs @@ -0,0 +1,184 @@ +{-# 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 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. +{-# 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." + #-} + +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 + +-- | 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 +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) + +-- | 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 + , filePartByteCount :: Integer + , 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 +-- Application. +-- +-- It is /highly/ advised that only WAI handlers import and use the data +-- constructor for this data type. +-- +-- @since 3.0.0 +data ResponseReceived = ResponseReceived diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,116 @@ +WAI: Web Application Interface +============================== + +Getting started +--------------- + +You want a minimal example? Here it is! + +~~~ {.haskell} +{-# LANGUAGE OverloadedStrings #-} +import Network.Wai +import Network.HTTP.Types +import Network.Wai.Handler.Warp (run) + +app :: Application +app _ respond = do + putStrLn "I've done some IO here" + respond $ responseLBS + status200 + [("Content-Type", "text/plain")] + "Hello, Web!" + +main :: IO () +main = do + putStrLn $ "http://localhost:8080/" + run 8080 app +~~~ + +Put that code into a file named _hello.hs_ and install [wai] and [warp] from Hackage: + + cabal install wai warp + +Run it: + + runhaskell hello.hs + +Point your browser to: + + http://localhost:8080/ + + +Serving static content +---------------------- + +We can modify our previous example to serve static content. For this create a file named _index.html_: + +

Hello, Web!

+ +Now we redefine `responseBody` to refer to that file: + +~~~ {.haskell} +app2 :: Application +app2 _ respond = respond index + +index :: Response +index = responseFile + status200 + [("Content-Type", "text/html")] + "index.html" + Nothing +~~~ + + +Basic dispatching +----------------- + +An `Application` maps `Request`s to `Response`s: + + ghci> :info Application + type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived + +Depending on the path info provided with each `Request` we can serve different `Response`s: + +~~~ {.haskell} +app3 :: Application +app3 request respond = respond $ case rawPathInfo request of + "/" -> index + "/raw/" -> plainIndex + _ -> notFound + +plainIndex :: Response +plainIndex = responseFile + status200 + [("Content-Type", "text/plain")] + "index.html" + Nothing + +notFound :: Response +notFound = responseLBS + status404 + [("Content-Type", "text/plain")] + "404 - Not Found" +~~~ + + +Doing without overloaded strings +-------------------------------- + +For the sake of efficiency, WAI uses the [bytestring] package. We used GHCs [overloaded strings] to almost hide this fact. But we can easily do without. What follows is a more verbose definition of `notFound`, that works without GHC extensions: + +~~~ {.haskell .ignore} +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as LB8 +import Data.CaseInsensitive (mk) + +notFound = responseLBS + status404 + [(mk $ B8.pack "Content-Type", B8.pack "text/plain")] + (LB8.pack "404 - Not Found") +~~~ + + + [wai]: http://hackage.haskell.org/package/wai + [warp]: http://hackage.haskell.org/package/warp + [overloaded strings]: http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-strings + [bytestring]: http://hackage.haskell.org/package/bytestring diff --git a/test/Network/WaiSpec.hs b/test/Network/WaiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/WaiSpec.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE LambdaCase #-} + +module Network.WaiSpec (spec) where + +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 Data.IORef +import Data.Word (Word8) +import Network.Wai +import Test.Hspec +import Test.Hspec.QuickCheck (prop) + +spec :: Spec +spec = do + describe "responseToStream" $ do + let getBody res = do + let (_, _, f) = responseToStream res + f $ \streamingBody -> do + builderRef <- newIORef mempty + let add :: Builder -> IO () + add b = atomicModifyIORef builderRef $ \builder -> + (builder `mappend` b, ()) + flush :: IO () + flush = return () + streamingBody add flush + 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 word8 bytes + body `shouldBe` S.pack bytes + prop "responseStream" $ \chunks -> do + body <- getBody $ responseStream undefined undefined $ \sendChunk _ -> + forM_ chunks $ \chunk -> sendChunk $ mconcat $ map word8 chunk + body `shouldBe` S.concat (map S.pack chunks) + it "responseFile total" $ do + let fp = "wai.cabal" + body <- getBody $ responseFile undefined undefined fp Nothing + expected <- S.readFile fp + body `shouldBe` expected + prop "responseFile partial" $ \offset' count' -> do + let fp = "wai.cabal" + totalBS <- S.readFile fp + 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 + } + let expected = S.take count $ S.drop offset totalBS + body `shouldBe` expected + describe "lazyRequestBody" $ do + prop "works" $ \chunks -> do + req <- mkRequestFromChunks chunks + body <- lazyRequestBody req + body `shouldBe` L.fromChunks (map S.pack chunks) + it "is lazy" $ do + let req = setRequestBodyChunks (error "requestBody") defaultRequest + _ <- lazyRequestBody req + return () + describe "strictRequestBody" $ do + prop "works" $ \chunks -> do + 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/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/wai.cabal b/wai.cabal --- a/wai.cabal +++ b/wai.cabal @@ -1,7 +1,10 @@ +Cabal-Version: >=1.10 Name: wai -Version: 1.2.0.3 +Version: 3.2.5 Synopsis: Web Application Interface. Description: Provides a common protocol for communication between web applications and web servers. + . + API docs and the README are available at . License: MIT License-file: LICENSE Author: Michael Snoyman @@ -9,22 +12,36 @@ Homepage: https://github.com/yesodweb/wai Category: Web Build-Type: Simple -Cabal-Version: >=1.6 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.9.1.4 - , blaze-builder >= 0.2.1.4 && < 0.4 - , conduit >= 0.4 && < 0.5 - , network >= 2.2.1.5 && < 2.4 - , http-types >= 0.6 && < 0.7 - , text >= 0.7 && < 0.12 - , transformers >= 0.2.2 && < 0.4 - , vault >= 0.1 && < 0.3 + 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 + , vault >= 0.3 && < 0.4 Exposed-modules: Network.Wai + 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 -Wall + cpp-options: -DTEST + build-depends: base >= 4.8 && < 5 + , wai + , hspec + , bytestring + other-modules: Network.WaiSpec + build-tool-depends: hspec-discover:hspec-discover