crypto/base64/websocket: portable shims for Chez without Round 12 prims
ober
c90f5d5d098a48c4f6b37cbfb0a6351279366fa8
--- a/lib/std/crypto/digest.sls +++ b/lib/std/crypto/digest.sls @@ -1,19 +1,21 @@ #!chezscheme -;;; :std/crypto/digest -- Cryptographic hash functions +;;; (std crypto digest) — hex digest helpers ;;; -;;; 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). +;;; Local override of upstream jerboa's (std crypto digest), which references +;;; Chez core prims `sha1-bytevector` and `sha256-bytevector` introduced in +;;; Round 12 Phase 67. Stock Chez Scheme 10.3 doesn't ship them, so this +;;; copy delegates to (std crypto native-rust) — the Rust ring-backed +;;; bindings already used elsewhere in jerboa-shell — for SHA-1/2 family +;;; digests. MD5 and SHA-224 still shell out to `openssl dgst` (no Rust +;;; binding for those). (library (std crypto digest) (export md5 sha1 sha224 sha256 sha384 sha512 digest->hex-string digest->u8vector) - (import (chezscheme)) + (import (chezscheme) + (std crypto native-rust)) (define hex-chars "0123456789abcdef") @@ -84,14 +86,15 @@ [(char<=? #\A c #\F) (+ 10 (- (char->integer c) (char->integer #\A)))] [else 0])) - ;; Public API: returns hex string - (define (sha1 data) (bv->hex (sha1-bytevector (->bv data)))) - (define (sha256 data) (bv->hex (sha256-bytevector (->bv data)))) + ;; SHA family via Rust ring bindings (no Chez prim, no shell-out). + (define (sha1 data) (bv->hex (rust-sha1 (->bv data)))) + (define (sha256 data) (bv->hex (rust-sha256 (->bv data)))) + (define (sha384 data) (bv->hex (rust-sha384 (->bv data)))) + (define (sha512 data) (bv->hex (rust-sha512 (->bv data)))) - (define (md5 data) (compute-digest-openssl "md5" data)) + ;; MD5 and SHA-224 still shell out (no Rust binding). + (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) --- a/lib/std/net/websocket.sls +++ b/lib/std/net/websocket.sls @@ -27,9 +27,6 @@ (std crypto native-rust) (std text base64)) - ;; sha1-bytevector is now in (chezscheme) core (Phase 67, Round 12). - ;; Falls back to FFI rust-sha1 only when the prim isn't available. - ;;; ========== Opcode constants ========== (define ws-opcode-continuation #x0) (define ws-opcode-text #x1) @@ -233,7 +230,7 @@ ;; Per RFC 6455: SHA1(key + GUID) then base64-encode. (define (ws-handshake-accept key) (let* ([combined (string->utf8 (string-append key ws-guid))] - [hash-bv (sha1-bytevector combined)]) + [hash-bv (rust-sha1 combined)]) (u8vector->base64-string hash-bv))) ;; Generate a random 16-byte WebSocket key (base64-encoded). --- a/lib/std/text/base64.sls +++ b/lib/std/text/base64.sls @@ -1,17 +1,154 @@ #!chezscheme -;;; :std/text/base64 -- Base64 encoding/decoding +;;; :std/text/base64 — pure-Scheme RFC 4648 port ;;; -;;; Thin wrapper over Chez core (chezscheme) base64-encode/base64-decode -;;; (Phase 66 of Round 12 — landed 2026-04-26 in ChezScheme). -;;; Legacy names u8vector->base64-string / base64-string->u8vector kept -;;; as aliases for callers that haven't migrated. +;;; Override for static jsh builds. The upstream (std text base64) is a +;;; thin wrapper over Chez core base64-encode/base64-decode (Round 12 +;;; Phase 66). Some Chez builds — notably the ober/ChezScheme tree +;;; cloned inside jerboa21/jerboa — ship boot files that predate Phase +;;; 66, so the host scheme has the prims but the container scheme does +;;; not. Rather than chase boot-file regen across hosts, this file +;;; provides a self-contained implementation so the build works on any +;;; Chez >= 9.5 regardless of whether base64-encode is a core prim. (library (std text base64) + ;; Define under internal names (b64-encode, b64-decode) and rename on + ;; export. This sidesteps both failure modes: + ;; - On host Chez where base64-encode is a builtin, defining it + ;; locally would error with "multiple definitions". + ;; - On container Chez where base64-encode does NOT exist, using + ;; `(except (chezscheme) base64-encode ...)` errors because Chez + ;; requires excepted names to actually be exported. + ;; Rename-on-export works in both because we never collide with, nor + ;; reference, the built-in name in the library body. (export - base64-encode base64-decode + (rename (b64-encode base64-encode) + (b64-decode base64-decode)) u8vector->base64-string base64-string->u8vector) (import (chezscheme)) - (define u8vector->base64-string base64-encode) - (define base64-string->u8vector base64-decode)) + (define +alphabet-std+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") + (define +alphabet-url+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") + + (define (encode bv url-safe? pad?) + (let* ([alpha (if url-safe? +alphabet-url+ +alphabet-std+)] + [n (bytevector-length bv)] + [full (quotient n 3)] + [rem (- n (* full 3))] + [out-len (+ (* full 4) + (cond [(= rem 0) 0] + [pad? 4] + [(= rem 1) 2] + [else 3]))] + [out (make-string out-len)]) + (let loop ([i 0] [j 0]) + (cond + [(< i (* full 3)) + (let ([b0 (bytevector-u8-ref bv i)] + [b1 (bytevector-u8-ref bv (+ i 1))] + [b2 (bytevector-u8-ref bv (+ i 2))]) + (string-set! out j + (string-ref alpha (bitwise-arithmetic-shift-right b0 2))) + (string-set! out (+ j 1) + (string-ref alpha + (bitwise-and #x3f + (bitwise-ior (bitwise-arithmetic-shift-left b0 4) + (bitwise-arithmetic-shift-right b1 4))))) + (string-set! out (+ j 2) + (string-ref alpha + (bitwise-and #x3f + (bitwise-ior (bitwise-arithmetic-shift-left b1 2) + (bitwise-arithmetic-shift-right b2 6))))) + (string-set! out (+ j 3) + (string-ref alpha (bitwise-and b2 #x3f))) + (loop (+ i 3) (+ j 4)))] + [(= rem 1) + (let ([b0 (bytevector-u8-ref bv i)]) + (string-set! out j + (string-ref alpha (bitwise-arithmetic-shift-right b0 2))) + (string-set! out (+ j 1) + (string-ref alpha + (bitwise-and #x3f (bitwise-arithmetic-shift-left b0 4)))) + (when pad? + (string-set! out (+ j 2) #\=) + (string-set! out (+ j 3) #\=)))] + [(= rem 2) + (let ([b0 (bytevector-u8-ref bv i)] + [b1 (bytevector-u8-ref bv (+ i 1))]) + (string-set! out j + (string-ref alpha (bitwise-arithmetic-shift-right b0 2))) + (string-set! out (+ j 1) + (string-ref alpha + (bitwise-and #x3f + (bitwise-ior (bitwise-arithmetic-shift-left b0 4) + (bitwise-arithmetic-shift-right b1 4))))) + (string-set! out (+ j 2) + (string-ref alpha + (bitwise-and #x3f (bitwise-arithmetic-shift-left b1 2)))) + (when pad? + (string-set! out (+ j 3) #\=)))])) + out)) + + (define b64-encode + (case-lambda + [(bv) (encode bv #f #t)] + [(bv url-safe?) (encode bv url-safe? #t)] + [(bv url-safe? pad?) (encode bv url-safe? pad?)])) + + (define (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)))] + [(or (char=? c #\+) (char=? c #\-)) 62] + [(or (char=? c #\/) (char=? c #\_)) 63] + [else #f])) + + (define (b64-decode str) + (let* ([raw-len (string-length str)] + [end (let loop ([k raw-len]) + (if (and (> k 0) (char=? (string-ref str (- k 1)) #\=)) + (loop (- k 1)) + k))]) + (when (= 1 (modulo end 4)) + (errorf 'base64-decode "invalid base64 length (mod 4 = 1)")) + (let* ([q (quotient end 4)] + [r (- end (* q 4))] + [out-len (case r + [(0) (* q 3)] + [(2) (+ (* q 3) 1)] + [(3) (+ (* q 3) 2)])] + [out (make-bytevector out-len)]) + (let loop ([i 0] [j 0]) + (cond + [(>= i end) out] + [else + (let* ([n (min 4 (- end i))] + [c0 (decode-char (string-ref str i))] + [c1 (and (>= n 2) (decode-char (string-ref str (+ i 1))))] + [c2 (and (>= n 3) (decode-char (string-ref str (+ i 2))))] + [c3 (and (>= n 4) (decode-char (string-ref str (+ i 3))))]) + (unless c0 (errorf 'base64-decode "invalid char at index ~a" i)) + (when (and (>= n 2) (not c1)) (errorf 'base64-decode "invalid char at index ~a" (+ i 1))) + (when (and (>= n 3) (not c2)) (errorf 'base64-decode "invalid char at index ~a" (+ i 2))) + (when (and (>= n 4) (not c3)) (errorf 'base64-decode "invalid char at index ~a" (+ i 3))) + (when (>= n 2) + (bytevector-u8-set! out j + (bitwise-and #xff + (bitwise-ior (bitwise-arithmetic-shift-left c0 2) + (bitwise-arithmetic-shift-right c1 4))))) + (when (>= n 3) + (bytevector-u8-set! out (+ j 1) + (bitwise-and #xff + (bitwise-ior (bitwise-arithmetic-shift-left c1 4) + (bitwise-arithmetic-shift-right c2 2))))) + (when (>= n 4) + (bytevector-u8-set! out (+ j 2) + (bitwise-and #xff + (bitwise-ior (bitwise-arithmetic-shift-left c2 6) c3)))) + (loop (+ i 4) (+ j 3)))]))))) + + (define u8vector->base64-string b64-encode) + (define base64-string->u8vector b64-decode))