Chunked responses

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-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"
   }
 }

docs/Examples/Image/Main.purs → 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,61 +1,84 @@
 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
 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.
-  -- | 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 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.
   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
+
+  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
     _ <- Stream.end stream $ pure unit
     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
+
+  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
     _ <- Stream.end stream $ pure unit
     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
-  size <- EffectClass.liftEffect $ Body.size body
-  pure $ { status, headers, size, writeBody: Body.write body }
+response' status headers body = EffectClass.liftEffect do
+  defaultHeaders <- Body.defaultHeaders 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 =
-  void $ Aff.runAff (\_ -> pure unit) do
-    req <- Request.fromHTTPRequest request
-    router req >>= Response.send response
+handleRequest router request httpresponse =
+  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

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
+defaultHeadersSpec :: TestHelpers.Test
+defaultHeadersSpec = Spec.describe "defaultHeaders" 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.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.defaultHeaders "\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.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.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