Add HTTPS static site binary support
ober
114bd9bb4b947f2414100a136425c237705b64b9
--- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ build/ +dist/ *.so *.wpo *.o --- a/Makefile +++ b/Makefile @@ -6,8 +6,16 @@ BUILD_DIR ?= build SRC_STAGE := $(BUILD_DIR)/src LIB_STAGE := $(BUILD_DIR)/lib LIBDIRS := $(LIB_STAGE):$(JERBOA_HOME)/lib +ENTRY ?= secure-site.ss +BINARY_OUTPUT ?= dist/jerboa-sinatra-site +STATIC_BINARY_OUTPUT ?= dist/jerboa-sinatra-site-linux-amd64 +PROJECT_LIBDIRS := $(abspath $(LIB_STAGE)):$(JERBOA_HOME)/lib +STATIC_TARGET_MACHINE ?= ta6le +STATIC_CHEZ_PREFIX ?= $(JERBOA_HOME)/.chez-cross-$(STATIC_TARGET_MACHINE) +STATIC_XPATCH ?= $(JERBOA_HOME)/build/chez/xc-$(STATIC_TARGET_MACHINE)/s/xpatch +STATIC_MUSL_CC ?= x86_64-linux-musl-gcc -.PHONY: build test example clean +.PHONY: build test example binary static-binary clean distclean build: rm -rf $(SRC_STAGE) $(LIB_STAGE) @@ -19,8 +27,29 @@ build: test: build $(SCHEME) --libdirs $(LIBDIRS) --script test-runner.ss +binary: build + mkdir -p $(dir $(BINARY_OUTPUT)) + BINARY_LIBDIRS="$(PROJECT_LIBDIRS)" $(JERBOA_HOME)/support/build-binary.sh $(ENTRY) $(BINARY_OUTPUT) + +static-binary: build + @ls "$(STATIC_CHEZ_PREFIX)"/lib/csv*/"$(STATIC_TARGET_MACHINE)"/libkernel.a >/dev/null 2>&1 || { echo "ERROR: static Chez libkernel not found under $(STATIC_CHEZ_PREFIX); override STATIC_CHEZ_PREFIX or build the cross Chez first" >&2; exit 1; } + @test -f "$(STATIC_XPATCH)" || { echo "ERROR: xpatch not found at $(STATIC_XPATCH); override STATIC_XPATCH or build the cross Chez first" >&2; exit 1; } + @command -v "$(STATIC_MUSL_CC)" >/dev/null 2>&1 || { echo "ERROR: $(STATIC_MUSL_CC) not on PATH" >&2; exit 1; } + mkdir -p $(dir $(STATIC_BINARY_OUTPUT)) + BINARY_LIBDIRS="$(PROJECT_LIBDIRS)" \ + JERBOA_HOME="$(JERBOA_HOME)" \ + JERBOA_MUSL_CHEZ_PREFIX="$(STATIC_CHEZ_PREFIX)" \ + JERBOA_XPATCH="$(STATIC_XPATCH)" \ + TARGET_MACHINE="$(STATIC_TARGET_MACHINE)" \ + MUSL_CC="$(STATIC_MUSL_CC)" \ + SCHEME="$(SCHEME)" \ + $(JERBOA_HOME)/support/build-static-script.sh $(ENTRY) $(STATIC_BINARY_OUTPUT) + example: build $(SCHEME) --libdirs $(LIBDIRS) --script example.ss clean: rm -rf $(BUILD_DIR) + +distclean: clean + rm -rf dist --- a/README.md +++ b/README.md @@ -15,3 +15,20 @@ make test ``` The Makefile uses `~/mine/jerboa` by default. Override with `JERBOA_HOME=/path/to/jerboa` if needed. + +## HTTPS Site Binary + +`secure-site.ss` is a minimal production entrypoint. It serves embedded content over rustls-backed HTTPS and adds strict security headers. + +```sh +make binary +TLS_CERT=/path/fullchain.pem TLS_KEY=/path/privkey.pem PORT=8443 ./dist/jerboa-sinatra-site +``` + +For a fully static Linux amd64 binary: + +```sh +make static-binary +``` + +That target uses Jerboa's local ta6le cross Chez, xpatch, `x86_64-linux-musl-gcc`, and `libjerboa_native.a`. The output is `dist/jerboa-sinatra-site-linux-amd64`. new file mode 100644 --- /dev/null +++ b/secure-site.ss @@ -0,0 +1,45 @@ +#!chezscheme + +(import (chezscheme) + (only (std misc thread) thread-sleep!) + (sinatra) + (sinatra security)) + +(set-option! "environment" "production") +(set-option! "static" #f) + +(define home-page + "<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><meta name=\"viewport\" content=\"width=device-width,initial-scale=1\"><title>jerboa-sinatra</title><style>body{margin:0;font-family:system-ui,sans-serif;background:#0d1117;color:#f0f6fc;display:grid;min-height:100vh;place-items:center}main{max-width:42rem;padding:2rem}h1{font-size:2.5rem;margin:0 0 1rem}p{line-height:1.6;color:#c9d1d9}</style></head><body><main><h1>jerboa-sinatra</h1><p>This page is embedded in the executable and served over rustls-backed HTTPS with strict response headers.</p></main></body></html>") + +(before + (secure-headers!)) + +(GET "/" + (content-type! "text/html; charset=utf-8") + home-page) + +(GET "/healthz" + (content-type! "text/plain; charset=utf-8") + "ok\n") + +(not-found + (status! 404) + (content-type! "text/plain; charset=utf-8") + "not found\n") + +(define (env-number name default) + (let ((value (getenv name))) + (if value + (or (string->number value) default) + default))) + +(define (main) + (let ((port (env-number "PORT" 8443)) + (cert (getenv "TLS_CERT")) + (key (getenv "TLS_KEY"))) + (run-https! default-app 'port: port 'cert: cert 'key: key) + (let loop () + (thread-sleep! 3600) + (loop)))) + +(main) --- a/sinatra.ss +++ b/sinatra.ss @@ -17,6 +17,8 @@ (sinatra cookies) (sinatra session) (sinatra static) + (sinatra security) + (sinatra tls) (sinatra template) (sinatra middleware) (sinatra logging) @@ -38,13 +40,14 @@ use! ;; Server RUN! run! + RUN-HTTPS! run-https! ;; Modular-style (explicit app) sinatra-get sinatra-post sinatra-put sinatra-delete sinatra-patch sinatra-options sinatra-head sinatra-before sinatra-after sinatra-not-found sinatra-error-handler - sinatra-run! + sinatra-run! sinatra-run-https! make-sinatra-app default-app ;; Context accessors @@ -92,6 +95,13 @@ ;; Logging sinatra-logger current-logger log-request + ;; Security and HTTPS + default-content-security-policy default-security-headers + secure-headers! + run-tls! run-https! + sinatra-run-tls! sinatra-run-https! + sinatra-tls-server? sinatra-tls-server-port sinatra-tls-stop! + ;; App settings app-setting app-setting-set! app-enable! app-disable! app-add-route! app-add-before! app-add-after! --- a/sinatra/dsl.ss +++ b/sinatra/dsl.ss @@ -3,7 +3,8 @@ (sinatra app) (sinatra handler) (sinatra context) - (sinatra helpers)) + (sinatra helpers) + (prefix (sinatra tls) tls:)) (export GET POST PUT DELETE PATCH OPTIONS HEAD get post put delete* patch options head @@ -13,11 +14,13 @@ set-option! enable! disable! use! RUN! run! + RUN-HTTPS! run-https! sinatra-get sinatra-post sinatra-put sinatra-delete sinatra-patch sinatra-options sinatra-head sinatra-before sinatra-after sinatra-not-found sinatra-error-handler - sinatra-run!) + sinatra-run! + sinatra-run-https!) ;; ============================================================ ;; Uppercase route macros — wrap body in lambda @@ -142,6 +145,9 @@ (defrules RUN! () ((_) (run!))) +(defrules RUN-HTTPS! () + ((_) (run-https!))) + (def (run! (the-app default-app) port: (port #f) bind: (bind #f)) @@ -152,6 +158,17 @@ (displayln (format "== Sinatra has taken the stage on port ~a ==" port)) srv))) +(def (run-https! (the-app default-app) + port: (port #f) + cert: (cert #f) + key: (key #f) + backlog: (backlog 128)) + (tls:run-tls! the-app + port: (or port (app-setting the-app "tls-port") 8443) + cert: cert + key: key + backlog: backlog)) + ;; ============================================================ ;; Modular-style (explicit app) functions ;; ============================================================ @@ -197,3 +214,10 @@ (def (sinatra-run! app port: (port #f) bind: (bind #f)) (run! app port: port bind: bind)) + +(def (sinatra-run-https! app + port: (port #f) + cert: (cert #f) + key: (key #f) + backlog: (backlog 128)) + (run-https! app port: port cert: cert key: key backlog: backlog)) new file mode 100644 --- /dev/null +++ b/sinatra/security.ss @@ -0,0 +1,25 @@ +(import (sinatra helpers)) + +(export default-content-security-policy + default-security-headers + secure-headers!) + +(def default-content-security-policy + "default-src 'self'; base-uri 'self'; frame-ancestors 'none'; form-action 'self'; object-src 'none'") + +(def default-security-headers + (list + (cons "Strict-Transport-Security" "max-age=31536000; includeSubDomains") + (cons "Content-Security-Policy" default-content-security-policy) + (cons "X-Content-Type-Options" "nosniff") + (cons "X-Frame-Options" "DENY") + (cons "Referrer-Policy" "no-referrer") + (cons "Permissions-Policy" + "accelerometer=(), camera=(), geolocation=(), gyroscope=(), magnetometer=(), microphone=(), payment=(), usb=()") + (cons "Cross-Origin-Opener-Policy" "same-origin") + (cons "Cross-Origin-Resource-Policy" "same-origin"))) + +(def (secure-headers! . maybe-headers) + (headers! (if (null? maybe-headers) + default-security-headers + (car maybe-headers)))) new file mode 100644 --- /dev/null +++ b/sinatra/tls.ss @@ -0,0 +1,334 @@ +(import (std net tls-rustls) + (std net tcp-raw) + (prefix (std net thread-httpd) th:) + (std format) + (sinatra app) + (sinatra handler)) + +(export run-tls! + sinatra-run-tls! + sinatra-tls-server? + 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))) + (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")))