Round 11: Clojure parity polish — eight new phases
ober
62b41bcd51f655f7385368e9b9e6372c04d9c0dd
--- a/lib/std/clojure.sls +++ b/lib/std/clojure.sls @@ -2057,14 +2057,22 @@ ;; (map-indexed (lambda (i x) ...) coll) → list ;; (keep-indexed F coll) — drop entries where F returns #f. + (define (%coerce-to-seq coll) + (cond + [(list? coll) coll] + [(vector? coll) (vector->list coll)] + [(persistent-vector? coll) (persistent-vector->list coll)] + [(string? coll) (string->list coll)] + [else (error 'map-indexed "unsupported collection" coll)])) + (define (map-indexed f coll) - (let loop ([i 0] [xs coll] [acc '()]) + (let loop ([i 0] [xs (%coerce-to-seq coll)] [acc '()]) (cond [(null? xs) (reverse acc)] [else (loop (+ i 1) (cdr xs) (cons (f i (car xs)) acc))]))) (define (keep-indexed f coll) - (let loop ([i 0] [xs coll] [acc '()]) + (let loop ([i 0] [xs (%coerce-to-seq coll)] [acc '()]) (cond [(null? xs) (reverse acc)] [else @@ -2102,8 +2110,12 @@ ;; the `:>>` form is used). The trailing single expression is the ;; default; an absent default raises. + ;; The Clojure-native `:>>` literal is unreachable in default + ;; Jerboa reader mode (`:>>` reads as a Gerbil-style module path), + ;; so we additionally accept `=>` — already familiar from `cond`'s + ;; bind-arrow. Both literals are equivalent. (define-syntax condp - (syntax-rules (:>>) + (syntax-rules (:>> =>) [(_ pred expr default) default] [(_ pred expr test :>> handler more ...) @@ -2111,6 +2123,11 @@ (if %v (handler %v) (condp pred expr more ...)))] + [(_ pred expr test => handler more ...) + (let ([%v ((lambda (p e t) (p t e)) pred expr test)]) + (if %v + (handler %v) + (condp pred expr more ...)))] [(_ pred expr test result more ...) (if ((lambda (p e t) (p t e)) pred expr test) result new file mode 100644 --- /dev/null +++ b/lib/std/clojure/data.sls @@ -0,0 +1,212 @@ +#!chezscheme +;;; (std clojure data) — clojure.data compatibility +;;; +;;; Recursive comparison of two values returning a list of three +;;; elements `(only-in-a only-in-b in-both)`: +;;; +;;; only-in-a — what `a` has that `b` lacks (or where they differ) +;;; only-in-b — what `b` has that `a` lacks (or where they differ) +;;; in-both — what is identical in both, in the same shape +;;; +;;; Recognised containers: lists, vectors, persistent-map, +;;; persistent-set, persistent-vector, hash-table. Anything else +;;; is compared with `equal?` — equal scalars become +;;; `(#f #f a)`, unequal scalars become `(a b #f)`. +;;; +;;; (diff '(1 2 3) '(1 2 4)) => ((#f #f 3) (#f #f 4) (1 2 #f)) +;;; (diff (persistent-map :a 1 :b 2) (persistent-map :b 2 :c 3)) +;;; => (pmap{:a 1} pmap{:c 3} pmap{:b 2}) + +(library (std clojure data) + (export diff) + + (import (except (chezscheme) make-hash-table hash-table?) + (only (jerboa runtime) + make-hash-table hash-table? hash-keys hash-ref hash-put!) + (only (std pmap) + persistent-map? persistent-map make-persistent-map + persistent-map-set persistent-map-ref persistent-map-has? + persistent-map->list persistent-map-size) + (only (std pset) + persistent-set? persistent-set + persistent-set-add persistent-set-contains? + persistent-set->list persistent-set-size) + (only (std pvec) + persistent-vector? persistent-vector + persistent-vector->list persistent-vector-length)) + + ;; ---- helpers -------------------------------------------------- + + (define (empty-pmap) (persistent-map)) + (define (empty-pset) (persistent-set)) + + (define (pmap-empty? m) (zero? (persistent-map-size m))) + (define (pset-empty? s) (zero? (persistent-set-size s))) + + ;; If a result map/set is empty, return #f instead — clojure.data + ;; reports "no contribution" as nil, not as an empty container. + (define (pmap-or-false m) (if (pmap-empty? m) #f m)) + (define (pset-or-false s) (if (pset-empty? s) #f s)) + + ;; ---- map diff ------------------------------------------------- + + (define (diff-pmap a b) + ;; First pass: walk keys of a. For each key, either it's + ;; missing in b (goes to only-a), or it's in b — recurse on + ;; values and split the result across the three buckets. + (let-values ([(only-a only-b both) + (let loop ([pairs (persistent-map->list a)] + [oa (empty-pmap)] + [ob (empty-pmap)] + [bo (empty-pmap)]) + (cond + [(null? pairs) (values oa ob bo)] + [else + (let* ([kv (car pairs)] [k (car kv)] [va (cdr kv)]) + (cond + [(persistent-map-has? b k) + (let* ([vb (persistent-map-ref b k)] + [d (diff va vb)] + [da (car d)] [db (cadr d)] [bv (caddr d)]) + (loop (cdr pairs) + (if da (persistent-map-set oa k da) oa) + (if db (persistent-map-set ob k db) ob) + (if bv (persistent-map-set bo k bv) bo)))] + [else + (loop (cdr pairs) + (persistent-map-set oa k va) ob bo)]))]))]) + ;; Second pass: keys present in b but not in a → only-b. + (let loop2 ([pairs (persistent-map->list b)] [ob only-b]) + (cond + [(null? pairs) + (list (pmap-or-false only-a) + (pmap-or-false ob) + (pmap-or-false both))] + [else + (let* ([kv (car pairs)] [k (car kv)] [vb (cdr kv)]) + (loop2 (cdr pairs) + (if (persistent-map-has? a k) + ob + (persistent-map-set ob k vb))))])))) + + ;; ---- set diff ------------------------------------------------- + + (define (diff-pset a b) + (let ([only-a (empty-pset)] + [only-b (empty-pset)] + [both (empty-pset)]) + (for-each + (lambda (x) + (if (persistent-set-contains? b x) + (set! both (persistent-set-add both x)) + (set! only-a (persistent-set-add only-a x)))) + (persistent-set->list a)) + (for-each + (lambda (x) + (unless (persistent-set-contains? a x) + (set! only-b (persistent-set-add only-b x)))) + (persistent-set->list b)) + (list (pset-or-false only-a) + (pset-or-false only-b) + (pset-or-false both)))) + + ;; ---- sequential diff (lists, vectors, persistent-vectors) ---- + ;; + ;; clojure.data treats two seqs elementwise: at each index, recurse; + ;; trailing elements in the longer seq go to the corresponding + ;; only-in-X result. The output container shape mirrors the + ;; input (list-in → list-out, vector-in → vector-out, + ;; pvec-in → pvec-out). + + (define (seq-len kind seq) + (case kind + [(list) (length seq)] + [(vector) (vector-length seq)] + [(pvec) (persistent-vector-length seq)])) + + (define (seq-ref kind seq i) + (case kind + [(list) (list-ref seq i)] + [(vector) (vector-ref seq i)] + [(pvec) (list-ref (persistent-vector->list seq) i)])) + + (define (seq-build kind elements) + (case kind + [(list) elements] + [(vector) (list->vector elements)] + [(pvec) (apply persistent-vector elements)])) + + (define (all-false? lst) + (let loop ([l lst]) + (cond [(null? l) #t] + [(car l) #f] + [else (loop (cdr l))]))) + + (define (drop-trailing-falses lst) + ;; reverse, drop leading #f, reverse back + (let loop ([l (reverse lst)]) + (cond [(null? l) '()] + [(car l) (reverse l)] + [else (loop (cdr l))]))) + + (define (or-false? kind lst) + (and (not (null? lst)) (seq-build kind lst))) + + (define (diff-seq kind a b) + (let* ([la (seq-len kind a)] + [lb (seq-len kind b)] + [common (min la lb)]) + (let loop ([i 0] + [oa '()] [ob '()] [bo '()]) + (cond + [(< i common) + (let* ([va (seq-ref kind a i)] + [vb (seq-ref kind b i)] + [d (diff va vb)]) + (loop (+ i 1) + (cons (car d) oa) + (cons (cadr d) ob) + (cons (caddr d) bo)))] + [else + (let* ([oa* (let lp ([i common] [acc oa]) + (if (>= i la) acc + (lp (+ i 1) (cons (seq-ref kind a i) acc))))] + [ob* (let lp ([i common] [acc ob]) + (if (>= i lb) acc + (lp (+ i 1) (cons (seq-ref kind b i) acc))))] + [oa-list (reverse oa*)] + [ob-list (reverse ob*)] + [bo-list (drop-trailing-falses (reverse bo))]) + (list (if (all-false? oa-list) #f (or-false? kind oa-list)) + (if (all-false? ob-list) #f (or-false? kind ob-list)) + (or-false? kind bo-list)))])))) + + ;; ---- public diff ---------------------------------------------- + + (define (diff a b) + (cond + [(equal? a b) + (list #f #f a)] + [(and (persistent-map? a) (persistent-map? b)) + (diff-pmap a b)] + [(and (persistent-set? a) (persistent-set? b)) + (diff-pset a b)] + [(and (persistent-vector? a) (persistent-vector? b)) + (diff-seq 'pvec a b)] + [(and (vector? a) (vector? b)) + (diff-seq 'vector a b)] + [(and (list? a) (list? b)) + (diff-seq 'list a b)] + [(and (hash-table? a) (hash-table? b)) + ;; Convert to pmap for the comparison; result returned as pmaps. + (let ([ma (empty-pmap)] [mb (empty-pmap)]) + (for-each (lambda (k) (set! ma (persistent-map-set ma k (hash-ref a k)))) + (hash-keys a)) + (for-each (lambda (k) (set! mb (persistent-map-set mb k (hash-ref b k)))) + (hash-keys b)) + (diff-pmap ma mb))] + [else + ;; Disparate or unrecognised types: full a / full b / nothing. + (list a b #f)])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/clojure/zip.sls @@ -0,0 +1,329 @@ +#!chezscheme +;;; (std clojure zip) — clojure.zip compatibility +;;; +;;; A zipper is a functional pointer into a tree. It carries the +;;; "current" subtree along with enough context (path back to the +;;; root, and unvisited siblings on either side) to reconstruct the +;;; whole tree on demand. All movement and edits are pure: every +;;; operation returns a new zipper. +;;; +;;; A zipper is built by handing `zipper` three procedures plus the +;;; root tree: +;;; +;;; branch? (lambda (node) ...) ;; can node have children? +;;; children (lambda (node) ...) ;; → list of child nodes +;;; make (lambda (node kids) ...) ;; reassemble node from kids +;;; +;;; For convenience, three pre-baked zippers are provided: +;;; +;;; (seq-zip root) ;; lists; branch? = list? +;;; (vector-zip root) ;; vectors; branch? = vector? +;;; (xml-zip root) ;; SXML-style nodes (tag . children-list) +;;; +;;; Movement: up down left right +;;; Inspection: node branch? children +;;; Editing: replace edit insert-left insert-right +;;; insert-child append-child remove +;;; Termination: root end? next prev + +(library (std clojure zip) + (export + zipper seq-zip vector-zip xml-zip + zip? node branch? children make-node + up down left right + leftmost rightmost + lefts rights path + replace edit insert-left insert-right + insert-child append-child remove + root end? next prev) + + (import (except (chezscheme) remove)) + + ;; ---- record --------------------------------------------------- + ;; + ;; A zipper holds the current node and a "loc" — the contextual + ;; information needed to walk back to the root. The branch?, + ;; children, and make-node procedures travel with the zipper so + ;; that all operations stay polymorphic across container kinds. + + (define-record-type zip + (fields (immutable node) + (immutable loc) ;; #f at root, else (parent-zip ls rs) + (immutable branch?-p) + (immutable children-p) + (immutable make-p) + (immutable end?-flag)) + (sealed #t)) + + (define (node z) (zip-node z)) + + (define (branch? z) + ((zip-branch?-p z) (zip-node z))) + + (define (children z) + (cond + [(branch? z) ((zip-children-p z) (zip-node z))] + [else (error 'children "called on a leaf node" z)])) + + (define (make-node z n kids) + ((zip-make-p z) n kids)) + + ;; ---- constructors -------------------------------------------- + + (define (zipper branch?-p children-p make-p root) + (make-zip root #f branch?-p children-p make-p #f)) + + (define (seq-zip root) + (zipper list? values + (lambda (_node kids) kids) + root)) + + (define (vector-zip root) + (zipper vector? vector->list + (lambda (_node kids) (list->vector kids)) + root)) + + ;; SXML-style: a branch is a pair whose car is a tag (symbol or + ;; string) and whose cdr is the list of children. Leaves are + ;; everything else. + (define (xml-zip root) + (zipper (lambda (n) + (and (pair? n) + (or (symbol? (car n)) (string? (car n))))) + cdr + (lambda (n kids) (cons (car n) kids)) + root)) + + ;; ---- a "loc" carries: parent-zip + lefts (reversed) + rights ---- + + (define-record-type loc + (fields (immutable parent) ;; zip pointing at the parent node + (immutable ls) ;; siblings to the left, REVERSED + (immutable rs)) ;; siblings to the right + (sealed #t)) + + ;; ---- movement ------------------------------------------------- + + (define (down z) + (cond + [(not (branch? z)) #f] + [else + (let ([kids (children z)]) + (cond + [(null? kids) #f] + [else + (make-zip (car kids) + (make-loc z '() (cdr kids)) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f)]))])) + + (define (up z) + (let ([l (zip-loc z)]) + (cond + [(not l) #f] + [else + (let* ([p (loc-parent l)] + [kids (append (reverse (loc-ls l)) + (cons (zip-node z) (loc-rs l)))] + [new-p (make-node p (zip-node p) kids)]) + (make-zip new-p + (zip-loc p) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f))]))) + + (define (left z) + (let ([l (zip-loc z)]) + (cond + [(or (not l) (null? (loc-ls l))) #f] + [else + (make-zip (car (loc-ls l)) + (make-loc (loc-parent l) + (cdr (loc-ls l)) + (cons (zip-node z) (loc-rs l))) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f)]))) + + (define (right z) + (let ([l (zip-loc z)]) + (cond + [(or (not l) (null? (loc-rs l))) #f] + [else + (make-zip (car (loc-rs l)) + (make-loc (loc-parent l) + (cons (zip-node z) (loc-ls l)) + (cdr (loc-rs l))) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f)]))) + + (define (leftmost z) + (let lp ([z z]) + (let ([l (left z)]) + (if l (lp l) z)))) + + (define (rightmost z) + (let lp ([z z]) + (let ([r (right z)]) + (if r (lp r) z)))) + + (define (lefts z) + (cond + [(zip-loc z) => (lambda (l) (reverse (loc-ls l)))] + [else '()])) + + (define (rights z) + (cond + [(zip-loc z) => (lambda (l) (loc-rs l))] + [else '()])) + + ;; Walk to the root of a zipper, return the list of nodes from + ;; root → current. + (define (path z) + (let lp ([z z] [acc (list (zip-node z))]) + (let ([u (up z)]) + (if u (lp u (cons (zip-node u) acc)) acc)))) + + ;; ---- editing -------------------------------------------------- + + (define (replace z new-node) + (make-zip new-node + (zip-loc z) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f)) + + (define (edit z f . args) + (replace z (apply f (zip-node z) args))) + + (define (insert-left z x) + (let ([l (zip-loc z)]) + (cond + [(not l) (error 'insert-left "at root")] + [else + (make-zip (zip-node z) + (make-loc (loc-parent l) + (cons x (loc-ls l)) + (loc-rs l)) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f)]))) + + (define (insert-right z x) + (let ([l (zip-loc z)]) + (cond + [(not l) (error 'insert-right "at root")] + [else + (make-zip (zip-node z) + (make-loc (loc-parent l) + (loc-ls l) + (cons x (loc-rs l))) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f)]))) + + (define (insert-child z x) + (cond + [(not (branch? z)) + (error 'insert-child "leaf has no children" z)] + [else + (let* ([kids (children z)] + [new (make-node z (zip-node z) (cons x kids))]) + (replace z new))])) + + (define (append-child z x) + (cond + [(not (branch? z)) + (error 'append-child "leaf has no children" z)] + [else + (let* ([kids (children z)] + [new (make-node z (zip-node z) (append kids (list x)))]) + (replace z new))])) + + ;; Remove the current node, returning the zipper at the location + ;; of the previous sibling (or parent if there is no left sibling). + (define (remove z) + (let ([l (zip-loc z)]) + (cond + [(not l) (error 'remove "at root")] + [(not (null? (loc-ls l))) + (make-zip (car (loc-ls l)) + (make-loc (loc-parent l) + (cdr (loc-ls l)) + (loc-rs l)) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f)] + [else + ;; No left sibling: rebuild parent with the right siblings + ;; only and return that as the new current. + (let* ([p (loc-parent l)] + [new-p (make-node p (zip-node p) (loc-rs l))]) + (make-zip new-p + (zip-loc p) + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #f))]))) + + ;; ---- termination --------------------------------------------- + + (define (root z) + (let lp ([z z]) + (let ([u (up z)]) + (if u (lp u) (zip-node z))))) + + (define (end? z) (zip-end?-flag z)) + + ;; Depth-first, in-order: down, then right, then up+right, ... . + (define (next z) + (cond + [(end? z) z] + [(branch? z) + (let ([d (down z)]) + (or d (next-after z)))] + [else (next-after z)])) + + (define (next-after z) + (let lp ([z z]) + (cond + [(right z) => (lambda (r) r)] + [else + (let ([u (up z)]) + (cond + [(not u) + ;; Done — flag terminal zipper with end?-flag = #t. + (make-zip (zip-node z) #f + (zip-branch?-p z) + (zip-children-p z) + (zip-make-p z) + #t)] + [else (lp u)]))]))) + + ;; Reverse traversal: cousin of `next`. + (define (prev z) + (cond + [(left z) + => (lambda (l) + ;; Descend rightmost branches until a leaf is reached. + (let lp ([z l]) + (cond + [(branch? z) + (let ([d (down z)]) + (cond + [d (lp (rightmost d))] + [else z]))] + [else z])))] + [else (up z)])) + +) ;; end library --- a/lib/std/net/fiber-ws.sls +++ b/lib/std/net/fiber-ws.sls @@ -5,31 +5,37 @@ ;;; fiber-aware TCP I/O. One fiber per WebSocket connection. ;;; ;;; API: -;;; (make-fiber-ws fd poller) — wrap an already-upgraded fd -;;; (fiber-ws? obj) — predicate -;;; (fiber-ws-open? ws) — is connection open? -;;; (fiber-ws-recv ws) — receive message (parks fiber) -;;; returns string, bytevector, or #f (close) -;;; (fiber-ws-send ws msg) — send text message -;;; (fiber-ws-send-binary ws bv) — send binary message -;;; (fiber-ws-close ws) — send close frame and shut down -;;; (fiber-ws-ping ws) — send ping (pong auto-handled) +;;; (make-fiber-ws fd poller open?) — wrap an upgraded fd (server) +;;; (fiber-ws? obj) — predicate +;;; (fiber-ws-open? ws) — is connection open? +;;; (fiber-ws-client? ws) — is this a client connection? +;;; (fiber-ws-recv ws) — receive message (parks fiber) +;;; returns string, bytevector, or #f +;;; (fiber-ws-send ws msg) — send text message +;;; (fiber-ws-send-binary ws bv) — send binary message +;;; (fiber-ws-close ws) — send close frame and shut down +;;; (fiber-ws-ping ws) — send ping (pong auto-handled) ;;; -;;; (fiber-ws-upgrade req fd poller) — perform WebSocket handshake -;;; req-headers: alist from HTTP request -;;; returns fiber-ws or #f +;;; (fiber-ws-upgrade req fd poller) — server-side handshake +;;; (fiber-ws-connect host port path poller) — client-side handshake +;;; +;;; Per RFC 6455, client→server frames MUST be masked, server→client +;;; frames MUST NOT be. fiber-ws tracks the role and does the right +;;; thing automatically on outbound frames. (library (std net fiber-ws) (export make-fiber-ws fiber-ws? fiber-ws-open? + fiber-ws-client? fiber-ws-recv fiber-ws-send fiber-ws-send-binary fiber-ws-close fiber-ws-ping - fiber-ws-upgrade) + fiber-ws-upgrade + fiber-ws-connect) (import (chezscheme) (std fiber) @@ -42,7 +48,13 @@ (fields (immutable fd) (immutable poller) + (immutable client?) (mutable open?)) + (protocol + (lambda (new) + (case-lambda + [(fd poller open?) (new fd poller #f open?)] + [(fd poller client? open?) (new fd poller client? open?)]))) (sealed #t)) ;; ========== Low-level I/O ========== @@ -61,9 +73,7 @@ (loop (+ got rc))])))))) ;; Read a single WebSocket frame from the fd. - ;; Returns a ws-frame record or #f on connection close. (define (read-ws-frame fd poller) - ;; Read header: first 2 bytes (let ([hdr (make-bytevector 2)]) (let ([n (read-exact fd hdr 2 poller)]) (if (< n 2) #f @@ -73,7 +83,6 @@ [opcode (bitwise-and b0 #x0F)] [masked? (not (zero? (bitwise-and b1 #x80)))] [len7 (bitwise-and b1 #x7F)]) - ;; Extended length (let ([payload-len (cond [(= len7 126) @@ -85,39 +94,55 @@ [(= len7 127) (let ([ext (make-bytevector 8)]) (when (< (read-exact fd ext 8 poller) 8) (void)) - ;; Use lower 32 bits (bitwise-ior (bitwise-arithmetic-shift-left (bytevector-u8-ref ext 4) 24) (bitwise-arithmetic-shift-left (bytevector-u8-ref ext 5) 16) (bitwise-arithmetic-shift-left (bytevector-u8-ref ext 6) 8) (bytevector-u8-ref ext 7)))] [else len7])]) - ;; Masking key (let ([mask-key (if masked? (let ([mk (make-bytevector 4)]) (read-exact fd mk 4 poller) mk) #f)]) - ;; Payload (let ([payload (make-bytevector payload-len)]) (when (> payload-len 0) (read-exact fd payload payload-len poller)) - ;; Unmask if needed (let ([data (if (and masked? mask-key) (ws-unmask-payload payload mask-key) payload)]) (make-ws-frame fin? masked? opcode data mask-key)))))))))) - ;; Write a ws-frame over the fd. - (define (write-ws-frame fd poller frame) - (let ([encoded (ws-frame-encode frame)]) - (fiber-tcp-write fd encoded (bytevector-length encoded) poller))) + ;; Generate a 4-byte mask key (required for client-side frames). + (define (random-mask-key) + (let ([mk (make-bytevector 4)]) + (do ([i 0 (+ i 1)]) + ((= i 4) mk) + (bytevector-u8-set! mk i (random 256))))) + + ;; If the connection is client-side, rebuild the frame with masking + ;; turned on and a fresh random key. + (define (maybe-mask-frame ws frame) + (cond + [(fiber-ws-client? ws) + (make-ws-frame + (ws-frame-fin? frame) + #t + (ws-frame-opcode frame) + (ws-frame-payload frame) + (random-mask-key))] + [else frame])) + + ;; Write a ws-frame over the fd, masking if this is a client connection. + (define (write-ws-frame-via ws frame) + (let* ([f (maybe-mask-frame ws frame)] + [encoded (ws-frame-encode f)]) + (fiber-tcp-write (fiber-ws-fd ws) encoded + (bytevector-length encoded) + (fiber-ws-poller ws)))) - ;; ========== WebSocket upgrade handshake ========== + ;; ========== Server-side handshake ========== - ;; Perform the server-side WebSocket handshake. - ;; req-headers: alist of (lowercase-name . value) from the HTTP request - ;; Returns: fiber-ws record, or #f on failure (define (fiber-ws-upgrade req-headers fd poller) (let ([ws-key (cond [(assoc "sec-websocket-key" req-headers) => cdr] [else #f])]) @@ -132,12 +157,126 @@ "\r\n")] [resp-bv (string->bytevector resp-str (make-transcoder (utf-8-codec)))]) (fiber-tcp-write fd resp-bv (bytevector-length resp-bv) poller) - (make-fiber-ws fd poller #t))))) + (make-fiber-ws fd poller #f #t))))) + + ;; ========== Client-side handshake ========== + + ;; Read one CRLF-terminated line from fd. Returns the line WITHOUT + ;; the trailing \r\n, or #f on EOF/short read. + (define (read-http-line fd poller) + (define buf (make-bytevector 4096)) + (define one (make-bytevector 1)) + (let loop ([i 0]) + (cond + [(>= i 4096) (error 'fiber-ws-connect "HTTP line too long")] + [else + (let ([rc (fiber-tcp-read fd one 1 poller)]) + (cond + [(<= rc 0) #f] + [else + (let ([b (bytevector-u8-ref one 0)]) + (bytevector-u8-set! buf i b) + (cond + [(and (>= i 1) + (= b #x0a) + (= (bytevector-u8-ref buf (- i 1)) #x0d)) + (let ([line-bv (make-bytevector (- i 1))]) + (bytevector-copy! buf 0 line-bv 0 (- i 1)) + (utf8->string line-bv))] + [else (loop (+ i 1))]))]))]))) + + ;; Lowercase ASCII (good enough for HTTP header names). + (define (ascii-downcase s) + (let* ([n (string-length s)] [out (make-string n)]) + (do ([i 0 (+ i 1)]) + ((= i n) out) + (let ([c (string-ref s i)]) + (string-set! out i + (if (and (char>=? c #\A) (char<=? c #\Z)) + (integer->char (+ (char->integer c) 32)) + c)))))) + + ;; Read HTTP status line + headers until the blank line. + ;; Returns (values status-int headers-alist) where headers have + ;; lowercase keys. + (define (read-http-response fd poller) + (let ([status-line (read-http-line fd poller)]) + (unless status-line + (error 'fiber-ws-connect "no HTTP response")) + (let* ([sp (cond [(string-index status-line #\space) => values] + [else (error 'fiber-ws-connect + "malformed status line" status-line)])] + [rest (substring status-line (+ sp 1) (string-length status-line))] + [sp2 (cond [(string-index rest #\space) => values] + [else (string-length rest)])] + [code-str (substring rest 0 sp2)] + [code (or (string->number code-str) + (error 'fiber-ws-connect "bad status code" code-str))]) + (let loop ([hdrs '()]) + (let ([line (read-http-line fd poller)]) + (cond + [(or (not line) (string=? line "")) + (values code (reverse hdrs))] + [else + (let ([colon (string-index line #\:)]) + (cond + [(not colon) (loop hdrs)] + [else + (let* ([k (ascii-downcase (substring line 0 colon))] + [v0 (substring line (+ colon 1) (string-length line))] + ;; trim leading spaces + [v (let lp ([i 0]) + (cond + [(>= i (string-length v0)) ""] + [(char=? (string-ref v0 i) #\space) + (lp (+ i 1))] + [else (substring v0 i (string-length v0))]))]) + (loop (cons (cons k v) hdrs)))]))])))))) + + ;; Find first occurrence of char in string; return index or #f. + (define (string-index s c) + (let ([n (string-length s)]) + (let loop ([i 0]) + (cond + [(>= i n) #f] + [(char=? (string-ref s i) c) i] + [else (loop (+ i 1))])))) + + ;; Open a WebSocket client connection. + ;; host — server hostname or IP + ;; port — server port + ;; path — request path (e.g. "/socket") + ;; poller — fiber I/O poller + ;; Returns a fiber-ws or raises on handshake failure. + (define (fiber-ws-connect host port path poller) + (let ([fd (fiber-tcp-connect host port poller)]) + (guard (exn [#t (fiber-tcp-close fd) (raise exn)]) + (let* ([key (ws-handshake-key)] + [req (string-append + "GET " path " HTTP/1.1\r\n" + "Host: " host ":" + (number->string port) "\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: " key "\r\n" + "Sec-WebSocket-Version: 13\r\n" + "\r\n")] + [req-bv (string->bytevector req (make-transcoder (utf-8-codec)))]) + (fiber-tcp-write fd req-bv (bytevector-length req-bv) poller) + (let-values ([(status headers) (read-http-response fd poller)]) + (unless (= status 101) + (error 'fiber-ws-connect "server refused upgrade" status)) + (let ([accept (cond + [(assoc "sec-websocket-accept" headers) => cdr] + [else (error 'fiber-ws-connect + "missing Sec-WebSocket-Accept")])]) + (unless (ws-handshake-valid? key accept) + (error 'fiber-ws-connect + "Sec-WebSocket-Accept mismatch" accept)) + (make-fiber-ws fd poller #t #t))))))) ;; ========== Public API ========== - ;; Receive a message. Parks the fiber until a frame arrives. - ;; Returns: string (text), bytevector (binary), or #f (close/error). (define (fiber-ws-recv ws) (unless (fiber-ws-open? ws) (error 'fiber-ws-recv "WebSocket is closed")) @@ -151,50 +290,38 @@ (bytevector->string payload (make-transcoder (utf-8-codec)))] [(= opcode ws-opcode-binary) payload] [(= opcode ws-opcode-close) - ;; Send close back (guard (exn [#t (void)]) - (write-ws-frame (fiber-ws-fd ws) (fiber-ws-poller ws) (ws-close-frame))) + (write-ws-frame-via ws (ws-close-frame))) (fiber-ws-open?-set! ws #f) #f] [(= opcode ws-opcode-ping) - ;; Auto-pong - (write-ws-frame (fiber-ws-fd ws) (fiber-ws-poller ws) - (ws-pong-frame payload)) + (write-ws-frame-via ws (ws-pong-frame payload)) (fiber-ws-recv ws)] [(= opcode ws-opcode-pong) - ;; Ignore, keep receiving (fiber-ws-recv ws)] [else - ;; Unknown opcode (fiber-ws-open?-set! ws #f) #f]))))) - ;; Send a text message. (define (fiber-ws-send ws msg) (unless (fiber-ws-open? ws) (error 'fiber-ws-send "WebSocket is closed")) (let ([payload (string->bytevector msg (make-transcoder (utf-8-codec)))]) - (write-ws-frame (fiber-ws-fd ws) (fiber-ws-poller ws) - (ws-text-frame payload)))) + (write-ws-frame-via ws (ws-text-frame payload)))) - ;; Send a binary message. (define (fiber-ws-send-binary ws bv) (unless (fiber-ws-open? ws) (error 'fiber-ws-send-binary "WebSocket is closed")) - (write-ws-frame (fiber-ws-fd ws) (fiber-ws-poller ws) - (ws-binary-frame bv))) + (write-ws-frame-via ws (ws-binary-frame bv))) - ;; Send a ping frame. (define (fiber-ws-ping ws) (when (fiber-ws-open? ws) - (write-ws-frame (fiber-ws-fd ws) (fiber-ws-poller ws) - (ws-ping-frame (make-bytevector 0))))) + (write-ws-frame-via ws (ws-ping-frame (make-bytevector 0))))) - ;; Close the WebSocket gracefully. (define (fiber-ws-close ws) (when (fiber-ws-open? ws) (guard (exn [#t (void)]) - (write-ws-frame (fiber-ws-fd ws) (fiber-ws-poller ws) (ws-close-frame))) + (write-ws-frame-via ws (ws-close-frame))) (fiber-ws-open?-set! ws #f) (fiber-tcp-close (fiber-ws-fd ws)))) --- a/lib/std/spec.sls +++ b/lib/std/spec.sls @@ -37,8 +37,8 @@ s-defn ;; Instrumentation (Round 5 §36) s-instrument s-unstrument s-instrumented? - ;; Generation (basic) - s-exercise) + ;; Generation (basic + composite) + s-exercise s-gen s-sample) (import (chezscheme)) @@ -602,6 +602,155 @@ (find-generator spec (cdr generators)))] [else #f])) + ;; ---- composite generation (s-gen / s-sample) ----------------- + ;; + ;; (s-gen spec) returns a thunk that, when called, produces a + ;; value conforming to `spec`. Composite specs (s-and, s-or, + ;; s-tuple, s-coll-of, s-map-of, s-nilable, s-enum, s-keys) are + ;; handled by recursing into their components. Bare predicates + ;; consult a fixed table of built-in generators. + ;; + ;; (s-sample spec) → 10 samples + ;; (s-sample spec n) → n samples + ;; + ;; Property-style usage: + ;; + ;; (for-each + ;; (lambda (v) + ;; (assert (= (string-length (str v)) + ;; (string-length (str v))))) + ;; (s-sample (s-or :s string? :i integer?) 100)) + + (define %builtin-generators + (list + (cons integer? (lambda () (- (random 200) 100))) + (cons number? (lambda () (* (random 1000) 0.01))) + (cons real? (lambda () (* (random 1000) 0.01))) + (cons string? (lambda () (list-ref '("foo" "bar" "baz" "hello" "world" "" "x") + (random 7)))) + (cons symbol? (lambda () (list-ref '(a b c x y z) (random 6)))) + (cons boolean? (lambda () (= (random 2) 0))) + (cons positive? (lambda () (+ 1 (random 100)))) + (cons negative? (lambda () (- (- 1 (random 100))))) + (cons zero? (lambda () 0)) + (cons char? (lambda () (integer->char (+ 65 (random 26))))) + (cons null? (lambda () '())) + (cons pair? (lambda () (cons (random 100) (random 100)))))) + + (define (%pred-gen pred) + (cond + [(assq pred %builtin-generators) => cdr] + [else + (lambda () + ;; Last-ditch: try a few random scalars and return one; + ;; the caller's accept/reject loop will discard mismatches. + (case (random 4) + [(0) (random 100)] + [(1) (* (random 100) 0.5)] + [(2) (list-ref '(a b "s" #t #f) (random 5))] + [else 0]))]))