From edae228eec16c3a73fb744a9060a29446237292c Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Sat, 16 Sep 2023 01:46:47 +0000 Subject: [PATCH] Address new round of json-rpc reviews --- src/std/build-spec.ss | 1 + src/std/misc/atom.ss | 88 ++++++++++++++++++++++++++++++ src/std/misc/string-test.ss | 18 +++---- src/std/misc/string.ss | 9 ++-- src/std/misc/with-id-test.ss | 2 +- src/std/net/httpd/handler.ss | 2 +- src/std/net/json-rpc-test.ss | 1 - src/std/net/json-rpc.ss | 101 ++++++++++++++++++----------------- src/std/net/uri.ss | 8 +-- src/std/values.ss | 8 ++- 10 files changed, 168 insertions(+), 70 deletions(-) create mode 100644 src/std/misc/atom.ss diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss index ccf4d9dd54..be6490136b 100644 --- a/src/std/build-spec.ss +++ b/src/std/build-spec.ss @@ -308,6 +308,7 @@ "crypto/kdf" "crypto" ;; :std/misc + "misc/atom" "misc/with-id" "misc/concurrent-plan" "misc/timeout" diff --git a/src/std/misc/atom.ss b/src/std/misc/atom.ss new file mode 100644 index 0000000000..9480e4df03 --- /dev/null +++ b/src/std/misc/atom.ss @@ -0,0 +1,88 @@ +;; Atoms in the style of clojure: shared, synchronous, independent state + +;; NB: Compared to the Clojure atom API, we: +;; - Do not support the meta field and the functions alter-meta! reset-meta! +;; - Replace swap-vals! and reset-vals! by swap-values! and reset-values! +;; returning values rather than vectors. +;; - Rename add-watch and remove-watch to add-watch! and remove-watch! +;; - Do not have generic functions that work on multiple kinds of "references" +;; but only one set of functions for atoms. +;; - Also export atom-increment! and atomic-counter for the common case. + +(import :gerbil/gambit/threads + :std/sugar + :std/values) + +(export atom deref + swap! swap-values! reset! reset-values! + compare-and-set! + get-validator set-validator! + add-watch! remove-watch! + atom-increment! atomic-counter) + +(defstruct Atom + (mutex value validator watchers) + final: #t) + +(def (atom (initial-value (void)) validator: (validator #f)) + (Atom (make-mutex 'atom) initial-value validator (hash))) + +(def deref Atom-value) + +;; Internal helper to ensure atomicity +(defrule (with-atom-lock a body ...) + (with-lock (Atom-mutex a) (lambda () body ...))) + +;; Internal helper to be called inside with-atom-lock +(def (update-atom! a new-val) + (with ((Atom _ old-val validator watchers) a) + (when validator (unless (validator new-val) (error "invalid atom value" new-val))) + (set! (Atom-value a) new-val) + (hash-for-each (lambda (key watch) (watch key a old-val new-val)) watchers) + (values old-val new-val))) + +;; analog to Clojure swap-values!, but returning (values old-val new-val) rather than [old-val new-val] +(def (swap-values! a f . args) + (with-atom-lock a (update-atom! a (apply f (deref a) args)))) + +;; same as Clojure swap! +(def (swap! a f . args) + (second-value (apply swap-values! a f args))) + +;; analog to Clojure reset-values!, but returning (values old-val new-val) rather than [old-val new-val] +(def (reset-values! a new-val) + (with-atom-lock a (update-atom! a new-val))) + +;; same as Clojure reset! +(def (reset! a new-val) + (second-value (reset-values! a new-val))) + +;; same as Clojure compare-and-set! +(def (compare-and-set! a old-val new-val) + (with-atom-lock a + (and (eq? (deref a) old-val) + (try (update-atom! a new-val) #t + (catch (_) #f))))) + +;; same as Clojure set-validator! +(def set-validator! Atom-validator-set!) + +;; same as Clojure get-validator +(def get-validator Atom-validator) + +;; same as Clojure add-watch +(def (add-watch! a key fn) + (with-atom-lock a + (hash-put! (Atom-watchers a) key fn))) + +;; same as Clojure remove-watch +(def (remove-watch! a key) + (with-atom-lock a + (hash-remove! (Atom-watchers a) key))) + +(def (atom-increment! atom (increment 1)) + (swap! atom + increment)) + +(def (atomic-counter (initial-value -1)) + (def a (atom initial-value)) + (lambda ((increment 1)) (swap! a + increment))) diff --git a/src/std/misc/string-test.ss b/src/std/misc/string-test.ss index 8e6d2102ea..ee0eab12e9 100644 --- a/src/std/misc/string-test.ss +++ b/src/std/misc/string-test.ss @@ -85,13 +85,13 @@ (check (str (values 1 2)) => "(values 1 2)") (check (str (make-point 1 2)) => "(point 1 2)")) (test-case "test string-substitute-char" - (check-equal? (string-substitute-char #\o #\a "banana") "bonono") - (check-equal? (string-substitute-char #\o #\a "banana" start: 3) "banono") - (check-equal? (string-substitute-char #\o #\a "banana" end: 5) "bonona") - (check-equal? (string-substitute-char #\o #\a "banana" start: 1 end: 5) "bonona") - (check-equal? (string-substitute-char #\o #\a "banana" count: 2) "bonona") - (check-equal? (string-substitute-char #\o #\a "banana" count: 2 from-end: #t) "banono") - (check-equal? (string-substitute-char #\o #\c "banana" test: char>?) "oonono") - (check-equal? (string-substitute-char #\o #\a "banana" test-not: equal?) "oaoaoa") - (check-equal? (string-substitute-char #\o #\A "banana" key: char-upcase) "bonono")) + (check-equal? (string-substitute-char "banana" #\o #\a) "bonono") + (check-equal? (string-substitute-char "banana" #\o #\a start: 3) "banono") + (check-equal? (string-substitute-char "banana" #\o #\a end: 5) "bonona") + (check-equal? (string-substitute-char "banana" #\o #\a start: 1 end: 5) "bonona") + (check-equal? (string-substitute-char "banana" #\o #\a count: 2) "bonona") + (check-equal? (string-substitute-char "banana" #\o #\a count: 2 from-end: #t) "banono") + (check-equal? (string-substitute-char "banana" #\o #\c test: char>?) "oonono") + (check-equal? (string-substitute-char "banana" #\o #\a test-not: equal?) "oaoaoa") + (check-equal? (string-substitute-char "banana" #\o #\A key: char-upcase) "bonono")) )) diff --git a/src/std/misc/string.ss b/src/std/misc/string.ss index 98dc818baa..847b86842e 100644 --- a/src/std/misc/string.ss +++ b/src/std/misc/string.ss @@ -257,9 +257,9 @@ ((? (or list? hash-table? vector? ##values? obj-pr?) v) "~r") (else "~a"))) -;; Like CL SUBSTITUTE but specialized for strings and chars +;; Like CL SUBSTITUTE-IF but specialized for strings and chars. Mind the argument order. (def (string-substitute-char-if - newchar predicate string + string newchar predicate start: (start #f) end: (end #f) from-end: (from-end? #f) @@ -283,8 +283,9 @@ (string-set! s i newchar)))))) s) +;; Like CL SUBSTITUTE but specialized for strings and chars. Mind the argument order. (def (string-substitute-char - newchar oldchar string + string newchar oldchar test: (test #f) test-not: (test-not #f) key: (key #f) @@ -301,5 +302,5 @@ (key (lambda (x) (eqv? oldchar (key x)))) (else (cut eqv? oldchar <>))))) (string-substitute-char-if - newchar predicate string + string newchar predicate start: start end: end count: count from-end: from-end? in-place: in-place?))) diff --git a/src/std/misc/with-id-test.ss b/src/std/misc/with-id-test.ss index 7b92c12a09..bad9fb2fd2 100644 --- a/src/std/misc/with-id-test.ss +++ b/src/std/misc/with-id-test.ss @@ -15,7 +15,7 @@ (test-case "with-id, defining variables" (def mem (make-vector 5 0)) (defrule (defvar name n) - (with-id defvar ((@ #'name "@") (get #'name) (set #'name "-set!")) + (with-id name ((@ #'name "@") (get #'name) (set #'name "-set!")) (begin (def @ n) (def (get) (vector-ref mem @)) (def (set x) (vector-set! mem @ x))))) (defvar A 0) (defvar B 1) diff --git a/src/std/net/httpd/handler.ss b/src/std/net/httpd/handler.ss index 37067e9eec..04dc247128 100644 --- a/src/std/net/httpd/handler.ss +++ b/src/std/net/httpd/handler.ss @@ -606,7 +606,7 @@ END-C (defstruct http-condition (code message)) (defrule (def-http-condition ctx code message) (with-id ctx ((condition - (string-substitute-char #\- #\space (stringify #'message)))) + (string-substitute-char (stringify #'message) #\- #\space))) (def condition (make-http-condition code message)) (export condition) (hash-put! +http-response-codes+ code message))) diff --git a/src/std/net/json-rpc-test.ss b/src/std/net/json-rpc-test.ss index 3832909d11..6771172963 100644 --- a/src/std/net/json-rpc-test.ss +++ b/src/std/net/json-rpc-test.ss @@ -28,7 +28,6 @@ (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)))) diff --git a/src/std/net/json-rpc.ss b/src/std/net/json-rpc.ss index 44b4b17a83..8f50b42501 100644 --- a/src/std/net/json-rpc.ss +++ b/src/std/net/json-rpc.ss @@ -19,6 +19,7 @@ (import (only-in :std/error Exception ) + (only-in :std/misc/atom atomic-counter) (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) @@ -36,7 +37,7 @@ ;; data) ;; (Maybe Bytes) transparent: #t constructor: :init!) (defmethod {:init! json-rpc-error} - (lambda (self what: (what (void)) where: (where (void)) + (lambda (self what: (what "JSON RPC error") where: (where 'json-rpc) code: code ;; SInt16 message: message ;; String data: (data (void))) ;; (Maybe Bytes) @@ -82,10 +83,7 @@ (class-instance-init! self jsonrpc: jsonrpc result: result error: error id: id))) ;; Global counter to correlate responses and answers in logs. -(def id-counter - (let (counter 0) - (lambda ((increment 1)) - (begin0 counter (set! counter (+ counter increment)))))) +(def id-counter (atomic-counter)) ;; These functions construct error results to be returned by the json-rpc server to the client. ;; Beware: DO NOT LEAK internal information in such externally returned error messages. @@ -129,7 +127,7 @@ http-method: (http-method 'POST)) (def id (id-counter)) (when log - (log [jsonrpc: server-url method: method params: params id: id])) + (log [json-rpc: server-url method: method params: params id: id])) (def response-bytes (request-response-bytes (case http-method @@ -192,78 +190,81 @@ response-json)) (def (decode-json-rpc-response decoder request-id response-json) - (def (mal e) + (def (mal! e) (raise (malformed-response request-id: request-id response: response-json e: (error-message e)))) - (def response (with-catch mal (cut trivial-json-object->class json-rpc-response::t response-json))) + (def response (with-catch mal! (cut trivial-json-object->class json-rpc-response::t response-json))) (def jsonrpc (@ response jsonrpc)) (def result (@ response result)) (def error (@ response error)) (def id (@ response id)) (unless (or (void? jsonrpc) ;; a 1.0 server might fail to include this field (equal? jsonrpc json-rpc-version)) ;; but a recent server must reply with same version - (mal "bad json_rpc_version")) + (mal! "bad json_rpc_version")) (unless (or (void? result) (void? error)) - (mal "result error conflict")) + (mal! "result error conflict")) (unless (equal? id request-id) - (mal "bad id")) + (mal! "bad id")) (if (void? error) - (with-catch mal (cut decoder result)) - (raise (with-catch mal (cut json->json-rpc-error error))))) + (with-catch mal! (cut decoder result)) + (raise (with-catch mal! (cut json->json-rpc-error error))))) ;;; Server code ;; http handler for json-rpc ;; 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) +(def (json-rpc-handler processor log: (log #f)) (lambda (req res) - (let/cc return - ;; NB: the JSON RPC over HTTP says that the client MUST specify - ;; application/json-rpc (preferrably) or else application/json or application/jsonrequest - ;; in a Content-Type header, and MUST specify and Accept header with one (or many) of them - ;; and that a Content-Length header MUST be present... but frankly, no one bothers, - ;; and enforcing any of it would make the server needlessly incompatible with clients, - ;; so we don't bother either. - (case (http-request-method req) - ((POST) (json-rpc-handler/POST req res processor)) ;; preferred method - ((GET) (json-rpc-handler/GET req res processor)) ;; mostly for testing - (else (http-response-write-condition res Bad-Request)))))) + ;; NB: the JSON RPC over HTTP says that the client MUST specify + ;; application/json-rpc (preferrably) or else application/json or application/jsonrequest + ;; in a Content-Type header, and MUST specify and Accept header with one (or many) of them + ;; and that a Content-Length header MUST be present... but frankly, no one bothers, + ;; and enforcing any of it would make the server needlessly incompatible with clients, + ;; so we don't bother either. + (def http-method (http-request-method req)) + (case http-method + ((POST) (json-rpc-handler/POST req res processor log)) ;; preferred method + ((GET) (json-rpc-handler/GET req res processor log)) ;; mostly for testing + (else + (when log (log [json-rpc-handler: 'BAD-HTTP-METHOD http-method])) + (http-response-write-condition res Bad-Request))))) -(def (json-rpc-handler/POST req res processor) +(def (json-rpc-handler/POST req res processor log) (let/cc return (def request-json (try (bytes->json (http-request-body req)) (catch (_) - (json-rpc-handler/response-json - res (hash ("jsonrpc" "2.0") ("error" (parser-error)))) + (json-rpc-handler/response + res log 'BAD-POST + (hash ("jsonrpc" json-rpc-version) ("error" (parser-error)))) (return)))) - (json-rpc-handler/JSON res processor request-json))) + (json-rpc-handler/JSON res processor log request-json))) -(def (json-rpc-handler/GET req res processor) +(def (json-rpc-handler/GET req res processor log) (let/cc return (def request-json (try (def url-params (form-url-decode (http-request-params req))) (def method (assget "method" url-params (void))) + (unless method (raise 'parser-error)) (def params (bytes->json (base64-string->u8vector - (uri-decode - (assget "params" url-params))))) + (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)) + (alet (jsonrpc (assget "jsonrpc" url-params)) + (hash-put! json "jsonrpc" jsonrpc)) + (alet (id (assget "id" url-params)) + (hash-put! json "id" id)) json (catch (_) - (json-rpc-handler/response-json - res (hash ("jsonrpc" "2.0") ("error" (parser-error)))) + (json-rpc-handler/response + res log 'BAD-GET (hash ("jsonrpc" json-rpc-version) ("error" (parser-error)))) (return)))) - (json-rpc-handler/JSON res processor request-json))) + (json-rpc-handler/JSON res processor log request-json))) -(def (json-rpc-handler/JSON res processor request-json) - (json-rpc-handler/response-json res (serve-json-rpc processor request-json))) +(def (json-rpc-handler/JSON res processor log request-json) + (json-rpc-handler/response res log request-json (serve-json-rpc processor request-json))) ;; The processor either returns a JSON object, or raise a json-rpc-error ;; Any other error raised will cause an internal error. @@ -276,7 +277,7 @@ (def (invalid-req) (return-error (invalid-request))) (for-each (lambda (k) (unless (member k '("jsonrpc" "method" "params" "id")) (invalid-req))) (hash-keys request-json)) - (unless (member jsonrpc '(#!void "1.0" "2.0")) (set! jsonrpc "2.0") (invalid-req)) + (unless (member jsonrpc '(#!void "1.0" "2.0")) (set! jsonrpc json-rpc-version) (invalid-req)) (def method (hash-ref request-json "method" (void))) (unless (string? method) (invalid-req)) (def params (hash-ref request-json "params" (void))) @@ -290,12 +291,14 @@ (if notification? (void) (hash ("jsonrpc" jsonrpc) ("id" id) ("result" result))) (catch (e) (return-error (if (json-rpc-error? e) e (internal-error))))))) -(def (json-rpc-handler/response-json res response-json) +(def (json-rpc-handler/response res log request-json response-json) (let/cc return - (def response-text - (try - (json-object->string response-json) - (catch (_) - (http-response-write-condition res Internal-Server-Error) - (return)))) + (def response-text + (try + (json-object->string response-json) + (catch (_) + (when log (log [json-rpc-handler: request-json 'BAD-JSON-RESPONSE])) + (http-response-write-condition res Internal-Server-Error) + (return)))) + (when log (log [json-rpc-handler: request-json response-json])) (http-response-write res 200 `(("Content-Type" . "text/json-rpc")) response-text))) diff --git a/src/std/net/uri.ss b/src/std/net/uri.ss index a73bedf953..09b8c14499 100644 --- a/src/std/net/uri.ss +++ b/src/std/net/uri.ss @@ -80,17 +80,17 @@ (lambda (o) (display path o) (let loop ((options options) - (separator "?")) + (separator #\?)) (match options - ('() (void)) + ([] (void)) ([key value . more] (if value (begin (display separator o) (display key o) - (display "=" o) + (display #\= o) (display value o) - (loop more "&")) + (loop more #\&)) (loop more separator)))))))) (def (write-uri-encoded str encoding) diff --git a/src/std/values.ss b/src/std/values.ss index 1e0214f2a6..8c5b58efc5 100644 --- a/src/std/values.ss +++ b/src/std/values.ss @@ -2,7 +2,7 @@ (import ./sugar) -(export first-value nth-value +(export first-value second-value nth-value values->vector vector->values list->values ;; NB: values->list is builtin values->cons cons->values) @@ -11,6 +11,12 @@ ((_ form) (with ((values x . _) form) x)) ((_ form forms ...) (error "syntax error")) (_ (lambda (x . _) x))) + +(defrules second-value () + ((_ form) (with ((values _ x . _) form) x)) + ((_ form forms ...) (error "syntax error")) + (_ (lambda (_ x . _) x))) + (defrule (nth-value n form) (with ((values . x) form) (list-ref x n))) (defrule (values->vector form) (list->vector (values->list form)))