Use Jerboa HTTPS daemon
ober
29dfbe90a83c79dfdd5c255bf55aa55c9d992047
--- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ The Makefile uses `~/mine/jerboa` by default. Override with `JERBOA_HOME=/path/t ## HTTPS Site Binary -`secure-site.ss` is a minimal production entrypoint. It serves embedded content over rustls-backed HTTPS and adds strict security headers. +`secure-site.ss` is a minimal production entrypoint. It serves embedded content over Jerboa's `(std net httpsd)` rustls HTTPS daemon and adds strict security headers. HTTPSD uses Rust request parsing and rejects ambiguous framing such as duplicate `Content-Length`, `Transfer-Encoding`, missing HTTP/1.1 `Host`, oversized headers, and oversized bodies before the Sinatra handler runs. ```sh make binary --- a/sinatra/dsl.ss +++ b/sinatra/dsl.ss @@ -162,12 +162,18 @@ port: (port #f) cert: (cert #f) key: (key #f) - backlog: (backlog 128)) + backlog: (backlog 128) + client-ca: (client-ca #f) + max-header-size: (max-header-size 8192) + max-body-size: (max-body-size (* 4 1024 1024))) (tls:run-tls! the-app port: (or port (app-setting the-app "tls-port") 8443) cert: cert key: key - backlog: backlog)) + backlog: backlog + client-ca: client-ca + max-header-size: max-header-size + max-body-size: max-body-size)) ;; ============================================================ ;; Modular-style (explicit app) functions @@ -219,5 +225,15 @@ port: (port #f) cert: (cert #f) key: (key #f) - backlog: (backlog 128)) - (run-https! app port: port cert: cert key: key backlog: backlog)) + backlog: (backlog 128) + client-ca: (client-ca #f) + max-header-size: (max-header-size 8192) + max-body-size: (max-body-size (* 4 1024 1024))) + (run-https! app + port: port + cert: cert + key: key + backlog: backlog + client-ca: client-ca + max-header-size: max-header-size + max-body-size: max-body-size)) --- a/sinatra/tls.ss +++ b/sinatra/tls.ss @@ -1,8 +1,5 @@ -(import (std net tls-rustls) - (std net tcp-raw) - (prefix (std net thread-httpd) th:) +(import (std net httpsd) (std format) - (sinatra app) (sinatra handler)) (export run-tls! @@ -11,324 +8,26 @@ sinatra-tls-server-port sinatra-tls-stop!) -(defstruct sinatra-tls-server - (listen-fd port tls-ctx running?) - transparent: #t) - -(def *tls-max-header-size* 16384) -(def *tls-max-body-size* (* 4 1024 1024)) -(def *tls-read-chunk-size* 4096) - (def (run-tls! app port: (port 8443) cert: (cert (getenv "TLS_CERT")) key: (key (getenv "TLS_KEY")) - backlog: (backlog 128)) - (unless cert - (error 'run-tls! "missing TLS certificate path; pass cert: or set TLS_CERT")) - (unless key - (error 'run-tls! "missing TLS private key path; pass key: or set TLS_KEY")) - (let* ((tls-ctx (rustls-server-ctx-new cert key)) - (listen-fd (tcp-listen port backlog)) - (server (make-sinatra-tls-server listen-fd port tls-ctx #t)) - (handler (sinatra-handler app))) - (fork-thread - (lambda () - (tls-accept-loop server handler))) + backlog: (backlog 128) + client-ca: (client-ca #f) + max-header-size: (max-header-size 8192) + max-body-size: (max-body-size (* 4 1024 1024))) + (let ((server (httpsd-start port + (sinatra-handler app) + cert + key + backlog: backlog + client-ca: client-ca + max-header-size: max-header-size + max-body-size: max-body-size))) (displayln (format "== Sinatra HTTPS is listening on port ~a ==" port)) server)) (def sinatra-run-tls! run-tls!) - -(def (sinatra-tls-stop! server) - (sinatra-tls-server-running?-set! server #f) - (try (tcp-close (sinatra-tls-server-listen-fd server)) - (catch (e) (void))) - (try (rustls-server-ctx-free (sinatra-tls-server-tls-ctx server)) - (catch (e) (void))) - (void)) - -(def (tls-accept-loop server handler) - (let loop () - (when (sinatra-tls-server-running? server) - (let-values (((client-fd client-addr) - (try (tcp-accept (sinatra-tls-server-listen-fd server)) - (catch (e) (values #f #f))))) - (when client-fd - (fork-thread - (lambda () - (handle-tls-client (sinatra-tls-server-tls-ctx server) - client-fd handler))))) - (loop)))) - -(def (handle-tls-client tls-ctx client-fd handler) - (let ((conn (try (rustls-accept tls-ctx client-fd) - (catch (e) #f)))) - (if conn - (begin - (try - (let ((req (read-tls-request conn))) - (when req - (write-tls-response conn (normalize-response (handler req))))) - (catch (e) (void))) - (try (rustls-close conn) - (catch (e) (void)))) - (try (tcp-close client-fd) - (catch (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")) - (else (th:respond-text 200 (format "~a" value))))) - -(def (read-tls-request conn) - (let loop ((chunks '()) (total 0)) - (cond - ((>= total *tls-max-header-size*) #f) - (else - (let* ((buf (make-bytevector (min *tls-read-chunk-size* - (- *tls-max-header-size* total)))) - (n (rustls-read conn buf (bytevector-length buf)))) - (cond - ((<= n 0) #f) - (else - (let* ((chunk (bytevector-copy-range buf 0 n)) - (all (append-bytevectors (reverse (cons chunk chunks)))) - (header-end (find-crlf-crlf all (bytevector-length all)))) - (if header-end - (parse-tls-request conn all header-end) - (loop (cons chunk chunks) - (+ total (bytevector-length chunk)))))))))))) - -(def (parse-tls-request conn all header-end) - (let* ((header-text (utf8->string-range all 0 header-end)) - (parsed (parse-headers header-text))) - (if (not parsed) - #f - (let* ((method (vector-ref parsed 0)) - (path (vector-ref parsed 1)) - (version (vector-ref parsed 2)) - (headers (ensure-https-header (vector-ref parsed 3))) - (content-length-entry (assoc "content-length" headers)) - (content-length (or (and content-length-entry - (string->number-safe - (cdr content-length-entry))) - 0)) - (body-start (+ header-end 4))) - (cond - ((> content-length *tls-max-body-size*) #f) - (else - (let ((body (read-tls-body conn all body-start content-length))) - (and body - (th:make-request method path version headers body))))))))) - -(def (read-tls-body conn all body-start need) - (cond - ((<= need 0) "") - (else - (let* ((available (- (bytevector-length all) body-start)) - (pre (max 0 (min available need))) - (out (make-bytevector need))) - (when (> pre 0) - (bytevector-copy! all body-start out 0 pre)) - (let loop ((filled pre)) - (cond - ((>= filled need) (utf8->string-range out 0 need)) - (else - (let* ((buf (make-bytevector - (min *tls-read-chunk-size* (- need filled)))) - (n (rustls-read conn buf (bytevector-length buf)))) - (if (<= n 0) - #f - (begin - (bytevector-copy! buf 0 out filled n) - (loop (+ filled n)))))))))))) - -(def (ensure-https-header headers) - (if (assoc "x-forwarded-proto" headers) - headers - (cons (cons "x-forwarded-proto" "https") headers))) - -(def (write-tls-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 (and (pair? header) - (not (connection-header? (car header))) - (not (content-length-header? (car header)))) - (display (car header) out) - (display ": " out) - (display (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 (tls-write-all conn bv) - (let ((len (bytevector-length bv))) - (let loop ((offset 0)) - (when (< offset len) - (let* ((chunk (bytevector-copy-range bv offset len)) - (n (rustls-write conn chunk (bytevector-length chunk)))) - (when (> n 0) - (loop (+ offset n)))))))) - -(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 (append-bytevectors bvs) - (let* ((total (apply + (map bytevector-length bvs))) - (out (make-bytevector total))) - (let loop ((rest bvs) (offset 0)) - (if (null? rest) - out - (let ((bv (car rest))) - (bytevector-copy! bv 0 out offset (bytevector-length bv)) - (loop (cdr rest) (+ offset (bytevector-length bv)))))))) - -(def (utf8->string-range bv start len) - (utf8->string (bytevector-copy-range bv start (+ start len)))) - -(def (find-crlf-crlf bv len) - (let loop ((i 0)) - (cond - ((> (+ i 4) len) #f) - ((and (= (bytevector-u8-ref bv i) 13) - (= (bytevector-u8-ref bv (+ i 1)) 10) - (= (bytevector-u8-ref bv (+ i 2)) 13) - (= (bytevector-u8-ref bv (+ i 3)) 10)) - i) - (else (loop (+ i 1)))))) - -(def (parse-headers text) - (let* ((lines (split-crlf text)) - (first (and (pair? lines) (car lines)))) - (if (not first) - #f - (let ((parts (split-spaces first))) - (if (not (= (length parts) 3)) - #f - (vector (car parts) - (cadr parts) - (caddr parts) - (parse-header-lines (cdr lines)))))))) - -(def (parse-header-lines lines) - (let loop ((rest lines) (headers '())) - (cond - ((null? rest) (reverse headers)) - ((string=? (car rest) "") (reverse headers)) - (else - (let ((colon (string-index (car rest) #\:))) - (if (not colon) - (loop (cdr rest) headers) - (let ((name (string-downcase (substring (car rest) 0 colon))) - (value (string-trim (substring (car rest) (+ colon 1) - (string-length (car rest)))))) - (loop (cdr rest) (cons (cons name value) headers))))))))) - -(def (split-crlf s) - (let ((n (string-length s))) - (let loop ((i 0) (start 0) (parts '())) - (cond - ((> (+ i 2) n) - (reverse (cons (substring s start n) parts))) - ((and (char=? (string-ref s i) #\return) - (char=? (string-ref s (+ i 1)) #\newline)) - (loop (+ i 2) (+ i 2) (cons (substring s start i) parts))) - (else (loop (+ i 1) start parts)))))) - -(def (split-spaces s) - (let ((n (string-length s))) - (let loop ((i 0) (start 0) (parts '())) - (cond - ((= i n) - (let ((final (substring s start n))) - (if (string=? final "") - (reverse parts) - (reverse (cons final parts))))) - ((char=? (string-ref s i) #\space) - (let ((part (substring s start i))) - (if (string=? part "") - (loop (+ i 1) (+ i 1) parts) - (loop (+ i 1) (+ i 1) (cons part parts))))) - (else (loop (+ i 1) start parts)))))) - -(def (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)))))) - -(def (string-trim s) - (let* ((n (string-length s)) - (start (let loop ((i 0)) - (cond - ((= i n) i) - ((char-whitespace? (string-ref s i)) (loop (+ i 1))) - (else i)))) - (end (let loop ((i n)) - (cond - ((= i 0) 0) - ((char-whitespace? (string-ref s (- i 1))) (loop (- i 1))) - (else i))))) - (if (>= start end) - "" - (substring s start end)))) - -(def (string->number-safe s) - (try (string->number s) - (catch (e) #f))) - -(def (connection-header? name) - (string=? (string-downcase name) "connection")) - -(def (content-length-header? name) - (string=? (string-downcase name) "content-length")) - -(def (status-text code) - (cond - ((= code 200) "OK") - ((= code 201) "Created") - ((= code 204) "No Content") - ((= code 301) "Moved Permanently") - ((= code 302) "Found") - ((= code 304) "Not Modified") - ((= code 400) "Bad Request") - ((= code 401) "Unauthorized") - ((= code 403) "Forbidden") - ((= code 404) "Not Found") - ((= code 405) "Method Not Allowed") - ((= code 500) "Internal Server Error") - (else "OK"))) +(def sinatra-tls-server? httpsd?) +(def sinatra-tls-server-port httpsd-listen-port) +(def sinatra-tls-stop! httpsd-stop!)