From 429ce17af378c00a339ff92291fd4e32385a1858 Mon Sep 17 00:00:00 2001 From: Connor Prussin Date: Mon, 27 Aug 2018 12:21:20 -0700 Subject: [PATCH 1/6] Chunked responses --- docs/Examples/{Image => Binary}/Main.purs | 4 +- docs/Examples/Binary/Readme.md | 10 ++++ docs/Examples/{Image => Binary}/circle.png | Bin docs/Examples/Chunked/Main.js | 16 +++++++ docs/Examples/Chunked/Main.purs | 39 +++++++++++++++ docs/Examples/Chunked/Readme.md | 10 ++++ src/HTTPure.purs | 4 +- src/HTTPure/Body.purs | 50 +++++++++++++------ src/HTTPure/Response.purs | 20 ++++---- src/HTTPure/Server.purs | 5 +- test/Test/HTTPure/BodySpec.purs | 44 +++++++++++------ test/Test/HTTPure/IntegrationSpec.purs | 53 +++++++++++++-------- test/Test/HTTPure/ResponseSpec.purs | 37 +++++--------- test/Test/HTTPure/TestHelpers.js | 11 +++++ test/Test/HTTPure/TestHelpers.purs | 3 ++ 15 files changed, 214 insertions(+), 92 deletions(-) rename docs/Examples/{Image => Binary}/Main.purs (93%) create mode 100644 docs/Examples/Binary/Readme.md rename docs/Examples/{Image => Binary}/circle.png (100%) create mode 100644 docs/Examples/Chunked/Main.js create mode 100644 docs/Examples/Chunked/Main.purs create mode 100644 docs/Examples/Chunked/Readme.md diff --git a/docs/Examples/Image/Main.purs b/docs/Examples/Binary/Main.purs similarity index 93% rename from docs/Examples/Image/Main.purs rename to docs/Examples/Binary/Main.purs index 2b96fe9..ef6ca4d 100644 --- a/docs/Examples/Image/Main.purs +++ b/docs/Examples/Binary/Main.purs @@ -1,4 +1,4 @@ -module Examples.Image.Main where +module Examples.Binary.Main where import Prelude @@ -16,7 +16,7 @@ portS = show port -- | The path to the file containing the response to send filePath :: String -filePath = "./docs/Examples/Image/circle.png" +filePath = "./docs/Examples/Binary/circle.png" -- | Respond with image data when run image :: HTTPure.Request -> HTTPure.ResponseM diff --git a/docs/Examples/Binary/Readme.md b/docs/Examples/Binary/Readme.md new file mode 100644 index 0000000..01b164b --- /dev/null +++ b/docs/Examples/Binary/Readme.md @@ -0,0 +1,10 @@ +# Binary Example + +This is a basic example of sending binary data. It serves an image file as +binary data on any URL. + +To run the server, run: + +```bash +make example EXAMPLE=Binary +``` diff --git a/docs/Examples/Image/circle.png b/docs/Examples/Binary/circle.png similarity index 100% rename from docs/Examples/Image/circle.png rename to docs/Examples/Binary/circle.png diff --git a/docs/Examples/Chunked/Main.js b/docs/Examples/Chunked/Main.js new file mode 100644 index 0000000..80c98cd --- /dev/null +++ b/docs/Examples/Chunked/Main.js @@ -0,0 +1,16 @@ +"use strict"; + +exports.stagger = function (start) { + return function (end) { + return function (delay) { + var stream = new require('stream').Readable(); + stream._read = function () {}; + stream.push(start); + setTimeout(function () { + stream.push(end); + stream.push(null); + }, delay); + return stream; + }; + }; +}; diff --git a/docs/Examples/Chunked/Main.purs b/docs/Examples/Chunked/Main.purs new file mode 100644 index 0000000..c763c97 --- /dev/null +++ b/docs/Examples/Chunked/Main.purs @@ -0,0 +1,39 @@ +module Examples.Chunked.Main where + +import Prelude + +import Effect.Console as Console +import HTTPure as HTTPure +import Node.Stream as Stream + +-- | Serve the example server on this port +port :: Int +port = 8091 + +-- | Shortcut for `show port` +portS :: String +portS = show port + +-- | Return a readable stream that emits the first string, then the second +-- | string, with a delay in between given by the third argument +foreign import stagger :: String -> String -> Int -> Stream.Readable () + +-- | Say 'hello world!' in chunks when run +sayHello :: HTTPure.Request -> HTTPure.ResponseM +sayHello _ = HTTPure.ok $ HTTPure.Chunked $ stagger "hello " "world!" 1000 + +-- | Boot up the server +main :: HTTPure.ServerM +main = HTTPure.serve port sayHello do + Console.log $ " ┌────────────────────────────────────────────┐" + Console.log $ " │ Server now up on port " <> portS <> " │" + Console.log $ " │ │" + Console.log $ " │ To test, run: │" + Console.log $ " │ > curl -Nv localhost:" <> portS <> " │" + Console.log $ " │ # => ... │" + Console.log $ " │ # => < Transfer-Encoding: chunked │" + Console.log $ " │ # => ... │" + Console.log $ " │ # => hello │" + Console.log $ " │ (1 second pause) │" + Console.log $ " │ # => world! │" + Console.log $ " └────────────────────────────────────────────┘" diff --git a/docs/Examples/Chunked/Readme.md b/docs/Examples/Chunked/Readme.md new file mode 100644 index 0000000..36852ba --- /dev/null +++ b/docs/Examples/Chunked/Readme.md @@ -0,0 +1,10 @@ +# Chunked Example + +This is a basic example of sending chunked data. It will return 'hello world' +in two separate chunks spaced a second apart on any URL. + +To run the example server, run: + +```bash +make example EXAMPLE=Chunked +``` diff --git a/src/HTTPure.purs b/src/HTTPure.purs index e9699c8..f9d9391 100644 --- a/src/HTTPure.purs +++ b/src/HTTPure.purs @@ -1,5 +1,6 @@ module HTTPure - ( module HTTPure.Headers + ( module HTTPure.Body + , module HTTPure.Headers , module HTTPure.Lookup , module HTTPure.Method , module HTTPure.Path @@ -10,6 +11,7 @@ module HTTPure , module HTTPure.Status ) where +import HTTPure.Body (Chunked(..)) import HTTPure.Headers (Headers, empty, header, headers) import HTTPure.Lookup (at, (!@), has, (!?), lookup, (!!)) import HTTPure.Method (Method(..)) diff --git a/src/HTTPure/Body.purs b/src/HTTPure/Body.purs index 5e68dc6..d194019 100644 --- a/src/HTTPure/Body.purs +++ b/src/HTTPure/Body.purs @@ -1,14 +1,14 @@ module HTTPure.Body ( class Body + , Chunked(..) + , additionalHeaders , read - , size , write ) where import Prelude import Data.Either as Either -import Data.Maybe as Maybe import Effect as Effect import Effect.Aff as Aff import Effect.Ref as Ref @@ -17,26 +17,32 @@ import Node.Encoding as Encoding import Node.HTTP as HTTP import Node.Stream as Stream +import HTTPure.Headers as Headers + +newtype Chunked = Chunked (Stream.Readable ()) + -- | Types that implement the `Body` class can be used as a body to an HTTPure -- | response, and can be used with all the response helpers. class Body b where - -- | Given a body value, return an effect that maybe calculates a size. - -- | TODO: This is a `Maybe` to support chunked transfer encoding. We still - -- | need to add code to send the body using chunking if the effect resolves a - -- | `Maybe.Nothing`. - size :: b -> Effect.Effect (Maybe.Maybe Int) + -- | Return any additional headers that need to be sent with this body type. + -- | Things like `Content-Type`, `Content-Length`, and `Transfer-Encoding`. + additionalHeaders :: b -> Effect.Effect Headers.Headers -- | Given a body value and a Node HTTP `Response` value, write the body value -- | to the Node response. write :: b -> HTTP.Response -> Aff.Aff Unit -- | The instance for `String` will convert the string to a buffer first in --- | order to determine it's size. This is to properly handle UTF-8 characters --- | in the string. Writing is simply implemented by writing the string to the +-- | order to determine it's additional headers. This is to ensure that the +-- | `Content-Length` header properly accounts for UTF-8 characters in the +-- | string. Writing is simply implemented by writing the string to the -- | response stream and closing the response stream. instance bodyString :: Body String where - size body = Buffer.fromString body Encoding.UTF8 >>= size + + additionalHeaders body = + Buffer.fromString body Encoding.UTF8 >>= additionalHeaders + write body response = Aff.makeAff \done -> do let stream = HTTP.responseAsStream response _ <- Stream.writeString stream Encoding.UTF8 body $ pure unit @@ -44,11 +50,15 @@ instance bodyString :: Body String where done $ Either.Right unit pure Aff.nonCanceler --- | The instance for `Buffer` is trivial--to calculate size, we use --- | `Buffer.size`, and to send the response, we just write the buffer to the --- | stream and end the stream. +-- | The instance for `Buffer` is trivial--we add a `Content-Length` header +-- | using `Buffer.size`, and to send the response, we just write the buffer to +-- | the stream and end the stream. instance bodyBuffer :: Body Buffer.Buffer where - size = Buffer.size >>> map Maybe.Just + + additionalHeaders buf = do + size <- Buffer.size buf + pure $ Headers.header "Content-Length" $ show size + write body response = Aff.makeAff \done -> do let stream = HTTP.responseAsStream response _ <- Stream.write stream body $ pure unit @@ -56,6 +66,18 @@ instance bodyBuffer :: Body Buffer.Buffer where done $ Either.Right unit pure Aff.nonCanceler +-- | This instance can be used to send chunked data. Here, we add a +-- | `Transfer-Encoding` header to indicate chunked data. To write the data, we +-- | simply pipe the newtype-wrapped `Stream` to the response. +instance bodyChunked :: Body Chunked where + + additionalHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked" + + write (Chunked body) response = Aff.makeAff \done -> do + _ <- Stream.pipe body $ HTTP.responseAsStream response + Stream.onEnd body $ done $ Either.Right unit + pure Aff.nonCanceler + -- | Extract the contents of the body of the HTTP `Request`. read :: HTTP.Request -> Aff.Aff String read request = Aff.makeAff \done -> do diff --git a/src/HTTPure/Response.purs b/src/HTTPure/Response.purs index 79ed777..85aaecc 100644 --- a/src/HTTPure/Response.purs +++ b/src/HTTPure/Response.purs @@ -78,7 +78,6 @@ module HTTPure.Response import Prelude -import Data.Maybe as Maybe import Effect.Aff as Aff import Effect.Class as EffectClass import Node.HTTP as HTTP @@ -97,21 +96,16 @@ type Response = { status :: Status.Status , headers :: Headers.Headers , writeBody :: HTTP.Response -> Aff.Aff Unit - , size :: Maybe.Maybe Int } -- | Given an HTTP `Response` and a HTTPure `Response`, this method will return -- | a monad encapsulating writing the HTTPure `Response` to the HTTP `Response` -- | and closing the HTTP `Response`. send :: HTTP.Response -> Response -> Aff.Aff Unit -send httpresponse { status, headers, writeBody, size } = do +send httpresponse { status, headers, writeBody } = do EffectClass.liftEffect $ Status.write httpresponse status - EffectClass.liftEffect $ Headers.write httpresponse finalHeaders + EffectClass.liftEffect $ Headers.write httpresponse headers writeBody httpresponse - where - finalHeaders = headers <> contentLength size - contentLength (Maybe.Just s) = Headers.header "Content-Length" $ show s - contentLength Maybe.Nothing = Headers.empty -- | For custom response statuses or providing a body for response codes that -- | don't typically send one. @@ -124,9 +118,13 @@ response' :: forall b. Body.Body b => Headers.Headers -> b -> ResponseM -response' status headers body = do - size <- EffectClass.liftEffect $ Body.size body - pure $ { status, headers, size, writeBody: Body.write body } +response' status headers body = EffectClass.liftEffect do + additionalHeaders <- Body.additionalHeaders body + pure + { status + , headers: headers <> additionalHeaders + , writeBody: Body.write body + } -- | The same as `response` but without a body. emptyResponse :: Status.Status -> ResponseM diff --git a/src/HTTPure/Server.purs b/src/HTTPure/Server.purs index 48261b1..3d1e8e9 100644 --- a/src/HTTPure/Server.purs +++ b/src/HTTPure/Server.purs @@ -33,10 +33,11 @@ handleRequest :: (Request.Request -> Response.ResponseM) -> HTTP.Request -> HTTP.Response -> ServerM -handleRequest router request response = +handleRequest router request httpresponse = void $ Aff.runAff (\_ -> pure unit) do req <- Request.fromHTTPRequest request - router req >>= Response.send response + response <- router req + Response.send httpresponse response -- | Given a `ListenOptions` object, a function mapping `Request` to -- | `ResponseM`, and a `ServerM` containing effects to run on boot, creates and diff --git a/test/Test/HTTPure/BodySpec.purs b/test/Test/HTTPure/BodySpec.purs index 3e5cf9e..0baadbb 100644 --- a/test/Test/HTTPure/BodySpec.purs +++ b/test/Test/HTTPure/BodySpec.purs @@ -2,13 +2,13 @@ module Test.HTTPure.BodySpec where import Prelude -import Data.Maybe as Maybe import Effect.Class as EffectClass import Node.Buffer as Buffer import Node.Encoding as Encoding import Test.Spec as Spec import HTTPure.Body as Body +import HTTPure.Headers as Headers import Test.HTTPure.TestHelpers as TestHelpers import Test.HTTPure.TestHelpers ((?=)) @@ -20,21 +20,27 @@ readSpec = Spec.describe "read" do body <- Body.read request body ?= "test" -sizeSpec :: TestHelpers.Test -sizeSpec = Spec.describe "size" do +additionalHeadersSpec :: TestHelpers.Test +additionalHeadersSpec = Spec.describe "additionalHeaders" do Spec.describe "String" do - Spec.it "returns the correct size for ASCII string body" do - size <- EffectClass.liftEffect $ Body.size "ascii" - size ?= Maybe.Just 5 - Spec.it "returns the correct size for UTF-8 string body" do - size <- EffectClass.liftEffect $ Body.size "\x2603" -- snowman - size ?= Maybe.Just 3 + Spec.describe "with an ASCII string" do + Spec.it "has the correct Content-Length header" do + headers <- EffectClass.liftEffect $ Body.additionalHeaders "ascii" + headers ?= Headers.header "Content-Length" "5" + Spec.describe "with a UTF-8 string" do + Spec.it "has the correct Content-Length header" do + headers <- EffectClass.liftEffect $ Body.additionalHeaders "\x2603" + headers ?= Headers.header "Content-Length" "3" Spec.describe "Buffer" do - Spec.it "returns the correct size for binary body" do - size <- EffectClass.liftEffect do - buf <- Buffer.fromString "foobar" Encoding.UTF8 - Body.size buf - size ?= Maybe.Just 6 + Spec.it "has the correct Content-Length header" do + buf <- EffectClass.liftEffect $ Buffer.fromString "foobar" Encoding.UTF8 + headers <- EffectClass.liftEffect $ Body.additionalHeaders buf + headers ?= Headers.header "Content-Length" "6" + Spec.describe "Chunked" do + Spec.it "specifies the Transfer-Encoding header" do + let body = Body.Chunked $ TestHelpers.stringToStream "test" + headers <- EffectClass.liftEffect $ Body.additionalHeaders body + headers ?= Headers.header "Transfer-Encoding" "chunked" writeSpec :: TestHelpers.Test writeSpec = Spec.describe "write" do @@ -53,9 +59,17 @@ writeSpec = Spec.describe "write" do Body.write buf resp pure $ TestHelpers.getResponseBody resp body ?= "test" + Spec.describe "Chunked" do + Spec.it "pipes the input stream to the Response body" do + body <- do + resp <- EffectClass.liftEffect TestHelpers.mockResponse + let body = Body.Chunked $ TestHelpers.stringToStream "test" + Body.write body resp + pure $ TestHelpers.getResponseBody resp + body ?= "test" bodySpec :: TestHelpers.Test bodySpec = Spec.describe "Body" do + additionalHeadersSpec readSpec - sizeSpec writeSpec diff --git a/test/Test/HTTPure/IntegrationSpec.purs b/test/Test/HTTPure/IntegrationSpec.purs index 3643f4c..38d346a 100644 --- a/test/Test/HTTPure/IntegrationSpec.purs +++ b/test/Test/HTTPure/IntegrationSpec.purs @@ -12,14 +12,15 @@ import Test.HTTPure.TestHelpers as TestHelpers import Test.HTTPure.TestHelpers ((?=)) import Examples.AsyncResponse.Main as AsyncResponse +import Examples.Binary.Main as Binary +import Examples.Chunked.Main as Chunked import Examples.Headers.Main as Headers import Examples.HelloWorld.Main as HelloWorld -import Examples.Image.Main as Image import Examples.Middleware.Main as Middleware import Examples.MultiRoute.Main as MultiRoute import Examples.PathSegments.Main as PathSegments -import Examples.QueryParameters.Main as QueryParameters import Examples.Post.Main as Post +import Examples.QueryParameters.Main as QueryParameters import Examples.SSL.Main as SSL asyncResponseSpec :: TestHelpers.Test @@ -29,6 +30,25 @@ asyncResponseSpec = Spec.it "runs the async response example" do response ?= "hello world!" where port = AsyncResponse.port +binarySpec :: TestHelpers.Test +binarySpec = Spec.it "runs the binary example" do + binaryBuf <- FS.readFile Binary.filePath + expected <- EffectClass.liftEffect $ Buffer.toArray binaryBuf + EffectClass.liftEffect Binary.main + responseBuf <- TestHelpers.getBinary port Object.empty "/" + response <- EffectClass.liftEffect $ Buffer.toArray responseBuf + response ?= expected + where port = Binary.port + +chunkedSpec :: TestHelpers.Test +chunkedSpec = Spec.it "runs the chunked example" do + EffectClass.liftEffect Chunked.main + response <- TestHelpers.get port Object.empty "/" + -- TODO this isn't a great way to validate this, we need a way of inspecting + -- each individual chunk instead of just looking at the entire response + response ?= "hello world!" + where port = Chunked.port + headersSpec :: TestHelpers.Test headersSpec = Spec.it "runs the headers example" do EffectClass.liftEffect Headers.main @@ -45,16 +65,6 @@ helloWorldSpec = Spec.it "runs the hello world example" do response ?= "hello world!" where port = HelloWorld.port -imageSpec :: TestHelpers.Test -imageSpec = Spec.it "runs the image example" do - imageBuf <- FS.readFile Image.filePath - expected <- EffectClass.liftEffect $ Buffer.toArray imageBuf - EffectClass.liftEffect Image.main - responseBuf <- TestHelpers.getBinary port Object.empty "/" - response <- EffectClass.liftEffect $ Buffer.toArray responseBuf - response ?= expected - where port = Image.port - middlewareSpec :: TestHelpers.Test middlewareSpec = Spec.it "runs the middleware example" do EffectClass.liftEffect Middleware.main @@ -86,6 +96,13 @@ pathSegmentsSpec = Spec.it "runs the path segments example" do somebars ?= "[\"some\",\"bars\"]" where port = PathSegments.port +postSpec :: TestHelpers.Test +postSpec = Spec.it "runs the post example" do + EffectClass.liftEffect Post.main + response <- TestHelpers.post port Object.empty "/" "test" + response ?= "test" + where port = Post.port + queryParametersSpec :: TestHelpers.Test queryParametersSpec = Spec.it "runs the query parameters example" do EffectClass.liftEffect QueryParameters.main @@ -99,13 +116,6 @@ queryParametersSpec = Spec.it "runs the query parameters example" do baz ?= "test" where port = QueryParameters.port -postSpec :: TestHelpers.Test -postSpec = Spec.it "runs the post example" do - EffectClass.liftEffect Post.main - response <- TestHelpers.post port Object.empty "/" "test" - response ?= "test" - where port = Post.port - sslSpec :: TestHelpers.Test sslSpec = Spec.it "runs the ssl example" do EffectClass.liftEffect SSL.main @@ -116,12 +126,13 @@ sslSpec = Spec.it "runs the ssl example" do integrationSpec :: TestHelpers.Test integrationSpec = Spec.describe "Integration" do asyncResponseSpec + binarySpec + chunkedSpec headersSpec helloWorldSpec - imageSpec middlewareSpec multiRouteSpec pathSegmentsSpec - queryParametersSpec postSpec + queryParametersSpec sslSpec diff --git a/test/Test/HTTPure/ResponseSpec.purs b/test/Test/HTTPure/ResponseSpec.purs index d02e08e..7db2f56 100644 --- a/test/Test/HTTPure/ResponseSpec.purs +++ b/test/Test/HTTPure/ResponseSpec.purs @@ -3,7 +3,6 @@ module Test.HTTPure.ResponseSpec where import Prelude import Data.Either as Either -import Data.Maybe as Maybe import Effect.Aff as Aff import Effect.Class as EffectClass import Node.Encoding as Encoding @@ -11,6 +10,7 @@ import Node.HTTP as HTTP import Node.Stream as Stream import Test.Spec as Spec +import HTTPure.Body as Body import HTTPure.Headers as Headers import HTTPure.Response as Response @@ -25,12 +25,6 @@ sendSpec = Spec.describe "send" do Response.send httpResponse $ mockResponse unit pure $ TestHelpers.getResponseHeader "Test" httpResponse header ?= "test" - Spec.it "sets the Content-Length header" do - header <- do - httpResponse <- EffectClass.liftEffect $ TestHelpers.mockResponse - Response.send httpResponse $ mockResponse unit - pure $ TestHelpers.getResponseHeader "Content-Length" httpResponse - header ?= "4" Spec.it "writes the status" do status <- do httpResponse <- EffectClass.liftEffect $ TestHelpers.mockResponse @@ -54,7 +48,6 @@ sendSpec = Spec.describe "send" do _ <- Stream.end stream $ pure unit done $ Either.Right unit pure Aff.nonCanceler - , size: Maybe.Just 4 } responseFunctionSpec :: TestHelpers.Test @@ -62,12 +55,10 @@ responseFunctionSpec = Spec.describe "response" do Spec.it "has the right status" do resp <- Response.response 123 "test" resp.status ?= 123 - Spec.it "has empty headers" do - resp <- Response.response 123 "test" - resp.headers ?= Headers.empty - Spec.it "has the right size" do + Spec.it "has only default headers" do resp <- Response.response 123 "test" - resp.size ?= Maybe.Just 4 + defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "test" + resp.headers ?= defaultHeaders Spec.it "has the right writeBody function" do body <- do resp <- Response.response 123 "test" @@ -83,10 +74,8 @@ response'Spec = Spec.describe "response'" do resp.status ?= 123 Spec.it "has the right headers" do resp <- mockResponse - resp.headers ?= mockHeaders - Spec.it "has the right size" do - resp <- mockResponse - resp.size ?= Maybe.Just 4 + defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "test" + resp.headers ?= defaultHeaders <> mockHeaders Spec.it "has the right writeBody function" do body <- do resp <- mockResponse @@ -103,12 +92,10 @@ emptyResponseSpec = Spec.describe "emptyResponse" do Spec.it "has the right status" do resp <- Response.emptyResponse 123 resp.status ?= 123 - Spec.it "has empty headers" do - resp <- Response.emptyResponse 123 - resp.headers ?= Headers.empty - Spec.it "has the right size" do + Spec.it "has only default headers" do resp <- Response.emptyResponse 123 - resp.size ?= Maybe.Just 0 + defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "" + resp.headers ?= defaultHeaders Spec.it "has the right writeBody function" do body <- do resp <- Response.emptyResponse 123 @@ -124,10 +111,8 @@ emptyResponse'Spec = Spec.describe "emptyResponse'" do resp.status ?= 123 Spec.it "has the right headers" do resp <- mockResponse - resp.headers ?= mockHeaders - Spec.it "has the right size" do - resp <- mockResponse - resp.size ?= Maybe.Just 0 + defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "" + resp.headers ?= mockHeaders <> defaultHeaders Spec.it "has the right writeBody function" do body <- do resp <- mockResponse diff --git a/test/Test/HTTPure/TestHelpers.js b/test/Test/HTTPure/TestHelpers.js index 7c9f2f3..7232b49 100644 --- a/test/Test/HTTPure/TestHelpers.js +++ b/test/Test/HTTPure/TestHelpers.js @@ -32,9 +32,20 @@ exports.mockResponse = function() { }, end: function() { }, + on: function() { }, + once: function() { }, + emit: function() { }, setHeader: function(header, val) { this.headers[header] = val; } }; }; + +exports.stringToStream = function (str) { + var stream = new require('stream').Readable(); + stream._read = function () {}; + stream.push(str); + stream.push(null); + return stream; +} diff --git a/test/Test/HTTPure/TestHelpers.purs b/test/Test/HTTPure/TestHelpers.purs index a52bbc3..74c7ad9 100644 --- a/test/Test/HTTPure/TestHelpers.purs +++ b/test/Test/HTTPure/TestHelpers.purs @@ -162,3 +162,6 @@ getResponseHeaders = Coerce.unsafeCoerce <<< _.headers <<< Coerce.unsafeCoerce getResponseHeader :: String -> HTTP.Response -> String getResponseHeader header = Maybe.fromMaybe "" <<< Object.lookup header <<< getResponseHeaders + +-- | Create a stream out of a string. +foreign import stringToStream :: String -> Stream.Readable () From 7892229f15df6c0420886a0c783720da080479e9 Mon Sep 17 00:00:00 2001 From: Connor Prussin Date: Tue, 28 Aug 2018 20:41:59 -0700 Subject: [PATCH 2/6] Remove Chunked newtype wrapper around Streams --- docs/Examples/Chunked/Main.purs | 2 +- src/HTTPure.purs | 4 +--- src/HTTPure/Body.purs | 15 ++++++++------- test/Test/HTTPure/BodySpec.purs | 9 ++++----- 4 files changed, 14 insertions(+), 16 deletions(-) diff --git a/docs/Examples/Chunked/Main.purs b/docs/Examples/Chunked/Main.purs index c763c97..a9cf47d 100644 --- a/docs/Examples/Chunked/Main.purs +++ b/docs/Examples/Chunked/Main.purs @@ -20,7 +20,7 @@ foreign import stagger :: String -> String -> Int -> Stream.Readable () -- | Say 'hello world!' in chunks when run sayHello :: HTTPure.Request -> HTTPure.ResponseM -sayHello _ = HTTPure.ok $ HTTPure.Chunked $ stagger "hello " "world!" 1000 +sayHello _ = HTTPure.ok $ stagger "hello " "world!" 1000 -- | Boot up the server main :: HTTPure.ServerM diff --git a/src/HTTPure.purs b/src/HTTPure.purs index f9d9391..e9699c8 100644 --- a/src/HTTPure.purs +++ b/src/HTTPure.purs @@ -1,6 +1,5 @@ module HTTPure - ( module HTTPure.Body - , module HTTPure.Headers + ( module HTTPure.Headers , module HTTPure.Lookup , module HTTPure.Method , module HTTPure.Path @@ -11,7 +10,6 @@ module HTTPure , module HTTPure.Status ) where -import HTTPure.Body (Chunked(..)) import HTTPure.Headers (Headers, empty, header, headers) import HTTPure.Lookup (at, (!@), has, (!?), lookup, (!!)) import HTTPure.Method (Method(..)) diff --git a/src/HTTPure/Body.purs b/src/HTTPure/Body.purs index d194019..b5182af 100644 --- a/src/HTTPure/Body.purs +++ b/src/HTTPure/Body.purs @@ -1,6 +1,5 @@ module HTTPure.Body ( class Body - , Chunked(..) , additionalHeaders , read , write @@ -16,11 +15,10 @@ import Node.Buffer as Buffer import Node.Encoding as Encoding import Node.HTTP as HTTP import Node.Stream as Stream +import Type.Equality as TypeEquals import HTTPure.Headers as Headers -newtype Chunked = Chunked (Stream.Readable ()) - -- | Types that implement the `Body` class can be used as a body to an HTTPure -- | response, and can be used with all the response helpers. class Body b where @@ -69,13 +67,16 @@ instance bodyBuffer :: Body Buffer.Buffer where -- | This instance can be used to send chunked data. Here, we add a -- | `Transfer-Encoding` header to indicate chunked data. To write the data, we -- | simply pipe the newtype-wrapped `Stream` to the response. -instance bodyChunked :: Body Chunked where +instance bodyChunked :: + TypeEquals.TypeEquals (Stream.Stream r) (Stream.Readable ()) => + Body (Stream.Stream r) where additionalHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked" - write (Chunked body) response = Aff.makeAff \done -> do - _ <- Stream.pipe body $ HTTP.responseAsStream response - Stream.onEnd body $ done $ Either.Right unit + write body response = Aff.makeAff \done -> do + let stream = TypeEquals.to body + _ <- Stream.pipe stream $ HTTP.responseAsStream response + Stream.onEnd stream $ done $ Either.Right unit pure Aff.nonCanceler -- | Extract the contents of the body of the HTTP `Request`. diff --git a/test/Test/HTTPure/BodySpec.purs b/test/Test/HTTPure/BodySpec.purs index 0baadbb..5b2b5c8 100644 --- a/test/Test/HTTPure/BodySpec.purs +++ b/test/Test/HTTPure/BodySpec.purs @@ -36,9 +36,9 @@ additionalHeadersSpec = Spec.describe "additionalHeaders" do buf <- EffectClass.liftEffect $ Buffer.fromString "foobar" Encoding.UTF8 headers <- EffectClass.liftEffect $ Body.additionalHeaders buf headers ?= Headers.header "Content-Length" "6" - Spec.describe "Chunked" do + Spec.describe "Readable" do Spec.it "specifies the Transfer-Encoding header" do - let body = Body.Chunked $ TestHelpers.stringToStream "test" + let body = TestHelpers.stringToStream "test" headers <- EffectClass.liftEffect $ Body.additionalHeaders body headers ?= Headers.header "Transfer-Encoding" "chunked" @@ -59,12 +59,11 @@ writeSpec = Spec.describe "write" do Body.write buf resp pure $ TestHelpers.getResponseBody resp body ?= "test" - Spec.describe "Chunked" do + Spec.describe "Readable" do Spec.it "pipes the input stream to the Response body" do body <- do resp <- EffectClass.liftEffect TestHelpers.mockResponse - let body = Body.Chunked $ TestHelpers.stringToStream "test" - Body.write body resp + Body.write (TestHelpers.stringToStream "test") resp pure $ TestHelpers.getResponseBody resp body ?= "test" From 3035c6e14e0fb8ee41073d1bf880d2b3a23b2a4a Mon Sep 17 00:00:00 2001 From: Connor Prussin Date: Tue, 28 Aug 2018 21:15:35 -0700 Subject: [PATCH 3/6] Use child process instead of ffi stream for chunked example --- bower.json | 11 ++++++----- docs/Examples/Chunked/Main.js | 16 ---------------- docs/Examples/Chunked/Main.purs | 14 +++++++++----- 3 files changed, 15 insertions(+), 26 deletions(-) delete mode 100644 docs/Examples/Chunked/Main.js diff --git a/bower.json b/bower.json index 05faaf3..e03a2c0 100644 --- a/bower.json +++ b/bower.json @@ -17,17 +17,18 @@ "*.md" ], "dependencies": { - "purescript-prelude": "^4.0.1", "purescript-aff": "^5.0.0", + "purescript-foldable-traversable": "^4.0.0", "purescript-node-fs": "^5.0.0", "purescript-node-http": "^5.0.0", - "purescript-strings": "^4.0.0", - "purescript-foldable-traversable": "^4.0.0" + "purescript-prelude": "^4.0.1", + "purescript-strings": "^4.0.0" }, "devDependencies": { + "purescript-node-child-process": "^5.0.0", + "purescript-node-fs-aff": "^6.0.0", "purescript-psci-support": "^4.0.0", "purescript-spec": "^3.0.0", - "purescript-unsafe-coerce": "^4.0.0", - "purescript-node-fs-aff": "^6.0.0" + "purescript-unsafe-coerce": "^4.0.0" } } diff --git a/docs/Examples/Chunked/Main.js b/docs/Examples/Chunked/Main.js deleted file mode 100644 index 80c98cd..0000000 --- a/docs/Examples/Chunked/Main.js +++ /dev/null @@ -1,16 +0,0 @@ -"use strict"; - -exports.stagger = function (start) { - return function (end) { - return function (delay) { - var stream = new require('stream').Readable(); - stream._read = function () {}; - stream.push(start); - setTimeout(function () { - stream.push(end); - stream.push(null); - }, delay); - return stream; - }; - }; -}; diff --git a/docs/Examples/Chunked/Main.purs b/docs/Examples/Chunked/Main.purs index a9cf47d..bf1f459 100644 --- a/docs/Examples/Chunked/Main.purs +++ b/docs/Examples/Chunked/Main.purs @@ -2,9 +2,10 @@ module Examples.Chunked.Main where import Prelude +import Effect.Class as EffectClass import Effect.Console as Console import HTTPure as HTTPure -import Node.Stream as Stream +import Node.ChildProcess as ChildProcess -- | Serve the example server on this port port :: Int @@ -14,13 +15,16 @@ port = 8091 portS :: String portS = show port --- | Return a readable stream that emits the first string, then the second --- | string, with a delay in between given by the third argument -foreign import stagger :: String -> String -> Int -> Stream.Readable () +-- | This is the script that says hello! +script :: String +script = "echo -n 'hello '; sleep 1; echo -n 'world!'" -- | Say 'hello world!' in chunks when run sayHello :: HTTPure.Request -> HTTPure.ResponseM -sayHello _ = HTTPure.ok $ stagger "hello " "world!" 1000 +sayHello _ = do + child <- EffectClass.liftEffect $ + ChildProcess.spawn "sh" [ "-c", script ] ChildProcess.defaultSpawnOptions + HTTPure.ok $ ChildProcess.stdout $ child -- | Boot up the server main :: HTTPure.ServerM From 03fa2b1c90e7cd9b21abdac1f1d9520edfaf842f Mon Sep 17 00:00:00 2001 From: Connor Prussin Date: Tue, 28 Aug 2018 21:38:56 -0700 Subject: [PATCH 4/6] Rename additionalHeaders to defaultHeaders --- src/HTTPure/Body.purs | 17 +++++++++-------- src/HTTPure/Response.purs | 4 ++-- test/Test/HTTPure/BodySpec.purs | 14 +++++++------- test/Test/HTTPure/ResponseSpec.purs | 8 ++++---- 4 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/HTTPure/Body.purs b/src/HTTPure/Body.purs index b5182af..3067ee9 100644 --- a/src/HTTPure/Body.purs +++ b/src/HTTPure/Body.purs @@ -1,6 +1,6 @@ module HTTPure.Body ( class Body - , additionalHeaders + , defaultHeaders , read , write ) where @@ -23,9 +23,11 @@ import HTTPure.Headers as Headers -- | response, and can be used with all the response helpers. class Body b where - -- | Return any additional headers that need to be sent with this body type. - -- | Things like `Content-Type`, `Content-Length`, and `Transfer-Encoding`. - additionalHeaders :: b -> Effect.Effect Headers.Headers + -- | Return any default headers that need to be sent with this body type, + -- | 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.Effect Headers.Headers -- | Given a body value and a Node HTTP `Response` value, write the body value -- | to the Node response. @@ -38,8 +40,7 @@ class Body b where -- | response stream and closing the response stream. instance bodyString :: Body String where - additionalHeaders body = - Buffer.fromString body Encoding.UTF8 >>= additionalHeaders + defaultHeaders body = Buffer.fromString body Encoding.UTF8 >>= defaultHeaders write body response = Aff.makeAff \done -> do let stream = HTTP.responseAsStream response @@ -53,7 +54,7 @@ instance bodyString :: Body String where -- | the stream and end the stream. instance bodyBuffer :: Body Buffer.Buffer where - additionalHeaders buf = do + defaultHeaders buf = do size <- Buffer.size buf pure $ Headers.header "Content-Length" $ show size @@ -71,7 +72,7 @@ instance bodyChunked :: TypeEquals.TypeEquals (Stream.Stream r) (Stream.Readable ()) => Body (Stream.Stream r) where - additionalHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked" + defaultHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked" write body response = Aff.makeAff \done -> do let stream = TypeEquals.to body diff --git a/src/HTTPure/Response.purs b/src/HTTPure/Response.purs index 85aaecc..4deffa0 100644 --- a/src/HTTPure/Response.purs +++ b/src/HTTPure/Response.purs @@ -119,10 +119,10 @@ response' :: forall b. Body.Body b => b -> ResponseM response' status headers body = EffectClass.liftEffect do - additionalHeaders <- Body.additionalHeaders body + defaultHeaders <- Body.defaultHeaders body pure { status - , headers: headers <> additionalHeaders + , headers: defaultHeaders <> headers , writeBody: Body.write body } diff --git a/test/Test/HTTPure/BodySpec.purs b/test/Test/HTTPure/BodySpec.purs index 5b2b5c8..3e6b5e3 100644 --- a/test/Test/HTTPure/BodySpec.purs +++ b/test/Test/HTTPure/BodySpec.purs @@ -20,26 +20,26 @@ readSpec = Spec.describe "read" do body <- Body.read request body ?= "test" -additionalHeadersSpec :: TestHelpers.Test -additionalHeadersSpec = Spec.describe "additionalHeaders" do +defaultHeadersSpec :: TestHelpers.Test +defaultHeadersSpec = Spec.describe "defaultHeaders" do Spec.describe "String" do Spec.describe "with an ASCII string" do Spec.it "has the correct Content-Length header" do - headers <- EffectClass.liftEffect $ Body.additionalHeaders "ascii" + headers <- EffectClass.liftEffect $ Body.defaultHeaders "ascii" headers ?= Headers.header "Content-Length" "5" Spec.describe "with a UTF-8 string" do Spec.it "has the correct Content-Length header" do - headers <- EffectClass.liftEffect $ Body.additionalHeaders "\x2603" + headers <- EffectClass.liftEffect $ Body.defaultHeaders "\x2603" headers ?= Headers.header "Content-Length" "3" Spec.describe "Buffer" do Spec.it "has the correct Content-Length header" do buf <- EffectClass.liftEffect $ Buffer.fromString "foobar" Encoding.UTF8 - headers <- EffectClass.liftEffect $ Body.additionalHeaders buf + headers <- EffectClass.liftEffect $ Body.defaultHeaders buf headers ?= Headers.header "Content-Length" "6" Spec.describe "Readable" do Spec.it "specifies the Transfer-Encoding header" do let body = TestHelpers.stringToStream "test" - headers <- EffectClass.liftEffect $ Body.additionalHeaders body + headers <- EffectClass.liftEffect $ Body.defaultHeaders body headers ?= Headers.header "Transfer-Encoding" "chunked" writeSpec :: TestHelpers.Test @@ -69,6 +69,6 @@ writeSpec = Spec.describe "write" do bodySpec :: TestHelpers.Test bodySpec = Spec.describe "Body" do - additionalHeadersSpec + defaultHeadersSpec readSpec writeSpec diff --git a/test/Test/HTTPure/ResponseSpec.purs b/test/Test/HTTPure/ResponseSpec.purs index 7db2f56..1b30cd5 100644 --- a/test/Test/HTTPure/ResponseSpec.purs +++ b/test/Test/HTTPure/ResponseSpec.purs @@ -57,7 +57,7 @@ responseFunctionSpec = Spec.describe "response" do resp.status ?= 123 Spec.it "has only default headers" do resp <- Response.response 123 "test" - defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "test" + defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders "test" resp.headers ?= defaultHeaders Spec.it "has the right writeBody function" do body <- do @@ -74,7 +74,7 @@ response'Spec = Spec.describe "response'" do resp.status ?= 123 Spec.it "has the right headers" do resp <- mockResponse - defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "test" + defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders "test" resp.headers ?= defaultHeaders <> mockHeaders Spec.it "has the right writeBody function" do body <- do @@ -94,7 +94,7 @@ emptyResponseSpec = Spec.describe "emptyResponse" do resp.status ?= 123 Spec.it "has only default headers" do resp <- Response.emptyResponse 123 - defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "" + defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders "" resp.headers ?= defaultHeaders Spec.it "has the right writeBody function" do body <- do @@ -111,7 +111,7 @@ emptyResponse'Spec = Spec.describe "emptyResponse'" do resp.status ?= 123 Spec.it "has the right headers" do resp <- mockResponse - defaultHeaders <- EffectClass.liftEffect $ Body.additionalHeaders "" + defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders "" resp.headers ?= mockHeaders <> defaultHeaders Spec.it "has the right writeBody function" do body <- do From d0f8f369417a35ee17e7aa68d56a167dc86d67ed Mon Sep 17 00:00:00 2001 From: Connor Prussin Date: Tue, 28 Aug 2018 21:43:24 -0700 Subject: [PATCH 5/6] Add History.md entry --- History.md | 1 + 1 file changed, 1 insertion(+) diff --git a/History.md b/History.md index d0100c5..a7c8115 100644 --- a/History.md +++ b/History.md @@ -2,6 +2,7 @@ unreleased ========== - Re-export `HTTPure.Query` and `HTTPure.Status` (thanks **@akheron**) - Support binary response body (thanks **@akheron**) +- Add support for chunked responses 0.7.0 / 2018-07-08 ================== From 3d99544a2ee2908d2c63ef580435fb6ca9701051 Mon Sep 17 00:00:00 2001 From: Connor Prussin Date: Wed, 29 Aug 2018 01:05:18 -0700 Subject: [PATCH 6/6] General cleanup --- docs/Examples/Chunked/Main.purs | 15 ++++++++------- src/HTTPure/Body.purs | 5 ++--- src/HTTPure/Server.purs | 6 ++---- 3 files changed, 12 insertions(+), 14 deletions(-) diff --git a/docs/Examples/Chunked/Main.purs b/docs/Examples/Chunked/Main.purs index bf1f459..ea256c9 100644 --- a/docs/Examples/Chunked/Main.purs +++ b/docs/Examples/Chunked/Main.purs @@ -2,10 +2,12 @@ module Examples.Chunked.Main where import Prelude +import Effect.Aff as Aff import Effect.Class as EffectClass import Effect.Console as Console import HTTPure as HTTPure import Node.ChildProcess as ChildProcess +import Node.Stream as Stream -- | Serve the example server on this port port :: Int @@ -15,16 +17,15 @@ port = 8091 portS :: String portS = show port --- | This is the script that says hello! -script :: String -script = "echo -n 'hello '; sleep 1; echo -n 'world!'" +-- | Run a script and return it's stdout stream +runScript :: String -> Aff.Aff (Stream.Readable ()) +runScript script = EffectClass.liftEffect $ ChildProcess.stdout <$> + ChildProcess.spawn "sh" [ "-c", script ] ChildProcess.defaultSpawnOptions -- | Say 'hello world!' in chunks when run sayHello :: HTTPure.Request -> HTTPure.ResponseM -sayHello _ = do - child <- EffectClass.liftEffect $ - ChildProcess.spawn "sh" [ "-c", script ] ChildProcess.defaultSpawnOptions - HTTPure.ok $ ChildProcess.stdout $ child +sayHello _ = + runScript "echo -n 'hello '; sleep 1; echo -n 'world!'" >>= HTTPure.ok -- | Boot up the server main :: HTTPure.ServerM diff --git a/src/HTTPure/Body.purs b/src/HTTPure/Body.purs index 3067ee9..c09da37 100644 --- a/src/HTTPure/Body.purs +++ b/src/HTTPure/Body.purs @@ -54,9 +54,8 @@ instance bodyString :: Body String where -- | the stream and end the stream. instance bodyBuffer :: Body Buffer.Buffer where - defaultHeaders buf = do - size <- Buffer.size buf - pure $ Headers.header "Content-Length" $ show size + defaultHeaders buf = + Headers.header "Content-Length" <$> show <$> Buffer.size buf write body response = Aff.makeAff \done -> do let stream = HTTP.responseAsStream response diff --git a/src/HTTPure/Server.purs b/src/HTTPure/Server.purs index 3d1e8e9..1ad8919 100644 --- a/src/HTTPure/Server.purs +++ b/src/HTTPure/Server.purs @@ -34,10 +34,8 @@ handleRequest :: (Request.Request -> Response.ResponseM) -> HTTP.Response -> ServerM handleRequest router request httpresponse = - void $ Aff.runAff (\_ -> pure unit) do - req <- Request.fromHTTPRequest request - response <- router req - Response.send httpresponse response + void $ Aff.runAff (\_ -> pure unit) $ + Request.fromHTTPRequest request >>= router >>= Response.send httpresponse -- | Given a `ListenOptions` object, a function mapping `Request` to -- | `ResponseM`, and a `ServerM` containing effects to run on boot, creates and