std/net: add http + thread-httpd modules with BSD support
ober
25867ead07a60f8862dcddffdadfe6e422581137
new file mode 100644 --- /dev/null +++ b/lib/std/net/http.sls @@ -0,0 +1,576 @@ +#!chezscheme +;;; :std/net/http -- High-level HTTP/HTTPS client with DNS, redirects, custom headers +;;; +;;; Self-contained: does its own DNS resolution (via getaddrinfo), TCP/TLS +;;; connections, and HTTP/1.1 request/response cycle. Built atop low-level +;;; (std net tcp) and (std net tls-rustls). +;;; +;;; API: +;;; (http-fetch url ...keyword args) → http-response +;;; (http-fetch-get url ...kw) → http-response +;;; (http-fetch-post url body ...kw) → http-response +;;; +;;; Keyword options (passed as 'name: value): +;;; method: "GET" / "POST" / ... (default "GET") +;;; headers: alist of (name . value) (default '()) +;;; body: string (default #f) +;;; max-redirects: integer (default 5) +;;; user-agent: string (default "JerboaHTTP/1.0") +;;; timeout: integer ms (default #f) +;;; +;;; Response accessors: +;;; (http-status r), (http-body r), (http-headers r), (http-header r name) +;;; (http-final-url r) — URL after redirects +;;; +;;; Helpers: +;;; (resolve-host hostname) → IPv4 string +;;; (url-encode s), (build-query-string alist), (parse-url url) + +(library (std net http) + (export + http-fetch + http-fetch-get + http-fetch-post + http-status + http-body + http-headers + http-header + http-final-url + http-response? + resolve-host + url-encode + build-query-string + parse-url-host + parse-url-port + parse-url-path + parse-url-scheme) + + (import (chezscheme) + (std net tcp) + (std net tls-rustls)) + + ;; ========== Synchronous DNS resolution ========== + + (define _libc-loaded + (let ((v (getenv "JERBOA_STATIC"))) + (if (and v (not (string=? v "")) (not (string=? v "0"))) + #f + (load-shared-object #f)))) + + (define c-getaddrinfo + (foreign-procedure "getaddrinfo" (string string void* void*) int)) + (define c-freeaddrinfo + (foreign-procedure "freeaddrinfo" (void*) void)) + (define c-inet-ntop + (foreign-procedure "inet_ntop" (int void* u8* int) void*)) + + (define AF_INET 2) + (define SOCK_STREAM 1) + (define INET_ADDRSTRLEN 16) + + (define (string-contains? s sub) + (let ([sl (string-length s)] [bl (string-length sub)]) + (and (>= sl bl) + (let loop ([i 0]) + (cond + [(> (+ i bl) sl) #f] + [(string=? sub (substring s i (+ i bl))) #t] + [else (loop (+ i 1))]))))) + + ;; struct addrinfo: ai_addr offset differs by OS + ;; macOS / BSD: 32 (ai_canonname before ai_addr) + ;; Linux glibc: 24 (ai_addr before ai_canonname) + (define ai-addr-offset + (let ([mt (symbol->string (machine-type))]) + (cond + [(or (string-contains? mt "osx") + (string-contains? mt "darwin") + (string-contains? mt "fb") + (string-contains? mt "ob") + (string-contains? mt "nb")) + 32] + [else 24]))) + + (define (looks-like-ipv4? s) + (let loop ([i 0] [dots 0] [digit-run 0]) + (cond + [(= i (string-length s)) + (and (= dots 3) (> digit-run 0))] + [else + (let ([c (string-ref s i)]) + (cond + [(char-numeric? c) (loop (+ i 1) dots (+ digit-run 1))] + [(char=? c #\.) (loop (+ i 1) (+ dots 1) 0)] + [else #f]))]))) + + (define (resolve-host hostname) + (cond + [(or (string=? hostname "localhost") (string=? hostname "")) "127.0.0.1"] + [(looks-like-ipv4? hostname) hostname] + [else (resolve-host-blocking hostname)])) + + (define (resolve-host-blocking hostname) + (let ([hints (foreign-alloc 48)]) + (do ([i 0 (+ i 1)]) ((= i 48)) + (foreign-set! 'unsigned-8 hints i 0)) + (foreign-set! 'int hints 4 AF_INET) + (foreign-set! 'int hints 8 SOCK_STREAM) + (let ([result-ptr (foreign-alloc 8)]) + (foreign-set! 'void* result-ptr 0 0) + (let ([rc (c-getaddrinfo hostname #f hints result-ptr)]) + (foreign-free hints) + (cond + [(not (= rc 0)) + (foreign-free result-ptr) + (error 'resolve-host "DNS resolution failed" hostname rc)] + [else + (let ([result (foreign-ref 'void* result-ptr 0)]) + (foreign-free result-ptr) + (if (= result 0) + (error 'resolve-host "no addresses found" hostname) + (let ([addr-ptr (foreign-ref 'void* result ai-addr-offset)]) + (let ([in-addr-ptr (+ addr-ptr 4)] + [buf (make-bytevector INET_ADDRSTRLEN)]) + (let ([p (c-inet-ntop AF_INET in-addr-ptr buf INET_ADDRSTRLEN)]) + (c-freeaddrinfo result) + (if (= p 0) + (error 'resolve-host "inet_ntop failed" hostname) + (let loop ([i 0]) + (if (= (bytevector-u8-ref buf i) 0) + (utf8->string + (let ([b (make-bytevector i)]) + (bytevector-copy! buf 0 b 0 i) b)) + (loop (+ i 1))))))))))]))))) + + ;; ========== URL parsing ========== + + (define (string-prefix? prefix s) + (and (>= (string-length s) (string-length prefix)) + (string=? prefix (substring s 0 (string-length prefix))))) + + (define (string-find-char s ch) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) ch) i] + [else (loop (+ i 1))]))) + + (define-record-type url-info + (fields scheme host port path) + (sealed #t)) + + (define (parse-url url) + (let* ([after-scheme + (cond + [(string-prefix? "http://" url) (cons "http" (substring url 7 (string-length url)))] + [(string-prefix? "https://" url) (cons "https" (substring url 8 (string-length url)))] + [else (cons "http" url)])] + [scheme (car after-scheme)] + [rest (cdr after-scheme)] + [slash-pos (string-find-char rest #\/)] + [host+port (if slash-pos (substring rest 0 slash-pos) rest)] + [path (if slash-pos (substring rest slash-pos (string-length rest)) "/")] + [colon-pos (string-find-char host+port #\:)] + [host (if colon-pos (substring host+port 0 colon-pos) host+port)] + [port (if colon-pos + (string->number + (substring host+port (+ colon-pos 1) (string-length host+port))) + (if (string=? scheme "https") 443 80))]) + (make-url-info scheme host port path))) + + (define (parse-url-scheme u) (url-info-scheme (parse-url u))) + (define (parse-url-host u) (url-info-host (parse-url u))) + (define (parse-url-port u) (url-info-port (parse-url u))) + (define (parse-url-path u) (url-info-path (parse-url u))) + + ;; ========== URL encoding ========== + + (define (hex-digit n) + (if (< n 10) (integer->char (+ n 48)) (integer->char (+ n 55)))) + + (define (url-encode str) + (let ([out (open-output-string)]) + (string-for-each + (lambda (c) + (cond + [(or (char-alphabetic? c) (char-numeric? c) (memv c '(#\- #\_ #\. #\~))) + (write-char c out)] + [else + (let ([bv (string->utf8 (string c))]) + (let loop ([i 0]) + (when (< i (bytevector-length bv)) + (let ([b (bytevector-u8-ref bv i)]) + (write-char #\% out) + (write-char (hex-digit (bitwise-arithmetic-shift-right b 4)) out) + (write-char (hex-digit (bitwise-and b 15)) out)) + (loop (+ i 1)))))])) + str) + (get-output-string out))) + + (define (string-join strs sep) + (cond + [(null? strs) ""] + [(null? (cdr strs)) (car strs)] + [else (string-append (car strs) sep (string-join (cdr strs) sep))])) + + (define (build-query-string params) + (string-join + (map (lambda (p) (string-append (url-encode (car p)) "=" (url-encode (cdr p)))) params) + "&")) + + ;; ========== HTTP wire protocol ========== + + (define (validate-no-crlf! s field) + (string-for-each + (lambda (c) + (when (or (char=? c #\return) (char=? c #\newline)) + (error 'http-fetch "header injection: CR/LF in" field))) + s)) + + (define (build-request-line method path) + (string-append method " " path " HTTP/1.1\r\n")) + + (define (build-headers-block host content-length user-headers) + ;; Drop user-supplied Host/Content-Length to avoid duplicates; we add canonical ones + (let ([filtered (filter (lambda (h) + (let ([n (string-downcase (car h))]) + (and (not (string=? n "host")) + (not (string=? n "content-length"))))) + user-headers)]) + (let ([out (open-output-string)]) + (put-string out "Host: ") (put-string out host) (put-string out "\r\n") + (put-string out "Connection: close\r\n") + (when content-length + (put-string out "Content-Length: ") + (put-string out (number->string content-length)) + (put-string out "\r\n")) + (for-each (lambda (h) + (validate-no-crlf! (car h) "header name") + (validate-no-crlf! (cdr h) "header value") + (put-string out (car h)) (put-string out ": ") + (put-string out (cdr h)) (put-string out "\r\n")) + filtered) + (put-string out "\r\n") + (get-output-string out)))) + + ;; Read raw bytes from a port (text or binary) into a bytevector + (define (read-port-all p) + (let ([chunks '()]) + (let loop () + (let ([c (read-char p)]) + (if (eof-object? c) + (let ([s (apply string-append (reverse chunks))]) + s) + (begin + (set! chunks (cons (string c) chunks)) + (loop))))))) + + ;; Faster: read in 4KB chunks + (define (read-port-fast p) + (let ([buf-size 4096] + [out (open-output-string)]) + (let ([buf (make-string buf-size)]) + (let loop () + (let ([n (block-read p buf buf-size)]) + (cond + [(eof-object? n) (get-output-string out)] + [(= n 0) (get-output-string out)] + [else + (put-string out (substring buf 0 n)) + (loop)])))))) + + (define (parse-status-line line) + ;; "HTTP/1.1 200 OK" + (if (and (string? line) (>= (string-length line) 12)) + (let ([code (string->number (substring line 9 12))]) + (or code 0)) + 0)) + + (define (read-line-crlf in) + (let ([out (open-output-string)]) + (let loop () + (let ([c (read-char in)]) + (cond + [(eof-object? c) (get-output-string out)] + [(char=? c #\return) + (let ([next (read-char in)]) + (if (and (char? next) (char=? next #\newline)) + (get-output-string out) + (begin + (write-char c out) + (when (char? next) (write-char next out)) + (loop))))] + [else (write-char c out) (loop)]))))) + + (define (read-headers in) + (let loop ([acc '()]) + (let ([line (read-line-crlf in)]) + (cond + [(string=? line "") (reverse acc)] + [else + (let ([colon (string-find-char line #\:)]) + (if colon + (let ([name (string-downcase (substring line 0 colon))] + [value (string-trim-left + (substring line (+ colon 1) (string-length line)))]) + (loop (cons (cons name value) acc))) + (loop acc)))])))) + + (define (string-trim-left s) + (let loop ([i 0]) + (cond + [(= i (string-length s)) ""] + [(or (char=? (string-ref s i) #\space) + (char=? (string-ref s i) #\tab)) + (loop (+ i 1))] + [else (substring s i (string-length s))]))) + + (define (read-body-content-length in n) + (if (or (not n) (= n 0)) + "" + (let ([out (open-output-string)]) + (let loop ([remaining n]) + (if (<= remaining 0) + (get-output-string out) + (let ([c (read-char in)]) + (cond + [(eof-object? c) (get-output-string out)] + [else (write-char c out) (loop (- remaining 1))]))))))) + + (define (read-body-chunked in) + (let ([out (open-output-string)]) + (let loop () + (let* ([size-line (read-line-crlf in)] + [;; parse hex; chunk-size may have ;extensions + semi (string-find-char size-line #\;)] + [size-str (if semi (substring size-line 0 semi) size-line)] + [size (string->number (string-trim-both size-str) 16)]) + (cond + [(or (not size) (= size 0)) + ;; Read trailing CRLF / trailers + (read-line-crlf in) + (get-output-string out)] + [else + (let chunk-loop ([remaining size]) + (when (> remaining 0) + (let ([c (read-char in)]) + (unless (eof-object? c) + (write-char c out) + (chunk-loop (- remaining 1)))))) + (read-line-crlf in) ;; eat trailing CRLF + (loop)]))))) + + (define (string-trim-both s) + (let* ([s (string-trim-left s)] + [len (string-length s)]) + (let loop ([i (- len 1)]) + (cond + [(< i 0) ""] + [(or (char=? (string-ref s i) #\space) + (char=? (string-ref s i) #\tab)) + (loop (- i 1))] + [else (substring s 0 (+ i 1))])))) + + (define (read-body in headers) + (let ([te (assoc "transfer-encoding" headers)] + [cl (assoc "content-length" headers)]) + (cond + [(and te (string-contains? (string-downcase (cdr te)) "chunked")) + (read-body-chunked in)] + [cl + (let ([n (string->number (string-trim-both (cdr cl)))]) + (read-body-content-length in n))] + [else + ;; No Content-Length and not chunked — read until EOF + (let ([out (open-output-string)]) + (let loop () + (let ([c (read-char in)]) + (cond + [(eof-object? c) (get-output-string out)] + [else (write-char c out) (loop)]))))]))) + + ;; ========== Connection layer ========== + + (define-record-type http-response + (fields status headers body final-url) + (sealed #t)) + + (define (http-status r) (http-response-status r)) + (define (http-body r) (http-response-body r)) + (define (http-headers r) (http-response-headers r)) + (define (http-header r name) + (let ([p (assoc (string-downcase name) (http-response-headers r))]) + (and p (cdr p)))) + (define (http-final-url r) (http-response-final-url r)) + + (define (do-http-request scheme host port path method headers body) + (cond + [(string=? scheme "http") + (let ([ip (resolve-host host)]) + (let-values ([(in out) (tcp-connect ip port)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (put-string out (build-request-line method path)) + (put-string out (build-headers-block host + (and body (bytevector-length (string->utf8 body))) + headers)) + (when body (put-string out body)) + (flush-output-port out) + (let* ([status (parse-status-line (read-line-crlf in))] + [resp-headers (read-headers in)] + [body (if (string=? method "HEAD") "" (read-body in resp-headers))]) + (values status resp-headers body))) + (lambda () + (close-port in) + (close-port out)))))] + [(string=? scheme "https") + (let ([handle (rustls-connect host port)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (let ([req-bv (string->utf8 + (string-append + (build-request-line method path) + (build-headers-block host + (and body (bytevector-length (string->utf8 body))) + headers) + (or body "")))]) + (rustls-write handle req-bv (bytevector-length req-bv))) + (let* ([resp-bv (rustls-read-until-eof handle)] + [resp-str (utf8->string resp-bv)] + [resp-port (open-input-string resp-str)] + [status (parse-status-line (read-line-crlf resp-port))] + [resp-headers (read-headers resp-port)] + [body (if (string=? method "HEAD") "" (read-body resp-port resp-headers))]) + (values status resp-headers body))) + (lambda () + (guard (e [#t (void)]) (rustls-close handle)))))] + [else (error 'do-http-request "unknown scheme" scheme)])) + + (define (rustls-read-until-eof handle) + (let ([buf (make-bytevector 32768)] + [chunks '()]) + (let loop () + (let ([n (rustls-read handle buf 32768)]) + (cond + [(<= n 0) + ;; concat chunks + (let ([total (apply + (map bytevector-length (reverse chunks)))]) + (let ([result (make-bytevector total 0)]) + (let lp ([offset 0] [bvs (reverse chunks)]) + (if (null? bvs) + result + (let* ([bv (car bvs)] [len (bytevector-length bv)]) + (bytevector-copy! bv 0 result offset len) + (lp (+ offset len) (cdr bvs)))))))] + [else + (let ([chunk (make-bytevector n)]) + (bytevector-copy! buf 0 chunk 0 n) + (set! chunks (cons chunk chunks)) + (loop))]))))) + + ;; ========== Top-level fetch with redirects ========== + + (define default-headers + '(("Accept" . "*/*") + ("Accept-Encoding" . "identity"))) + + (define (parse-keyword-args args) + (let loop ([args args] [opts '()]) + (cond + [(null? args) opts] + [(symbol? (car args)) + (if (null? (cdr args)) + (error 'http-fetch "keyword without value" (car args)) + (loop (cddr args) (cons (cons (car args) (cadr args)) opts)))] + [else (error 'http-fetch "expected keyword" (car args))]))) + + (define (opt-get opts key default) + (let ([p (assq key opts)]) + (if p (cdr p) default))) + + (define (merge-headers user-headers) + (let* ([user-keys (map (lambda (p) (string-downcase (car p))) user-headers)] + [filtered-defaults (filter (lambda (p) (not (member (string-downcase (car p)) user-keys))) + default-headers)] + [has-ua? (member "user-agent" user-keys)] + [with-ua (if has-ua? user-headers + (cons (cons "User-Agent" "JerboaHTTP/1.0") user-headers))]) + (append with-ua filtered-defaults))) + + (define (absolute-url base loc) + (cond + [(or (string-prefix? "http://" loc) (string-prefix? "https://" loc)) loc] + [(and (> (string-length loc) 0) (char=? (string-ref loc 0) #\/)) + (let* ([u (parse-url base)] + [scheme (url-info-scheme u)] + [host (url-info-host u)] + [port (url-info-port u)] + [default-port (if (string=? scheme "https") 443 80)]) + (if (= port default-port) + (string-append scheme "://" host loc) + (string-append scheme "://" host ":" (number->string port) loc)))] + [else + (let* ([u (parse-url base)] + [scheme (url-info-scheme u)] + [host (url-info-host u)] + [port (url-info-port u)] + [path (url-info-path u)] + [last-slash (let lp ([i (- (string-length path) 1)]) + (cond + [(< i 0) -1] + [(char=? (string-ref path i) #\/) i] + [else (lp (- i 1))]))] + [dir (if (>= last-slash 0) + (substring path 0 (+ last-slash 1)) + "/")] + [default-port (if (string=? scheme "https") 443 80)]) + (if (= port default-port) + (string-append scheme "://" host dir loc) + (string-append scheme "://" host ":" (number->string port) dir loc)))])) + + (define (http-fetch url . kw-args) + (let* ([opts (parse-keyword-args kw-args)] + [method (opt-get opts 'method: "GET")] + [user-headers (opt-get opts 'headers: '())] + [body (opt-get opts 'body: #f)] + [max-redirects (opt-get opts 'max-redirects: 5)] + [user-agent (opt-get opts 'user-agent: #f)] + [headers (merge-headers + (if user-agent + (cons (cons "User-Agent" user-agent) user-headers) + user-headers))]) + (let loop ([cur-url url] [meth method] [redirects 0]) + (let* ([u (parse-url cur-url)] + [scheme (url-info-scheme u)] + [host (url-info-host u)] + [port (url-info-port u)] + [path (url-info-path u)]) + (let-values ([(status resp-headers resp-body) + (do-http-request scheme host port path meth headers body)]) + (cond + [(and (or (= status 301) (= status 302) (= status 303) + (= status 307) (= status 308)) + (< redirects max-redirects)) + (let ([loc (let ([p (assoc "location" resp-headers)]) + (and p (cdr p)))]) + (if loc + (let* ([next-url (absolute-url cur-url loc)] + [next-method (cond + [(or (= status 301) (= status 302) (= status 303)) + (if (or (string=? meth "GET") (string=? meth "HEAD")) + meth "GET")] + [else meth])]) + (loop next-url next-method (+ redirects 1))) + (make-http-response status resp-headers resp-body cur-url)))] + [else + (make-http-response status resp-headers resp-body cur-url)])))))) + + (define (http-fetch-get url . kw) + (apply http-fetch url 'method: "GET" kw)) + + (define (http-fetch-post url body . kw) + (apply http-fetch url 'method: "POST" 'body: body kw)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/thread-httpd.sls @@ -0,0 +1,659 @@ +#!chezscheme +;;; (std net thread-httpd) — Cross-platform thread-per-connection HTTP/1.1 server +;;; +;;; Pure-Scheme + libc FFI. No dependency on epoll/kqueue, so the +;;; server runs unmodified on Linux, macOS, and the BSDs (FreeBSD, +;;; NetBSD, OpenBSD). Each accepted connection is dispatched to its +;;; own OS thread (fork-thread) which reads the request, calls the +;;; handler, writes the response, and closes the socket. Suitable +;;; for low-to-medium concurrency workloads — for high-concurrency +;;; epoll-driven I/O use (std net fiber-httpd) instead (Linux only). +;;; +;;; API mirrors (std net fiber-httpd) closely so callers can swap +;;; backends with one import change. + +(library (std net thread-httpd) + (export + ;; Server lifecycle + thread-httpd-start + thread-httpd-stop! + thread-httpd? + thread-httpd-listen-port + + ;; Request record + make-request request? request-method request-path request-version + request-headers request-body request-header + request-query-string request-path-only + + ;; Response helpers + respond respond-text respond-json respond-html + response? response-status response-headers response-body + + ;; Router + make-router router-add! router-dispatch + route-get route-post route-put route-delete + route-param current-route-params) + + (import (chezscheme)) + + ;; ========== libc FFI ========== + + (define _libc-loaded + (load-shared-object #f)) + + (define c-socket (foreign-procedure "socket" (int int int) int)) + (define c-bind (foreign-procedure "bind" (int void* int) int)) + (define c-listen (foreign-procedure "listen" (int int) int)) + ;; accept/read/write are blocking syscalls — mark them __collect_safe so + ;; the calling thread is deactivated, letting other Scheme threads run + ;; (including the accept loop while a worker is busy in read). + (define c-accept (foreign-procedure __collect_safe "accept" + (int void* void*) int)) + (define c-close (foreign-procedure "close" (int) int)) + (define c-read (foreign-procedure __collect_safe "read" + (int u8* size_t) ssize_t)) + (define c-write (foreign-procedure __collect_safe "write" + (int u8* size_t) ssize_t)) + (define c-setsockopt (foreign-procedure "setsockopt" + (int int int void* int) int)) + (define c-htons (foreign-procedure "htons" (unsigned-16) unsigned-16)) + (define c-inet-addr (foreign-procedure "inet_addr" (string) unsigned-32)) + + ;; Chez (machine-type) suffix tells us the OS: + ;; osx / darwin — macOS + ;; fb — FreeBSD + ;; nb — NetBSD + ;; ob — OpenBSD + ;; (else) — Linux (and other glibc-style systems) + ;; All four BSD-family systems share the same sockaddr_in layout + ;; (sin_len byte at offset 0) and the same SOL_SOCKET / SO_REUSEADDR + ;; constant values, so we collapse them into a single bsd? predicate. + + (define (machine-type-bsd?) + (let ([mt (symbol->string (machine-type))]) + (define (contains? sub) + (let ([sl (string-length mt)] + [bl (string-length sub)]) + (and (>= sl bl) + (let loop ([i 0]) + (cond + [(> (+ i bl) sl) #f] + [(string=? (substring mt i (+ i bl)) sub) #t] + [else (loop (+ i 1))]))))) + (or (contains? "osx") + (contains? "darwin") + (contains? "fb") + (contains? "nb") + (contains? "ob")))) + + (define AF_INET 2) + (define SOCK_STREAM 1) + ;; SOL_SOCKET / SO_REUSEADDR values differ between Linux and the BSDs. + ;; Linux: SOL_SOCKET=1, SO_REUSEADDR=2 + ;; BSD: SOL_SOCKET=0xFFFF, SO_REUSEADDR=4 + ;; (BSD = macOS, FreeBSD, NetBSD, OpenBSD.) + (define SOL_SOCKET (if (machine-type-bsd?) #xFFFF 1)) + (define SO_REUSEADDR (if (machine-type-bsd?) 4 2)) + + ;; sockaddr_in is { sa_family_t sin_family; in_port_t sin_port; + ;; struct in_addr sin_addr; char sin_zero[8]; } + ;; Both layouts are 16 bytes total but lay out the first two bytes + ;; differently: + ;; Linux glibc: u16 sin_family at offset 0 (no sin_len). + ;; BSDs: u8 sin_len at offset 0, + ;; u8 sin_family at offset 1. + (define SOCKADDR_IN_SIZE 16) + + (define (make-sockaddr-in address port) + (let ([buf (foreign-alloc SOCKADDR_IN_SIZE)]) + (do ([i 0 (+ i 1)]) + ((= i SOCKADDR_IN_SIZE)) + (foreign-set! 'unsigned-8 buf i 0)) + (cond + [(machine-type-bsd?) + ;; sin_len = 16 at offset 0, sin_family = AF_INET at offset 1 + (foreign-set! 'unsigned-8 buf 0 SOCKADDR_IN_SIZE) + (foreign-set! 'unsigned-8 buf 1 AF_INET)] + [else + (foreign-set! 'unsigned-16 buf 0 AF_INET)]) + ;; sin_port @ 2 (network order) + (foreign-set! 'unsigned-16 buf 2 (c-htons port)) + ;; sin_addr @ 4 (already in network order from inet_addr) + (foreign-set! 'unsigned-32 buf 4 (c-inet-addr address)) + buf)) + + (define (set-int-sockopt! fd level optname value) + (let ([buf (foreign-alloc 4)]) + (foreign-set! 'int buf 0 value) + (let ([rc (c-setsockopt fd level optname buf 4)]) + (foreign-free buf) rc))) + + ;; ========== Records ========== + + (define-record-type request + (fields method path version headers body) + (protocol (lambda (new) (lambda (m p v h b) (new m p v h b))))) + + (define (request-header req name) + (let ([p (assoc (string-downcase name) (request-headers req))]) + (and p (cdr p)))) + + (define (request-path-only req) + (let* ([path (request-path req)] + [q (string-index path #\?)]) + (if q (substring path 0 q) path))) + + (define (request-query-string req) + (let* ([path (request-path req)] + [q (string-index path #\?)]) + (if q (substring path (+ q 1) (string-length path)) ""))) + + (define (string-index s ch) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) ch) i] + [else (loop (+ i 1))]))) + + (define-record-type response + (fields status headers body) + (protocol (lambda (new) (lambda (s h b) (new s h b))))) + + (define (respond status headers body) (make-response status headers body)) + + (define (respond-text status text) + (respond status + '(("Content-Type" . "text/plain; charset=utf-8")) + text)) + + (define (respond-json status json-str) + (respond status + '(("Content-Type" . "application/json; charset=utf-8")) + json-str)) + + (define (respond-html status html) + (respond status + '(("Content-Type" . "text/html; charset=utf-8")) + html)) + + ;; ========== Router ========== + + (define-record-type router + (fields (mutable routes)) + (protocol (lambda (new) (lambda () (new '()))))) + + (define (router-add! r method path handler) + (router-routes-set! r + (cons (list method path handler) (router-routes r)))) + + (define (split-on-slash s) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (cons (substring s start i) acc))] + [(char=? (string-ref s i) #\/) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else (loop (+ i 1) start acc)]))) + + (define (split-path-segments p) + (let ([segs (split-on-slash p)]) + (if (and (not (null? segs)) (string=? (car segs) "")) + (cdr segs) segs))) + + (define (match-path-pattern pattern path) + (if (string=? pattern "*") + '() + (let ([pat-segs (split-path-segments pattern)] + [path-segs (split-path-segments path)]) + (and (= (length pat-segs) (length path-segs)) + (let loop ([ps pat-segs] [xs path-segs] [params '()]) + (cond + [(null? ps) (reverse params)] + [(and (> (string-length (car ps)) 0) + (char=? (string-ref (car ps) 0) #\:)) + (loop (cdr ps) (cdr xs) + (cons (cons (substring (car ps) 1 + (string-length (car ps))) + (car xs)) + params))] + [(string=? (car ps) (car xs)) + (loop (cdr ps) (cdr xs) params)] + [else #f])))))) + + (define current-route-params (make-parameter '())) + + (define (route-param req name) + (let ([entry (assoc name (current-route-params))]) + (and entry (cdr entry)))) + + (define (router-dispatch r req) + (let ([method (request-method req)] + [path (request-path-only req)]) + (let loop ([routes (router-routes r)]) + (if (null? routes) + (respond-text 404 "Not Found") + (let* ([route (car routes)] + [params (and (string=? (car route) method) + (match-path-pattern (cadr route) path))]) + (if params + (parameterize ([current-route-params params]) + ((caddr route) req)) + (loop (cdr routes)))))))) + + (define (route-get r path handler) (router-add! r "GET" path handler)) + (define (route-post r path handler) (router-add! r "POST" path handler)) + (define (route-put r path handler) (router-add! r "PUT" path handler)) + (define (route-delete r path handler) (router-add! r "DELETE" path handler)) + + ;; ========== HTTP/1.1 Parser ========== + ;; + ;; Tiny line-based parser. Reads up to *max-header-size* bytes for + ;; the request line + headers, then reads Content-Length bytes for + ;; the body (or 0 if absent). Pipelining and chunked transfer- + ;; encoding are NOT supported; one request per connection. + + (define *max-header-size* 16384) + (define *max-body-size* (* 4 1024 1024)) + + (define (read-request fd) + ;; Read until we see \r\n\r\n (or EOF). + (let* ([buf (make-bytevector *max-header-size*)] + [hdr-end + (let loop ([filled 0]) + (cond + [(>= filled *max-header-size*) #f] + [else + (let ([n (c-read fd + (bv-tail-pointer buf filled) + (- *max-header-size* filled))]) + (cond + [(<= n 0) #f] + [else + (let ([new-filled (+ filled n)]) + (let ([end (find-crlf-crlf buf new-filled)]) + (if end end + (loop new-filled))))]))]))]) + (cond + [(not hdr-end) #f] + [else + (let* ([hdr-text (utf8->string-bv buf 0 hdr-end)] + [parsed (parse-headers hdr-text)]) + (cond + [(not parsed) #f] + [else + (let* ([method (vector-ref parsed 0)] + [path (vector-ref parsed 1)] + [vsn (vector-ref parsed 2)] + [hdrs (vector-ref parsed 3)] + [cl-pair (assoc "content-length" hdrs)] + [cl (and cl-pair + (string->number-safe (cdr cl-pair)))] + [extra-start (+ hdr-end 4)] + ;; total bytes already in buf is *we don't track + ;; current filled* after exit... we know hdr-end + ;; was returned at first detection. We must + ;; redo and capture filled count. Simplify by + ;; re-reading the body fresh. + [body + (cond + [(or (not cl) (<= cl 0)) ""] + [(> cl *max-body-size*) #f] + [else + (read-body fd buf extra-start cl)])]) + (cond + [(not body) #f] + [else + (make-request method path vsn hdrs body)]))]))]))) + + (define (read-body fd buf extra-start needed) + (let* ([buf-extra (max 0 (- (bytevector-length buf) extra-start))] + [out (make-bytevector needed)]) + ;; Copy whatever's already in the header buffer beyond the CRLFCRLF. + (let ([copy (min buf-extra needed)]) + (when (> copy 0) + (bytevector-copy! buf extra-start out 0 copy))) + (let loop ([filled (min buf-extra needed)]) + (cond + [(>= filled needed) (utf8->string-bv out 0 needed)] + [else + (let ([n (c-read fd (bv-tail-pointer out filled) + (- needed filled))]) + (cond + [(<= n 0) #f] + [else (loop (+ filled n))]))])))) + + (define (bv-tail-pointer bv offset) + ;; Build a sub-bytevector backing for read. We rely on Chez's + ;; bytevector being passed as u8* — we must pass a bytevector that + ;; *starts* at offset. Workaround: copy after read using a small + ;; staging buffer of exactly the requested size. + ;; + ;; Implementation: allocate a fresh bytevector for the read, then + ;; copy into the destination. This is what we actually do via the + ;; staging-read helper below. + (error 'bv-tail-pointer "unused — use staging-read")) + + ;; The c-read FFI takes a u8* (bytevector) — we can't compute mid- + ;; bytevector pointers safely. Use a staging buffer instead. + (define *stage-size* 4096) + + (define (read-bytes fd n) + ;; Read up to n bytes; return bytevector or #f on EOF/error. + (let ([stage (make-bytevector (min n *stage-size*))]) + (let ([got (c-read fd stage (bytevector-length stage))]) + (cond + [(<= got 0) #f] + [else + (let ([out (make-bytevector got)]) + (bytevector-copy! stage 0 out 0 got) + out)])))) + + ;; Re-implement read-request and read-body using read-bytes so we + ;; don't need bv-tail-pointer. Override the previous defs. + + (define (read-request* fd) + (let loop ([chunks '()] [total 0]) + (cond + [(>= total *max-header-size*) #f] + [else + (let ([blob (read-bytes fd + (- *max-header-size* total))]) + (cond + [(not blob) #f] + [else + (let* ([all (append-bvs (reverse (cons blob chunks)))] + [end (find-crlf-crlf all (bytevector-length all))]) + (cond + [end + ;; Got headers — parse, then read body if needed. + (let* ([hdr-text (utf8->string-bv all 0 end)] + [parsed (parse-headers hdr-text)]) + (cond + [(not parsed) #f] + [else + (let* ([method (vector-ref parsed 0)] + [path (vector-ref parsed 1)] + [vsn (vector-ref parsed 2)] + [hdrs (vector-ref parsed 3)] + [cl-pair (assoc "content-length" hdrs)] + [cl (and cl-pair + (string->number-safe (cdr cl-pair)))] + [body-start (+ end 4)] + [pre (- (bytevector-length all) body-start)] + [need (or cl 0)]) + (cond + [(> need *max-body-size*) #f] + [(<= need pre) + (let ([b (make-bytevector need)]) + (when (> need 0) + (bytevector-copy! all body-start + b 0 need)) + (make-request method path vsn hdrs + (utf8->string-bv b 0 need)))] + [else + (let* ([extra (- need pre)] + [b (make-bytevector need)]) + (when (> pre 0) + (bytevector-copy! all body-start + b 0 pre)) + (let read-loop ([filled pre]) + (cond + [(>= filled need) + (make-request method path vsn hdrs + (utf8->string-bv b 0 need))] + [else + (let ([more (read-bytes fd + (- need filled))]) + (cond + [(not more) #f] + [else + (bytevector-copy! more 0 + b filled + (bytevector-length more)) + (read-loop + (+ filled + (bytevector-length more)))]))])))]))]))] + [else + (loop (cons blob chunks) + (+ total (bytevector-length blob)))]))]))]))) +