From 88169cd299d11aef33554bb8ff01da4f174df6fd Mon Sep 17 00:00:00 2001 From: sigma-andex <77549848+sigma-andex@users.noreply.github.com> Date: Thu, 16 Jun 2022 19:58:33 +0100 Subject: [PATCH] Separate headers into request and response headers - Add response header construction using records - Update tests and examples - Update doc --- CHANGELOG.md | 2 ++ docs/Differences.md | 5 +++ docs/Examples/BinaryResponse/Main.purs | 4 +-- docs/Examples/Headers/Main.purs | 11 ++++--- src/HTTPurple/Headers.purs | 45 +++++++++++++++++--------- test/Test/HTTPurple/BodySpec.purs | 10 +++--- test/Test/HTTPurple/HeadersSpec.purs | 18 +++++------ test/Test/HTTPurple/ResponseSpec.purs | 12 ++++--- test/Test/HTTPurple/TestHelpers.purs | 6 ++-- 9 files changed, 69 insertions(+), 44 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b8dfa16..1bb6bfa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,8 @@ # Changelog ## Unpublished +- Separate `Headers` into `RequestHeaders` and `ResponseHeaders` +- Allow passing a record to `headers` to make `ResponseHeaders` easier ## v1.3.0 diff --git a/docs/Differences.md b/docs/Differences.md index 8a1a6a5..90e6ccd 100644 --- a/docs/Differences.md +++ b/docs/Differences.md @@ -119,6 +119,11 @@ main = HTTPurple 🪁 has some helpers to make json parsing and validation very simple. See the [requests guide](./Requests.md) for more information. +## Headers + +HTTPurple 🪁 has two separate types for headers, namely `RequestHeader` and `ResponseHeader`. `ResponseHeader` wraps `Map CaseInsensitiveString (Array String)` and therefore allows setting multiple response headers. This is useful if you e.g. want to set multiple `Set-Cookie` headers. +Also you can create the headers by passing a record. See the [responses documentation](./Differences.md) for more information. + ## Other improvmenets * Default closing handler - A default closing handler is provided so you can just stop your server using `ctrl+x` without having to worry about anything. You can deactivate it by setting `closingHandler: NoClosingHandler` in the listen options. diff --git a/docs/Examples/BinaryResponse/Main.purs b/docs/Examples/BinaryResponse/Main.purs index 90ba0cd..79e910e 100644 --- a/docs/Examples/BinaryResponse/Main.purs +++ b/docs/Examples/BinaryResponse/Main.purs @@ -5,7 +5,7 @@ import Prelude import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) import Effect.Console (log) -import HTTPurple (Headers, Request, ResponseM, ServerM, header, ok', serve) +import HTTPurple (Request, ResponseHeaders, ResponseM, ServerM, header, ok', serve) import Node.FS.Aff (readFile) import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -23,7 +23,7 @@ route = RD.root $ RG.sum filePath :: String filePath = "./docs/Examples/BinaryResponse/circle.png" -responseHeaders :: Headers +responseHeaders :: ResponseHeaders responseHeaders = header "Content-Type" "image/png" -- | Respond with image data when run diff --git a/docs/Examples/Headers/Main.purs b/docs/Examples/Headers/Main.purs index c4afc16..4984a93 100644 --- a/docs/Examples/Headers/Main.purs +++ b/docs/Examples/Headers/Main.purs @@ -3,9 +3,9 @@ module Examples.Headers.Main where import Prelude import Data.Generic.Rep (class Generic) -import Data.Maybe (Maybe(..)) import Effect.Console (log) -import HTTPurple (Headers, Request, ResponseM, ServerM, header, ok', serve, (!@)) +import HTTPurple (Request, ResponseHeaders, ResponseM, ServerM, ok', serve, (!@)) +import HTTPurple.Headers (headers) import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -19,8 +19,11 @@ route = RD.root $ RG.sum } -- | The headers that will be included in every response. -responseHeaders :: Headers -responseHeaders = header "X-Example" "hello world!" +responseHeaders :: ResponseHeaders +responseHeaders = headers + { "X-Example": "hello world!" + , "X-Example2": "hello world!" + } -- | Route to the correct handler router :: Request Route -> ResponseM diff --git a/src/HTTPurple/Headers.purs b/src/HTTPurple/Headers.purs index b472ce1..c3ae7a5 100644 --- a/src/HTTPurple/Headers.purs +++ b/src/HTTPurple/Headers.purs @@ -12,8 +12,7 @@ module HTTPurple.Headers , read , toResponseHeaders , write - ) - where + ) where import Prelude @@ -36,8 +35,9 @@ import Prim.RowList (class RowToList, Cons, Nil) import Record as Record import Type.Proxy (Proxy(..)) --- | The `RequestHeaders` type is just sugar for a `Object` of `Strings` --- | that represents the set of headers in an HTTP request or response. +-- | The `RequestHeaders` type is a wrapper for a map +-- | that represents the set of headers in an HTTP request. +-- | A request header contains maximum one value per key. newtype RequestHeaders = RequestHeaders (Map CaseInsensitiveString String) derive instance Newtype RequestHeaders _ @@ -47,14 +47,14 @@ derive instance Newtype RequestHeaders _ instance Lookup RequestHeaders String String where lookup (RequestHeaders headers') key = headers' !! key --- | Allow a `Headers` to be represented as a string. This string is formatted +-- | Allow a `RequestHeaders` to be represented as a string. This string is formatted -- | in HTTP headers format. instance Show RequestHeaders where show (RequestHeaders headers') = foldMapWithIndex showField headers' <> "\n" where showField key value = unwrap key <> ": " <> value <> "\n" --- | Compare two `Headers` objects by comparing the underlying `Objects`. +-- | Compare two `RequestHeaders` objects by comparing the underlying `Objects`. instance Eq RequestHeaders where eq (RequestHeaders a) (RequestHeaders b) = eq a b @@ -62,11 +62,12 @@ instance Eq RequestHeaders where instance Semigroup RequestHeaders where append (RequestHeaders a) (RequestHeaders b) = RequestHeaders $ union b a --- | The `RequestHeaders` type is just sugar for a `Object` of `Strings` --- | that represents the set of headers in an HTTP request or response. +-- | The `ResponseHeaders` type is a wrapper for a map +-- | that represents the set of headers in an HTTP response. +-- | A response header can contain multiple values per key, +-- | e.g. in the case of multiple Set-Cookie directives. newtype ResponseHeaders = ResponseHeaders (Map CaseInsensitiveString (Array String)) - -- | Allow one `ResponseHeaders` objects to be appended to another. instance Semigroup ResponseHeaders where append (ResponseHeaders a) (ResponseHeaders b) = ResponseHeaders $ union b a @@ -82,7 +83,7 @@ instance Show ResponseHeaders where instance Eq ResponseHeaders where eq (ResponseHeaders a) (ResponseHeaders b) = eq a b --- | Get the headers out of a HTTP `Request` object. +-- | Get the headers out of a HTTP `RequestHeaders` object. read :: Request -> RequestHeaders read = requestHeaders >>> fold insertField Map.empty >>> RequestHeaders where @@ -95,18 +96,19 @@ write response (ResponseHeaders headers') = void $ traverseWithIndex writeField where writeField key values = setHeaders response (unwrap key) values --- | Return a `ResponseHeaders` containing nothing. +-- | Return a `ResponseHeaders` containing no headers. empty :: ResponseHeaders empty = ResponseHeaders Map.empty - --- -- | Convert an `Array` of `Tuples` of 2 `Strings` to a `Headers` object. +-- | Convert an `Array` of `Tuples` of 2 `Strings` to a `RequestHeaders` object. +-- | This is intended mainly for internal use. mkRequestHeaders :: Array (Tuple String String) -> RequestHeaders mkRequestHeaders = foldl insertField Map.empty >>> RequestHeaders where insertField x (Tuple key value) = insert (CaseInsensitiveString key) value x -- | Create a singleton header from a key-value pair. +-- | This is intended mainly for internal use. mkRequestHeader :: String -> String -> RequestHeaders mkRequestHeader key = singleton (CaseInsensitiveString key) >>> RequestHeaders @@ -114,6 +116,8 @@ mkRequestHeader key = singleton (CaseInsensitiveString key) >>> RequestHeaders header :: String -> String -> ResponseHeaders header key = Array.singleton >>> singleton (CaseInsensitiveString key) >>> ResponseHeaders +-- | Copy the request headers to the response headers +-- | This is intended mainly for internal use. toResponseHeaders :: RequestHeaders -> ResponseHeaders toResponseHeaders = un RequestHeaders >>> map (Array.singleton) >>> ResponseHeaders @@ -128,7 +132,7 @@ else instance , RowToList r rl , RowToList tail tailRL , Row.Cons sym String tail r - , Row.Lacks sym tail + , Row.Lacks sym tail , ToHeadersHelper tail tailRL ) => ToHeadersHelper r (Cons sym String tailRL) where @@ -143,7 +147,7 @@ else instance , RowToList r rl , RowToList tail tailRL , Row.Cons sym (Array String) tail r - , Row.Lacks sym tail + , Row.Lacks sym tail , ToHeadersHelper tail tailRL ) => ToHeadersHelper r (Cons sym (Array String) tailRL) where @@ -156,7 +160,16 @@ else instance tail = Record.delete (Proxy :: Proxy sym) rec class ToHeaders r where + -- | Create `ResponseHeaders` from a record, an `Array (Tuple String String)` or an `Array (Tuple String (Array String))` headers :: r -> ResponseHeaders -instance (RowToList r rl, ToHeadersHelper r rl) => ToHeaders (Record r) where +instance ToHeaders (Array (Tuple String String)) where + headers = foldl insertField Map.empty >>> ResponseHeaders + where + insertField x (Tuple key value) = insert (CaseInsensitiveString key) (Array.singleton value) x +else instance ToHeaders (Array (Tuple String (Array String))) where + headers = foldl insertField Map.empty >>> ResponseHeaders + where + insertField x (Tuple key value) = insert (CaseInsensitiveString key) value x +else instance (RowToList r rl, ToHeadersHelper r rl) => ToHeaders (Record r) where headers = headersImpl (Proxy :: Proxy rl) diff --git a/test/Test/HTTPurple/BodySpec.purs b/test/Test/HTTPurple/BodySpec.purs index d8a839e..9e8427f 100644 --- a/test/Test/HTTPurple/BodySpec.purs +++ b/test/Test/HTTPurple/BodySpec.purs @@ -7,7 +7,7 @@ import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Ref (new) as Ref import HTTPurple.Body (RequestBody, defaultHeaders, read, toBuffer, toStream, toString, write) -import HTTPurple.Headers (header) +import HTTPurple.Headers (mkRequestHeader) import Node.Buffer (Buffer, fromString) import Node.Buffer (toString) as Buffer import Node.Encoding (Encoding(UTF8)) @@ -72,20 +72,20 @@ defaultHeadersSpec = describe "with an ASCII string" do it "has the correct Content-Length header" do headers <- liftEffect $ defaultHeaders "ascii" - headers ?= header "Content-Length" "5" + headers ?= (mkRequestHeader "Content-Length" "5") describe "with a UTF-8 string" do it "has the correct Content-Length header" do headers <- liftEffect $ defaultHeaders "\x2603" - headers ?= header "Content-Length" "3" + headers ?= (mkRequestHeader "Content-Length" "3") describe "Buffer" do it "has the correct Content-Length header" do buf :: Buffer <- liftEffect $ fromString "foobar" UTF8 headers <- liftEffect $ defaultHeaders buf - headers ?= header "Content-Length" "6" + headers ?= (mkRequestHeader "Content-Length" "6") describe "Readable" do it "specifies the Transfer-Encoding header" do headers <- liftEffect $ defaultHeaders $ stringToStream "test" - headers ?= header "Transfer-Encoding" "chunked" + headers ?= (mkRequestHeader "Transfer-Encoding" "chunked") writeSpec :: Test writeSpec = diff --git a/test/Test/HTTPurple/HeadersSpec.purs b/test/Test/HTTPurple/HeadersSpec.purs index 27e18f3..f3ca08c 100644 --- a/test/Test/HTTPurple/HeadersSpec.purs +++ b/test/Test/HTTPurple/HeadersSpec.purs @@ -5,7 +5,7 @@ import Prelude import Data.Maybe (Maybe(Nothing, Just)) import Data.Tuple (Tuple(Tuple)) import Effect.Class (liftEffect) -import HTTPurple.Headers (empty, header, headers, read, write) +import HTTPurple.Headers (empty, header, headers, mkRequestHeader, mkRequestHeaders, read, write) import HTTPurple.Lookup ((!!)) import Test.HTTPurple.TestHelpers ((?=)) import Test.HTTPurple.TestHelpers as TestHelpers @@ -17,20 +17,20 @@ lookupSpec = describe "when the string is in the header set" do describe "when searching with lowercase" do it "is Just the string" do - header "x-test" "test" !! "x-test" ?= Just "test" + mkRequestHeader "x-test" "test" !! "x-test" ?= Just "test" describe "when searching with uppercase" do it "is Just the string" do - header "x-test" "test" !! "X-Test" ?= Just "test" + mkRequestHeader "x-test" "test" !! "X-Test" ?= Just "test" describe "when the string is uppercase" do describe "when searching with lowercase" do it "is Just the string" do - header "X-Test" "test" !! "x-test" ?= Just "test" + mkRequestHeader "X-Test" "test" !! "x-test" ?= Just "test" describe "when searching with uppercase" do it "is Just the string" do - header "X-Test" "test" !! "X-Test" ?= Just "test" + mkRequestHeader "X-Test" "test" !! "X-Test" ?= Just "test" describe "when the string is not in the header set" do it "is Nothing" do - ((empty !! "X-Test") :: Maybe String) ?= Nothing + ((mkRequestHeaders [] !! "X-Test") :: Maybe String) ?= Nothing showSpec :: TestHelpers.Test showSpec = @@ -83,12 +83,12 @@ readSpec = describe "with no headers" do it "is an empty Map" do request <- TestHelpers.mockRequest "" "" "" "" [] - read request ?= empty + read request ?= (mkRequestHeaders []) describe "with headers" do it "is a Map with the contents of the headers" do let testHeader = [ Tuple "X-Test" "test" ] request <- TestHelpers.mockRequest "" "" "" "" testHeader - read request ?= headers testHeader + read request ?= mkRequestHeaders testHeader writeSpec :: TestHelpers.Test writeSpec = @@ -98,7 +98,7 @@ writeSpec = mock <- TestHelpers.mockResponse write mock $ header "X-Test" "test" pure $ TestHelpers.getResponseHeader "X-Test" mock - header ?= "test" + header ?= [ "test" ] emptySpec :: TestHelpers.Test emptySpec = diff --git a/test/Test/HTTPurple/ResponseSpec.purs b/test/Test/HTTPurple/ResponseSpec.purs index 5a24a40..d566279 100644 --- a/test/Test/HTTPurple/ResponseSpec.purs +++ b/test/Test/HTTPurple/ResponseSpec.purs @@ -3,10 +3,12 @@ module Test.HTTPurple.ResponseSpec where import Prelude import Data.Either (Either(Right)) +import Debug (spy) import Effect.Aff (makeAff, nonCanceler) import Effect.Class (liftEffect) import HTTPurple.Body (defaultHeaders) -import HTTPurple.Headers (header, toResponseHeaders) +import HTTPurple.Headers (toResponseHeaders) +import HTTPurple.Headers as Headers import HTTPurple.Response (emptyResponse, emptyResponse', response, response', send) import Node.Encoding (Encoding(UTF8)) import Node.HTTP (responseAsStream) @@ -20,7 +22,7 @@ sendSpec = let mockResponse' = { status: 123 - , headers: header "Test" "test" + , headers: Headers.header "Test" "test" , writeBody: \response -> makeAff \done -> do stream <- pure $ responseAsStream response @@ -32,7 +34,7 @@ sendSpec = httpResponse <- liftEffect mockResponse send httpResponse mockResponse' pure $ getResponseHeader "Test" httpResponse - header ?= "test" + header ?= [ "test" ] it "writes the status" do status <- do httpResponse <- liftEffect mockResponse @@ -68,7 +70,7 @@ response'Spec :: Test response'Spec = describe "response'" do let - mockHeaders = header "Test" "test" + mockHeaders = Headers.header "Test" "test" mockResponse' = response' 123 mockHeaders "test" it "has the right status" do resp <- mockResponse' @@ -107,7 +109,7 @@ emptyResponse'Spec :: Test emptyResponse'Spec = describe "emptyResponse'" do let - mockHeaders = header "Test" "test" + mockHeaders = Headers.header "Test" "test" mockResponse' = emptyResponse' 123 mockHeaders it "has the right status" do resp <- mockResponse' diff --git a/test/Test/HTTPurple/TestHelpers.purs b/test/Test/HTTPurple/TestHelpers.purs index 7b4eb19..eacf8b9 100644 --- a/test/Test/HTTPurple/TestHelpers.purs +++ b/test/Test/HTTPurple/TestHelpers.purs @@ -230,12 +230,12 @@ getResponseStatus :: HTTP.Response -> Int getResponseStatus = _.statusCode <<< unsafeCoerce -- | Get all current headers on the HTTP Response object. -getResponseHeaders :: HTTP.Response -> Object String +getResponseHeaders :: HTTP.Response -> Object (Array String) getResponseHeaders = unsafeCoerce <<< _.headers <<< unsafeCoerce -- | Get the current value for the header on the HTTP Response object. -getResponseHeader :: String -> HTTP.Response -> String -getResponseHeader header = fromMaybe "" <<< lookup header <<< getResponseHeaders +getResponseHeader :: String -> HTTP.Response -> Array String +getResponseHeader header = fromMaybe [ "" ] <<< lookup header <<< getResponseHeaders -- | Create a stream out of a string. foreign import stringToStream :: String -> Readable ()