hookup: utilize Chez core Round 12 prims (SHA, base64, ordered-hashtable, record-walk, bytevector-slice)
ober
747ea3b1e7ca3e06b59f2ca768a2ecbff69bef62
--- a/lib/std/build/reproducible.sls +++ b/lib/std/build/reproducible.sls @@ -63,40 +63,30 @@ (import (chezscheme)) ;; ========== Content Hashing ========== - ;; Default: SHA-256 via Chez's built-in bytevector-hash + double-hashing. - ;; If (std crypto hash) is available, uses real SHA-256. + ;; SHA-256 via Chez core sha256-bytevector (Phase 67, Round 12). ;; *content-hasher* parameter allows plugging in a custom hasher. (define *content-hasher* (make-parameter #f)) ;; #f = use built-in - ;; Try to load real SHA-256 from (std crypto hash) at init time. - (define sha256-proc - (guard (e [#t #f]) - (let ([env (environment '(std crypto hash))]) - (eval 'sha256-bytevector env)))) + (define hex-chars "0123456789abcdef") + + (define (bv->hex bv) + (let* ([n (bytevector-length bv)] + [out (make-string (fx* 2 n))]) + (let loop ([i 0]) + (when (fx< i n) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (fx* 2 i) + (string-ref hex-chars (fxarithmetic-shift-right b 4))) + (string-set! out (fx+ (fx* 2 i) 1) + (string-ref hex-chars (fxand b #xf)))) + (loop (fx+ i 1)))) + out)) (define (sha256-hash bv) - ;; Real SHA-256 producing hex string. - ;; Falls back to strong FNV-1a if crypto module not available. - (if sha256-proc - (sha256-proc bv) - (fnv1a-hash bv))) - - (define (fnv1a-hash bv) - ;; FNV-1a 64-bit over a bytevector. Returns hex string. - ;; Used as fallback when SHA-256 is not available. - (let ([basis #xcbf29ce484222325] - [prime #x100000001b3] - [mask #xffffffffffffffff]) - (let loop ([i 0] [h basis]) - (if (= i (bytevector-length bv)) - (let ([hex (number->string h 16)]) - ;; Zero-pad to 16 hex chars - (string-append (make-string (max 0 (- 16 (string-length hex))) #\0) hex)) - (loop (+ i 1) - (bitwise-and - (* (bitwise-xor h (bytevector-u8-ref bv i)) prime) - mask)))))) + ;; Real SHA-256 producing hex string. No more eval/environment dance — + ;; the prim is in (chezscheme) core. + (bv->hex (sha256-bytevector bv))) (define (str->bv str) ;; String to bytevector using char codes. --- a/lib/std/build/verify.sls +++ b/lib/std/build/verify.sls @@ -37,55 +37,69 @@ (immutable actual verification-result-actual))) ;; actual hash or error message ;; ========== SHA-256 Hex ========== + ;; + ;; sha256-bytevector landed in Chez core (Phase 67, Round 12). This + ;; replaces the previous sha256sum/find/xargs shell pipeline, which had + ;; shell-quote injection surface and required two process spawns per + ;; verification. Pure-Scheme path now: read file → hash → hex-encode. + + (define hex-chars "0123456789abcdef") + + (define (bv->hex bv) + (let* ([n (bytevector-length bv)] + [out (make-string (fx* 2 n))]) + (let loop ([i 0]) + (when (fx< i n) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (fx* 2 i) + (string-ref hex-chars (fxarithmetic-shift-right b 4))) + (string-set! out (fx+ (fx* 2 i) 1) + (string-ref hex-chars (fxand b #xf)))) + (loop (fx+ i 1)))) + out)) + + (define (read-file-bytevector path) + (let* ([port (open-file-input-port path)] + [bv (get-bytevector-all port)]) + (close-port port) + (if (eof-object? bv) #vu8() bv))) (define (file-sha256-hex path) - ;; Compute SHA-256 hex digest of a file using sha256sum. + ;; SHA-256 hex digest of a file using Chez-core sha256-bytevector. ;; Returns hex string or #f on error. (guard (exn [#t #f]) (unless (file-exists? path) (error 'file-sha256-hex "file not found" path)) - (let-values ([(to-stdin from-stdout from-stderr pid) - (open-process-ports - (string-append "sha256sum " (shell-quote path)) - (buffer-mode block) - (make-transcoder (utf-8-codec)))]) - (close-port to-stdin) - (let ([output (get-string-all from-stdout)]) - (close-port from-stdout) - (close-port from-stderr) - (and (string? output) - (>= (string-length output) 64) - (substring output 0 64)))))) - - (define (shell-quote s) - ;; Basic shell quoting — wrap in single quotes, escape existing quotes. - (string-append "'" - (let loop ([i 0] [out '()]) - (if (= i (string-length s)) - (list->string (reverse out)) - (let ([c (string-ref s i)]) - (if (char=? c #\') - (loop (+ i 1) (append (reverse (string->list "'\\''")) out)) - (loop (+ i 1) (cons c out)))))) - "'")) + (bv->hex (sha256-bytevector (read-file-bytevector path))))) (define (directory-hash dir) - ;; Hash all files in a directory recursively. - ;; Returns a combined hex hash or #f. + ;; Hash all files in a directory recursively, sorted by relative path. + ;; Mirrors `find … -type f | sort | xargs sha256sum | sha256sum` but + ;; entirely in-process — no shell, no quoting. (guard (exn [#t #f]) - (let-values ([(to-stdin from-stdout from-stderr pid) - (open-process-ports - (string-append "find " (shell-quote dir) - " -type f -print0 | sort -z | xargs -0 sha256sum | sha256sum") - (buffer-mode block) - (make-transcoder (utf-8-codec)))]) - (close-port to-stdin) - (let ([output (get-string-all from-stdout)]) - (close-port from-stdout) - (close-port from-stderr) - (and (string? output) - (>= (string-length output) 64) - (substring output 0 64)))))) + (let* ([files (sort string<? + (collect-files dir (string-length dir)))] + [parts (map (lambda (rel) + (let* ([full (string-append dir "/" rel)] + [h (file-sha256-hex full)]) + (string->utf8 + (string-append h " " rel "\n")))) + files)] + [combined (apply bytevector-append parts)]) + (bv->hex (sha256-bytevector combined))))) + + (define (collect-files root prefix-len) + ;; Returns a list of paths relative to root (no leading slash). + (let loop ([dir root] [acc '()]) + (fold-left + (lambda (a entry) + (let ([full (string-append dir "/" entry)]) + (cond + [(file-directory? full) (loop full a)] + [else (cons (substring full (fx+ prefix-len 1) + (string-length full)) a)]))) + acc + (directory-list dir)))) ;; ========== Single Dependency Verification ========== --- a/lib/std/clojure.sls +++ b/lib/std/clojure.sls @@ -218,32 +218,12 @@ [(keyword? k) (string->symbol (keyword->string k))] [else #f])) - ;; Collect (field-name . accessor) pairs for a record instance, - ;; walking the parent chain so inherited fields are included in - ;; declaration order (parent first, child fields appended). - ;; Returns a fresh list each call; cache in a caller if hot. + ;; Collect (field-name . value) pairs for a record instance, walking the + ;; parent chain so inherited fields are included in declaration order + ;; (parent first, child fields appended). Backed by Chez core + ;; record->alist (Phase 72, Round 12 — landed 2026-04-26). (define (%record-fields-all rec) - (let ([rtd (record-rtd rec)]) - ;; `walk` receives the tail-so-far and prepends this rtd's fields - ;; (in reverse index order) to it. By walking the chain leaf-to- - ;; root and feeding each result as the tail, we end up with - ;; root-to-leaf declaration order overall. - (define (walk-rtd r tail) - (let* ([names (record-type-field-names r)] - [n (vector-length names)]) - (let lp ([i (- n 1)] [out tail]) - (if (< i 0) - out - (lp (- i 1) - (cons (cons (vector-ref names i) - (record-accessor r i)) - out)))))) - (let walk ([r rtd] [tail '()]) - (cond - [(not r) tail] - [else - (walk (record-type-parent r) - (walk-rtd r tail))])))) + (record->alist rec)) ;; Find a record's field-value by name (walking parent chain). ;; Returns default if not found. @@ -287,8 +267,7 @@ ;; Ordered list of a record's field values (parent first). (define (%record-vals rec) - (map (lambda (pair) ((cdr pair) rec)) - (%record-fields-all rec))) + (map cdr (%record-fields-all rec))) ;; Escape a record to a persistent-map with its field bindings. ;; Called by assoc/dissoc when they need to produce an updated @@ -301,7 +280,7 @@ m (let ([pair (car fields)]) (lp (cdr fields) - (persistent-map-set m (car pair) ((cdr pair) rec))))))) + (persistent-map-set m (car pair) (cdr pair))))))) ;; ========================================================================= ;; Numerics @@ -1282,7 +1261,7 @@ acc (let ([pair (car fields)]) (lp (cdr fields) - (f acc (car pair) ((cdr pair) coll))))))] + (f acc (car pair) (cdr pair))))))] [else (error 'reduce-kv "unsupported collection type" coll)])) ;; min-key — return the x in coll that minimizes (k x). --- a/lib/std/crypto/digest.sls +++ b/lib/std/crypto/digest.sls @@ -1,8 +1,12 @@ #!chezscheme -;;; :std/crypto/digest -- Cryptographic hash functions via openssl CLI +;;; :std/crypto/digest -- Cryptographic hash functions ;;; -;;; HARDENED: Data piped via stdin — no temp files, no command injection. -;;; Command string contains only hardcoded algorithm names. +;;; SHA-1 and SHA-256 use Chez core sha1-bytevector / sha256-bytevector +;;; (Phase 67, Round 12 — landed 2026-04-26 in ChezScheme). No process +;;; spawn, no shell, no openssl dependency for those two. +;;; +;;; MD5, SHA-224, SHA-384, SHA-512 still shell out to `openssl dgst` +;;; with data piped via stdin (no temp files, no command injection). (library (std crypto digest) (export @@ -11,38 +15,45 @@ (import (chezscheme)) - (define (compute-digest algo data) - ;; data can be string or bytevector - (let* ([input (if (bytevector? data) data (string->utf8 data))] - [algo-name (case algo - [(md5) "md5"] - [(sha1) "sha1"] - [(sha224) "sha224"] - [(sha256) "sha256"] - [(sha384) "sha384"] - [(sha512) "sha512"] - [else (error 'compute-digest "unknown algorithm" algo)])]) - ;; Pipe data via stdin — no temp files, no user input in command string - (let-values ([(to-stdin from-stdout from-stderr pid) - (open-process-ports - (string-append "openssl dgst -" algo-name " -hex") - (buffer-mode block) - #f)]) ;; #f = binary mode for stdin - (put-bytevector to-stdin input) - (close-port to-stdin) - (let* ([stdout-transcoded (transcoded-port from-stdout (native-transcoder))] - [output (get-string-all stdout-transcoded)]) - (close-port stdout-transcoded) - (close-port from-stderr) - ;; openssl output: "(stdin)= hexstring\n" - (let ([eq-pos (let lp ([i 0]) - (cond - [(>= i (string-length output)) #f] - [(char=? (string-ref output i) #\=) i] - [else (lp (+ i 1))]))]) - (if eq-pos - (string-trim (substring output (+ eq-pos 1) (string-length output))) - (string-trim output))))))) + (define hex-chars "0123456789abcdef") + + (define (bv->hex bv) + (let* ([n (bytevector-length bv)] + [out (make-string (fx* 2 n))]) + (let loop ([i 0]) + (when (fx< i n) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (fx* 2 i) + (string-ref hex-chars (fxarithmetic-shift-right b 4))) + (string-set! out (fx+ (fx* 2 i) 1) + (string-ref hex-chars (fxand b #xf)))) + (loop (fx+ i 1)))) + out)) + + (define (->bv data) + (if (bytevector? data) data (string->utf8 data))) + + (define (compute-digest-openssl algo-name data) + ;; Stdin pipe — no temp files, no user input in command string. + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports + (string-append "openssl dgst -" algo-name " -hex") + (buffer-mode block) + #f)]) + (put-bytevector to-stdin (->bv data)) + (close-port to-stdin) + (let* ([stdout-transcoded (transcoded-port from-stdout (native-transcoder))] + [output (get-string-all stdout-transcoded)]) + (close-port stdout-transcoded) + (close-port from-stderr) + (let ([eq-pos (let lp ([i 0]) + (cond + [(>= i (string-length output)) #f] + [(char=? (string-ref output i) #\=) i] + [else (lp (+ i 1))]))]) + (if eq-pos + (string-trim (substring output (+ eq-pos 1) (string-length output))) + (string-trim output)))))) (define (string-trim str) (let* ([len (string-length str)] @@ -74,17 +85,16 @@ [else 0])) ;; Public API: returns hex string - (define (md5 data) (compute-digest 'md5 data)) - (define (sha1 data) (compute-digest 'sha1 data)) - (define (sha224 data) (compute-digest 'sha224 data)) - (define (sha256 data) (compute-digest 'sha256 data)) - (define (sha384 data) (compute-digest 'sha384 data)) - (define (sha512 data) (compute-digest 'sha512 data)) + (define (sha1 data) (bv->hex (sha1-bytevector (->bv data)))) + (define (sha256 data) (bv->hex (sha256-bytevector (->bv data)))) - (define (digest->hex-string digest-result) - digest-result) ;; already a hex string + (define (md5 data) (compute-digest-openssl "md5" data)) + (define (sha224 data) (compute-digest-openssl "sha224" data)) + (define (sha384 data) (compute-digest-openssl "sha384" data)) + (define (sha512 data) (compute-digest-openssl "sha512" data)) + (define (digest->hex-string digest-result) digest-result) (define (digest->u8vector digest-result) (hex-string->u8vector digest-result)) - ) ;; end library + ) --- a/lib/std/debug/record-inspect.sls +++ b/lib/std/debug/record-inspect.sls @@ -1,4 +1,10 @@ ;;; Record Introspection — Phase 5c (Track 14.3) +;;; +;;; record->alist now lives in (chezscheme) core (Phase 72, Round 12 — +;;; landed 2026-04-26). The Chez version walks the parent chain so +;;; inherited fields are included (parents first); the previous local +;;; version saw only own-fields. All other helpers here remain so +;;; callers don't need to migrate. (library (std debug record-inspect) (export @@ -8,7 +14,7 @@ record-field-count record-ref record-set! - record->alist + record->alist ;; re-exported from (chezscheme) alist->record record-copy) (import (except (chezscheme) iota)) @@ -17,16 +23,13 @@ (let loop ([i 0] [acc '()]) (if (= i n) (reverse acc) (loop (+ i 1) (cons i acc))))) - ;; Record-type parent (returns #f if no parent) (define (record-type-parent* rtd) (let ([p (record-type-parent rtd)]) (if (boolean? p) #f p))) - ;; Number of fields on a record instance (define (record-field-count r) (vector-length (record-type-field-names (record-rtd r)))) - ;; Generic field access by integer index or symbol name (define (record-ref r field) (let* ([rtd (record-rtd r)] [names (record-type-field-names rtd)] @@ -43,7 +46,6 @@ (loop (+ i 1)))))] [else (error 'record-ref "field must be integer or symbol" field)]))) - ;; Generic field mutation by integer index or symbol name (define (record-set! r field val) (let* ([rtd (record-rtd r)] [names (record-type-field-names rtd)] @@ -62,17 +64,6 @@ (loop (+ i 1)))))] [else (error 'record-set! "field must be integer or symbol" field)]))) - ;; Convert record to association list - (define (record->alist r) - (let* ([rtd (record-rtd r)] - [names (record-type-field-names rtd)] - [n (vector-length names)]) - (map (lambda (i) - (cons (vector-ref names i) - ((record-accessor rtd i) r))) - (iota* n)))) - - ;; Construct a record from an alist using rtd (define (alist->record rtd alist) (let* ([names (record-type-field-names rtd)] [n (vector-length names)] @@ -87,7 +78,6 @@ (let ([ctor (record-constructor (make-record-constructor-descriptor rtd #f #f))]) (apply ctor (vector->list vals))))) - ;; Shallow copy (works only if all fields are mutable) (define (record-copy r) (let* ([rtd (record-rtd r)] [n (vector-length (record-type-field-names rtd))] --- a/lib/std/derive2.sls +++ b/lib/std/derive2.sls @@ -32,35 +32,36 @@ (define (protocol-registry) *protocols*) ;; ========== Record introspection helpers ========== + ;; + ;; The parent-walk helpers below now route through Chez core primitives + ;; (record-fields / record->alist, Phase 72 — landed 2026-04-26). Where we + ;; only have an rtd (no instance), we still walk the chain locally because + ;; the core prims are instance-based. Local walk is parents-first to match + ;; the core contract. + + (define (rtd-chain rtd) + (let loop ([r rtd] [acc '()]) + (if r (loop (record-type-parent r) (cons r acc)) acc))) (define (record-field-names-of rtd) - (let loop ([r rtd] [fields '()]) - (if (not r) - fields - (loop (record-type-parent r) - (append (vector->list (record-type-field-names r)) fields))))) + (apply append + (map (lambda (r) (vector->list (record-type-field-names r))) + (rtd-chain rtd)))) (define (record-field-values obj) - (let* ([rtd (record-rtd obj)] - [names (record-field-names-of rtd)]) - (map (lambda (name) - (let ([acc (record-accessor rtd (field-index rtd name))]) - (acc obj))) - (vector->list (record-type-field-names rtd))))) - - (define (field-index rtd name) - (let ([names (vector->list (record-type-field-names rtd))]) - (let loop ([ns names] [i 0]) - (cond - [(null? ns) (error 'field-index "field not found" name)] - [(eq? (car ns) name) i] - [else (loop (cdr ns) (+ i 1))])))) + ;; Chez core: parents-first list of (name . value) pairs. + (map cdr (record->alist obj))) (define (all-field-accessors rtd) - (let ([names (vector->list (record-type-field-names rtd))]) - (map (lambda (name) - (record-accessor rtd (field-index rtd name))) - names))) + (apply append + (map (lambda (r) + (let ([n (vector-length (record-type-field-names r))]) + (let lp ([i 0] [acc '()]) + (if (fx= i n) + (reverse acc) + (lp (fx+ i 1) + (cons (record-accessor r i) acc)))))) + (rtd-chain rtd)))) ;; ========== auto-equal ========== @@ -90,7 +91,7 @@ (define (auto-display rtd) (let ([accessors (all-field-accessors rtd)] - [names (vector->list (record-type-field-names rtd))] + [names (record-field-names-of rtd)] [type-name (record-type-name rtd)]) (lambda (obj port) (display "#<" port) @@ -142,7 +143,7 @@ (define (auto-serialize rtd) (let ([accessors (all-field-accessors rtd)] - [names (vector->list (record-type-field-names rtd))] + [names (record-field-names-of rtd)] [type-name (record-type-name rtd)] [constructor (record-constructor (make-record-constructor-descriptor rtd #f #f))]) @@ -163,7 +164,7 @@ (define (auto-json rtd) (let ([accessors (all-field-accessors rtd)] - [names (vector->list (record-type-field-names rtd))] + [names (record-field-names-of rtd)] [constructor (record-constructor (make-record-constructor-descriptor rtd #f #f))]) (cons --- a/lib/std/inspect.sls +++ b/lib/std/inspect.sls @@ -93,40 +93,23 @@ (loop (ash m -1) (+ n 1) (if (odd? m) (cons n acc) acc))))]))) - ;; Inspect a condition + ;; Inspect a condition. + ;; Uses Chez core record->alist (Phase 72) so inherited fields surface + ;; parents-first without manual rtd walking. (define (inspect-condition c) (unless (condition? c) (error 'inspect-condition "not a condition" c)) - (let ([components (simple-conditions c)]) - (map (lambda (sc) - (let ([rtd (record-rtd sc)]) - `(,(record-type-name rtd) - ,@(let loop ([flds (csv7:record-type-field-names rtd)] - [i 0] - [acc '()]) - (if (null? flds) - (reverse acc) - (loop (cdr flds) (+ i 1) - (cons (cons (car flds) - ((csv7:record-field-accessor rtd i) sc)) - acc))))))) - components))) + (map (lambda (sc) + (cons (record-type-name (record-rtd sc)) + (record->alist sc))) + (simple-conditions c))) ;; Inspect a record (define (inspect-record rec) (unless (record? rec) (error 'inspect-record "not a record" rec)) - (let ([rtd (record-rtd rec)]) - `((type . ,(record-type-name rtd)) - (fields . ,(let loop ([flds (csv7:record-type-field-names rtd)] - [i 0] - [acc '()]) - (if (null? flds) - (reverse acc) - (loop (cdr flds) (+ i 1) - (cons (cons (car flds) - ((csv7:record-field-accessor rtd i) rec)) - acc)))))))) + `((type . ,(record-type-name (record-rtd rec))) + (fields . ,(record->alist rec)))) ;; Object size in bytes (approximate) (define (object-size obj) new file mode 100644 --- /dev/null +++ b/lib/std/misc/ordered-hashtable.sls @@ -0,0 +1,73 @@ +#!chezscheme +;;; (std misc ordered-hashtable) — Insertion-ordered hash tables +;;; +;;; Thin wrapper exposing Chez core ordered-hashtable (Phase 68, Round 12 — +;;; landed 2026-04-26 in ChezScheme). Keys preserve insertion order across +;;; ref / set! / delete! / clear! and are walked in that order by +;;; ordered-hashtable-walk and ordered-hashtable-keys/values/entries/cells. +;;; +;;; Use cases: HTTP header tables, YAML mappings, JSON object preservation, +;;; LRU eviction queues, deterministic test fixtures. +;;; +;;; This is a distinct Chez record type from R6RS hashtables — predicates +;;; like (hashtable? oht) return #f, so don't substitute it blindly into +;;; APIs that consume eq-/eqv-hashtables. + +(library (std misc ordered-hashtable) + (export + make-ordered-hashtable ;; (hashfn equiv) → oht (eq-comparable: pass eq? eqv? equal?) + make-string-ordered-hashtable ;; convenience: string-hash + string=? + make-eq-ordered-hashtable ;; convenience: eq-style ordered table + ordered-hashtable? + ordered-hashtable-size + ordered-hashtable-ref + ordered-hashtable-contains? + ordered-hashtable-set! + ordered-hashtable-delete! + ordered-hashtable-update! + ordered-hashtable-clear! + ordered-hashtable-keys + ordered-hashtable-values + ordered-hashtable-entries + ordered-hashtable-cells + ordered-hashtable-copy + ordered-hashtable-walk + ordered-hashtable->alist + alist->ordered-hashtable) + + (import (chezscheme)) + + (define (make-string-ordered-hashtable) + (make-ordered-hashtable string-hash string=?)) + + (define (make-eq-ordered-hashtable) + ;; eq? has no separate hash fn; equal-hash on identity works. + (make-ordered-hashtable equal-hash eq?)) + + (define (ordered-hashtable->alist oht) + ;; Returns list of (key . value) pairs in insertion order. + (let-values ([(keys vals) (ordered-hashtable-entries oht)]) + (let ([n (vector-length keys)]) + (let loop ([i 0] [acc '()]) + (if (fx= i n) + (reverse acc) + (loop (fx+ i 1) + (cons (cons (vector-ref keys i) (vector-ref vals i)) + acc))))))) + + (define (alist->ordered-hashtable alist . hash/equiv) + ;; (alist->ordered-hashtable alist) uses string-hash/string=? + ;; (alist->ordered-hashtable alist hashfn equiv) for custom keys + (let ([oht (cond + [(null? hash/equiv) (make-string-ordered-hashtable)] + [(null? (cdr hash/equiv)) + (error 'alist->ordered-hashtable + "must pass both hashfn and equiv-fn or neither")] + [else (make-ordered-hashtable + (car hash/equiv) (cadr hash/equiv))])]) + (for-each (lambda (pair) + (ordered-hashtable-set! oht (car pair) (cdr pair))) + alist) + oht)) + + ) ;; end library --- a/lib/std/net/9p.sls +++ b/lib/std/net/9p.sls @@ -414,12 +414,9 @@ ;;; ========== Low-level decoding helpers ========== - ;; Extract a sub-range of a bytevector (Chez bytevector-copy takes only 1 arg) + ;; Extract a sub-range — Chez core bytevector-slice (Phase 67). (define (subbytevector bv start end) - (let* ([len (- end start)] - [out (make-bytevector len)]) - (bytevector-copy! bv start out 0 len) - out)) + (bytevector-slice bv start end)) (define (decode-u8 bv pos) (values (bytevector-u8-ref bv pos) (+ pos 1))) --- a/lib/std/net/dns.sls +++ b/lib/std/net/dns.sls @@ -136,12 +136,9 @@ (subbytevector bv (+ pos 1) (+ pos 1 label-len)))]) (loop (+ pos 1 label-len) (cons label-str labels) jumped? end-pos hops)))]))))) - ;; Helper: extract sub-bytevector + ;; Helper: extract sub-bytevector — Chez core bytevector-slice (Phase 67). (define (subbytevector bv start end) - (let* ([len (- end start)] - [out (make-bytevector len)]) - (bytevector-copy! bv start out 0 len) - out)) + (bytevector-slice bv start end)) ;; Helper: join strings with separator (define (string-join strs sep) --- a/lib/std/net/http2.sls +++ b/lib/std/net/http2.sls @@ -274,12 +274,9 @@ [str (utf8->string (subbytevector bv (+ offset 1) (+ offset 1 len)))]) (cons str (+ offset 1 len)))) - ;; Helper: extract sub-bytevector + ;; Helper: extract sub-bytevector — Chez core bytevector-slice (Phase 67). (define (subbytevector bv start end) - (let* ([len (- end start)] - [out (make-bytevector len)]) - (bytevector-copy! bv start out 0 len) - out)) + (bytevector-slice bv start end)) ;; HPACK context (dynamic table as alist, max size) (define-record-type hpack-context-rec --- a/lib/std/net/s3.sls +++ b/lib/std/net/s3.sls @@ -83,17 +83,19 @@ [(char<=? #\A c #\F) (+ 10 (- (char->integer c) (char->integer #\A)))] [else 0])) - ;; ========== SHA-256 as bytevector ========== + ;; ========== SHA-256 ========== + ;; + ;; sha256-bytevector landed in Chez core (Phase 67, Round 12 — 2026-04-26), + ;; so we no longer round-trip through (std crypto digest) hex strings. + + (define (->bv data) + (if (bytevector? data) data (string->utf8 data))) (define (sha256-bv data) - ;; Returns SHA-256 hash as a bytevector. - ;; (std crypto digest) sha256 returns a hex string. - (hex-string->bytevector (sha256 data))) + (sha256-bytevector (->bv data))) (define (sha256-hex data) - ;; Returns SHA-256 hash as a lowercase hex string. - (let ([h (sha256 data)]) - (string-downcase h))) + (bytevector->hex (sha256-bv data))) ;; ========== HMAC-SHA256 ========== --- a/lib/std/net/sasl.sls +++ b/lib/std/net/sasl.sls @@ -11,38 +11,7 @@ (import (chezscheme)) - ;; ========== Base64 (self-contained for no external deps) ========== - - (define *b64-chars* - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") - - (define (base64-encode bv) - ;; Encode a bytevector to a base64 string. - (let* ([len (bytevector-length bv)] - [out-len (* 4 (quotient (+ len 2) 3))] - [out (make-string out-len #\=)] - [b64 *b64-chars*]) - (let loop ([i 0] [o 0]) - (when (< i len) - (let* ([b0 (bytevector-u8-ref bv i)] - [b1 (if (< (+ i 1) len) (bytevector-u8-ref bv (+ i 1)) 0)] - [b2 (if (< (+ i 2) len) (bytevector-u8-ref bv (+ i 2)) 0)] - [triple (bitwise-ior - (bitwise-arithmetic-shift-left b0 16) - (bitwise-arithmetic-shift-left b1 8) - b2)]) - (string-set! out o - (string-ref b64 (bitwise-and (bitwise-arithmetic-shift-right triple 18) #x3F))) - (string-set! out (+ o 1) - (string-ref b64 (bitwise-and (bitwise-arithmetic-shift-right triple 12) #x3F))) - (when (< (+ i 1) len) - (string-set! out (+ o 2) - (string-ref b64 (bitwise-and (bitwise-arithmetic-shift-right triple 6) #x3F)))) - (when (< (+ i 2) len) - (string-set! out (+ o 3) - (string-ref b64 (bitwise-and triple #x3F)))) - (loop (+ i 3) (+ o 4))))) - out)) + ;; base64-encode comes from (chezscheme) core (Phase 66, Round 12). ;; ========== PLAIN mechanism (RFC 4616) ========== --- a/lib/std/net/ssh/auth.sls +++ b/lib/std/net/ssh/auth.sls @@ -20,17 +20,7 @@ (std net ssh conditions) (chez-ssh crypto)) - ;; ---- Helpers ---- - - (define (bytevector-append . bvs) - (let* ([total (apply + (map bytevector-length bvs))] - [result (make-bytevector total)]) - (let loop ([bvs bvs] [off 0]) - (unless (null? bvs) - (let ([bv (car bvs)]) - (bytevector-copy! bv 0 result off (bytevector-length bv)) - (loop (cdr bvs) (+ off (bytevector-length bv)))))) - result)) + ;; bytevector-append is in (chezscheme) core — no shim needed. ;; ---- Service request ---- --- a/lib/std/net/ssh/client.sls +++ b/lib/std/net/ssh/client.sls @@ -192,7 +192,7 @@ [b64-clean (list->string (filter (lambda (c) (not (char-whitespace? c))) (string->list b64-text)))] - [decoded (base64-decode-simple b64-clean)]) + [decoded (base64-decode b64-clean)]) (extract-ed25519-seed-from-decoded decoded)))))) (define (string-search haystack needle) @@ -251,57 +251,7 @@ (bytevector-copy! bv off data 0 len) (cons data (+ off len)))) - (define (base64-decode-simple s) - (let ([table (make-vector 128 -1)] - [chars "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"]) - (do ([i 0 (+ i 1)]) - ((>= i 64)) - (vector-set! table (char->integer (string-ref chars i)) i)) - (let ([vals (let loop ([i 0] [acc '()]) - (if (>= i (string-length s)) - (reverse acc) - (let ([c (string-ref s i)]) - (if (char=? c #\=) - (reverse acc) - (let ([v (and (< (char->integer c) 128) - (vector-ref table (char->integer c)))]) - (if (and v (>= v 0)) - (loop (+ i 1) (cons v acc)) - (loop (+ i 1) acc)))))))]) - (let* ([nvals (length vals)] - [nbytes (- (quotient (* nvals 3) 4) - (cond [(= (modulo nvals 4) 2) 1] - [(= (modulo nvals 4) 3) 0] - [else 0]))]) - (let loop ([vs vals] [acc '()]) - (cond - [(null? vs) - (u8-list->bytevector (reverse acc))] - [(>= (length vs) 4) - (let ([a (car vs)] [b (cadr vs)] [c (caddr vs)] [d (cadddr vs)]) - (loop (cddddr vs) - (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left c 6) d)) - (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left b 4) - (bitwise-arithmetic-shift-right c 2))) - (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left a 2) - (bitwise-arithmetic-shift-right b 4))) - acc)))))] - [(= (length vs) 3) - (let ([a (car vs)] [b (cadr vs)] [c (caddr vs)]) - (let ([acc (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left b 4) - (bitwise-arithmetic-shift-right c 2))) - (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left a 2) - (bitwise-arithmetic-shift-right b 4))) - acc))]) - (u8-list->bytevector (reverse acc))))] - [(= (length vs) 2) - (let ([a (car vs)] [b (cadr vs)]) - (let ([acc (cons (bitwise-and #xff (bitwise-ior (bitwise-arithmetic-shift-left a 2) - (bitwise-arithmetic-shift-right b 4))) - acc)]) - (u8-list->bytevector (reverse acc))))] - [else - (u8-list->bytevector (reverse acc))])))))) + ;; base64-decode now comes from (chezscheme) core (Phase 66, Round 12). (define (find-default-key) (let ([home (or (getenv "HOME") "")]) --- a/lib/std/net/ssh/kex.sls +++ b/lib/std/net/ssh/kex.sls @@ -24,16 +24,7 @@ (chez-ssh crypto)) ;; ---- Helpers ---- - - (define (bytevector-append . bvs) - (let* ([total (apply + (map bytevector-length bvs))] - [result (make-bytevector total)]) - (let loop ([bvs bvs] [off 0]) - (unless (null? bvs) - (let ([bv (car bvs)]) - (bytevector-copy! bv 0 result off (bytevector-length bv)) - (loop (cdr bvs) (+ off (bytevector-length bv)))))) - result)) + ;; bytevector-append is in (chezscheme) core — no shim needed. (define (bytevector->uint bv) (let loop ([i 0] [n 0]) --- a/lib/std/net/ssh/known-hosts.sls +++ b/lib/std/net/ssh/known-hosts.sls @@ -16,115 +16,20 @@ (import (chezscheme) (std net ssh wire) - (std net ssh conditions) - (chez-ssh crypto)) - - ;; ---- Base64 encode ---- - (define b64-chars "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") - - (define (base64-encode bv) - (let* ([len (bytevector-length bv)] - [out '()]) - (let loop ([i 0] [acc out]) - (cond - [(>= i len) - (list->string (reverse acc))] - [else - (let* ([b0 (bytevector-u8-ref bv i)] - [b1 (if (< (+ i 1) len) (bytevector-u8-ref bv (+ i 1)) 0)] - [b2 (if (< (+ i 2) len) (bytevector-u8-ref bv (+ i 2)) 0)] - [remaining (- len i)] - [c0 (string-ref b64-chars (bitwise-arithmetic-shift-right b0 2))] - [c1 (string-ref b64-chars - (bitwise-ior - (bitwise-arithmetic-shift-left (bitwise-and b0 3) 4) - (bitwise-arithmetic-shift-right b1 4)))] - [c2 (if (>= remaining 2) - (string-ref b64-chars - (bitwise-ior - (bitwise-arithmetic-shift-left (bitwise-and b1 #xf) 2) - (bitwise-arithmetic-shift-right b2 6))) - #\=)] - [c3 (if (>= remaining 3) - (string-ref b64-chars (bitwise-and b2 #x3f)) - #\=)]) - (loop (+ i 3) - (cons c3 (cons c2 (cons c1 (cons c0 acc))))))])))) - - ;; ---- Base64 decode ---- - (define (base64-decode-char c) - (cond - [(and (char>=? c #\A) (char<=? c #\Z)) (- (char->integer c) (char->integer #\A))] - [(and (char>=? c #\a) (char<=? c #\z)) (+ 26 (- (char->integer c) (char->integer #\a)))] - [(and (char>=? c #\0) (char<=? c #\9)) (+ 52 (- (char->integer c) (char->integer #\0)))] - [(char=? c #\+) 62] - [(char=? c #\/) 63] - [else #f])) - - (define (base64-decode s) - (let ([chars (string->list (string-filter (lambda (c) (not (char-whitespace? c))) s))] - [out '()]) - (let loop ([cs chars] [acc '()]) - (cond - [(null? cs) - (list->bytevector (reverse acc))] - [else - (let* ([c0 (base64-decode-char (car cs))] - [c1 (if (null? (cdr cs)) 0 (base64-decode-char (cadr cs)))] - [c2 (if (or (null? (cdr cs)) (null? (cddr cs)) - (char=? (caddr cs) #\=)) - #f - (base64-decode-char (caddr cs)))] - [c3 (if (or (null? (cdr cs)) (null? (cddr cs)) (null? (cdddr cs)) - (char=? (cadddr cs) #\=)) - #f - (base64-decode-char (cadddr cs)))]) - (when (and c0 c1) - (let ([b0 (bitwise-ior - (bitwise-arithmetic-shift-left c0 2) - (bitwise-arithmetic-shift-right c1 4))]) - (set! acc (cons b0 acc)))) - (when (and c1 c2) - (let ([b1 (bitwise-and #xff - (bitwise-ior - (bitwise-arithmetic-shift-left c1 4) - (bitwise-arithmetic-shift-right c2 2)))]) - (set! acc (cons b1 acc)))) - (when (and c2 c3) - (let ([b2 (bitwise-and #xff - (bitwise-ior - (bitwise-arithmetic-shift-left c2 6) - c3))]) - (set! acc (cons b2 acc)))) - (let ([advance (min 4 (length cs))]) - (loop (list-tail cs advance) acc)))])))) - - (define (string-filter pred s) - (list->string (filter pred (string->list s)))) - - (define (list->bytevector lst) - (let* ([len (length lst)] - [bv (make-bytevector len)]) - (let loop ([l lst] [i 0]) - (unless (null? l) - (bytevector-u8-set! bv i (car l)) - (loop (cdr l) (+ i 1)))) - bv)) + (std net ssh conditions)) + + ;; base64-encode/decode and sha256-bytevector come from (chezscheme) core + ;; (Phases 66/67, Round 12). No more need for chez-ssh crypto FFI. ;; ---- Fingerprint ---- (define (ssh-host-key-fingerprint host-key-blob) - (let ([hash (make-bytevector 32)]) - (ssh-crypto-sha256 host-key-blob (bytevector-length host-key-blob) hash) - (string-append "SHA256:" (base64-encode-no-pad hash)))) + (string-append "SHA256:" + (base64-encode-no-pad (sha256-bytevector host-key-blob)))) (define (base64-encode-no-pad bv) - (let ([s (base64-encode bv)]) - (let loop ([i (- (string-length s) 1)]) - (cond - [(< i 0) ""] - [(char=? (string-ref s i) #\=) (loop (- i 1))] - [else (substring s 0 (+ i 1))])))) + ;; OpenSSH SHA256: prints base64 without trailing '=' padding. + (base64-encode bv #f #f)) ;; ---- Known hosts file ---- @@ -191,7 +96,7 @@ (if (bytevector=? (caddr parsed) host-key-blob) 'ok 'changed)]