Add support for update events

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

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

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) {

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

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