Address json-rpc review

src/std/net/json-rpc-test.ss

@@ -1,12 +1,12 @@
 ;;; -*- Gerbil -*-
 ;;; std/net/json-rpc unit-test
 
-(import :gerbil/gambit/threads
-        :gerbil/gambit/random
-        :std/test
+(import :std/iter
         :std/net/httpd
         :std/net/request
-        :std/net/json-rpc)
+        :std/net/json-rpc
+        :std/sugar
+        :std/test)
 (export json-rpc-test)
 
 (def server-address
@@ -25,18 +25,24 @@
   (test-suite "json-rpc test"
     (def httpd
       (start-http-server! server-address mux: (make-recursive-http-mux)))
-    (test-case "basic handlers"
-      (http-register-handler httpd "/json-rpc-test" (json-rpc-handler json-rpc-test-processor))
-      (def url (string-append server-url "/json-rpc-test"))
-      (def (this-json-rpc-error? number)
-        (lambda (e) (and (json-rpc-error? e) (equal? (json-rpc-error-code e) number))))
-      (check (json-rpc url "ping" '(42)) => '("pong" (42)))
-      (check (json-rpc url "add" '(1 2 3 4)) => 10)
-      (check-exception (json-rpc url 42)
-                       (this-json-rpc-error? -32600)) ;; invalid-request
-      (check-exception (json-rpc url "meaning-of-life")
-                       (this-json-rpc-error? -32601)) ;; method-not-found
-      (check-exception (json-rpc url "ping" 42)
-                       (this-json-rpc-error? -32602)) ;; invalid-params
-      (void))
+    (http-register-handler httpd "/json-rpc-test" (json-rpc-handler json-rpc-test-processor))
+    (def url (string-append server-url "/json-rpc-test"))
+    (def (query . args)
+      (display "query: ") (write args) (newline)
+      (apply json-rpc url args))
+    (def (this-json-rpc-error? number)
+      (lambda (e) (and (json-rpc-error? e) (equal? (json-rpc-error-code e) number))))
+    (defrule (check-e expr code) (check-exception expr (this-json-rpc-error? code)))
+    (def (test-basic-handlers http-method)
+      (def (q . a) (apply query http-method: http-method a))
+      (check (q "ping" '(42)) => '("pong" (42)))
+      (check (q "add" '(1 2 3 4)) => 10)
+      (check-e (q "ping" 42) -32602) ;; invalid-params
+      (check-e (q "meaning-of-life") -32601)) ;; method-not-found
+    (test-case "basic handlers with POST"
+      (test-basic-handlers 'POST)
+      (check-exception (query 42 http-method: 'POST) (this-json-rpc-error? -32600))) ;; invalid-request
+    (test-case "basic handlers with GET"
+      (test-basic-handlers 'GET)
+      (check-exception (query 42 http-method: 'GET) true)) ;; can't uri-encode number 42
     (stop-http-server! httpd)))

src/std/net/json-rpc.ss

@@ -1,5 +1,6 @@
 ;; Support for JSON RPC 2.0 -- https://www.jsonrpc.org/specification
 ;; JSON RPC over HTTP (historical): https://www.jsonrpc.org/historical/json-rpc-over-http.html
+;; See also https://www.simple-is-better.org/json-rpc/transport_http.html#get-request
 ;; In practice, we try to support existing clients and servers,
 ;; that don't follow various subsets of the specification
 ;; (especially the HTTP spec, but many clients and servers only do 1.0, 1.1 or 1.2)
@@ -8,14 +9,17 @@
 (export #t)
 
 (import
-  :gerbil/gambit/ports
-  :gerbil/gambit/exceptions
-  :std/error
-  :std/format
-  :std/net/httpd
-  :std/net/request
-  :std/sugar
-  :std/text/json)
+  (only-in :std/error Exception <error>)
+  (only-in :std/net/httpd http-response-write http-response-write-condition
+           http-request-body http-request-params http-request-method
+           Bad-Request Internal-Server-Error)
+  (only-in :std/net/request http-post http-get request-response-bytes)
+  (only-in :std/net/ssl default-client-ssl-context)
+  (only-in :std/net/uri form-url-decode uri-decode)
+  (only-in :std/sugar try catch hash)
+  (only-in :std/text/base64 u8vector->base64-string base64-string->u8vector)
+  (only-in :std/text/json trivial-json-object->class jsonable json-symbolic-keys
+           bytes->json-object json-object->bytes json-object->string))
 
 (defstruct (json-rpc-error <error>) ()
 ;;  (code    ;; SInt16
@@ -103,46 +107,80 @@
 (defclass (malformed-request jsonable Exception) (method params e) transparent: #t)
 (defclass (malformed-response jsonable Exception) (request-id response e) transparent: #t)
 
+(def (bytes->json b) ;; Don't intern JSON keys, using strings
+  (parameterize ((json-symbolic-keys #f)) (bytes->json-object b)))
+
 ;;; Client code
 (def (json-rpc server-url method (params (void))
                auth: (auth #f)
                headers: (headers #f)
                cookies: (cookies #f)
+               ssl-context: (ssl-context (default-client-ssl-context))
                result-decoder: (result-decoder identity)
                param-encoder: (param-encoder identity)
                timeout: (timeout rpc-timeout)
-               log: (log #f))
+               log: (log #f)
+               http-method: (http-method 'POST))
   (def id (id-counter))
-  (def request-string (request->string method (param-encoder params) id))
   (when log
-    (log [to: server-url request: request-string]))
+    (log [jsonrpc: server-url method: method params: params id: id]))
   ;; TODO: implement timeouts, with semi-asynchronous aborts the http-post thread itself.
   (def response-bytes
     (request-response-bytes
-     (http-post server-url
-                auth: auth
-                headers: `(("Content-Type" . "application/json-rpc")
-                           ;; ("Accept" . "application/json-rpc, application/json, application/jsonrequest")
-                           ,@headers)
-                cookies: cookies
-                data: (string->bytes request-string))))
+     (case http-method
+       ((POST)
+        (let (data
+              (try (json-object->bytes
+                    (json-rpc-request jsonrpc: json-rpc-version
+                                      method: method params: params id: id))
+                   (catch (e) (raise (malformed-request method: method params: params
+                                                        e: (error-message e))))))
+          (http-post server-url
+                     auth: auth
+                     headers: `(("Content-Type" . "application/json-rpc")
+                                ;; ("Accept" . "application/json-rpc, application/json, application/jsonrequest")
+                                ,@headers)
+                     ssl-context: ssl-context
+                     cookies: cookies
+                     data: data)))
+       ;; NB: the GET http-method is strongly disrecommended:
+       ;; It is only supported by few servers,
+       ;; only appropriate for calls to safe and idempotent methods
+       ;; that may or may not be cached on the way to the actual server,
+       ;; when the encoded parameters lead to a URI length too long
+       ;; for caches and proxies (say over 255 bytes).
+       ((GET)
+        (set! id (number->string id)) ;; GET method wants string id.
+        (let* ((base64-params
+                (try (u8vector->base64-string (json-object->bytes params))
+                     (catch (e) (raise (malformed-request
+                                        method: method params: params
+                                        e: (error-message e))))))
+               (uri-params
+                `(("jsonrpc" .,json-rpc-version)
+                  ("method" .,method)
+                  ("params" .,base64-params)
+                  ("id" .,id))))
+          (http-get server-url
+                    auth: auth
+                    headers: `(("Content-Type" . "application/json-rpc")
+                               ;; ("Accept" . "application/json-rpc, application/json, application/jsonrequest")
+                               ,@headers)
+                    params: uri-params
+                    ssl-context: ssl-context
+                    cookies: cookies)))
+       (else (raise (error "Invalid http method" http-method))))))
   (def response-json
     (try
-       (parameterize ((json-symbolic-keys #f)) ;; Don't intern JSON keys, using strings
-         (bytes->json-object response-bytes)) ;; todo: move to decode-json-rpc-response ?
-       (catch (e) (raise (malformed-response request-id: id response: response-bytes e: e)))))
+     (bytes->json response-bytes) ;; todo: move to decode-json-rpc-response ?
+     (catch (e) (raise (malformed-response request-id: id response: response-bytes e: e)))))
   (when log
     (log [from: server-url response: (bytes->string response-bytes)]))
   (decode-json-rpc-response
    result-decoder
    (and (hash-table? response-json) (hash-get response-json "id"))
    response-json))
 
-(def (request->string method params id)
-  (try (json-object->string
-        (json-rpc-request jsonrpc: json-rpc-version method: method params: params id: id))
-       (catch (e) (raise (malformed-request method: method params: params e: (error-message e))))))
-
 (def (decode-json-rpc-response decoder request-id response-json)
   (def (mal e)
     (raise (malformed-response request-id: request-id response: response-json e: (error-message e))))
@@ -170,31 +208,52 @@
      "application/json" "application/jsonrequest"))) ;; MAY be these
 
 ;; http handler for json-rpc
-;; NB: Be sure to wrap into a condition-handler, or some such.
+;; NB: This will catch any exception raised and convert it into an error notified to the client.
+;; TODO: have an optional parameter to specify a logging facility for those errors we find.
 (def (json-rpc-handler processor)
   (lambda (req res)
     (let/cc return
       (def (bad-request)
         (http-response-write-condition res Bad-Request)
         (return))
-      ;; Skip these checks specified in JSON RPC over HTTP
+      ;; Skip these checks specified in JSON RPC over HTTP, but not heeded by most clients.
       #;(let (headers (http-request-headers req))
           (unless (and (member (assget "Content-Type" headers) +json-rpc-content-types+)
                        (assget "Content-Length" headers)
                        (member (assget "Accept" headers) +json-rpc-content-types+))
             (bad-request)))
       (case (http-request-method req)
-        ;; TODO: implement GET as per https://www.jsonrpc.org/historical/json-rpc-over-http.html
-        #;((GET) (json-rpc-handler/GET req res processor))
-        ((POST) (json-rpc-handler/POST req res processor))
+        ((POST) (json-rpc-handler/POST req res processor)) ;; preferred method
+        ((GET) (json-rpc-handler/GET req res processor)) ;; mostly for testing
         (else (bad-request))))))
 
 (def (json-rpc-handler/POST req res processor)
   (let/cc return
     (def request-json
       (try
-       (parameterize ((json-symbolic-keys #f)) ;; Don't intern JSON keys, using strings
-         (bytes->json-object (http-request-body req)))
+       (bytes->json (http-request-body req))
+       (catch (_)
+         (json-rpc-handler/response-json
+          res (hash ("jsonrpc" "2.0") ("error" (parser-error))))
+         (return))))
+    (json-rpc-handler/JSON res processor request-json)))
+
+(def (json-rpc-handler/GET req res processor)
+  (let/cc return
+    (def request-json
+      (try
+       (def url-params (form-url-decode (http-request-params req)))
+       (def method (assget "method" url-params (void)))
+       (def params (bytes->json
+                    (base64-string->u8vector
+                     (uri-decode
+                      (assget "params" url-params)))))
+       (def json (hash ("method" method) ("params" params)))
+       (def jsonrpc (assget "jsonrpc" url-params))
+       (when jsonrpc (hash-put! json "jsonrpc" jsonrpc))
+       (def id (assget "id" url-params))
+       (when id (hash-put! json "id" id))
+       json
        (catch (_)
          (json-rpc-handler/response-json
           res (hash ("jsonrpc" "2.0") ("error" (parser-error))))

src/std/stxutil.ss

@@ -15,11 +15,6 @@
   (datum->syntax ctx (string->symbol (apply format fmt (map stx-e args)))
                  (stx-source ctx)))
 
-#;(import
-  (for-syntax :std/iter :std/srfi/1)
-  <expander-runtime> :gerbil/expander :std/misc/ports :std/sugar
-  ./basic-parsers ./path)
-
 ;; Use maybe-intern-symbol instead of string->symbol to avoid DoS attacks
 ;; that cause you to intern too many symbols and run out of memory.
 ;; : (Or Symbol String) <- String

src/std/text/json/output.ss

@@ -202,4 +202,4 @@
 
 (defjson-writer port write-char write-string)
 (defjson-writer writer writer-write-char writer-write-string)
-(defjson-writer buffer buffer-write-char buffer-write-string)
+(defjson-writer buffer buffer-write-char buffer-write-string)

src/std/text/json/util.ss

@@ -48,7 +48,7 @@
 
 (def (json-object->bytes obj)
   (let (buffer (open-buffered-writer #f))
-    (write-json-object/writer obj buffer (make-env))
+    (write-json-object/buffer obj buffer (make-env))
     (get-buffer-output-u8vector buffer)))
 
 (def (trivial-class->json-object object)