Skip to content

Commit

Permalink
Fixes to JSON-RPC and WebSocket clients (#1189)
Browse files Browse the repository at this point in the history
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>
belmarca and fare authored Apr 12, 2024
1 parent 7ece9dd commit 05b056f
Showing 4 changed files with 50 additions and 53 deletions.
7 changes: 7 additions & 0 deletions doc/reference/std/net/json-rpc.md
Original file line number Diff line number Diff line change
@@ -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))
13 changes: 2 additions & 11 deletions src/std/net/json-rpc.ss
Original file line number Diff line number Diff line change
@@ -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)))
3 changes: 2 additions & 1 deletion src/std/net/websocket/client.ss
Original file line number Diff line number Diff line change
@@ -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))
80 changes: 39 additions & 41 deletions src/std/net/websocket/server.ss
Original file line number Diff line number Diff line change
@@ -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)))))

0 comments on commit 05b056f

Please sign in to comment.