Harden Jerboa HTTPSD and static binary builds
ober
5f4854ebb01c9637edc731d2c6dd7842556c6795
--- a/lib/std/net/httpsd.ss +++ b/lib/std/net/httpsd.ss @@ -7,7 +7,8 @@ httpsd-start* httpsd-stop! httpsd? - httpsd-listen-port) + httpsd-listen-port + httpsd-default-security-headers) (import (chezscheme) (std net tls-rustls) @@ -24,6 +25,40 @@ (error who "HTTPSD native HTTP parser is unavailable; rebuild/load libjerboa_native with jerboa_http_parse"))) + (def (httpsd-debug-enabled?) + (let ([v (getenv "JERBOA_HTTPSD_DEBUG")]) + (and v (not (string=? v "")) (not (string=? v "0"))))) + + (def (httpsd-debug . parts) + (when (httpsd-debug-enabled?) + (let ([err (current-error-port)]) + (display "httpsd: " err) + (for-each (lambda (part) (display part err)) parts) + (newline err) + (flush-output-port err)))) + + (def (debug-byte-preview bv len) + (let* ([n (min len 200)] + [copy (make-bytevector n)]) + (when (> n 0) + (bytevector-copy! bv 0 copy 0 n)) + (try + (visible-string (utf8->string copy)) + (catch (e) "<non-utf8 request bytes>")))) + + (def (visible-string s) + (let ([out (open-output-string)]) + (let loop ([i 0]) + (when (< i (string-length s)) + (let ([ch (string-ref s i)]) + (cond + [(char=? ch #\return) (display "\\r" out)] + [(char=? ch #\newline) (display "\\n" out)] + [(char=? ch #\tab) (display "\\t" out)] + [else (display ch out)])) + (loop (+ i 1)))) + (get-output-string out))) + (def c-http-parse (try (foreign-procedure "jerboa_http_parse" (u8* size_t u8*) int) @@ -32,6 +67,15 @@ (def *default-max-header-size* 8192) (def *default-max-body-size* (* 4 1024 1024)) (def *read-chunk-size* 4096) + (def httpsd-default-security-headers + '(("Strict-Transport-Security" . "max-age=31536000; includeSubDomains") + ("Content-Security-Policy" . "default-src 'none'; base-uri 'none'; frame-ancestors 'none'; form-action 'none'; object-src 'none'") + ("X-Content-Type-Options" . "nosniff") + ("X-Frame-Options" . "DENY") + ("Referrer-Policy" . "no-referrer") + ("Permissions-Policy" . "accelerometer=(), camera=(), geolocation=(), gyroscope=(), magnetometer=(), microphone=(), payment=(), usb=()") + ("Cross-Origin-Opener-Policy" . "same-origin") + ("Cross-Origin-Resource-Policy" . "same-origin"))) (define-record-type httpsd (fields (immutable listen-fd) @@ -39,14 +83,16 @@ (immutable tls-ctx) (mutable running?) (immutable max-header-size) - (immutable max-body-size)) + (immutable max-body-size) + (immutable security-headers)) (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*)) + max-body-size: (max-body-size *default-max-body-size*) + security-headers: (security-headers httpsd-default-security-headers)) (unless cert-path (error 'httpsd-start "missing TLS certificate path; pass cert: or set TLS_CERT")) (unless key-path @@ -62,7 +108,7 @@ (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)]) + max-header-size max-body-size security-headers)]) (fork-thread (lambda () (httpsd-accept-loop server handler))) @@ -81,12 +127,15 @@ [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*)]) + *default-max-body-size*)] + [security-headers (config-ref config '(security-headers security-headers:) + httpsd-default-security-headers)]) (httpsd-start port handler cert key 'backlog: backlog 'client-ca: client-ca 'max-header-size: max-header-size - 'max-body-size: max-body-size))) + 'max-body-size: max-body-size + 'security-headers: security-headers))) (def (httpsd-stop! server) (httpsd-running?-set! server #f) @@ -133,11 +182,11 @@ (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)] + (write-response conn (apply-security-headers server resp)))] + [status (write-error-response server conn status)] [else (void)])) (catch (e) - (try (write-error-response conn 500) + (try (write-error-response server conn 500) (catch (write-e) (void))))) (try (rustls-close conn) (catch (close-e) (void)))) @@ -168,14 +217,20 @@ (let ([total (+ filled n)]) (let ([rc (c-http-parse hdr-buf total parse-out)]) (if (< rc 0) - (values 400 #f) + (begin + (httpsd-debug "native parser call failed") + (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)])))))])))))) + [else + (httpsd-debug "parser rejected request after " total + " byte(s): " + (debug-byte-preview hdr-buf total)) + (values 400 #f)])))))])))))) (def (build-request conn hdr-buf header-end filled parse-out max-body-size) (let* ((method (slice->string hdr-buf @@ -189,13 +244,21 @@ (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)) + ((not (valid-method? method)) + (httpsd-debug "invalid method: " method) + (values 400 #f)) + ((not (valid-path? path)) + (httpsd-debug "invalid path: " path) + (values 400 #f)) + ((not (valid-header-set? headers version)) + (httpsd-debug "invalid headers for " version ": " headers) + (values 400 #f)) (else (let ((cl (content-length headers))) (cond - ((not cl) (values 400 #f)) + ((not cl) + (httpsd-debug "invalid content-length headers: " headers) + (values 400 #f)) ((> cl max-body-size) (values 413 #f)) (else (let ((body (read-body conn hdr-buf header-end filled cl))) @@ -204,7 +267,9 @@ (th:make-request method path version (ensure-https-header headers) body)) - (values 400 #f)))))))))) + (begin + (httpsd-debug "request body read failed") + (values 400 #f))))))))))) (def (extract-headers hdr-buf parse-out nhdrs) (let loop ([i 0] [acc '()]) @@ -282,10 +347,41 @@ headers (cons (cons "x-forwarded-proto" "https") headers))) - (def (write-error-response conn status) + (def (apply-security-headers server resp) + (let ([security-headers (httpsd-security-headers server)]) + (if security-headers + (th:respond + (th:response-status resp) + (merge-missing-headers (th:response-headers resp) security-headers) + (th:response-body resp)) + resp))) + + (def (merge-missing-headers headers defaults) + (let loop ([xs defaults] [extra '()]) + (cond + [(null? xs) (append headers (reverse extra))] + [(or (not (pair? (car xs))) + (not (string? (caar xs))) + (header-present? headers (caar xs))) + (loop (cdr xs) extra)] + [else (loop (cdr xs) (cons (car xs) extra))]))) + + (def (header-present? headers name) + (let ([needle (string-downcase name)]) + (let loop ([xs headers]) + (cond + [(null? xs) #f] + [(and (pair? (car xs)) + (string? (caar xs)) + (string=? (string-downcase (caar xs)) needle)) + #t] + [else (loop (cdr xs))])))) + + (def (write-error-response server conn status) (write-response conn - (th:respond-text status - (string-append (status-text status) "\n")))) + (apply-security-headers server + (th:respond-text status + (string-append (status-text status) "\n"))))) (def (write-response conn resp) (let* ([body (th:response-body resp)] @@ -301,7 +397,8 @@ (bytevector-length body-bv)))]) (tls-write-all conn header-bv) (when (> (bytevector-length body-bv) 0) - (tls-write-all conn body-bv)))) + (tls-write-all conn body-bv)) + (rustls-flush conn))) (def (response-header-text status headers body-length) (let ([out (open-output-string)]) --- a/lib/std/net/tcp-raw.ss +++ b/lib/std/net/tcp-raw.ss @@ -34,8 +34,8 @@ (def c-socket (foreign-procedure "socket" (int int int) int)) (def c-bind (foreign-procedure "bind" (int void* int) int)) (def c-listen (foreign-procedure "listen" (int int) int)) - (def c-accept (foreign-procedure "accept" (int void* void*) int)) - (def c-connect (foreign-procedure "connect" (int void* int) int)) + (def c-accept (foreign-procedure __collect_safe "accept" (int void* void*) int)) + (def c-connect (foreign-procedure __collect_safe "connect" (int void* int) int)) (def c-close (foreign-procedure "close" (int) int)) (def c-setsockopt (foreign-procedure "setsockopt" (int int int void* int) int)) (def c-read (foreign-procedure "read" (int u8* size_t) ssize_t)) --- a/lib/std/net/tls-rustls.ss +++ b/lib/std/net/tls-rustls.ss @@ -116,12 +116,12 @@ ;; I/O (def c-tls-read (try - (foreign-procedure __collect_safe "jerboa_tls_read" (unsigned-64 u8* unsigned-64) int) + (foreign-procedure __collect_safe "jerboa_tls_read" (unsigned-64 void* unsigned-64) int) (catch (e) (tls-native-unavailable 'rustls-read)))) (def c-tls-write (try - (foreign-procedure __collect_safe "jerboa_tls_write" (unsigned-64 u8* unsigned-64) int) + (foreign-procedure __collect_safe "jerboa_tls_write" (unsigned-64 void* unsigned-64) int) (catch (e) (tls-native-unavailable 'rustls-write)))) (def c-tls-flush @@ -270,13 +270,31 @@ (def (rustls-read handle buf max-len) ;; Read up to max-len bytes. Returns bytes read, 0 on EOF, -1 on error. - (c-tls-read handle buf max-len)) + (let* ([limit (min max-len (bytevector-length buf))] + [tmp (foreign-alloc (max 1 limit))]) + (try + (let ([n (c-tls-read handle tmp limit)]) + (when (> n 0) + (let loop ([i 0]) + (when (< i n) + (bytevector-u8-set! buf i (foreign-ref 'unsigned-8 tmp i)) + (loop (+ i 1))))) + n) + (finally (foreign-free tmp))))) (def (rustls-write handle buf len) ;; Write len bytes from buf. Returns bytes written or -1 on error. - (let ([n (c-tls-write handle buf len)]) + (let* ([limit (min len (bytevector-length buf))] + [tmp (foreign-alloc (max 1 limit))]) + (let loop ([i 0]) + (when (< i limit) + (foreign-set! 'unsigned-8 tmp i (bytevector-u8-ref buf i)) + (loop (+ i 1)))) + (let ([n (try + (c-tls-write handle tmp limit) + (finally (foreign-free tmp)))]) (when (> n 0) (c-tls-flush handle)) - n)) + n))) (def (rustls-flush handle) (c-tls-flush handle)) --- a/support/build-jerboa-multicall.ss +++ b/support/build-jerboa-multicall.ss @@ -36,6 +36,13 @@ [end (let lp ([i n]) (if (and (> i start) (char-whitespace? (string-ref s (- i 1)))) (lp (- i 1)) i))]) (substring s start end))) +(define (runtime-version-text) + (let* ([v (scheme-version)] + [prefix "Chez Scheme Version "]) + (if (string-prefix? prefix v) + (substring v (string-length prefix) (string-length v)) + v))) + (define (shell-quote s) (call-with-string-output-port (lambda (out) @@ -258,9 +265,9 @@ (loop)])))] [(or (string=? (car args) "--version") (string=? (car args) "-v")) (displayln ,(string-append "jerboa " project-version " (multicall: jerboa/jmcp/jlsp/jerbuild/jpkg)")) - (displayln (string-append "Bundled Chez runtime " - (scheme-version) - " (Apache 2.0, (c) Cisco Systems, Inc.)")) + (displayln ,(string-append "Bundled Chez runtime " + (runtime-version-text) + " (Apache 2.0, (c) Cisco Systems, Inc.)")) (displayln "See LICENSE-CHEZ for the runtime NOTICE and license.")] [(or (string=? (car args) "--help") (string=? (car args) "-h")) (for-each displayln --- a/support/build-static-script.sh +++ b/support/build-static-script.sh @@ -71,6 +71,25 @@ if [ ! -f "${NATIVE_A}" ]; then exit 1 fi +RUST_TARGET="${RUST_TARGET:-x86_64-unknown-linux-musl}" +STATIC_OS_LIBS="${STATIC_OS_LIBS:--lm -ldl -lpthread -static -no-pie -lstdc++}" +JERBUILD_ARGS=( + jerbuild binary + --static-native + --cc "${MUSL_CC}" + --rust-target "${RUST_TARGET}" + --csv-dir "${CSV_DIR}" + --os-libs "${STATIC_OS_LIBS}" + --libdirs "${LIBDIRS}" +) +if [ -n "${JERBOA_XPATCH:-}" ]; then + JERBUILD_ARGS+=(--xpatch "${JERBOA_XPATCH}") +fi + +echo "==> Delegating to jerboa jerbuild binary" +JERBOA_HOME="${JERBOA_HOME}" JERBOA_NATIVE_A="${NATIVE_A}" \ + exec ${JERBOA_CMD} "${JERBUILD_ARGS[@]}" "${SCRIPT}" "${OUTPUT}" + # ── Step 1: Compile script with WPO → <output>.wp.so ───────────────────────── WPO_SO="${OUTPUT}.wp.so" # Writable dir for compiled library .so output (source lib dir may be read-only)