/
Body.purs
146 lines (135 loc) · 5.07 KB
/
Body.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
module HTTPurple.Body
( class Body
, RequestBody
, defaultHeaders
, write
, read
, toBuffer
, toStream
, toString
) where
import Prelude
import Data.Either (Either(Right))
import Data.Maybe (Maybe(Just, Nothing))
import Effect (Effect)
import Effect.Aff (Aff, makeAff, nonCanceler)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (liftEffect)
import Effect.Ref (Ref)
import Effect.Ref (modify, new, read, write) as Ref
import HTTPurple.Headers (RequestHeaders, mkRequestHeader)
import Node.Buffer (Buffer, concat, fromString, size)
import Node.Buffer (toString) as Buffer
import Node.Encoding (Encoding(UTF8))
import Node.HTTP (Request, Response, requestAsStream, responseAsStream)
import Node.Stream (Readable, Stream, end, onData, onEnd, pipe, writeString)
import Node.Stream (write) as Stream
import Type.Equality (class TypeEquals, to)
type RequestBody =
{ buffer :: Ref (Maybe Buffer)
, stream :: Readable ()
, string :: Ref (Maybe String)
}
-- | Read the body `Readable` stream out of the incoming request
read :: Request -> Effect RequestBody
read request = do
buffer <- Ref.new Nothing
string <- Ref.new Nothing
pure
{ buffer
, stream: requestAsStream request
, string
}
-- | Turn `RequestBody` into a `String`
-- |
-- | This drains the `Readable` stream in `RequestBody` for the first time
-- | and returns cached result from then on.
toString :: forall m. MonadAff m => RequestBody -> m String
toString requestBody = do
maybeString <-
liftEffect
$ Ref.read requestBody.string
case maybeString of
Nothing -> do
buffer <- toBuffer requestBody
string <- liftEffect
$ Buffer.toString UTF8 buffer
liftEffect
$ Ref.write (Just string) requestBody.string
pure string
Just string -> pure string
-- | Turn `RequestBody` into a `Buffer`
-- |
-- | This drains the `Readable` stream in `RequestBody` for the first time
-- | and returns cached result from then on.
toBuffer :: forall m. MonadAff m => RequestBody -> m Buffer
toBuffer requestBody = do
maybeBuffer <-
liftEffect
$ Ref.read requestBody.buffer
case maybeBuffer of
Nothing -> do
buffer <- streamToBuffer requestBody.stream
liftEffect
$ Ref.write (Just buffer) requestBody.buffer
pure buffer
Just buffer -> pure buffer
where
-- | Slurp the entire `Readable` stream into a `Buffer`
streamToBuffer :: MonadAff m => Readable () -> m Buffer
streamToBuffer stream =
liftAff $ makeAff \done -> do
bufs <- Ref.new []
onData stream \buf -> void $ Ref.modify (_ <> [ buf ]) bufs
onEnd stream do
body <- Ref.read bufs >>= concat
done $ Right body
pure nonCanceler
-- | Return the `Readable` stream directly from `RequestBody`
toStream :: RequestBody -> Readable ()
toStream = _.stream
-- | Types that implement the `Body` class can be used as a body to an HTTPurple
-- | response, and can be used with all the response helpers.
class Body b where
-- | 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 RequestHeaders
-- | Given a body value and a Node HTTP `Response` value, write the body value
-- | to the Node response.
write :: b -> Response -> Aff Unit
-- | The instance for `String` will convert the string to a buffer first in
-- | 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 Body String where
defaultHeaders body = do
buf :: Buffer <- fromString body UTF8
defaultHeaders buf
write body response = makeAff \done -> do
let stream = responseAsStream response
void $ writeString stream UTF8 body $ const $ end stream $ const $ done $ Right unit
pure nonCanceler
-- | 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 Body Buffer where
defaultHeaders buf = mkRequestHeader "Content-Length" <$> show <$> size buf
write body response = makeAff \done -> do
let stream = responseAsStream response
void $ Stream.write stream body $ const $ end stream $ const $ done $ Right unit
pure 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
TypeEquals (Stream r) (Readable s) =>
Body (Stream r) where
defaultHeaders _ = pure $ mkRequestHeader "Transfer-Encoding" "chunked"
write body response = makeAff \done -> do
let stream = to body
void $ pipe stream $ responseAsStream response
onEnd stream $ done $ Right unit
pure nonCanceler