Add Phase 3 security modules: AEAD, password hashing, auth, security headers
ober
aba8840188420e7eb046f673377b9635aa16603e
--- a/Makefile +++ b/Makefile @@ -254,6 +254,7 @@ test-security: @JERBOA_DB_HOST=evil.com JERBOA_DB_PORT=5433 JERBOA_SECRET=leaked $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-config-env.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-audit.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-sanitize.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-phase3-security.ss test-all: test test-features test-wrappers test-security new file mode 100644 --- /dev/null +++ b/lib/std/crypto/aead.sls @@ -0,0 +1,157 @@ +#!chezscheme +;;; (std crypto aead) — Authenticated Encryption with Associated Data +;;; +;;; AES-256-GCM via OpenSSL EVP_AEAD interface. +;;; Provides encrypt-then-authenticate in a single operation. + +(library (std crypto aead) + (export + aead-encrypt + aead-decrypt + aead-key-generate) + + (import (chezscheme) + (std crypto random)) + + ;; Load libcrypto + (define _loaded + (or (guard (e [#t #f]) (load-shared-object "libcrypto.so") #t) + (guard (e [#t #f]) (load-shared-object "libcrypto.so.3") #t))) + + ;; EVP cipher interface + (define c-EVP_CIPHER_CTX_new + (if _loaded (foreign-procedure "EVP_CIPHER_CTX_new" () uptr) (lambda () 0))) + (define c-EVP_CIPHER_CTX_free + (if _loaded (foreign-procedure "EVP_CIPHER_CTX_free" (uptr) void) (lambda (x) (void)))) + (define c-EVP_aes_256_gcm + (if _loaded (foreign-procedure "EVP_aes_256_gcm" () uptr) (lambda () 0))) + (define c-EVP_EncryptInit_ex + (if _loaded (foreign-procedure "EVP_EncryptInit_ex" (uptr uptr uptr u8* u8*) int) (lambda args 0))) + (define c-EVP_EncryptUpdate + (if _loaded (foreign-procedure "EVP_EncryptUpdate" (uptr u8* u8* u8* int) int) (lambda args 0))) + ;; Separate binding for AAD (NULL output buffer) + (define c-EVP_EncryptUpdate_AAD + (if _loaded (foreign-procedure "EVP_EncryptUpdate" (uptr uptr u8* u8* int) int) (lambda args 0))) + (define c-EVP_EncryptFinal_ex + (if _loaded (foreign-procedure "EVP_EncryptFinal_ex" (uptr u8* u8*) int) (lambda args 0))) + (define c-EVP_CIPHER_CTX_ctrl + (if _loaded (foreign-procedure "EVP_CIPHER_CTX_ctrl" (uptr int int u8*) int) (lambda args 0))) + (define c-EVP_DecryptInit_ex + (if _loaded (foreign-procedure "EVP_DecryptInit_ex" (uptr uptr uptr u8* u8*) int) (lambda args 0))) + (define c-EVP_DecryptUpdate + (if _loaded (foreign-procedure "EVP_DecryptUpdate" (uptr u8* u8* u8* int) int) (lambda args 0))) + (define c-EVP_DecryptUpdate_AAD + (if _loaded (foreign-procedure "EVP_DecryptUpdate" (uptr uptr u8* u8* int) int) (lambda args 0))) + (define c-EVP_DecryptFinal_ex + (if _loaded (foreign-procedure "EVP_DecryptFinal_ex" (uptr u8* u8*) int) (lambda args 0))) + + ;; EVP_CTRL constants + (define EVP_CTRL_GCM_SET_IVLEN #x9) + (define EVP_CTRL_GCM_GET_TAG #x10) + (define EVP_CTRL_GCM_SET_TAG #x11) + + (define GCM_IV_LEN 12) + (define GCM_TAG_LEN 16) + (define AES_KEY_LEN 32) ;; AES-256 + + ;; ========== Public API ========== + + (define (aead-key-generate) + ;; Generate a random 256-bit key for AES-256-GCM. + (random-bytes AES_KEY_LEN)) + + (define (aead-encrypt key plaintext . aad-opt) + ;; Encrypt plaintext with AES-256-GCM. + ;; key: 32-byte bytevector + ;; plaintext: bytevector or string + ;; aad: optional associated data bytevector (authenticated but not encrypted) + ;; Returns: bytevector containing IV || ciphertext || tag + (unless _loaded (error 'aead-encrypt "libcrypto not available")) + (unless (and (bytevector? key) (= (bytevector-length key) AES_KEY_LEN)) + (error 'aead-encrypt "key must be 32-byte bytevector")) + (let* ([pt (if (string? plaintext) (string->utf8 plaintext) plaintext)] + [aad (if (pair? aad-opt) (car aad-opt) #f)] + [iv (random-bytes GCM_IV_LEN)] + [ct (make-bytevector (bytevector-length pt))] + [tag (make-bytevector GCM_TAG_LEN)] + [outlen (make-bytevector 4 0)] + [ctx (c-EVP_CIPHER_CTX_new)]) + (when (= ctx 0) (error 'aead-encrypt "EVP_CIPHER_CTX_new failed")) + (dynamic-wind + (lambda () (void)) + (lambda () + ;; Init + (when (= 0 (c-EVP_EncryptInit_ex ctx (c-EVP_aes_256_gcm) 0 key iv)) + (error 'aead-encrypt "EVP_EncryptInit_ex failed")) + ;; AAD (output buffer = NULL for AAD) + (when aad + (let ([aad-bv (if (string? aad) (string->utf8 aad) aad)]) + (when (= 0 (c-EVP_EncryptUpdate_AAD ctx 0 outlen aad-bv (bytevector-length aad-bv))) + (error 'aead-encrypt "EVP_EncryptUpdate (AAD) failed")))) + ;; Encrypt + (when (= 0 (c-EVP_EncryptUpdate ctx ct outlen pt (bytevector-length pt))) + (error 'aead-encrypt "EVP_EncryptUpdate failed")) + ;; Finalize + (when (= 0 (c-EVP_EncryptFinal_ex ctx (make-bytevector 16) outlen)) + (error 'aead-encrypt "EVP_EncryptFinal_ex failed")) + ;; Get tag + (when (= 0 (c-EVP_CIPHER_CTX_ctrl ctx EVP_CTRL_GCM_GET_TAG GCM_TAG_LEN tag)) + (error 'aead-encrypt "get tag failed")) + ;; Return IV || ciphertext || tag + (let ([result (make-bytevector (+ GCM_IV_LEN (bytevector-length ct) GCM_TAG_LEN))]) + (bytevector-copy! iv 0 result 0 GCM_IV_LEN) + (bytevector-copy! ct 0 result GCM_IV_LEN (bytevector-length ct)) + (bytevector-copy! tag 0 result (+ GCM_IV_LEN (bytevector-length ct)) GCM_TAG_LEN) + result)) + (lambda () + (c-EVP_CIPHER_CTX_free ctx))))) + + (define (aead-decrypt key ciphertext . aad-opt) + ;; Decrypt ciphertext with AES-256-GCM. + ;; ciphertext: bytevector containing IV || encrypted || tag + ;; Returns: plaintext bytevector, or raises error on auth failure + (unless _loaded (error 'aead-decrypt "libcrypto not available")) + (unless (and (bytevector? key) (= (bytevector-length key) AES_KEY_LEN)) + (error 'aead-decrypt "key must be 32-byte bytevector")) + (let* ([total-len (bytevector-length ciphertext)] + [ct-len (- total-len GCM_IV_LEN GCM_TAG_LEN)]) + (when (< ct-len 0) + (error 'aead-decrypt "ciphertext too short")) + (let* ([aad (if (pair? aad-opt) (car aad-opt) #f)] + [iv (make-bytevector GCM_IV_LEN)] + [ct (make-bytevector ct-len)] + [tag (make-bytevector GCM_TAG_LEN)] + [pt (make-bytevector ct-len)] + [outlen (make-bytevector 4 0)] + [ctx (c-EVP_CIPHER_CTX_new)]) + ;; Extract IV, ciphertext, tag + (bytevector-copy! ciphertext 0 iv 0 GCM_IV_LEN) + (bytevector-copy! ciphertext GCM_IV_LEN ct 0 ct-len) + (bytevector-copy! ciphertext (+ GCM_IV_LEN ct-len) tag 0 GCM_TAG_LEN) + (when (= ctx 0) (error 'aead-decrypt "EVP_CIPHER_CTX_new failed")) + (dynamic-wind + (lambda () (void)) + (lambda () + ;; Init + (when (= 0 (c-EVP_DecryptInit_ex ctx (c-EVP_aes_256_gcm) 0 key iv)) + (error 'aead-decrypt "EVP_DecryptInit_ex failed")) + ;; AAD (output buffer = NULL for AAD) + (when aad + (let ([aad-bv (if (string? aad) (string->utf8 aad) aad)]) + (when (= 0 (c-EVP_DecryptUpdate_AAD ctx 0 outlen aad-bv (bytevector-length aad-bv))) + (error 'aead-decrypt "EVP_DecryptUpdate (AAD) failed")))) + ;; Decrypt + (when (= 0 (c-EVP_DecryptUpdate ctx pt outlen ct ct-len)) + (error 'aead-decrypt "EVP_DecryptUpdate failed")) + ;; Set expected tag + (when (= 0 (c-EVP_CIPHER_CTX_ctrl ctx EVP_CTRL_GCM_SET_TAG GCM_TAG_LEN tag)) + (error 'aead-decrypt "set tag failed")) + ;; Verify + (let ([r (c-EVP_DecryptFinal_ex ctx (make-bytevector 16) outlen)]) + (when (= r 0) + (error 'aead-decrypt "authentication failed — ciphertext tampered")) + pt)) + (lambda () + (c-EVP_CIPHER_CTX_free ctx)))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/crypto/password.sls @@ -0,0 +1,136 @@ +#!chezscheme +;;; (std crypto password) — Password hashing via PBKDF2 +;;; +;;; Uses PKCS5_PBKDF2_HMAC from libcrypto for password hashing. +;;; PBKDF2-HMAC-SHA256 with configurable iterations and salt. +;;; Argon2id would be preferred but requires libargon2 — PBKDF2 is +;;; universally available via OpenSSL. + +(library (std crypto password) + (export + password-hash + password-verify + make-password-salt) + + (import (chezscheme) + (std crypto random) + (std crypto compare)) + + ;; Load libcrypto + (define _loaded + (or (guard (e [#t #f]) (load-shared-object "libcrypto.so") #t) + (guard (e [#t #f]) (load-shared-object "libcrypto.so.3") #t))) + + (define c-PKCS5_PBKDF2_HMAC + (if _loaded + (foreign-procedure "PKCS5_PBKDF2_HMAC" + (u8* int u8* int int uptr int u8*) int) + (lambda args (error 'password-hash "libcrypto not available")))) + + (define c-EVP_sha256 + (if _loaded + (foreign-procedure "EVP_sha256" () uptr) + (lambda () 0))) + + ;; ========== Public API ========== + + (define default-iterations 600000) ;; OWASP 2023 recommendation for PBKDF2-SHA256 + (define default-key-len 32) + (define default-salt-len 16) + + (define (make-password-salt) + ;; Generate a random salt for password hashing. + (random-bytes default-salt-len)) + + (define (password-hash password . opts) + ;; Hash a password with PBKDF2-HMAC-SHA256. + ;; Returns a string: "$pbkdf2-sha256$iterations$salt-hex$hash-hex" + ;; opts: iterations: N (default 600000), salt: bytevector + (let* ([pass-bv (if (string? password) (string->utf8 password) password)] + [iterations (kwarg 'iterations: opts default-iterations)] + [salt (kwarg 'salt: opts (make-password-salt))] + [out (make-bytevector default-key-len)]) + (let ([r (c-PKCS5_PBKDF2_HMAC + pass-bv (bytevector-length pass-bv) + salt (bytevector-length salt) + iterations + (c-EVP_sha256) + default-key-len + out)]) + (when (not (= r 1)) + (error 'password-hash "PKCS5_PBKDF2_HMAC failed")) + ;; Format: $pbkdf2-sha256$iterations$salt$hash + (string-append "$pbkdf2-sha256$" + (number->string iterations) "$" + (bytevector->hex salt) "$" + (bytevector->hex out))))) + + (define (password-verify password hash-string) + ;; Verify a password against a hash string. + ;; Uses timing-safe comparison to prevent timing attacks. + (let ([parts (string-split-dollar hash-string)]) + (unless (and (= (length parts) 5) + (string=? (cadr parts) "pbkdf2-sha256")) + (error 'password-verify "invalid hash format" hash-string)) + (let* ([iterations (string->number (caddr parts))] + [salt (hex->bytevector (cadddr parts))] + [expected-hash (list-ref parts 4)] + [pass-bv (if (string? password) (string->utf8 password) password)] + [out (make-bytevector default-key-len)] + [r (c-PKCS5_PBKDF2_HMAC + pass-bv (bytevector-length pass-bv) + salt (bytevector-length salt) + iterations + (c-EVP_sha256) + default-key-len + out)]) + (when (not (= r 1)) + (error 'password-verify "PKCS5_PBKDF2_HMAC failed")) + ;; Timing-safe comparison + (timing-safe-string=? (bytevector->hex out) expected-hash)))) + + ;; ========== Helpers ========== + + (define (kwarg key opts default) + (let loop ([l opts]) + (cond [(null? l) default] + [(and (pair? (cdr l)) (eq? (car l) key)) (cadr l)] + [else (loop (cdr l))]))) + + (define (bytevector->hex bv) + (let* ([len (bytevector-length bv)] + [out (make-string (* len 2))]) + (do ([i 0 (+ i 1)]) + ((= i len) out) + (let* ([b (bytevector-u8-ref bv i)] + [hi (bitwise-arithmetic-shift-right b 4)] + [lo (bitwise-and b #xf)]) + (string-set! out (* i 2) (string-ref "0123456789abcdef" hi)) + (string-set! out (+ (* i 2) 1) (string-ref "0123456789abcdef" lo)))))) + + (define (hex->bytevector s) + (let* ([len (string-length s)] + [out-len (quotient len 2)] + [result (make-bytevector out-len)]) + (do ([i 0 (+ i 2)] [j 0 (+ j 1)]) + ((>= i len) result) + (bytevector-u8-set! result j + (+ (* (hex-val (string-ref s i)) 16) + (hex-val (string-ref s (+ i 1)))))))) + + (define (hex-val c) + (cond [(char<=? #\0 c #\9) (- (char->integer c) (char->integer #\0))] + [(char<=? #\a c #\f) (+ 10 (- (char->integer c) (char->integer #\a)))] + [(char<=? #\A c #\F) (+ 10 (- (char->integer c) (char->integer #\A)))] + [else 0])) + + (define (string-split-dollar s) + (let ([n (string-length s)]) + (let lp ([i 0] [start 0] [acc '()]) + (cond + [(>= i n) (reverse (cons (substring s start n) acc))] + [(char=? (string-ref s i) #\$) + (lp (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else (lp (+ i 1) start acc)])))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/security-headers.sls @@ -0,0 +1,127 @@ +#!chezscheme +;;; (std net security-headers) — HTTP security response headers +;;; +;;; Middleware that adds standard security headers to HTTP responses. +;;; Prevents XSS, clickjacking, MIME sniffing, and other common attacks. + +(library (std net security-headers) + (export + default-security-headers + make-security-headers + apply-security-headers + with-security-headers + csp-header + hsts-header) + + (import (chezscheme)) + + ;; ========== Default Headers ========== + + (define default-security-headers + '(("X-Content-Type-Options" . "nosniff") + ("X-Frame-Options" . "DENY") + ("X-XSS-Protection" . "0") ;; Disabled — CSP is the modern solution + ("Referrer-Policy" . "strict-origin-when-cross-origin") + ("Permissions-Policy" . "geolocation=(), camera=(), microphone=()") + ("Cache-Control" . "no-store") + ("Content-Security-Policy" . "default-src 'self'; script-src 'self'; style-src 'self'; img-src 'self' data:; frame-ancestors 'none'"))) + + ;; ========== Custom Headers ========== + + (define (make-security-headers . opts) + ;; Create a custom set of security headers. + ;; opts: keyword list overriding defaults + ;; e.g., (make-security-headers 'csp: "default-src 'none'" 'frame: "SAMEORIGIN") + (let loop ([o opts] [headers default-security-headers]) + (if (or (null? o) (null? (cdr o))) + headers + (let ([key (car o)] [val (cadr o)]) + (loop (cddr o) + (case key + [(csp:) (alist-set headers "Content-Security-Policy" val)] + [(frame:) (alist-set headers "X-Frame-Options" val)] + [(referrer:) (alist-set headers "Referrer-Policy" val)] + [(permissions:) (alist-set headers "Permissions-Policy" val)] + [(cache:) (alist-set headers "Cache-Control" val)] + [(hsts:) (alist-set headers "Strict-Transport-Security" val)] + [else headers])))))) + + ;; ========== Apply Headers ========== + + (define (apply-security-headers response-headers . opts) + ;; Add security headers to an existing response header alist. + ;; Does NOT override headers already present in response. + (let ([sec-headers (if (pair? opts) (car opts) default-security-headers)]) + (fold-left + (lambda (headers pair) + (let ([name (car pair)] [val (cdr pair)]) + (if (assoc name headers) + headers ;; Don't override existing + (cons pair headers)))) + response-headers + sec-headers))) + + ;; ========== Middleware Wrapper ========== + + (define (with-security-headers handler . opts) + ;; Wrap an HTTP handler to add security headers. + ;; handler: (lambda (request) -> (status headers body)) + ;; Returns a new handler that adds security headers to the response. + (let ([sec-headers (if (pair? opts) (car opts) default-security-headers)]) + (lambda (request) + (let ([response (handler request)]) + (if (and (list? response) (>= (length response) 3)) + (let ([status (car response)] + [headers (cadr response)] + [body (caddr response)]) + (list status (apply-security-headers headers sec-headers) body)) + response))))) + + ;; ========== Content Security Policy Builder ========== + + (define (csp-header . directives) + ;; Build a Content-Security-Policy header value. + ;; directives: flat keyword list + ;; e.g., (csp-header 'default-src: "'self'" 'script-src: "'self' cdn.example.com") + (let loop ([d directives] [parts '()]) + (if (or (null? d) (null? (cdr d))) + (string-join-parts (reverse parts) "; ") + (let* ([key (car d)] + [val (cadr d)] + [name (let ([s (symbol->string key)]) + (if (and (> (string-length s) 0) + (char=? (string-ref s (- (string-length s) 1)) #\:)) + (substring s 0 (- (string-length s) 1)) + s))]) + (loop (cddr d) (cons (string-append name " " val) parts)))))) + + ;; ========== HSTS Header Builder ========== + + (define (hsts-header max-age . opts) + ;; Build a Strict-Transport-Security header value. + (let ([include-subdomains (memq 'include-subdomains opts)] + [preload (memq 'preload opts)]) + (string-append "max-age=" (number->string max-age) + (if include-subdomains "; includeSubDomains" "") + (if preload "; preload" "")))) + + ;; ========== Helpers ========== + + (define (alist-set alist key val) + (cons (cons key val) + (remove-matching (lambda (pair) (string=? (car pair) key)) alist))) + + (define (remove-matching pred lst) + (let loop ([l lst] [acc '()]) + (if (null? l) (reverse acc) + (loop (cdr l) (if (pred (car l)) acc (cons (car l) acc)))))) + + (define (string-join-parts lst sep) + (cond + [(null? lst) ""] + [(null? (cdr lst)) (car lst)] + [else (let loop ([rest (cdr lst)] [acc (car lst)]) + (if (null? rest) acc + (loop (cdr rest) (string-append acc sep (car rest)))))])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/security/auth.sls @@ -0,0 +1,223 @@ +#!chezscheme +;;; (std security auth) — Authentication framework +;;; +;;; Provides token-based authentication with: +;;; - API key validation +;;; - Session tokens with expiry +;;; - Bearer token middleware pattern +;;; - Rate limiting for auth attempts + +(library (std security auth) + (export + ;; API keys + make-api-key-store + api-key-store? + api-key-register! + api-key-validate + api-key-revoke! + + ;; Session tokens + make-session-store + session-store? + session-create! + session-validate + session-destroy! + session-cleanup! + + ;; Auth middleware pattern + make-auth-middleware + make-auth-result + auth-result? + auth-result-authenticated? + auth-result-identity + auth-result-roles + + ;; Rate limiting + make-rate-limiter + rate-limit-check!) + + (import (chezscheme) + (std crypto random) + (std crypto compare)) + + ;; ========== API Key Store ========== + + (define-record-type (api-key-store %make-api-key-store api-key-store?) + (sealed #t) + (fields + (immutable keys %api-key-store-keys) ;; hashtable: key-hash -> (identity roles) + (immutable mutex %api-key-store-mutex))) + + (define (make-api-key-store) + (%make-api-key-store + (make-hashtable string-hash string=?) + (make-mutex))) + + (define (api-key-register! store identity roles) + ;; Register a new API key. Returns the key string. + (let ([key (random-token 32)]) ;; 64-char hex string + (with-mutex (%api-key-store-mutex store) + (hashtable-set! (%api-key-store-keys store) key + (list identity roles))) + key)) + + (define (api-key-validate store key) + ;; Validate an API key. Returns (identity roles) or #f. + ;; Uses timing-safe comparison. + (with-mutex (%api-key-store-mutex store) + (let ([keys (%api-key-store-keys store)]) + ;; Must check all keys to prevent timing leaks + (let-values ([(ks vs) (hashtable-entries keys)]) + (let loop ([i 0] [found #f]) + (if (>= i (vector-length ks)) + found + (let ([stored-key (vector-ref ks i)] + [entry (vector-ref vs i)]) + (if (timing-safe-string=? key stored-key) + (loop (+ i 1) entry) + (loop (+ i 1) found))))))))) + + (define (api-key-revoke! store key) + (with-mutex (%api-key-store-mutex store) + (hashtable-delete! (%api-key-store-keys store) key))) + + ;; ========== Session Store ========== + + (define-record-type (session-store make-session-store* session-store?) + (sealed #t) + (fields + (immutable sessions %session-store-sessions) ;; hashtable: token -> (identity roles expiry) + (immutable mutex %session-store-mutex) + (immutable default-ttl %session-store-ttl))) ;; seconds + + (define (make-session-store . opts) + (let ([ttl (if (and (pair? opts) (pair? (cdr opts)) (eq? (car opts) 'ttl:)) + (cadr opts) + 3600)]) ;; Default: 1 hour + (make-session-store* + (make-hashtable string-hash string=?) + (make-mutex) + ttl))) + + (define (session-create! store identity roles) + ;; Create a new session. Returns the session token. + (let ([token (random-token 32)] + [expiry (+ (time-second (current-time 'time-utc)) + (%session-store-ttl store))]) + (with-mutex (%session-store-mutex store) + (hashtable-set! (%session-store-sessions store) token + (list identity roles expiry))) + token)) + + (define (session-validate store token) + ;; Validate a session token. Returns (identity roles) or #f. + (with-mutex (%session-store-mutex store) + (let ([entry (hashtable-ref (%session-store-sessions store) token #f)]) + (if entry + (let ([expiry (caddr entry)]) + (if (> (time-second (current-time 'time-utc)) expiry) + (begin + (hashtable-delete! (%session-store-sessions store) token) + #f) + (list (car entry) (cadr entry)))) + #f)))) + + (define (session-destroy! store token) + (with-mutex (%session-store-mutex store) + (hashtable-delete! (%session-store-sessions store) token))) + + (define (session-cleanup! store) + ;; Remove all expired sessions. + (with-mutex (%session-store-mutex store) + (let ([sessions (%session-store-sessions store)] + [now (time-second (current-time 'time-utc))]) + (let-values ([(ks vs) (hashtable-entries sessions)]) + (do ([i 0 (+ i 1)]) + ((= i (vector-length ks))) + (let ([expiry (caddr (vector-ref vs i))]) + (when (> now expiry) + (hashtable-delete! sessions (vector-ref ks i))))))))) + + ;; ========== Auth Result ========== + + (define-record-type (auth-result make-auth-result auth-result?) + (fields + (immutable authenticated? auth-result-authenticated?) + (immutable identity auth-result-identity) + (immutable roles auth-result-roles))) + + ;; ========== Auth Middleware ========== + + (define (make-auth-middleware validator) + ;; Create an auth middleware function. + ;; validator: (lambda (token) -> (identity roles) | #f) + ;; Returns: (lambda (handler) -> wrapped-handler) + (lambda (handler) + (lambda (request) + (let* ([auth-header (extract-auth-header request)] + [token (and auth-header (extract-bearer-token auth-header))] + [result (if token (validator token) #f)]) + (if result + (handler (cons (cons 'auth (make-auth-result #t (car result) (cadr result))) + request)) + (list 401 '(("WWW-Authenticate" . "Bearer")) "Unauthorized")))))) + + (define (extract-auth-header request) + ;; Extract Authorization header from request alist. + (let loop ([r request]) + (cond + [(null? r) #f] + [(and (pair? (car r)) (equal? (caar r) 'authorization)) + (cdar r)] + [(and (pair? (car r)) (equal? (caar r) "Authorization")) + (cdar r)] + [else (loop (cdr r))]))) + + (define (extract-bearer-token header) + ;; Extract token from "Bearer <token>" header value. + (let ([prefix "Bearer "]) + (if (and (>= (string-length header) (string-length prefix)) + (string=? (substring header 0 (string-length prefix)) prefix)) + (substring header (string-length prefix) (string-length header)) + #f))) + + ;; ========== Rate Limiter ========== + + (define-record-type (rate-limiter make-rate-limiter* rate-limiter?) + (sealed #t) + (fields + (immutable attempts %rl-attempts) ;; hashtable: key -> (count window-start) + (immutable mutex %rl-mutex) + (immutable max-attempts %rl-max) + (immutable window-seconds %rl-window))) + + (define (make-rate-limiter max-attempts window-seconds) + (make-rate-limiter* + (make-hashtable string-hash string=?) + (make-mutex) + max-attempts + window-seconds)) + + (define (rate-limit-check! limiter key) + ;; Check if a key (e.g., IP address) is within rate limits. + ;; Returns #t if allowed, #f if rate-limited. + (with-mutex (%rl-mutex limiter) + (let* ([now (time-second (current-time 'time-utc))] + [attempts (%rl-attempts limiter)] + [entry (hashtable-ref attempts key #f)]) + (cond + [(not entry) + ;; First attempt + (hashtable-set! attempts key (list 1 now)) + #t] + [(> (- now (cadr entry)) (%rl-window limiter)) + ;; Window expired, reset + (hashtable-set! attempts key (list 1 now)) + #t] + [(< (car entry) (%rl-max limiter)) + ;; Within limits + (hashtable-set! attempts key (list (+ (car entry) 1) (cadr entry))) + #t] + [else #f])))) ;; Rate limited + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-phase3-security.ss @@ -0,0 +1,173 @@ +#!chezscheme +;;; test-phase3-security.ss -- Tests for Phase 3 security modules + +(import (chezscheme) + (std net security-headers) + (std crypto password) + (std crypto aead) + (std security auth)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") (write 'expr) + (display " => ") (write result) + (display " expected ") (write exp) (newline))))])) + +(define-syntax check-error + (syntax-rules () + [(_ expr) + (guard (exn [#t (set! pass-count (+ pass-count 1))]) + expr + (set! fail-count (+ fail-count 1)) + (display "FAIL: expected error from ") (write 'expr) (newline))])) + +;; ========== Security Headers Tests ========== +(display " Testing security headers...\n") + +(check (pair? default-security-headers) => #t) +(check (and (assoc "X-Frame-Options" default-security-headers) #t) => #t) +(check (and (assoc "Content-Security-Policy" default-security-headers) #t) => #t) + +;; apply-security-headers +(let ([result (apply-security-headers '(("Content-Type" . "text/html")))]) + (check (and (assoc "X-Frame-Options" result) #t) => #t) + (check (and (assoc "Content-Type" result) #t) => #t)) + +;; Don't override existing headers +(let ([result (apply-security-headers '(("X-Frame-Options" . "SAMEORIGIN")))]) + (check (cdr (assoc "X-Frame-Options" result)) => "SAMEORIGIN")) + +;; CSP builder +(check (csp-header 'default-src: "'self'" 'script-src: "'none'") + => "default-src 'self'; script-src 'none'") + +;; HSTS builder +(check (hsts-header 31536000) => "max-age=31536000") +(check (hsts-header 31536000 'include-subdomains 'preload) + => "max-age=31536000; includeSubDomains; preload") + +;; Custom headers +(let ([custom (make-security-headers 'frame: "SAMEORIGIN")]) + (check (cdr (assoc "X-Frame-Options" custom)) => "SAMEORIGIN")) + +;; ========== Password Hashing Tests ========== +(display " Testing password hashing...\n") + +;; Basic hash and verify +(let ([hash (password-hash "mypassword" 'iterations: 10000)]) + (check (string? hash) => #t) + ;; Starts with $pbkdf2-sha256$ + (check (and (> (string-length hash) 15) + (string=? (substring hash 0 15) "$pbkdf2-sha256$")) => #t) + ;; Verify correct password + (check (password-verify "mypassword" hash) => #t) + ;; Reject wrong password + (check (password-verify "wrongpassword" hash) => #f)) + +;; Different passwords produce different hashes +(let ([h1 (password-hash "pass1" 'iterations: 10000)] + [h2 (password-hash "pass2" 'iterations: 10000)]) + (check (string=? h1 h2) => #f)) + +;; Same password with different salt produces different hashes +(let ([h1 (password-hash "same" 'iterations: 10000)] + [h2 (password-hash "same" 'iterations: 10000)]) + (check (string=? h1 h2) => #f)) + +;; ========== AEAD Tests ========== +(display " Testing AEAD encryption...\n") + +(let ([key (aead-key-generate)]) + (check (bytevector? key) => #t) + (check (bytevector-length key) => 32) + + ;; Encrypt and decrypt + (let* ([plaintext #vu8(72 101 108 108 111)] ;; "Hello" + [ct (aead-encrypt key plaintext)] + [pt (aead-decrypt key ct)]) + (check (equal? pt plaintext) => #t)) + + ;; String input + (let* ([ct (aead-encrypt key "Hello World")] + [pt (aead-decrypt key ct)]) + (check (equal? (utf8->string pt) "Hello World") => #t)) + + ;; With AAD + (let* ([ct (aead-encrypt key "secret" #vu8(1 2 3))] + [pt (aead-decrypt key ct #vu8(1 2 3))]) + (check (equal? (utf8->string pt) "secret") => #t)) + + ;; Wrong key fails + (let* ([ct (aead-encrypt key "test")] + [wrong-key (aead-key-generate)]) + (check-error (aead-decrypt wrong-key ct))) + + ;; Tampered ciphertext fails + (let ([ct (aead-encrypt key "test")]) + (bytevector-u8-set! ct 15 (bitwise-xor (bytevector-u8-ref ct 15) #xff)) + (check-error (aead-decrypt key ct)))) + +;; ========== Auth Module Tests ========== +(display " Testing auth module...\n") + +;; API key store +(let ([store (make-api-key-store)]) + (check (api-key-store? store) => #t) + (let ([key (api-key-register! store "user1" '(admin))]) + (check (string? key) => #t) + (check (= (string-length key) 64) => #t) ;; 32 bytes = 64 hex chars + ;; Validate + (let ([result (api-key-validate store key)]) + (check (pair? result) => #t) + (check (car result) => "user1") + (check (cadr result) => '(admin))) + ;; Invalid key + (check (api-key-validate store "invalid-key") => #f) + ;; Revoke + (api-key-revoke! store key) + (check (api-key-validate store key) => #f))) + +;; Session store +(let ([store (make-session-store 'ttl: 3600)]) + (check (session-store? store) => #t) + (let ([token (session-create! store "user1" '(read write))]) + (check (string? token) => #t) + ;; Validate + (let ([result (session-validate store token)]) + (check (pair? result) => #t) + (check (car result) => "user1")) + ;; Destroy + (session-destroy! store token) + (check (session-validate store token) => #f))) + +;; Rate limiter +(let ([limiter (make-rate-limiter 3 60)]) + (check (rate-limit-check! limiter "192.168.1.1") => #t) ;; 1st + (check (rate-limit-check! limiter "192.168.1.1") => #t) ;; 2nd + (check (rate-limit-check! limiter "192.168.1.1") => #t) ;; 3rd + (check (rate-limit-check! limiter "192.168.1.1") => #f) ;; 4th — blocked + ;; Different key is fine + (check (rate-limit-check! limiter "192.168.1.2") => #t)) + +;; Auth result +(let ([r (make-auth-result #t "user1" '(admin))]) + (check (auth-result? r) => #t) + (check (auth-result-authenticated? r) => #t) + (check (auth-result-identity r) => "user1") + (check (auth-result-roles r) => '(admin))) + +(display " phase3-security: ") +(display pass-count) (display " passed") +(when (> fail-count 0) + (display ", ") (display fail-count) (display " failed")) +(newline) +(when (> fail-count 0) (exit 1))