Support binary response body (#99)

* Support binary response body

Fixes #98

* Address PR comments

- Expose data constructors for Body and use them for construction and
  pattern matching instead of various helpers

- Add an example and integration test for binary response

- Adjust the middleware example to be a bit nicer

docs/Examples/Image/Main.purs

@@ -0,0 +1,36 @@
+module Examples.Image.Main where
+
+import Prelude
+
+import Effect.Console as Console
+import Node.FS.Aff as FS
+import HTTPure as HTTPure
+
+-- | Serve the example server on this port
+port :: Int
+port = 8090
+
+-- | Shortcut for `show port`
+portS :: String
+portS = show port
+
+-- | The path to the file containing the response to send
+filePath :: String
+filePath = "./docs/Examples/Image/circle.png"
+
+-- | Respond with image data when run
+image :: HTTPure.Request -> HTTPure.ResponseM
+image _ =
+  FS.readFile filePath >>= HTTPure.binaryResponse' 200 headers
+  where
+    headers = HTTPure.header "Content-Type" "image/png"
+
+-- | Boot up the server
+main :: HTTPure.ServerM
+main = HTTPure.serve port image do
+  Console.log $ " ┌────────────────────────────────────────────┐"
+  Console.log $ " │ Server now up on port " <> portS <> "                 │"
+  Console.log $ " │                                            │"
+  Console.log $ " │ To test, run:                              │"
+  Console.log $ " │  > curl -o circle.png localhost:" <> portS <> "       │"
+  Console.log $ " └────────────────────────────────────────────┘"

docs/Examples/Middleware/Main.purs

@@ -32,8 +32,8 @@ headerMiddleware :: (HTTPure.Request -> HTTPure.ResponseM) ->
                     HTTPure.Request ->
                     HTTPure.ResponseM
 headerMiddleware router request = do
-  response <- router request
-  HTTPure.response' response.status (header <> response.headers) response.body
+  response@{ headers } <- router request
+  pure $ response { headers = header <> headers }
   where
     header = HTTPure.header "X-Middleware" "middleware"
 

src/HTTPure.purs

@@ -20,6 +20,7 @@ import HTTPure.Response
   ( Response
   , ResponseM
   , response, response'
+  , binaryResponse, binaryResponse'
   , emptyResponse, emptyResponse'
 
   -- 1xx

src/HTTPure/Body.purs

@@ -1,25 +1,30 @@
 module HTTPure.Body
-  ( Body
+  ( Body(..)
   , read
   , write
+  , size
   ) where
 
 import Prelude
 
 import Data.Either as Either
+import Data.String as String
 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
 
 -- | The `Body` type is just sugar for a `String`, that will be sent or received
 -- | in the HTTP body.
-type Body = String
+data Body
+  = StringBody String
+  | BinaryBody Buffer.Buffer
 
 -- | Extract the contents of the body of the HTTP `Request`.
-read :: HTTP.Request -> Aff.Aff Body
+read :: HTTP.Request -> Aff.Aff String
 read request = Aff.makeAff \done -> do
   let stream = HTTP.requestAsStream request
   buf <- Ref.new ""
@@ -31,7 +36,16 @@ read request = Aff.makeAff \done -> do
 -- | Write a `Body` to the given HTTP `Response` and close it.
 write :: HTTP.Response -> Body -> Effect.Effect Unit
 write response body = void do
-  _ <- Stream.writeString stream Encoding.UTF8 body $ pure unit
+  _ <- writeToStream $ pure unit
   Stream.end stream $ pure unit
   where
     stream = HTTP.responseAsStream response
+    writeToStream =
+      case body of
+        StringBody str -> Stream.writeString stream Encoding.UTF8 str
+        BinaryBody buf -> Stream.write stream buf
+
+-- | Get the size of the body in bytes
+size :: Body -> Effect.Effect Int
+size (StringBody body) = pure $ String.length body
+size (BinaryBody body) = Buffer.size body

src/HTTPure/Request.purs

@@ -24,7 +24,7 @@ type Request =
   , path :: Path.Path
   , query :: Query.Query
   , headers :: Headers.Headers
-  , body :: Body.Body
+  , body :: String
   }
 
 -- | Return the full resolved path, including query parameters. This may not

src/HTTPure/Response.purs

@@ -3,6 +3,7 @@ module HTTPure.Response
   , ResponseM
   , send
   , response, response'
+  , binaryResponse, binaryResponse'
   , emptyResponse, emptyResponse'
 
   -- 1xx
@@ -78,9 +79,9 @@ module HTTPure.Response
 
 import Prelude
 
-import Data.String as String
 import Effect as Effect
 import Effect.Aff as Aff
+import Node.Buffer as Buffer
 import Node.HTTP as HTTP
 
 import HTTPure.Body as Body
@@ -105,22 +106,36 @@ type Response =
 send :: HTTP.Response -> Response -> Effect.Effect Unit
 send httpresponse { status, headers, body } = do
   Status.write httpresponse $ status
-  Headers.write httpresponse $ headers <> contentLength
+  size <- Body.size body
+  Headers.write httpresponse $ headers <> contentLength size
   Body.write httpresponse $ body
   where
-    contentLength = Headers.header "Content-Length" $ show $ String.length body
+    contentLength size = Headers.header "Content-Length" $ show size
 
 -- | For custom response statuses or providing a body for response codes that
 -- | don't typically send one.
-response :: Status.Status -> Body.Body -> ResponseM
+response :: Status.Status -> String -> ResponseM
 response status = response' status Headers.empty
 
 -- | The same as `response` but with headers.
 response' :: Status.Status ->
              Headers.Headers ->
-             Body.Body ->
+             String ->
              ResponseM
-response' status headers body = pure $ { status, headers, body }
+response' status headers body =
+  pure $ { status, headers, body: Body.StringBody body }
+
+-- | Like `response`, but the response body is binary data.
+binaryResponse :: Status.Status -> Buffer.Buffer -> Aff.Aff Response
+binaryResponse status = binaryResponse' status Headers.empty
+
+-- | The same as `binaryResponse` but with headers.
+binaryResponse' :: Status.Status ->
+                   Headers.Headers ->
+                   Buffer.Buffer ->
+                   Aff.Aff Response
+binaryResponse' status headers body
+  = pure $ { status, headers, body: Body.BinaryBody body }
 
 -- | The same as `response` but without a body.
 emptyResponse :: Status.Status -> ResponseM
@@ -163,11 +178,11 @@ processing' = emptyResponse' Status.processing
 ---------
 
 -- | 200
-ok :: Body.Body -> ResponseM
+ok :: String -> ResponseM
 ok = ok' Headers.empty
 
 -- | 200 with headers
-ok' :: Headers.Headers -> Body.Body -> ResponseM
+ok' :: Headers.Headers -> String -> ResponseM
 ok' = response' Status.ok
 
 -- | 201
@@ -187,12 +202,12 @@ accepted' :: Headers.Headers -> ResponseM
 accepted' = emptyResponse' Status.accepted
 
 -- | 203
-nonAuthoritativeInformation :: Body.Body -> ResponseM
+nonAuthoritativeInformation :: String -> ResponseM
 nonAuthoritativeInformation = nonAuthoritativeInformation' Headers.empty
 
 -- | 203 with headers
 nonAuthoritativeInformation' :: Headers.Headers ->
-                                Body.Body ->
+                                String ->
                                 ResponseM
 nonAuthoritativeInformation' = response' Status.nonAuthoritativeInformation
 
@@ -213,19 +228,19 @@ resetContent' :: Headers.Headers -> ResponseM
 resetContent' = emptyResponse' Status.resetContent
 
 -- | 206
-partialContent :: Body.Body -> ResponseM
+partialContent :: String -> ResponseM
 partialContent = partialContent' Headers.empty
 
 -- | 206 with headers
-partialContent' :: Headers.Headers -> Body.Body -> ResponseM
+partialContent' :: Headers.Headers -> String -> ResponseM
 partialContent' = response' Status.partialContent
 
 -- | 207
-multiStatus :: Body.Body -> ResponseM
+multiStatus :: String -> ResponseM
 multiStatus = multiStatus' Headers.empty
 
 -- | 207 with headers
-multiStatus' :: Headers.Headers -> Body.Body -> ResponseM
+multiStatus' :: Headers.Headers -> String -> ResponseM
 multiStatus' = response' Status.multiStatus
 
 -- | 208
@@ -237,11 +252,11 @@ alreadyReported' :: Headers.Headers -> ResponseM
 alreadyReported' = emptyResponse' Status.alreadyReported
 
 -- | 226
-iMUsed :: Body.Body -> ResponseM
+iMUsed :: String -> ResponseM
 iMUsed = iMUsed' Headers.empty
 
 -- | 226 with headers
-iMUsed' :: Headers.Headers -> Body.Body -> ResponseM
+iMUsed' :: Headers.Headers -> String -> ResponseM
 iMUsed' = response' Status.iMUsed
 
 ---------
@@ -249,35 +264,35 @@ iMUsed' = response' Status.iMUsed
 ---------
 
 -- | 300
-multipleChoices :: Body.Body -> ResponseM
+multipleChoices :: String -> ResponseM
 multipleChoices = multipleChoices' Headers.empty
 
 -- | 300 with headers
-multipleChoices' :: Headers.Headers -> Body.Body -> ResponseM
+multipleChoices' :: Headers.Headers -> String -> ResponseM
 multipleChoices' = response' Status.multipleChoices
 
 -- | 301
-movedPermanently :: Body.Body -> ResponseM
+movedPermanently :: String -> ResponseM
 movedPermanently = movedPermanently' Headers.empty
 
 -- | 301 with headers
-movedPermanently' :: Headers.Headers -> Body.Body -> ResponseM
+movedPermanently' :: Headers.Headers -> String -> ResponseM
 movedPermanently' = response' Status.movedPermanently
 
 -- | 302
-found :: Body.Body -> ResponseM
+found :: String -> ResponseM
 found = found' Headers.empty
 
 -- | 302 with headers
-found' :: Headers.Headers -> Body.Body -> ResponseM
+found' :: Headers.Headers -> String -> ResponseM
 found' = response' Status.found
 
 -- | 303
-seeOther :: Body.Body -> ResponseM
+seeOther :: String -> ResponseM
 seeOther = seeOther' Headers.empty
 
 -- | 303 with headers
-seeOther' :: Headers.Headers -> Body.Body -> ResponseM
+seeOther' :: Headers.Headers -> String -> ResponseM
 seeOther' = response' Status.seeOther
 
 -- | 304
@@ -289,27 +304,27 @@ notModified' :: Headers.Headers -> ResponseM
 notModified' = emptyResponse' Status.notModified
 
 -- | 305
-useProxy :: Body.Body -> ResponseM
+useProxy :: String -> ResponseM
 useProxy = useProxy' Headers.empty
 
 -- | 305 with headers
-useProxy' :: Headers.Headers -> Body.Body -> ResponseM
+useProxy' :: Headers.Headers -> String -> ResponseM
 useProxy' = response' Status.useProxy
 
 -- | 307
-temporaryRedirect :: Body.Body -> ResponseM
+temporaryRedirect :: String -> ResponseM
 temporaryRedirect = temporaryRedirect' Headers.empty
 
 -- | 307 with headers
-temporaryRedirect' :: Headers.Headers -> Body.Body -> ResponseM
+temporaryRedirect' :: Headers.Headers -> String -> ResponseM
 temporaryRedirect' = response' Status.temporaryRedirect
 
 -- | 308
-permanentRedirect :: Body.Body -> ResponseM
+permanentRedirect :: String -> ResponseM
 permanentRedirect = permanentRedirect' Headers.empty
 
 -- | 308 with headers
-permanentRedirect' :: Headers.Headers -> Body.Body -> ResponseM
+permanentRedirect' :: Headers.Headers -> String -> ResponseM
 permanentRedirect' = response' Status.permanentRedirect
 
 
@@ -318,11 +333,11 @@ permanentRedirect' = response' Status.permanentRedirect
 ---------
 
 -- | 400
-badRequest :: Body.Body -> ResponseM
+badRequest :: String -> ResponseM
 badRequest = badRequest' Headers.empty
 
 -- | 400 with headers
-badRequest' :: Headers.Headers -> Body.Body -> ResponseM
+badRequest' :: Headers.Headers -> String -> ResponseM
 badRequest' = response' Status.badRequest
 
 -- | 401
@@ -390,11 +405,11 @@ requestTimeout' :: Headers.Headers -> ResponseM
 requestTimeout' = emptyResponse' Status.requestTimeout
 
 -- | 409
-conflict :: Body.Body -> ResponseM
+conflict :: String -> ResponseM
 conflict = conflict' Headers.empty
 
 -- | 409 with headers
-conflict' :: Headers.Headers -> Body.Body -> ResponseM
+conflict' :: Headers.Headers -> String -> ResponseM
 conflict' = response' Status.conflict
 
 -- | 410
@@ -546,11 +561,11 @@ unavailableForLegalReasons' = emptyResponse' Status.unavailableForLegalReasons
 ---------
 
 -- | 500
-internalServerError :: Body.Body -> ResponseM
+internalServerError :: String -> ResponseM
 internalServerError = internalServerError' Headers.empty
 
 -- | 500 with headers
-internalServerError' :: Headers.Headers -> Body.Body -> ResponseM
+internalServerError' :: Headers.Headers -> String -> ResponseM
 internalServerError' = response' Status.internalServerError
 
 -- | 501

test/Test/HTTPure/BodySpec.purs

@@ -22,7 +22,7 @@ writeSpec = Spec.describe "write" do
   Spec.it "writes the string to the Response body" do
     body <- EffectClass.liftEffect do
       resp <- TestHelpers.mockResponse
-      Body.write resp "test"
+      Body.write resp $ Body.StringBody "test"
       pure $ TestHelpers.getResponseBody resp
     body ?= "test"
 

test/Test/HTTPure/IntegrationSpec.purs

@@ -4,6 +4,8 @@ import Prelude
 
 import Effect.Class as EffectClass
 import Foreign.Object as Object
+import Node.Buffer as Buffer
+import Node.FS.Aff as FS
 import Test.Spec as Spec
 
 import Test.HTTPure.TestHelpers as TestHelpers
@@ -12,6 +14,7 @@ import Test.HTTPure.TestHelpers ((?=))
 import Examples.AsyncResponse.Main as AsyncResponse
 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
@@ -42,6 +45,16 @@ 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
@@ -105,6 +118,7 @@ integrationSpec = Spec.describe "Integration" do
   asyncResponseSpec
   headersSpec
   helloWorldSpec
+  imageSpec
   middlewareSpec
   multiRouteSpec
   pathSegmentsSpec

test/Test/HTTPure/ResponseSpec.purs

@@ -3,8 +3,12 @@ module Test.HTTPure.ResponseSpec where
 import Prelude
 
 import Effect.Class as EffectClass
+import Node.Buffer as Buffer
+import Node.Encoding as Encoding
 import Test.Spec as Spec
+import Test.Spec.Assertions as Assertions
 
+import HTTPure.Body as Body
 import HTTPure.Headers as Headers
 import HTTPure.Response as Response
 
@@ -39,7 +43,11 @@ sendSpec = Spec.describe "send" do
     body ?= "test"
   where
     mockHeaders = Headers.header "Test" "test"
-    mockResponse = { status: 123, headers: mockHeaders, body: "test" }
+    mockResponse =
+      { status: 123
+      , headers: mockHeaders
+      , body: Body.StringBody "test"
+      }
 
 responseFunctionSpec :: TestHelpers.Test
 responseFunctionSpec = Spec.describe "response" do
@@ -51,7 +59,9 @@ responseFunctionSpec = Spec.describe "response" do
     resp.headers ?= Headers.empty
   Spec.it "has the right body" do
     resp <- Response.response 123 "test"
-    resp.body ?= "test"
+    case resp.body of
+      Body.StringBody str -> str ?= "test"
+      _ -> Assertions.fail "String body expected"
 
 response'Spec :: TestHelpers.Test
 response'Spec = Spec.describe "response'" do
@@ -63,11 +73,54 @@ response'Spec = Spec.describe "response'" do
     resp.headers ?= mockHeaders
   Spec.it "has the right body" do
     resp <- mockResponse
-    resp.body ?= "test"
+    case resp.body of
+      Body.StringBody str -> str ?= "test"
+      _ -> Assertions.fail "String body expected"
   where
     mockHeaders = Headers.header "Test" "test"
     mockResponse = Response.response' 123 mockHeaders "test"
 
+binaryResponseSpec :: TestHelpers.Test
+binaryResponseSpec = Spec.describe "binaryResponse" do
+  Spec.it "has the right status" do
+    body <- EffectClass.liftEffect $ Buffer.fromString "test" Encoding.UTF8
+    resp <- Response.binaryResponse 123 body
+    resp.status ?= 123
+  Spec.it "has empty headers" do
+    body <- EffectClass.liftEffect $ Buffer.fromString "test" Encoding.UTF8
+    resp <- Response.binaryResponse 123 body
+    resp.headers ?= Headers.empty
+  Spec.it "has the right body" do
+    body <- EffectClass.liftEffect $ Buffer.fromString "test" Encoding.UTF8
+    resp <- Response.binaryResponse 123 body
+    case resp.body of
+      Body.BinaryBody bin -> do
+        str <- EffectClass.liftEffect $ Buffer.toString Encoding.UTF8 bin
+        str ?= "test"
+      _ -> Assertions.fail "Binary body expected"
+
+binaryResponse'Spec :: TestHelpers.Test
+binaryResponse'Spec = Spec.describe "binaryResponse'" do
+  Spec.it "has the right status" do
+    body <- EffectClass.liftEffect $ Buffer.fromString "test" Encoding.UTF8
+    resp <- mockResponse body
+    resp.status ?= 123
+  Spec.it "has the right headers" do
+    body <- EffectClass.liftEffect $ Buffer.fromString "test" Encoding.UTF8
+    resp <- mockResponse body
+    resp.headers ?= mockHeaders
+  Spec.it "has the right body" do
+    body <- EffectClass.liftEffect $ Buffer.fromString "test" Encoding.UTF8
+    resp <- mockResponse body
+    case resp.body of
+      Body.BinaryBody bin -> do
+        str <- EffectClass.liftEffect $ Buffer.toString Encoding.UTF8 bin
+        str ?= "test"
+      _ -> Assertions.fail "Binary body expected"
+  where
+    mockHeaders = Headers.header "Test" "test"
+    mockResponse = Response.binaryResponse' 123 mockHeaders
+
 emptyResponseSpec :: TestHelpers.Test
 emptyResponseSpec = Spec.describe "emptyResponse" do
   Spec.it "has the right status" do
@@ -78,7 +131,9 @@ emptyResponseSpec = Spec.describe "emptyResponse" do
     resp.headers ?= Headers.empty
   Spec.it "has an empty body" do
     resp <- Response.emptyResponse 123
-    resp.body ?= ""
+    case resp.body of
+      Body.StringBody str -> str ?= ""
+      _ -> Assertions.fail "String body expected"
 
 emptyResponse'Spec :: TestHelpers.Test
 emptyResponse'Spec = Spec.describe "emptyResponse'" do
@@ -90,7 +145,9 @@ emptyResponse'Spec = Spec.describe "emptyResponse'" do
     resp.headers ?= mockHeaders
   Spec.it "has an empty body" do
     resp <- mockResponse
-    resp.body ?= ""
+    case resp.body of
+      Body.StringBody str -> str ?= ""
+      _ -> Assertions.fail "String body expected"
   where
     mockHeaders = Headers.header "Test" "test"
     mockResponse = Response.emptyResponse' 123 mockHeaders
@@ -100,5 +157,7 @@ responseSpec = Spec.describe "Response" do
   sendSpec
   responseFunctionSpec
   response'Spec
+  binaryResponseSpec
+  binaryResponse'Spec
   emptyResponseSpec
   emptyResponse'Spec

test/Test/HTTPure/TestHelpers.purs

@@ -6,12 +6,15 @@ import Effect as Effect
 import Effect.Aff as Aff
 import Effect.Class as EffectClass
 import Effect.Ref as Ref
+import Data.Array as Array
 import Data.Either as Either
+import Data.List as List
 import Data.Maybe as Maybe
 import Data.Options ((:=))
 import Data.String as StringUtil
 import Data.Tuple as Tuple
 import Foreign.Object as Object
+import Node.Buffer as Buffer
 import Node.Encoding as Encoding
 import Node.HTTP as HTTP
 import Node.HTTP.Client as HTTPClient
@@ -53,19 +56,23 @@ request secure port method headers path body = Aff.makeAff \done -> do
       HTTPClient.headers  := HTTPClient.RequestHeaders headers <>
       HTTPClient.rejectUnauthorized := false
 
--- | Given an ST String buffer and a new string, concatenate that new string
--- | onto the ST buffer.
-concat :: Ref.Ref String -> String -> Effect.Effect Unit
-concat buf new = void $ Ref.modify ((<>) new) buf
+-- | Convert a request to an Aff containing the `Buffer with the response body.
+toBuffer :: HTTPClient.Response -> Aff.Aff Buffer.Buffer
+toBuffer response = Aff.makeAff \done -> do
+  let stream = HTTPClient.responseAsStream response
+  chunks <- Ref.new List.Nil
+  Stream.onData stream $ \new -> Ref.modify_ (List.Cons new) chunks
+  Stream.onEnd stream $
+    Ref.read chunks
+    >>= List.reverse >>> Array.fromFoldable >>> Buffer.concat
+    >>= Either.Right >>> done
+  pure $ Aff.nonCanceler
 
 -- | Convert a request to an Aff containing the string with the response body.
 toString :: HTTPClient.Response -> Aff.Aff String
-toString response = Aff.makeAff \done -> do
-  let stream = HTTPClient.responseAsStream response
-  buf <- Ref.new ""
-  Stream.onDataString stream Encoding.UTF8 $ concat buf
-  Stream.onEnd stream $ Ref.read buf >>= Either.Right >>> done
-  pure $ Aff.nonCanceler
+toString resp = do
+  buf <- toBuffer resp
+  EffectClass.liftEffect $ Buffer.toString Encoding.UTF8 buf
 
 -- | Run an HTTP GET with the given url and return an Aff that contains the
 -- | string with the response body.
@@ -75,6 +82,14 @@ get :: Int ->
        Aff.Aff String
 get port headers path = request false port "GET" headers path "" >>= toString
 
+-- | Like `get` but return a response body in a `Buffer`
+getBinary :: Int ->
+             Object.Object String ->
+             String ->
+             Aff.Aff Buffer.Buffer
+getBinary port headers path =
+  request false port "GET" headers path "" >>= toBuffer
+
 -- | Run an HTTPS GET with the given url and return an Aff that contains the
 -- | string with the response body.
 get' :: Int ->