Update node libs (tests do not pass)
This commit is contained in:
parent
791a18c749
commit
4667feefa4
3
.vscode/settings.json
vendored
Normal file
3
.vscode/settings.json
vendored
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
{
|
||||||
|
"purescript.buildCommand": "spago -x test.dhall build --purs-args --json-errors"
|
||||||
|
}
|
@ -10,6 +10,7 @@
|
|||||||
, "either"
|
, "either"
|
||||||
, "exceptions"
|
, "exceptions"
|
||||||
, "foldable-traversable"
|
, "foldable-traversable"
|
||||||
|
, "foreign"
|
||||||
, "foreign-object"
|
, "foreign-object"
|
||||||
, "functions"
|
, "functions"
|
||||||
, "js-uri"
|
, "js-uri"
|
||||||
@ -19,7 +20,9 @@
|
|||||||
, "maybe"
|
, "maybe"
|
||||||
, "newtype"
|
, "newtype"
|
||||||
, "node-buffer"
|
, "node-buffer"
|
||||||
|
, "node-event-emitter"
|
||||||
, "node-fs"
|
, "node-fs"
|
||||||
|
, "node-net"
|
||||||
, "node-http"
|
, "node-http"
|
||||||
, "node-process"
|
, "node-process"
|
||||||
, "node-streams"
|
, "node-streams"
|
||||||
|
@ -18,14 +18,19 @@ import Effect.Aff (Aff, makeAff, nonCanceler)
|
|||||||
import Effect.Aff.Class (class MonadAff, liftAff)
|
import Effect.Aff.Class (class MonadAff, liftAff)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Effect.Ref (Ref)
|
import Effect.Ref (Ref)
|
||||||
import Effect.Ref (modify, new, read, write) as Ref
|
import Effect.Ref (new, read, write) as Ref
|
||||||
import HTTPurple.Headers (RequestHeaders, mkRequestHeader)
|
import HTTPurple.Headers (RequestHeaders, mkRequestHeader)
|
||||||
import Node.Buffer (Buffer, concat, fromString, size)
|
import Node.Buffer (Buffer, fromString, size)
|
||||||
import Node.Buffer (toString) as Buffer
|
import Node.Buffer (concat, toString) as Buffer
|
||||||
import Node.Encoding (Encoding(UTF8))
|
import Node.Encoding (Encoding(UTF8))
|
||||||
import Node.HTTP (Request, Response, requestAsStream, responseAsStream)
|
import Node.EventEmitter (once_)
|
||||||
import Node.Stream (Readable, Stream, end, onData, onEnd, pipe, writeString)
|
import Node.HTTP.IncomingMessage as IM
|
||||||
import Node.Stream (write) as Stream
|
import Node.HTTP.OutgoingMessage as OM
|
||||||
|
import Node.HTTP.ServerResponse as SR
|
||||||
|
import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse)
|
||||||
|
import Node.Stream (Readable, Stream, end', pipe, writeString')
|
||||||
|
import Node.Stream (endH, write') as Stream
|
||||||
|
import Node.Stream.Aff (readableToBuffers)
|
||||||
import Type.Equality (class TypeEquals, to)
|
import Type.Equality (class TypeEquals, to)
|
||||||
|
|
||||||
type RequestBody =
|
type RequestBody =
|
||||||
@ -35,13 +40,13 @@ type RequestBody =
|
|||||||
}
|
}
|
||||||
|
|
||||||
-- | Read the body `Readable` stream out of the incoming request
|
-- | Read the body `Readable` stream out of the incoming request
|
||||||
read :: Request -> Effect RequestBody
|
read :: IncomingMessage IMServer -> Effect RequestBody
|
||||||
read request = do
|
read request = do
|
||||||
buffer <- Ref.new Nothing
|
buffer <- Ref.new Nothing
|
||||||
string <- Ref.new Nothing
|
string <- Ref.new Nothing
|
||||||
pure
|
pure
|
||||||
{ buffer
|
{ buffer
|
||||||
, stream: requestAsStream request
|
, stream: IM.toReadable request
|
||||||
, string
|
, string
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -75,22 +80,12 @@ toBuffer requestBody = do
|
|||||||
$ Ref.read requestBody.buffer
|
$ Ref.read requestBody.buffer
|
||||||
case maybeBuffer of
|
case maybeBuffer of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
buffer <- streamToBuffer requestBody.stream
|
buffers <- liftAff $ readableToBuffers requestBody.stream
|
||||||
liftEffect
|
liftEffect do
|
||||||
$ Ref.write (Just buffer) requestBody.buffer
|
buffer <- Buffer.concat buffers
|
||||||
pure buffer
|
Ref.write (Just buffer) requestBody.buffer
|
||||||
|
pure buffer
|
||||||
Just 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`
|
-- | Return the `Readable` stream directly from `RequestBody`
|
||||||
toStream :: RequestBody -> Readable ()
|
toStream :: RequestBody -> Readable ()
|
||||||
@ -106,7 +101,7 @@ class Body b where
|
|||||||
defaultHeaders :: b -> Effect RequestHeaders
|
defaultHeaders :: b -> Effect RequestHeaders
|
||||||
-- | Given a body value and a Node HTTP `Response` value, write the body value
|
-- | Given a body value and a Node HTTP `Response` value, write the body value
|
||||||
-- | to the Node response.
|
-- | to the Node response.
|
||||||
write :: b -> Response -> Aff Unit
|
write :: b -> ServerResponse -> Aff Unit
|
||||||
|
|
||||||
-- | The instance for `String` will convert the string to a buffer first in
|
-- | 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
|
-- | order to determine it's additional headers. This is to ensure that the
|
||||||
@ -118,8 +113,8 @@ instance Body String where
|
|||||||
buf :: Buffer <- fromString body UTF8
|
buf :: Buffer <- fromString body UTF8
|
||||||
defaultHeaders buf
|
defaultHeaders buf
|
||||||
write body response = makeAff \done -> do
|
write body response = makeAff \done -> do
|
||||||
let stream = responseAsStream response
|
let stream = OM.toWriteable $ SR.toOutgoingMessage response
|
||||||
void $ writeString stream UTF8 body $ const $ end stream $ const $ done $ Right unit
|
void $ writeString' stream UTF8 body $ const $ end' stream $ const $ done $ Right unit
|
||||||
pure nonCanceler
|
pure nonCanceler
|
||||||
|
|
||||||
-- | The instance for `Buffer` is trivial--we add a `Content-Length` header
|
-- | The instance for `Buffer` is trivial--we add a `Content-Length` header
|
||||||
@ -128,8 +123,8 @@ instance Body String where
|
|||||||
instance Body Buffer where
|
instance Body Buffer where
|
||||||
defaultHeaders buf = mkRequestHeader "Content-Length" <$> show <$> size buf
|
defaultHeaders buf = mkRequestHeader "Content-Length" <$> show <$> size buf
|
||||||
write body response = makeAff \done -> do
|
write body response = makeAff \done -> do
|
||||||
let stream = responseAsStream response
|
let stream = OM.toWriteable $ SR.toOutgoingMessage response
|
||||||
void $ Stream.write stream body $ const $ end stream $ const $ done $ Right unit
|
void $ Stream.write' stream body $ const $ end' stream $ const $ done $ Right unit
|
||||||
pure nonCanceler
|
pure nonCanceler
|
||||||
|
|
||||||
-- | This instance can be used to send chunked data. Here, we add a
|
-- | This instance can be used to send chunked data. Here, we add a
|
||||||
@ -141,6 +136,6 @@ instance
|
|||||||
defaultHeaders _ = pure $ mkRequestHeader "Transfer-Encoding" "chunked"
|
defaultHeaders _ = pure $ mkRequestHeader "Transfer-Encoding" "chunked"
|
||||||
write body response = makeAff \done -> do
|
write body response = makeAff \done -> do
|
||||||
let stream = to body
|
let stream = to body
|
||||||
void $ pipe stream $ responseAsStream response
|
void $ pipe stream $ OM.toWriteable $ SR.toOutgoingMessage response
|
||||||
onEnd stream $ done $ Right unit
|
stream # once_ Stream.endH (done $ Right unit)
|
||||||
pure nonCanceler
|
pure nonCanceler
|
||||||
|
@ -29,7 +29,10 @@ import Data.Tuple (Tuple(Tuple))
|
|||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Foreign.Object (fold)
|
import Foreign.Object (fold)
|
||||||
import HTTPurple.Lookup (class Lookup, (!!))
|
import HTTPurple.Lookup (class Lookup, (!!))
|
||||||
import Node.HTTP (Request, Response, requestHeaders, setHeaders)
|
import Node.HTTP.IncomingMessage as IM
|
||||||
|
import Node.HTTP.OutgoingMessage (setHeader')
|
||||||
|
import Node.HTTP.ServerResponse (toOutgoingMessage)
|
||||||
|
import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse)
|
||||||
import Prim.Row as Row
|
import Prim.Row as Row
|
||||||
import Prim.RowList (class RowToList, Cons, Nil)
|
import Prim.RowList (class RowToList, Cons, Nil)
|
||||||
import Record as Record
|
import Record as Record
|
||||||
@ -84,17 +87,18 @@ instance Eq ResponseHeaders where
|
|||||||
eq (ResponseHeaders a) (ResponseHeaders b) = eq a b
|
eq (ResponseHeaders a) (ResponseHeaders b) = eq a b
|
||||||
|
|
||||||
-- | Get the headers out of a HTTP `RequestHeaders` object.
|
-- | Get the headers out of a HTTP `RequestHeaders` object.
|
||||||
read :: Request -> RequestHeaders
|
read :: IncomingMessage IMServer -> RequestHeaders
|
||||||
read = requestHeaders >>> fold insertField Map.empty >>> RequestHeaders
|
read = IM.headers >>> fold insertField Map.empty >>> RequestHeaders
|
||||||
where
|
where
|
||||||
insertField x key value = insert (CaseInsensitiveString key) value x
|
insertField x key value = insert (CaseInsensitiveString key) value x
|
||||||
|
|
||||||
-- | Given an HTTP `Response` and a `ResponseHeaders` object, return an effect that will
|
-- | Given an HTTP `Response` and a `ResponseHeaders` object, return an effect that will
|
||||||
-- | write the `ResponseHeaders` to the `Response`.
|
-- | write the `ResponseHeaders` to the `Response`.
|
||||||
write :: Response -> ResponseHeaders -> Effect Unit
|
write :: ServerResponse -> ResponseHeaders -> Effect Unit
|
||||||
write response (ResponseHeaders headers') = void $ traverseWithIndex writeField headers'
|
write response (ResponseHeaders headers') = void $ traverseWithIndex writeField headers'
|
||||||
where
|
where
|
||||||
writeField key values = setHeaders response (unwrap key) values
|
om = toOutgoingMessage response
|
||||||
|
writeField key values = om # setHeader' (unwrap key) values
|
||||||
|
|
||||||
-- | Return a `ResponseHeaders` containing no headers.
|
-- | Return a `ResponseHeaders` containing no headers.
|
||||||
empty :: ResponseHeaders
|
empty :: ResponseHeaders
|
||||||
|
@ -5,7 +5,8 @@ module HTTPurple.Method
|
|||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Node.HTTP (Request, requestMethod)
|
import Node.HTTP.IncomingMessage (method)
|
||||||
|
import Node.HTTP.Types (IMServer, IncomingMessage)
|
||||||
|
|
||||||
-- | These are the HTTP methods that HTTPurple understands.
|
-- | These are the HTTP methods that HTTPurple understands.
|
||||||
data Method
|
data Method
|
||||||
@ -35,8 +36,8 @@ instance showMethod :: Show Method where
|
|||||||
show Patch = "Patch"
|
show Patch = "Patch"
|
||||||
|
|
||||||
-- | Take an HTTP `Request` and extract the `Method` for that request.
|
-- | Take an HTTP `Request` and extract the `Method` for that request.
|
||||||
read :: Request -> Method
|
read :: IncomingMessage IMServer -> Method
|
||||||
read = requestMethod >>> case _ of
|
read = method >>> case _ of
|
||||||
"POST" -> Post
|
"POST" -> Post
|
||||||
"PUT" -> Put
|
"PUT" -> Put
|
||||||
"DELETE" -> Delete
|
"DELETE" -> Delete
|
||||||
|
@ -24,20 +24,20 @@ import Effect.Exception (Error)
|
|||||||
import Effect.Ref as Ref
|
import Effect.Ref as Ref
|
||||||
import Effect.Uncurried (EffectFn1, EffectFn3, mkEffectFn1, runEffectFn1, runEffectFn3)
|
import Effect.Uncurried (EffectFn1, EffectFn3, mkEffectFn1, runEffectFn1, runEffectFn3)
|
||||||
import Literals.Undefined (Undefined, undefined)
|
import Literals.Undefined (Undefined, undefined)
|
||||||
import Node.HTTP as HTTP
|
import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse)
|
||||||
import Prim.Row (class Union)
|
import Prim.Row (class Union)
|
||||||
import Untagged.Union (type (|+|), UndefinedOr, asOneOf, uorToMaybe)
|
import Untagged.Union (type (|+|), UndefinedOr, asOneOf, uorToMaybe)
|
||||||
|
|
||||||
newtype NodeMiddleware :: forall k. k -> Type
|
newtype NodeMiddleware :: forall k. k -> Type
|
||||||
newtype NodeMiddleware extended =
|
newtype NodeMiddleware extended =
|
||||||
NodeMiddleware (EffectFn3 HTTP.Request HTTP.Response (EffectFn1 (UndefinedOr Error) Unit) (Effect Unit))
|
NodeMiddleware (EffectFn3 (IncomingMessage IMServer) ServerResponse (EffectFn1 (UndefinedOr Error) Unit) (Effect Unit))
|
||||||
|
|
||||||
derive instance Newtype (NodeMiddleware extended) _
|
derive instance Newtype (NodeMiddleware extended) _
|
||||||
|
|
||||||
data NextInvocation = NotCalled | ProcessingFailed Error | ProcessingSucceeded
|
data NextInvocation = NotCalled | ProcessingFailed Error | ProcessingSucceeded
|
||||||
|
|
||||||
type MiddlewareResultR =
|
type MiddlewareResultR =
|
||||||
(request :: HTTP.Request, response :: HTTP.Response, middlewareResult :: NextInvocation)
|
(request :: IncomingMessage IMServer, response :: ServerResponse, middlewareResult :: NextInvocation)
|
||||||
|
|
||||||
newtype MiddlewareResult :: forall k. k -> Type
|
newtype MiddlewareResult :: forall k. k -> Type
|
||||||
newtype MiddlewareResult input = MiddlewareResult { | MiddlewareResultR }
|
newtype MiddlewareResult input = MiddlewareResult { | MiddlewareResultR }
|
||||||
|
@ -9,7 +9,8 @@ import Data.Array (filter, head)
|
|||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.String (Pattern(Pattern), split)
|
import Data.String (Pattern(Pattern), split)
|
||||||
import HTTPurple.Utils (urlDecode)
|
import HTTPurple.Utils (urlDecode)
|
||||||
import Node.HTTP (Request, requestURL)
|
import Node.HTTP.IncomingMessage (url)
|
||||||
|
import Node.HTTP.Types (IMServer, IncomingMessage)
|
||||||
|
|
||||||
-- | The `Path` type is just sugar for an `Array` of `String` segments that are
|
-- | The `Path` type is just sugar for an `Array` of `String` segments that are
|
||||||
-- | sent in a request and indicates the path of the resource being requested.
|
-- | sent in a request and indicates the path of the resource being requested.
|
||||||
@ -20,8 +21,8 @@ import Node.HTTP (Request, requestURL)
|
|||||||
type Path = Array String
|
type Path = Array String
|
||||||
|
|
||||||
-- | Given an HTTP `Request` object, extract the `Path`.
|
-- | Given an HTTP `Request` object, extract the `Path`.
|
||||||
read :: Request -> Path
|
read :: IncomingMessage IMServer -> Path
|
||||||
read = requestURL >>> split' "?" >>> first >>> split' "/" >>> nonempty >>> map urlDecode
|
read = url >>> split' "?" >>> first >>> split' "/" >>> nonempty >>> map urlDecode
|
||||||
where
|
where
|
||||||
nonempty = filter ((/=) "")
|
nonempty = filter ((/=) "")
|
||||||
split' = Pattern >>> split
|
split' = Pattern >>> split
|
||||||
|
@ -12,7 +12,8 @@ import Data.String (Pattern(Pattern), joinWith, split)
|
|||||||
import Data.Tuple (Tuple(Tuple))
|
import Data.Tuple (Tuple(Tuple))
|
||||||
import Foreign.Object (Object, fromFoldable)
|
import Foreign.Object (Object, fromFoldable)
|
||||||
import HTTPurple.Utils (replacePlus, urlDecode)
|
import HTTPurple.Utils (replacePlus, urlDecode)
|
||||||
import Node.HTTP (Request, requestURL)
|
import Node.HTTP.IncomingMessage (url)
|
||||||
|
import Node.HTTP.Types (IMServer, IncomingMessage)
|
||||||
|
|
||||||
-- | The `Query` type is a `Object` of `Strings`, with one entry per query
|
-- | The `Query` type is a `Object` of `Strings`, with one entry per query
|
||||||
-- | parameter in the request. For any query parameters that don't have values
|
-- | parameter in the request. For any query parameters that don't have values
|
||||||
@ -25,8 +26,8 @@ import Node.HTTP (Request, requestURL)
|
|||||||
type Query = Object String
|
type Query = Object String
|
||||||
|
|
||||||
-- | The `Map` of query segments in the given HTTP `Request`.
|
-- | The `Map` of query segments in the given HTTP `Request`.
|
||||||
read :: Request -> Query
|
read :: IncomingMessage IMServer -> Query
|
||||||
read = requestURL >>> split' "?" >>> last >>> split' "&" >>> nonempty >>> toObject
|
read = url >>> split' "?" >>> last >>> split' "&" >>> nonempty >>> toObject
|
||||||
where
|
where
|
||||||
toObject = map toTuple >>> fromFoldable
|
toObject = map toTuple >>> fromFoldable
|
||||||
nonempty = filter ((/=) "")
|
nonempty = filter ((/=) "")
|
||||||
|
@ -32,8 +32,8 @@ import HTTPurple.Query (read) as Query
|
|||||||
import HTTPurple.Utils (encodeURIComponent)
|
import HTTPurple.Utils (encodeURIComponent)
|
||||||
import HTTPurple.Version (Version)
|
import HTTPurple.Version (Version)
|
||||||
import HTTPurple.Version (read) as Version
|
import HTTPurple.Version (read) as Version
|
||||||
import Node.HTTP (Request) as HTTP
|
import Node.HTTP.IncomingMessage as IM
|
||||||
import Node.HTTP (requestURL)
|
import Node.HTTP.Types (IMServer, IncomingMessage)
|
||||||
import Prim.Row (class Nub, class Union)
|
import Prim.Row (class Nub, class Union)
|
||||||
import Prim.RowList (class RowToList)
|
import Prim.RowList (class RowToList)
|
||||||
import Record (merge)
|
import Record (merge)
|
||||||
@ -81,7 +81,7 @@ fullPath { path: p, query } = "/" <> path <> questionMark <> queryParams
|
|||||||
queryParamsArr = toArrayWithKey stringifyQueryParam query
|
queryParamsArr = toArrayWithKey stringifyQueryParam query
|
||||||
stringifyQueryParam key value = encodeURIComponent key <> "=" <> encodeURIComponent value
|
stringifyQueryParam key value = encodeURIComponent key <> "=" <> encodeURIComponent value
|
||||||
|
|
||||||
mkRequest :: forall route m. MonadEffect m => HTTP.Request -> route -> m (Request route)
|
mkRequest :: forall route m. MonadEffect m => IncomingMessage IMServer -> route -> m (Request route)
|
||||||
mkRequest request route = do
|
mkRequest request route = do
|
||||||
body <- liftEffect $ Body.read request
|
body <- liftEffect $ Body.read request
|
||||||
pure
|
pure
|
||||||
@ -92,17 +92,17 @@ mkRequest request route = do
|
|||||||
, headers: Headers.read request
|
, headers: Headers.read request
|
||||||
, body
|
, body
|
||||||
, httpVersion: Version.read request
|
, httpVersion: Version.read request
|
||||||
, url: requestURL request
|
, url: IM.url request
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Given an HTTP `Request` object, this method will convert it to an HTTPurple
|
-- | Given an HTTP `Request` object, this method will convert it to an HTTPurple
|
||||||
-- | `Request` object.
|
-- | `Request` object.
|
||||||
fromHTTPRequest :: forall route. RD.RouteDuplex' route -> HTTP.Request -> Aff (Either (Request Unit) (Request route))
|
fromHTTPRequest :: forall route. RD.RouteDuplex' route -> IncomingMessage IMServer -> Aff (Either (Request Unit) (Request route))
|
||||||
fromHTTPRequest route request = do
|
fromHTTPRequest route request = do
|
||||||
RD.parse route (requestURL request) #
|
RD.parse route (IM.url request) #
|
||||||
bitraverse (const $ mkRequest request unit) (mkRequest request)
|
bitraverse (const $ mkRequest request unit) (mkRequest request)
|
||||||
|
|
||||||
fromHTTPRequestUnit :: HTTP.Request -> Aff (Request Unit)
|
fromHTTPRequestUnit :: IncomingMessage IMServer -> Aff (Request Unit)
|
||||||
fromHTTPRequestUnit = flip mkRequest unit
|
fromHTTPRequestUnit = flip mkRequest unit
|
||||||
|
|
||||||
fromHTTPRequestExt ::
|
fromHTTPRequestExt ::
|
||||||
@ -113,7 +113,7 @@ fromHTTPRequestExt ::
|
|||||||
Keys ctx =>
|
Keys ctx =>
|
||||||
RD.RouteDuplex' route ->
|
RD.RouteDuplex' route ->
|
||||||
Proxy ctx ->
|
Proxy ctx ->
|
||||||
HTTP.Request ->
|
IncomingMessage IMServer ->
|
||||||
Aff (Either (Request Unit) (ExtRequestNT route ctx))
|
Aff (Either (Request Unit) (ExtRequestNT route ctx))
|
||||||
fromHTTPRequestExt route _ nodeRequest = do
|
fromHTTPRequestExt route _ nodeRequest = do
|
||||||
let
|
let
|
||||||
|
@ -143,7 +143,7 @@ import HTTPurple.Headers (ResponseHeaders, empty, toResponseHeaders)
|
|||||||
import HTTPurple.Headers (write) as Headers
|
import HTTPurple.Headers (write) as Headers
|
||||||
import HTTPurple.Status (Status)
|
import HTTPurple.Status (Status)
|
||||||
import HTTPurple.Status (accepted, alreadyReported, badGateway, badRequest, conflict, continue, created, expectationFailed, failedDependency, forbidden, found, gatewayTimeout, gone, hTTPVersionNotSupported, iMUsed, imATeapot, insufficientStorage, internalServerError, lengthRequired, locked, loopDetected, methodNotAllowed, misdirectedRequest, movedPermanently, multiStatus, multipleChoices, networkAuthenticationRequired, noContent, nonAuthoritativeInformation, notAcceptable, notExtended, notFound, notImplemented, notModified, ok, partialContent, payloadTooLarge, paymentRequired, permanentRedirect, preconditionFailed, preconditionRequired, processing, proxyAuthenticationRequired, rangeNotSatisfiable, requestHeaderFieldsTooLarge, requestTimeout, resetContent, seeOther, serviceUnavailable, switchingProtocols, temporaryRedirect, tooManyRequests, uRITooLong, unauthorized, unavailableForLegalReasons, unprocessableEntity, unsupportedMediaType, upgradeRequired, useProxy, variantAlsoNegotiates, write) as Status
|
import HTTPurple.Status (accepted, alreadyReported, badGateway, badRequest, conflict, continue, created, expectationFailed, failedDependency, forbidden, found, gatewayTimeout, gone, hTTPVersionNotSupported, iMUsed, imATeapot, insufficientStorage, internalServerError, lengthRequired, locked, loopDetected, methodNotAllowed, misdirectedRequest, movedPermanently, multiStatus, multipleChoices, networkAuthenticationRequired, noContent, nonAuthoritativeInformation, notAcceptable, notExtended, notFound, notImplemented, notModified, ok, partialContent, payloadTooLarge, paymentRequired, permanentRedirect, preconditionFailed, preconditionRequired, processing, proxyAuthenticationRequired, rangeNotSatisfiable, requestHeaderFieldsTooLarge, requestTimeout, resetContent, seeOther, serviceUnavailable, switchingProtocols, temporaryRedirect, tooManyRequests, uRITooLong, unauthorized, unavailableForLegalReasons, unprocessableEntity, unsupportedMediaType, upgradeRequired, useProxy, variantAlsoNegotiates, write) as Status
|
||||||
import Node.HTTP (Response) as HTTP
|
import Node.HTTP.Types (ServerResponse)
|
||||||
|
|
||||||
-- | The `ResponseM` type simply conveniently wraps up an HTTPurple monad that
|
-- | The `ResponseM` type simply conveniently wraps up an HTTPurple monad that
|
||||||
-- | returns a response. This type is the return type of all router/route
|
-- | returns a response. This type is the return type of all router/route
|
||||||
@ -154,13 +154,13 @@ type ResponseM = Aff Response
|
|||||||
type Response =
|
type Response =
|
||||||
{ status :: Status
|
{ status :: Status
|
||||||
, headers :: ResponseHeaders
|
, headers :: ResponseHeaders
|
||||||
, writeBody :: HTTP.Response -> Aff Unit
|
, writeBody :: ServerResponse -> Aff Unit
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Given an HTTP `Response` and a HTTPurple `Response`, this method will return
|
-- | Given an HTTP `Response` and a HTTPurple `Response`, this method will return
|
||||||
-- | a monad encapsulating writing the HTTPurple `Response` to the HTTP `Response`
|
-- | a monad encapsulating writing the HTTPurple `Response` to the HTTP `Response`
|
||||||
-- | and closing the HTTP `Response`.
|
-- | and closing the HTTP `Response`.
|
||||||
send :: forall m. MonadEffect m => MonadAff m => HTTP.Response -> Response -> m Unit
|
send :: forall m. MonadEffect m => MonadAff m => ServerResponse -> Response -> m Unit
|
||||||
send httpresponse { status, headers, writeBody } = do
|
send httpresponse { status, headers, writeBody } = do
|
||||||
liftEffect $ Status.write httpresponse status
|
liftEffect $ Status.write httpresponse status
|
||||||
liftEffect $ Headers.write httpresponse headers
|
liftEffect $ Headers.write httpresponse headers
|
||||||
|
@ -17,7 +17,6 @@ import Prelude
|
|||||||
import Control.Monad.Cont (runContT)
|
import Control.Monad.Cont (runContT)
|
||||||
import Data.Maybe (Maybe(..), fromMaybe)
|
import Data.Maybe (Maybe(..), fromMaybe)
|
||||||
import Data.Newtype (unwrap)
|
import Data.Newtype (unwrap)
|
||||||
import Data.Options ((:=))
|
|
||||||
import Data.Posix.Signal (Signal(..))
|
import Data.Posix.Signal (Signal(..))
|
||||||
import Data.Profunctor (lcmap)
|
import Data.Profunctor (lcmap)
|
||||||
import Data.Profunctor.Choice ((|||))
|
import Data.Profunctor.Choice ((|||))
|
||||||
@ -33,13 +32,16 @@ import HTTPurple.Response (Response, ResponseM, internalServerError, notFound, s
|
|||||||
import Justifill (justifill)
|
import Justifill (justifill)
|
||||||
import Justifill.Fillable (class FillableFields)
|
import Justifill.Fillable (class FillableFields)
|
||||||
import Justifill.Justifiable (class JustifiableFields)
|
import Justifill.Justifiable (class JustifiableFields)
|
||||||
import Node.Encoding (Encoding(UTF8))
|
import Node.EventEmitter as EE
|
||||||
import Node.FS.Sync (readTextFile)
|
import Node.FS.Sync (readFile)
|
||||||
import Node.HTTP (ListenOptions, Request, Response, createServer) as HTTP
|
import Node.HTTP as HTTP
|
||||||
import Node.HTTP (close, listen)
|
import Node.HTTP.Server as HServer
|
||||||
import Node.HTTP.Secure (cert, certString, key, keyString)
|
import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse)
|
||||||
import Node.HTTP.Secure (createServer) as HTTPS
|
import Node.HTTPS as HTTPS
|
||||||
import Node.Process (onSignal)
|
import Node.Net.Server (listenTcp, listeningH)
|
||||||
|
import Node.Net.Server as NServer
|
||||||
|
import Node.Process (mkSignalH)
|
||||||
|
import Node.Process as Process
|
||||||
import Prim.Row (class Nub, class Union)
|
import Prim.Row (class Nub, class Union)
|
||||||
import Prim.RowList (class RowToList)
|
import Prim.RowList (class RowToList)
|
||||||
import Record (merge)
|
import Record (merge)
|
||||||
@ -101,8 +103,8 @@ defaultMiddlewareErrorHandler err _ = do
|
|||||||
-- | handle requests without a routing adt.
|
-- | handle requests without a routing adt.
|
||||||
handleRequestUnit ::
|
handleRequestUnit ::
|
||||||
(Request Unit -> ResponseM) ->
|
(Request Unit -> ResponseM) ->
|
||||||
HTTP.Request ->
|
IncomingMessage IMServer ->
|
||||||
HTTP.Response ->
|
ServerResponse ->
|
||||||
Effect Unit
|
Effect Unit
|
||||||
handleRequestUnit router request httpresponse =
|
handleRequestUnit router request httpresponse =
|
||||||
void $ runAff (\_ -> pure unit) $ fromHTTPRequestUnit request
|
void $ runAff (\_ -> pure unit) $ fromHTTPRequestUnit request
|
||||||
@ -127,8 +129,8 @@ handleExtRequest ::
|
|||||||
, router :: ExtRequestNT route ctx -> ResponseM
|
, router :: ExtRequestNT route ctx -> ResponseM
|
||||||
, notFoundHandler :: Request Unit -> ResponseM
|
, notFoundHandler :: Request Unit -> ResponseM
|
||||||
} ->
|
} ->
|
||||||
HTTP.Request ->
|
IncomingMessage IMServer ->
|
||||||
HTTP.Response ->
|
ServerResponse ->
|
||||||
Aff Unit
|
Aff Unit
|
||||||
handleExtRequest { route, router, notFoundHandler } req resp = do
|
handleExtRequest { route, router, notFoundHandler } req resp = do
|
||||||
httpurpleReq <- fromHTTPRequestExt route (Proxy :: Proxy ctx) req
|
httpurpleReq <- fromHTTPRequestExt route (Proxy :: Proxy ctx) req
|
||||||
@ -145,8 +147,8 @@ handleRequest ::
|
|||||||
, router :: ExtRequestNT route ctx -> ResponseM
|
, router :: ExtRequestNT route ctx -> ResponseM
|
||||||
, notFoundHandler :: Request Unit -> ResponseM
|
, notFoundHandler :: Request Unit -> ResponseM
|
||||||
} ->
|
} ->
|
||||||
HTTP.Request ->
|
IncomingMessage IMServer ->
|
||||||
HTTP.Response ->
|
ServerResponse ->
|
||||||
Effect Unit
|
Effect Unit
|
||||||
handleRequest settings request response = void $ runAff (\_ -> pure unit) $ handleExtRequest settings request response
|
handleRequest settings request response = void $ runAff (\_ -> pure unit) $ handleExtRequest settings request response
|
||||||
|
|
||||||
@ -161,8 +163,8 @@ handleExtRequestWithMiddleware ::
|
|||||||
, router :: ExtRequestNT route output -> ResponseM
|
, router :: ExtRequestNT route output -> ResponseM
|
||||||
, notFoundHandler :: Request Unit -> ResponseM
|
, notFoundHandler :: Request Unit -> ResponseM
|
||||||
} ->
|
} ->
|
||||||
HTTP.Request ->
|
IncomingMessage IMServer ->
|
||||||
HTTP.Response ->
|
ServerResponse ->
|
||||||
Effect Unit
|
Effect Unit
|
||||||
handleExtRequestWithMiddleware { route, nodeMiddleware: NodeMiddlewareStack middleware, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ do
|
handleExtRequestWithMiddleware { route, nodeMiddleware: NodeMiddlewareStack middleware, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ do
|
||||||
eff <- liftEffect $ flip runContT (coerce >>> pure) $ middleware (MiddlewareResult { request: req, response: resp, middlewareResult: NotCalled })
|
eff <- liftEffect $ flip runContT (coerce >>> pure) $ middleware (MiddlewareResult { request: req, response: resp, middlewareResult: NotCalled })
|
||||||
@ -209,15 +211,14 @@ serveInternal inputOptions maybeNodeMiddleware settings = do
|
|||||||
filledOptions :: ListenOptions
|
filledOptions :: ListenOptions
|
||||||
filledOptions = justifill inputOptions
|
filledOptions = justifill inputOptions
|
||||||
|
|
||||||
hostname = fromMaybe defaultHostname filledOptions.hostname
|
host = fromMaybe defaultHostname filledOptions.hostname
|
||||||
port = fromMaybe defaultPort filledOptions.port
|
port = fromMaybe defaultPort filledOptions.port
|
||||||
onStarted = fromMaybe (defaultOnStart hostname port) filledOptions.onStarted
|
onStarted = fromMaybe (defaultOnStart host port) filledOptions.onStarted
|
||||||
|
|
||||||
options :: HTTP.ListenOptions
|
|
||||||
options =
|
options =
|
||||||
{ hostname
|
{ host
|
||||||
, port
|
, port
|
||||||
, backlog: filledOptions.backlog
|
, backlog: fromMaybe 511 filledOptions.backlog
|
||||||
}
|
}
|
||||||
|
|
||||||
routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler }
|
routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler }
|
||||||
@ -226,17 +227,24 @@ serveInternal inputOptions maybeNodeMiddleware settings = do
|
|||||||
Just nodeMiddleware -> handleExtRequestWithMiddleware $ merge routingSettings { nodeMiddleware }
|
Just nodeMiddleware -> handleExtRequestWithMiddleware $ merge routingSettings { nodeMiddleware }
|
||||||
Nothing -> handleRequest routingSettings
|
Nothing -> handleRequest routingSettings
|
||||||
sslOptions = { certFile: _, keyFile: _ } <$> filledOptions.certFile <*> filledOptions.keyFile
|
sslOptions = { certFile: _, keyFile: _ } <$> filledOptions.certFile <*> filledOptions.keyFile
|
||||||
server <- case sslOptions of
|
netServer <- case sslOptions of
|
||||||
Just { certFile, keyFile } ->
|
Just { certFile, keyFile } -> do
|
||||||
do
|
cert' <- readFile certFile
|
||||||
cert' <- readTextFile UTF8 certFile
|
key' <- readFile keyFile
|
||||||
key' <- readTextFile UTF8 keyFile
|
server <- HTTPS.createSecureServer'
|
||||||
let sslOpts = key := keyString key' <> cert := certString cert'
|
{ key: [ key' ]
|
||||||
HTTPS.createServer sslOpts handler
|
, cert: [ cert' ]
|
||||||
Nothing -> HTTP.createServer handler
|
}
|
||||||
listen server options onStarted
|
server # EE.on_ HServer.requestH handler
|
||||||
let closingHandler = close server
|
pure $ HServer.toNetServer server
|
||||||
registerClosingHandler filledOptions.closingHandler closingHandler
|
Nothing -> do
|
||||||
|
server <- HTTP.createServer
|
||||||
|
server # EE.on_ HServer.requestH handler
|
||||||
|
pure $ HServer.toNetServer server
|
||||||
|
netServer # EE.on_ listeningH onStarted
|
||||||
|
listenTcp netServer options
|
||||||
|
let closingHandler = NServer.close netServer
|
||||||
|
liftEffect $ registerClosingHandler filledOptions.closingHandler (\eff -> eff *> closingHandler)
|
||||||
|
|
||||||
serve ::
|
serve ::
|
||||||
forall route from fromRL via missing missingList.
|
forall route from fromRL via missing missingList.
|
||||||
@ -277,8 +285,8 @@ serveNodeMiddleware inputOptions { route, router, nodeMiddleware } = do
|
|||||||
registerClosingHandler :: Maybe ClosingHandler -> (Effect Unit -> Effect Unit) -> ServerM
|
registerClosingHandler :: Maybe ClosingHandler -> (Effect Unit -> Effect Unit) -> ServerM
|
||||||
registerClosingHandler (Just NoClosingHandler) closingHandler = pure closingHandler
|
registerClosingHandler (Just NoClosingHandler) closingHandler = pure closingHandler
|
||||||
registerClosingHandler _ closingHandler = do
|
registerClosingHandler _ closingHandler = do
|
||||||
onSignal SIGINT $ closingHandler $ log "Aye, stopping service now. Goodbye!"
|
Process.process # EE.on_ (mkSignalH SIGINT) (closingHandler $ log "Aye, stopping service now. Goodbye!")
|
||||||
onSignal SIGTERM $ closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye..."
|
Process.process # EE.on_ (mkSignalH SIGTERM) (closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye...")
|
||||||
pure closingHandler
|
pure closingHandler
|
||||||
|
|
||||||
defaultHostname :: String
|
defaultHostname :: String
|
||||||
|
@ -71,14 +71,15 @@ module HTTPurple.Status
|
|||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Node.HTTP (Response, setStatusCode)
|
import Node.HTTP.ServerResponse (setStatusCode)
|
||||||
|
import Node.HTTP.Types (ServerResponse)
|
||||||
|
|
||||||
-- | The `Status` type enumerates all valid HTTP response status codes.
|
-- | The `Status` type enumerates all valid HTTP response status codes.
|
||||||
type Status = Int
|
type Status = Int
|
||||||
|
|
||||||
-- | Write a status to a given HTTP `Response`.
|
-- | Write a status to a given HTTP `Response`.
|
||||||
write :: Response -> Status -> Effect Unit
|
write :: ServerResponse -> Status -> Effect Unit
|
||||||
write = setStatusCode
|
write = flip setStatusCode
|
||||||
|
|
||||||
---------
|
---------
|
||||||
-- 1xx --
|
-- 1xx --
|
||||||
|
@ -5,7 +5,8 @@ module HTTPurple.Version
|
|||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Node.HTTP (Request, httpVersion)
|
import Node.HTTP.IncomingMessage (httpVersion)
|
||||||
|
import Node.HTTP.Types (IMServer, IncomingMessage)
|
||||||
|
|
||||||
-- | These are the HTTP versions that HTTPurple understands. There are five
|
-- | These are the HTTP versions that HTTPurple understands. There are five
|
||||||
-- | commonly known versions which are explicitly named.
|
-- | commonly known versions which are explicitly named.
|
||||||
@ -31,7 +32,7 @@ instance showVersion :: Show Version where
|
|||||||
show (Other version) = "HTTP/" <> version
|
show (Other version) = "HTTP/" <> version
|
||||||
|
|
||||||
-- | Take an HTTP `Request` and extract the `Version` for that request.
|
-- | Take an HTTP `Request` and extract the `Version` for that request.
|
||||||
read :: Request -> Version
|
read :: IncomingMessage IMServer -> Version
|
||||||
read = httpVersion >>> case _ of
|
read = httpVersion >>> case _ of
|
||||||
"0.9" -> HTTP0_9
|
"0.9" -> HTTP0_9
|
||||||
"1.0" -> HTTP1_0
|
"1.0" -> HTTP1_0
|
||||||
|
@ -6,7 +6,6 @@ in conf // {
|
|||||||
, "exceptions"
|
, "exceptions"
|
||||||
, "lists"
|
, "lists"
|
||||||
, "node-child-process"
|
, "node-child-process"
|
||||||
, "node-fs-aff"
|
|
||||||
, "spec"
|
, "spec"
|
||||||
, "debug"
|
, "debug"
|
||||||
, "transformers"
|
, "transformers"
|
||||||
|
@ -31,7 +31,7 @@ readSpec =
|
|||||||
describe "read" do
|
describe "read" do
|
||||||
it "is the body of the Request" do
|
it "is the body of the Request" do
|
||||||
body <- (liftEffect <<< read) =<< mockRequest "" "GET" "" "test" []
|
body <- (liftEffect <<< read) =<< mockRequest "" "GET" "" "test" []
|
||||||
string <- liftEffect $ fromMaybe "" <$> readString (toStream body) Nothing UTF8
|
string <- liftEffect $ fromMaybe "" <$> readString (toStream body) UTF8
|
||||||
string ?= "test"
|
string ?= "test"
|
||||||
|
|
||||||
toStringSpec :: Test
|
toStringSpec :: Test
|
||||||
|
@ -2,8 +2,6 @@ module Test.HTTPurple.IntegrationSpec where
|
|||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
|
||||||
import Effect.Aff (Milliseconds(..), delay)
|
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Examples.AsyncResponse.Main as AsyncResponse
|
import Examples.AsyncResponse.Main as AsyncResponse
|
||||||
import Examples.BinaryRequest.Main as BinaryRequest
|
import Examples.BinaryRequest.Main as BinaryRequest
|
||||||
@ -26,7 +24,7 @@ import Foreign.Object as Object
|
|||||||
import Node.Buffer (toArray)
|
import Node.Buffer (toArray)
|
||||||
import Node.FS.Aff (readFile)
|
import Node.FS.Aff (readFile)
|
||||||
import Test.HTTPurple.TestHelpers (Test, get, get', getBinary, getHeader, post, postBinary, (?=))
|
import Test.HTTPurple.TestHelpers (Test, get, get', getBinary, getHeader, post, postBinary, (?=))
|
||||||
import Test.Spec (Tree(..), describe, it)
|
import Test.Spec (describe, it)
|
||||||
import Test.Spec.Assertions.String (shouldStartWith)
|
import Test.Spec.Assertions.String (shouldStartWith)
|
||||||
|
|
||||||
asyncResponseSpec :: Test
|
asyncResponseSpec :: Test
|
||||||
|
@ -3,7 +3,6 @@ module Test.HTTPurple.ResponseSpec where
|
|||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Data.Either (Either(Right))
|
import Data.Either (Either(Right))
|
||||||
import Debug (spy)
|
|
||||||
import Effect.Aff (makeAff, nonCanceler)
|
import Effect.Aff (makeAff, nonCanceler)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import HTTPurple.Body (defaultHeaders)
|
import HTTPurple.Body (defaultHeaders)
|
||||||
@ -11,8 +10,9 @@ import HTTPurple.Headers (toResponseHeaders)
|
|||||||
import HTTPurple.Headers as Headers
|
import HTTPurple.Headers as Headers
|
||||||
import HTTPurple.Response (emptyResponse, emptyResponse', response, response', send)
|
import HTTPurple.Response (emptyResponse, emptyResponse', response, response', send)
|
||||||
import Node.Encoding (Encoding(UTF8))
|
import Node.Encoding (Encoding(UTF8))
|
||||||
import Node.HTTP (responseAsStream)
|
import Node.HTTP.OutgoingMessage as OM
|
||||||
import Node.Stream (end, writeString)
|
import Node.HTTP.ServerResponse as SR
|
||||||
|
import Node.Stream (end', writeString')
|
||||||
import Test.HTTPurple.TestHelpers (Test, getResponseBody, getResponseHeader, getResponseStatus, mockResponse, (?=))
|
import Test.HTTPurple.TestHelpers (Test, getResponseBody, getResponseHeader, getResponseStatus, mockResponse, (?=))
|
||||||
import Test.Spec (describe, it)
|
import Test.Spec (describe, it)
|
||||||
|
|
||||||
@ -25,8 +25,8 @@ sendSpec =
|
|||||||
, headers: Headers.header "Test" "test"
|
, headers: Headers.header "Test" "test"
|
||||||
, writeBody:
|
, writeBody:
|
||||||
\response -> makeAff \done -> do
|
\response -> makeAff \done -> do
|
||||||
stream <- pure $ responseAsStream response
|
stream <- pure $ OM.toWriteable $ SR.toOutgoingMessage response
|
||||||
void $ writeString stream UTF8 "test" $ const $ end stream $ const $ done $ Right unit
|
void $ writeString' stream UTF8 "test" $ const $ end' stream $ const $ done $ Right unit
|
||||||
pure nonCanceler
|
pure nonCanceler
|
||||||
}
|
}
|
||||||
it "writes the headers" do
|
it "writes the headers" do
|
||||||
|
@ -3,20 +3,13 @@ module Test.HTTPurple.ServerSpec where
|
|||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Control.Monad.Except (throwError)
|
import Control.Monad.Except (throwError)
|
||||||
import Data.Either (Either(..))
|
|
||||||
import Data.Generic.Rep (class Generic)
|
import Data.Generic.Rep (class Generic)
|
||||||
import Data.Maybe (Maybe(Nothing))
|
|
||||||
import Data.Options ((:=))
|
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Effect.Exception (error)
|
import Effect.Exception (error)
|
||||||
import Foreign.Object (empty)
|
import Foreign.Object (empty)
|
||||||
import HTTPurple.Request (Request)
|
import HTTPurple.Request (Request)
|
||||||
import HTTPurple.Response (ResponseM, notFound, ok)
|
import HTTPurple.Response (ResponseM, ok)
|
||||||
import HTTPurple.Server (serve)
|
import HTTPurple.Server (serve)
|
||||||
import HTTPurple.Server as Server
|
|
||||||
import Node.Encoding (Encoding(UTF8))
|
|
||||||
import Node.FS.Sync (readTextFile)
|
|
||||||
import Node.HTTP.Secure (cert, certString, key, keyString)
|
|
||||||
import Routing.Duplex (RouteDuplex')
|
import Routing.Duplex (RouteDuplex')
|
||||||
import Routing.Duplex as RD
|
import Routing.Duplex as RD
|
||||||
import Routing.Duplex.Generic as G
|
import Routing.Duplex.Generic as G
|
||||||
|
@ -2,40 +2,29 @@ module Test.HTTPurple.TestHelpers where
|
|||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Data.Array (fromFoldable) as Array
|
|
||||||
import Data.Either (Either(Right))
|
import Data.Either (Either(Right))
|
||||||
import Data.List (List(Nil, Cons), reverse)
|
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Options ((:=))
|
|
||||||
import Data.String (toLower)
|
import Data.String (toLower)
|
||||||
import Data.Tuple (Tuple)
|
import Data.Tuple (Tuple)
|
||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Effect.Aff (Aff, makeAff, nonCanceler)
|
import Effect.Aff (Aff, makeAff, nonCanceler)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Effect.Ref (modify_, new, read)
|
import Foreign (Foreign)
|
||||||
import Foreign.Object (Object, lookup)
|
import Foreign.Object (Object, lookup)
|
||||||
import Foreign.Object (fromFoldable) as Object
|
import Foreign.Object (fromFoldable) as Object
|
||||||
import Node.Buffer (Buffer, concat, create, fromString)
|
import Node.Buffer (Buffer, create, fromString)
|
||||||
import Node.Buffer (toString) as Buffer
|
import Node.Buffer (concat, toString) as Buffer
|
||||||
import Node.Encoding (Encoding(UTF8))
|
import Node.Encoding (Encoding(UTF8))
|
||||||
import Node.HTTP (Request)
|
import Node.EventEmitter (once_)
|
||||||
import Node.HTTP (Response) as HTTP
|
import Node.HTTP as HTTP
|
||||||
import Node.HTTP.Client
|
import Node.HTTP.ClientRequest as HTTPClient
|
||||||
( RequestHeaders(RequestHeaders)
|
import Node.HTTP.IncomingMessage as IM
|
||||||
, headers
|
import Node.HTTP.OutgoingMessage as OM
|
||||||
, hostname
|
import Node.HTTP.Types (IMClientRequest, IncomingMessage, ServerResponse)
|
||||||
, method
|
import Node.HTTPS as HTTPS
|
||||||
, path
|
import Node.Stream (Readable)
|
||||||
, port
|
import Node.Stream as Stream
|
||||||
, protocol
|
import Node.Stream.Aff (readableToBuffers)
|
||||||
, rejectUnauthorized
|
|
||||||
, requestAsStream
|
|
||||||
, responseAsStream
|
|
||||||
, responseHeaders
|
|
||||||
, statusCode
|
|
||||||
)
|
|
||||||
import Node.HTTP.Client (Response, request) as HTTPClient
|
|
||||||
import Node.Stream (Readable, end, onData, onEnd, write)
|
|
||||||
import Test.Spec (Spec)
|
import Test.Spec (Spec)
|
||||||
import Test.Spec.Assertions (shouldEqual)
|
import Test.Spec.Assertions (shouldEqual)
|
||||||
import Unsafe.Coerce (unsafeCoerce)
|
import Unsafe.Coerce (unsafeCoerce)
|
||||||
@ -57,27 +46,32 @@ request ::
|
|||||||
Object String ->
|
Object String ->
|
||||||
String ->
|
String ->
|
||||||
Buffer ->
|
Buffer ->
|
||||||
Aff HTTPClient.Response
|
Aff (IncomingMessage IMClientRequest)
|
||||||
request secure port' method' headers' path' body =
|
request secure port' method' headers' path' body =
|
||||||
makeAff \done -> do
|
makeAff \done -> do
|
||||||
req <- HTTPClient.request options $ Right >>> done
|
req <- case secure of
|
||||||
let stream = requestAsStream req
|
true -> HTTPS.requestOpts
|
||||||
|
{ method: method'
|
||||||
|
, host: "localhost"
|
||||||
|
, port: port'
|
||||||
|
, path: path'
|
||||||
|
, headers: unsafeCoerce headers' :: Object Foreign
|
||||||
|
, rejectUnauthorized: false
|
||||||
|
}
|
||||||
|
false -> HTTP.requestOpts
|
||||||
|
{ method: method'
|
||||||
|
, host: "localhost"
|
||||||
|
, port: port'
|
||||||
|
, path: path'
|
||||||
|
, headers: unsafeCoerce headers' :: Object Foreign
|
||||||
|
}
|
||||||
|
req # once_ HTTPClient.responseH (Right >>> done)
|
||||||
|
let stream = OM.toWriteable $ HTTPClient.toOutgoingMessage req
|
||||||
void
|
void
|
||||||
$ write stream body
|
$ Stream.write' stream body
|
||||||
$ const
|
$ const
|
||||||
$ end stream
|
$ Stream.end stream
|
||||||
$ const
|
|
||||||
$ pure unit
|
|
||||||
pure nonCanceler
|
pure nonCanceler
|
||||||
where
|
|
||||||
options =
|
|
||||||
protocol := (if secure then "https:" else "http:")
|
|
||||||
<> method := method'
|
|
||||||
<> hostname := "localhost"
|
|
||||||
<> port := port'
|
|
||||||
<> path := path'
|
|
||||||
<> headers := RequestHeaders headers'
|
|
||||||
<> rejectUnauthorized := false
|
|
||||||
|
|
||||||
-- | Same as `request` but without.
|
-- | Same as `request` but without.
|
||||||
request' ::
|
request' ::
|
||||||
@ -86,7 +80,7 @@ request' ::
|
|||||||
String ->
|
String ->
|
||||||
Object String ->
|
Object String ->
|
||||||
String ->
|
String ->
|
||||||
Aff HTTPClient.Response
|
Aff (IncomingMessage IMClientRequest)
|
||||||
request' secure port method headers path =
|
request' secure port method headers path =
|
||||||
liftEffect (create 0)
|
liftEffect (create 0)
|
||||||
>>= request secure port method headers path
|
>>= request secure port method headers path
|
||||||
@ -99,29 +93,19 @@ requestString ::
|
|||||||
Object String ->
|
Object String ->
|
||||||
String ->
|
String ->
|
||||||
String ->
|
String ->
|
||||||
Aff HTTPClient.Response
|
Aff (IncomingMessage IMClientRequest)
|
||||||
requestString secure port method headers path body = do
|
requestString secure port method headers path body = do
|
||||||
liftEffect (fromString body UTF8)
|
liftEffect (fromString body UTF8)
|
||||||
>>= request secure port method headers path
|
>>= request secure port method headers path
|
||||||
|
|
||||||
-- | Convert a request to an Aff containing the `Buffer with the response body.
|
-- | Convert a request to an Aff containing the `Buffer with the response body.
|
||||||
toBuffer :: HTTPClient.Response -> Aff Buffer
|
toBuffer :: IncomingMessage IMClientRequest -> Aff Buffer
|
||||||
toBuffer response =
|
toBuffer response = do
|
||||||
makeAff \done -> do
|
bufs <- readableToBuffers $ IM.toReadable response
|
||||||
let
|
liftEffect $ Buffer.concat bufs
|
||||||
stream = responseAsStream response
|
|
||||||
chunks <- new Nil
|
|
||||||
onData stream $ \new -> modify_ (Cons new) chunks
|
|
||||||
onEnd stream $ read chunks
|
|
||||||
>>= reverse
|
|
||||||
>>> Array.fromFoldable
|
|
||||||
>>> concat
|
|
||||||
>>= Right
|
|
||||||
>>> done
|
|
||||||
pure nonCanceler
|
|
||||||
|
|
||||||
-- | Convert a request to an Aff containing the string with the response body.
|
-- | Convert a request to an Aff containing the string with the response body.
|
||||||
toString :: HTTPClient.Response -> Aff String
|
toString :: IncomingMessage IMClientRequest -> Aff String
|
||||||
toString resp = do
|
toString resp = do
|
||||||
buf <- toBuffer resp
|
buf <- toBuffer resp
|
||||||
liftEffect $ Buffer.toString UTF8 buf
|
liftEffect $ Buffer.toString UTF8 buf
|
||||||
@ -174,8 +158,8 @@ postBinary port headers path = request false port "POST" headers path >=> toStri
|
|||||||
|
|
||||||
-- | Convert a request to an Aff containing the string with the given header
|
-- | Convert a request to an Aff containing the string with the given header
|
||||||
-- | value.
|
-- | value.
|
||||||
extractHeader :: String -> HTTPClient.Response -> String
|
extractHeader :: String -> IncomingMessage IMClientRequest -> String
|
||||||
extractHeader header = unmaybe <<< lookup' <<< responseHeaders
|
extractHeader header = unmaybe <<< lookup' <<< IM.headers
|
||||||
where
|
where
|
||||||
unmaybe = fromMaybe ""
|
unmaybe = fromMaybe ""
|
||||||
|
|
||||||
@ -196,45 +180,47 @@ getStatus ::
|
|||||||
Object String ->
|
Object String ->
|
||||||
String ->
|
String ->
|
||||||
Aff Int
|
Aff Int
|
||||||
getStatus port headers path = statusCode <$> request' false port "GET" headers path
|
getStatus port headers path = IM.statusCode <$> request' false port "GET" headers path
|
||||||
|
|
||||||
-- | Mock an HTTP Request object
|
-- | Mock an HTTP Request object
|
||||||
foreign import mockRequestImpl ::
|
foreign import mockRequestImpl ::
|
||||||
|
forall a.
|
||||||
String ->
|
String ->
|
||||||
String ->
|
String ->
|
||||||
String ->
|
String ->
|
||||||
String ->
|
String ->
|
||||||
Object String ->
|
Object String ->
|
||||||
Effect Request
|
Effect (IncomingMessage a)
|
||||||
|
|
||||||
-- | Mock an HTTP Request object
|
-- | Mock an HTTP Request object
|
||||||
mockRequest ::
|
mockRequest ::
|
||||||
|
forall a.
|
||||||
String ->
|
String ->
|
||||||
String ->
|
String ->
|
||||||
String ->
|
String ->
|
||||||
String ->
|
String ->
|
||||||
Array (Tuple String String) ->
|
Array (Tuple String String) ->
|
||||||
Aff Request
|
Aff (IncomingMessage a)
|
||||||
mockRequest httpVersion method url body = liftEffect <<< mockRequestImpl httpVersion method url body <<< Object.fromFoldable
|
mockRequest httpVersion method url body = liftEffect <<< mockRequestImpl httpVersion method url body <<< Object.fromFoldable
|
||||||
|
|
||||||
-- | Mock an HTTP Response object
|
-- | Mock an HTTP Response object
|
||||||
foreign import mockResponse :: Effect HTTP.Response
|
foreign import mockResponse :: Effect ServerResponse
|
||||||
|
|
||||||
-- | Get the current body from an HTTP Response object (note this will only work
|
-- | Get the current body from an HTTP Response object (note this will only work
|
||||||
-- | with an object returned from mockResponse).
|
-- | with an object returned from mockResponse).
|
||||||
getResponseBody :: HTTP.Response -> String
|
getResponseBody :: ServerResponse -> String
|
||||||
getResponseBody = _.body <<< unsafeCoerce
|
getResponseBody = _.body <<< unsafeCoerce
|
||||||
|
|
||||||
-- | Get the currently set status from an HTTP Response object.
|
-- | Get the currently set status from an HTTP Response object.
|
||||||
getResponseStatus :: HTTP.Response -> Int
|
getResponseStatus :: ServerResponse -> Int
|
||||||
getResponseStatus = _.statusCode <<< unsafeCoerce
|
getResponseStatus = _.statusCode <<< unsafeCoerce
|
||||||
|
|
||||||
-- | Get all current headers on the HTTP Response object.
|
-- | Get all current headers on the HTTP Response object.
|
||||||
getResponseHeaders :: HTTP.Response -> Object (Array String)
|
getResponseHeaders :: ServerResponse -> Object (Array String)
|
||||||
getResponseHeaders = unsafeCoerce <<< _.headers <<< unsafeCoerce
|
getResponseHeaders = unsafeCoerce <<< _.headers <<< unsafeCoerce
|
||||||
|
|
||||||
-- | Get the current value for the header on the HTTP Response object.
|
-- | Get the current value for the header on the HTTP Response object.
|
||||||
getResponseHeader :: String -> HTTP.Response -> Array String
|
getResponseHeader :: String -> ServerResponse -> Array String
|
||||||
getResponseHeader header = fromMaybe [ "" ] <<< lookup header <<< getResponseHeaders
|
getResponseHeader header = fromMaybe [ "" ] <<< lookup header <<< getResponseHeaders
|
||||||
|
|
||||||
-- | Create a stream out of a string.
|
-- | Create a stream out of a string.
|
||||||
|
Loading…
Reference in New Issue
Block a user