Chunked responses (#107)

* Chunked responses

* Remove Chunked newtype wrapper around Streams

* Use child process instead of ffi stream for chunked example

* Rename additionalHeaders to defaultHeaders

* Add History.md entry

* General cleanup

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
 ==================

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-prelude": "^4.0.1",
-    "purescript-foldable-traversable": "^4.0.0"
+    "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-unsafe-coerce": "^4.0.0"
-    "purescript-node-fs-aff": "^6.0.0"
   }
 }

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

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
+```

docs/Examples/Chunked/Main.purs

@@ -0,0 +1,44 @@
+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
+port = 8091
+
+-- | Shortcut for `show port`
+portS :: String
+portS = show port
+
+-- | 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 _ =
+  runScript "echo -n 'hello '; sleep 1; echo -n 'world!'" >>= HTTPure.ok
+
+-- | 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 $ " └────────────────────────────────────────────┘"

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
+```

src/HTTPure/Body.purs

@@ -1,14 +1,13 @@
 module HTTPure.Body
   ( class Body
+  , defaultHeaders
   , 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
@@ -16,27 +15,33 @@ 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
 
 -- | 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.
+  -- | Return any default headers that need to be sent with this body type,
-  -- | TODO: This is a `Maybe` to support chunked transfer encoding.  We still
+  -- | things like `Content-Type`, `Content-Length`, and `Transfer-Encoding`.
-  -- | need to add code to send the body using chunking if the effect resolves a
+  -- | Note that any headers passed in a response helper such as `ok'` will take
-  -- | `Maybe.Nothing`.
+  -- | precedence over these.
-  size :: b -> Effect.Effect (Maybe.Maybe Int)
+  defaultHeaders :: 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
+-- | order to determine it's additional headers.  This is to ensure that the
--- | in the string.  Writing is simply implemented by writing the string to 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
+
+  defaultHeaders body = Buffer.fromString body Encoding.UTF8 >>= defaultHeaders
+
   write body response = Aff.makeAff \done -> do
     let stream = HTTP.responseAsStream response
     _ <- Stream.writeString stream Encoding.UTF8 body $ pure unit
@@ -44,11 +49,14 @@ instance bodyString :: Body String where
     done $ Either.Right unit
     pure Aff.nonCanceler
 
--- | The instance for `Buffer` is trivial--to calculate size, we use
+-- | The instance for `Buffer` is trivial--we add a `Content-Length` header
--- | `Buffer.size`, and to send the response, we just write the buffer to the
+-- | using `Buffer.size`, and to send the response, we just write the buffer to
--- | stream and end the stream.
+-- | the stream and end the stream.
 instance bodyBuffer :: Body Buffer.Buffer where
-  size = Buffer.size >>> map Maybe.Just
+
+  defaultHeaders buf =
+    Headers.header "Content-Length" <$> show <$> Buffer.size buf
+
   write body response = Aff.makeAff \done -> do
     let stream = HTTP.responseAsStream response
     _ <- Stream.write stream body $ pure unit
@@ -56,6 +64,21 @@ 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 ::
+  TypeEquals.TypeEquals (Stream.Stream r) (Stream.Readable ()) =>
+  Body (Stream.Stream r) where
+
+  defaultHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked"
+
+  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`.
 read :: HTTP.Request -> Aff.Aff String
 read request = Aff.makeAff \done -> do

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
+response' status headers body = EffectClass.liftEffect do
-  size <- EffectClass.liftEffect $ Body.size body
+  defaultHeaders <- Body.defaultHeaders body
-  pure $ { status, headers, size, writeBody: Body.write body }
+  pure
+    { status
+    , headers: defaultHeaders <> headers
+    , writeBody: Body.write body
+    }
 
 -- | The same as `response` but without a body.
 emptyResponse :: Status.Status -> ResponseM

src/HTTPure/Server.purs

@@ -33,10 +33,9 @@ handleRequest :: (Request.Request -> Response.ResponseM) ->
                  HTTP.Request ->
                  HTTP.Response ->
                  ServerM
-handleRequest router request response =
+handleRequest router request httpresponse =
-  void $ Aff.runAff (\_ -> pure unit) do
+  void $ Aff.runAff (\_ -> pure unit) $
-    req <- Request.fromHTTPRequest request
+    Request.fromHTTPRequest request >>= router >>= Response.send httpresponse
-    router req >>= Response.send response
 
 -- | Given a `ListenOptions` object, a function mapping `Request` to
 -- | `ResponseM`, and a `ServerM` containing effects to run on boot, creates and

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
+defaultHeadersSpec :: TestHelpers.Test
-sizeSpec = Spec.describe "size" do
+defaultHeadersSpec = Spec.describe "defaultHeaders" do
   Spec.describe "String" do
-    Spec.it "returns the correct size for ASCII string body" do
+    Spec.describe "with an ASCII string" do
-      size <- EffectClass.liftEffect $ Body.size "ascii"
+      Spec.it "has the correct Content-Length header" do
-      size ?= Maybe.Just 5
+        headers <- EffectClass.liftEffect $ Body.defaultHeaders "ascii"
-    Spec.it "returns the correct size for UTF-8 string body" do
+        headers ?= Headers.header "Content-Length" "5"
-      size <- EffectClass.liftEffect $ Body.size "\x2603"  -- snowman
+    Spec.describe "with a UTF-8 string" do
-      size ?= Maybe.Just 3
+      Spec.it "has the correct Content-Length header" do
+        headers <- EffectClass.liftEffect $ Body.defaultHeaders "\x2603"
+        headers ?= Headers.header "Content-Length" "3"
   Spec.describe "Buffer" do
-    Spec.it "returns the correct size for binary body" do
+    Spec.it "has the correct Content-Length header" do
-      size <- EffectClass.liftEffect do
+      buf <- EffectClass.liftEffect $ Buffer.fromString "foobar" Encoding.UTF8
-        buf <- Buffer.fromString "foobar" Encoding.UTF8
+      headers <- EffectClass.liftEffect $ Body.defaultHeaders buf
-        Body.size buf
+      headers ?= Headers.header "Content-Length" "6"
-      size ?= Maybe.Just 6
+  Spec.describe "Readable" do
+    Spec.it "specifies the Transfer-Encoding header" do
+      let body = TestHelpers.stringToStream "test"
+      headers <- EffectClass.liftEffect $ Body.defaultHeaders body
+      headers ?= Headers.header "Transfer-Encoding" "chunked"
 
 writeSpec :: TestHelpers.Test
 writeSpec = Spec.describe "write" do
@@ -53,9 +59,16 @@ writeSpec = Spec.describe "write" do
         Body.write buf resp
         pure $ TestHelpers.getResponseBody resp
       body ?= "test"
+  Spec.describe "Readable" do
+    Spec.it "pipes the input stream to the Response body" do
+      body <- do
+        resp <- EffectClass.liftEffect TestHelpers.mockResponse
+        Body.write (TestHelpers.stringToStream "test") resp
+        pure $ TestHelpers.getResponseBody resp
+      body ?= "test"
 
 bodySpec :: TestHelpers.Test
 bodySpec = Spec.describe "Body" do
+  defaultHeadersSpec
   readSpec
-  sizeSpec
   writeSpec

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

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
+  Spec.it "has only default headers" do
     resp <- Response.response 123 "test"
-    resp.headers ?= Headers.empty
+    defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders "test"
-  Spec.it "has the right size" do
+    resp.headers ?= defaultHeaders
-    resp <- Response.response 123 "test"
-    resp.size ?= Maybe.Just 4
   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
+    defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders "test"
-  Spec.it "has the right size" do
+    resp.headers ?= defaultHeaders <> mockHeaders
-    resp <- mockResponse
-    resp.size ?= Maybe.Just 4
   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
+  Spec.it "has only default headers" do
     resp <- Response.emptyResponse 123
-    resp.headers ?= Headers.empty
+    defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders ""
-  Spec.it "has the right size" do
+    resp.headers ?= defaultHeaders
-    resp <- Response.emptyResponse 123
-    resp.size ?= Maybe.Just 0
   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
+    defaultHeaders <- EffectClass.liftEffect $ Body.defaultHeaders ""
-  Spec.it "has the right size" do
+    resp.headers ?= mockHeaders <> defaultHeaders
-    resp <- mockResponse
-    resp.size ?= Maybe.Just 0
   Spec.it "has the right writeBody function" do
     body <- do
       resp <- mockResponse

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;
+}

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