Phase 3b complete: Advanced Networking (5 libraries, 129 tests passing)
ober
634c6d58aba44327b641828f1ac8217bfae3f398
new file mode 100644 --- /dev/null +++ b/lib/std/net/dns.sls @@ -0,0 +1,268 @@ +#!chezscheme +;;; (std net dns) -- DNS message format (RFC 1035) +;;; +;;; Pure functions for encoding/decoding DNS wire-format messages. +;;; No live network connections. + +(library (std net dns) + (export + ;; RR type constants + dns-rr-type-a dns-rr-type-aaaa dns-rr-type-cname + dns-rr-type-mx dns-rr-type-txt dns-rr-type-ns + ;; Query construction + dns-make-query dns-encode-query + ;; Name encoding/decoding + dns-encode-name dns-decode-name + ;; Response decoding + dns-decode-response + ;; Message accessors + dns-transaction-id dns-response? dns-questions dns-answers + ;; Question record + dns-question + ;; Answer record and accessors + dns-answer dns-answer-name dns-answer-type dns-answer-ttl dns-answer-data) + + (import (chezscheme)) + + ;;; ========== RR type constants ========== + (define dns-rr-type-a 1) + (define dns-rr-type-ns 2) + (define dns-rr-type-cname 5) + (define dns-rr-type-mx 15) + (define dns-rr-type-txt 16) + (define dns-rr-type-aaaa 28) + + ;;; ========== Internal records ========== + (define-record-type dns-question-rec + (fields name type class)) + + (define-record-type dns-answer-rec + (fields name type class ttl data)) + + (define-record-type dns-message-rec + (fields id flags questions answers)) + + ;; Public constructors + (define (dns-question name type class) + (make-dns-question-rec name type class)) + + (define (dns-answer name type ttl data) + (make-dns-answer-rec name type 1 ttl data)) + + (define (dns-answer-name a) (dns-answer-rec-name a)) + (define (dns-answer-type a) (dns-answer-rec-type a)) + (define (dns-answer-ttl a) (dns-answer-rec-ttl a)) + (define (dns-answer-data a) (dns-answer-rec-data a)) + + (define (dns-transaction-id msg) (dns-message-rec-id msg)) + (define (dns-response? msg) (not (zero? (bitwise-and (dns-message-rec-flags msg) #x8000)))) + (define (dns-questions msg) (dns-message-rec-questions msg)) + (define (dns-answers msg) (dns-message-rec-answers msg)) + + ;;; ========== Name encoding ========== + ;; Encode a domain name string to DNS label format. + ;; "www.example.com" -> #u8(3 119 119 119 7 101 120 ...) + (define (dns-encode-name name) + (let* ([labels (string-split name #\.)] + [parts (map (lambda (label) + (let* ([bstr (string->utf8 label)] + [len (bytevector-length bstr)] + [out (make-bytevector (+ 1 len))]) + (bytevector-u8-set! out 0 len) + (bytevector-copy! bstr 0 out 1 len) + out)) + labels)] + ;; total = sum of (1 + len) for each label, + 1 for null terminator + [total (+ (apply + (map bytevector-length parts)) 1)] + [result (make-bytevector total)] + [pos 0]) + (for-each + (lambda (part) + (let ([plen (bytevector-length part)]) + (bytevector-copy! part 0 result pos plen) + (set! pos (+ pos plen)))) + parts) + ;; Null terminator + (bytevector-u8-set! result pos 0) + result)) + + ;; Helper: split string by delimiter character + (define (string-split str delim) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length str)) + (reverse (cons (substring str start i) acc))] + [(char=? (string-ref str i) delim) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))] + [else + (loop (+ i 1) start acc)]))) + + ;;; ========== Name decoding ========== + ;; Decode DNS label-encoded name from bytevector at offset. + ;; Returns (name-string . new-offset). + ;; Handles compression pointers (0xC0 prefix). + (define (dns-decode-name bv offset) + (let loop ([pos offset] [labels '()] [jumped? #f] [end-pos -1]) + (let ([b (bytevector-u8-ref bv pos)]) + (cond + ;; Null label: end of name + [(= b 0) + (let ([final-pos (if jumped? end-pos (+ pos 1))]) + (cons (string-join (reverse labels) ".") final-pos))] + ;; Compression pointer: 11xxxxxx + [(= (bitwise-and b #xC0) #xC0) + (let* ([ptr (bitwise-ior + (bitwise-arithmetic-shift-left (bitwise-and b #x3F) 8) + (bytevector-u8-ref bv (+ pos 1)))] + [new-end (if jumped? end-pos (+ pos 2))]) + (loop ptr labels #t new-end))] + ;; Regular label + [else + (let* ([label-len b] + [label-str (utf8->string + (subbytevector bv (+ pos 1) (+ pos 1 label-len)))]) + (loop (+ pos 1 label-len) (cons label-str labels) jumped? end-pos))])))) + + ;; Helper: extract sub-bytevector + (define (subbytevector bv start end) + (let* ([len (- end start)] + [out (make-bytevector len)]) + (bytevector-copy! bv start out 0 len) + out)) + + ;; Helper: join strings with separator + (define (string-join strs sep) + (if (null? strs) + "" + (let loop ([rest (cdr strs)] [acc (car strs)]) + (if (null? rest) + acc + (loop (cdr rest) (string-append acc sep (car rest))))))) + + ;;; ========== Query construction ========== + (define (dns-make-query id name type) + (make-dns-message-rec id #x0100 ; QR=0, RD=1 + (list (make-dns-question-rec name type 1)) + '())) + + ;;; ========== Query encoding ========== + ;; DNS message header (12 bytes): + ;; ID(2) FLAGS(2) QDCOUNT(2) ANCOUNT(2) NSCOUNT(2) ARCOUNT(2) + (define (dns-encode-query msg) + (let* ([id (dns-message-rec-id msg)] + [flags (dns-message-rec-flags msg)] + [questions (dns-message-rec-questions msg)] + ;; Encode each question + [q-parts (map (lambda (q) + (let* ([name-bv (dns-encode-name (dns-question-rec-name q))] + [type (dns-question-rec-type q)] + [class (dns-question-rec-class q)] + [qlen (+ (bytevector-length name-bv) 4)] + [qbv (make-bytevector qlen)]) + (bytevector-copy! name-bv 0 qbv 0 (bytevector-length name-bv)) + (let ([off (bytevector-length name-bv)]) + (bytevector-u8-set! qbv off (bitwise-arithmetic-shift-right type 8)) + (bytevector-u8-set! qbv (+ off 1) (bitwise-and type #xFF)) + (bytevector-u8-set! qbv (+ off 2) (bitwise-arithmetic-shift-right class 8)) + (bytevector-u8-set! qbv (+ off 3) (bitwise-and class #xFF))) + qbv)) + questions)] + [q-total (apply + (map bytevector-length q-parts))] + [total (+ 12 q-total)] + [bv (make-bytevector total 0)]) + ;; Header + (bytevector-u8-set! bv 0 (bitwise-arithmetic-shift-right id 8)) + (bytevector-u8-set! bv 1 (bitwise-and id #xFF)) + (bytevector-u8-set! bv 2 (bitwise-arithmetic-shift-right flags 8)) + (bytevector-u8-set! bv 3 (bitwise-and flags #xFF)) + ;; QDCOUNT + (bytevector-u8-set! bv 4 0) + (bytevector-u8-set! bv 5 (length questions)) + ;; ANCOUNT, NSCOUNT, ARCOUNT = 0 + ;; Write question sections + (let loop ([parts q-parts] [pos 12]) + (unless (null? parts) + (let* ([p (car parts)] + [len (bytevector-length p)]) + (bytevector-copy! p 0 bv pos len) + (loop (cdr parts) (+ pos len))))) + bv)) + + ;;; ========== Response decoding ========== + (define (dns-decode-response bv) + (let* ([id (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 0) 8) + (bytevector-u8-ref bv 1))] + [flags (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 2) 8) + (bytevector-u8-ref bv 3))] + [qdcount (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 4) 8) + (bytevector-u8-ref bv 5))] + [ancount (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 6) 8) + (bytevector-u8-ref bv 7))] + [pos 12]) + ;; Skip questions + (let loop-q ([i 0] [pos pos]) + (if (= i qdcount) + ;; Decode answers + (let loop-a ([j 0] [pos pos] [answers '()]) + (if (= j ancount) + (make-dns-message-rec id flags '() (reverse answers)) + (let* ([name-r (dns-decode-name bv pos)] + [name (car name-r)] + [pos (cdr name-r)] + [type (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv pos) 8) + (bytevector-u8-ref bv (+ pos 1)))] + [_class (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 2)) 8) + (bytevector-u8-ref bv (+ pos 3)))] + [ttl (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 4)) 24) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 5)) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 6)) 8) + (bytevector-u8-ref bv (+ pos 7)))] + [rdlen (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ pos 8)) 8) + (bytevector-u8-ref bv (+ pos 9)))] + [rdstart (+ pos 10)] + [rdata (subbytevector bv rdstart (+ rdstart rdlen))] + [data (cond + ;; A record: 4-byte IPv4 + [(= type dns-rr-type-a) + (string-append + (number->string (bytevector-u8-ref rdata 0)) "." + (number->string (bytevector-u8-ref rdata 1)) "." + (number->string (bytevector-u8-ref rdata 2)) "." + (number->string (bytevector-u8-ref rdata 3)))] + ;; AAAA record: 16-byte IPv6 + [(= type dns-rr-type-aaaa) + (let loop-v6 ([i 0] [parts '()]) + (if (= i 8) + (string-join (reverse parts) ":") + (let ([word (bitwise-ior + (bitwise-arithmetic-shift-left + (bytevector-u8-ref rdata (* i 2)) 8) + (bytevector-u8-ref rdata (+ (* i 2) 1)))]) + (loop-v6 (+ i 1) + (cons (number->string word 16) parts)))))] + ;; CNAME: decode name + [(= type dns-rr-type-cname) + (car (dns-decode-name bv rdstart))] + ;; TXT: first byte is length, rest is text + [(= type dns-rr-type-txt) + (let ([tlen (bytevector-u8-ref rdata 0)]) + (utf8->string (subbytevector rdata 1 (+ 1 tlen))))] + ;; Default: raw bytevector + [else rdata])]) + (loop-a (+ j 1) + (+ rdstart rdlen) + (cons (make-dns-answer-rec name type 1 ttl data) answers))))) + ;; Skip question: decode name, skip 4 bytes (type + class) + (let* ([name-r (dns-decode-name bv pos)] + [new-pos (+ (cdr name-r) 4)]) + (loop-q (+ i 1) new-pos)))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/http2.sls @@ -0,0 +1,382 @@ +#!chezscheme +;;; (std net http2) -- HTTP/2 framing and HPACK (simplified) +;;; +;;; HTTP/2 frame format (RFC 7540): +;;; 3 bytes length, 1 byte type, 1 byte flags, 4 bytes stream-id (31-bit), payload +;;; +;;; HPACK (RFC 7541): +;;; Simplified static-table encode/decode for common headers. + +(library (std net http2) + (export + ;; Frame type constants + http2-frame-type-data http2-frame-type-headers http2-frame-type-settings + http2-frame-type-ping http2-frame-type-goaway http2-frame-type-rst-stream + http2-frame-type-window-update http2-frame-type-priority + http2-frame-type-push-promise http2-frame-type-continuation + ;; Frame record accessors + http2-frame-type http2-frame-flags http2-frame-stream-id http2-frame-payload + ;; Frame encode/decode + http2-frame-encode http2-frame-decode + ;; Frame constructors + make-http2-data-frame make-http2-headers-frame make-http2-settings-frame + make-http2-ping-frame make-http2-goaway-frame make-http2-rst-stream-frame + make-http2-window-update-frame + ;; HPACK + make-hpack-context hpack-context? hpack-encode hpack-decode) + + (import (chezscheme)) + + ;;; ========== Frame type constants ========== + (define http2-frame-type-data #x0) + (define http2-frame-type-headers #x1) + (define http2-frame-type-priority #x2) + (define http2-frame-type-rst-stream #x3) + (define http2-frame-type-settings #x4) + (define http2-frame-type-push-promise #x5) + (define http2-frame-type-ping #x6) + (define http2-frame-type-goaway #x7) + (define http2-frame-type-window-update #x8) + (define http2-frame-type-continuation #x9) + + ;;; ========== Frame record ========== + (define-record-type http2-frame-rec + (fields type flags stream-id payload)) + + (define (http2-frame-type f) (http2-frame-rec-type f)) + (define (http2-frame-flags f) (http2-frame-rec-flags f)) + (define (http2-frame-stream-id f) (http2-frame-rec-stream-id f)) + (define (http2-frame-payload f) (http2-frame-rec-payload f)) + + ;;; ========== Frame encoding ========== + ;; Wire: [length:3][type:1][flags:1][stream-id:4][payload:N] + ;; stream-id is 31-bit (top bit reserved, always 0) + (define (http2-frame-encode frame) + (let* ([type (http2-frame-rec-type frame)] + [flags (http2-frame-rec-flags frame)] + [stream-id (http2-frame-rec-stream-id frame)] + [payload (http2-frame-rec-payload frame)] + [plen (bytevector-length payload)] + [total (+ 9 plen)] + [bv (make-bytevector total 0)]) + ;; 3-byte length + (bytevector-u8-set! bv 0 (bitwise-and (bitwise-arithmetic-shift-right plen 16) #xFF)) + (bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right plen 8) #xFF)) + (bytevector-u8-set! bv 2 (bitwise-and plen #xFF)) + ;; type, flags + (bytevector-u8-set! bv 3 type) + (bytevector-u8-set! bv 4 flags) + ;; 4-byte stream id (31-bit, big-endian) + (bytevector-u8-set! bv 5 (bitwise-and (bitwise-arithmetic-shift-right stream-id 24) #x7F)) + (bytevector-u8-set! bv 6 (bitwise-and (bitwise-arithmetic-shift-right stream-id 16) #xFF)) + (bytevector-u8-set! bv 7 (bitwise-and (bitwise-arithmetic-shift-right stream-id 8) #xFF)) + (bytevector-u8-set! bv 8 (bitwise-and stream-id #xFF)) + ;; payload + (bytevector-copy! payload 0 bv 9 plen) + bv)) + + ;;; ========== Frame decoding ========== + (define (http2-frame-decode bv) + (let* ([plen (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 0) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 1) 8) + (bytevector-u8-ref bv 2))] + [type (bytevector-u8-ref bv 3)] + [flags (bytevector-u8-ref bv 4)] + [sid (bitwise-ior + (bitwise-arithmetic-shift-left + (bitwise-and (bytevector-u8-ref bv 5) #x7F) 24) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 6) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv 7) 8) + (bytevector-u8-ref bv 8))] + [payload (let ([p (make-bytevector plen)]) + (bytevector-copy! bv 9 p 0 plen) + p)]) + (make-http2-frame-rec type flags sid payload))) + + ;;; ========== Frame constructors ========== + (define (make-http2-data-frame stream-id payload . flags) + (make-http2-frame-rec http2-frame-type-data + (if (null? flags) 0 (car flags)) + stream-id payload)) + + (define (make-http2-headers-frame stream-id payload . flags) + (make-http2-frame-rec http2-frame-type-headers + (if (null? flags) 4 (car flags)) ; END_HEADERS=0x4 + stream-id payload)) + + (define (make-http2-settings-frame payload . flags) + (make-http2-frame-rec http2-frame-type-settings + (if (null? flags) 0 (car flags)) + 0 payload)) + + (define (make-http2-ping-frame payload . flags) + (make-http2-frame-rec http2-frame-type-ping + (if (null? flags) 0 (car flags)) + 0 payload)) + + (define (make-http2-goaway-frame last-stream-id error-code) + (let ([bv (make-bytevector 8 0)]) + (bytevector-u8-set! bv 0 (bitwise-and (bitwise-arithmetic-shift-right last-stream-id 24) #x7F)) + (bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right last-stream-id 16) #xFF)) + (bytevector-u8-set! bv 2 (bitwise-and (bitwise-arithmetic-shift-right last-stream-id 8) #xFF)) + (bytevector-u8-set! bv 3 (bitwise-and last-stream-id #xFF)) + (bytevector-u8-set! bv 4 (bitwise-and (bitwise-arithmetic-shift-right error-code 24) #xFF)) + (bytevector-u8-set! bv 5 (bitwise-and (bitwise-arithmetic-shift-right error-code 16) #xFF)) + (bytevector-u8-set! bv 6 (bitwise-and (bitwise-arithmetic-shift-right error-code 8) #xFF)) + (bytevector-u8-set! bv 7 (bitwise-and error-code #xFF)) + (make-http2-frame-rec http2-frame-type-goaway 0 0 bv))) + + (define (make-http2-rst-stream-frame stream-id error-code) + (let ([bv (make-bytevector 4 0)]) + (bytevector-u8-set! bv 0 (bitwise-and (bitwise-arithmetic-shift-right error-code 24) #xFF)) + (bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right error-code 16) #xFF)) + (bytevector-u8-set! bv 2 (bitwise-and (bitwise-arithmetic-shift-right error-code 8) #xFF)) + (bytevector-u8-set! bv 3 (bitwise-and error-code #xFF)) + (make-http2-frame-rec http2-frame-type-rst-stream 0 stream-id bv))) + + (define (make-http2-window-update-frame stream-id increment) + (let ([bv (make-bytevector 4 0)]) + (bytevector-u8-set! bv 0 (bitwise-and (bitwise-arithmetic-shift-right increment 24) #x7F)) + (bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right increment 16) #xFF)) + (bytevector-u8-set! bv 2 (bitwise-and (bitwise-arithmetic-shift-right increment 8) #xFF)) + (bytevector-u8-set! bv 3 (bitwise-and increment #xFF)) + (make-http2-frame-rec http2-frame-type-window-update 0 stream-id bv))) + + ;;; ========== HPACK ========== + ;; Simplified HPACK static table (RFC 7541 Appendix A, first 10 entries) + ;; Index Name Value + ;; 1 :authority "" + ;; 2 :method GET + ;; 3 :method POST + ;; 4 :path / + ;; 5 :path /index.html + ;; 6 :scheme http + ;; 7 :scheme https + ;; 8 :status 200 + ;; 9 :status 204 + ;; 10 :status 206 + + (define hpack-static-table + '#(("" . "") ; index 0 unused + (":authority" . "") + (":method" . "GET") + (":method" . "POST") + (":path" . "/") + (":path" . "/index.html") + (":scheme" . "http") + (":scheme" . "https") + (":status" . "200") + (":status" . "204") + (":status" . "206") + (":status" . "304") + (":status" . "400") + (":status" . "404") + (":status" . "500") + ("accept-charset" . "") + ("accept-encoding" . "gzip, deflate") + ("accept-language" . "") + ("accept-ranges" . "") + ("accept" . "") + ("access-control-allow-origin" . "") + ("age" . "") + ("allow" . "") + ("authorization" . "") + ("cache-control" . "") + ("content-disposition" . "") + ("content-encoding" . "") + ("content-language" . "") + ("content-length" . "") + ("content-location" . "") + ("content-range" . "") + ("content-type" . "") + ("cookie" . "") + ("date" . "") + ("etag" . "") + ("expect" . "") + ("expires" . "") + ("from" . "") + ("host" . "") + ("if-match" . "") + ("if-modified-since" . "") + ("if-none-match" . "") + ("if-range" . "") + ("if-unmodified-since" . "") + ("last-modified" . "") + ("link" . "") + ("location" . "") + ("max-forwards" . "") + ("proxy-authenticate" . "") + ("proxy-authorization" . "") + ("range" . "") + ("referer" . "") + ("refresh" . "") + ("retry-after" . "") + ("server" . "") + ("set-cookie" . "") + ("strict-transport-security" . "") + ("transfer-encoding" . "") + ("user-agent" . "") + ("vary" . "") + ("via" . "") + ("www-authenticate" . ""))) + + ;; Find static table index for (name . value) pair (1-based, 0 = not found) + (define (hpack-static-index name value) + (let loop ([i 1]) + (if (> i 61) + 0 + (let ([entry (vector-ref hpack-static-table i)]) + (if (and (string=? (car entry) name) + (string=? (cdr entry) value)) + i + (loop (+ i 1))))))) + + ;; Find static table index for name only (value doesn't matter) + (define (hpack-static-name-index name) + (let loop ([i 1]) + (if (> i 61) + 0 + (if (string=? (car (vector-ref hpack-static-table i)) name) + i + (loop (+ i 1)))))) + + ;; Encode a string as HPACK literal (length-prefixed, no Huffman) + ;; Format: 0xxxxxxx length, then ASCII bytes + (define (hpack-encode-string str) + (let* ([bstr (string->utf8 str)] + [len (bytevector-length bstr)] + [out (make-bytevector (+ 1 len))]) + (bytevector-u8-set! out 0 len) ; H=0 (no Huffman), length in 7 bits + (bytevector-copy! bstr 0 out 1 len) + out)) + + ;; Decode a string from HPACK literal at offset, returns (string . new-offset) + (define (hpack-decode-string bv offset) + (let* ([b (bytevector-u8-ref bv offset)] + [_huff? (not (zero? (bitwise-and b #x80)))] + [len (bitwise-and b #x7F)] + [str (utf8->string (subbytevector bv (+ offset 1) (+ offset 1 len)))]) + (cons str (+ offset 1 len)))) + + ;; Helper: extract sub-bytevector + (define (subbytevector bv start end) + (let* ([len (- end start)] + [out (make-bytevector len)]) + (bytevector-copy! bv start out 0 len) + out)) + + ;; HPACK context (dynamic table as alist, max size) + (define-record-type hpack-context-rec + (fields (mutable dynamic-table) (mutable table-size) max-size) + (protocol + (lambda (new) + (lambda (max-size) + (new '() 0 max-size))))) + + (define (hpack-context? x) (hpack-context-rec? x)) + + (define (make-hpack-context . args) + (let ([max-size (if (null? args) 4096 (car args))]) + (make-hpack-context-rec max-size))) + + ;; Encode a list of (name . value) pairs using HPACK. + ;; Strategy: indexed if in static table, literal with name-index if name matches, + ;; else literal with name string. + (define (hpack-encode ctx headers) + (let ([parts '()]) + (for-each + (lambda (header) + (let* ([name (car header)] + [value (cdr header)] + [idx (hpack-static-index name value)]) + (if (> idx 0) + ;; Indexed header field: 1xxxxxxx + (set! parts (cons (make-bytevector 1 (bitwise-ior #x80 idx)) parts)) + ;; Literal header field without indexing: 0000xxxx + (let ([name-idx (hpack-static-name-index name)]) + (if (> name-idx 0) + ;; Name indexed, value literal: 0000nnnn + value + (let* ([name-bv (make-bytevector 1 name-idx)] + [val-bv (hpack-encode-string value)]) + (set! parts (cons val-bv (cons name-bv parts)))) + ;; Both name and value literal: 00000000 + name + value + (let* ([prefix-bv (make-bytevector 1 0)] + [name-bv (hpack-encode-string name)] + [val-bv (hpack-encode-string value)]) + (set! parts (cons val-bv (cons name-bv (cons prefix-bv parts)))))))))) + headers) + ;; Concatenate all parts + (let* ([reversed (reverse parts)] + [total (apply + (map bytevector-length reversed))] + [out (make-bytevector total)] + [pos 0]) + (for-each + (lambda (bv) + (let ([len (bytevector-length bv)]) + (bytevector-copy! bv 0 out pos len) + (set! pos (+ pos len)))) + reversed) + out))) + + ;; Decode HPACK-encoded bytevector into list of (name . value) pairs. + (define (hpack-decode ctx bv) + (let ([len (bytevector-length bv)] + [result '()]) + (let loop ([pos 0]) + (when (< pos len) + (let ([b (bytevector-u8-ref bv pos)]) + (cond + ;; Indexed header field: 1xxxxxxx + [(not (zero? (bitwise-and b #x80))) + (let* ([idx (bitwise-and b #x7F)] + [entry (if (and (> idx 0) (<= idx 61)) + (vector-ref hpack-static-table idx) + (cons "" ""))]) + (set! result (cons entry result)) + (loop (+ pos 1)))] + ;; Literal with incremental indexing: 01xxxxxx (skip for simplicity) + [(not (zero? (bitwise-and b #x40))) + (let* ([name-idx (bitwise-and b #x3F)] + [pos1 (+ pos 1)]) + (if (> name-idx 0) + ;; Name from static table + (let* ([name (car (vector-ref hpack-static-table name-idx))] + [val-r (hpack-decode-string bv pos1)] + [value (car val-r)] + [pos2 (cdr val-r)]) + (set! result (cons (cons name value) result)) + (loop pos2)) + ;; Literal name + (let* ([name-r (hpack-decode-string bv pos1)] + [name (car name-r)] + [pos2 (cdr name-r)] + [val-r (hpack-decode-string bv pos2)] + [value (car val-r)] + [pos3 (cdr val-r)]) + (set! result (cons (cons name value) result)) + (loop pos3))))] + ;; Literal without indexing or never-indexed: 0000xxxx + [else + (let* ([name-idx (bitwise-and b #x0F)] + [pos1 (+ pos 1)]) + (if (> name-idx 0) + ;; Name from static table + (let* ([name (car (vector-ref hpack-static-table name-idx))] + [val-r (hpack-decode-string bv pos1)] + [value (car val-r)] + [pos2 (cdr val-r)]) + (set! result (cons (cons name value) result)) + (loop pos2)) + ;; Literal name + (let* ([name-r (hpack-decode-string bv pos1)] + [name (car name-r)] + [pos2 (cdr name-r)] + [val-r (hpack-decode-string bv pos2)] + [value (car val-r)] + [pos3 (cdr val-r)]) + (set! result (cons (cons name value) result)) + (loop pos3))))])) + (reverse result))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/rate.sls @@ -0,0 +1,187 @@ +#!chezscheme +;;; (std net rate) -- Rate limiting +;;; +;;; Token bucket, sliding window, fixed window, and thread-safe rate limiter. + +(library (std net rate) + (export + ;; Token bucket + make-token-bucket token-bucket? token-bucket-try! token-bucket-consume! + token-bucket-tokens + ;; Sliding window + make-sliding-window sliding-window? sliding-window-try! sliding-window-count + ;; Fixed window + make-fixed-window fixed-window? fixed-window-try! fixed-window-count + ;; Rate limiter (thread-safe wrapper) + make-rate-limiter rate-limiter? rate-limiter-try! rate-limiter-wait!) + + (import (chezscheme)) + + ;;; ========== Time utility ========== + ;; Returns current time as a real-number (seconds since epoch). + (define (now-seconds) + (let ([t (current-time 'time-utc)]) + (+ (time-second t) (/ (time-nanosecond t) 1000000000.0)))) + + ;;; ========== Token Bucket ========== + ;; capacity: max tokens (integer or real) + ;; rate: tokens per second to add + ;; tokens: current token count (mutable) + ;; last: last refill time as real seconds (mutable) + (define-record-type token-bucket-rec + (fields capacity rate (mutable tokens) (mutable last)) + (protocol + (lambda (new) + (lambda (capacity rate) + (new capacity rate (exact->inexact capacity) (now-seconds)))))) + + (define (token-bucket? x) (token-bucket-rec? x)) + + (define (make-token-bucket capacity rate) + (make-token-bucket-rec capacity rate)) + + ;; Refill tokens based on elapsed time. + (define (token-bucket-refill! tb) + (let* ([n (now-seconds)] + [elapsed (- n (token-bucket-rec-last tb))] + [rate (token-bucket-rec-rate tb)] + [cap (exact->inexact (token-bucket-rec-capacity tb))] + [new-toks (min cap (+ (token-bucket-rec-tokens tb) + (* elapsed (exact->inexact rate))))]) + (token-bucket-rec-tokens-set! tb new-toks) + (token-bucket-rec-last-set! tb n))) + + ;; Return current token count (after refill). + (define (token-bucket-tokens tb) + (token-bucket-refill! tb) + (token-bucket-rec-tokens tb)) + + ;; Try to consume 1 token. Returns #t if available, #f otherwise. + (define (token-bucket-try! tb) + (token-bucket-refill! tb) + (let ([toks (token-bucket-rec-tokens tb)]) + (if (>= toks 1.0) + (begin + (token-bucket-rec-tokens-set! tb (- toks 1.0)) + #t) + #f))) + + ;; Try to consume n tokens. Returns #t if available, #f otherwise. + (define (token-bucket-consume! tb n) + (token-bucket-refill! tb) + (let* ([toks (token-bucket-rec-tokens tb)] + [n-real (exact->inexact n)]) + (if (>= toks n-real) + (begin + (token-bucket-rec-tokens-set! tb (- toks n-real)) + #t) + #f))) + + ;;; ========== Sliding Window ========== + ;; Allows up to `limit` requests in the last `window-seconds` seconds. + ;; Timestamps stored as a list of real-number seconds. + (define-record-type sliding-window-rec + (fields limit window-seconds (mutable timestamps)) + (protocol + (lambda (new) + (lambda (limit window-seconds) + (new limit window-seconds '()))))) + + (define (sliding-window? x) (sliding-window-rec? x)) + + (define (make-sliding-window limit window-seconds) + (make-sliding-window-rec limit window-seconds)) + + ;; Remove timestamps older than window-seconds ago. + (define (sliding-window-prune! sw) + (let* ([cutoff (- (now-seconds) (exact->inexact (sliding-window-rec-window-seconds sw)))] + [new-ts (filter (lambda (t) (>= t cutoff)) + (sliding-window-rec-timestamps sw))]) + (sliding-window-rec-timestamps-set! sw new-ts))) + + ;; Return count of requests in current window. + (define (sliding-window-count sw) + (sliding-window-prune! sw) + (length (sliding-window-rec-timestamps sw))) + + ;; Try to allow a request. Returns #t if within limit, #f otherwise. + (define (sliding-window-try! sw) + (sliding-window-prune! sw) + (let ([count (length (sliding-window-rec-timestamps sw))] + [limit (sliding-window-rec-limit sw)]) + (if (< count limit) + (begin + (sliding-window-rec-timestamps-set! sw + (cons (now-seconds) (sliding-window-rec-timestamps sw))) + #t) + #f))) + + ;;; ========== Fixed Window ========== + ;; Allows up to `limit` requests per window of `window-seconds`. + ;; Window number = floor(now / window-seconds). + (define-record-type fixed-window-rec + (fields limit window-seconds (mutable current-window) (mutable count)) + (protocol + (lambda (new) + (lambda (limit window-seconds) + (new limit window-seconds -1 0))))) + + (define (fixed-window? x) (fixed-window-rec? x)) + + (define (make-fixed-window limit window-seconds) + (make-fixed-window-rec limit window-seconds)) + + ;; Compute current window number. + (define (fixed-window-number fw) + (let ([ws (exact->inexact (fixed-window-rec-window-seconds fw))]) + (exact (floor (/ (now-seconds) ws))))) + + ;; Return count of requests in current window. + (define (fixed-window-count fw) + (let ([w (fixed-window-number fw)]) + (if (= w (fixed-window-rec-current-window fw)) + (fixed-window-rec-count fw) + 0))) + + ;; Try to allow a request. Returns #t if within limit, #f otherwise. + (define (fixed-window-try! fw) + (let* ([w (fixed-window-number fw)] + [curr (fixed-window-rec-current-window fw)] + [count (if (= w curr) (fixed-window-rec-count fw) 0)] + [limit (fixed-window-rec-limit fw)]) + (when (not (= w curr)) + (fixed-window-rec-current-window-set! fw w) + (fixed-window-rec-count-set! fw 0)) + (if (< count limit) + (begin + (fixed-window-rec-count-set! fw (+ count 1)) + #t) + #f))) + + ;;; ========== Rate Limiter (thread-safe token bucket) ========== + (define-record-type rate-limiter-rec + (fields bucket mutex) + (protocol + (lambda (new) + (lambda (capacity rate) + (new (make-token-bucket capacity rate) + (make-mutex)))))) + + (define (rate-limiter? x) (rate-limiter-rec? x)) + + (define (make-rate-limiter capacity rate) + (make-rate-limiter-rec capacity rate)) + + ;; Try to consume a token (thread-safe). Returns #t/#f. + (define (rate-limiter-try! rl) + (with-mutex (rate-limiter-rec-mutex rl) + (token-bucket-try! (rate-limiter-rec-bucket rl)))) + + ;; Wait until a token is available, then consume it. + (define (rate-limiter-wait! rl) + (let loop () + (unless (rate-limiter-try! rl) + (sleep (make-time 'time-duration 100000000 0)) ; 100ms + (loop)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/router.sls @@ -0,0 +1,185 @@ +#!chezscheme +;;; (std net router) -- HTTP request routing +;;; +;;; Pattern matching: /users/:id/posts/:post-id -> params alist +;;; Route precedence: static > parameterized > wildcard +;;; Middleware: ordered list of wrappers + +(library (std net router) + (export + make-router router? + router-add! router-match + route-match? route-params route-handler route-middleware + router-get! router-post! router-put! router-delete! router-patch! router-any! + route-not-found make-route router-middleware!) + + (import (chezscheme)) + + ;;; ========== Route record ========== + (define-record-type route-rec + (fields method pattern handler priority (mutable middleware)) + (protocol + (lambda (new) + (lambda (method pattern handler priority) + (new method pattern handler priority '()))))) + + (define (make-route method pattern handler) + (let ([priority (pattern-priority pattern)]) + (make-route-rec method pattern handler priority))) + + ;;; ========== Route match result ========== + (define-record-type route-match-rec + (fields handler params middleware)) + + (define (route-match? x) (route-match-rec? x)) + (define (route-params m) (route-match-rec-params m)) + (define (route-handler m) (route-match-rec-handler m)) + (define (route-middleware m) (route-match-rec-middleware m)) + + ;; Sentinel for not-found + (define route-not-found #f) + + ;;; ========== Router record ========== + (define-record-type router-rec + (fields (mutable routes) (mutable middleware)) + (protocol + (lambda (new) + (lambda () + (new '() '()))))) + + (define (router? x) (router-rec? x)) + + (define (make-router) + (make-router-rec)) + + ;;; ========== Pattern parsing ========== + ;; Parse a path pattern into segments: each segment is either + ;; 'static -> exact string match + ;; 'param -> :name capture + ;; 'wildcard -> * matches rest + (define (parse-pattern pattern) + (let ([segs (string-split pattern #\/)]) + ;; Remove empty leading segment from leading / + (let ([parts (if (and (not (null? segs)) (string=? (car segs) "")) + (cdr segs) + segs)]) + (map (lambda (s) + (cond + [(string=? s "*") (cons 'wildcard s)] + [(and (> (string-length s) 0) (char=? (string-ref s 0) #\:)) + (cons 'param (substring s 1 (string-length s)))] + [else (cons 'static s)])) + parts)))) + + ;; Compute priority: number of static segments (higher = more specific) + ;; Wildcard gets lowest priority (-1), params get 0, statics get 1 each. + (define (pattern-priority pattern) + (let ([segs (parse-pattern pattern)]) + (if (any-wildcard? segs) + -1 + (fold-left (lambda (acc seg) + (+ acc (if (eq? (car seg) 'static) 1 0))) + 0 segs)))) + + (define (any-wildcard? segs) + (exists (lambda (s) (eq? (car s) 'wildcard)) segs)) + + ;;; ========== Path matching ========== + ;; Match a request path against a route pattern. + ;; Returns alist of (param-name . value) on success, #f on failure. + (define (match-pattern pattern path) + (let* ([pat-segs (parse-pattern pattern)] + [path-segs (let ([parts (string-split path #\/)]) + (if (and (not (null? parts)) (string=? (car parts) "")) + (cdr parts) + parts))]) + (let loop ([pats pat-segs] [paths path-segs] [params '()]) + (cond + ;; Both exhausted: match! + [(and (null? pats) (null? paths)) + (reverse params)] + ;; Wildcard: match rest of path + [(and (not (null? pats)) (eq? (caar pats) 'wildcard)) + (reverse (cons (cons '* (string-join path-segs "/")) params))] + ;; Pattern exhausted but path has more: no match + [(null? pats) #f] + ;; Path exhausted but pattern has more: no match + [(null? paths) #f] + ;; Static segment: must match exactly + [(eq? (caar pats) 'static) + (if (string=? (cdar pats) (car paths)) + (loop (cdr pats) (cdr paths) params) + #f)] + ;; Param segment: capture + [(eq? (caar pats) 'param) + (loop (cdr pats) (cdr paths) + (cons (cons (string->symbol (cdar pats)) (car paths)) + params))] + [else #f])))) + + ;;; ========== Router operations ========== + ;; Add a route to the router. Inserts in priority order (highest first). + (define (router-add! router method pattern handler) + (let* ([route (make-route method pattern handler)] + [routes (router-rec-routes router)] + [new-routes (insert-route route routes)]) + (router-rec-routes-set! router new-routes))) + + ;; Insert route maintaining descending priority order. + (define (insert-route route routes) + (cond + [(null? routes) (list route)] + [(>= (route-rec-priority route) (route-rec-priority (car routes))) + (cons route routes)] + [else + (cons (car routes) (insert-route route (cdr routes)))])) + + ;; Match a request: returns route-match-rec or #f. + (define (router-match router method path) + (let ([routes (router-rec-routes router)] + [global-mw (router-rec-middleware router)]) + (let loop ([rs routes]) + (if (null? rs) + route-not-found + (let* ([r (car rs)] + [rmeth (route-rec-method r)] + [rpat (route-rec-pattern r)]) + (if (and (or (eq? rmeth 'ANY) + (equal? rmeth method)) + (match-pattern rpat path)) + (let ([params (match-pattern rpat path)] + [mw (append global-mw (route-rec-middleware r))]) + (make-route-match-rec (route-rec-handler r) params mw)) + (loop (cdr rs)))))))) +