Add secure rustls HTTPS daemon
ober
a29001097555b19a1c05bbe1fd035a62d697bb93
--- a/README.md +++ b/README.md @@ -72,10 +72,10 @@ exports the everyday language; specialized libraries are imported from | Persistent and generic collections | Persistent maps/vectors/sets/queues, sorted maps/sets, HAMT maps, weak collections, ephemerons, immutable values, lazy sequences, generic collection protocols, relation operations, tables, dataframes, datalog, lenses, zippers, Specter-style navigation. | | Clojure compatibility | Sequences, reducers, transducers, atoms, agents, refs/STM, protocols, multimethods, metadata, futures/promises/deref, EDN, walkers, zippers, nested data helpers, datafy, core.async-style CSP channels. | | Concurrency | Native OS threads with no GIL, atomics, mutex/condition wrappers, M:N fibers, fiber-aware events/channels, async/await, structured concurrency, work pools, resource pools, barriers, wait groups, actor systems, supervisors, distributed actors, CRDTs, Raft, STM, CSP. | -| Networking and web | HTTP client/server, fiber HTTP server, WebSocket/fiber WebSocket, HTTP/2, DNS, routers, rate limiting, connection pools, sendfile/zero-copy paths, TCP/UDP/TLS/rustls, SSH, S3, SMTP, SOCKS5, gRPC, JSON-RPC, 9P, FastCGI, Rack-style web adapters, event streams. | +| Networking and web | HTTP client/server, secure rustls HTTPS daemon, fiber HTTP server, WebSocket/fiber WebSocket, HTTP/2, DNS, routers, rate limiting, connection pools, sendfile/zero-copy paths, TCP/UDP/TLS/rustls, SSH, S3, SMTP, SOCKS5, gRPC, JSON-RPC, 9P, FastCGI, Rack-style web adapters, event streams. | | Text and protocols | JSON and JSON Schema, CSV, YAML, XML, HTML/SXML, TOML, INI, EDN, MessagePack, CBOR, Transit, protobuf, base58/base64/hex, UTF-8/16/32, globbing, diffs, templates, regex, native regex, PCRE2, `rx`, PEG parsers. | | Storage and databases | SQLite, PostgreSQL, DuckDB, LevelDB, DBI layer, query compilation, connection pools, mmap and mmap-btree helpers, content-addressed storage, image/closure persistence, package stores. | -| Native Rust backend | Optional `libjerboa_native` bindings for ring crypto, rustls TLS, ReDoS-resistant regex, flate2 compression, rusqlite/postgres/duckdb, secure memory, epoll, inotify, Landlock, packet capture, and panic-contained FFI entry points. | +| Native Rust backend | Optional `libjerboa_native` bindings for ring crypto, rustls TLS, Rust HTTP request parsing, ReDoS-resistant regex, flate2 compression, rusqlite/postgres/duckdb, secure memory, epoll, inotify, Landlock, packet capture, and panic-contained FFI entry points. | | Security and capabilities | Audit logging, auth, cages, capability and capability-typed I/O, import audit, flow/taint tracking, IO interception, Landlock, seccomp, Capsicum, seatbelt, sandboxing, sanitizers, secret handling, privilege separation, safe/pure audit tools. | | OS and runtime | Environment/path/fd/signal/process modules, errno/fcntl/flock, mmap, temp files, tty, aproc, exec identity, inotify, epoll, kqueue, io_uring, platform detection, supervised services. | | Typed and effect systems | Typed parser/checker, Rust/LLVMIR wrappers, affine and linear types, refinement, phantom, GADT, HKT, rows, typeclasses, effect typing, deep/scoped/resource effects, contracts and chaperones. | --- a/jerboa-native-rs/src/lib.rs +++ b/jerboa-native-rs/src/lib.rs @@ -42,7 +42,7 @@ mod wasm_sm; #[cfg(any(target_os = "linux", target_os = "android"))] mod epoll; -#[cfg(all(any(target_os = "linux", target_os = "android"), feature = "tls"))] +#[cfg(feature = "tls")] mod http_parse; #[cfg(target_os = "linux")] mod inotify_native; --- a/lib/std/net/httpd.ss +++ b/lib/std/net/httpd.ss @@ -21,6 +21,7 @@ (import (chezscheme) (prefix (std net thread-httpd) th:) + (prefix (std net httpsd) https:) (std text json) (only (jerboa core) def)) @@ -34,12 +35,19 @@ (config-port port-or-config) (adapt-handler handler))) - (def (httpd-start-https . _) - (error 'httpd-start-https - "HTTPS is not available through std/net/httpd; use std/net/tls-rustls with a dedicated HTTP handler")) + (def httpd-start-https + (case-lambda + [(config handler) + (https:httpsd-start* config (adapt-handler handler))] + [(port handler cert key) + (https:httpsd-start port (adapt-handler handler) cert key)] + [(port handler cert key . opts) + (apply https:httpsd-start port (adapt-handler handler) cert key opts)])) (def (httpd-stop server) - (th:thread-httpd-stop! server)) + (if (https:httpsd? server) + (https:httpsd-stop! server) + (th:thread-httpd-stop! server))) (def (config-port config) (cond new file mode 100644 --- /dev/null +++ b/lib/std/net/httpsd.ss @@ -0,0 +1,454 @@ +#!chezscheme +;;; (std net httpsd) -- rustls-backed HTTPS server. + +(library (std net httpsd) + (export + httpsd-start + httpsd-start* + httpsd-stop! + httpsd? + httpsd-listen-port) + + (import (chezscheme) + (std net tls-rustls) + (std net tcp-raw) + (prefix (std net thread-httpd) th:) + (std security sanitize) + (only (jerboa core) def try catch finally)) + + (def *parse-out-size* 270) + (def *parser-max-headers* 32) + + (def (native-unavailable who) + (lambda args + (error who + "HTTPSD native HTTP parser is unavailable; rebuild/load libjerboa_native with jerboa_http_parse"))) + + (def c-http-parse + (try + (foreign-procedure "jerboa_http_parse" (u8* size_t u8*) int) + (catch (e) (native-unavailable 'httpsd-start)))) + + (def *default-max-header-size* 8192) + (def *default-max-body-size* (* 4 1024 1024)) + (def *read-chunk-size* 4096) + + (define-record-type httpsd + (fields (immutable listen-fd) + (immutable listen-port) + (immutable tls-ctx) + (mutable running?) + (immutable max-header-size) + (immutable max-body-size)) + (sealed #t)) + + (def (httpsd-start port handler cert-path key-path + backlog: (backlog 128) + client-ca: (client-ca #f) + max-header-size: (max-header-size *default-max-header-size*) + max-body-size: (max-body-size *default-max-body-size*)) + (unless cert-path + (error 'httpsd-start "missing TLS certificate path; pass cert: or set TLS_CERT")) + (unless key-path + (error 'httpsd-start "missing TLS private key path; pass key: or set TLS_KEY")) + (when (> max-header-size 65535) + (error 'httpsd-start "max-header-size must be <= 65535 for the Rust parser ABI")) + (let ([tls-ctx #f] [listen-fd #f]) + (try + (begin + (set! tls-ctx + (if client-ca + (rustls-server-ctx-new-mtls cert-path key-path client-ca) + (rustls-server-ctx-new cert-path key-path))) + (set! listen-fd (tcp-listen port backlog)) + (let ([server (make-httpsd listen-fd port tls-ctx #t + max-header-size max-body-size)]) + (fork-thread + (lambda () + (httpsd-accept-loop server handler))) + server)) + (catch (e) + (when listen-fd (try (tcp-close listen-fd) (catch (close-e) (void)))) + (when tls-ctx (try (rustls-server-ctx-free tls-ctx) (catch (free-e) (void)))) + (raise e))))) + + (def (httpsd-start* config handler) + (let ([port (config-ref config '(port port:) 8443)] + [cert (config-ref config '(cert cert:) (getenv "TLS_CERT"))] + [key (config-ref config '(key key:) (getenv "TLS_KEY"))] + [client-ca (config-ref config '(client-ca client-ca:) #f)] + [backlog (config-ref config '(backlog backlog:) 128)] + [max-header-size (config-ref config '(max-header-size max-header-size:) + *default-max-header-size*)] + [max-body-size (config-ref config '(max-body-size max-body-size:) + *default-max-body-size*)]) + (httpsd-start port handler cert key + 'backlog: backlog + 'client-ca: client-ca + 'max-header-size: max-header-size + 'max-body-size: max-body-size))) + + (def (httpsd-stop! server) + (httpsd-running?-set! server #f) + (try (tcp-close (httpsd-listen-fd server)) + (catch (e) (void))) + (try (rustls-server-ctx-free (httpsd-tls-ctx server)) + (catch (e) (void))) + (void)) + + (def (config-ref config keys default) + (cond + [(not (pair? config)) default] + [else + (let loop ([xs config]) + (cond + [(null? xs) default] + [(and (pair? (cdr xs)) (memq (car xs) keys)) (cadr xs)] + [else (loop (cdr xs))]))])) + + (def (httpsd-accept-loop server handler) + (let loop () + (when (httpsd-running? server) + (let-values (((client-fd client-addr) + (try (tcp-accept (httpsd-listen-fd server)) + (catch (e) (values #f #f))))) + (when client-fd + (fork-thread + (lambda () + (handle-client server client-fd handler))))) + (loop)))) + + (def (handle-client server client-fd handler) + (let ([conn (try (rustls-accept (httpsd-tls-ctx server) client-fd) + (catch (e) #f))]) + (if conn + (begin + (try + (let-values (((status req) + (read-request conn + (httpsd-max-header-size server) + (httpsd-max-body-size server)))) + (cond + [req + (let ([resp (try (normalize-response (handler req)) + (catch (e) + (th:respond-text 500 "Internal Server Error\n")))]) + (write-response conn resp))] + [status (write-error-response conn status)] + [else (void)])) + (catch (e) + (try (write-error-response conn 500) + (catch (write-e) (void))))) + (try (rustls-close conn) + (catch (close-e) (void)))) + (try (tcp-close client-fd) + (catch (close-e) (void)))))) + + (def (normalize-response value) + (cond + [(th:response? value) value] + [(string? value) (th:respond-html 200 value)] + [(bytevector? value) (th:respond 200 '() value)] + [(not value) (th:respond-text 404 "Not Found\n")] + [else (th:respond-text 200 (format "~a" value))])) + + (def (read-request conn max-header-size max-body-size) + (let ([hdr-buf (make-bytevector max-header-size)] + [tmp (make-bytevector *read-chunk-size*)] + [parse-out (make-bytevector *parse-out-size* 0)]) + (let loop ([filled 0]) + (if (>= filled max-header-size) + (values 431 #f) + (let* ([want (min *read-chunk-size* (- max-header-size filled))] + [n (rustls-read conn tmp want)]) + (cond + [(<= n 0) (values #f #f)] + [else + (bytevector-copy! tmp 0 hdr-buf filled n) + (let ([total (+ filled n)]) + (let ([rc (c-http-parse hdr-buf total parse-out)]) + (if (< rc 0) + (values 400 #f) + (let ([status (bytevector-s32-native-ref parse-out 0)]) + (cond + [(> status 0) + (build-request conn hdr-buf status total parse-out + max-body-size)] + [(= status 0) (loop total)] + [else (values 400 #f)])))))])))))) + + (def (build-request conn hdr-buf header-end filled parse-out max-body-size) + (let* ((method (slice->string hdr-buf + (bytevector-u16-native-ref parse-out 4) + (bytevector-u16-native-ref parse-out 6))) + (path (slice->string hdr-buf + (bytevector-u16-native-ref parse-out 8) + (bytevector-u16-native-ref parse-out 10))) + (version (if (= (bytevector-u8-ref parse-out 12) 0) + "HTTP/1.0" "HTTP/1.1")) + (nhdrs (bytevector-u8-ref parse-out 13)) + (headers (extract-headers hdr-buf parse-out nhdrs))) + (cond + ((not (valid-method? method)) (values 400 #f)) + ((not (valid-path? path)) (values 400 #f)) + ((not (valid-header-set? headers version)) (values 400 #f)) + (else + (let ((cl (content-length headers))) + (cond + ((not cl) (values 400 #f)) + ((> cl max-body-size) (values 413 #f)) + (else + (let ((body (read-body conn hdr-buf header-end filled cl))) + (if body + (values #f + (th:make-request method path version + (ensure-https-header headers) + body)) + (values 400 #f)))))))))) + + (def (extract-headers hdr-buf parse-out nhdrs) + (let loop ([i 0] [acc '()]) + (if (>= i nhdrs) + (reverse acc) + (let* ([base (+ 14 (* i 8))] + [ns (bytevector-u16-native-ref parse-out base)] + [nl (bytevector-u16-native-ref parse-out (+ base 2))] + [vs (bytevector-u16-native-ref parse-out (+ base 4))] + [vl (bytevector-u16-native-ref parse-out (+ base 6))] + [name (string-downcase (slice->string hdr-buf ns nl))] + [val (trim-header-value (slice->string hdr-buf vs vl))]) + (loop (+ i 1) (cons (cons name val) acc)))))) + + (def (read-body conn hdr-buf header-end filled need) + (cond + [(<= need 0) ""] + [else + (let* ([body-start (+ header-end 4)] + [available (max 0 (- filled body-start))] + [pre (min available need)] + [out (make-bytevector need)]) + (when (> pre 0) + (bytevector-copy! hdr-buf body-start out 0 pre)) + (let loop ([got pre]) + (cond + [(>= got need) (try (utf8->string out) (catch (e) #f))] + [else + (let* ([chunk-len (min *read-chunk-size* (- need got))] + [tmp (make-bytevector chunk-len)] + [n (rustls-read conn tmp chunk-len)]) + (if (<= n 0) + #f + (begin + (bytevector-copy! tmp 0 out got n) + (loop (+ got n)))))])))])) + + (def (content-length headers) + (let loop ([xs headers] [seen? #f] [value 0]) + (cond + [(null? xs) value] + [(string=? (caar xs) "content-length") + (if seen? + #f + (let ([n (parse-nonnegative-decimal (cdar xs))]) + (and n (loop (cdr xs) #t n))))] + [else (loop (cdr xs) seen? value)]))) + + (def (valid-header-set? headers version) + (and (<= (length headers) *parser-max-headers*) + (all-headers-safe? headers) + (not (assoc "transfer-encoding" headers)) + (if (string=? version "HTTP/1.1") + (= (count-header headers "host") 1) + (<= (count-header headers "host") 1)))) + + (def (all-headers-safe? headers) + (let loop ([xs headers]) + (cond + [(null? xs) #t] + [(and (valid-header-name? (caar xs)) + (safe-header-value? (cdar xs))) + (loop (cdr xs))] + [else #f]))) + + (def (count-header headers name) + (let loop ([xs headers] [n 0]) + (cond + [(null? xs) n] + [(string=? (caar xs) name) (loop (cdr xs) (+ n 1))] + [else (loop (cdr xs) n)]))) + + (def (ensure-https-header headers) + (if (assoc "x-forwarded-proto" headers) + headers + (cons (cons "x-forwarded-proto" "https") headers))) + + (def (write-error-response conn status) + (write-response conn + (th:respond-text status + (string-append (status-text status) "\n")))) + + (def (write-response conn resp) + (let* ([body (th:response-body resp)] + [body-bv (cond + [(not body) (make-bytevector 0)] + [(bytevector? body) body] + [(string? body) (string->utf8 body)] + [else (string->utf8 (format "~a" body))])] + [header-bv (string->utf8 + (response-header-text + (th:response-status resp) + (th:response-headers resp) + (bytevector-length body-bv)))]) + (tls-write-all conn header-bv) + (when (> (bytevector-length body-bv) 0) + (tls-write-all conn body-bv)))) + + (def (response-header-text status headers body-length) + (let ([out (open-output-string)]) + (display "HTTP/1.1 " out) + (display status out) + (display " " out) + (display (status-text status) out) + (display "\r\n" out) + (for-each + (lambda (header) + (when (safe-response-header? header) + (display (car header) out) + (display ": " out) + (display (sanitize-header-value (format "~a" (cdr header))) out) + (display "\r\n" out))) + headers) + (display "Content-Length: " out) + (display body-length out) + (display "\r\nConnection: close\r\n\r\n" out) + (get-output-string out))) + + (def (safe-response-header? header) + (and (pair? header) + (string? (car header)) + (valid-header-name? (car header)) + (not (hop-by-hop-header? (car header))) + (not (content-length-header? (car header))) + (safe-header-value? (format "~a" (cdr header))))) + + (def (tls-write-all conn bv) + (let ([len (bytevector-length bv)]) + (let loop ([offset 0]) + (when (< offset len) + (let* ([remaining (- len offset)] + [chunk (bytevector-copy-range bv offset len)] + [n (rustls-write conn chunk remaining)]) + (if (> n 0) + (loop (+ offset n)) + (error 'httpsd-write "TLS write failed"))))))) + + (def (slice->string bv start len) + (utf8->string (bytevector-copy-range bv start (+ start len)))) + + (def (bytevector-copy-range bv start end) + (let* ([len (- end start)] + [out (make-bytevector len)]) + (when (> len 0) + (bytevector-copy! bv start out 0 len)) + out)) + + (def (valid-method? s) + (and (> (string-length s) 0) + (token-string? s))) + + (def (valid-path? s) + (and (> (string-length s) 0) + (not (string-contains-char? s #\return)) + (not (string-contains-char? s #\newline)) + (not (string-contains-char? s #\nul)) + (or (char=? (string-ref s 0) #\/) + (string=? s "*")))) + + (def (valid-header-name? s) + (and (> (string-length s) 0) + (token-string? s))) + + (def (token-string? s) + (let ([len (string-length s)]) + (let loop ([i 0]) + (cond + [(= i len) #t] + [(token-char? (string-ref s i)) (loop (+ i 1))] + [else #f])))) + + (def (token-char? c) + (let ([n (char->integer c)]) + (or (and (>= n 48) (<= n 57)) + (and (>= n 65) (<= n 90)) + (and (>= n 97) (<= n 122)) + (memv c '(#\! #\# #\$ #\% #\& #\' #\* #\+ #\- #\. #\^ #\_ #\` #\| #\~))))) + + (def (safe-header-value? s) + (and (string? s) + (not (string-contains-char? s #\return)) + (not (string-contains-char? s #\newline)) + (not (string-contains-char? s #\nul)))) + + (def (string-contains-char? s ch) + (let ([len (string-length s)]) + (let loop ([i 0]) + (cond + [(= i len) #f] + [(char=? (string-ref s i) ch) #t] + [else (loop (+ i 1))])))) + + (def (trim-header-value s) + (let* ([len (string-length s)] + [start (let loop ([i 0]) + (cond + [(= i len) i] + [(ows? (string-ref s i)) (loop (+ i 1))] + [else i]))] + [end (let loop ([i len]) + (cond + [(= i start) i] + [(ows? (string-ref s (- i 1))) (loop (- i 1))] + [else i]))]) + (substring s start end))) + + (def (ows? c) + (or (char=? c #\space) (char=? c #\tab))) + + (def (parse-nonnegative-decimal s) + (let ([len (string-length s)]) + (and (> len 0) + (let loop ([i 0] [n 0]) + (cond + [(= i len) n] + [else + (let ([d (- (char->integer (string-ref s i)) 48)]) + (and (>= d 0) (<= d 9) + (loop (+ i 1) (+ (* n 10) d))))]))))) + + (def (hop-by-hop-header? name) + (let ([n (string-downcase name)]) + (or (string=? n "connection") + (string=? n "keep-alive") + (string=? n "proxy-authenticate") + (string=? n "proxy-authorization") + (string=? n "te") + (string=? n "trailer") + (string=? n "transfer-encoding") + (string=? n "upgrade")))) + + (def (content-length-header? name) + (string=? (string-downcase name) "content-length")) + + (def (status-text code) + (case code + [(200) "OK"] [(201) "Created"] [(202) "Accepted"] [(204) "No Content"] + [(301) "Moved Permanently"] [(302) "Found"] [(304) "Not Modified"] + [(400) "Bad Request"] [(401) "Unauthorized"] [(403) "Forbidden"] + [(404) "Not Found"] [(405) "Method Not Allowed"] [(409) "Conflict"] + [(413) "Payload Too Large"] [(414) "URI Too Long"] + [(431) "Request Header Fields Too Large"] + [(500) "Internal Server Error"] [(501) "Not Implemented"] + [(502) "Bad Gateway"] [(503) "Service Unavailable"] [(504) "Gateway Timeout"] + [else "Unknown"])) + + ) ;; end library --- a/support/build-static-script.sh +++ b/support/build-static-script.sh @@ -199,6 +199,9 @@ extern void jerboa_tls_close(unsigned long long); extern int jerboa_tls_set_nonblock(unsigned long long,int); extern int jerboa_tls_get_fd(unsigned long long); extern unsigned long long jerboa_last_error(unsigned char*,unsigned long long); +/* HTTP parser / scatter-gather write */ +extern int jerboa_http_parse(unsigned char*,unsigned long long,unsigned char*); +extern long jerboa_writev2(int,unsigned char*,unsigned long long,unsigned char*,unsigned long long); /* Crypto — correct names (not jerboa_sha/hmac/argon/pbkdf/chacha/md) */ extern int jerboa_sha1(unsigned char*,unsigned long long,unsigned char*,unsigned long long); extern int jerboa_sha256(unsigned char*,unsigned long long,unsigned char*,unsigned long long); @@ -289,6 +292,8 @@ static void custom_init(void) { Sforeign_symbol("jerboa_tls_set_nonblock", (void *)jerboa_tls_set_nonblock); Sforeign_symbol("jerboa_tls_get_fd", (void *)jerboa_tls_get_fd); Sforeign_symbol("jerboa_last_error", (void *)jerboa_last_error); + Sforeign_symbol("jerboa_http_parse", (void *)jerboa_http_parse); + Sforeign_symbol("jerboa_writev2", (void *)jerboa_writev2); /* Crypto — actual symbol names from libjerboa_native.a */ Sforeign_symbol("jerboa_sha1", (void *)jerboa_sha1); Sforeign_symbol("jerboa_sha256", (void *)jerboa_sha256);