Fixes to JSON-RPC and WebSocket clients (#1189)

Some JSON-RPC servers do not accept `Content-Type:
application/json-rpc`. The programmer must now specialize their code for
their own uses.

The WebSocket client was wrongly terminating when the server did not
respond with a Sec-Websocket-Version header. Our logic was flawed and we
now fail when it is present. See
https://datatracker.ietf.org/doc/html/rfc6455#section-4.4.

---------

Co-authored-by: François-René Rideau <fare@tunes.org>

doc/reference/std/net/json-rpc.md

@@ -48,6 +48,13 @@ A variety of HTTP or JSON-RPC errors can be raised during the query
 that you may or may not want to report, log or inspect, but otherwise
 this is the only function you need to call as a JSON RPC client.
 
+As for headers, you should follow the documentation and examples
+for the services you're using, and lacking that may try some as follows:
+```
+headers: '(("Content-Type" . "application/json-rpc")
+           ("Accept" . "application/json-rpc, application/json, application/jsonrequest"))
+```
+
 ## json-rpc-handler
 ```
 (json-rpc-handler processor log: (log #f))

src/std/net/json-rpc.ss

@@ -155,14 +155,7 @@
                                         message: (error-message e))))))
           (http-post server-url
                      auth: auth
-                     headers: `(("Content-Type" . "application/json-rpc")
-                                ;; The JSON RPC over HTTP standard says we MUST send
-                                ;; some variant of the Accept header below, but actually
-                                ;; no client bothers sending it, no server bothers checking it,
-                                ;; and it can only make things slower and trigger unwanted
-                                ;; edge cases, so we don't bother sending it either.
-                                ;; ("Accept" . "application/json-rpc, application/json, application/jsonrequest")
-                                ,@headers)
+                     headers: headers
                      ssl-context: ssl-context
                      cookies: cookies
                      data: data)))
@@ -187,9 +180,7 @@
                   ("id" .,id))))
           (http-get server-url
                     auth: auth
-                    headers: `(("Content-Type" . "application/json-rpc")
-                               ;; NB: we don't bother with an Accept header here, either.
-                               ,@headers)
+                    headers: headers
                     params: uri-params
                     ssl-context: ssl-context
                     cookies: cookies)))

src/std/net/websocket/client.ss

@@ -69,7 +69,8 @@
                          "bad server response; no websocket upgrade"
                          url Upgrade))
 
-       (unless (and Sec-Websocket-Version (equal? (cdr Sec-Websocket-Version) +websocket-version+))
+       ;; We only support a single version
+       (when Sec-Websocket-Version
          (raise-io-error websocket-connect
                          "bad server response; unsupported websocket version"
                          Sec-Websocket-Version))

src/std/net/websocket/server.ss

@@ -14,7 +14,7 @@
 (def +websocket-version+ "13")
 (def +websocket-magic+ "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")
 
-;; creates an httpd handler that handles ws/wss requests
+;; Creates an httpd handler that handles ws/wss requests
 ;; - continue is a procedure that receives a newly accepted websocket to handle
 ;;   the request. When this process returns the handler closes the request.
 ;; - protocol is a procedure to select a protocol, if the client has specified
@@ -30,44 +30,42 @@
       (websocket-handle-request req res continue select-protocol max-frame-size))))
 
 (def (websocket-handle-request req res continue select-protocol max-frame-size)
-  (let/cc exit
-    (def (bad-request! message)
-      (http-response-write res 400 [] message)
-      (exit 'bad-request))
+  (def (bad-request! message)
+    (http-response-write res 400 [["Sec-Websocket-Version" . +websocket-version+]] message)
+    (raise 'bad-request))
 
-    (let* ((request-headers (http-request-headers req))
-           (_ (alet (version (aget "Sec-Websocket-Version" request-headers))
-                (unless (equal? version +websocket-version+)
-                  (bad-request! "unusupported websocket protocol version"))))
-           (proto
-            (alet (request-proto (aget "Sec-Websocket-Protocol" request-headers))
-              (cond
-               ((select-protocol (string-split request-proto #\,)))
-               (else
-                (bad-request! "unsupported websocket protocol")))))
-           (auth
-            (alet (nonce64 (aget "Sec-Websocket-Key" request-headers))
-              (let* ((digest (make-digest digest::sha1))
-                     (_ (digest-update! digest (string->utf8 nonce64)))
-                     (_ (digest-update! digest (string->utf8 +websocket-magic+)))
-                     (auth (digest-final! digest)))
-                (base64-encode auth))))
-           ;; TODO do we need any more headers?
-           (upgrade-headers
-            [["Upgrade" . "websocket"]
-             ["Sec-Websocket-Version" . +websocket-version+]
-             (if auth
-               [["Sec-Websocket-Accept" . auth]]
-               [])
-             ...
-             (if proto
-               [["Sec-Websocket-Protocol" . proto]]
-               [])
-             ...])
-           ((values sock reader writer)
-            (http-response-upgrade! res upgrade-headers)))
-      (continue
-       (WebSocket (make-websocket sock reader writer
-                                  #t    ; server socket
-                                  proto
-                                  max-frame-size))))))
+  (let* ((request-headers (http-request-headers req))
+         (_ (alet (version (aget "Sec-Websocket-Version" request-headers))
+              (unless (equal? version +websocket-version+)
+                (bad-request! "unsupported websocket protocol version"))))
+         (proto
+          (alet (request-proto (aget "Sec-Websocket-Protocol" request-headers))
+            (cond
+             ((select-protocol (string-split request-proto #\,)))
+             (else
+              (bad-request! "unsupported websocket protocol")))))
+         (auth
+          (alet (nonce64 (aget "Sec-Websocket-Key" request-headers))
+            (let* ((digest (make-digest digest::sha1))
+                   (_ (digest-update! digest (string->utf8 nonce64)))
+                   (_ (digest-update! digest (string->utf8 +websocket-magic+)))
+                   (auth (digest-final! digest)))
+              (base64-encode auth))))
+         ;; TODO do we need any more headers?
+         (upgrade-headers
+          [["Upgrade" . "websocket"]
+           (if auth
+             [["Sec-Websocket-Accept" . auth]]
+             [])
+           ...
+           (if proto
+             [["Sec-Websocket-Protocol" . proto]]
+             [])
+           ...])
+         ((values sock reader writer)
+          (http-response-upgrade! res upgrade-headers)))
+    (continue
+     (WebSocket (make-websocket sock reader writer
+                                #t    ; server socket
+                                proto
+                                max-frame-size)))))