diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2e4c7a1..66354b4 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,7 +14,7 @@ jobs: - uses: purescript-contrib/setup-purescript@main with: - purescript: "0.14.0-rc3" + purescript: "0.14.0-rc5" - uses: actions/setup-node@v1 with: diff --git a/bower.json b/bower.json index e086c3c..24cab73 100644 --- a/bower.json +++ b/bower.json @@ -22,6 +22,7 @@ "purescript-foreign-object": "master", "purescript-maybe": "master", "purescript-node-buffer": "master", + "purescript-node-net": "master", "purescript-node-streams": "master", "purescript-node-url": "master", "purescript-nullable": "main", diff --git a/src/Node/HTTP.js b/src/Node/HTTP.js index 76f974b..a059f40 100644 --- a/src/Node/HTTP.js +++ b/src/Node/HTTP.js @@ -46,6 +46,16 @@ exports.listenSocket = function (server) { }; }; +exports.onUpgrade = function (server) { + return function (cb) { + return function () { + server.on("upgrade", function (req, socket, buffer) { + return cb(req)(socket)(buffer)(); + }); + }; + }; +}; + exports.setHeader = function (res) { return function (key) { return function (value) { diff --git a/src/Node/HTTP.purs b/src/Node/HTTP.purs index e43c5fe..0c8c95a 100644 --- a/src/Node/HTTP.purs +++ b/src/Node/HTTP.purs @@ -10,6 +10,7 @@ module Node.HTTP , close , ListenOptions , listenSocket + , onUpgrade , httpVersion , requestHeaders @@ -30,6 +31,8 @@ import Data.Maybe (Maybe) import Data.Nullable (Nullable, toNullable) import Effect (Effect) import Foreign.Object (Object) +import Node.Buffer (Buffer) +import Node.Net.Socket (Socket) import Node.Stream (Writable, Readable) import Unsafe.Coerce (unsafeCoerce) @@ -67,6 +70,9 @@ type ListenOptions = -- | Listen on a unix socket. The specified callback will be run when setup is complete. foreign import listenSocket :: Server -> String -> Effect Unit -> Effect Unit +-- | Listen to `upgrade` events on the server +foreign import onUpgrade :: Server -> (Request -> Socket -> Buffer -> Effect Unit) -> Effect Unit + -- | Get the request HTTP version httpVersion :: Request -> String httpVersion = _.httpVersion <<< unsafeCoerce diff --git a/test/Main.purs b/test/Main.purs index 7087c82..d5860c2 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -3,14 +3,17 @@ module Test.Main where import Prelude import Data.Foldable (foldMap) -import Data.Maybe (Maybe(..)) +import Data.Maybe (Maybe(..), fromMaybe) import Data.Options (Options, options, (:=)) +import Data.Tuple (Tuple(..)) import Effect (Effect) import Effect.Console (log, logShow) +import Foreign.Object (fromFoldable, lookup) import Node.Encoding (Encoding(..)) -import Node.HTTP (Request, Response, listen, createServer, setHeader, requestMethod, requestURL, responseAsStream, requestAsStream, setStatusCode) +import Node.HTTP (Request, Response, listen, createServer, setHeader, requestHeaders, requestMethod, requestURL, responseAsStream, requestAsStream, setStatusCode, onUpgrade) import Node.HTTP.Client as Client import Node.HTTP.Secure as HTTPS +import Node.Net.Socket as Socket import Node.Stream (Writable, end, pipe, writeString) import Partial.Unsafe (unsafeCrashWith) import Unsafe.Coerce (unsafeCoerce) @@ -20,6 +23,7 @@ foreign import stdout :: forall r. Writable r main :: Effect Unit main = do testBasic + testUpgrade testHttpsServer testHttps testCookies @@ -154,3 +158,67 @@ logResponse response = void do log "Response:" let responseStream = Client.responseAsStream response pipe responseStream stdout + +testUpgrade :: Effect Unit +testUpgrade = do + server <- createServer respond + onUpgrade server handleUpgrade + listen server { hostname: "localhost", port: 3000, backlog: Nothing } + $ void do + log "Listening on port 3000." + sendRequests + where + handleUpgrade req socket buffer = do + let upgradeHeader = fromMaybe "" $ lookup "upgrade" $ requestHeaders req + if upgradeHeader == "websocket" then + void $ Socket.writeString + socket + "HTTP/1.1 101 Switching Protocols\r\nContent-Length: 0\r\n\r\n" + UTF8 + $ pure unit + else + void $ Socket.writeString + socket + "HTTP/1.1 426 Upgrade Required\r\nContent-Length: 0\r\n\r\n" + UTF8 + $ pure unit + + sendRequests = do + -- This tests that the upgrade callback is not called when the request is not an HTTP upgrade + reqSimple <- Client.request (Client.port := 3000) \response -> do + if (Client.statusCode response /= 200) then + unsafeCrashWith "Unexpected response to simple request on `testUpgrade`" + else + pure unit + end (Client.requestAsStream reqSimple) (pure unit) + {- + These two requests test that the upgrade callback is called and that it has + access to the original request and can write to the underlying TCP socket + -} + let headers = Client.RequestHeaders $ fromFoldable + [ Tuple "Connection" "upgrade" + , Tuple "Upgrade" "something" + ] + reqUpgrade <- Client.request + (Client.port := 3000 <> Client.headers := headers) + \response -> do + if (Client.statusCode response /= 426) then + unsafeCrashWith "Unexpected response to upgrade request on `testUpgrade`" + else + pure unit + end (Client.requestAsStream reqUpgrade) (pure unit) + + let wsHeaders = Client.RequestHeaders $ fromFoldable + [ Tuple "Connection" "upgrade" + , Tuple "Upgrade" "websocket" + ] + + reqWSUpgrade <- Client.request + (Client.port := 3000 <> Client.headers := wsHeaders) + \response -> do + if (Client.statusCode response /= 101) then + unsafeCrashWith "Unexpected response to websocket upgrade request on `testUpgrade`" + else + pure unit + end (Client.requestAsStream reqWSUpgrade) (pure unit) + pure unit