Separate headers into request and response headers

- Add response header construction using records
- Update tests and examples
- Update doc

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
 

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.

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

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

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)

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 =

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 =

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'

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 ()