From 5d63fc27656fd0bf7e59f20c0da3ecf17337c62b Mon Sep 17 00:00:00 2001 From: sjpgarcia <91515796+sjpgarcia@users.noreply.github.com> Date: Thu, 6 Jan 2022 23:42:00 +0800 Subject: [PATCH 01/12] Create separate request and response header types --- src/HTTPure.purs | 6 +- src/HTTPure/Body.purs | 4 +- src/HTTPure/Headers.purs | 75 ------------------ src/HTTPure/Request.purs | 6 +- src/HTTPure/RequestHeaders.purs | 48 +++++++++++ src/HTTPure/Response.purs | 132 +++++++++++++++---------------- src/HTTPure/ResponseHeaders.purs | 83 +++++++++++++++++++ 7 files changed, 206 insertions(+), 148 deletions(-) delete mode 100644 src/HTTPure/Headers.purs create mode 100644 src/HTTPure/RequestHeaders.purs create mode 100644 src/HTTPure/ResponseHeaders.purs diff --git a/src/HTTPure.purs b/src/HTTPure.purs index fcdf8e6..939bbfb 100644 --- a/src/HTTPure.purs +++ b/src/HTTPure.purs @@ -1,6 +1,7 @@ module HTTPure ( module HTTPure.Body - , module HTTPure.Headers + , module HTTPure.RequestHeaders + , module HTTPure.ResponseHeaders , module HTTPure.Lookup , module HTTPure.Method , module HTTPure.Path @@ -12,12 +13,13 @@ module HTTPure ) where import HTTPure.Body (toBuffer, toStream, toString) -import HTTPure.Headers (Headers, empty, header, headers) +import HTTPure.ResponseHeaders (ResponseHeaders, empty, header, headers) import HTTPure.Lookup (at, (!@), has, (!?), lookup, (!!)) import HTTPure.Method (Method(..)) import HTTPure.Path (Path) import HTTPure.Query (Query) import HTTPure.Request (Request, fullPath) +import HTTPure.RequestHeaders (RequestHeaders, read) import HTTPure.Response ( Response , ResponseM diff --git a/src/HTTPure/Body.purs b/src/HTTPure/Body.purs index 321606d..ec2ad44 100644 --- a/src/HTTPure/Body.purs +++ b/src/HTTPure/Body.purs @@ -17,7 +17,7 @@ import Effect.Aff (Aff, makeAff, nonCanceler) import Effect.Class (liftEffect) import Effect.Ref (Ref) import Effect.Ref (read, modify, new, write) as Ref -import HTTPure.Headers (Headers, header) +import HTTPure.ResponseHeaders (ResponseHeaders, header) import Node.Buffer (Buffer, concat, fromString, size) import Node.Buffer (toString) as Buffer import Node.Encoding (Encoding(UTF8)) @@ -101,7 +101,7 @@ class Body b where -- | things like `Content-Type`, `Content-Length`, and `Transfer-Encoding`. -- | Note that any headers passed in a response helper such as `ok'` will take -- | precedence over these. - defaultHeaders :: b -> Effect Headers + defaultHeaders :: b -> Effect ResponseHeaders -- | Given a body value and a Node HTTP `Response` value, write the body value -- | to the Node response. write :: b -> Response -> Aff Unit diff --git a/src/HTTPure/Headers.purs b/src/HTTPure/Headers.purs deleted file mode 100644 index 39b807f..0000000 --- a/src/HTTPure/Headers.purs +++ /dev/null @@ -1,75 +0,0 @@ -module HTTPure.Headers - ( Headers(..) - , empty - , headers - , header - , read - , write - ) where - -import Prelude -import Effect (Effect) -import Foreign.Object (fold) -import Data.Foldable (foldl) -import Data.FoldableWithIndex (foldMapWithIndex) -import Data.Map (empty) as Map -import Data.Map (Map, singleton, union, insert) -import Data.Newtype (class Newtype, unwrap) -import Data.String.CaseInsensitive (CaseInsensitiveString(CaseInsensitiveString)) -import Data.TraversableWithIndex (traverseWithIndex) -import Data.Tuple (Tuple(Tuple)) -import Node.HTTP (Request, Response, requestHeaders, setHeader) -import HTTPure.Lookup (class Lookup, (!!)) - --- | The `Headers` type is just sugar for a `Object` of `Strings` --- | that represents the set of headers in an HTTP request or response. -newtype Headers = Headers (Map CaseInsensitiveString String) - -derive instance newtypeHeaders :: Newtype Headers _ - --- | Given a string, return a `Maybe` containing the value of the matching --- | header, if there is any. -instance lookup :: Lookup Headers String String where - lookup (Headers headers') key = headers' !! key - --- | Allow a `Headers` to be represented as a string. This string is formatted --- | in HTTP headers format. -instance show :: Show Headers where - show (Headers headers') = foldMapWithIndex showField headers' <> "\n" - where - showField key value = unwrap key <> ": " <> value <> "\n" - --- | Compare two `Headers` objects by comparing the underlying `Objects`. -instance eq :: Eq Headers where - eq (Headers a) (Headers b) = eq a b - --- | Allow one `Headers` objects to be appended to another. -instance semigroup :: Semigroup Headers where - append (Headers a) (Headers b) = Headers $ union b a - --- | Get the headers out of a HTTP `Request` object. -read :: Request -> Headers -read = requestHeaders >>> fold insertField Map.empty >>> Headers - where - insertField x key value = insert (CaseInsensitiveString key) value x - --- | Given an HTTP `Response` and a `Headers` object, return an effect that will --- | write the `Headers` to the `Response`. -write :: Response -> Headers -> Effect Unit -write response (Headers headers') = void $ traverseWithIndex writeField headers' - where - writeField key value = setHeader response (unwrap key) value - --- | Return a `Headers` containing nothing. -empty :: Headers -empty = Headers Map.empty - --- | Convert an `Array` of `Tuples` of 2 `Strings` to a `Headers` object. -headers :: Array (Tuple String String) -> Headers -headers = foldl insertField Map.empty >>> Headers - where - insertField x (Tuple key value) = insert (CaseInsensitiveString key) value x - --- | Create a singleton header from a key-value pair. -header :: String -> String -> Headers -header key = singleton (CaseInsensitiveString key) >>> Headers diff --git a/src/HTTPure/Request.purs b/src/HTTPure/Request.purs index 07826bc..43aeef8 100644 --- a/src/HTTPure/Request.purs +++ b/src/HTTPure/Request.purs @@ -11,8 +11,8 @@ import Effect.Class (liftEffect) import Foreign.Object (isEmpty, toArrayWithKey) import HTTPure.Body (RequestBody) import HTTPure.Body (read) as Body -import HTTPure.Headers (Headers) -import HTTPure.Headers (read) as Headers +import HTTPure.RequestHeaders (RequestHeaders) +import HTTPure.RequestHeaders (read) as Headers import HTTPure.Method (Method) import HTTPure.Method (read) as Method import HTTPure.Path (Path) @@ -31,7 +31,7 @@ type Request = { method :: Method , path :: Path , query :: Query - , headers :: Headers + , headers :: RequestHeaders , body :: RequestBody , httpVersion :: Version , url :: String diff --git a/src/HTTPure/RequestHeaders.purs b/src/HTTPure/RequestHeaders.purs new file mode 100644 index 0000000..324f236 --- /dev/null +++ b/src/HTTPure/RequestHeaders.purs @@ -0,0 +1,48 @@ +module HTTPure.RequestHeaders + ( RequestHeaders(..) + , empty + , read + ) where + +import Prelude + +import Data.FoldableWithIndex (foldMapWithIndex) +import Data.Newtype (class Newtype) +import Data.String as String +import Foreign.Object (Object, union) +import Foreign.Object as Object +import HTTPure.Lookup (class Lookup, (!!)) +import Node.HTTP (Request, requestHeaders) + +-- | The `RequestHeaders` type is just sugar for a `Object` of `Strings` +-- | that represents the set of headers in an HTTP request. +newtype RequestHeaders = RequestHeaders (Object String) + +derive instance newtypeRequestHeaders :: Newtype RequestHeaders _ + +-- | Given a string. return a `Maybe` containing the value of the matching +-- | request header, if there is any. +instance lookupRequestHeaders :: Lookup RequestHeaders String String where + lookup (RequestHeaders headers') key = headers' !! (String.toLower key) + +-- | Allow a `RequestHeaders` to be represented as a string. This string is +-- | formatted in HTTP headers format. +instance showRequestHeaders :: Show RequestHeaders where + show (RequestHeaders headers') = foldMapWithIndex showField headers' <> "\n" + where + showField key value = key <> ": " <> value <> "\n" + +-- | Compare two `RequestHeaders` objects by comparing the underlying `Objects`. +instance eqRequestHeaders :: Eq RequestHeaders where + eq (RequestHeaders a) (RequestHeaders b) = eq a b + +-- | Allow one `RequestHeaders` objects to be appended to another. +instance semigroupRequestHeaders :: Semigroup RequestHeaders where + append (RequestHeaders a) (RequestHeaders b) = RequestHeaders $ union b a + +-- | Get the request headers out of a HTTP `Request` object. +read :: Request -> RequestHeaders +read = requestHeaders >>> RequestHeaders + +empty :: RequestHeaders +empty = RequestHeaders Object.empty diff --git a/src/HTTPure/Response.purs b/src/HTTPure/Response.purs index 63875c9..1531232 100644 --- a/src/HTTPure/Response.purs +++ b/src/HTTPure/Response.purs @@ -139,8 +139,8 @@ import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Class (class MonadEffect, liftEffect) import Node.HTTP (Response) as HTTP import HTTPure.Body (class Body, defaultHeaders, write) -import HTTPure.Headers (Headers, empty) -import HTTPure.Headers (write) as Headers +import HTTPure.ResponseHeaders (ResponseHeaders, empty) +import HTTPure.ResponseHeaders (write) as ResponseHeaders import HTTPure.Status (Status) import HTTPure.Status ( write @@ -214,7 +214,7 @@ type ResponseM = Aff Response -- | A `Response` is a status code, headers, and a body. type Response = { status :: Status - , headers :: Headers + , headers :: ResponseHeaders , writeBody :: HTTP.Response -> Aff Unit } @@ -224,7 +224,7 @@ type Response = send :: forall m. MonadEffect m => MonadAff m => HTTP.Response -> Response -> m Unit send httpresponse { status, headers, writeBody } = do liftEffect $ Status.write httpresponse status - liftEffect $ Headers.write httpresponse headers + liftEffect $ ResponseHeaders.write httpresponse headers liftAff $ writeBody httpresponse -- | For custom response statuses or providing a body for response codes that @@ -238,7 +238,7 @@ response' :: MonadAff m => Body b => Status -> - Headers -> + ResponseHeaders -> b -> m Response response' status headers body = liftEffect do @@ -254,7 +254,7 @@ emptyResponse :: forall m. MonadAff m => Status -> m Response emptyResponse status = emptyResponse' status empty -- | The same as `emptyResponse` but with headers. -emptyResponse' :: forall m. MonadAff m => Status -> Headers -> m Response +emptyResponse' :: forall m. MonadAff m => Status -> ResponseHeaders -> m Response emptyResponse' status headers = response' status headers "" --------- @@ -265,7 +265,7 @@ continue :: forall m. MonadAff m => m Response continue = continue' empty -- | 100 with headers -continue' :: forall m. MonadAff m => Headers -> m Response +continue' :: forall m. MonadAff m => ResponseHeaders -> m Response continue' = emptyResponse' Status.continue -- | 101 @@ -273,7 +273,7 @@ switchingProtocols :: forall m. MonadAff m => m Response switchingProtocols = switchingProtocols' empty -- | 101 with headers -switchingProtocols' :: forall m. MonadAff m => Headers -> m Response +switchingProtocols' :: forall m. MonadAff m => ResponseHeaders -> m Response switchingProtocols' = emptyResponse' Status.switchingProtocols -- | 102 @@ -281,7 +281,7 @@ processing :: forall m. MonadAff m => m Response processing = processing' empty -- | 102 with headers -processing' :: forall m. MonadAff m => Headers -> m Response +processing' :: forall m. MonadAff m => ResponseHeaders -> m Response processing' = emptyResponse' Status.processing --------- @@ -292,7 +292,7 @@ ok :: forall m b. MonadAff m => Body b => b -> m Response ok = ok' empty -- | 200 with headers -ok' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +ok' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response ok' = response' Status.ok -- | 201 @@ -300,7 +300,7 @@ created :: forall m. MonadAff m => m Response created = created' empty -- | 201 with headers -created' :: forall m. MonadAff m => Headers -> m Response +created' :: forall m. MonadAff m => ResponseHeaders -> m Response created' = emptyResponse' Status.created -- | 202 @@ -308,7 +308,7 @@ accepted :: forall m. MonadAff m => m Response accepted = accepted' empty -- | 202 with headers -accepted' :: forall m. MonadAff m => Headers -> m Response +accepted' :: forall m. MonadAff m => ResponseHeaders -> m Response accepted' = emptyResponse' Status.accepted -- | 203 @@ -320,7 +320,7 @@ nonAuthoritativeInformation' :: forall m b. MonadAff m => Body b => - Headers -> + ResponseHeaders -> b -> m Response nonAuthoritativeInformation' = response' Status.nonAuthoritativeInformation @@ -330,7 +330,7 @@ noContent :: forall m. MonadAff m => m Response noContent = noContent' empty -- | 204 with headers -noContent' :: forall m. MonadAff m => Headers -> m Response +noContent' :: forall m. MonadAff m => ResponseHeaders -> m Response noContent' = emptyResponse' Status.noContent -- | 205 @@ -338,7 +338,7 @@ resetContent :: forall m. MonadAff m => m Response resetContent = resetContent' empty -- | 205 with headers -resetContent' :: forall m. MonadAff m => Headers -> m Response +resetContent' :: forall m. MonadAff m => ResponseHeaders -> m Response resetContent' = emptyResponse' Status.resetContent -- | 206 @@ -346,7 +346,7 @@ partialContent :: forall m b. MonadAff m => Body b => b -> m Response partialContent = partialContent' empty -- | 206 with headers -partialContent' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +partialContent' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response partialContent' = response' Status.partialContent -- | 207 @@ -354,7 +354,7 @@ multiStatus :: forall m b. MonadAff m => Body b => b -> m Response multiStatus = multiStatus' empty -- | 207 with headers -multiStatus' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +multiStatus' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response multiStatus' = response' Status.multiStatus -- | 208 @@ -362,7 +362,7 @@ alreadyReported :: forall m. MonadAff m => m Response alreadyReported = alreadyReported' empty -- | 208 with headers -alreadyReported' :: forall m. MonadAff m => Headers -> m Response +alreadyReported' :: forall m. MonadAff m => ResponseHeaders -> m Response alreadyReported' = emptyResponse' Status.alreadyReported -- | 226 @@ -370,7 +370,7 @@ iMUsed :: forall m b. MonadAff m => Body b => b -> m Response iMUsed = iMUsed' empty -- | 226 with headers -iMUsed' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +iMUsed' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response iMUsed' = response' Status.iMUsed --------- @@ -381,7 +381,7 @@ multipleChoices :: forall m b. MonadAff m => Body b => b -> m Response multipleChoices = multipleChoices' empty -- | 300 with headers -multipleChoices' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +multipleChoices' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response multipleChoices' = response' Status.multipleChoices -- | 301 @@ -389,7 +389,7 @@ movedPermanently :: forall m b. MonadAff m => Body b => b -> m Response movedPermanently = movedPermanently' empty -- | 301 with headers -movedPermanently' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +movedPermanently' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response movedPermanently' = response' Status.movedPermanently -- | 302 @@ -397,7 +397,7 @@ found :: forall m b. MonadAff m => Body b => b -> m Response found = found' empty -- | 302 with headers -found' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +found' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response found' = response' Status.found -- | 303 @@ -405,7 +405,7 @@ seeOther :: forall m b. MonadAff m => Body b => b -> m Response seeOther = seeOther' empty -- | 303 with headers -seeOther' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +seeOther' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response seeOther' = response' Status.seeOther -- | 304 @@ -413,7 +413,7 @@ notModified :: forall m. MonadAff m => m Response notModified = notModified' empty -- | 304 with headers -notModified' :: forall m. MonadAff m => Headers -> m Response +notModified' :: forall m. MonadAff m => ResponseHeaders -> m Response notModified' = emptyResponse' Status.notModified -- | 305 @@ -421,7 +421,7 @@ useProxy :: forall m b. MonadAff m => Body b => b -> m Response useProxy = useProxy' empty -- | 305 with headers -useProxy' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +useProxy' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response useProxy' = response' Status.useProxy -- | 307 @@ -429,7 +429,7 @@ temporaryRedirect :: forall m b. MonadAff m => Body b => b -> m Response temporaryRedirect = temporaryRedirect' empty -- | 307 with headers -temporaryRedirect' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +temporaryRedirect' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response temporaryRedirect' = response' Status.temporaryRedirect -- | 308 @@ -437,7 +437,7 @@ permanentRedirect :: forall m b. MonadAff m => Body b => b -> m Response permanentRedirect = permanentRedirect' empty -- | 308 with headers -permanentRedirect' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +permanentRedirect' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response permanentRedirect' = response' Status.permanentRedirect --------- @@ -448,7 +448,7 @@ badRequest :: forall m b. MonadAff m => Body b => b -> m Response badRequest = badRequest' empty -- | 400 with headers -badRequest' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +badRequest' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response badRequest' = response' Status.badRequest -- | 401 @@ -456,7 +456,7 @@ unauthorized :: forall m. MonadAff m => m Response unauthorized = unauthorized' empty -- | 401 with headers -unauthorized' :: forall m. MonadAff m => Headers -> m Response +unauthorized' :: forall m. MonadAff m => ResponseHeaders -> m Response unauthorized' = emptyResponse' Status.unauthorized -- | 402 @@ -464,7 +464,7 @@ paymentRequired :: forall m. MonadAff m => m Response paymentRequired = paymentRequired' empty -- | 402 with headers -paymentRequired' :: forall m. MonadAff m => Headers -> m Response +paymentRequired' :: forall m. MonadAff m => ResponseHeaders -> m Response paymentRequired' = emptyResponse' Status.paymentRequired -- | 403 @@ -472,7 +472,7 @@ forbidden :: forall m. MonadAff m => m Response forbidden = forbidden' empty -- | 403 with headers -forbidden' :: forall m. MonadAff m => Headers -> m Response +forbidden' :: forall m. MonadAff m => ResponseHeaders -> m Response forbidden' = emptyResponse' Status.forbidden -- | 404 @@ -480,7 +480,7 @@ notFound :: forall m. MonadAff m => m Response notFound = notFound' empty -- | 404 with headers -notFound' :: forall m. MonadAff m => Headers -> m Response +notFound' :: forall m. MonadAff m => ResponseHeaders -> m Response notFound' = emptyResponse' Status.notFound -- | 405 @@ -488,7 +488,7 @@ methodNotAllowed :: forall m. MonadAff m => m Response methodNotAllowed = methodNotAllowed' empty -- | 405 with headers -methodNotAllowed' :: forall m. MonadAff m => Headers -> m Response +methodNotAllowed' :: forall m. MonadAff m => ResponseHeaders -> m Response methodNotAllowed' = emptyResponse' Status.methodNotAllowed -- | 406 @@ -496,7 +496,7 @@ notAcceptable :: forall m. MonadAff m => m Response notAcceptable = notAcceptable' empty -- | 406 with headers -notAcceptable' :: forall m. MonadAff m => Headers -> m Response +notAcceptable' :: forall m. MonadAff m => ResponseHeaders -> m Response notAcceptable' = emptyResponse' Status.notAcceptable -- | 407 @@ -504,7 +504,7 @@ proxyAuthenticationRequired :: forall m. MonadAff m => m Response proxyAuthenticationRequired = proxyAuthenticationRequired' empty -- | 407 with headers -proxyAuthenticationRequired' :: forall m. MonadAff m => Headers -> m Response +proxyAuthenticationRequired' :: forall m. MonadAff m => ResponseHeaders -> m Response proxyAuthenticationRequired' = emptyResponse' Status.proxyAuthenticationRequired -- | 408 @@ -512,7 +512,7 @@ requestTimeout :: forall m. MonadAff m => m Response requestTimeout = requestTimeout' empty -- | 408 with headers -requestTimeout' :: forall m. MonadAff m => Headers -> m Response +requestTimeout' :: forall m. MonadAff m => ResponseHeaders -> m Response requestTimeout' = emptyResponse' Status.requestTimeout -- | 409 @@ -520,7 +520,7 @@ conflict :: forall m b. MonadAff m => Body b => b -> m Response conflict = conflict' empty -- | 409 with headers -conflict' :: forall m b. MonadAff m => Body b => Headers -> b -> m Response +conflict' :: forall m b. MonadAff m => Body b => ResponseHeaders -> b -> m Response conflict' = response' Status.conflict -- | 410 @@ -528,7 +528,7 @@ gone :: forall m. MonadAff m => m Response gone = gone' empty -- | 410 with headers -gone' :: forall m. MonadAff m => Headers -> m Response +gone' :: forall m. MonadAff m => ResponseHeaders -> m Response gone' = emptyResponse' Status.gone -- | 411 @@ -536,7 +536,7 @@ lengthRequired :: forall m. MonadAff m => m Response lengthRequired = lengthRequired' empty -- | 411 with headers -lengthRequired' :: forall m. MonadAff m => Headers -> m Response +lengthRequired' :: forall m. MonadAff m => ResponseHeaders -> m Response lengthRequired' = emptyResponse' Status.lengthRequired -- | 412 @@ -544,7 +544,7 @@ preconditionFailed :: forall m. MonadAff m => m Response preconditionFailed = preconditionFailed' empty -- | 412 with headers -preconditionFailed' :: forall m. MonadAff m => Headers -> m Response +preconditionFailed' :: forall m. MonadAff m => ResponseHeaders -> m Response preconditionFailed' = emptyResponse' Status.preconditionFailed -- | 413 @@ -552,7 +552,7 @@ payloadTooLarge :: forall m. MonadAff m => m Response payloadTooLarge = payloadTooLarge' empty -- | 413 with headers -payloadTooLarge' :: forall m. MonadAff m => Headers -> m Response +payloadTooLarge' :: forall m. MonadAff m => ResponseHeaders -> m Response payloadTooLarge' = emptyResponse' Status.payloadTooLarge -- | 414 @@ -560,7 +560,7 @@ uRITooLong :: forall m. MonadAff m => m Response uRITooLong = uRITooLong' empty -- | 414 with headers -uRITooLong' :: forall m. MonadAff m => Headers -> m Response +uRITooLong' :: forall m. MonadAff m => ResponseHeaders -> m Response uRITooLong' = emptyResponse' Status.uRITooLong -- | 415 @@ -568,7 +568,7 @@ unsupportedMediaType :: forall m. MonadAff m => m Response unsupportedMediaType = unsupportedMediaType' empty -- | 415 with headers -unsupportedMediaType' :: forall m. MonadAff m => Headers -> m Response +unsupportedMediaType' :: forall m. MonadAff m => ResponseHeaders -> m Response unsupportedMediaType' = emptyResponse' Status.unsupportedMediaType -- | 416 @@ -576,7 +576,7 @@ rangeNotSatisfiable :: forall m. MonadAff m => m Response rangeNotSatisfiable = rangeNotSatisfiable' empty -- | 416 with headers -rangeNotSatisfiable' :: forall m. MonadAff m => Headers -> m Response +rangeNotSatisfiable' :: forall m. MonadAff m => ResponseHeaders -> m Response rangeNotSatisfiable' = emptyResponse' Status.rangeNotSatisfiable -- | 417 @@ -584,7 +584,7 @@ expectationFailed :: forall m. MonadAff m => m Response expectationFailed = expectationFailed' empty -- | 417 with headers -expectationFailed' :: forall m. MonadAff m => Headers -> m Response +expectationFailed' :: forall m. MonadAff m => ResponseHeaders -> m Response expectationFailed' = emptyResponse' Status.expectationFailed -- | 418 @@ -592,7 +592,7 @@ imATeapot :: forall m. MonadAff m => m Response imATeapot = imATeapot' empty -- | 418 with headers -imATeapot' :: forall m. MonadAff m => Headers -> m Response +imATeapot' :: forall m. MonadAff m => ResponseHeaders -> m Response imATeapot' = emptyResponse' Status.imATeapot -- | 421 @@ -600,7 +600,7 @@ misdirectedRequest :: forall m. MonadAff m => m Response misdirectedRequest = misdirectedRequest' empty -- | 421 with headers -misdirectedRequest' :: forall m. MonadAff m => Headers -> m Response +misdirectedRequest' :: forall m. MonadAff m => ResponseHeaders -> m Response misdirectedRequest' = emptyResponse' Status.misdirectedRequest -- | 422 @@ -608,7 +608,7 @@ unprocessableEntity :: forall m. MonadAff m => m Response unprocessableEntity = unprocessableEntity' empty -- | 422 with headers -unprocessableEntity' :: forall m. MonadAff m => Headers -> m Response +unprocessableEntity' :: forall m. MonadAff m => ResponseHeaders -> m Response unprocessableEntity' = emptyResponse' Status.unprocessableEntity -- | 423 @@ -616,7 +616,7 @@ locked :: forall m. MonadAff m => m Response locked = locked' empty -- | 423 with headers -locked' :: forall m. MonadAff m => Headers -> m Response +locked' :: forall m. MonadAff m => ResponseHeaders -> m Response locked' = emptyResponse' Status.locked -- | 424 @@ -624,7 +624,7 @@ failedDependency :: forall m. MonadAff m => m Response failedDependency = failedDependency' empty -- | 424 with headers -failedDependency' :: forall m. MonadAff m => Headers -> m Response +failedDependency' :: forall m. MonadAff m => ResponseHeaders -> m Response failedDependency' = emptyResponse' Status.failedDependency -- | 426 @@ -632,7 +632,7 @@ upgradeRequired :: forall m. MonadAff m => m Response upgradeRequired = upgradeRequired' empty -- | 426 with headers -upgradeRequired' :: forall m. MonadAff m => Headers -> m Response +upgradeRequired' :: forall m. MonadAff m => ResponseHeaders -> m Response upgradeRequired' = emptyResponse' Status.upgradeRequired -- | 428 @@ -640,7 +640,7 @@ preconditionRequired :: forall m. MonadAff m => m Response preconditionRequired = preconditionRequired' empty -- | 428 with headers -preconditionRequired' :: forall m. MonadAff m => Headers -> m Response +preconditionRequired' :: forall m. MonadAff m => ResponseHeaders -> m Response preconditionRequired' = emptyResponse' Status.preconditionRequired -- | 429 @@ -648,7 +648,7 @@ tooManyRequests :: forall m. MonadAff m => m Response tooManyRequests = tooManyRequests' empty -- | 429 with headers -tooManyRequests' :: forall m. MonadAff m => Headers -> m Response +tooManyRequests' :: forall m. MonadAff m => ResponseHeaders -> m Response tooManyRequests' = emptyResponse' Status.tooManyRequests -- | 431 @@ -656,7 +656,7 @@ requestHeaderFieldsTooLarge :: forall m. MonadAff m => m Response requestHeaderFieldsTooLarge = requestHeaderFieldsTooLarge' empty -- | 431 with headers -requestHeaderFieldsTooLarge' :: forall m. MonadAff m => Headers -> m Response +requestHeaderFieldsTooLarge' :: forall m. MonadAff m => ResponseHeaders -> m Response requestHeaderFieldsTooLarge' = emptyResponse' Status.requestHeaderFieldsTooLarge -- | 451 @@ -664,7 +664,7 @@ unavailableForLegalReasons :: forall m. MonadAff m => m Response unavailableForLegalReasons = unavailableForLegalReasons' empty -- | 451 with headers -unavailableForLegalReasons' :: forall m. MonadAff m => Headers -> m Response +unavailableForLegalReasons' :: forall m. MonadAff m => ResponseHeaders -> m Response unavailableForLegalReasons' = emptyResponse' Status.unavailableForLegalReasons --------- @@ -679,7 +679,7 @@ internalServerError' :: forall m b. MonadAff m => Body b => - Headers -> + ResponseHeaders -> b -> m Response internalServerError' = response' Status.internalServerError @@ -689,7 +689,7 @@ notImplemented :: forall m. MonadAff m => m Response notImplemented = notImplemented' empty -- | 501 with headers -notImplemented' :: forall m. MonadAff m => Headers -> m Response +notImplemented' :: forall m. MonadAff m => ResponseHeaders -> m Response notImplemented' = emptyResponse' Status.notImplemented -- | 502 @@ -697,7 +697,7 @@ badGateway :: forall m. MonadAff m => m Response badGateway = badGateway' empty -- | 502 with headers -badGateway' :: forall m. MonadAff m => Headers -> m Response +badGateway' :: forall m. MonadAff m => ResponseHeaders -> m Response badGateway' = emptyResponse' Status.badGateway -- | 503 @@ -705,7 +705,7 @@ serviceUnavailable :: forall m. MonadAff m => m Response serviceUnavailable = serviceUnavailable' empty -- | 503 with headers -serviceUnavailable' :: forall m. MonadAff m => Headers -> m Response +serviceUnavailable' :: forall m. MonadAff m => ResponseHeaders -> m Response serviceUnavailable' = emptyResponse' Status.serviceUnavailable -- | 504 @@ -713,7 +713,7 @@ gatewayTimeout :: forall m. MonadAff m => m Response gatewayTimeout = gatewayTimeout' empty -- | 504 with headers -gatewayTimeout' :: forall m. MonadAff m => Headers -> m Response +gatewayTimeout' :: forall m. MonadAff m => ResponseHeaders -> m Response gatewayTimeout' = emptyResponse' Status.gatewayTimeout -- | 505 @@ -721,7 +721,7 @@ hTTPVersionNotSupported :: forall m. MonadAff m => m Response hTTPVersionNotSupported = hTTPVersionNotSupported' empty -- | 505 with headers -hTTPVersionNotSupported' :: forall m. MonadAff m => Headers -> m Response +hTTPVersionNotSupported' :: forall m. MonadAff m => ResponseHeaders -> m Response hTTPVersionNotSupported' = emptyResponse' Status.hTTPVersionNotSupported -- | 506 @@ -729,7 +729,7 @@ variantAlsoNegotiates :: forall m. MonadAff m => m Response variantAlsoNegotiates = variantAlsoNegotiates' empty -- | 506 with headers -variantAlsoNegotiates' :: forall m. MonadAff m => Headers -> m Response +variantAlsoNegotiates' :: forall m. MonadAff m => ResponseHeaders -> m Response variantAlsoNegotiates' = emptyResponse' Status.variantAlsoNegotiates -- | 507 @@ -737,7 +737,7 @@ insufficientStorage :: forall m. MonadAff m => m Response insufficientStorage = insufficientStorage' empty -- | 507 with headers -insufficientStorage' :: forall m. MonadAff m => Headers -> m Response +insufficientStorage' :: forall m. MonadAff m => ResponseHeaders -> m Response insufficientStorage' = emptyResponse' Status.insufficientStorage -- | 508 @@ -745,7 +745,7 @@ loopDetected :: forall m. MonadAff m => m Response loopDetected = loopDetected' empty -- | 508 with headers -loopDetected' :: forall m. MonadAff m => Headers -> m Response +loopDetected' :: forall m. MonadAff m => ResponseHeaders -> m Response loopDetected' = emptyResponse' Status.loopDetected -- | 510 @@ -753,7 +753,7 @@ notExtended :: forall m. MonadAff m => m Response notExtended = notExtended' empty -- | 510 with headers -notExtended' :: forall m. MonadAff m => Headers -> m Response +notExtended' :: forall m. MonadAff m => ResponseHeaders -> m Response notExtended' = emptyResponse' Status.notExtended -- | 511 @@ -761,5 +761,5 @@ networkAuthenticationRequired :: forall m. MonadAff m => m Response networkAuthenticationRequired = networkAuthenticationRequired' empty -- | 511 with headers -networkAuthenticationRequired' :: forall m. MonadAff m => Headers -> m Response +networkAuthenticationRequired' :: forall m. MonadAff m => ResponseHeaders -> m Response networkAuthenticationRequired' = emptyResponse' Status.networkAuthenticationRequired diff --git a/src/HTTPure/ResponseHeaders.purs b/src/HTTPure/ResponseHeaders.purs new file mode 100644 index 0000000..f1d2fc6 --- /dev/null +++ b/src/HTTPure/ResponseHeaders.purs @@ -0,0 +1,83 @@ +module HTTPure.ResponseHeaders + ( ResponseHeaders(..) + , empty + , headers + , headers' + , header + , header' + , write + ) where + +import Prelude + +import Data.Array.NonEmpty (NonEmptyArray, toArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Foldable (foldl) +import Data.FoldableWithIndex (foldMapWithIndex) +import Data.Map (Map, singleton, union, insert) +import Data.Map (empty) as Map +import Data.Newtype (class Newtype, unwrap) +import Data.String.CaseInsensitive (CaseInsensitiveString(CaseInsensitiveString)) +import Data.Traversable (traverse) +import Data.TraversableWithIndex (traverseWithIndex) +import Data.Tuple (Tuple(Tuple)) +import Effect (Effect) +import HTTPure.Lookup (class Lookup, (!!)) +import Node.HTTP (Response, setHeader, setHeaders) + +-- | The `ResponseHeaders` type is just sugar for a `Map` of `Strings` +-- | that represents the set of headers in an HTTP request or response. +newtype ResponseHeaders = ResponseHeaders (Map CaseInsensitiveString (NonEmptyArray String)) + +derive instance newtypeResponseHeaders :: Newtype ResponseHeaders _ + +-- | Given a string, return a `Maybe` containing the value of the matching +-- | header, if there is any. +instance lookupResponseHeaders :: Lookup ResponseHeaders String (NonEmptyArray String) where + lookup (ResponseHeaders responseHeaders) key = responseHeaders !! key + +-- | Allow a `ResponseHeaders` to be represented as a string. This string +-- | is formatted in HTTP headers format. +instance showResponseHeaders :: Show ResponseHeaders where + show (ResponseHeaders responseHeaders) = foldMapWithIndex showField responseHeaders <> "\n" + where + showField key value = unwrap key <> ": " <> NonEmptyArray.intercalate " " value <> "\n" + +-- | Compare two `ResponseHeaders` objects by comparing the underlying +-- | `Objects`. +instance eqResponseHeaders :: Eq ResponseHeaders where + eq (ResponseHeaders a) (ResponseHeaders b) = eq a b + +-- | Allow one `ResponseHeaders` objects to be appended to another. +instance semigroupResponseHeaders :: Semigroup ResponseHeaders where + append (ResponseHeaders a) (ResponseHeaders b) = ResponseHeaders $ union b a + +-- | Given an HTTP `Response` and a `ResponseHeaders` object, return an +-- | effect that will write the `ResponseHeaders` to the `Response`. +write :: Response -> ResponseHeaders -> Effect Unit +write response (ResponseHeaders responseHeaders) = void $ traverseWithIndex writeField responseHeaders + where + writeField key = traverse (setHeader response (unwrap key)) + +-- | Return a `ResponseHeaders` containing nothing. +empty :: ResponseHeaders +empty = ResponseHeaders Map.empty + +-- | Convert an `Array` of `Tuples` of 2 `Strings` to a `ResponseHeaders` +-- | object. +headers :: Array (Tuple String String) -> ResponseHeaders +headers = foldl insertField Map.empty >>> ResponseHeaders + where + insertField x (Tuple key value) = insert (CaseInsensitiveString key) (NonEmptyArray.singleton value) x + +headers' :: Array (Tuple String (NonEmptyArray String)) -> ResponseHeaders +headers' = foldl insertField Map.empty >>> ResponseHeaders + where + insertField x (Tuple key value) = insert (CaseInsensitiveString key) value x + +-- | Create a singleton header from a key-value pair. +header :: String -> String -> ResponseHeaders +header key = NonEmptyArray.singleton >>> singleton (CaseInsensitiveString key) >>> ResponseHeaders + +header' :: String -> NonEmptyArray String -> ResponseHeaders +header' key = singleton (CaseInsensitiveString key) >>> ResponseHeaders From 0920cd0373dd8b28b14fe54fcc5e3e43aa4ede64 Mon Sep 17 00:00:00 2001 From: sjpgarcia <91515796+sjpgarcia@users.noreply.github.com> Date: Fri, 7 Jan 2022 00:24:06 +0800 Subject: [PATCH 02/12] Make docs and test source files compile --- docs/Examples/BinaryResponse/Main.purs | 4 +-- docs/Examples/Headers/Main.purs | 4 +-- test/Test/HTTPure/BodySpec.purs | 2 +- test/Test/HTTPure/HeadersSpec.purs | 14 +++++---- test/Test/HTTPure/RequestSpec.purs | 6 ++-- test/Test/HTTPure/ResponseSpec.purs | 2 +- test/Test/HTTPure/TestHelpers.purs | 42 +++++++++++++------------- 7 files changed, 38 insertions(+), 36 deletions(-) diff --git a/docs/Examples/BinaryResponse/Main.purs b/docs/Examples/BinaryResponse/Main.purs index 4569a83..0f1bde6 100644 --- a/docs/Examples/BinaryResponse/Main.purs +++ b/docs/Examples/BinaryResponse/Main.purs @@ -3,13 +3,13 @@ module Examples.BinaryResponse.Main where import Prelude import Effect.Console (log) import Node.FS.Aff (readFile) -import HTTPure (ServerM, Request, ResponseM, Headers, serve, ok', header) +import HTTPure (ServerM, Request, ResponseM, ResponseHeaders, serve, ok', header) -- | The path to the file containing the response to send 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 b85c488..37ac813 100644 --- a/docs/Examples/Headers/Main.purs +++ b/docs/Examples/Headers/Main.purs @@ -2,10 +2,10 @@ module Examples.Headers.Main where import Prelude import Effect.Console (log) -import HTTPure (ServerM, Headers, Request, ResponseM, (!@), header, serve, ok') +import HTTPure (ServerM, ResponseHeaders, Request, ResponseM, (!@), header, serve, ok') -- | The headers that will be included in every response. -responseHeaders :: Headers +responseHeaders :: ResponseHeaders responseHeaders = header "X-Example" "hello world!" -- | Route to the correct handler diff --git a/test/Test/HTTPure/BodySpec.purs b/test/Test/HTTPure/BodySpec.purs index 66d2986..a34f8af 100644 --- a/test/Test/HTTPure/BodySpec.purs +++ b/test/Test/HTTPure/BodySpec.purs @@ -7,7 +7,7 @@ import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Ref (new) as Ref import HTTPure.Body (RequestBody, defaultHeaders, read, toBuffer, toStream, toString, write) -import HTTPure.Headers (header) +import HTTPure.ResponseHeaders (header) import Node.Buffer (Buffer, fromString) import Node.Buffer (toString) as Buffer import Node.Encoding (Encoding(UTF8)) diff --git a/test/Test/HTTPure/HeadersSpec.purs b/test/Test/HTTPure/HeadersSpec.purs index 0bbc184..58e9215 100644 --- a/test/Test/HTTPure/HeadersSpec.purs +++ b/test/Test/HTTPure/HeadersSpec.purs @@ -2,10 +2,12 @@ module Test.HTTPure.HeadersSpec where import Prelude import Effect.Class (liftEffect) +import Data.Array.NonEmpty (singleton) import Data.Maybe (Maybe(Nothing, Just)) import Data.Tuple (Tuple(Tuple)) import Test.Spec (describe, it) -import HTTPure.Headers (header, headers, empty, read, write) +import HTTPure.RequestHeaders (read, empty) +import HTTPure.ResponseHeaders (header, headers, write) import HTTPure.Lookup ((!!)) import Test.HTTPure.TestHelpers as TestHelpers import Test.HTTPure.TestHelpers ((?=)) @@ -16,17 +18,17 @@ 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" + header "x-test" "test" !! "x-test" ?= Just (singleton "test") describe "when searching with uppercase" do it "is Just the string" do - header "x-test" "test" !! "X-Test" ?= Just "test" + header "x-test" "test" !! "X-Test" ?= Just (singleton "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" + header "X-Test" "test" !! "x-test" ?= Just (singleton "test") describe "when searching with uppercase" do it "is Just the string" do - header "X-Test" "test" !! "X-Test" ?= Just "test" + header "X-Test" "test" !! "X-Test" ?= Just (singleton "test") describe "when the string is not in the header set" do it "is Nothing" do ((empty !! "X-Test") :: Maybe String) ?= Nothing @@ -87,7 +89,7 @@ readSpec = 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 + TestHelpers.convertToResponseHeader (read request) ?= headers testHeader writeSpec :: TestHelpers.Test writeSpec = diff --git a/test/Test/HTTPure/RequestSpec.purs b/test/Test/HTTPure/RequestSpec.purs index b4aeaf9..e7e2ff5 100644 --- a/test/Test/HTTPure/RequestSpec.purs +++ b/test/Test/HTTPure/RequestSpec.purs @@ -5,11 +5,11 @@ import Data.Tuple (Tuple(Tuple)) import Foreign.Object (singleton) import Test.Spec (describe, it) import HTTPure.Body (toString) -import HTTPure.Headers (headers) +import HTTPure.ResponseHeaders (headers) import HTTPure.Method (Method(Post)) import HTTPure.Request (fromHTTPRequest, fullPath) import HTTPure.Version (Version(HTTP1_1)) -import Test.HTTPure.TestHelpers (Test, (?=), mockRequest) +import Test.HTTPure.TestHelpers (Test, (?=), convertToResponseHeader, mockRequest) fromHTTPRequestSpec :: Test fromHTTPRequestSpec = @@ -25,7 +25,7 @@ fromHTTPRequestSpec = mock.query ?= singleton "a" "b" it "contains the correct headers" do mock <- mockRequest' - mock.headers ?= headers mockHeaders + convertToResponseHeader mock.headers ?= headers mockHeaders it "contains the correct body" do mockBody <- mockRequest' >>= _.body >>> toString mockBody ?= "body" diff --git a/test/Test/HTTPure/ResponseSpec.purs b/test/Test/HTTPure/ResponseSpec.purs index 04ed340..fc7673b 100644 --- a/test/Test/HTTPure/ResponseSpec.purs +++ b/test/Test/HTTPure/ResponseSpec.purs @@ -9,7 +9,7 @@ import Node.HTTP (responseAsStream) import Node.Stream (writeString, end) import Test.Spec (describe, it) import HTTPure.Body (defaultHeaders) -import HTTPure.Headers (header) +import HTTPure.ResponseHeaders (header) import HTTPure.Response (send, response, response', emptyResponse, emptyResponse') import Test.HTTPure.TestHelpers ( Test diff --git a/test/Test/HTTPure/TestHelpers.purs b/test/Test/HTTPure/TestHelpers.purs index 486d4f0..1b4e2ab 100644 --- a/test/Test/HTTPure/TestHelpers.purs +++ b/test/Test/HTTPure/TestHelpers.purs @@ -1,39 +1,33 @@ module Test.HTTPure.TestHelpers where import Prelude -import Effect (Effect) -import Effect.Aff (Aff, makeAff, nonCanceler) -import Effect.Class (liftEffect) -import Effect.Ref (new, modify_, read) + import Data.Array (fromFoldable) as Array +import Data.Array.NonEmpty as NonEmptyArray import Data.Either (Either(Right)) +import Data.FoldableWithIndex (foldlWithIndex) import Data.List (List(Nil, Cons), reverse) +import Data.Map as Map import Data.Maybe (fromMaybe) import Data.Options ((:=)) import Data.String (toLower) +import Data.String.CaseInsensitive (CaseInsensitiveString(..)) import Data.Tuple (Tuple) -import Foreign.Object (fromFoldable) as Object +import Effect (Effect) +import Effect.Aff (Aff, makeAff, nonCanceler) +import Effect.Class (liftEffect) +import Effect.Ref (new, modify_, read) import Foreign.Object (Object, lookup) -import Node.Buffer (toString) as Buffer +import Foreign.Object as Object +import HTTPure.RequestHeaders (RequestHeaders(..)) as HTTPure +import HTTPure.ResponseHeaders (ResponseHeaders(..)) as HTTPure import Node.Buffer (Buffer, create, fromString, concat) +import Node.Buffer (toString) as Buffer import Node.Encoding (Encoding(UTF8)) -import Node.HTTP (Response) as HTTP import Node.HTTP (Request) +import Node.HTTP (Response) as HTTP +import Node.HTTP.Client (RequestHeaders(RequestHeaders), requestAsStream, protocol, method, hostname, port, path, headers, rejectUnauthorized, statusCode, responseHeaders, responseAsStream) import Node.HTTP.Client (Response, request) as HTTPClient -import Node.HTTP.Client - ( RequestHeaders(RequestHeaders) - , requestAsStream - , protocol - , method - , hostname - , port - , path - , headers - , rejectUnauthorized - , statusCode - , responseHeaders - , responseAsStream - ) import Node.Stream (Readable, write, end, onData, onEnd) import Test.Spec (Spec) import Test.Spec.Assertions (shouldEqual) @@ -237,3 +231,9 @@ getResponseHeader header = fromMaybe "" <<< lookup header <<< getResponseHeaders -- | Create a stream out of a string. foreign import stringToStream :: String -> Readable () + +convertToResponseHeader :: HTTPure.RequestHeaders -> HTTPure.ResponseHeaders +convertToResponseHeader (HTTPure.RequestHeaders requestHeaders) = + HTTPure.ResponseHeaders $ foldlWithIndex insertValue Map.empty requestHeaders + where + insertValue k o v = Map.insert (CaseInsensitiveString k) (NonEmptyArray.singleton v) o From edd268b817c10cedd3636ab35186ad87c2415681 Mon Sep 17 00:00:00 2001 From: sjpgarcia <91515796+sjpgarcia@users.noreply.github.com> Date: Fri, 7 Jan 2022 00:25:10 +0800 Subject: [PATCH 03/12] Document additional header constructors --- src/HTTPure/ResponseHeaders.purs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/HTTPure/ResponseHeaders.purs b/src/HTTPure/ResponseHeaders.purs index f1d2fc6..21f91af 100644 --- a/src/HTTPure/ResponseHeaders.purs +++ b/src/HTTPure/ResponseHeaders.purs @@ -70,6 +70,8 @@ headers = foldl insertField Map.empty >>> ResponseHeaders where insertField x (Tuple key value) = insert (CaseInsensitiveString key) (NonEmptyArray.singleton value) x +-- | Convert an `Array` of `Tuples` of `Strings` and `NonEmptyArray Strings` +-- | to a `ResponseHeaders` object. headers' :: Array (Tuple String (NonEmptyArray String)) -> ResponseHeaders headers' = foldl insertField Map.empty >>> ResponseHeaders where @@ -79,5 +81,6 @@ headers' = foldl insertField Map.empty >>> ResponseHeaders header :: String -> String -> ResponseHeaders header key = NonEmptyArray.singleton >>> singleton (CaseInsensitiveString key) >>> ResponseHeaders +-- | Create a header from a key-value pair. header' :: String -> NonEmptyArray String -> ResponseHeaders header' key = singleton (CaseInsensitiveString key) >>> ResponseHeaders From 3d4c989c1b54eaef0c6cc5739bbbe6f32e434b41 Mon Sep 17 00:00:00 2001 From: sjpgarcia <91515796+sjpgarcia@users.noreply.github.com> Date: Fri, 7 Jan 2022 00:46:30 +0800 Subject: [PATCH 04/12] Fix value intercalation for response headers --- src/HTTPure/ResponseHeaders.purs | 4 ++-- test/Test/HTTPure/HeadersSpec.purs | 6 ++++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/HTTPure/ResponseHeaders.purs b/src/HTTPure/ResponseHeaders.purs index 21f91af..cf2b89b 100644 --- a/src/HTTPure/ResponseHeaders.purs +++ b/src/HTTPure/ResponseHeaders.purs @@ -23,7 +23,7 @@ import Data.TraversableWithIndex (traverseWithIndex) import Data.Tuple (Tuple(Tuple)) import Effect (Effect) import HTTPure.Lookup (class Lookup, (!!)) -import Node.HTTP (Response, setHeader, setHeaders) +import Node.HTTP (Response, setHeader) -- | The `ResponseHeaders` type is just sugar for a `Map` of `Strings` -- | that represents the set of headers in an HTTP request or response. @@ -41,7 +41,7 @@ instance lookupResponseHeaders :: Lookup ResponseHeaders String (NonEmptyArray S instance showResponseHeaders :: Show ResponseHeaders where show (ResponseHeaders responseHeaders) = foldMapWithIndex showField responseHeaders <> "\n" where - showField key value = unwrap key <> ": " <> NonEmptyArray.intercalate " " value <> "\n" + showField key value = unwrap key <> ": " <> NonEmptyArray.intercalate "," value <> "\n" -- | Compare two `ResponseHeaders` objects by comparing the underlying -- | `Objects`. diff --git a/test/Test/HTTPure/HeadersSpec.purs b/test/Test/HTTPure/HeadersSpec.purs index 58e9215..f0cbaa2 100644 --- a/test/Test/HTTPure/HeadersSpec.purs +++ b/test/Test/HTTPure/HeadersSpec.purs @@ -2,12 +2,12 @@ module Test.HTTPure.HeadersSpec where import Prelude import Effect.Class (liftEffect) -import Data.Array.NonEmpty (singleton) +import Data.Array.NonEmpty (fromArray, singleton) import Data.Maybe (Maybe(Nothing, Just)) import Data.Tuple (Tuple(Tuple)) import Test.Spec (describe, it) import HTTPure.RequestHeaders (read, empty) -import HTTPure.ResponseHeaders (header, headers, write) +import HTTPure.ResponseHeaders (header, header', headers, write) import HTTPure.Lookup ((!!)) import Test.HTTPure.TestHelpers as TestHelpers import Test.HTTPure.TestHelpers ((?=)) @@ -112,6 +112,8 @@ headerSpec = describe "header" do it "creates a singleton Headers" do show (header "X-Test" "test") ?= "X-Test: test\n\n" + it "creates a multi-value Headers" do + show <<< header' "X-Test" <$> fromArray ["test1", "test2"] ?= Just "X-Test: test1,test2\n\n" headersFunctionSpec :: TestHelpers.Test headersFunctionSpec = From 0f82b0b2b590732f5d3ab4f190be6c45143065bd Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Thu, 13 Oct 2022 12:07:01 -0300 Subject: [PATCH 05/12] Use `Node.HTTP.setHeaders` in `HTTPure.ResponseHeaders.write` Now that `ResponseHeaders` supports multiple values per header, we can't just set the same header multiple times, but should, instead, use the `Node.HTTP.setHeaders` function. According to the [Node.js docs](https://nodejs.org/api/http.html#requestsetheadername-value), if we set a header that "[...] already exists in the to-be-sent headers, its value will be replaced." --- src/HTTPure/ResponseHeaders.purs | 5 ++--- test/Test/HTTPure/HeadersSpec.purs | 2 +- test/Test/HTTPure/ResponseSpec.purs | 2 +- test/Test/HTTPure/TestHelpers.purs | 6 +++--- 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/HTTPure/ResponseHeaders.purs b/src/HTTPure/ResponseHeaders.purs index c6ecf66..193d7ec 100644 --- a/src/HTTPure/ResponseHeaders.purs +++ b/src/HTTPure/ResponseHeaders.purs @@ -18,12 +18,11 @@ import Data.Map (Map, insert, singleton, union) import Data.Map (empty) as Map import Data.Newtype (class Newtype, unwrap) import Data.String.CaseInsensitive (CaseInsensitiveString(CaseInsensitiveString)) -import Data.Traversable (traverse) import Data.TraversableWithIndex (traverseWithIndex) import Data.Tuple (Tuple(Tuple)) import Effect (Effect) import HTTPure.Lookup (class Lookup, (!!)) -import Node.HTTP (Response, setHeader) +import Node.HTTP (Response, setHeaders) -- | The `ResponseHeaders` type is just sugar for a `Map` of `Strings` -- | that represents the set of headers in an HTTP request or response. @@ -57,7 +56,7 @@ instance semigroupResponseHeaders :: Semigroup ResponseHeaders where write :: Response -> ResponseHeaders -> Effect Unit write response (ResponseHeaders responseHeaders) = void $ traverseWithIndex writeField responseHeaders where - writeField key = traverse (setHeader response (unwrap key)) + writeField key = setHeaders response (unwrap key) <<< NonEmptyArray.toArray -- | Return a `ResponseHeaders` containing nothing. empty :: ResponseHeaders diff --git a/test/Test/HTTPure/HeadersSpec.purs b/test/Test/HTTPure/HeadersSpec.purs index 536b29d..41dc438 100644 --- a/test/Test/HTTPure/HeadersSpec.purs +++ b/test/Test/HTTPure/HeadersSpec.purs @@ -100,7 +100,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/HTTPure/ResponseSpec.purs b/test/Test/HTTPure/ResponseSpec.purs index bf31df6..df18534 100644 --- a/test/Test/HTTPure/ResponseSpec.purs +++ b/test/Test/HTTPure/ResponseSpec.purs @@ -39,7 +39,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 diff --git a/test/Test/HTTPure/TestHelpers.purs b/test/Test/HTTPure/TestHelpers.purs index a970628..8a7dd09 100644 --- a/test/Test/HTTPure/TestHelpers.purs +++ b/test/Test/HTTPure/TestHelpers.purs @@ -236,12 +236,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 () From 9967c99c388eda6f1d0bc15fa8e8edfd6a7e5715 Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Thu, 13 Oct 2022 12:11:13 -0300 Subject: [PATCH 06/12] Update docstring on `HTTPure.ResponseHeaders.header'` --- src/HTTPure/ResponseHeaders.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/HTTPure/ResponseHeaders.purs b/src/HTTPure/ResponseHeaders.purs index 193d7ec..3068a60 100644 --- a/src/HTTPure/ResponseHeaders.purs +++ b/src/HTTPure/ResponseHeaders.purs @@ -80,6 +80,6 @@ headers' = foldl insertField Map.empty >>> ResponseHeaders header :: String -> String -> ResponseHeaders header key = NonEmptyArray.singleton >>> singleton (CaseInsensitiveString key) >>> ResponseHeaders --- | Create a header from a key-value pair. +-- | Create a header from a key-values pair. header' :: String -> NonEmptyArray String -> ResponseHeaders header' key = singleton (CaseInsensitiveString key) >>> ResponseHeaders From ff7b3c445a4da5ee26473afff52014734514f652 Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Fri, 14 Oct 2022 11:09:59 -0300 Subject: [PATCH 07/12] Split HeadersSpec into RequestHeadersSpec and ResponseHeadersSpec --- test/Test/HTTPure/RequestHeadersSpec.purs | 117 ++++++++++++++++++ ...dersSpec.purs => ResponseHeadersSpec.purs} | 29 ++--- test/Test/Main.purs | 6 +- 3 files changed, 128 insertions(+), 24 deletions(-) create mode 100644 test/Test/HTTPure/RequestHeadersSpec.purs rename test/Test/HTTPure/{HeadersSpec.purs => ResponseHeadersSpec.purs} (82%) diff --git a/test/Test/HTTPure/RequestHeadersSpec.purs b/test/Test/HTTPure/RequestHeadersSpec.purs new file mode 100644 index 0000000..27da08d --- /dev/null +++ b/test/Test/HTTPure/RequestHeadersSpec.purs @@ -0,0 +1,117 @@ +module Test.HTTPure.RequestHeadersSpec where + +import Prelude + +import Data.Foldable (class Foldable) +import Data.Maybe (Maybe(Nothing, Just)) +import Data.Tuple (Tuple(Tuple)) +import Foreign.Object as Foreign.Object +import HTTPure.Lookup ((!!)) +import HTTPure.RequestHeaders (RequestHeaders(..), empty, read) +import HTTPure.ResponseHeaders as HTTPure.ResponseHeaders +import Test.HTTPure.TestHelpers ((?=)) +import Test.HTTPure.TestHelpers as TestHelpers +import Test.Spec (describe, it) + +lookupSpec :: TestHelpers.Test +lookupSpec = + describe "lookup" do + 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" + describe "when searching with uppercase" do + it "is Just the string" do + header "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" + describe "when searching with uppercase" do + it "is Just the string" do + header "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 + +showSpec :: TestHelpers.Test +showSpec = + describe "show" do + it "is a string representing the headers in HTTP format" do + let mock = header "Test1" "1" <> header "Test2" "2" + show mock ?= "Test1: 1\nTest2: 2\n\n" + +eqSpec :: TestHelpers.Test +eqSpec = + describe "eq" do + describe "when the two Headers contain the same keys and values" do + it "is true" do + header "Test1" "test1" == header "Test1" "test1" ?= true + describe "when the two Headers contain different keys and values" do + it "is false" do + header "Test1" "test1" == header "Test2" "test2" ?= false + describe "when the two Headers contain only different values" do + it "is false" do + header "Test1" "test1" == header "Test1" "test2" ?= false + describe "when the one Headers contains additional keys and values" do + it "is false" do + let mock = header "Test1" "1" <> header "Test2" "2" + header "Test1" "1" == mock ?= false + +appendSpec :: TestHelpers.Test +appendSpec = + describe "append" do + describe "when there are multiple keys" do + it "appends the headers correctly" do + let + mock1 = header "Test1" "1" <> header "Test2" "2" + mock2 = header "Test3" "3" <> header "Test4" "4" + mock3 = + headers + [ Tuple "Test1" "1" + , Tuple "Test2" "2" + , Tuple "Test3" "3" + , Tuple "Test4" "4" + ] + mock1 <> mock2 ?= mock3 + describe "when there is a duplicated key" do + it "uses the last appended value" do + let mock = header "Test" "foo" <> header "Test" "bar" + mock ?= header "Test" "bar" + +readSpec :: TestHelpers.Test +readSpec = + describe "read" do + describe "with no headers" do + it "is an empty Map" do + request <- TestHelpers.mockRequest "" "" "" "" [] + read request ?= empty + 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 + TestHelpers.convertToResponseHeader (read request) ?= HTTPure.ResponseHeaders.headers testHeader + +emptySpec :: TestHelpers.Test +emptySpec = + describe "empty" do + it "is an empty Map in an empty Headers" do + show empty ?= "\n" + +requestHeadersSpec :: TestHelpers.Test +requestHeadersSpec = + describe "RequestHeaders" do + lookupSpec + showSpec + eqSpec + appendSpec + readSpec + emptySpec + +-- | Helper function for creating a singleton `RequestHeaders`. +header :: String -> String -> RequestHeaders +header name = RequestHeaders <<< Foreign.Object.singleton name + +-- | Helper function for creating a `RequestHeaders` from a `Foldable` container. +headers :: forall f. Foldable f => f (Tuple String String) -> RequestHeaders +headers = RequestHeaders <<< Foreign.Object.fromFoldable diff --git a/test/Test/HTTPure/HeadersSpec.purs b/test/Test/HTTPure/ResponseHeadersSpec.purs similarity index 82% rename from test/Test/HTTPure/HeadersSpec.purs rename to test/Test/HTTPure/ResponseHeadersSpec.purs index 41dc438..b2f521e 100644 --- a/test/Test/HTTPure/HeadersSpec.purs +++ b/test/Test/HTTPure/ResponseHeadersSpec.purs @@ -1,14 +1,13 @@ -module Test.HTTPure.HeadersSpec where +module Test.HTTPure.ResponseHeadersSpec where import Prelude -import Data.Array.NonEmpty (fromArray, singleton) +import Data.Array.NonEmpty (NonEmptyArray, fromArray, singleton) import Data.Maybe (Maybe(Nothing, Just)) import Data.Tuple (Tuple(Tuple)) import Effect.Class (liftEffect) import HTTPure.Lookup ((!!)) -import HTTPure.RequestHeaders (empty, read) -import HTTPure.ResponseHeaders (header, header', headers, write) +import HTTPure.ResponseHeaders (empty, header, header', headers, write) import Test.HTTPure.TestHelpers ((?=)) import Test.HTTPure.TestHelpers as TestHelpers import Test.Spec (describe, it) @@ -32,7 +31,7 @@ lookupSpec = header "X-Test" "test" !! "X-Test" ?= Just (singleton "test") describe "when the string is not in the header set" do it "is Nothing" do - ((empty !! "X-Test") :: Maybe String) ?= Nothing + ((empty !! "X-Test") :: Maybe (NonEmptyArray String)) ?= Nothing showSpec :: TestHelpers.Test showSpec = @@ -79,19 +78,6 @@ appendSpec = let mock = header "Test" "foo" <> header "Test" "bar" mock ?= header "Test" "bar" -readSpec :: TestHelpers.Test -readSpec = - describe "read" do - describe "with no headers" do - it "is an empty Map" do - request <- TestHelpers.mockRequest "" "" "" "" [] - read request ?= empty - 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 - TestHelpers.convertToResponseHeader (read request) ?= headers testHeader - writeSpec :: TestHelpers.Test writeSpec = describe "write" do @@ -128,14 +114,13 @@ headersFunctionSpec = ] test ?= expected -headersSpec :: TestHelpers.Test -headersSpec = - describe "Headers" do +responseHeadersSpec :: TestHelpers.Test +responseHeadersSpec = + describe "ResponseHeaders" do lookupSpec showSpec eqSpec appendSpec - readSpec writeSpec emptySpec headerSpec diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 187d15a..042ddc5 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -4,13 +4,14 @@ import Prelude import Effect.Aff (launchAff_) import Test.HTTPure.BodySpec (bodySpec) -import Test.HTTPure.HeadersSpec (headersSpec) import Test.HTTPure.IntegrationSpec (integrationSpec) import Test.HTTPure.LookupSpec (lookupSpec) import Test.HTTPure.MethodSpec (methodSpec) import Test.HTTPure.PathSpec (pathSpec) import Test.HTTPure.QuerySpec (querySpec) +import Test.HTTPure.RequestHeadersSpec (requestHeadersSpec) import Test.HTTPure.RequestSpec (requestSpec) +import Test.HTTPure.ResponseHeadersSpec (responseHeadersSpec) import Test.HTTPure.ResponseSpec (responseSpec) import Test.HTTPure.ServerSpec (serverSpec) import Test.HTTPure.StatusSpec (statusSpec) @@ -24,12 +25,13 @@ import Test.Spec.Runner (runSpec) main :: TestSuite main = launchAff_ $ runSpec [ specReporter ] $ describe "HTTPure" do bodySpec - headersSpec lookupSpec methodSpec pathSpec querySpec + requestHeadersSpec requestSpec + responseHeadersSpec responseSpec serverSpec statusSpec From e48524eaae8c75cd39c1021f91c29c01eaceb5ca Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Fri, 14 Oct 2022 11:11:30 -0300 Subject: [PATCH 08/12] Remove re-export of `ResponseHeaders.empty` Now that we differentiate between Request and Response headers, it doesn't make sense to provide the `ResponseHeaders.empty` value as a re-export in `HTTPure`, as it could be unclear which type of headers we're talking about. --- src/HTTPure.purs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/HTTPure.purs b/src/HTTPure.purs index 08d5fa9..a0bcd1d 100644 --- a/src/HTTPure.purs +++ b/src/HTTPure.purs @@ -152,7 +152,7 @@ import HTTPure.Response , variantAlsoNegotiates , variantAlsoNegotiates' ) -import HTTPure.ResponseHeaders (ResponseHeaders, empty, header, headers) +import HTTPure.ResponseHeaders (ResponseHeaders, header, headers) import HTTPure.Server ( ServerM , serve From 06514d99c790f61c069441760c6b81283bf21160 Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Fri, 14 Oct 2022 11:12:54 -0300 Subject: [PATCH 09/12] Newtype-derive `Eq` instance for `RequestHeaders` and `ResponseHeaders` --- src/HTTPure/RequestHeaders.purs | 3 +-- src/HTTPure/ResponseHeaders.purs | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/HTTPure/RequestHeaders.purs b/src/HTTPure/RequestHeaders.purs index 324f236..683f90b 100644 --- a/src/HTTPure/RequestHeaders.purs +++ b/src/HTTPure/RequestHeaders.purs @@ -33,8 +33,7 @@ instance showRequestHeaders :: Show RequestHeaders where showField key value = key <> ": " <> value <> "\n" -- | Compare two `RequestHeaders` objects by comparing the underlying `Objects`. -instance eqRequestHeaders :: Eq RequestHeaders where - eq (RequestHeaders a) (RequestHeaders b) = eq a b +derive instance eqRequestHeaders :: Eq RequestHeaders -- | Allow one `RequestHeaders` objects to be appended to another. instance semigroupRequestHeaders :: Semigroup RequestHeaders where diff --git a/src/HTTPure/ResponseHeaders.purs b/src/HTTPure/ResponseHeaders.purs index 3068a60..98e572b 100644 --- a/src/HTTPure/ResponseHeaders.purs +++ b/src/HTTPure/ResponseHeaders.purs @@ -44,8 +44,7 @@ instance showResponseHeaders :: Show ResponseHeaders where -- | Compare two `ResponseHeaders` objects by comparing the underlying -- | `Objects`. -instance eqResponseHeaders :: Eq ResponseHeaders where - eq (ResponseHeaders a) (ResponseHeaders b) = eq a b +derive newtype instance eqResponseHeaders :: Eq ResponseHeaders -- | Allow one `ResponseHeaders` objects to be appended to another. instance semigroupResponseHeaders :: Semigroup ResponseHeaders where From 6603688c4d169a3ff0ea9d94641e049af2e8f39a Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Fri, 14 Oct 2022 11:13:26 -0300 Subject: [PATCH 10/12] Use `show` for debugging and define `toString` for String formatting --- src/HTTPure/RequestHeaders.purs | 18 +++++++++++++----- src/HTTPure/ResponseHeaders.purs | 18 +++++++++++++----- test/Test/HTTPure/RequestHeadersSpec.purs | 14 +++++++------- test/Test/HTTPure/ResponseHeadersSpec.purs | 18 +++++++++--------- 4 files changed, 42 insertions(+), 26 deletions(-) diff --git a/src/HTTPure/RequestHeaders.purs b/src/HTTPure/RequestHeaders.purs index 683f90b..c326031 100644 --- a/src/HTTPure/RequestHeaders.purs +++ b/src/HTTPure/RequestHeaders.purs @@ -2,12 +2,15 @@ module HTTPure.RequestHeaders ( RequestHeaders(..) , empty , read + , toString ) where import Prelude import Data.FoldableWithIndex (foldMapWithIndex) +import Data.Generic.Rep (class Generic) import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) import Data.String as String import Foreign.Object (Object, union) import Foreign.Object as Object @@ -20,17 +23,15 @@ newtype RequestHeaders = RequestHeaders (Object String) derive instance newtypeRequestHeaders :: Newtype RequestHeaders _ +derive instance genericRequestHeaders :: Generic RequestHeaders _ + -- | Given a string. return a `Maybe` containing the value of the matching -- | request header, if there is any. instance lookupRequestHeaders :: Lookup RequestHeaders String String where lookup (RequestHeaders headers') key = headers' !! (String.toLower key) --- | Allow a `RequestHeaders` to be represented as a string. This string is --- | formatted in HTTP headers format. instance showRequestHeaders :: Show RequestHeaders where - show (RequestHeaders headers') = foldMapWithIndex showField headers' <> "\n" - where - showField key value = key <> ": " <> value <> "\n" + show = genericShow -- | Compare two `RequestHeaders` objects by comparing the underlying `Objects`. derive instance eqRequestHeaders :: Eq RequestHeaders @@ -45,3 +46,10 @@ read = requestHeaders >>> RequestHeaders empty :: RequestHeaders empty = RequestHeaders Object.empty + +-- | Allow a `RequestHeaders` to be represented as a string. This string is +-- | formatted in HTTP headers format. +toString :: RequestHeaders -> String +toString (RequestHeaders headers') = foldMapWithIndex showField headers' <> "\n" + where + showField key value = key <> ": " <> value <> "\n" diff --git a/src/HTTPure/ResponseHeaders.purs b/src/HTTPure/ResponseHeaders.purs index 98e572b..7cb391a 100644 --- a/src/HTTPure/ResponseHeaders.purs +++ b/src/HTTPure/ResponseHeaders.purs @@ -5,6 +5,7 @@ module HTTPure.ResponseHeaders , headers' , header , header' + , toString , write ) where @@ -14,9 +15,11 @@ import Data.Array.NonEmpty (NonEmptyArray) import Data.Array.NonEmpty as NonEmptyArray import Data.Foldable (foldl) import Data.FoldableWithIndex (foldMapWithIndex) +import Data.Generic.Rep (class Generic) import Data.Map (Map, insert, singleton, union) import Data.Map (empty) as Map import Data.Newtype (class Newtype, unwrap) +import Data.Show.Generic (genericShow) import Data.String.CaseInsensitive (CaseInsensitiveString(CaseInsensitiveString)) import Data.TraversableWithIndex (traverseWithIndex) import Data.Tuple (Tuple(Tuple)) @@ -30,17 +33,15 @@ newtype ResponseHeaders = ResponseHeaders (Map CaseInsensitiveString (NonEmptyAr derive instance newtypeResponseHeaders :: Newtype ResponseHeaders _ +derive instance genericResponseHeaders :: Generic ResponseHeaders _ + -- | Given a string, return a `Maybe` containing the value of the matching -- | header, if there is any. instance lookupResponseHeaders :: Lookup ResponseHeaders String (NonEmptyArray String) where lookup (ResponseHeaders responseHeaders) key = responseHeaders !! key --- | Allow a `ResponseHeaders` to be represented as a string. This string --- | is formatted in HTTP headers format. instance showResponseHeaders :: Show ResponseHeaders where - show (ResponseHeaders responseHeaders) = foldMapWithIndex showField responseHeaders <> "\n" - where - showField key value = unwrap key <> ": " <> NonEmptyArray.intercalate "," value <> "\n" + show = genericShow -- | Compare two `ResponseHeaders` objects by comparing the underlying -- | `Objects`. @@ -82,3 +83,10 @@ header key = NonEmptyArray.singleton >>> singleton (CaseInsensitiveString key) > -- | Create a header from a key-values pair. header' :: String -> NonEmptyArray String -> ResponseHeaders header' key = singleton (CaseInsensitiveString key) >>> ResponseHeaders + +-- | Allow a `ResponseHeaders` to be represented as a string. This string +-- | is formatted in HTTP headers format. +toString :: ResponseHeaders -> String +toString (ResponseHeaders responseHeaders) = foldMapWithIndex showField responseHeaders <> "\n" + where + showField key value = unwrap key <> ": " <> NonEmptyArray.intercalate "," value <> "\n" diff --git a/test/Test/HTTPure/RequestHeadersSpec.purs b/test/Test/HTTPure/RequestHeadersSpec.purs index 27da08d..bbbb9f7 100644 --- a/test/Test/HTTPure/RequestHeadersSpec.purs +++ b/test/Test/HTTPure/RequestHeadersSpec.purs @@ -7,7 +7,7 @@ import Data.Maybe (Maybe(Nothing, Just)) import Data.Tuple (Tuple(Tuple)) import Foreign.Object as Foreign.Object import HTTPure.Lookup ((!!)) -import HTTPure.RequestHeaders (RequestHeaders(..), empty, read) +import HTTPure.RequestHeaders (RequestHeaders(..), empty, read, toString) import HTTPure.ResponseHeaders as HTTPure.ResponseHeaders import Test.HTTPure.TestHelpers ((?=)) import Test.HTTPure.TestHelpers as TestHelpers @@ -34,12 +34,12 @@ lookupSpec = it "is Nothing" do ((empty !! "X-Test") :: Maybe String) ?= Nothing -showSpec :: TestHelpers.Test -showSpec = - describe "show" do +toStringSpec :: TestHelpers.Test +toStringSpec = + describe "toString" do it "is a string representing the headers in HTTP format" do let mock = header "Test1" "1" <> header "Test2" "2" - show mock ?= "Test1: 1\nTest2: 2\n\n" + toString mock ?= "Test1: 1\nTest2: 2\n\n" eqSpec :: TestHelpers.Test eqSpec = @@ -96,13 +96,13 @@ emptySpec :: TestHelpers.Test emptySpec = describe "empty" do it "is an empty Map in an empty Headers" do - show empty ?= "\n" + toString empty ?= "\n" requestHeadersSpec :: TestHelpers.Test requestHeadersSpec = describe "RequestHeaders" do lookupSpec - showSpec + toStringSpec eqSpec appendSpec readSpec diff --git a/test/Test/HTTPure/ResponseHeadersSpec.purs b/test/Test/HTTPure/ResponseHeadersSpec.purs index b2f521e..0a33502 100644 --- a/test/Test/HTTPure/ResponseHeadersSpec.purs +++ b/test/Test/HTTPure/ResponseHeadersSpec.purs @@ -7,7 +7,7 @@ import Data.Maybe (Maybe(Nothing, Just)) import Data.Tuple (Tuple(Tuple)) import Effect.Class (liftEffect) import HTTPure.Lookup ((!!)) -import HTTPure.ResponseHeaders (empty, header, header', headers, write) +import HTTPure.ResponseHeaders (empty, header, header', headers, toString, write) import Test.HTTPure.TestHelpers ((?=)) import Test.HTTPure.TestHelpers as TestHelpers import Test.Spec (describe, it) @@ -33,12 +33,12 @@ lookupSpec = it "is Nothing" do ((empty !! "X-Test") :: Maybe (NonEmptyArray String)) ?= Nothing -showSpec :: TestHelpers.Test -showSpec = - describe "show" do +toStringSpec :: TestHelpers.Test +toStringSpec = + describe "toString" do it "is a string representing the headers in HTTP format" do let mock = header "Test1" "1" <> header "Test2" "2" - show mock ?= "Test1: 1\nTest2: 2\n\n" + toString mock ?= "Test1: 1\nTest2: 2\n\n" eqSpec :: TestHelpers.Test eqSpec = @@ -92,15 +92,15 @@ emptySpec :: TestHelpers.Test emptySpec = describe "empty" do it "is an empty Map in an empty Headers" do - show empty ?= "\n" + toString empty ?= "\n" headerSpec :: TestHelpers.Test headerSpec = describe "header" do it "creates a singleton Headers" do - show (header "X-Test" "test") ?= "X-Test: test\n\n" + toString (header "X-Test" "test") ?= "X-Test: test\n\n" it "creates a multi-value Headers" do - show <<< header' "X-Test" <$> fromArray [ "test1", "test2" ] ?= Just "X-Test: test1,test2\n\n" + toString <<< header' "X-Test" <$> fromArray [ "test1", "test2" ] ?= Just "X-Test: test1,test2\n\n" headersFunctionSpec :: TestHelpers.Test headersFunctionSpec = @@ -118,7 +118,7 @@ responseHeadersSpec :: TestHelpers.Test responseHeadersSpec = describe "ResponseHeaders" do lookupSpec - showSpec + toStringSpec eqSpec appendSpec writeSpec From 4975d1017413dd9ccfa4d171da009df2ca73f9b6 Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Fri, 14 Oct 2022 11:25:25 -0300 Subject: [PATCH 11/12] Ignore the case of Request header names --- src/HTTPure/RequestHeaders.purs | 22 +++++++++++++++------- test/Test/HTTPure/RequestHeadersSpec.purs | 10 ++++++---- test/Test/HTTPure/TestHelpers.purs | 3 +-- 3 files changed, 22 insertions(+), 13 deletions(-) diff --git a/src/HTTPure/RequestHeaders.purs b/src/HTTPure/RequestHeaders.purs index c326031..e827d21 100644 --- a/src/HTTPure/RequestHeaders.purs +++ b/src/HTTPure/RequestHeaders.purs @@ -7,19 +7,22 @@ module HTTPure.RequestHeaders import Prelude +import Data.Bifunctor (lmap) import Data.FoldableWithIndex (foldMapWithIndex) import Data.Generic.Rep (class Generic) -import Data.Newtype (class Newtype) +import Data.Map (Map) +import Data.Map as Data.Map +import Data.Newtype (class Newtype, un) import Data.Show.Generic (genericShow) import Data.String as String -import Foreign.Object (Object, union) +import Data.String.CaseInsensitive (CaseInsensitiveString(..)) import Foreign.Object as Object import HTTPure.Lookup (class Lookup, (!!)) import Node.HTTP (Request, requestHeaders) -- | The `RequestHeaders` type is just sugar for a `Object` of `Strings` -- | that represents the set of headers in an HTTP request. -newtype RequestHeaders = RequestHeaders (Object String) +newtype RequestHeaders = RequestHeaders (Map CaseInsensitiveString String) derive instance newtypeRequestHeaders :: Newtype RequestHeaders _ @@ -38,18 +41,23 @@ derive instance eqRequestHeaders :: Eq RequestHeaders -- | Allow one `RequestHeaders` objects to be appended to another. instance semigroupRequestHeaders :: Semigroup RequestHeaders where - append (RequestHeaders a) (RequestHeaders b) = RequestHeaders $ union b a + append (RequestHeaders a) (RequestHeaders b) = RequestHeaders $ Data.Map.union b a -- | Get the request headers out of a HTTP `Request` object. read :: Request -> RequestHeaders -read = requestHeaders >>> RequestHeaders +read = + RequestHeaders + <<< Data.Map.fromFoldable + <<< map (lmap CaseInsensitiveString) + <<< (Object.toUnfoldable :: _ -> Array _) + <<< requestHeaders empty :: RequestHeaders -empty = RequestHeaders Object.empty +empty = RequestHeaders Data.Map.empty -- | Allow a `RequestHeaders` to be represented as a string. This string is -- | formatted in HTTP headers format. toString :: RequestHeaders -> String toString (RequestHeaders headers') = foldMapWithIndex showField headers' <> "\n" where - showField key value = key <> ": " <> value <> "\n" + showField key value = un CaseInsensitiveString key <> ": " <> value <> "\n" diff --git a/test/Test/HTTPure/RequestHeadersSpec.purs b/test/Test/HTTPure/RequestHeadersSpec.purs index bbbb9f7..b29db88 100644 --- a/test/Test/HTTPure/RequestHeadersSpec.purs +++ b/test/Test/HTTPure/RequestHeadersSpec.purs @@ -2,10 +2,12 @@ module Test.HTTPure.RequestHeadersSpec where import Prelude +import Data.Bifunctor (lmap) import Data.Foldable (class Foldable) import Data.Maybe (Maybe(Nothing, Just)) import Data.Tuple (Tuple(Tuple)) -import Foreign.Object as Foreign.Object +import Data.Map as Data.Map +import Data.String.CaseInsensitive (CaseInsensitiveString(..)) import HTTPure.Lookup ((!!)) import HTTPure.RequestHeaders (RequestHeaders(..), empty, read, toString) import HTTPure.ResponseHeaders as HTTPure.ResponseHeaders @@ -110,8 +112,8 @@ requestHeadersSpec = -- | Helper function for creating a singleton `RequestHeaders`. header :: String -> String -> RequestHeaders -header name = RequestHeaders <<< Foreign.Object.singleton name +header name = RequestHeaders <<< Data.Map.singleton (CaseInsensitiveString name) -- | Helper function for creating a `RequestHeaders` from a `Foldable` container. -headers :: forall f. Foldable f => f (Tuple String String) -> RequestHeaders -headers = RequestHeaders <<< Foreign.Object.fromFoldable +headers :: forall f. Functor f => Foldable f => f (Tuple String String) -> RequestHeaders +headers = RequestHeaders <<< Data.Map.fromFoldable <<< map (lmap CaseInsensitiveString) diff --git a/test/Test/HTTPure/TestHelpers.purs b/test/Test/HTTPure/TestHelpers.purs index 8a7dd09..c2313ec 100644 --- a/test/Test/HTTPure/TestHelpers.purs +++ b/test/Test/HTTPure/TestHelpers.purs @@ -11,7 +11,6 @@ import Data.Map as Map import Data.Maybe (fromMaybe) import Data.Options ((:=)) import Data.String (toLower) -import Data.String.CaseInsensitive (CaseInsensitiveString(..)) import Data.Tuple (Tuple) import Effect (Effect) import Effect.Aff (Aff, makeAff, nonCanceler) @@ -250,4 +249,4 @@ convertToResponseHeader :: HTTPure.RequestHeaders -> HTTPure.ResponseHeaders convertToResponseHeader (HTTPure.RequestHeaders requestHeaders) = HTTPure.ResponseHeaders $ foldlWithIndex insertValue Map.empty requestHeaders where - insertValue k o v = Map.insert (CaseInsensitiveString k) (NonEmptyArray.singleton v) o + insertValue k o v = Map.insert k (NonEmptyArray.singleton v) o From 79ed5f8ba331844cee41e8af45335f3cf3d52f52 Mon Sep 17 00:00:00 2001 From: Arthur Xavier Date: Fri, 14 Oct 2022 14:01:16 -0300 Subject: [PATCH 12/12] Fix examples --- docs/Examples/BinaryResponse/Main.purs | 3 ++- docs/Examples/Headers/Main.purs | 3 ++- docs/Examples/Middleware/Main.purs | 3 ++- src/HTTPure.purs | 2 +- src/HTTPure/RequestHeaders.purs | 15 +++++++++++++++ 5 files changed, 22 insertions(+), 4 deletions(-) diff --git a/docs/Examples/BinaryResponse/Main.purs b/docs/Examples/BinaryResponse/Main.purs index 0bef572..7b29800 100644 --- a/docs/Examples/BinaryResponse/Main.purs +++ b/docs/Examples/BinaryResponse/Main.purs @@ -3,7 +3,8 @@ module Examples.BinaryResponse.Main where import Prelude import Effect.Console (log) -import HTTPure (Request, ResponseHeaders, ResponseM, ServerM, header, ok', serve) +import HTTPure (Request, ResponseM, ServerM, ok', serve) +import HTTPure.ResponseHeaders (ResponseHeaders, header) import Node.FS.Aff (readFile) -- | The path to the file containing the response to send diff --git a/docs/Examples/Headers/Main.purs b/docs/Examples/Headers/Main.purs index d7d4d36..a684aaf 100644 --- a/docs/Examples/Headers/Main.purs +++ b/docs/Examples/Headers/Main.purs @@ -3,7 +3,8 @@ module Examples.Headers.Main where import Prelude import Effect.Console (log) -import HTTPure (Request, ResponseHeaders, ResponseM, ServerM, header, ok', serve, (!@)) +import HTTPure (Request, ResponseM, ServerM, ok', serve, (!@)) +import HTTPure.ResponseHeaders (ResponseHeaders, header) -- | The headers that will be included in every response. responseHeaders :: ResponseHeaders diff --git a/docs/Examples/Middleware/Main.purs b/docs/Examples/Middleware/Main.purs index e506ba2..3d00f04 100644 --- a/docs/Examples/Middleware/Main.purs +++ b/docs/Examples/Middleware/Main.purs @@ -4,7 +4,8 @@ import Prelude import Effect.Class (liftEffect) import Effect.Console (log) -import HTTPure (Request, ResponseM, ServerM, fullPath, header, ok, ok', serve) +import HTTPure (Request, ResponseM, ServerM, fullPath, ok, ok', serve) +import HTTPure.ResponseHeaders (header) -- | A middleware that logs at the beginning and end of each request loggingMiddleware :: diff --git a/src/HTTPure.purs b/src/HTTPure.purs index a0bcd1d..8201df4 100644 --- a/src/HTTPure.purs +++ b/src/HTTPure.purs @@ -152,7 +152,7 @@ import HTTPure.Response , variantAlsoNegotiates , variantAlsoNegotiates' ) -import HTTPure.ResponseHeaders (ResponseHeaders, header, headers) +import HTTPure.ResponseHeaders (ResponseHeaders, write) import HTTPure.Server ( ServerM , serve diff --git a/src/HTTPure/RequestHeaders.purs b/src/HTTPure/RequestHeaders.purs index e827d21..52cfdc1 100644 --- a/src/HTTPure/RequestHeaders.purs +++ b/src/HTTPure/RequestHeaders.purs @@ -1,6 +1,8 @@ module HTTPure.RequestHeaders ( RequestHeaders(..) , empty + , header + , headers , read , toString ) where @@ -8,6 +10,7 @@ module HTTPure.RequestHeaders import Prelude import Data.Bifunctor (lmap) +import Data.Foldable (foldl) import Data.FoldableWithIndex (foldMapWithIndex) import Data.Generic.Rep (class Generic) import Data.Map (Map) @@ -16,6 +19,7 @@ import Data.Newtype (class Newtype, un) import Data.Show.Generic (genericShow) import Data.String as String import Data.String.CaseInsensitive (CaseInsensitiveString(..)) +import Data.Tuple (Tuple(..)) import Foreign.Object as Object import HTTPure.Lookup (class Lookup, (!!)) import Node.HTTP (Request, requestHeaders) @@ -43,6 +47,17 @@ derive instance eqRequestHeaders :: Eq RequestHeaders instance semigroupRequestHeaders :: Semigroup RequestHeaders where append (RequestHeaders a) (RequestHeaders b) = RequestHeaders $ Data.Map.union b a +-- | Create a singleton header from a key-value pair. +header :: String -> String -> RequestHeaders +header key = Data.Map.singleton (CaseInsensitiveString key) >>> RequestHeaders + +-- | Convert an `Array` of `Tuples` of 2 `Strings` to a `RequestHeaders` +-- | object. +headers :: Array (Tuple String String) -> RequestHeaders +headers = foldl insertField Data.Map.empty >>> RequestHeaders + where + insertField x (Tuple key value) = Data.Map.insert (CaseInsensitiveString key) value x + -- | Get the request headers out of a HTTP `Request` object. read :: Request -> RequestHeaders read =