From 8c6623503f110888a465275a33e8744717ea68ae Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 13:06:12 -0400 Subject: [PATCH 1/6] Host hooks for library class shims: __register-class-methods! + __register-instance-check! clj-http-lite drives java.net URL/HttpURLConnection and java.io byte streams through .method interop. The Chez host had __register-class-ctor!/-statics! (what router/reitit needs) but no way to register instance methods on a shim object or to extend instance?. Add both, plus jolt.host/table?: - tagged-table .method dispatch: an htable-arm on record-method-dispatch routes (.m obj a*) through a per-tag method registry keyed off the table's jolt/type; unregistered methods fall through (sorted colls are htables too). - __register-instance-check! installs (fn [class-name val] -> true|false|nil), nil = fall through; chained ahead of the base instance-check. Runtime .ss shims, no re-mint. Unit covers dispatch, args, instance? both ways. --- host/chez/host-static.ss | 55 +++++++++++++++++++++++++++++++++++++++- test/chez/unit.edn | 6 +++++ 2 files changed, 60 insertions(+), 1 deletion(-) diff --git a/host/chez/host-static.ss b/host/chez/host-static.ss index 6ca69dd..1ae92a5 100644 --- a/host/chez/host-static.ss +++ b/host/chez/host-static.ss @@ -657,4 +657,57 @@ (def-var! "clojure.core" "__register-class-ctor!" (lambda (name proc) (register-class-ctor! name proc) jolt-nil)) (def-var! "clojure.core" "__register-class-statics!" - (lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil)) \ No newline at end of file + (lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil)) + +;; ---- tagged-table method dispatch + pluggable instance? -------------------- +;; A jolt library can build stateful host objects with (jolt.host/tagged-table +;; tag) and dispatch (.method obj ...) to handlers registered here, keyed by the +;; table's "jolt/type" tag — the htable analogue of the jhost method registry +;; above. jolt-lang/http-client uses this to emulate java.net URL / +;; HttpURLConnection / java.io byte streams so clj-http-lite runs unchanged. +(define tagged-methods-tbl (make-hashtable string-hash string=?)) ; tag-key -> (method-ht) +(define (tag->method-key tag) + (if (keyword-t? tag) + (let ((ns (keyword-t-ns tag))) + (if (and ns (not (jolt-nil? ns))) (string-append ns "/" (keyword-t-name tag)) (keyword-t-name tag))) + (jolt-str-render-one tag))) +(define (register-tagged-methods! tag members) + (let* ((key (tag->method-key tag)) + (h (or (hashtable-ref tagged-methods-tbl key #f) + (let ((nh (make-hashtable string-hash string=?))) + (hashtable-set! tagged-methods-tbl key nh) nh)))) + (for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members))) + +;; htable arm: dispatch (.method obj a*) through the table's tag method registry; +;; an unregistered method falls through (sorted colls are htables too). +(define %hs-rmd-htable record-method-dispatch) +(set! record-method-dispatch + (lambda (obj method-name rest-args) + (let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f)))) + (let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f))) + (f (and mh (hashtable-ref mh method-name #f)))) + (if f + (apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args))) + (%hs-rmd-htable obj method-name rest-args)))))) + +(def-var! "clojure.core" "__register-class-methods!" + (lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil)) + +;; Pluggable instance? — a library registers (fn [class-name-string val] -> true +;; | false | nil); nil means "not my class, fall through". First non-nil wins. +(define user-instance-checks '()) +(define %hs-instance-check instance-check) +(set! instance-check + (lambda (type-sym val) + (let ((tname (symbol-t-name type-sym))) + (let loop ((fs user-instance-checks)) + (if (null? fs) + (%hs-instance-check type-sym val) + (let ((r ((car fs) tname val))) + (if (jolt-nil? r) (loop (cdr fs)) (if (jolt-truthy? r) #t #f)))))))) +(def-var! "clojure.core" "instance-check" instance-check) +(def-var! "clojure.core" "__register-instance-check!" + (lambda (f) (set! user-instance-checks (append user-instance-checks (list f))) jolt-nil)) + +;; (jolt.host/table? x) — is x a host tagged-table (the Janet-table replacement)? +(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f))) \ No newline at end of file diff --git a/test/chez/unit.edn b/test/chez/unit.edn index b94695f..53d2f2f 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -459,4 +459,10 @@ {:suite "deftype-mutable" :expr "(do (defprotocol IB (gv [_]) (sv [_ v])) (deftype B [^:unsynchronized-mutable val] IB (gv [_] val) (sv [_ v] (set! val v))) (let [b (->B 1)] (sv b 42) (gv b)))" :expected "42"} {:suite "deftype-mutable" :expr "(do (defprotocol IC (bump [_]) (cur [_])) (deftype C [^:unsynchronized-mutable n] IC (bump [this] (set! n (inc n)) n) (cur [_] n)) (let [c (->C 5)] (bump c) (bump c) (bump c) (cur c)))" :expected "8"} {:suite "deftype-mutable" :expr "(do (defprotocol IH (g [_]) (s [_ v])) (deftype H [^:volatile-mutable st] IH (g [_] st) (s [this v] (set! (.-st this) v))) (let [h (->H :old)] (s h :new) (g h)))" :expected ":new"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box1\" (fn [v] (let [t (jolt.host/tagged-table :my/box)] (jolt.host/ref-put! t :v v) t))) (__register-class-methods! :my/box {\"getV\" (fn [self] (jolt.host/ref-get self :v))}) (.getV (Box1. 42)))" :expected "42"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box2\" (fn [v] (let [t (jolt.host/tagged-table :my/box2)] (jolt.host/ref-put! t :v v) t))) (__register-class-methods! :my/box2 {\"add\" (fn [self n] (+ n (jolt.host/ref-get self :v)))}) (.add (Box2. 10) 5))" :expected "15"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box3\" (fn [] (jolt.host/tagged-table :my/box3))) (__register-instance-check! (fn [cn val] (if (= cn \"Box3\") (= :my/box3 (jolt.host/ref-get val :jolt/type)) nil))) (instance? Box3 (Box3.)))" :expected "true"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box4\" (fn [] (jolt.host/tagged-table :my/box4))) (__register-instance-check! (fn [cn val] (if (= cn \"Box4\") (= :my/box4 (jolt.host/ref-get val :jolt/type)) nil))) (instance? Box4 \"not-a-box\"))" :expected "false"} + {:suite "hostshim" :expr "(jolt.host/table? (jolt.host/tagged-table :t))" :expected "true"} + {:suite "hostshim" :expr "(jolt.host/table? \"x\")" :expected "false"} ] From c5e1e0544a32916cf5bb54a00c58b4027b992299 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 13:11:08 -0400 Subject: [PATCH 2/6] jolt.ffi: read-array/write-array for binary-faithful buffer I/O MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit read-bytes/write-bytes go through UTF-8 (with a latin1 fallback), which mangles arbitrary binary — gzip payloads, TLS records, any non-text body. An HTTP client moving bytes between jolt byte-arrays and foreign socket/zlib/OpenSSL buffers needs byte-exact transfer. read-array returns a fresh byte-array of n bytes from foreign memory; write-array copies a byte-array's bytes into a pointer. Test covers a round-trip preserving high bytes (200, 255). --- host/chez/ffi.ss | 17 +++++++++++++++++ test/chez/ffi-binding-test.ss | 13 +++++++++++++ 2 files changed, 30 insertions(+) diff --git a/host/chez/ffi.ss b/host/chez/ffi.ss index c3c7ceb..2c1f98c 100644 --- a/host/chez/ffi.ss +++ b/host/chez/ffi.ss @@ -80,6 +80,23 @@ (def-var! "jolt.ffi" "read-bytes" ffi-read-bytes) (def-var! "jolt.ffi" "write-bytes" ffi-write-bytes) +;; --- byte-array buffer I/O (binary-faithful) -------------------------------- +;; Move raw bytes between a jolt byte-array (jolt-array kind 'byte) and foreign +;; memory, byte-exact (no UTF-8 / latin1 decode) — for socket recv/send and the +;; zlib / OpenSSL buffers an HTTP client passes through. read-array returns a +;; fresh byte-array of n bytes; write-array copies a byte-array's bytes into ptr +;; and returns the count. +(define (ffi-read-array ptr n) + (let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (v (make-vector n 0))) + (do ((i 0 (+ i 1))) ((= i n)) (vector-set! v i (foreign-ref 'unsigned-8 p i))) + (make-jolt-array v 'byte))) +(define (ffi-write-array ptr arr) + (let* ((v (jolt-array-vec arr)) (n (vector-length v)) (p (jnum->exact ptr))) + (do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bitwise-and (exact (vector-ref v i)) #xff))) + n)) +(def-var! "jolt.ffi" "read-array" ffi-read-array) +(def-var! "jolt.ffi" "write-array" ffi-write-array) + ;; --- string / bytevector marshaling ------------------------------------------ ;; A C string result already comes back as a jolt string (the `string` foreign ;; type). For a `void*` that points at a NUL-terminated C string, read it here. diff --git a/test/chez/ffi-binding-test.ss b/test/chez/ffi-binding-test.ss index ec4cb9d..db8f290 100644 --- a/test/chez/ffi-binding-test.ss +++ b/test/chez/ffi-binding-test.ss @@ -39,6 +39,19 @@ (let [v (jolt.ffi/read p :int)] (jolt.ffi/free p) v))")))) (ok "sizeof :pointer is a word" (let ((n (jnum->exact (ev "(jolt.ffi/sizeof :pointer)")))) (or (= n 8) (= n 4)))) +;; byte-array buffer I/O: write a byte-array into foreign memory and read it back +;; byte-exact (high bytes preserved, no UTF-8 mangling). +(ok "byte-array roundtrip (binary-faithful)" + (jolt-truthy? + (ev "(let [src (byte-array [0 65 200 255 10]) + p (jolt.ffi/alloc 5)] + (jolt.ffi/write-array p src) + (let [back (jolt.ffi/read-array p 5)] + (jolt.ffi/free p) + (and (= 5 (alength back)) + (= 0 (aget back 0)) (= 65 (aget back 1)) + (= 200 (aget back 2)) (= 255 (aget back 3)) (= 10 (aget back 4)))))"))) + ;; a :blocking foreign call is collect-safe: a thread parked in it must not pin ;; the stop-the-world collector. (collect) here would throw "cannot collect when ;; multiple threads are active" if usleep weren't emitted __collect_safe. From 3253df979af34dd00c5bb368b04fd62db020aaad Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 13:20:27 -0400 Subject: [PATCH 3/6] Byte-array <-> bytevector interop + charset-aware (String. bytes cs) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The host carries bytes two ways: Chez bytevectors (what String/.getBytes produce) and jolt byte-arrays (what byte-array / the Java-array shims use). They didn't interconvert, so code mixing the two — like clj-http-lite, which buffers into (byte-array n) but encodes via .getBytes and decodes via (String. ^[B body charset) — broke. - byte-array now also accepts a bytevector or a string (UTF-8 bytes), so the two representations convert freely at interop seams. - (String. bytes [charset]) decodes a bytevector OR a jolt byte-array with the named charset (UTF-8 default; ISO-8859-1/latin1/ascii = one byte/char). It previously only took a bytevector and ignored the charset. Runtime .ss shims, no re-mint. Unit covers both directions + charset. --- host/chez/host-static.ss | 26 ++++++++++++++++++++++++-- host/chez/natives-array.ss | 16 +++++++++++++--- test/chez/unit.edn | 7 +++++++ 3 files changed, 44 insertions(+), 5 deletions(-) diff --git a/host/chez/host-static.ss b/host/chez/host-static.ss index 1ae92a5..1c574d3 100644 --- a/host/chez/host-static.ss +++ b/host/chez/host-static.ss @@ -514,9 +514,31 @@ (error #f "NoSuchElementException"))))))) ;; ---- String / BigInteger / MapEntry constructors ---------------------------- -;; (String. x) / (String. bytes): a bytevector decodes UTF-8; else stringify. +;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array) +;; with the named charset (UTF-8 default; ISO-8859-1/latin1/ascii = one byte per +;; char); else stringify. clj-http-lite's body coercion is (String. ^[B body cs). +(define (string-charset-name rest) + (if (pair? rest) + (let ((c (car rest))) + (cond ((string? c) c) + ((and (jhost? c) (string=? (jhost-tag c) "charset")) + (let ((p (assq 'name (jhost-state c)))) (if p (jolt-str-render-one (cdr p)) "UTF-8"))) + (else "UTF-8"))) + "UTF-8")) +(define (decode-bytevector bv rest) + (let ((cs (ascii-string-down (string-charset-name rest)))) + (cond + ((or (string=? cs "utf-8") (string=? cs "utf8")) (utf8->string bv)) + ((or (string=? cs "iso-8859-1") (string=? cs "latin1") (string=? cs "iso8859-1") + (string=? cs "us-ascii") (string=? cs "ascii")) + (list->string (map integer->char (bytevector->u8-list bv)))) + (else (guard (e (#t (list->string (map integer->char (bytevector->u8-list bv))))) (utf8->string bv)))))) (register-class-ctor! "String" - (lambda (x . _) (cond ((bytevector? x) (utf8->string x)) ((string? x) x) (else (jolt-str-render-one x))))) + (lambda (x . rest) + (cond ((bytevector? x) (decode-bytevector x rest)) + ((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (decode-bytevector (na-bytearray->bv x) rest)) + ((string? x) x) + (else (jolt-str-render-one x))))) (register-class-ctor! "BigInteger" (lambda (v) (parse-int-or-throw v 10 "BigInteger"))) (register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v))) diff --git a/host/chez/natives-array.ss b/host/chez/natives-array.ss index 5f53cee..895fd85 100644 --- a/host/chez/natives-array.ss +++ b/host/chez/natives-array.ss @@ -46,10 +46,20 @@ (else (make-jolt-array (list->vector (map (lambda (c) (if (char? c) c (integer->char (exact (truncate c))))) (seq->list (jolt-seq a)))) 'char)))) +;; (byte-array n [init]) | (byte-array coll). Also coerces the host's OTHER byte +;; carrier — a Chez bytevector (what String/.getBytes produce) — and a string's +;; UTF-8 bytes, so bytevector and byte-array interconvert across interop seams. (define (na-byte-array a . rest) - (if (number? a) - (make-jolt-array (make-vector (exact (na-idx a)) (na-byte-of (if (pair? rest) (car rest) 0))) 'byte) - (make-jolt-array (list->vector (map na-byte-of (seq->list (jolt-seq a)))) 'byte))) + (cond + ((number? a) (make-jolt-array (make-vector (exact (na-idx a)) (na-byte-of (if (pair? rest) (car rest) 0))) 'byte)) + ((bytevector? a) (make-jolt-array (list->vector (bytevector->u8-list a)) 'byte)) + ((string? a) (make-jolt-array (list->vector (bytevector->u8-list (string->utf8 a))) 'byte)) + (else (make-jolt-array (list->vector (map na-byte-of (seq->list (jolt-seq a)))) 'byte)))) +;; jolt byte-array -> Chez bytevector (for String decode / utf8->string). +(define (na-bytearray->bv arr) + (let* ((v (jolt-array-vec arr)) (n (vector-length v)) (bv (make-bytevector n))) + (do ((i 0 (+ i 1))) ((= i n)) (bytevector-u8-set! bv i (bitwise-and (exact (vector-ref v i)) #xff))) + bv)) (define (na-make-array a . rest) ; (make-array len) | (make-array type len ...) (make-jolt-array (make-vector (exact (na-idx (if (number? a) a (car rest)))) jolt-nil) 'object)) (define (na-into-array a . rest) (na-from-seq (if (pair? rest) (car rest) a) 'object)) diff --git a/test/chez/unit.edn b/test/chez/unit.edn index 53d2f2f..4593704 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -465,4 +465,11 @@ {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box4\" (fn [] (jolt.host/tagged-table :my/box4))) (__register-instance-check! (fn [cn val] (if (= cn \"Box4\") (= :my/box4 (jolt.host/ref-get val :jolt/type)) nil))) (instance? Box4 \"not-a-box\"))" :expected "false"} {:suite "hostshim" :expr "(jolt.host/table? (jolt.host/tagged-table :t))" :expected "true"} {:suite "hostshim" :expr "(jolt.host/table? \"x\")" :expected "false"} + {:suite "bytes" :expr "(seq (byte-array \"hi\"))" :expected "(104 105)"} + {:suite "bytes" :expr "(seq (byte-array (.getBytes \"AB\" \"UTF-8\")))" :expected "(65 66)"} + {:suite "bytes" :expr "(alength (byte-array (.getBytes \"hello\" \"UTF-8\")))" :expected "5"} + {:suite "bytes" :expr "(String. (byte-array [104 105]))" :expected "hi"} + {:suite "bytes" :expr "(String. (byte-array [104 105]) \"UTF-8\")" :expected "hi"} + {:suite "bytes" :expr "(int (first (String. (byte-array [200]) \"ISO-8859-1\")))" :expected "200"} + {:suite "bytes" :expr "(String. (.getBytes \"round\" \"UTF-8\") \"UTF-8\")" :expected "round"} ] From 5bcfc629fc926564238bf234d22db5e415ff98cc Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 13:34:19 -0400 Subject: [PATCH 4/6] clojure.java.io/copy + registry-aware io/as-url MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit clj-http-lite drives bytes through clojure.java.io/copy (response body into a ByteArrayOutputStream, request body out) and resolves URLs via io/as-url. Neither worked for a library shim: - io/copy was absent. Add it: raw bytes / string / a jhost reader write in one shot; any other source drains via .read into a buffer and .write to the dest, both through method dispatch — so a library's tagged-table streams copy without the host knowing their layout. - io/as-url ignored a library-registered URL class, so it and (URL. spec) disagreed (the file-only jhost has no getProtocol/getHost/...). It now honors a registered URL ctor, falling back to the jhost. Runtime .ss shims, no re-mint. --- host/chez/io.ss | 9 ++++++++- host/chez/natives-array.ss | 26 ++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/host/chez/io.ss b/host/chez/io.ss index 20c081c..766bb28 100644 --- a/host/chez/io.ss +++ b/host/chez/io.ss @@ -284,4 +284,11 @@ ((file-exists? (string-append (car roots) "/" nm)) (make-jfile (string-append (car roots) "/" nm))) (else (loop (cdr roots))))))) (def-var! "clojure.java.io" "resource" jolt-io-resource) -(def-var! "clojure.java.io" "as-url" (lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "url")) x (make-url (jolt-str-render-one x))))) +;; as-url honors a library-registered URL class (e.g. jolt-lang/http-client's full +;; java.net.URL shim) so io/as-url and (URL. spec) agree; else the file-only jhost. +(def-var! "clojure.java.io" "as-url" + (lambda (x) + (cond ((and (jhost? x) (string=? (jhost-tag x) "url")) x) + ((htable? x) x) + (else (let ((ctor (lookup-class class-ctors-tbl "URL"))) + (if ctor (ctor (jolt-str-render-one x)) (make-url (jolt-str-render-one x)))))))) diff --git a/host/chez/natives-array.ss b/host/chez/natives-array.ss index 895fd85..ba7f6ac 100644 --- a/host/chez/natives-array.ss +++ b/host/chez/natives-array.ss @@ -205,3 +205,29 @@ (cons "chunk" na-chunk) (cons "chunk-cons" na-chunk-cons) (cons "chunk-first" na-chunk-first) (cons "chunk-rest" na-chunk-rest) (cons "chunk-next" na-chunk-next) (cons "chunked-seq?" na-chunked-seq?))) + +;; --- clojure.java.io/copy --------------------------------------------------- +;; Copy src -> dst, JVM-style. Raw bytes (byte-array / bytevector / string) and a +;; jhost reader write in one shot; any other source (a stream shim with a .read +;; method, e.g. jolt-lang/http-client's ByteArrayInputStream) drains via .read +;; into a byte-array buffer and .write to dst — both reached through method +;; dispatch, so a library's tagged-table streams work without the host knowing +;; their layout. Lives here (not io.ss) because io.ss loads before byte-array. +(define (jolt-io-copy src dst . _opts) + (define (write-all! bytes) + (record-method-dispatch dst "write" (list->cseq (list bytes 0 (vector-length (jolt-array-vec bytes)))))) + (cond + ((or (bytevector? src) (string? src) + (and (jolt-array? src) (eq? (jolt-array-kind src) 'byte))) + (write-all! (na-byte-array src))) + ((and (jhost? src) (member (jhost-tag src) '("string-reader" "pushback-reader"))) + (write-all! (na-byte-array (drain-reader src)))) + (else + (let ((buf (na-byte-array 8192))) + (let loop () + (let ((n (record-method-dispatch src "read" (list->cseq (list buf 0 8192))))) + (when (and (number? n) (> (jnum->exact n) 0)) + (record-method-dispatch dst "write" (list->cseq (list buf 0 n))) + (loop))))))) + jolt-nil) +(def-var! "clojure.java.io" "copy" jolt-io-copy) From 13aaf74c4b51439f6c2294d62fdd48c1ac4cb248 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 13:54:04 -0400 Subject: [PATCH 5/6] Host completeness for clj-http-lite: with-open/slurp on shims, charset, exc classes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Gaps the clj-http-lite suite hit running over jolt-lang/http-client: - with-open now closes a tagged-table stream shim via its .close method (was a :close field lookup that only matched the Janet-era tables). - slurp accepts a bytevector / jolt byte-array / a byte input-stream shim and honors :encoding — clj-http-lite slurps response bodies and :as :stream bodies. - (.getBytes s charset) and Charset/forName respect the charset (ISO-8859-1 etc., one byte per char), not always UTF-8; Charset/forName returns the name string. - (class e) reads the JVM :class off a throwable tagged-table, so clojure.test's (thrown? Class …) / (= Class (class e)) match a library's typed exceptions. - Registered the HTTP/IO exception class names (IOException, UnknownHostException, SocketTimeoutException, SSLException, …) so the FQ literals self-evaluate. All runtime .ss shims, no re-mint. Full gate green. --- host/chez/host-class.ss | 16 ++++++++++++++++ host/chez/host-static.ss | 4 +++- host/chez/host-table.ss | 9 +++++++++ host/chez/io.ss | 25 +++++++++++++++++++++++++ host/chez/natives-str.ss | 12 +++++++++++- 5 files changed, 64 insertions(+), 2 deletions(-) diff --git a/host/chez/host-class.ss b/host/chez/host-class.ss index 9d9a333..ba67878 100644 --- a/host/chez/host-class.ss +++ b/host/chez/host-class.ss @@ -49,7 +49,16 @@ ("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64") ("Exception" . "java.lang.Exception") ("IllegalArgumentException" . "java.lang.IllegalArgumentException") + ("IllegalStateException" . "java.lang.IllegalStateException") + ("RuntimeException" . "java.lang.RuntimeException") + ("UnsupportedOperationException" . "java.lang.UnsupportedOperationException") ("InterruptedException" . "java.lang.InterruptedException") + ("IOException" . "java.io.IOException") + ("UnknownHostException" . "java.net.UnknownHostException") + ("ConnectException" . "java.net.ConnectException") + ("SocketTimeoutException" . "java.net.SocketTimeoutException") + ("MalformedURLException" . "java.net.MalformedURLException") + ("SSLException" . "javax.net.ssl.SSLException") ("Throwable" . "java.lang.Throwable"))) (for-each (lambda (pair) (def-var! "clojure.core" (car pair) (cdr pair))) @@ -74,4 +83,11 @@ '("java.lang.Long" "java.lang.Integer" "java.lang.Double" "java.lang.Float" "java.lang.Number" "java.lang.String" "java.lang.Boolean" "java.lang.Character" "java.lang.Object" + ;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e)) + "java.lang.Exception" "java.lang.Throwable" "java.lang.RuntimeException" + "java.lang.IllegalArgumentException" "java.lang.IllegalStateException" + "java.lang.UnsupportedOperationException" "java.io.IOException" + "java.net.UnknownHostException" "java.net.ConnectException" + "java.net.SocketTimeoutException" "java.net.MalformedURLException" + "javax.net.ssl.SSLException" "clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom")) diff --git a/host/chez/host-static.ss b/host/chez/host-static.ss index 1c574d3..5904f4c 100644 --- a/host/chez/host-static.ss +++ b/host/chez/host-static.ss @@ -583,7 +583,9 @@ (let loop ((l lst) (i 0)) (if (null? l) bv (begin (bytevector-u8-set! bv i (car l)) (loop (cdr l) (+ i 1))))))) (register-class-statics! "URLEncoder" (list (cons "encode" url-encode))) (register-class-statics! "URLDecoder" (list (cons "decode" url-decode))) -(register-class-statics! "Charset" (list (cons "forName" (lambda (nm) (make-jhost "charset" (list (cons 'name nm))))))) +;; Charset/forName yields the canonical name STRING (not an opaque object) so it +;; threads straight into (.getBytes s cs) / (String. bytes cs), which take a name. +(register-class-statics! "Charset" (list (cons "forName" (lambda (nm) (jolt-str-render-one nm))))) ;; ---- Base64 (RFC 4648) ------------------------------------------------------ (define b64-alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") diff --git a/host/chez/host-table.ss b/host/chez/host-table.ss index 39fcdbf..b155dba 100644 --- a/host/chez/host-table.ss +++ b/host/chez/host-table.ss @@ -176,3 +176,12 @@ ((htable-sorted-set? obj) '("PersistentTreeSet" "Sorted" "IPersistentSet" "Set" "java.util.Set" "Collection" "IPersistentCollection" "Object")) (else (%h-value-host-tags obj))))) + +;; (class e) on a throwable tagged-table (a library's ex-info envelope carrying a +;; JVM :class, e.g. jolt-lang/http-client's UnknownHostException) reads that +;; class name, so clojure.test's (thrown? Class …) / (= Class (class e)) match. +(define %h-class jolt-class) +(set! jolt-class (lambda (x) + (let ((c (and (htable? x) (hashtable-ref (htable-h x) "class" #f)))) + (if (and c (string? c)) c (%h-class x))))) +(def-var! "clojure.core" "class" jolt-class) diff --git a/host/chez/io.ss b/host/chez/io.ss index 766bb28..fc7bfe3 100644 --- a/host/chez/io.ss +++ b/host/chez/io.ss @@ -151,10 +151,32 @@ ((reader-jhost? rdr) (drain-reader rdr)) (else (jolt-str-render-one rdr)))))) +;; (slurp src :encoding "...") — pull the charset from the trailing kwargs. +(define (slurp-encoding opts) + (let loop ((o opts)) + (cond ((or (null? o) (null? (cdr o))) '()) + ((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "encoding")) + (list (jolt-str-render-one (cadr o)))) + (else (loop (cddr o)))))) +;; drain a byte input-stream shim (tagged-table) one byte at a time to a bytevector. +(define (drain-byte-stream src) + (let loop ((acc '())) + (let ((b (record-method-dispatch src "read" jolt-nil))) + (if (or (jolt-nil? b) (and (number? b) (< b 0))) + (u8-list->bytevector (reverse acc)) + (loop (cons (bitwise-and (jnum->exact b) #xff) acc)))))) (define (jolt-slurp src . opts) (cond ((jfile? src) (read-file-string (jfile-path src))) ((reader-jhost? src) (drain-reader src)) + ;; bytes (a bytevector or a jolt byte-array): decode with :encoding (UTF-8 + ;; default). clj-http-lite slurps response-body byte arrays. + ((bytevector? src) (decode-bytevector src (slurp-encoding opts))) + ((and (jolt-array? src) (eq? (jolt-array-kind src) 'byte)) + (decode-bytevector (na-bytearray->bv src) (slurp-encoding opts))) + ;; a byte input-stream shim (e.g. clj-http-lite's :as :stream body): drain it. + ((and (htable? src) (jolt-truthy? (jolt-ref-get src (keyword "jolt" "input-stream")))) + (decode-bytevector (drain-byte-stream src) (slurp-encoding opts))) ((string? src) (read-file-string src)) (else (error #f "slurp: unsupported source" src)))) @@ -230,6 +252,9 @@ ((jolt-nil? x) jolt-nil) ((and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader" "writer"))) (record-method-dispatch x "close" jolt-nil) jolt-nil) + ;; a library's stream shim (tagged-table) closes via its registered .close + ;; method (a no-op for in-memory streams); absent method -> no-op. + ((htable? x) (guard (e (#t jolt-nil)) (record-method-dispatch x "close" jolt-nil)) jolt-nil) ((jfile? x) jolt-nil) (else (let ((closef (jolt-get x (keyword #f "close") jolt-nil))) diff --git a/host/chez/natives-str.ss b/host/chez/natives-str.ss index ac09f65..20d18ad 100644 --- a/host/chez/natives-str.ss +++ b/host/chez/natives-str.ss @@ -117,7 +117,17 @@ (string=? (ascii-string-down s) (ascii-string-down (arg 0)))) ((string=? method "compareTo") (let ((o (arg 0))) (cond ((string? s o) 1.0) (else 0.0)))) - ((string=? method "getBytes") (string->utf8 s)) + ((string=? method "getBytes") + ;; (.getBytes s) / (.getBytes s charset). UTF-8 default; ISO-8859-1/latin1/ + ;; ascii encode one byte per char (clj-http-lite's body-encoding path). + (if (null? rest) + (string->utf8 s) + (let ((cn (ascii-string-down (if (string? (arg 0)) (arg 0) (jolt-str-render-one (arg 0)))))) + (if (member cn '("iso-8859-1" "latin1" "iso8859-1" "us-ascii" "ascii")) + (let* ((n (string-length s)) (bv (make-bytevector n))) + (do ((i 0 (+ i 1))) ((= i n) bv) + (bytevector-u8-set! bv i (bitwise-and (char->integer (string-ref s i)) #xff)))) + (string->utf8 s))))) ((string=? method "matches") (if (irregex-match (str-irx (arg 0)) s) #t #f)) ((string=? method "replaceAll") (irregex-replace/all (str-irx (arg 0)) s (arg 1))) ((string=? method "replaceFirst") (irregex-replace (str-irx (arg 0)) s (arg 1))) From 9a60922d61ed967d6bcd4e3184f3a1e0461a488e Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 13:55:49 -0400 Subject: [PATCH 6/6] Remove the built-in jolt.http-client (the curl shim) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit jolt-lang/http-client (clj-http-lite over jolt.ffi) replaces it, the same way ring-janet-adapter replaced the built-in HTTP server. An HTTP client is a library concern — jolt core no longer ships one or shells out to curl. Apps depend on the library; (require '[jolt.http-client]) now resolves to its source. Full gate green. --- host/chez/cli.ss | 1 - host/chez/http-client.ss | 160 --------------------------------------- 2 files changed, 161 deletions(-) delete mode 100644 host/chez/http-client.ss diff --git a/host/chez/cli.ss b/host/chez/cli.ss index aa2a35f..ca220b4 100644 --- a/host/chez/cli.ss +++ b/host/chez/cli.ss @@ -20,7 +20,6 @@ (load "host/chez/seed/image.ss") (load "host/chez/compile-eval.ss") (load "host/chez/png.ss") ; jolt.png — a baked namespace before the snapshot -(load "host/chez/http-client.ss") ; jolt.http-client (libcurl) (load "host/chez/loader.ss") ;; jolt.ffi host primitives (memory / library loading) load AFTER the loader's ;; baked-ns snapshot, so a library's (require '[jolt.ffi]) still loads jolt.ffi's diff --git a/host/chez/http-client.ss b/host/chez/http-client.ss deleted file mode 100644 index 7c19bb2..0000000 --- a/host/chez/http-client.ss +++ /dev/null @@ -1,160 +0,0 @@ -;; http-client.ss (jolt-90sp) — jolt.http-client: a synchronous HTTP client. -;; -;; Backed by the system `curl` binary rather than a direct libcurl FFI: on Apple -;; Silicon curl_easy_setopt is variadic and its value arg goes on the stack, where -;; Chez's fixed-signature foreign-procedure can't place it (it would need a -;; compiled C shim per platform). Shelling to curl uses the same mature native -;; library — TLS, redirects, gzip and all — with no build step and identical -;; behavior across platforms. Returns a Ring-ish {:status :headers :body}. -;; -;; def-var!'d into the jolt.http-client namespace; loaded by the CLI before the -;; loader snapshot, so (require '[jolt.http-client]) resolves with no source file. - -;; single-quote an argument for the outer `sh -c` (loader.ss's sh-quote isn't -;; loaded yet at this point). -(define (hc-shq s) - (string-append "'" - (apply string-append - (map (lambda (c) (if (char=? c #\') "'\\''" (string c))) (string->list s))) - "'")) - -(define hc-status-sentinel "\nJOLTHTTPSTATUS:") - -(define kw-method (keyword #f "method")) -(define kw-url (keyword #f "url")) -(define kw-headers (keyword #f "headers")) -(define kw-body (keyword #f "body")) -(define kw-insecure (keyword #f "insecure?")) -(define kw-follow (keyword #f "follow?")) -(define kw-timeout (keyword #f "timeout-ms")) -(define kw-status (keyword #f "status")) -(define kw-query (keyword #f "query-params")) -(define kw-ctype (keyword #f "content-type")) - -;; :content-type :json -> "application/json"; a string passes through. -(define (hc-ctype->str ct) - (cond ((keyword? ct) - (let ((n (keyword-t-name ct))) - (cond ((string=? n "json") "application/json") - ((string=? n "xml") "application/xml") - ((string=? n "form") "application/x-www-form-urlencoded") - (else n)))) - (else (jolt-str-render-one ct)))) - -;; A per-request header file path, unique across processes (PID) and threads (a -;; mutex-guarded monotonic counter). The previous unguarded `set!` + `mod 90000` -;; raced: concurrent callers could compute the same path and clobber each other's -;; -D header dump. getpid is a fast, non-blocking foreign call. -(define c-getpid (begin (load-shared-object #f) (foreign-procedure "getpid" () int))) -(define hc-tmp-mutex (make-mutex)) -(define hc-tmp-counter 0) -(define (hc-tmp-path) - (let ((n (with-mutex hc-tmp-mutex (set! hc-tmp-counter (+ hc-tmp-counter 1)) hc-tmp-counter))) - (string-append (or (getenv "TMPDIR") "/tmp") "/jolt-http-" - (number->string (c-getpid)) "-" (number->string n) ".hdr"))) - -(define (hc-trim s) - (let* ((n (string-length s)) - (a (let lp ((i 0)) (if (and (< i n) (char-whitespace? (string-ref s i))) (lp (+ i 1)) i))) - (b (let lp ((i n)) (if (and (> i a) (char-whitespace? (string-ref s (- i 1)))) (lp (- i 1)) i)))) - (substring s a b))) -(define (hc-lines s) - (let loop ((i 0) (start 0) (acc '())) - (cond ((>= i (string-length s)) (reverse (if (> i start) (cons (substring s start i) acc) acc))) - ((char=? (string-ref s i) #\newline) - (loop (+ i 1) (+ i 1) (if (> i start) (cons (substring s start i) acc) acc))) - (else (loop (+ i 1) start acc))))) -;; raw header dump (curl -D) -> a jolt map {lowercased-name -> value}. With -;; redirects there are several blocks; the LAST status line resets the map so the -;; final response's headers win. -(define (hc-parse-headers text) - (let ((m (jolt-hash-map))) - (for-each - (lambda (raw) - (let ((line (hc-trim raw))) - (cond - ((= 0 (string-length line)) #t) - ((and (>= (string-length line) 5) (string=? (substring line 0 5) "HTTP/")) - (set! m (jolt-hash-map))) ; new response block - (else - (let ((ci (let scan ((i 0)) (cond ((>= i (string-length line)) #f) - ((char=? (string-ref line i) #\:) i) - (else (scan (+ i 1))))))) - (when (and ci (> ci 0)) - (set! m (jolt-assoc m (ascii-string-down (hc-trim (substring line 0 ci))) - (hc-trim (substring line (+ ci 1) (string-length line))))))))))) - (hc-lines text)) - m)) - -(define (hc-split-status out) - ;; out ends with "\nJOLTHTTPSTATUS:"; return (values body code-int). - (let ((idx (let ((sl (string-length hc-status-sentinel)) (ol (string-length out))) - (let scan ((i (- ol sl))) - (cond ((< i 0) #f) - ((string=? (substring out i (+ i sl)) hc-status-sentinel) i) - (else (scan (- i 1)))))))) - (if idx - (values (substring out 0 idx) - (or (string->number (hc-trim (substring out (+ idx (string-length hc-status-sentinel)) - (string-length out)))) 0)) - (values out 0)))) - -(define (hc-request method url opts) - (when (or (not url) (jolt-nil? url)) (error #f "jolt.http-client: missing :url")) - (let* ((headers (jolt-get opts kw-headers)) - (body (let ((x (jolt-get opts kw-body))) (and (not (jolt-nil? x)) x))) - (insecure? (jolt-truthy? (jolt-get opts kw-insecure))) - (follow? (let ((x (jolt-get opts kw-follow))) (or (jolt-nil? x) (jolt-truthy? x)))) - (timeout (let ((x (jolt-get opts kw-timeout))) (if (jolt-nil? x) 30 (quotient (jnum->exact x) 1000)))) - (hdrfile (hc-tmp-path)) - (parts (list "curl -sS" - (if follow? "-L" "") - (if insecure? "-k" "") - "--max-time" (number->string (max 1 timeout)) - "-D" (hc-shq hdrfile) - "-X" (hc-shq (string-upcase method)) - "-w" (hc-shq (string-append hc-status-sentinel "%{http_code}")) - "--compressed")) - (ctype (let ((x (jolt-get opts kw-ctype))) (and (not (jolt-nil? x)) (hc-ctype->str x)))) - (parts (if ctype (append parts (list "-H" (hc-shq (string-append "Content-Type: " ctype)))) parts)) - (parts (if (pmap? headers) - (append parts (pmap-fold headers - (lambda (k v acc) - (cons "-H" (cons (hc-shq (string-append (jolt-str-render-one k) ": " - (jolt-str-render-one v))) acc))) - '())) - parts)) - ;; query-params: let curl URL-encode them onto the URL (-G appends as the - ;; query string for a GET). - (qp (let ((x (jolt-get opts kw-query))) (and (pmap? x) x))) - (parts (if qp - (append parts - (cons "-G" - (pmap-fold qp (lambda (k v acc) - (cons "--data-urlencode" - (cons (hc-shq (string-append (jolt-str-render-one k) "=" - (jolt-str-render-one v))) acc))) - '()))) - parts)) - (parts (if body (append parts (list "--data-binary" (hc-shq (jolt-str-render-one body)))) parts)) - (parts (append parts (list (hc-shq (jolt-str-render-one url))))) - (cmd (let join ((xs parts) (s "")) (if (null? xs) s - (join (cdr xs) (if (string=? (car xs) "") s (string-append s (if (string=? s "") "" " ") (car xs))))))) - (out (jolt-sh-out cmd))) - (let-values (((bdy code) (hc-split-status out))) - (let ((hdr-text (guard (e (#t "")) (read-file-string hdrfile)))) - (guard (e (#t #f)) (delete-file hdrfile)) - (jolt-hash-map kw-status code - kw-headers (hc-parse-headers hdr-text) - kw-body bdy))))) - -;; --- public jolt.http-client API -------------------------------------------- -(define (hc-verb method) (lambda (url . opt) (hc-request method url (if (pair? opt) (car opt) (jolt-hash-map))))) -(def-var! "jolt.http-client" "request" - (lambda (opts) (hc-request (let ((m (jolt-get opts kw-method))) (if (jolt-nil? m) "GET" (jolt-str-render-one m))) - (jolt-get opts kw-url) opts))) -(def-var! "jolt.http-client" "get" (hc-verb "GET")) -(def-var! "jolt.http-client" "head" (hc-verb "HEAD")) -(def-var! "jolt.http-client" "post" (hc-verb "POST")) -(def-var! "jolt.http-client" "put" (hc-verb "PUT")) -(def-var! "jolt.http-client" "delete" (hc-verb "DELETE"))