From 4667feefa4335cd7cd124c9484b3ec118c2ac66f Mon Sep 17 00:00:00 2001 From: Jordan Martinez Date: Mon, 7 Aug 2023 09:37:29 -0500 Subject: [PATCH] Update node libs (tests do not pass) --- .vscode/settings.json | 3 + spago.dhall | 3 + src/HTTPurple/Body.purs | 55 +++++------ src/HTTPurple/Headers.purs | 14 ++- src/HTTPurple/Method.purs | 7 +- src/HTTPurple/NodeMiddleware.purs | 6 +- src/HTTPurple/Path.purs | 7 +- src/HTTPurple/Query.purs | 7 +- src/HTTPurple/Request.purs | 16 +-- src/HTTPurple/Response.purs | 6 +- src/HTTPurple/Server.purs | 76 +++++++------- src/HTTPurple/Status.purs | 7 +- src/HTTPurple/Version.purs | 5 +- test.dhall | 1 - test/Test/HTTPurple/BodySpec.purs | 2 +- test/Test/HTTPurple/IntegrationSpec.purs | 4 +- test/Test/HTTPurple/ResponseSpec.purs | 10 +- test/Test/HTTPurple/ServerSpec.purs | 9 +- test/Test/HTTPurple/TestHelpers.purs | 120 ++++++++++------------- 19 files changed, 176 insertions(+), 182 deletions(-) create mode 100644 .vscode/settings.json diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..1d939b5 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,3 @@ +{ + "purescript.buildCommand": "spago -x test.dhall build --purs-args --json-errors" +} diff --git a/spago.dhall b/spago.dhall index 60eb29e..aa83097 100644 --- a/spago.dhall +++ b/spago.dhall @@ -10,6 +10,7 @@ , "either" , "exceptions" , "foldable-traversable" + , "foreign" , "foreign-object" , "functions" , "js-uri" @@ -19,7 +20,9 @@ , "maybe" , "newtype" , "node-buffer" + , "node-event-emitter" , "node-fs" + , "node-net" , "node-http" , "node-process" , "node-streams" diff --git a/src/HTTPurple/Body.purs b/src/HTTPurple/Body.purs index a55f273..430c566 100644 --- a/src/HTTPurple/Body.purs +++ b/src/HTTPurple/Body.purs @@ -18,14 +18,19 @@ import Effect.Aff (Aff, makeAff, nonCanceler) import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Class (liftEffect) import Effect.Ref (Ref) -import Effect.Ref (modify, new, read, write) as Ref +import Effect.Ref (new, read, write) as Ref import HTTPurple.Headers (RequestHeaders, mkRequestHeader) -import Node.Buffer (Buffer, concat, fromString, size) -import Node.Buffer (toString) as Buffer +import Node.Buffer (Buffer, fromString, size) +import Node.Buffer (concat, toString) as Buffer import Node.Encoding (Encoding(UTF8)) -import Node.HTTP (Request, Response, requestAsStream, responseAsStream) -import Node.Stream (Readable, Stream, end, onData, onEnd, pipe, writeString) -import Node.Stream (write) as Stream +import Node.EventEmitter (once_) +import Node.HTTP.IncomingMessage as IM +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) type RequestBody = @@ -35,13 +40,13 @@ type RequestBody = } -- | Read the body `Readable` stream out of the incoming request -read :: Request -> Effect RequestBody +read :: IncomingMessage IMServer -> Effect RequestBody read request = do buffer <- Ref.new Nothing string <- Ref.new Nothing pure { buffer - , stream: requestAsStream request + , stream: IM.toReadable request , string } @@ -75,22 +80,12 @@ toBuffer requestBody = do $ Ref.read requestBody.buffer case maybeBuffer of Nothing -> do - buffer <- streamToBuffer requestBody.stream - liftEffect - $ Ref.write (Just buffer) requestBody.buffer - pure buffer + buffers <- liftAff $ readableToBuffers requestBody.stream + liftEffect do + buffer <- Buffer.concat buffers + Ref.write (Just buffer) requestBody.buffer + pure buffer Just buffer -> pure buffer - where - -- | Slurp the entire `Readable` stream into a `Buffer` - streamToBuffer :: MonadAff m => Readable () -> m Buffer - streamToBuffer stream = - liftAff $ makeAff \done -> do - bufs <- Ref.new [] - onData stream \buf -> void $ Ref.modify (_ <> [ buf ]) bufs - onEnd stream do - body <- Ref.read bufs >>= concat - done $ Right body - pure nonCanceler -- | Return the `Readable` stream directly from `RequestBody` toStream :: RequestBody -> Readable () @@ -106,7 +101,7 @@ class Body b where defaultHeaders :: b -> Effect RequestHeaders -- | Given a body value and a Node HTTP `Response` value, write the body value -- | to the Node response. - write :: b -> Response -> Aff Unit + write :: b -> ServerResponse -> Aff Unit -- | The instance for `String` will convert the string to a buffer first in -- | order to determine it's additional headers. This is to ensure that the @@ -118,8 +113,8 @@ instance Body String where buf :: Buffer <- fromString body UTF8 defaultHeaders buf write body response = makeAff \done -> do - let stream = responseAsStream response - void $ writeString stream UTF8 body $ const $ end stream $ const $ done $ Right unit + let stream = OM.toWriteable $ SR.toOutgoingMessage response + void $ writeString' stream UTF8 body $ const $ end' stream $ const $ done $ Right unit pure nonCanceler -- | The instance for `Buffer` is trivial--we add a `Content-Length` header @@ -128,8 +123,8 @@ instance Body String where instance Body Buffer where defaultHeaders buf = mkRequestHeader "Content-Length" <$> show <$> size buf write body response = makeAff \done -> do - let stream = responseAsStream response - void $ Stream.write stream body $ const $ end stream $ const $ done $ Right unit + let stream = OM.toWriteable $ SR.toOutgoingMessage response + void $ Stream.write' stream body $ const $ end' stream $ const $ done $ Right unit pure nonCanceler -- | This instance can be used to send chunked data. Here, we add a @@ -141,6 +136,6 @@ instance defaultHeaders _ = pure $ mkRequestHeader "Transfer-Encoding" "chunked" write body response = makeAff \done -> do let stream = to body - void $ pipe stream $ responseAsStream response - onEnd stream $ done $ Right unit + void $ pipe stream $ OM.toWriteable $ SR.toOutgoingMessage response + stream # once_ Stream.endH (done $ Right unit) pure nonCanceler diff --git a/src/HTTPurple/Headers.purs b/src/HTTPurple/Headers.purs index c3ae7a5..808a504 100644 --- a/src/HTTPurple/Headers.purs +++ b/src/HTTPurple/Headers.purs @@ -29,7 +29,10 @@ import Data.Tuple (Tuple(Tuple)) import Effect (Effect) import Foreign.Object (fold) 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.RowList (class RowToList, Cons, Nil) import Record as Record @@ -84,17 +87,18 @@ instance Eq ResponseHeaders where eq (ResponseHeaders a) (ResponseHeaders b) = eq a b -- | Get the headers out of a HTTP `RequestHeaders` object. -read :: Request -> RequestHeaders -read = requestHeaders >>> fold insertField Map.empty >>> RequestHeaders +read :: IncomingMessage IMServer -> RequestHeaders +read = IM.headers >>> fold insertField Map.empty >>> RequestHeaders where insertField x key value = insert (CaseInsensitiveString key) value x -- | Given an HTTP `Response` and a `ResponseHeaders` object, return an effect that will -- | write the `ResponseHeaders` to the `Response`. -write :: Response -> ResponseHeaders -> Effect Unit +write :: ServerResponse -> ResponseHeaders -> Effect Unit write response (ResponseHeaders headers') = void $ traverseWithIndex writeField headers' 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. empty :: ResponseHeaders diff --git a/src/HTTPurple/Method.purs b/src/HTTPurple/Method.purs index 7fa2bde..55f362c 100644 --- a/src/HTTPurple/Method.purs +++ b/src/HTTPurple/Method.purs @@ -5,7 +5,8 @@ module HTTPurple.Method 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. data Method @@ -35,8 +36,8 @@ instance showMethod :: Show Method where show Patch = "Patch" -- | Take an HTTP `Request` and extract the `Method` for that request. -read :: Request -> Method -read = requestMethod >>> case _ of +read :: IncomingMessage IMServer -> Method +read = method >>> case _ of "POST" -> Post "PUT" -> Put "DELETE" -> Delete diff --git a/src/HTTPurple/NodeMiddleware.purs b/src/HTTPurple/NodeMiddleware.purs index 5757531..0a5b50c 100644 --- a/src/HTTPurple/NodeMiddleware.purs +++ b/src/HTTPurple/NodeMiddleware.purs @@ -24,20 +24,20 @@ import Effect.Exception (Error) import Effect.Ref as Ref import Effect.Uncurried (EffectFn1, EffectFn3, mkEffectFn1, runEffectFn1, runEffectFn3) import Literals.Undefined (Undefined, undefined) -import Node.HTTP as HTTP +import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse) import Prim.Row (class Union) import Untagged.Union (type (|+|), UndefinedOr, asOneOf, uorToMaybe) newtype NodeMiddleware :: forall k. k -> Type 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) _ data NextInvocation = NotCalled | ProcessingFailed Error | ProcessingSucceeded 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 input = MiddlewareResult { | MiddlewareResultR } diff --git a/src/HTTPurple/Path.purs b/src/HTTPurple/Path.purs index 5302ec8..27ff691 100644 --- a/src/HTTPurple/Path.purs +++ b/src/HTTPurple/Path.purs @@ -9,7 +9,8 @@ import Data.Array (filter, head) import Data.Maybe (fromMaybe) import Data.String (Pattern(Pattern), split) 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 -- | 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 -- | Given an HTTP `Request` object, extract the `Path`. -read :: Request -> Path -read = requestURL >>> split' "?" >>> first >>> split' "/" >>> nonempty >>> map urlDecode +read :: IncomingMessage IMServer -> Path +read = url >>> split' "?" >>> first >>> split' "/" >>> nonempty >>> map urlDecode where nonempty = filter ((/=) "") split' = Pattern >>> split diff --git a/src/HTTPurple/Query.purs b/src/HTTPurple/Query.purs index 8ae7360..4e06871 100644 --- a/src/HTTPurple/Query.purs +++ b/src/HTTPurple/Query.purs @@ -12,7 +12,8 @@ import Data.String (Pattern(Pattern), joinWith, split) import Data.Tuple (Tuple(Tuple)) import Foreign.Object (Object, fromFoldable) 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 -- | 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 -- | The `Map` of query segments in the given HTTP `Request`. -read :: Request -> Query -read = requestURL >>> split' "?" >>> last >>> split' "&" >>> nonempty >>> toObject +read :: IncomingMessage IMServer -> Query +read = url >>> split' "?" >>> last >>> split' "&" >>> nonempty >>> toObject where toObject = map toTuple >>> fromFoldable nonempty = filter ((/=) "") diff --git a/src/HTTPurple/Request.purs b/src/HTTPurple/Request.purs index be31174..deb1857 100644 --- a/src/HTTPurple/Request.purs +++ b/src/HTTPurple/Request.purs @@ -32,8 +32,8 @@ import HTTPurple.Query (read) as Query import HTTPurple.Utils (encodeURIComponent) import HTTPurple.Version (Version) import HTTPurple.Version (read) as Version -import Node.HTTP (Request) as HTTP -import Node.HTTP (requestURL) +import Node.HTTP.IncomingMessage as IM +import Node.HTTP.Types (IMServer, IncomingMessage) import Prim.Row (class Nub, class Union) import Prim.RowList (class RowToList) import Record (merge) @@ -81,7 +81,7 @@ fullPath { path: p, query } = "/" <> path <> questionMark <> queryParams queryParamsArr = toArrayWithKey stringifyQueryParam query 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 body <- liftEffect $ Body.read request pure @@ -92,17 +92,17 @@ mkRequest request route = do , headers: Headers.read request , body , httpVersion: Version.read request - , url: requestURL request + , url: IM.url request } -- | Given an HTTP `Request` object, this method will convert it to an HTTPurple -- | `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 - RD.parse route (requestURL request) # + RD.parse route (IM.url request) # bitraverse (const $ mkRequest request unit) (mkRequest request) -fromHTTPRequestUnit :: HTTP.Request -> Aff (Request Unit) +fromHTTPRequestUnit :: IncomingMessage IMServer -> Aff (Request Unit) fromHTTPRequestUnit = flip mkRequest unit fromHTTPRequestExt :: @@ -113,7 +113,7 @@ fromHTTPRequestExt :: Keys ctx => RD.RouteDuplex' route -> Proxy ctx -> - HTTP.Request -> + IncomingMessage IMServer -> Aff (Either (Request Unit) (ExtRequestNT route ctx)) fromHTTPRequestExt route _ nodeRequest = do let diff --git a/src/HTTPurple/Response.purs b/src/HTTPurple/Response.purs index 8432f4d..8ef5522 100644 --- a/src/HTTPurple/Response.purs +++ b/src/HTTPurple/Response.purs @@ -143,7 +143,7 @@ import HTTPurple.Headers (ResponseHeaders, empty, toResponseHeaders) import HTTPurple.Headers (write) as Headers 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 Node.HTTP (Response) as HTTP +import Node.HTTP.Types (ServerResponse) -- | The `ResponseM` type simply conveniently wraps up an HTTPurple monad that -- | returns a response. This type is the return type of all router/route @@ -154,13 +154,13 @@ type ResponseM = Aff Response type Response = { status :: Status , headers :: ResponseHeaders - , writeBody :: HTTP.Response -> Aff Unit + , writeBody :: ServerResponse -> Aff Unit } -- | Given an HTTP `Response` and a HTTPurple `Response`, this method will return -- | a monad encapsulating writing the HTTPurple `Response` to 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 liftEffect $ Status.write httpresponse status liftEffect $ Headers.write httpresponse headers diff --git a/src/HTTPurple/Server.purs b/src/HTTPurple/Server.purs index 9313ec6..26ea060 100644 --- a/src/HTTPurple/Server.purs +++ b/src/HTTPurple/Server.purs @@ -17,7 +17,6 @@ import Prelude import Control.Monad.Cont (runContT) import Data.Maybe (Maybe(..), fromMaybe) import Data.Newtype (unwrap) -import Data.Options ((:=)) import Data.Posix.Signal (Signal(..)) import Data.Profunctor (lcmap) import Data.Profunctor.Choice ((|||)) @@ -33,13 +32,16 @@ import HTTPurple.Response (Response, ResponseM, internalServerError, notFound, s import Justifill (justifill) import Justifill.Fillable (class FillableFields) import Justifill.Justifiable (class JustifiableFields) -import Node.Encoding (Encoding(UTF8)) -import Node.FS.Sync (readTextFile) -import Node.HTTP (ListenOptions, Request, Response, createServer) as HTTP -import Node.HTTP (close, listen) -import Node.HTTP.Secure (cert, certString, key, keyString) -import Node.HTTP.Secure (createServer) as HTTPS -import Node.Process (onSignal) +import Node.EventEmitter as EE +import Node.FS.Sync (readFile) +import Node.HTTP as HTTP +import Node.HTTP.Server as HServer +import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse) +import Node.HTTPS as HTTPS +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.RowList (class RowToList) import Record (merge) @@ -101,8 +103,8 @@ defaultMiddlewareErrorHandler err _ = do -- | handle requests without a routing adt. handleRequestUnit :: (Request Unit -> ResponseM) -> - HTTP.Request -> - HTTP.Response -> + IncomingMessage IMServer -> + ServerResponse -> Effect Unit handleRequestUnit router request httpresponse = void $ runAff (\_ -> pure unit) $ fromHTTPRequestUnit request @@ -127,8 +129,8 @@ handleExtRequest :: , router :: ExtRequestNT route ctx -> ResponseM , notFoundHandler :: Request Unit -> ResponseM } -> - HTTP.Request -> - HTTP.Response -> + IncomingMessage IMServer -> + ServerResponse -> Aff Unit handleExtRequest { route, router, notFoundHandler } req resp = do httpurpleReq <- fromHTTPRequestExt route (Proxy :: Proxy ctx) req @@ -145,8 +147,8 @@ handleRequest :: , router :: ExtRequestNT route ctx -> ResponseM , notFoundHandler :: Request Unit -> ResponseM } -> - HTTP.Request -> - HTTP.Response -> + IncomingMessage IMServer -> + ServerResponse -> Effect Unit handleRequest settings request response = void $ runAff (\_ -> pure unit) $ handleExtRequest settings request response @@ -161,8 +163,8 @@ handleExtRequestWithMiddleware :: , router :: ExtRequestNT route output -> ResponseM , notFoundHandler :: Request Unit -> ResponseM } -> - HTTP.Request -> - HTTP.Response -> + IncomingMessage IMServer -> + ServerResponse -> Effect Unit 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 }) @@ -209,15 +211,14 @@ serveInternal inputOptions maybeNodeMiddleware settings = do filledOptions :: ListenOptions filledOptions = justifill inputOptions - hostname = fromMaybe defaultHostname filledOptions.hostname + host = fromMaybe defaultHostname filledOptions.hostname port = fromMaybe defaultPort filledOptions.port - onStarted = fromMaybe (defaultOnStart hostname port) filledOptions.onStarted + onStarted = fromMaybe (defaultOnStart host port) filledOptions.onStarted - options :: HTTP.ListenOptions options = - { hostname + { host , port - , backlog: filledOptions.backlog + , backlog: fromMaybe 511 filledOptions.backlog } routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler } @@ -226,17 +227,24 @@ serveInternal inputOptions maybeNodeMiddleware settings = do Just nodeMiddleware -> handleExtRequestWithMiddleware $ merge routingSettings { nodeMiddleware } Nothing -> handleRequest routingSettings sslOptions = { certFile: _, keyFile: _ } <$> filledOptions.certFile <*> filledOptions.keyFile - server <- case sslOptions of - Just { certFile, keyFile } -> - do - cert' <- readTextFile UTF8 certFile - key' <- readTextFile UTF8 keyFile - let sslOpts = key := keyString key' <> cert := certString cert' - HTTPS.createServer sslOpts handler - Nothing -> HTTP.createServer handler - listen server options onStarted - let closingHandler = close server - registerClosingHandler filledOptions.closingHandler closingHandler + netServer <- case sslOptions of + Just { certFile, keyFile } -> do + cert' <- readFile certFile + key' <- readFile keyFile + server <- HTTPS.createSecureServer' + { key: [ key' ] + , cert: [ cert' ] + } + server # EE.on_ HServer.requestH handler + pure $ HServer.toNetServer server + 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 :: 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 (Just NoClosingHandler) closingHandler = pure closingHandler registerClosingHandler _ closingHandler = do - onSignal 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 SIGINT) (closingHandler $ log "Aye, stopping service now. Goodbye!") + Process.process # EE.on_ (mkSignalH SIGTERM) (closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye...") pure closingHandler defaultHostname :: String diff --git a/src/HTTPurple/Status.purs b/src/HTTPurple/Status.purs index 3ae1cc8..bc26ddc 100644 --- a/src/HTTPurple/Status.purs +++ b/src/HTTPurple/Status.purs @@ -71,14 +71,15 @@ module HTTPurple.Status import Prelude 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. type Status = Int -- | Write a status to a given HTTP `Response`. -write :: Response -> Status -> Effect Unit -write = setStatusCode +write :: ServerResponse -> Status -> Effect Unit +write = flip setStatusCode --------- -- 1xx -- diff --git a/src/HTTPurple/Version.purs b/src/HTTPurple/Version.purs index bd3dd65..1dda2f0 100644 --- a/src/HTTPurple/Version.purs +++ b/src/HTTPurple/Version.purs @@ -5,7 +5,8 @@ module HTTPurple.Version 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 -- | commonly known versions which are explicitly named. @@ -31,7 +32,7 @@ instance showVersion :: Show Version where show (Other version) = "HTTP/" <> version -- | Take an HTTP `Request` and extract the `Version` for that request. -read :: Request -> Version +read :: IncomingMessage IMServer -> Version read = httpVersion >>> case _ of "0.9" -> HTTP0_9 "1.0" -> HTTP1_0 diff --git a/test.dhall b/test.dhall index fed9799..3329b3f 100644 --- a/test.dhall +++ b/test.dhall @@ -6,7 +6,6 @@ in conf // { , "exceptions" , "lists" , "node-child-process" - , "node-fs-aff" , "spec" , "debug" , "transformers" diff --git a/test/Test/HTTPurple/BodySpec.purs b/test/Test/HTTPurple/BodySpec.purs index 9e8427f..91bfcae 100644 --- a/test/Test/HTTPurple/BodySpec.purs +++ b/test/Test/HTTPurple/BodySpec.purs @@ -31,7 +31,7 @@ readSpec = describe "read" do it "is the body of the Request" do body <- (liftEffect <<< read) =<< mockRequest "" "GET" "" "test" [] - string <- liftEffect $ fromMaybe "" <$> readString (toStream body) Nothing UTF8 + string <- liftEffect $ fromMaybe "" <$> readString (toStream body) UTF8 string ?= "test" toStringSpec :: Test diff --git a/test/Test/HTTPurple/IntegrationSpec.purs b/test/Test/HTTPurple/IntegrationSpec.purs index acbda98..54e6e99 100644 --- a/test/Test/HTTPurple/IntegrationSpec.purs +++ b/test/Test/HTTPurple/IntegrationSpec.purs @@ -2,8 +2,6 @@ module Test.HTTPurple.IntegrationSpec where import Prelude -import Control.Monad.Trans.Class (lift) -import Effect.Aff (Milliseconds(..), delay) import Effect.Class (liftEffect) import Examples.AsyncResponse.Main as AsyncResponse import Examples.BinaryRequest.Main as BinaryRequest @@ -26,7 +24,7 @@ import Foreign.Object as Object import Node.Buffer (toArray) import Node.FS.Aff (readFile) 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) asyncResponseSpec :: Test diff --git a/test/Test/HTTPurple/ResponseSpec.purs b/test/Test/HTTPurple/ResponseSpec.purs index d566279..90c9289 100644 --- a/test/Test/HTTPurple/ResponseSpec.purs +++ b/test/Test/HTTPurple/ResponseSpec.purs @@ -3,7 +3,6 @@ module Test.HTTPurple.ResponseSpec where import Prelude import Data.Either (Either(Right)) -import Debug (spy) import Effect.Aff (makeAff, nonCanceler) import Effect.Class (liftEffect) import HTTPurple.Body (defaultHeaders) @@ -11,8 +10,9 @@ import HTTPurple.Headers (toResponseHeaders) import HTTPurple.Headers as Headers import HTTPurple.Response (emptyResponse, emptyResponse', response, response', send) import Node.Encoding (Encoding(UTF8)) -import Node.HTTP (responseAsStream) -import Node.Stream (end, writeString) +import Node.HTTP.OutgoingMessage as OM +import Node.HTTP.ServerResponse as SR +import Node.Stream (end', writeString') import Test.HTTPurple.TestHelpers (Test, getResponseBody, getResponseHeader, getResponseStatus, mockResponse, (?=)) import Test.Spec (describe, it) @@ -25,8 +25,8 @@ sendSpec = , headers: Headers.header "Test" "test" , writeBody: \response -> makeAff \done -> do - stream <- pure $ responseAsStream response - void $ writeString stream UTF8 "test" $ const $ end stream $ const $ done $ Right unit + stream <- pure $ OM.toWriteable $ SR.toOutgoingMessage response + void $ writeString' stream UTF8 "test" $ const $ end' stream $ const $ done $ Right unit pure nonCanceler } it "writes the headers" do diff --git a/test/Test/HTTPurple/ServerSpec.purs b/test/Test/HTTPurple/ServerSpec.purs index 59e3e20..6a5224a 100644 --- a/test/Test/HTTPurple/ServerSpec.purs +++ b/test/Test/HTTPurple/ServerSpec.purs @@ -3,20 +3,13 @@ module Test.HTTPurple.ServerSpec where import Prelude import Control.Monad.Except (throwError) -import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) -import Data.Maybe (Maybe(Nothing)) -import Data.Options ((:=)) import Effect.Class (liftEffect) import Effect.Exception (error) import Foreign.Object (empty) import HTTPurple.Request (Request) -import HTTPurple.Response (ResponseM, notFound, ok) +import HTTPurple.Response (ResponseM, ok) 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 as RD import Routing.Duplex.Generic as G diff --git a/test/Test/HTTPurple/TestHelpers.purs b/test/Test/HTTPurple/TestHelpers.purs index eacf8b9..8cfa3b9 100644 --- a/test/Test/HTTPurple/TestHelpers.purs +++ b/test/Test/HTTPurple/TestHelpers.purs @@ -2,40 +2,29 @@ module Test.HTTPurple.TestHelpers where import Prelude -import Data.Array (fromFoldable) as Array import Data.Either (Either(Right)) -import Data.List (List(Nil, Cons), reverse) import Data.Maybe (fromMaybe) -import Data.Options ((:=)) import Data.String (toLower) import Data.Tuple (Tuple) import Effect (Effect) import Effect.Aff (Aff, makeAff, nonCanceler) import Effect.Class (liftEffect) -import Effect.Ref (modify_, new, read) +import Foreign (Foreign) import Foreign.Object (Object, lookup) import Foreign.Object (fromFoldable) as Object -import Node.Buffer (Buffer, concat, create, fromString) -import Node.Buffer (toString) as Buffer +import Node.Buffer (Buffer, create, fromString) +import Node.Buffer (concat, toString) as Buffer import Node.Encoding (Encoding(UTF8)) -import Node.HTTP (Request) -import Node.HTTP (Response) as HTTP -import Node.HTTP.Client - ( RequestHeaders(RequestHeaders) - , headers - , hostname - , method - , path - , port - , protocol - , rejectUnauthorized - , requestAsStream - , responseAsStream - , responseHeaders - , statusCode - ) -import Node.HTTP.Client (Response, request) as HTTPClient -import Node.Stream (Readable, end, onData, onEnd, write) +import Node.EventEmitter (once_) +import Node.HTTP as HTTP +import Node.HTTP.ClientRequest as HTTPClient +import Node.HTTP.IncomingMessage as IM +import Node.HTTP.OutgoingMessage as OM +import Node.HTTP.Types (IMClientRequest, IncomingMessage, ServerResponse) +import Node.HTTPS as HTTPS +import Node.Stream (Readable) +import Node.Stream as Stream +import Node.Stream.Aff (readableToBuffers) import Test.Spec (Spec) import Test.Spec.Assertions (shouldEqual) import Unsafe.Coerce (unsafeCoerce) @@ -57,27 +46,32 @@ request :: Object String -> String -> Buffer -> - Aff HTTPClient.Response + Aff (IncomingMessage IMClientRequest) request secure port' method' headers' path' body = makeAff \done -> do - req <- HTTPClient.request options $ Right >>> done - let stream = requestAsStream req + req <- case secure of + 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 - $ write stream body + $ Stream.write' stream body $ const - $ end stream - $ const - $ pure unit + $ Stream.end stream 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. request' :: @@ -86,7 +80,7 @@ request' :: String -> Object String -> String -> - Aff HTTPClient.Response + Aff (IncomingMessage IMClientRequest) request' secure port method headers path = liftEffect (create 0) >>= request secure port method headers path @@ -99,29 +93,19 @@ requestString :: Object String -> String -> String -> - Aff HTTPClient.Response + Aff (IncomingMessage IMClientRequest) requestString secure port method headers path body = do liftEffect (fromString body UTF8) >>= request secure port method headers path -- | Convert a request to an Aff containing the `Buffer with the response body. -toBuffer :: HTTPClient.Response -> Aff Buffer -toBuffer response = - makeAff \done -> do - let - 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 +toBuffer :: IncomingMessage IMClientRequest -> Aff Buffer +toBuffer response = do + bufs <- readableToBuffers $ IM.toReadable response + liftEffect $ Buffer.concat bufs -- | 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 buf <- toBuffer resp 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 -- | value. -extractHeader :: String -> HTTPClient.Response -> String -extractHeader header = unmaybe <<< lookup' <<< responseHeaders +extractHeader :: String -> IncomingMessage IMClientRequest -> String +extractHeader header = unmaybe <<< lookup' <<< IM.headers where unmaybe = fromMaybe "" @@ -196,45 +180,47 @@ getStatus :: Object String -> String -> 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 foreign import mockRequestImpl :: + forall a. String -> String -> String -> String -> Object String -> - Effect Request + Effect (IncomingMessage a) -- | Mock an HTTP Request object mockRequest :: + forall a. String -> String -> String -> String -> Array (Tuple String String) -> - Aff Request + Aff (IncomingMessage a) mockRequest httpVersion method url body = liftEffect <<< mockRequestImpl httpVersion method url body <<< Object.fromFoldable -- | 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 -- | with an object returned from mockResponse). -getResponseBody :: HTTP.Response -> String +getResponseBody :: ServerResponse -> String getResponseBody = _.body <<< unsafeCoerce -- | Get the currently set status from an HTTP Response object. -getResponseStatus :: HTTP.Response -> Int +getResponseStatus :: ServerResponse -> Int getResponseStatus = _.statusCode <<< unsafeCoerce -- | Get all current headers on the HTTP Response object. -getResponseHeaders :: HTTP.Response -> Object (Array String) +getResponseHeaders :: ServerResponse -> Object (Array String) getResponseHeaders = unsafeCoerce <<< _.headers <<< unsafeCoerce -- | 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 -- | Create a stream out of a string.