diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # ChangeLog for wai +## 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) @@ -34,23 +41,23 @@ * 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. +* 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 @@ -66,6 +66,9 @@ , consumeRequestBodyStrict , lazyRequestBody , consumeRequestBodyLazy + -- ** Request modifiers + , setRequestBodyChunks + , mapRequestHeaders -- * Response , Response , StreamingBody @@ -85,17 +88,16 @@ , mapResponseStatus -- * Middleware composition , ifRequest + , modifyRequest , modifyResponse ) where -import Data.ByteString.Builder (Builder, lazyByteString) -import Data.ByteString.Builder (byteString) +import Data.ByteString.Builder (Builder, byteString, lazyByteString) import Control.Monad (unless) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as LI import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Data.ByteString.Lazy.Char8 () import Data.Function (fix) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr (SockAddrInet)) @@ -106,6 +108,8 @@ ---------------------------------------------------------------- -- | Creating 'Response' from a file. +-- +-- @since 2.0.0 responseFile :: H.Status -> H.ResponseHeaders -> FilePath -> Maybe FilePart -> Response responseFile = ResponseFile @@ -132,11 +136,15 @@ -- -- 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 . lazyByteString @@ -161,7 +169,7 @@ -- 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 +-- @since 3.0.0 responseStream :: H.Status -> H.ResponseHeaders -> StreamingBody @@ -178,7 +186,7 @@ -- In the event that you read from the request body before returning a -- @responseRaw@, behavior is undefined. -- --- Since 2.1.0 +-- @since 2.1.0 responseRaw :: (IO B.ByteString -> (B.ByteString -> IO ()) -> IO ()) -> Response -> Response @@ -187,6 +195,8 @@ ---------------------------------------------------------------- -- | Accessing 'H.Status' in 'Response'. +-- +-- @since 1.2.0 responseStatus :: Response -> H.Status responseStatus (ResponseFile s _ _ _) = s responseStatus (ResponseBuilder s _ _ ) = s @@ -194,6 +204,8 @@ 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 @@ -201,6 +213,8 @@ responseHeaders (ResponseRaw _ res) = responseHeaders res -- | Converting the body information in 'Response' to a 'StreamingBody'. +-- +-- @since 3.0.0 responseToStream :: Response -> ( H.Status , H.ResponseHeaders @@ -236,6 +250,8 @@ responseToStream (ResponseRaw _ res) = responseToStream res -- | 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 @@ -243,6 +259,8 @@ 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 @@ -269,7 +287,7 @@ -- | A default, blank request. -- --- Since 2.0.0 +-- @since 2.0.0 defaultRequest :: Request defaultRequest = Request { requestMethod = H.methodGet @@ -291,32 +309,170 @@ } --- | 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 -- @@ -374,7 +530,7 @@ -- -- Note: Since this function consumes the request body, future calls to it will return the empty string. -- --- Since 3.0.1 +-- @since 3.0.1 strictRequestBody :: Request -> IO L.ByteString strictRequestBody req = loop id @@ -397,7 +553,7 @@ -- -- Note: Since this function consumes the request body, future calls to it will return the empty string. -- --- Since 1.4.1 +-- @since 1.4.1 lazyRequestBody :: Request -> IO L.ByteString lazyRequestBody req = loop @@ -416,3 +572,9 @@ -- @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 --- a/Network/Wai/Internal.hs +++ b/Network/Wai/Internal.hs @@ -1,12 +1,11 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | Internal constructors and helper functions. Note that no guarantees are -- given for stability of these interfaces. module Network.Wai.Internal where import Data.ByteString.Builder (Builder) -import qualified Data.ByteString as B hiding (pack) +import qualified Data.ByteString as B import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vault.Lazy (Vault) @@ -17,7 +16,7 @@ -- | 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." #-} +{-# 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 { -- | Request method such as GET. requestMethod :: H.Method @@ -70,23 +69,23 @@ -- | The size of the request body. In the case of a chunked request body, -- this may be unknown. -- - -- Since 1.4.0 + -- @since 1.4.0 , requestBodyLength :: RequestBodyLength -- | The value of the Host header in a HTTP request. -- - -- Since 2.0.0 + -- @since 2.0.0 , requestHeaderHost :: Maybe B.ByteString -- | The value of the Range header in a HTTP request. -- - -- Since 2.0.0 + -- @since 2.0.0 , requestHeaderRange :: Maybe B.ByteString -- | The value of the Referer header in a HTTP request. -- - -- Since 3.2.0 + -- @since 3.2.0 , requestHeaderReferer :: Maybe B.ByteString -- | The value of the User-Agent header in a HTTP request. -- - -- Since 3.2.0 + -- @since 3.2.0 , requestHeaderUserAgent :: Maybe B.ByteString } deriving (Typeable) @@ -98,6 +97,17 @@ 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 @@ -131,18 +141,20 @@ -- 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 +-- @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 @@ -156,6 +168,6 @@ -- 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 diff --git a/test/Network/WaiSpec.hs b/test/Network/WaiSpec.hs --- a/test/Network/WaiSpec.hs +++ b/test/Network/WaiSpec.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE LambdaCase #-} module Network.WaiSpec (spec) where import Test.Hspec import Test.Hspec.QuickCheck (prop) import Network.Wai +import Data.Word (Word8) import Data.IORef import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -22,7 +24,7 @@ flush :: IO () flush = return () streamingBody add flush - fmap (L.toStrict . toLazyByteString) $ readIORef builderRef + L.toStrict . toLazyByteString <$> readIORef builderRef prop "responseLBS" $ \bytes -> do body <- getBody $ responseLBS undefined undefined $ L.pack bytes body `shouldBe` S.pack bytes @@ -54,29 +56,24 @@ body `shouldBe` expected describe "lazyRequestBody" $ do prop "works" $ \chunks -> do - ref <- newIORef $ map S.pack $ filter (not . null) chunks - let req = defaultRequest - { 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 = defaultRequest - { 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 = defaultRequest - { 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,6 +1,6 @@ Cabal-Version: >=1.10 Name: wai -Version: 3.2.3 +Version: 3.2.4 Synopsis: Web Application Interface. Description: Provides a common protocol for communication between web applications and web servers. . @@ -21,7 +21,7 @@ Library default-language: Haskell2010 - Build-Depends: base >= 4.10 && < 5 + Build-Depends: base >= 4.12 && < 5 , bytestring >= 0.10.4 , network >= 2.2.1.5 , http-types >= 0.7