Port net/json-rpc from clan to std (#826)

Adds support for JSON-RPC to the stdlib, both client and server side.

Fixes #815 
- [x] Code
- [x] Tests
- [ ] Docs

---------

Co-authored-by: vyzo <[email protected]>

.github/workflows/ci.yml

@@ -9,7 +9,7 @@ jobs:
         gambit-version: ['v4.9.5', 'master']
         shared-mode: ['', '--enable-shared']
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v3
       - name: Install dependencies
         run: sudo apt-get -y install openssl libssl-dev sqlite3 libsqlite3-dev
       - name: Configure Gerbil

.gitignore

@@ -4,6 +4,7 @@ gambit-source
 attic
 bin
 lib
+/build
 *.o
 *.o?
 *.so

src/std/build-spec.ss

@@ -12,6 +12,7 @@
     "pregexp"
     "sort"
     "sugar"
+    "values"
     "assert"
     "make"
     "build-script"
@@ -177,6 +178,7 @@
     "text/json/env"
     "text/json/input"
     "text/json/output"
+    "text/json/util"
     "text/json/api"
     "text/json"
     ,@(if config-enable-libyaml
@@ -205,6 +207,7 @@
     "net/ssl"
     "net/uri"
     "net/request"
+    "net/json-rpc"
     ;; TODO to be ported
     ;;"net/websocket"
     ;; TODO to be removed
@@ -305,6 +308,8 @@
     "crypto/kdf"
     "crypto"
     ;; :std/misc
+    "misc/atom"
+    "misc/with-id"
     "misc/concurrent-plan"
     "misc/timeout"
     "misc/list-builder"

src/std/error.ss

@@ -37,3 +37,5 @@
 
 (def (raise-timeout where what . irritants)
   (raise (make-timeout-error what irritants where)))
+
+(defclass Exception ()) ;; for exceptions as classes rather than structs

src/std/misc/atom.ss

@@ -0,0 +1,118 @@
+;;; -*- Gerbil -*-
+;;; © fare, vyzo
+;;; 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)
+
+(export atom
+        (rename: Atom-value atom-deref)
+        (rename: swap! atom-swap!)
+        (rename: swap-values! atom-swap-values!)
+        (rename: reset! atom-reset!)
+        (rename: reset-values! atom-reset-values!)
+        (rename: compare-and-set! atom-compare-and-set!)
+        (rename: Atom-validator atom-validator)
+        (rename: Atom-validator-set! atom-validator-set!)
+        (rename: add-watch! atom-add-watch!)
+        (rename: remove-watch! atom-remove-watch!)
+        atom-increment! atomic-counter)
+
+(defstruct Atom
+  (mutex value validator watchers)
+  final: #t unchecked: #t)
+
+(def (atom (initial-value (void)) validator: (validator #f))
+  (Atom (make-mutex 'atom) initial-value validator (hash)))
+
+(defalias &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 (values? #t))
+  (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)
+    (if values?
+      (values old-val new-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)
+   (with-atom-lock a (update-atom! a (f (&deref a)))))
+  ((a f val)
+   (with-atom-lock a (update-atom! a (f (&deref a) val))))
+  ((a f val . rest)
+   (with-atom-lock a (update-atom! a (apply f (&deref a) val rest)))))
+
+(def* swap-value!
+  ((a f)
+   (with-atom-lock a (update-atom! a (f (&deref a)) #f)))
+  ((a f val)
+   (with-atom-lock a (update-atom! a (f (&deref a) val) #f)))
+  ((a f val . rest)
+   (with-atom-lock a (update-atom! a (apply f (&deref a) val rest) #f))))
+
+;; same as Clojure swap!
+(def* swap!
+  ((a f)
+   (swap-value! a f))
+  ((a f val)
+   (swap-value! a f val))
+  ((a f val . rest)
+   (apply swap-value! a f rest)))
+
+;; 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)
+  (with-atom-lock a (update-atom! a new-val #f)))
+
+;; 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)
+         (update-atom! a new-val #f)
+         #t)))
+
+;; 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))
+  (let (a (atom initial-value))
+    (lambda ()
+      (let (mx (&Atom-mutex a))
+        (mutex-lock! mx)
+        (let (new (1+ (&Atom-value a)))
+          (set! (&Atom-value a)
+            new)
+          (mutex-unlock! mx)
+          new)))))

src/std/misc/list-test.ss

@@ -156,6 +156,9 @@
       (check-equal? (group [1]) [[1]])
       (check-equal? (group [1 []]) [[1] [[]]])
       (check-equal? (group ["aa" "aa" "b"]) [["aa" "aa"] ["b"]]))
+    (test-case "grouping"
+      (check-equal? (grouping '("abc" "b" "c" "ef" "gh" "ijk") string-length)
+                    '(("abc" "ijk") ("b" "c") ("ef" "gh"))))
     (test-case "test every-consecutive?"
       (check-equal? (every-consecutive? < [1 2 3 4 5]) #t)
       (check-equal? (every-consecutive? < [1 2 5 4 3]) #f)

src/std/misc/list.ss

@@ -18,7 +18,8 @@
   butlast
   split
   take-until take-until! drop-until
-  group
+  group group-by grouping
+  map/car
   every-consecutive?
   separate-keyword-arguments
   first-and-only
@@ -34,7 +35,8 @@
         (only-in ../srfi/1
                  drop drop-right drop-right! take take-right take! reverse!
                  take-while take-while! drop-while
-                 delete-duplicates delete-duplicates!)
+                 delete-duplicates delete-duplicates!
+                 split-at)
         ../sugar
         ../assert)
 
@@ -284,7 +286,7 @@
 ;;  (drop-until number? ['a [] "hi" 1 'c]) => (1 c)
 (def (drop-until pred list) (drop-while (? (not pred)) list))
 
-;; group consecutive elements of the list lst into a list-of-lists.
+;; group consecutive equal elements of the list lst into a list-of-lists.
 ;;
 ;; Example:
 ;;  (group [1 2 2 3 1 1]) => ((1) (2 2) (3) (1 1))
@@ -302,6 +304,36 @@
     ([a] [[a]])
     (_ (helper))))
 
+;; group consecutive clusters of n elements of the list into a list-of-lists
+;; The last element of the list returned may have fewer than n elements.
+;; : Nat (List X) -> (List (List X))
+(def (group-by n list)
+  (cond
+   ((null? list) [])
+   ((length<=n? list n) [list])
+   (else (let-values (((head tail) (split-at list n))) (cons head (group-by n tail))))))
+
+;; Given a list l of X, a key function f from X to Y, and a presumably empty table of Y to a list of X
+;; (by default an empty hash-table), add the elements in l to t, then return the list for each added
+;; key y in t of the list of elements xs with that same key y (for the equality predicate of t).
+;; Otherwise preserve the order of appearance of keys and elements for each key.
+;; : (List X) (Fun X -> Y) ?(Table Y -> (List X)) -> (List (List X))
+(def (grouping l f (t (make-hash-table)))
+  (def ys (with-list-builder (c)
+            (for-each! l
+              (lambda (x)
+                (def y (f x))
+                (def p (hash-get t y))
+                (if p
+                  (hash-put! t y (cons x p))
+                  (begin
+                    (hash-put! t y (list x))
+                    (c y)))))))
+  (map (lambda (y) (reverse (hash-get t y))) ys))
+
+;; : (A -> C) (Cons A B) -> (Cons C B)
+(def (map/car f x) (match x ([a . b] [(f a) . b])))
+
 ;; Returns a boolean that is true if any two consecutive terms in the list satisfy the predicate.
 ;; In particular, if the predicate is a partial order predicate (respectively a strict partial
 ;; order predicate), then the list is totally ordered (respectively strictly totally ordered)

src/std/misc/process.ss

@@ -5,11 +5,14 @@
 (export
   invoke
   run-process
-  run-process/batch)
+  run-process/batch
+  filter-with-process)
 
 (import
   :gerbil/gambit/ports
-  :std/misc/ports :std/sugar)
+  :gerbil/gambit/threads
+  :std/misc/ports
+  :std/sugar)
 
 ;; Error
 (def (check-process-success exit-status settings)
@@ -82,16 +85,38 @@
 (def (invoke program args
              stdout-redirection: (stdout-r #f)
              stderr-redirection: (stderr-r #f)
-             stdin-redirection:  (stdin-r #f))
-  (let* ((process (open-process [path: program arguments: args
-                                 stdout-redirection: stdout-r
-                                 stderr-redirection: stderr-r
-                                 stdin-redirection: stdin-r]))
-         (status (process-status process)))
-    (try
-     (unless (zero? status)
-       (error "Process invocation exited with non-zero status" status (cons program args)))
-     (when stdout-r
-       (read-line process #f))
-     (finally
-      (close-port process)))))
+             stdin-redirection:  (stdin-r #f)
+             coprocess: (coprocess (if stdout-r read-all-as-string void))
+             check-status: (check-status #t)
+             environment: (environment #f)
+             directory: (directory #f)
+             show-console: (show-console #f))
+  (run-process (cons program args)
+               stdout-redirection: stdout-r
+               stderr-redirection: stderr-r
+               stdin-redirection: stdin-r
+               check-status: check-status
+               environment: environment
+               directory: directory
+               show-console: show-console))
+
+;; write data into a filter process and read some data back.
+;; process-options as per open-process, except you should only use
+;; path: arguments: directory: environment:
+(def (filter-with-process command writer reader)
+  (run-process
+   command
+   coprocess:
+   (lambda (process)
+     (spawn/name
+      ['writing-to command]
+      (lambda ()
+        (try
+         (writer process)
+         (force-output process)
+         (finally
+          (close-output-port process)))))
+     (try
+      (reader process)
+      (finally
+       (close-port process))))))

src/std/misc/string-test.ss

@@ -84,4 +84,14 @@
       (check (str #(1 2))             => "(vector 1 2)")
       (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 "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"))
     ))