security: pin WASM HTTP parser module SHA-256 (fail closed)
ober
1f553970c310f87e50ae4bea7c06c00ceca089c6
--- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ else LD_VAR = LD_LIBRARY_PATH endif -.PHONY: all build transpile wasm wasm-clean test test-https test-https-security test-httpd security audit fuzz-check load-smoke fuzz-evidence tls-proxy-evidence sbom reproducibility-report soak-evidence verify release-evidence clean deps dependency-lock-check +.PHONY: all build transpile wasm wasm-clean test test-https test-https-security test-httpd test-wasm security audit fuzz-check load-smoke fuzz-evidence tls-proxy-evidence sbom reproducibility-report soak-evidence verify release-evidence clean deps dependency-lock-check all: build @@ -49,7 +49,7 @@ wasm-clean: build: deps wasm transpile -test: test-https test-https-security test-httpd +test: test-https test-https-security test-httpd test-wasm test-https: build JERBOA_SSL_ALLOW_DYNAMIC_NATIVE=1 \ @@ -71,6 +71,12 @@ test-httpd: build $(LD_VAR)=$(RUNTIME_LIBDIRS) \ $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/httpd-test.ss +test-wasm: build + JERBOA_SSL_ALLOW_DYNAMIC_NATIVE=1 \ + JERBOA_SSL_LIB=$(SSL_DIR) \ + $(LD_VAR)=$(RUNTIME_LIBDIRS) \ + $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/wasm-http-test.ss + security: scripts/daemon-security-check.sh --- a/lib/jerboa-https/wasm-http.sls +++ b/lib/jerboa-https/wasm-http.sls @@ -7,7 +7,9 @@ parse-chunk-size-sandboxed http-parser-sandbox-available? require-http-parser-sandbox? set-require-http-parser-sandbox! wasm-http-init! - wasm-http-shutdown!) + wasm-http-shutdown! wasm-module-sha256 wasm-expected-sha256 + wasm-integrity-verified? wasm-loading-allowed? + wasm-allow-unpinned?) (import (except (chezscheme) make-hash-table hash-table? sort sort! printf fprintf format path-extension path-absolute? @@ -28,13 +30,19 @@ (def %instance-mutex (make-mutex 'jhttps-wasm-http)) (def *require-sandbox?* #f) (def (resolve-wasm-path) - (or (getenv "JHTTPS_HTTP_PARSER_WASM") - (find - file-exists? - '("lib/jerboa-https/sandbox/http_parser.wasm" - "sandbox/http_parser.wasm" - "/etc/jhttps/http_parser.wasm")) - "lib/jerboa-https/sandbox/http_parser.wasm")) + (let ([override (getenv "JHTTPS_HTTP_PARSER_WASM")]) + (cond + [override + (if (or (path-absolute? override) (wasm-allow-unpinned?)) + override + #f)] + [else + (or (find + file-exists? + '("lib/jerboa-https/sandbox/http_parser.wasm" + "sandbox/http_parser.wasm" + "/etc/jhttps/http_parser.wasm")) + "lib/jerboa-https/sandbox/http_parser.wasm")]))) (def (truthy-env? name) (let ([v (getenv name)]) (and v @@ -48,21 +56,214 @@ (call-with-port (open-file-input-port path) get-bytevector-all)) + (def *wasm-expected-sha256* + "1d8fa7b482fb7d2a8100f8cfc60a4b3a0aca978339e5cbd0dbd96d5fec1fb086") + (def (wasm-expected-sha256) *wasm-expected-sha256*) + (def (wasm-allow-unpinned?) + (truthy-env? "JHTTPS_WASM_ALLOW_UNPINNED")) + (def sha256-k + '#(1116352408 1899447441 3049323471 3921009573 961987163 + 1508970993 2453635748 2870763221 3624381080 310598401 + 607225278 1426881987 1925078388 2162078206 2614888103 + 3248222580 3835390401 4022224774 264347078 604807628 + 770255983 1249150122 1555081692 1996064986 2554220882 + 2821834349 2952996808 3210313671 3336571891 3584528711 + 113926993 338241895 666307205 773529912 1294757372 + 1396182291 1695183700 1986661051 2177026350 2456956037 + 2730485921 2820302411 3259730800 3345764771 3516065817 + 3600352804 4094571909 275423344 430227734 506948616 + 659060556 883997877 958139571 1322822218 1537002063 + 1747873779 1955562222 2024104815 2227730452 2361852424 + 2428436474 2756734187 3204031479 3329325298)) + (def (u32 x) (bitwise-and x 4294967295)) + (def (rotr32 x n) + (u32 (bitwise-ior + (bitwise-arithmetic-shift-right x n) + (bitwise-arithmetic-shift-left x (- 32 n))))) + (def (wasm-module-sha256 bv) + (let* ([n (bytevector-length bv)] + [bit-len (* n 8)] + [zeros (mod (- 56 (mod (+ n 1) 64)) 64)] + [total (+ n 1 zeros 8)] + [msg (make-bytevector total 0)]) + (bytevector-copy! bv 0 msg 0 n) + (bytevector-u8-set! msg n 128) + (let ([hi (bitwise-arithmetic-shift-right bit-len 32)] + [lo (bitwise-and bit-len 4294967295)]) + (bytevector-u8-set! + msg + (- total 8) + (bitwise-and (bitwise-arithmetic-shift-right hi 24) 255)) + (bytevector-u8-set! + msg + (- total 7) + (bitwise-and (bitwise-arithmetic-shift-right hi 16) 255)) + (bytevector-u8-set! + msg + (- total 6) + (bitwise-and (bitwise-arithmetic-shift-right hi 8) 255)) + (bytevector-u8-set! msg (- total 5) (bitwise-and hi 255)) + (bytevector-u8-set! + msg + (- total 4) + (bitwise-and (bitwise-arithmetic-shift-right lo 24) 255)) + (bytevector-u8-set! + msg + (- total 3) + (bitwise-and (bitwise-arithmetic-shift-right lo 16) 255)) + (bytevector-u8-set! + msg + (- total 2) + (bitwise-and (bitwise-arithmetic-shift-right lo 8) 255)) + (bytevector-u8-set! msg (- total 1) (bitwise-and lo 255))) + (let ([h (vector 1779033703 3144134277 1013904242 2773480762 + 1359893119 2600822924 528734635 1541459225)] + [w (make-vector 64 0)]) + (let block-loop ([off 0]) + (when (< off total) + (do ([i 0 (+ i 1)]) + ((= i 16)) + (let ([base (+ off (* i 4))]) + (vector-set! + w + i + (bitwise-ior + (bitwise-arithmetic-shift-left + (bytevector-u8-ref msg base) + 24) + (bitwise-arithmetic-shift-left + (bytevector-u8-ref msg (+ base 1)) + 16) + (bitwise-arithmetic-shift-left + (bytevector-u8-ref msg (+ base 2)) + 8) + (bytevector-u8-ref msg (+ base 3)))))) + (do ([i 16 (+ i 1)]) + ((= i 64)) + (let* ([w15 (vector-ref w (- i 15))] + [w2 (vector-ref w (- i 2))] + [s0 (bitwise-xor + (rotr32 w15 7) + (rotr32 w15 18) + (bitwise-arithmetic-shift-right w15 3))] + [s1 (bitwise-xor + (rotr32 w2 17) + (rotr32 w2 19) + (bitwise-arithmetic-shift-right w2 10))]) + (vector-set! + w + i + (u32 (+ (vector-ref w (- i 16)) + s0 + (vector-ref w (- i 7)) + s1))))) + (let ([a (vector-ref h 0)] + [b (vector-ref h 1)] + [c (vector-ref h 2)] + [d (vector-ref h 3)] + [e (vector-ref h 4)] + [f (vector-ref h 5)] + [g (vector-ref h 6)] + [hh (vector-ref h 7)]) + (do ([i 0 (+ i 1)]) + ((= i 64)) + (let* ([S1 (bitwise-xor + (rotr32 e 6) + (rotr32 e 11) + (rotr32 e 25))] + [ch (bitwise-xor + (bitwise-and e f) + (bitwise-and (bitwise-not e) g))] + [temp1 (u32 (+ hh S1 ch (vector-ref sha256-k i) + (vector-ref w i)))] + [S0 (bitwise-xor + (rotr32 a 2) + (rotr32 a 13) + (rotr32 a 22))] + [maj (bitwise-xor + (bitwise-and a b) + (bitwise-and a c) + (bitwise-and b c))] + [temp2 (u32 (+ S0 maj))]) + (set! hh g) + (set! g f) + (set! f e) + (set! e (u32 (+ d temp1))) + (set! d c) + (set! c b) + (set! b a) + (set! a (u32 (+ temp1 temp2))))) + (vector-set! h 0 (u32 (+ (vector-ref h 0) a))) + (vector-set! h 1 (u32 (+ (vector-ref h 1) b))) + (vector-set! h 2 (u32 (+ (vector-ref h 2) c))) + (vector-set! h 3 (u32 (+ (vector-ref h 3) d))) + (vector-set! h 4 (u32 (+ (vector-ref h 4) e))) + (vector-set! h 5 (u32 (+ (vector-ref h 5) f))) + (vector-set! h 6 (u32 (+ (vector-ref h 6) g))) + (vector-set! h 7 (u32 (+ (vector-ref h 7) hh))) + (block-loop (+ off 64))))) + (let ([hex "0123456789abcdef"]) + (let loop ([i 0] [acc '()]) + (if (= i 8) + (list->string (reverse acc)) + (let ([word (vector-ref h i)]) + (let inner ([j 0] [acc acc]) + (if (= j 4) + (loop (+ i 1) acc) + (let ([byte (bitwise-and + (bitwise-arithmetic-shift-right + word + (* 8 (- 3 j))) + 255)]) + (inner + (+ j 1) + (cons + (string-ref hex (bitwise-and byte 15)) + (cons + (string-ref + hex + (bitwise-arithmetic-shift-right + byte + 4)) + acc))))))))))))) + (def (wasm-integrity-verified? bytes expected-hash) + (and (bytevector? bytes) + (string? expected-hash) + (= (string-length expected-hash) 64) + (let ([actual (try (wasm-module-sha256 bytes) + (catch (e) #f))]) + (and actual (string-ci=? actual expected-hash))))) + (def (wasm-loading-allowed? + bytes + expected-hash + allow-unpinned?) + (or allow-unpinned? + (wasm-integrity-verified? bytes expected-hash))) (def (wasm-http-init!) (cond [%instance #t] [(not (wasm-sandbox-available?)) #f] [else (try (let* ([path (resolve-wasm-path)] - [bytes (and (file-exists? path) + [bytes (and path + (file-exists? path) (load-wasm-bytes path))]) - (if (not bytes) - #f - (let* ([m (wasm-sandbox-load bytes)] - [i (wasm-sandbox-instantiate m)]) - (set! %module m) - (set! %instance i) - #t))) + (cond + [(not bytes) #f] + [(not (wasm-loading-allowed? + bytes + (wasm-expected-sha256) + (wasm-allow-unpinned?))) + (when (require-http-parser-sandbox?) + (error 'wasm-http-init! + "wasm http parser failed integrity verification")) + #f] + [else + (let* ([m (wasm-sandbox-load bytes)] + [i (wasm-sandbox-instantiate m)]) + (set! %module m) + (set! %instance i) + #t)])) (catch (e) (set! %module #f) (set! %instance #f) #f))])) (def (wasm-http-shutdown!) (when %instance @@ -72,8 +273,8 @@ (try (wasm-sandbox-free-module %module) (catch (e) #f)) (set! %module #f))) (def (http-parser-sandbox-available?) - (and (wasm-sandbox-available?) - (file-exists? (resolve-wasm-path)))) + (let ([path (resolve-wasm-path)]) + (and (wasm-sandbox-available?) path (file-exists? path)))) (def (string-index str ch) (let ([len (string-length str)]) (let loop ([i 0]) --- a/src/jerboa-https/wasm-http.ss +++ b/src/jerboa-https/wasm-http.ss @@ -8,7 +8,12 @@ require-http-parser-sandbox? set-require-http-parser-sandbox! wasm-http-init! - wasm-http-shutdown!) + wasm-http-shutdown! + wasm-module-sha256 + wasm-expected-sha256 + wasm-integrity-verified? + wasm-loading-allowed? + wasm-allow-unpinned?) (import (except (jerboa prelude) string-trim string-index) @@ -30,12 +35,21 @@ (def *require-sandbox?* #f) (def (resolve-wasm-path) - (or (getenv "JHTTPS_HTTP_PARSER_WASM") - (find file-exists? - '("lib/jerboa-https/sandbox/http_parser.wasm" - "sandbox/http_parser.wasm" - "/etc/jhttps/http_parser.wasm")) - "lib/jerboa-https/sandbox/http_parser.wasm")) + (let ([override (getenv "JHTTPS_HTTP_PARSER_WASM")]) + (cond + ;; An explicit override is honored only when it is an absolute path or + ;; unpinned development loading is enabled; a relative override would be + ;; resolved against an attacker-controllable CWD. + [override + (if (or (path-absolute? override) (wasm-allow-unpinned?)) + override + #f)] + [else + (or (find file-exists? + '("lib/jerboa-https/sandbox/http_parser.wasm" + "sandbox/http_parser.wasm" + "/etc/jhttps/http_parser.wasm")) + "lib/jerboa-https/sandbox/http_parser.wasm")]))) (def (truthy-env? name) (let ([v (getenv name)]) @@ -53,6 +67,141 @@ (call-with-port (open-file-input-port path) get-bytevector-all)) + ;; ---------------------------------------------------------------- + ;; Module integrity. The parser module is loaded from an env-var or + ;; CWD-relative path, so an attacker who can plant a file (or set the env + ;; var) could otherwise control the parser logic. We pin the module's + ;; SHA-256 and refuse to execute bytes that do not match. The expected + ;; hash is embedded here -- the production trust anchor -- so it cannot be + ;; overridden by a pin file planted in the process CWD. + ;; ---------------------------------------------------------------- + + (def *wasm-expected-sha256* + "1d8fa7b482fb7d2a8100f8cfc60a4b3a0aca978339e5cbd0dbd96d5fec1fb086") + + (def (wasm-expected-sha256) *wasm-expected-sha256*) + + (def (wasm-allow-unpinned?) + (truthy-env? "JHTTPS_WASM_ALLOW_UNPINNED")) + + (def sha256-k + '#(#x428a2f98 #x71374491 #xb5c0fbcf #xe9b5dba5 + #x3956c25b #x59f111f1 #x923f82a4 #xab1c5ed5 + #xd807aa98 #x12835b01 #x243185be #x550c7dc3 + #x72be5d74 #x80deb1fe #x9bdc06a7 #xc19bf174 + #xe49b69c1 #xefbe4786 #x0fc19dc6 #x240ca1cc + #x2de92c6f #x4a7484aa #x5cb0a9dc #x76f988da + #x983e5152 #xa831c66d #xb00327c8 #xbf597fc7 + #xc6e00bf3 #xd5a79147 #x06ca6351 #x14292967 + #x27b70a85 #x2e1b2138 #x4d2c6dfc #x53380d13 + #x650a7354 #x766a0abb #x81c2c92e #x92722c85 + #xa2bfe8a1 #xa81a664b #xc24b8b70 #xc76c51a3 + #xd192e819 #xd6990624 #xf40e3585 #x106aa070 + #x19a4c116 #x1e376c08 #x2748774c #x34b0bcb5 + #x391c0cb3 #x4ed8aa4a #x5b9cca4f #x682e6ff3 + #x748f82ee #x78a5636f #x84c87814 #x8cc70208 + #x90befffa #xa4506ceb #xbef9a3f7 #xc67178f2)) + + (def (u32 x) (bitwise-and x #xFFFFFFFF)) + + (def (rotr32 x n) + (u32 (bitwise-ior (bitwise-arithmetic-shift-right x n) + (bitwise-arithmetic-shift-left x (- 32 n))))) + + ;; Pure-Scheme SHA-256 (FIPS 180-4). Self-contained so the parser's + ;; integrity gate does not depend on the native crypto bundle being present. + (def (wasm-module-sha256 bv) + (let* ([n (bytevector-length bv)] + [bit-len (* n 8)] + [zeros (mod (- 56 (mod (+ n 1) 64)) 64)] + [total (+ n 1 zeros 8)] + [msg (make-bytevector total 0)]) + (bytevector-copy! bv 0 msg 0 n) + (bytevector-u8-set! msg n #x80) + (let ([hi (bitwise-arithmetic-shift-right bit-len 32)] + [lo (bitwise-and bit-len #xFFFFFFFF)]) + (bytevector-u8-set! msg (- total 8) (bitwise-and (bitwise-arithmetic-shift-right hi 24) #xFF)) + (bytevector-u8-set! msg (- total 7) (bitwise-and (bitwise-arithmetic-shift-right hi 16) #xFF)) + (bytevector-u8-set! msg (- total 6) (bitwise-and (bitwise-arithmetic-shift-right hi 8) #xFF)) + (bytevector-u8-set! msg (- total 5) (bitwise-and hi #xFF)) + (bytevector-u8-set! msg (- total 4) (bitwise-and (bitwise-arithmetic-shift-right lo 24) #xFF)) + (bytevector-u8-set! msg (- total 3) (bitwise-and (bitwise-arithmetic-shift-right lo 16) #xFF)) + (bytevector-u8-set! msg (- total 2) (bitwise-and (bitwise-arithmetic-shift-right lo 8) #xFF)) + (bytevector-u8-set! msg (- total 1) (bitwise-and lo #xFF))) + (let ([h (vector #x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a + #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19)] + [w (make-vector 64 0)]) + (let block-loop ([off 0]) + (when (< off total) + (do ([i 0 (+ i 1)]) ([= i 16]) + (let ([base (+ off (* i 4))]) + (vector-set! w i + (bitwise-ior + (bitwise-arithmetic-shift-left (bytevector-u8-ref msg base) 24) + (bitwise-arithmetic-shift-left (bytevector-u8-ref msg (+ base 1)) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref msg (+ base 2)) 8) + (bytevector-u8-ref msg (+ base 3)))))) + (do ([i 16 (+ i 1)]) ([= i 64]) + (let* ([w15 (vector-ref w (- i 15))] + [w2 (vector-ref w (- i 2))] + [s0 (bitwise-xor (rotr32 w15 7) (rotr32 w15 18) + (bitwise-arithmetic-shift-right w15 3))] + [s1 (bitwise-xor (rotr32 w2 17) (rotr32 w2 19) + (bitwise-arithmetic-shift-right w2 10))]) + (vector-set! w i + (u32 (+ (vector-ref w (- i 16)) s0 (vector-ref w (- i 7)) s1))))) + (let ([a (vector-ref h 0)] [b (vector-ref h 1)] + [c (vector-ref h 2)] [d (vector-ref h 3)] + [e (vector-ref h 4)] [f (vector-ref h 5)] + [g (vector-ref h 6)] [hh (vector-ref h 7)]) + (do ([i 0 (+ i 1)]) ([= i 64]) + (let* ([S1 (bitwise-xor (rotr32 e 6) (rotr32 e 11) (rotr32 e 25))] + [ch (bitwise-xor (bitwise-and e f) + (bitwise-and (bitwise-not e) g))] + [temp1 (u32 (+ hh S1 ch (vector-ref sha256-k i) (vector-ref w i)))] + [S0 (bitwise-xor (rotr32 a 2) (rotr32 a 13) (rotr32 a 22))] + [maj (bitwise-xor (bitwise-and a b) (bitwise-and a c) + (bitwise-and b c))] + [temp2 (u32 (+ S0 maj))]) + (set! hh g) (set! g f) (set! f e) (set! e (u32 (+ d temp1))) + (set! d c) (set! c b) (set! b a) (set! a (u32 (+ temp1 temp2))))) + (vector-set! h 0 (u32 (+ (vector-ref h 0) a))) + (vector-set! h 1 (u32 (+ (vector-ref h 1) b))) + (vector-set! h 2 (u32 (+ (vector-ref h 2) c))) + (vector-set! h 3 (u32 (+ (vector-ref h 3) d))) + (vector-set! h 4 (u32 (+ (vector-ref h 4) e))) + (vector-set! h 5 (u32 (+ (vector-ref h 5) f))) + (vector-set! h 6 (u32 (+ (vector-ref h 6) g))) + (vector-set! h 7 (u32 (+ (vector-ref h 7) hh))) + (block-loop (+ off 64))))) + (let ([hex "0123456789abcdef"]) + (let loop ([i 0] [acc '()]) + (if (= i 8) + (list->string (reverse acc)) + (let ([word (vector-ref h i)]) + (let inner ([j 0] [acc acc]) + (if (= j 4) + (loop (+ i 1) acc) + (let ([byte (bitwise-and + (bitwise-arithmetic-shift-right word (* 8 (- 3 j))) #xFF)]) + (inner (+ j 1) + (cons (string-ref hex (bitwise-and byte #xf)) + (cons (string-ref hex (bitwise-arithmetic-shift-right byte 4)) + acc))))))))))))) + + (def (wasm-integrity-verified? bytes expected-hash) + ;; Pure check: true iff expected-hash is a present 64-hex-char pin matching + ;; the SHA-256 of bytes. A missing/empty pin (#f) fails closed. + (and (bytevector? bytes) + (string? expected-hash) + (= (string-length expected-hash) 64) + (let ([actual (try (wasm-module-sha256 bytes) (catch (e) #f))]) + (and actual (string-ci=? actual expected-hash))))) + + (def (wasm-loading-allowed? bytes expected-hash allow-unpinned?) + (or allow-unpinned? + (wasm-integrity-verified? bytes expected-hash))) + (def (wasm-http-init!) (cond [%instance #t] @@ -60,14 +209,23 @@ [else (try (let* ([path (resolve-wasm-path)] - [bytes (and (file-exists? path) (load-wasm-bytes path))]) - (if (not bytes) - #f - (let* ([m (wasm-sandbox-load bytes)] - [i (wasm-sandbox-instantiate m)]) - (set! %module m) - (set! %instance i) - #t))) + [bytes (and path (file-exists? path) (load-wasm-bytes path))]) + (cond + [(not bytes) #f] + [(not (wasm-loading-allowed? bytes (wasm-expected-sha256) + (wasm-allow-unpinned?))) + ;; Unverified module (hash mismatch, or pin missing): never execute + ;; it. Fail closed; when the sandbox is required this is an error. + (when (require-http-parser-sandbox?) + (error 'wasm-http-init! + "wasm http parser failed integrity verification")) + #f] + [else + (let* ([m (wasm-sandbox-load bytes)] + [i (wasm-sandbox-instantiate m)]) + (set! %module m) + (set! %instance i) + #t)])) (catch (e) (set! %module #f) (set! %instance #f) @@ -82,8 +240,10 @@ (set! %module #f))) (def (http-parser-sandbox-available?) - (and (wasm-sandbox-available?) - (file-exists? (resolve-wasm-path)))) + (let ([path (resolve-wasm-path)]) + (and (wasm-sandbox-available?) + path + (file-exists? path)))) (def (string-index str ch) (let ([len (string-length str)]) new file mode 100644 --- /dev/null +++ b/tests/wasm-http-test.ss @@ -0,0 +1,167 @@ +#!/usr/bin/env scheme-script +;; WASM HTTP parser module-integrity tests. +;; +;; Verifies the SHA-256 pin gate: a module whose hash does not match the pinned +;; expected hash is rejected (fails closed), a matching module loads, a missing +;; pin fails closed in production mode, and the JHTTPS_WASM_ALLOW_UNPINNED dev +;; override permits unpinned loading. + +(import + (scheme) + (only (std os env) setenv unsetenv) + (jerboa-https wasm-http)) + +(define pass-count 0) +(define fail-count 0) + +(define (test name thunk) + (guard (e [#t (set! fail-count (+ fail-count 1)) + (display "FAIL: ") (display name) (newline) + (display " ") (display-condition e) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert msg actual expected))) + +(define (assert-true val msg) + (unless val (error 'assert msg val))) + +(define module-path "lib/jerboa-https/sandbox/http_parser.wasm") + +(define (read-bytes path) + (call-with-port (open-file-input-port path) get-bytevector-all)) + +(define (write-bytes path bv) + (let ([p (open-file-output-port path)]) + (put-bytevector p bv) + (close-port p))) + +;; ---------------------------------------------------------------- +;; SHA-256 known-answer tests (validate the pure-Scheme implementation +;; that backs the integrity gate). +;; ---------------------------------------------------------------- + +(test "sha256 matches FIPS 180-4 vectors" + (lambda () + (assert-equal + (wasm-module-sha256 (string->utf8 "abc")) + "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" "abc") + (assert-equal + (wasm-module-sha256 (make-bytevector 0)) + "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" "empty") + (assert-equal + (wasm-module-sha256 + (string->utf8 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq")) + "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1" "two-block"))) + +;; ---------------------------------------------------------------- +;; Integrity verification logic (stub module bytes + expected/actual hash). +;; ---------------------------------------------------------------- + +(define stub-bytes (string->utf8 "stub-wasm-module-bytes")) +(define stub-hash (wasm-module-sha256 stub-bytes)) +(define wrong-hash "0000000000000000000000000000000000000000000000000000000000000000") + +(test "matching hash verifies" + (lambda () + (assert-true (wasm-integrity-verified? stub-bytes stub-hash) "match verifies"))) + +(test "mismatched hash is rejected (fails closed)" + (lambda () + (assert-true (not (wasm-integrity-verified? stub-bytes wrong-hash)) + "mismatch rejected"))) + +(test "missing pin fails closed in production mode" + (lambda () + (assert-true (not (wasm-integrity-verified? stub-bytes #f)) "absent pin rejected") + (assert-true (not (wasm-integrity-verified? stub-bytes "")) "empty pin rejected") + (assert-true (not (wasm-loading-allowed? stub-bytes #f #f)) + "production loading rejected without a pin"))) + +(test "production loading rejects mismatch and accepts match" + (lambda () + (assert-true (not (wasm-loading-allowed? stub-bytes wrong-hash #f)) + "production rejects mismatch") + (assert-true (wasm-loading-allowed? stub-bytes stub-hash #f) + "production accepts match"))) + +(test "dev override allows unpinned loading" + (lambda () + (assert-true (wasm-loading-allowed? stub-bytes wrong-hash #t) + "override permits mismatch") + (assert-true (wasm-loading-allowed? stub-bytes #f #t) + "override permits missing pin"))) + +;; ---------------------------------------------------------------- +;; Dev-override env var. +;; ---------------------------------------------------------------- + +(test "JHTTPS_WASM_ALLOW_UNPINNED env controls wasm-allow-unpinned?" + (lambda () + (unsetenv "JHTTPS_WASM_ALLOW_UNPINNED") + (assert-true (not (wasm-allow-unpinned?)) "unset -> #f") + (setenv "JHTTPS_WASM_ALLOW_UNPINNED" "1") + (assert-true (wasm-allow-unpinned?) "1 -> #t") + (setenv "JHTTPS_WASM_ALLOW_UNPINNED" "0") + (assert-true (not (wasm-allow-unpinned?)) "0 -> #f") + (unsetenv "JHTTPS_WASM_ALLOW_UNPINNED") + (assert-true (not (wasm-allow-unpinned?)) "cleared -> #f"))) + +;; ---------------------------------------------------------------- +;; The shipped module verifies against the embedded pin. +;; ---------------------------------------------------------------- + +(test "shipped http_parser.wasm matches the embedded pin" + (lambda () + (assert-true (file-exists? module-path) "module present") + (assert-true (wasm-integrity-verified? (read-bytes module-path) (wasm-expected-sha256)) + "shipped module verifies against embedded pin"))) + +;; ---------------------------------------------------------------- +;; Integration: init fails closed on a tampered module and loads the pinned one. +;; ---------------------------------------------------------------- + +(define tampered-path + (string-append (current-directory) "/tests/static/tampered-integrity-test.wasm")) + +(define (tampered-wasm-bytes) + (let* ([bytes (read-bytes module-path)] + [n (bytevector-length bytes)] + [copy (let ([c (make-bytevector n)]) (bytevector-copy! bytes 0 c 0 n) c)]) + (bytevector-u8-set! copy (- n 1) + (bitwise-xor (bytevector-u8-ref copy (- n 1)) #xFF)) + copy)) + +(when (http-parser-sandbox-available?) + (test "wasm-http-init! rejects a tampered module (fails closed)" + (lambda () + (unsetenv "JHTTPS_WASM_ALLOW_UNPINNED") + (write-bytes tampered-path (tampered-wasm-bytes)) + (dynamic-wind + void + (lambda () + (setenv "JHTTPS_HTTP_PARSER_WASM" tampered-path) + (wasm-http-shutdown!) + (assert-true (not (wasm-http-init!)) + "tampered module must not load")) + (lambda () + (unsetenv "JHTTPS_HTTP_PARSER_WASM") + (wasm-http-shutdown!) + (when (file-exists? tampered-path) (delete-file tampered-path)))))) + + (test "wasm-http-init! loads the pinned module" + (lambda () + (unsetenv "JHTTPS_WASM_ALLOW_UNPINNED") + (unsetenv "JHTTPS_HTTP_PARSER_WASM") + (wasm-http-shutdown!) + (assert-true (wasm-http-init!) "pinned module loads") + (wasm-http-shutdown!)))) + +(newline) +(display "Results: ") +(display pass-count) (display " passed, ") +(display fail-count) (display " failed\n") +(when (> fail-count 0) (exit 1))