Update node libs (tests do not pass)

This commit is contained in:
Jordan Martinez 2023-08-07 09:37:29 -05:00 committed by Jantxu
parent 791a18c749
commit 4667feefa4
19 changed files with 176 additions and 182 deletions

3
.vscode/settings.json vendored Normal file
View File

@ -0,0 +1,3 @@
{
"purescript.buildCommand": "spago -x test.dhall build --purs-args --json-errors"
}

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 ((/=) "")

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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.