Gerbil parity sprint: add 50 new stdlib modules (10,949 lines)
ober
ecfdcb29fe4c74f3e76fac6c911018ae6c59a12e
--- a/docs/TODO.md +++ b/docs/TODO.md @@ -52,11 +52,105 @@ or completed in the March 2026 sprint. Remaining items are genuinely open. --- -## Remaining +## Remaining — Gerbil Parity Sprint (50 features) -### Networking Polish +Features that Gerbil has but Jerboa does not. Organized by category. + +### Core Language (4) + +- [x] **1. `(std amb)`** — Nondeterministic computation with backtracking (amb, amb-find, amb-collect, amb-assert) +- [x] **2. `(std lazy)`** — Lazy streams (lazy, delay, force, lcons, ltake, ldrop, lmap, lfilter, lfold, lappend) +- [x] **3. `(std ref)`** — Generic polymorphic accessor (ref, ref-set! for lists, vectors, hash tables, strings) +- [x] **4. `(std deprecation)`** — Deprecation warnings with source location and migration hints + +### Data Structures (7) + +- [x] **5. `(std misc plist)`** — Property lists (pget, pput, pdel, plist->alist, alist->plist, plist-keys) +- [x] **6. `(std misc evector)`** — Expandable/growable vectors (make-evector, evector-push!, evector-pop!, evector-ref, evector->vector) +- [x] **7. `(std misc rbtree)`** — Red-black balanced BST (rbtree-insert, rbtree-lookup, rbtree-delete, rbtree-fold, rbtree->list) +- [x] **8. `(std misc decimal)`** — Exact decimal arithmetic (decimal+, decimal*, decimal/, decimal-round, string->decimal, decimal->string) +- [x] **9. `(std misc prime)`** — Primality testing, prime generation, factorization (prime?, next-prime, primes-up-to, factorize) +- [x] **10. `(std misc dag)`** — DAG operations (make-dag, dag-add-edge!, topological-sort, dag-reachable, dag-sources, dag-sinks) +- [x] **11. `(std misc shared)`** — Thread-safe shared mutable state (make-shared, shared-ref, shared-set!, shared-update!, shared-cas!) + +### Text & Encoding (4) + +- [x] **12. `(std text utf16)`** — UTF-16 encoding/decoding (string->utf16, utf16->string, utf16-length, BOM handling) +- [x] **13. `(std text utf32)`** — UTF-32 encoding/decoding (string->utf32, utf32->string) +- [x] **14. `(std text base58)`** — Base58 encoding for Bitcoin/IPFS (base58-encode, base58-decode, base58check-encode) +- [x] **15. `(std text html)`** — HTML parsing and generation (html-escape, html-unescape, parse-html, html->sxml) + +### Markup (3) + +- [x] **16. `(std markup sxml)`** — SXML representation, construction, and manipulation (sxml:element?, sxml:attributes, sxml:children) +- [x] **17. `(std markup sxml-path)`** — XPath-like queries on SXML trees (sxpath, sxml:select, node-typeof?, node-join) +- [x] **18. `(std markup sxml-print)`** — SXML to HTML/XML serialization (sxml->html, sxml->xml, sxml->string) + +### Networking (4) + +- [x] **19. `(std net socks)`** — SOCKS4/5 proxy client (socks-connect, socks4-connect, socks5-connect, with-socks-proxy) +- [x] **20. `(std net s3)`** — AWS S3 client (s3-put-object, s3-get-object, s3-list-bucket, s3-delete-object, sigv4 signing) +- [x] **21. `(std net sasl)`** — SASL authentication mechanisms (sasl-plain, sasl-scram-sha-256, sasl-step) +- [x] **22. `(std net bio)`** — Buffered network I/O (make-bio-input, make-bio-output, bio-read-line, bio-read-bytes, bio-flush) + +### Web (2) + +- [x] **23. `(std web fastcgi)`** — FastCGI protocol (fastcgi-accept, fastcgi-respond, fastcgi-params) +- [x] **24. `(std web rack)`** — Middleware/handler composable web interface (make-app, wrap-middleware, rack-run) + +### MIME (2) + +- [x] **25. `(std mime struct)`** — MIME message structure (make-mime-message, mime-headers, mime-body, multipart-encode, multipart-decode) +- [x] **26. `(std mime types)`** — MIME type database (extension->mime-type, mime-type->extension, mime-type?) + +### Crypto (2) + +- [x] **27. `(std crypto bn)`** — Big number arithmetic (bn+, bn*, bn-mod, bn-expt-mod, bn->bytevector, bytevector->bn) +- [x] **28. `(std crypto dh)`** — Diffie-Hellman key exchange (dh-generate-parameters, dh-generate-key, dh-compute-shared) + +### Database (2) + +- [x] **29. `(std db dbi)`** — Generic database interface (dbi-connect, dbi-query, dbi-exec, dbi-prepare, dbi-with-transaction) +- [x] **30. `(std db conpool)`** — Database connection pooling (make-connection-pool, pool-acquire, pool-release, with-connection) + +### Parser Framework (2) + +- [x] **31. `(std parser deflexer)`** — Lexer definition macro (deflexer, define-token, lex-string, lex-port) +- [x] **32. `(std parser defparser)`** — Parser definition macro with grammar rules (defparser, define-rule, parse) + +### Protobuf Enhanced (2) + +- [x] **33. `(std protobuf macros)`** — defmessage macro for defining proto3 message types as Scheme records +- [x] **34. `(std protobuf grammar)`** — .proto file parser (read-proto-file, proto->scheme) + +### Debug (3) + +- [x] **35. `(std debug heap)`** — Heap introspection and GC stats (heap-size, gc-count, gc-time, object-counts) +- [x] **36. `(std debug memleak)`** — Memory leak detection (track-allocation, report-leaks, with-leak-check) +- [x] **37. `(std debug threads)`** — Thread inspection and debugging (thread-list, thread-backtrace, thread-state) + +### I/O (3) + +- [x] **38. `(std io bio)`** — Buffered I/O with lookahead (make-buffered-input, buffered-peek, buffered-read-line, buffered-unread) +- [x] **39. `(std io strio)`** — String-based I/O with readers/writers (make-string-reader, reader-peek, reader-read-while) +- [x] **40. `(std io delimited)`** — Delimited text I/O (read-delimited, read-line*, read-until, write-delimited) + +### CLI (1) + +- [x] **41. `(std cli print-exit)`** — Print formatted output and exit (print-exit, print-error-exit, exit/success, exit/failure) + +### SRFI (9) + +- [x] **42. `(std srfi srfi-41)`** — Streams: lazy sequences (stream-cons, stream-null, stream-car, stream-cdr, stream-map, stream-filter, stream-fold) +- [x] **43. `(std srfi srfi-42)`** — Eager comprehensions (do-ec, list-ec, vector-ec, sum-ec, every?-ec, first-ec) +- [x] **44. `(std srfi srfi-113)`** — Sets and bags (set, bag, set-adjoin, set-delete, set-union, set-intersection, set-difference) +- [x] **45. `(std srfi srfi-121)`** — Generators (make-coroutine-generator, generator->list, gmap, gfilter, gfold) +- [x] **46. `(std srfi srfi-132)`** — Sort libraries (list-sort, list-stable-sort, vector-sort, vector-stable-sort, list-merge, vector-merge) +- [x] **47. `(std srfi srfi-133)`** — Extended vector library (vector-unfold, vector-map, vector-for-each, vector-fold, vector-count, vector-index) +- [x] **48. `(std srfi srfi-134)`** — Immutable deques (ideque, ideque-front, ideque-back, ideque-add-front, ideque-add-back, ideque-remove-front) +- [x] **49. `(std srfi srfi-144)`** — Flonum library (fl+, fl*, flsqrt, flexp, fllog, flsin, flcos, fl=, fl<, flonum constants) +- [x] **50. `(std srfi srfi-158)`** — Generators and accumulator (generator, circular-generator, make-accumulator, generator-fold, generator-for-each) + +### Networking Polish (existing) -- **SOCKS proxy** — low priority - **HTTP client API compat** — header format differences vs Gerbil - (dotted pairs vs triples). `(std net request)` works but Gerbil - ports need header conversion. new file mode 100644 --- /dev/null +++ b/lib/std/amb.sls @@ -0,0 +1,97 @@ +#!chezscheme +;;; (std amb) — Nondeterministic computation with backtracking +;;; +;;; McCarthy's amb operator using call/cc and a failure continuation stack. +;;; Explores nondeterministic choices depth-first; backtracks on failure. +;;; +;;; API: +;;; (amb x ...) — choose one value; backtrack on failure +;;; (amb-assert cond) — fail if condition is #f +;;; (amb-fail) — trigger backtracking +;;; (amb-find expr) — find first solution or #f +;;; (amb-collect expr) — collect all solutions into a list + +(library (std amb) + (export amb amb-assert amb-fail amb-find amb-collect) + + (import (chezscheme)) + + ;; The failure stack: a list of thunks, each of which resumes a + ;; previously captured continuation to try the next alternative. + (define *fail-stack* (make-parameter '())) + + ;; Trigger backtracking. Pops the most recent alternative off the + ;; failure stack and invokes it. If the stack is empty, raises an + ;; error (when used outside amb-find/amb-collect) or returns the + ;; sentinel installed by those forms. + (define (amb-fail) + (let ([stk (*fail-stack*)]) + (if (null? stk) + (error 'amb "no more alternatives") + (let ([top (car stk)]) + (*fail-stack* (cdr stk)) + (top))))) + + ;; Assert a condition; backtrack if it is false. + (define (amb-assert condition) + (unless condition (amb-fail))) + + ;; (amb v1 v2 ... vn) — nondeterministically return one of the values. + ;; With zero arguments, immediately fails (equivalent to amb-fail). + ;; Implementation: capture the current continuation, push alternatives + ;; onto the failure stack, and return the first choice. When + ;; backtracking reaches this point, the next alternative is tried. + (define-syntax amb + (syntax-rules () + [(_) (amb-fail)] + [(_ x) x] + [(_ x rest ...) + (call/cc + (lambda (k) + ;; Save current failure stack so we can restore it when + ;; trying alternatives at this choice point. + (let ([saved (*fail-stack*)]) + ;; Push a thunk that will try the remaining alternatives. + ;; When invoked, it restores the failure stack to what it + ;; was *before* pushing, then sets up the remaining choices + ;; by re-entering through the same continuation. + (*fail-stack* + (cons (lambda () + (*fail-stack* saved) + (k (amb rest ...))) + saved)) + x)))])) + + ;; Find the first solution. Returns #f if no solution exists. + ;; Installs a bottom-of-stack handler that escapes with #f. + (define-syntax amb-find + (syntax-rules () + [(_ expr) + (call/cc + (lambda (exit) + (parameterize ([*fail-stack* + (list (lambda () (exit #f)))]) + (let ([result expr]) + ;; Got a result — escape with it immediately so we + ;; don't explore further. + (exit result)))))])) + + ;; Collect all solutions into a list. + ;; Installs a bottom-of-stack handler that escapes with the + ;; accumulated results, and after each successful evaluation + ;; forces backtracking to find more. + (define-syntax amb-collect + (syntax-rules () + [(_ expr) + (let ([results '()]) + (call/cc + (lambda (exit) + (parameterize ([*fail-stack* + (list (lambda () + (exit (reverse results))))]) + (let ([v expr]) + (set! results (cons v results)) + ;; Force backtracking to find more solutions. + (amb-fail))))))])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/cli/print-exit.sls @@ -0,0 +1,54 @@ +#!chezscheme +;;; (std cli print-exit) — Print and exit utilities +;;; +;;; Convenience procedures for CLI tools: formatted output to stdout/stderr +;;; followed by process exit, plus warning helpers. + +(library (std cli print-exit) + (export + print-exit print-error-exit + exit/success exit/failure + die warn-and-continue) + + (import (chezscheme)) + + (define (print-exit fmt . args) + ;; Format and print to stdout, then exit 0. + (apply fprintf (console-output-port) fmt args) + (newline (console-output-port)) + (flush-output-port (console-output-port)) + (exit 0)) + + (define (print-error-exit fmt . args) + ;; Format and print to stderr, then exit 1. + (apply fprintf (console-error-port) fmt args) + (newline (console-error-port)) + (flush-output-port (console-error-port)) + (exit 1)) + + (define (exit/success) + ;; Exit with status 0. + (exit 0)) + + (define (exit/failure . rest) + ;; Exit with status 1. If a message string is given, print it to stderr. + (when (pair? rest) + (display (car rest) (console-error-port)) + (newline (console-error-port)) + (flush-output-port (console-error-port))) + (exit 1)) + + (define (die fmt . args) + ;; Format and print to stderr, then exit 1. Alias for print-error-exit. + (apply fprintf (console-error-port) fmt args) + (newline (console-error-port)) + (flush-output-port (console-error-port)) + (exit 1)) + + (define (warn-and-continue fmt . args) + ;; Format and print warning to stderr, continue execution. + (apply fprintf (console-error-port) fmt args) + (newline (console-error-port)) + (flush-output-port (console-error-port))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/crypto/bn.sls @@ -0,0 +1,166 @@ +#!chezscheme +;;; (std crypto bn) — Big number arithmetic utilities +;;; +;;; Convenience wrappers around Chez Scheme's native arbitrary-precision +;;; integers (bignums). Provides modular arithmetic, serialization to/from +;;; bytevectors and hex strings, and comparison helpers. + +(library (std crypto bn) + (export + bn+ bn- bn* bn/ bn-mod + bn-expt-mod + bn-gcd + bn-modinv + bn->bytevector bytevector->bn + bn->hex hex->bn + bn-bit-length + bn-zero? bn-negative? + bn-compare) + + (import (chezscheme)) + + ;; ========== Basic arithmetic ========== + + (define (bn+ a b) (+ a b)) + (define (bn- a b) (- a b)) + (define (bn* a b) (* a b)) + (define (bn/ a b) (div a b)) + (define (bn-mod a b) (mod a b)) + + ;; ========== Modular exponentiation (square-and-multiply) ========== + + (define (bn-expt-mod base exp modulus) + ;; Compute (base ^ exp) mod modulus efficiently. + ;; exp must be non-negative, modulus must be positive. + (when (< exp 0) + (error 'bn-expt-mod "exponent must be non-negative" exp)) + (when (<= modulus 0) + (error 'bn-expt-mod "modulus must be positive" modulus)) + (cond + [(= modulus 1) 0] + [(= exp 0) 1] + [else + (let loop ([b (mod base modulus)] + [e exp] + [result 1]) + (if (= e 0) + result + (let ([result (if (odd? e) + (mod (* result b) modulus) + result)] + [b (mod (* b b) modulus)] + [e (bitwise-arithmetic-shift-right e 1)]) + (loop b e result))))])) + + ;; ========== GCD ========== + + (define (bn-gcd a b) + (let loop ([a (abs a)] [b (abs b)]) + (if (zero? b) a (loop b (mod a b))))) + + ;; ========== Modular inverse (extended Euclidean algorithm) ========== + + (define (bn-modinv a modulus) + ;; Return x such that (a * x) mod modulus = 1. + ;; Raises an error if a and modulus are not coprime. + (when (<= modulus 0) + (error 'bn-modinv "modulus must be positive" modulus)) + (let loop ([old-r (mod a modulus)] [r modulus] + [old-s 1] [s 0]) + (if (zero? r) + (if (= old-r 1) + (mod old-s modulus) + (error 'bn-modinv "no modular inverse; gcd != 1" a modulus)) + (let ([q (div old-r r)]) + (loop r (- old-r (* q r)) + s (- old-s (* q s))))))) + + ;; ========== Serialization: bytevector (unsigned big-endian) ========== + + (define (bn->bytevector n) + ;; Convert a non-negative exact integer to a big-endian bytevector. + ;; Zero produces a single zero byte. + (when (negative? n) + (error 'bn->bytevector "expected non-negative integer" n)) + (if (zero? n) + (make-bytevector 1 0) + (let* ([bit-len (bitwise-length n)] + [byte-len (fxdiv (fx+ bit-len 7) 8)] + [bv (make-bytevector byte-len 0)]) + (let loop ([i (fx- byte-len 1)] [val n]) + (when (>= i 0) + (bytevector-u8-set! bv i (bitwise-and val #xff)) + (loop (fx- i 1) (bitwise-arithmetic-shift-right val 8)))) + bv))) + + (define (bytevector->bn bv) + ;; Convert a big-endian unsigned bytevector to an exact non-negative integer. + (let ([len (bytevector-length bv)]) + (let loop ([i 0] [acc 0]) + (if (fx>= i len) + acc + (loop (fx+ i 1) + (+ (bitwise-arithmetic-shift-left acc 8) + (bytevector-u8-ref bv i))))))) + + ;; ========== Serialization: hex strings ========== + + (define (bn->hex n) + ;; Convert an exact integer to a lowercase hex string (no prefix). + ;; Negative numbers get a leading "-". + (if (zero? n) + "0" + (let* ([neg? (negative? n)] + [val (abs n)]) + (let loop ([v val] [chars '()]) + (if (zero? v) + (if neg? + (list->string (cons #\- chars)) + (list->string chars)) + (let* ([digit (bitwise-and v #xf)] + [ch (string-ref "0123456789abcdef" digit)]) + (loop (bitwise-arithmetic-shift-right v 4) + (cons ch chars)))))))) + + (define (hex->bn str) + ;; Parse a hex string (optional leading "-", no "0x" prefix) to exact integer. + (when (= (string-length str) 0) + (error 'hex->bn "empty string")) + (let* ([neg? (char=? (string-ref str 0) #\-)] + [start (if neg? 1 0)] + [len (string-length str)]) + (when (= start len) + (error 'hex->bn "no digits after sign" str)) + (let loop ([i start] [acc 0]) + (if (fx>= i len) + (if neg? (- acc) acc) + (let* ([ch (string-ref str i)] + [digit (cond + [(and (char>=? ch #\0) (char<=? ch #\9)) + (fx- (char->integer ch) (char->integer #\0))] + [(and (char>=? ch #\a) (char<=? ch #\f)) + (fx+ 10 (fx- (char->integer ch) (char->integer #\a)))] + [(and (char>=? ch #\A) (char<=? ch #\F)) + (fx+ 10 (fx- (char->integer ch) (char->integer #\A)))] + [else (error 'hex->bn "invalid hex character" ch)])]) + (loop (fx+ i 1) + (+ (bitwise-arithmetic-shift-left acc 4) digit))))))) + + ;; ========== Bit length ========== + + (define (bn-bit-length n) + ;; Number of bits needed to represent |n| (0 returns 0). + (bitwise-length (abs n))) + + ;; ========== Predicates and comparison ========== + + (define (bn-zero? n) (zero? n)) + (define (bn-negative? n) (negative? n)) + + (define (bn-compare a b) + ;; Return -1, 0, or 1. + (cond [(< a b) -1] + [(= a b) 0] + [else 1])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/crypto/dh.sls @@ -0,0 +1,196 @@ +#!chezscheme +;;; (std crypto dh) — Diffie-Hellman key exchange +;;; +;;; Provides parameter generation, key generation, and shared-secret +;;; computation for classic DH over Z/pZ. Includes RFC 3526 Group 14 +;;; (2048-bit MODP) as a ready-to-use parameter set. +;;; +;;; Random bytes are read from /dev/urandom for security-relevant operations. + +(library (std crypto dh) + (export + make-dh-params dh-params? dh-params-p dh-params-g + make-dh-key dh-key? dh-key-public dh-key-private + dh-generate-parameters + dh-generate-key + dh-compute-shared + dh-2048-modp) + + (import (chezscheme) + (std crypto bn)) + + ;; ========== Record types ========== + + (define-record-type dh-params + (fields p g) + (protocol + (lambda (new) + (lambda (p g) + (unless (and (integer? p) (positive? p)) + (error 'make-dh-params "p must be a positive integer" p)) + (unless (and (integer? g) (positive? g)) + (error 'make-dh-params "g must be a positive integer" g)) + (new p g))))) + + (define-record-type dh-key + (fields public private) + (protocol + (lambda (new) + (lambda (public private) + (new public private))))) + + ;; ========== Random number generation (from /dev/urandom) ========== + + (define (read-urandom-bytes n) + ;; Read N bytes from /dev/urandom, return as a bytevector. + (let ([bv (make-bytevector n)] + [port (open-file-input-port "/dev/urandom" + (file-options) + (buffer-mode block))]) + (dynamic-wind + (lambda () (void)) + (lambda () + (let loop ([offset 0]) + (when (< offset n) + (let ([got (get-bytevector-n! port bv offset (- n offset))]) + (when (eof-object? got) + (error 'read-urandom-bytes "unexpected EOF from /dev/urandom")) + (loop (+ offset got))))) + bv) + (lambda () (close-port port))))) + + (define (random-integer-below limit) + ;; Return a random integer in [1, limit-1] using /dev/urandom. + ;; Uses rejection sampling to avoid modular bias. + (when (<= limit 2) + (error 'random-integer-below "limit must be > 2" limit)) + (let* ([byte-len (fxdiv (fx+ (bn-bit-length limit) 7) 8)] + ;; Compute mask: 2^(bit-length of limit) - 1 + [bit-len (bn-bit-length limit)] + [mask (- (bitwise-arithmetic-shift-left 1 bit-len) 1)]) + (let loop () + (let* ([bv (read-urandom-bytes byte-len)] + [candidate (bitwise-and (bytevector->bn bv) mask)]) + ;; We need candidate in [1, limit-1] + (if (and (> candidate 0) (< candidate limit)) + candidate + (loop)))))) + + ;; ========== RFC 3526 Group 14: 2048-bit MODP ========== + + (define dh-2048-modp + (make-dh-params + (hex->bn + (string-append + "FFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD1" + "29024E088A67CC74020BBEA63B139B22514A08798E3404DD" + "EF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245" + "E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7ED" + "EE386BFB5A899FA5AE9F24117C4B1FE649286651ECE45B3D" + "C2007CB8A163BF0598DA48361C55D39A69163FA8FD24CF5F" + "83655D23DCA3AD961C62F356208552BB9ED529077096966D" + "670C354E4ABC9804F1746C08CA18217C32905E462E36CE3B" + "E39E772C180E86039B2783A2EC07A28FB5C55DF06F4C52C9" + "DE2BCBF6955817183995497CEA956AE515D2261898FA0510" + "15728E5A8AACAA68FFFFFFFFFFFFFFFF")) + 2)) + + ;; ========== Parameter generation ========== + + (define (dh-generate-parameters bits . args) + ;; Generate DH parameters with a prime of approximately BITS bits. + ;; Optional keyword: generator (default 2). + ;; NOTE: For production use, prefer dh-2048-modp or other well-known + ;; groups. This generates a random probable prime, which is slower + ;; and less auditable than established parameters. + (let ([g (if (null? args) 2 (car args))]) + (unless (and (fixnum? bits) (>= bits 512)) + (error 'dh-generate-parameters "bits must be >= 512" bits)) + (let ([p (generate-safe-prime bits)]) + (make-dh-params p g)))) + + (define (generate-safe-prime bits) + ;; Find a probable safe prime p where p = 2q + 1 and q is also prime. + ;; Uses Miller-Rabin with enough rounds for confidence. + (let loop () + (let* ([candidate (random-odd-with-bits bits)]) + ;; Check if candidate is prime, and (candidate-1)/2 is also prime + (if (and (miller-rabin-prime? candidate 20) + (miller-rabin-prime? (div (- candidate 1) 2) 20)) + candidate + (loop))))) + + (define (random-odd-with-bits bits) + ;; Generate a random odd number with exactly BITS bits (high bit set). + (let* ([byte-len (fxdiv (fx+ bits 7) 8)] + [bv (read-urandom-bytes byte-len)] + [n (bytevector->bn bv)] + ;; Set the high bit + [n (bitwise-ior n (bitwise-arithmetic-shift-left 1 (- bits 1)))] + ;; Clear any bits above our target bit-length + [mask (- (bitwise-arithmetic-shift-left 1 bits) 1)] + [n (bitwise-and n mask)] + ;; Make odd + [n (bitwise-ior n 1)]) + n)) + + (define (miller-rabin-prime? n rounds) + ;; Miller-Rabin primality test. Returns #t if n is probably prime. + (cond + [(< n 2) #f] + [(= n 2) #t] + [(= n 3) #t] + [(even? n) #f] + [else + ;; Write n-1 as 2^r * d where d is odd + (let-values ([(r d) (factor-out-2s (- n 1))]) + (let loop ([i 0]) + (if (>= i rounds) + #t ; probably prime + (let* ([a (+ 2 (random-integer-below (- n 3)))] + ;; a is in [2, n-2] + [x (bn-expt-mod a d n)]) + (cond + [(or (= x 1) (= x (- n 1))) + (loop (+ i 1))] + [else + (let inner ([j 1] [x x]) + (cond + [(>= j r) #f] ; composite + [(= (bn-expt-mod x 2 n) (- n 1)) + (loop (+ i 1))] + [(= (bn-expt-mod x 2 n) 1) + #f] ; composite + [else + (inner (+ j 1) (bn-expt-mod x 2 n))]))])))))])) + + (define (factor-out-2s n) + ;; Return (values r d) where n = 2^r * d and d is odd. + (let loop ([r 0] [d n]) + (if (even? d) + (loop (+ r 1) (div d 2)) + (values r d)))) + + ;; ========== Key generation ========== + + (define (dh-generate-key params) + ;; Generate a DH key pair given parameters. + ;; Private key: random integer in [1, p-2] + ;; Public key: g^private mod p + (let* ([p (dh-params-p params)] + [g (dh-params-g params)] + [private (random-integer-below (- p 1))] ; [1, p-2] + [public (bn-expt-mod g private p)]) + (make-dh-key public private))) + + ;; ========== Shared secret computation ========== + + (define (dh-compute-shared params own-private other-public) + ;; Compute shared secret: other-public^own-private mod p + (let ([p (dh-params-p params)]) + (unless (and (> other-public 1) (< other-public (- p 1))) + (error 'dh-compute-shared + "other party's public key out of safe range" other-public)) + (bn-expt-mod other-public own-private p))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/db/conpool.sls @@ -0,0 +1,177 @@ +#!chezscheme +;;; (std db conpool) — Database connection pooling +;;; +;;; Thread-safe connection pool using Chez Scheme's mutex and condition +;;; variables. Manages a set of idle connections and tracks active ones. +;;; Connections are created on demand up to a configurable maximum. + +(library (std db conpool) + (export + make-connection-pool + pool-acquire + pool-release + pool-close + with-connection + pool-size + pool-available + pool-stats) + + (import (chezscheme)) + + ;; ========== Pool record ========== + + (define-record-type connection-pool + (fields + connector ; thunk that creates a new connection + max-size ; maximum number of connections (idle + active) + (mutable idle) ; list of idle connections + (mutable active) ; count of connections currently checked out + (mutable closed?) ; #t once pool-close has been called + (mutable total) ; total number of connections created (idle + active) + mutex ; mutex for thread safety + available-cv) ; condition variable: signaled when a connection + ; becomes available or pool is closed + (protocol + (lambda (new) + (lambda (connector max-size) + (unless (procedure? connector) + (error 'make-connection-pool "connector must be a procedure" connector)) + (unless (and (fixnum? max-size) (fx> max-size 0)) + (error 'make-connection-pool "max-size must be a positive fixnum" max-size)) + (new connector max-size + '() ; idle + 0 ; active + #f ; closed? + 0 ; total + (make-mutex) + (make-condition)))))) + + ;; ========== Internal helpers ========== + + (define (pool-check-open pool who) + (when (connection-pool-closed? pool) + (error who "connection pool is closed"))) + + ;; ========== Public API ========== + + (define (pool-acquire pool) + ;; Acquire a connection from the pool. If an idle connection is + ;; available, return it. Otherwise, if the pool is not at capacity, + ;; create a new one. If at capacity, block until one is released. + (let ([mtx (connection-pool-mutex pool)] + [cv (connection-pool-available-cv pool)]) + (mutex-acquire mtx) + (let loop () + (pool-check-open pool 'pool-acquire) + (let ([idle (connection-pool-idle pool)]) + (cond + ;; Idle connection available: take it + [(pair? idle) + (let ([conn (car idle)]) + (connection-pool-idle-set! pool (cdr idle)) + (connection-pool-active-set! pool + (fx+ (connection-pool-active pool) 1)) + (mutex-release mtx) + conn)] + ;; Room to create a new connection + [(fx< (connection-pool-total pool) (connection-pool-max-size pool)) + (connection-pool-active-set! pool + (fx+ (connection-pool-active pool) 1)) + (connection-pool-total-set! pool + (fx+ (connection-pool-total pool) 1)) + (mutex-release mtx) + ;; Create connection outside the lock + (let ([conn ((connection-pool-connector pool))]) + conn)] + ;; At capacity — wait + [else + (condition-wait cv mtx) + (loop)]))))) + + (define (pool-release pool conn) + ;; Return a connection to the pool's idle list. + (let ([mtx (connection-pool-mutex pool)] + [cv (connection-pool-available-cv pool)]) + (mutex-acquire mtx) + (connection-pool-active-set! pool + (fx- (connection-pool-active pool) 1)) + (cond + [(connection-pool-closed? pool) + ;; Pool is closing; decrement total and discard connection + (connection-pool-total-set! pool + (fx- (connection-pool-total pool) 1)) + (mutex-release mtx) + ;; Attempt to close the connection if it has a close method + ;; (best-effort; we don't know the type here) + (void)] + [else + (connection-pool-idle-set! pool + (cons conn (connection-pool-idle pool))) + (condition-signal cv) + (mutex-release mtx)]))) + + (define (pool-close pool) + ;; Close the pool: mark as closed, clear idle connections. + ;; Does not forcibly close active connections (they will be + ;; discarded when released). + (let ([mtx (connection-pool-mutex pool)] + [cv (connection-pool-available-cv pool)]) + (mutex-acquire mtx) + (connection-pool-closed?-set! pool #t) + (let ([idle (connection-pool-idle pool)]) + (connection-pool-idle-set! pool '()) + (connection-pool-total-set! pool + (connection-pool-active pool)) + ;; Wake up any threads waiting in pool-acquire so they get + ;; the "pool is closed" error. + (condition-broadcast cv) + (mutex-release mtx) + ;; Return the list of idle connections that were discarded, + ;; so callers can close them if needed. + idle))) + + (define (pool-size pool) + ;; Total number of connections managed (idle + active). + (let ([mtx (connection-pool-mutex pool)]) + (mutex-acquire mtx) + (let ([n (connection-pool-total pool)]) + (mutex-release mtx) + n))) + + (define (pool-available pool) + ;; Number of idle connections available for immediate use. + (let ([mtx (connection-pool-mutex pool)]) + (mutex-acquire mtx) + (let ([n (length (connection-pool-idle pool))]) + (mutex-release mtx) + n))) + + (define (pool-stats pool) + ;; Return an alist of pool statistics. + (let ([mtx (connection-pool-mutex pool)]) + (mutex-acquire mtx) + (let ([total (connection-pool-total pool)] + [active (connection-pool-active pool)] + [idle (length (connection-pool-idle pool))] + [max (connection-pool-max-size pool)] + [closed (connection-pool-closed? pool)]) + (mutex-release mtx) + `((total . ,total) + (active . ,active) + (idle . ,idle) + (max . ,max) + (closed . ,closed))))) + + ;; ========== with-connection macro ========== + + (define-syntax with-connection + (syntax-rules () + [(_ (conn pool-expr) body ...) + (let* ([p pool-expr] + [conn (pool-acquire p)]) + (dynamic-wind + (lambda () (void)) + (lambda () body ...) + (lambda () (pool-release p conn))))])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/db/dbi.sls @@ -0,0 +1,188 @@ +#!chezscheme +;;; (std db dbi) — Generic database interface +;;; +;;; Abstract database interface with pluggable drivers. Drivers register +;;; themselves via dbi-driver-register! and provide vtable procedures for +;;; connection management, query execution, and transaction control. +;;; +;;; A connection wraps a driver-specific handle with a uniform API. +;;; Statements (from dbi-prepare) are also driver-specific handles wrapped +;;; in a dbi-statement record. + +(library (std db dbi) + (export + ;; Connection + dbi-connect dbi-close + ;; Query + dbi-query dbi-exec + ;; Prepared statements + dbi-prepare dbi-bind dbi-step dbi-columns + ;; Transactions + dbi-with-transaction + ;; Connection record + make-dbi-connection dbi-connection? + ;; Driver registration + dbi-driver-register! dbi-drivers) + + (import (chezscheme)) + + ;; ========== Driver registry ========== + + ;; Each driver is an alist of (symbol . procedure): + ;; connect : (connection-params ...) -> driver-handle + ;; close : (driver-handle) -> void + ;; query : (driver-handle sql params) -> list of vectors (rows) + ;; exec : (driver-handle sql params) -> integer (affected rows) + ;; prepare : (driver-handle sql) -> stmt-handle + ;; bind : (stmt-handle params) -> void + ;; step : (stmt-handle) -> #f | vector (row) + ;; columns : (stmt-handle) -> list of strings (column names) + ;; begin-tx : (driver-handle) -> void + ;; commit-tx : (driver-handle) -> void + ;; rollback-tx: (driver-handle) -> void + + (define *drivers* '()) ; alist of (name . vtable-alist) + + (define (dbi-driver-register! name vtable) + ;; Register a driver. NAME is a symbol, VTABLE is an alist of + ;; (symbol . procedure) pairs. + (unless (symbol? name) + (error 'dbi-driver-register! "driver name must be a symbol" name)) + (let ([required '(connect close query exec)]) + (for-each + (lambda (key) + (unless (assq key vtable) + (error 'dbi-driver-register! + (format "driver ~a missing required operation: ~a" name key) + name key))) + required)) + ;; Replace existing or add new + (set! *drivers* + (cons (cons name vtable) + (remp (lambda (entry) (eq? (car entry) name)) *drivers*)))) + + (define (dbi-drivers) + ;; Return list of registered driver names. + (map car *drivers*)) + + (define (lookup-driver name) + (let ([entry (assq name *drivers*)]) + (unless entry + (error 'dbi-connect "unknown driver" name)) + (cdr entry))) + + (define (driver-op vtable op-name) + ;; Look up an operation in a vtable; return #f if not found. + (let ([entry (assq op-name vtable)]) + (and entry (cdr entry)))) + + (define (driver-op! vtable op-name who) + ;; Look up an operation, error if not found. + (let ([proc (driver-op vtable op-name)]) + (unless proc + (error who (format "driver does not support ~a" op-name) op-name)) + proc)) + + ;; ========== Connection record ========== + + (define-record-type dbi-connection + (fields + driver-name ; symbol + vtable ; alist of driver procedures + handle ; driver-specific connection handle + (mutable open?)) ; #t while the connection is alive + (protocol + (lambda (new) + (lambda (driver-name vtable handle) + (new driver-name vtable handle #t))))) + + ;; ========== Statement record ========== + + (define-record-type dbi-statement + (fields + connection ; parent dbi-connection + handle)) ; driver-specific statement handle + + ;; ========== Helpers ========== + + (define (check-open conn who) + (unless (dbi-connection-open? conn) + (error who "connection is closed"))) + + ;; ========== Public API ========== + + (define (dbi-connect driver-name . connect-args) + ;; Connect to a database. DRIVER-NAME is a symbol naming a registered + ;; driver. Remaining arguments are passed to the driver's connect proc. + (let* ([vtable (lookup-driver driver-name)] + [connect-proc (driver-op! vtable 'connect 'dbi-connect)] + [handle (apply connect-proc connect-args)]) + (make-dbi-connection driver-name vtable handle))) + + (define (dbi-close conn) + ;; Close a database connection. Safe to call multiple times. + (when (dbi-connection-open? conn) + (let ([close-proc (driver-op! (dbi-connection-vtable conn) 'close 'dbi-close)]) + (close-proc (dbi-connection-handle conn)) + (dbi-connection-open?-set! conn #f)))) + + (define (dbi-query conn sql . params) + ;; Execute SQL and return a list of row vectors. + (check-open conn 'dbi-query) + (let ([query-proc (driver-op! (dbi-connection-vtable conn) 'query 'dbi-query)]) + (query-proc (dbi-connection-handle conn) sql params))) + + (define (dbi-exec conn sql . params) + ;; Execute SQL for side effects, return affected row count. + (check-open conn 'dbi-exec) + (let ([exec-proc (driver-op! (dbi-connection-vtable conn) 'exec 'dbi-exec)]) + (exec-proc (dbi-connection-handle conn) sql params))) + + (define (dbi-prepare conn sql) + ;; Prepare a SQL statement, return a dbi-statement. + (check-open conn 'dbi-prepare) + (let ([prepare-proc (driver-op! (dbi-connection-vtable conn) 'prepare 'dbi-prepare)]) + (make-dbi-statement conn (prepare-proc (dbi-connection-handle conn) sql)))) + + (define (dbi-bind stmt . params) + ;; Bind parameters to a prepared statement. + (let* ([conn (dbi-statement-connection stmt)] + [bind-proc (driver-op! (dbi-connection-vtable conn) 'bind 'dbi-bind)]) + (check-open conn 'dbi-bind) + (bind-proc (dbi-statement-handle stmt) params))) + + (define (dbi-step stmt) + ;; Step a prepared statement. Returns a row vector or #f when done. + (let* ([conn (dbi-statement-connection stmt)] + [step-proc (driver-op! (dbi-connection-vtable conn) 'step 'dbi-step)]) + (check-open conn 'dbi-step) + (step-proc (dbi-statement-handle stmt)))) + + (define (dbi-columns stmt) + ;; Return list of column name strings for a prepared statement. + (let* ([conn (dbi-statement-connection stmt)] + [columns-proc (driver-op! (dbi-connection-vtable conn) 'columns 'dbi-columns)]) + (check-open conn 'dbi-columns) + (columns-proc (dbi-statement-handle stmt)))) + + (define (dbi-with-transaction conn thunk) + ;; Run THUNK inside a transaction. Commits on normal return, + ;; rolls back on exception, then re-raises. + (check-open conn 'dbi-with-transaction) + (let* ([vtable (dbi-connection-vtable conn)] + [handle (dbi-connection-handle conn)] + [begin-proc (driver-op! vtable 'begin-tx 'dbi-with-transaction)] + [commit-proc (driver-op! vtable 'commit-tx 'dbi-with-transaction)] + [rollback-proc (driver-op! vtable 'rollback-tx 'dbi-with-transaction)]) + (begin-proc handle) + (guard (exn + [#t + ;; Attempt rollback, then re-raise + (guard (rb-exn [#t (void)]) + (rollback-proc handle)) + (raise exn)]) + (let ([result (thunk)]) + (commit-proc handle)