Add WebSocket subprotocol negotiation (RFC 6455 §4.2.2)

CHANGELOG.md

@@ -4,6 +4,13 @@
 
 ### Added
 
+- **WebSocket subprotocol negotiation** (RFC 6455 §4.2.2). `App.WSP` registers
+  a WebSocket route with a list of supported subprotocols. During the upgrade
+  handshake, the server selects the first client-requested protocol that appears
+  in the route's list and includes `Sec-WebSocket-Protocol` in the 101 response.
+  The negotiated protocol is available to handlers via `(WebSocket.protocol ws)`.
+  `App.WS` is unchanged and does not negotiate subprotocols.
+
 - **WebSocket server-initiated ping with dead client detection.**
   `WebSocket.encode-ping` encodes a ping frame. The server automatically sends
   ping frames to idle WebSocket connections (after `App.ws-ping-interval`
@@ -52,6 +59,16 @@
 
 ### Changed
 
+- `WSRoute` gains a `protocols` field (`(Array String)`) listing supported
+  subprotocols. Existing `App.WS` calls pass an empty array for backward
+  compatibility.
+- `WebSocket` gains a `protocol` field (`(Maybe String)`) holding the
+  negotiated subprotocol, or `Nothing` if none was negotiated.
+- `ConnState` gains a `ws-protocol` map for tracking the negotiated
+  subprotocol per WebSocket connection.
+- `web-try-ws-upgrade` return type gains a `(Maybe String)` for the
+  negotiated protocol. `handle-ws-upgrade` includes `Sec-WebSocket-Protocol`
+  in the 101 response when a protocol was negotiated.
 - `ConnState` gains `ws-ping-count` and `ws-last-ping` maps for tracking
   server-initiated ping state per WebSocket connection.
 - `sweep-idle` now takes a `poll` parameter and sends ping frames to idle

test/websocket.carp

@@ -868,4 +868,148 @@
   (assert-equal test
     1
     (App.ws-ping-action 30 3 60 0 0 false)
-    "after pong resets pcount to 0: resumes pinging"))
+    "after pong resets pcount to 0: resumes pinging")
+
+  ; ---------------------------------------------------------------------------
+  ; ws-parse-protocols (Sec-WebSocket-Protocol header parsing)
+  ; ---------------------------------------------------------------------------
+
+  (assert-equal test
+    &[@"chat" @"superchat"]
+    &(ws-parse-protocols "chat, superchat")
+    "parse-protocols splits comma-separated values")
+
+  (assert-equal test
+    &[@"chat" @"superchat"]
+    &(ws-parse-protocols "chat,superchat")
+    "parse-protocols handles no spaces")
+
+  (assert-equal test
+    &[@"chat"]
+    &(ws-parse-protocols "chat")
+    "parse-protocols single value")
+
+  (assert-equal test
+    &(the (Array String) [])
+    &(ws-parse-protocols "")
+    "parse-protocols empty string")
+
+  (assert-equal test
+    &[@"rpc" @"chat-v2"]
+    &(ws-parse-protocols "  rpc , chat-v2  ")
+    "parse-protocols trims whitespace")
+
+  ; ---------------------------------------------------------------------------
+  ; ws-negotiate-protocol (subprotocol selection)
+  ; ---------------------------------------------------------------------------
+
+  (assert-equal test
+    &(Maybe.Just @"chat")
+    &(ws-negotiate-protocol &[@"chat" @"rpc"] &[@"rpc" @"chat"])
+    "negotiate selects first client protocol found in server list")
+
+  (assert-equal test
+    &(Maybe.Just @"rpc")
+    &(ws-negotiate-protocol &[@"rpc" @"chat"] &[@"rpc" @"chat"])
+    "negotiate respects client preference order")
+
+  (assert-equal test
+    &(the (Maybe String) (Maybe.Nothing))
+    &(ws-negotiate-protocol &[@"foo"] &[@"bar" @"baz"])
+    "negotiate returns Nothing when no match")
+
+  (assert-equal test
+    &(the (Maybe String) (Maybe.Nothing))
+    &(ws-negotiate-protocol &(the (Array String) []) &[@"chat"])
+    "negotiate returns Nothing when client list empty")
+
+  (assert-equal test
+    &(the (Maybe String) (Maybe.Nothing))
+    &(ws-negotiate-protocol &[@"chat"] &(the (Array String) []))
+    "negotiate returns Nothing when server list empty")
+
+  ; ---------------------------------------------------------------------------
+  ; Subprotocol negotiation through upgrade path
+  ; ---------------------------------------------------------------------------
+
+  (assert-true test
+    (let [app (App.WSP (App.create)
+                       @"/ws"
+                       [@"chat-v2" @"chat-v1"]
+                       (fn [e p w] ()))
+          buf (String.to-bytes
+            &@"GET /ws HTTP/1.1\r\nHost: x\r\nUpgrade: websocket\r\nSec-WebSocket-Version: 13\r\nSec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\nSec-WebSocket-Protocol: chat-v1, chat-v2\r\n\r\n")]
+      (match (web-try-ws-upgrade &buf (App.ws-routes &app))
+        (Maybe.Just info)
+          (= &(Maybe.Just @"chat-v1") (Pair.a (Pair.b (Pair.b &info))))
+        (Maybe.Nothing) false))
+    "upgrade negotiates first matching client protocol")
+
+  (assert-true test
+    (let [app (App.WSP (App.create)
+                       @"/ws"
+                       [@"chat-v2" @"chat-v1"]
+                       (fn [e p w] ()))
+          buf (String.to-bytes
+            &@"GET /ws HTTP/1.1\r\nHost: x\r\nUpgrade: websocket\r\nSec-WebSocket-Version: 13\r\nSec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\nSec-WebSocket-Protocol: chat-v2\r\n\r\n")]
+      (match (web-try-ws-upgrade &buf (App.ws-routes &app))
+        (Maybe.Just info)
+          (= &(Maybe.Just @"chat-v2") (Pair.a (Pair.b (Pair.b &info))))
+        (Maybe.Nothing) false))
+    "upgrade negotiates single matching protocol")
+
+  (assert-true test
+    (let [app (App.WSP (App.create)
+                       @"/ws"
+                       [@"chat-v2" @"chat-v1"]
+                       (fn [e p w] ()))
+          buf (String.to-bytes
+            &@"GET /ws HTTP/1.1\r\nHost: x\r\nUpgrade: websocket\r\nSec-WebSocket-Version: 13\r\nSec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\nSec-WebSocket-Protocol: unknown-proto\r\n\r\n")]
+      (match (web-try-ws-upgrade &buf (App.ws-routes &app))
+        (Maybe.Just info) (Maybe.nothing? (Pair.a (Pair.b (Pair.b &info))))
+        (Maybe.Nothing) false))
+    "upgrade with no matching protocol returns Nothing protocol")
+
+  (assert-true test
+    (let [app (App.WSP (App.create)
+                       @"/ws"
+                       [@"chat-v2" @"chat-v1"]
+                       (fn [e p w] ()))
+          buf (String.to-bytes
+            &@"GET /ws HTTP/1.1\r\nHost: x\r\nUpgrade: websocket\r\nSec-WebSocket-Version: 13\r\nSec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n\r\n")]
+      (match (web-try-ws-upgrade &buf (App.ws-routes &app))
+        (Maybe.Just info) (Maybe.nothing? (Pair.a (Pair.b (Pair.b &info))))
+        (Maybe.Nothing) false))
+    "upgrade without Sec-WebSocket-Protocol header returns Nothing protocol")
+
+  (assert-true test
+    (let [app (App.WS (App.create) @"/ws" (fn [e p w] ()))
+          buf (String.to-bytes
+            &@"GET /ws HTTP/1.1\r\nHost: x\r\nUpgrade: websocket\r\nSec-WebSocket-Version: 13\r\nSec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\nSec-WebSocket-Protocol: chat\r\n\r\n")]
+      (match (web-try-ws-upgrade &buf (App.ws-routes &app))
+        (Maybe.Just info) (Maybe.nothing? (Pair.a (Pair.b (Pair.b &info))))
+        (Maybe.Nothing) false))
+    "WS route (no protocols) ignores client Sec-WebSocket-Protocol")
+
+  ; ---------------------------------------------------------------------------
+  ; App.WSP route construction
+  ; ---------------------------------------------------------------------------
+
+  (assert-equal test
+    1
+    (let [app (-> (App.create) (App.WSP @"/ws/chat" [@"chat"] (fn [e p w] ())))]
+      (Array.length (App.ws-routes &app)))
+    "App.WSP adds a WS route")
+
+  (assert-equal test
+    &[@"chat-v2" @"chat-v1"]
+    &(let [app (-> (App.create)
+                   (App.WSP @"/ws/chat" [@"chat-v2" @"chat-v1"] (fn [e p w] ())))]
+      @(WSRoute.protocols (Array.unsafe-first (App.ws-routes &app))))
+    "App.WSP stores protocols on the route")
+
+  (assert-equal test
+    &(the (Array String) [])
+    &(let [app (-> (App.create) (App.WS @"/ws/echo" (fn [e p w] ())))]
+      @(WSRoute.protocols (Array.unsafe-first (App.ws-routes &app))))
+    "App.WS stores empty protocols on the route"))