Address new round of json-rpc reviews

src/std/build-spec.ss

@@ -308,6 +308,7 @@
     "crypto/kdf"
     "crypto"
     ;; :std/misc
+    "misc/atom"
     "misc/with-id"
     "misc/concurrent-plan"
     "misc/timeout"

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)))

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"))
     ))

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?)))

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)

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)))

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))))

src/std/net/json-rpc.ss

@@ -19,6 +19,7 @@
 
 (import
   (only-in :std/error Exception <error>)
+  (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)))

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)