security: taint ring and websocket inputs
Jaime Fournier <jaimef@linbsd.org>
5c03e25f4a3659730ed20e3250a76d8e4100fc02
diff --git a/docs/kimi3-security-recommmendations.md b/docs/kimi3-security-recommmendations.md
index 47d74be..e292319 100644
--- a/docs/kimi3-security-recommmendations.md
+++ b/docs/kimi3-security-recommmendations.md
@@ -210,7 +210,7 @@ when" must be answerable from `dist/release-evidence/` in minutes.
| In-process bounded eval (engine timeout, result cap, fails closed on process controls) | `(std security sandbox)` `run-safe-eval` | exists; no memory limit, no FFI preemption (documented) | security-reference §6 |
| Capability tokens (sealed, CSPRNG nonce, monotone attenuation, revocation) | `(std security capability)` | exists; path checks reject symlink escapes and keep create-target compatibility | [security-reference.md](security-reference.md#3-capability-based-security) |
| Typed capability declarations | `(std security capability-typed)` | exists | security-reference §3 |
-| Taint tracking + safe sinks | `(std security taint)`, `(jerboa prelude safe)` | exists; safe prelude binds standard file/shell/delete sinks to taint-checking wrappers and taints env/file-content reads; protocol/network source marking remains explicit | security-reference §4 |
+| Taint tracking + safe sinks | `(std security taint)`, `(jerboa prelude safe)`, `(std net ring)`, `(std net websocket)`, `(std net fiber-ws)` | exists; safe prelude binds standard file/shell/delete sinks to taint-checking wrappers and taints env/file-content reads; Ring request fields and WebSocket/fiber WebSocket payloads are source-tainted at the protocol boundary | security-reference §4 |
| Kernel FS confinement (Linux 5.13+, ABI v1–v3) | `(std security landlock)`, `(std os landlock-native)` | real syscalls | security-reference §5 |
| Kernel syscall filter (BPF, x86_64 + aarch64 numbers) | `(std security seccomp)`, `(std os seccomp)` | real BPF | security-reference §5 |
| macOS / FreeBSD confinement | `(std security seatbelt)`, `(std security capsicum)` | exist | security-reference §5 |
@@ -305,7 +305,7 @@ when" must be answerable from `dist/release-evidence/` in minutes.
| Goal | Where we stand | The gap |
|---|---|---|
| G1 shrink target | Managed core is memory-safe; parsers budgeted; safe prelude exists; FFI audit inventory, per-site provisional verdicts, and FFI hazard scanner rules exist | FFI remediation remains: unsafe invariant comments, native export shrinking/justification, and the `vendor/jsqlite` decision |
-| G2 cap blast radius | Capabilities, taint, kernel sandbox, egress policy objects, worker facade, memory rlimit pre-exec path, egress proxy env wiring, and authenticated actor transport/envelopes all exist | **No native pre-exec worker backend yet for kernel sandbox controls before child input**; protocol/network taint source defaults remain open |
+| G2 cap blast radius | Capabilities, taint, kernel sandbox, egress policy objects, worker facade, memory rlimit pre-exec path, egress proxy env wiring, authenticated actor transport/envelopes, Ring HTTP source taint, and WebSocket/fiber WebSocket source taint all exist | **No native pre-exec worker backend yet for kernel sandbox controls before child input** |
| G3 find it first | 13 harnesses, scanner w/ rule DB, lint | No corpora, no crash regression, no scheduled fuzzing, no standing AI-red-team, no exploit-shaped regression suite |
| G4 fail closed | Raw-fork launchers retired correctly; `allow-degraded?` explicit | New controls must keep the invariant; degraded-mode warnings must be test-locked |
| G5 recover fast | SBOM/repro/signing gates exist | TCB accounting manual; doc drift (stale tables, undocumented modules); independent-builder reproducibility not yet routine |
@@ -649,16 +649,23 @@ Taint is opt-in; native sinks don't check it. In the safe prelude, the
now cover trim/split/join, UTF-8 string/bytevector conversion, bytevector
copy, and bytevector element reads. Safe-prelude `getenv`,
`read-file-string`, and `read-file-lines` now taint present environment
- variables and file contents by default. `benchmarks/bench-taint.ss` gives a
- reproducible local overhead measurement for taint propagation wrappers.
-- **Remaining:** (b) Taint sources by default for HTTP request fields and
- network frames — wrapped at the protocol boundary.
-- **Accept:** partially satisfied: tainted values reaching standard sink names
+ variables and file contents by default. `(std net ring)` now taints request
+ URI/path/query/body values and HTTP header values as `http-input`; `(std net
+ websocket)` taints decoded frame payloads as `net-input`; and
+ `(std net fiber-ws)` returns tainted text/binary messages from
+ `fiber-ws-recv`. `benchmarks/bench-taint.ss` gives a reproducible local
+ overhead measurement for taint propagation wrappers.
+- **Remaining:** complete for the documented safe-prelude, Ring, WebSocket,
+ and fiber WebSocket boundaries. Low-level HTTP server request records remain
+ raw for router compatibility and must be tainted explicitly or converted
+ through Ring before application exposure.
+- **Accept:** satisfied for the documented boundaries: tainted values reaching
+ standard sink names
in safe-prelude code raise `&taint-violation`; untainted flows are covered by
existing safe-prelude tests; env/file-content reads are tainted by default;
- `safety-guide.md` has a taint section; taint overhead has a reproducible
- benchmark. Full completion still requires source-default work at
- protocol/network boundaries.
+ Ring request fields and WebSocket/fiber WebSocket frames are tainted at the
+ protocol boundary; `safety-guide.md` has a taint section; taint overhead has a
+ reproducible benchmark.
### K3-P1-04 — Decide `define-syntax` in the sandbox allowlist
**Serves:** G1. **Effort:** 2–3 days.
@@ -1164,8 +1171,10 @@ fake confidence happens.
- Seccomp tables cover x86_64/aarch64 only; Landlock needs Linux 5.13+;
Seatbelt/Capsicum have thinner test coverage (P1-08).
- Safe-prelude file/shell/delete sink names now check taint, env/file content
- reads are source-tainted by default, and taint overhead has a benchmark;
- protocol/network source marking remains P1-03 follow-up.
+ reads are source-tainted by default, Ring HTTP request fields and
+ WebSocket/fiber WebSocket payloads are source-tainted at the documented
+ boundary, and taint overhead has a benchmark. Low-level HTTP request records
+ remain raw for router compatibility.
- Distributed actor authentication is available in `(std actor transport)` and
`(std actor distributed)` authenticated envelopes; compatibility raw
serialization remains unauthenticated.
diff --git a/docs/safety-guide.md b/docs/safety-guide.md
index d9a6431..93b2cbb 100644
--- a/docs/safety-guide.md
+++ b/docs/safety-guide.md
@@ -290,9 +290,12 @@ keep `(std security import-audit)` in the build gate for applications.
In `(jerboa prelude safe)`, `getenv`, `read-file-string`, and
`read-file-lines` are already source wrappers: present environment variables
are tagged as `env-input`, file contents are tagged as `file-input`, and
-missing environment-variable defaults are returned unchanged. Protocol and
-network modules still need explicit source marking unless their API documents a
-tainted-by-default boundary. Measure local taint wrapper overhead with
+missing environment-variable defaults are returned unchanged. Ring request
+URI/path/query/body values and HTTP header values are tagged as `http-input`;
+decoded WebSocket frame payloads and `fiber-ws-recv` messages are tagged as
+`net-input`. Low-level HTTP request records stay raw for router compatibility,
+so taint those fields explicitly or convert through Ring before handing them to
+application code. Measure local taint wrapper overhead with
`jerboa run benchmarks/bench-taint.ss 200000` before changing enforcement
policy for performance reasons.
diff --git a/docs/security-reference.md b/docs/security-reference.md
index dba3372..01c27a5 100644
--- a/docs/security-reference.md
+++ b/docs/security-reference.md
@@ -354,6 +354,23 @@ These automatically call `check-untainted!` and reject tainted arguments:
wrappers, and exports the core taint API so application code can mark input
boundaries without importing a separate module.
+Source boundaries also mark data on entry:
+
+- `(jerboa prelude safe)` taints present `getenv` results as `env-input`,
+ taints `read-file-string` results as `file-input`, and taints each
+ `read-file-lines` line as `file-input`.
+- `(std net ring)` taints Ring request URI/path/query/body values and HTTP
+ header values as `http-input`; request methods and header names remain raw so
+ routing and lookup keys keep their normal string behavior.
+- `(std net websocket)` taints decoded frame payloads as `net-input`, and
+ `(std net fiber-ws)` returns tainted text or binary messages from
+ `fiber-ws-recv`.
+
+Low-level HTTP server records from `(std net fiber-httpd)` and
+`(std net thread-httpd)` remain raw for router compatibility; code that exposes
+those records directly should convert through Ring or taint fields explicitly
+before passing them to application handlers.
+
The safe prelude also treats environment and file contents as taint sources:
`getenv` returns `env-input` taint for present variables, `read-file-string`
returns `file-input` taint, and `read-file-lines` taints each returned line.
@@ -923,10 +940,11 @@ These are known gaps documented as current limitations, not implementation promi
binds default file/shell/delete sink names to taint-checking wrappers and
exports taint-propagating wrappers for common string/bytevector transforms.
Safe-prelude `getenv`, `read-file-string`, and `read-file-lines` mark
- environment and file contents by default, but raw Chez operations and unsafe
- imports do not check taint. Protocol and network sources still need explicit
- `taint-*` marking until those modules wrap inputs by default. Track local
- taint overhead with `benchmarks/bench-taint.ss` before accepting any
+ environment and file contents by default. Ring request fields are marked as
+ `http-input`, and decoded WebSocket/fiber WebSocket payloads are marked as
+ `net-input`. Raw Chez operations, unsafe imports, and low-level HTTP request
+ records do not check or add taint. Track local taint overhead with
+ `benchmarks/bench-taint.ss` before accepting any
performance-based de-optimization.
- **Distributed actor authentication is opt-in at the serialization layer.** `(std actor transport)` authenticates TCP traffic, and `(std actor distributed)` exposes HMAC'd envelopes with timestamp and monotonic sequence replay checks. Compatibility callers that use only `serialize-message` / `deserialize-message` still get parsing limits but no peer authentication.
- **Filesystem capabilities are not process sandboxes.** They validate paths at
diff --git a/lib/std/net/fiber-ws.ss b/lib/std/net/fiber-ws.ss
index 99bd938..c7eca56 100644
--- a/lib/std/net/fiber-ws.ss
+++ b/lib/std/net/fiber-ws.ss
@@ -10,7 +10,8 @@
;;; (fiber-ws-open? ws) — is connection open?
;;; (fiber-ws-client? ws) — is this a client connection?
;;; (fiber-ws-recv ws) — receive message (parks fiber)
-;;; returns string, bytevector, or #f
+;;; returns tainted string,
+;;; tainted bytevector, or #f
;;; (fiber-ws-send ws msg) — send text message
;;; (fiber-ws-send-binary ws bv) — send binary message
;;; (fiber-ws-close ws) — send close frame and shut down
@@ -41,6 +42,7 @@
(std fiber)
(std net io)
(std net websocket)
+ (only (std security taint) taint-net untaint)
(only (jerboa core) def defstruct try catch finally))
;; ========== Fiber WebSocket record ==========
@@ -287,7 +289,10 @@
[payload (ws-frame-payload frame)])
(cond
[(= opcode ws-opcode-text)
- (bytevector->string payload (make-transcoder (utf-8-codec)))]
+ (taint-net
+ (bytevector->string
+ (untaint payload)
+ (make-transcoder (utf-8-codec))))]
[(= opcode ws-opcode-binary) payload]
[(= opcode ws-opcode-close)
(try (write-ws-frame-via ws (ws-close-frame))
diff --git a/lib/std/net/ring.ss b/lib/std/net/ring.ss
index 0dd43cb..78fd64f 100644
--- a/lib/std/net/ring.ss
+++ b/lib/std/net/ring.ss
@@ -8,11 +8,11 @@
;;;
;;; Request alist keys:
;;; request-method — string: "GET", "POST", etc.
-;;; uri — string: full path including query string
-;;; path — string: path without query string
-;;; query-string — string: query string (or "")
-;;; headers — alist of (name . value)
-;;; body — string or #f
+;;; uri — tainted string: full path including query string
+;;; path — tainted string: path without query string
+;;; query-string — tainted string: query string (or "")
+;;; headers — alist of (name . tainted value)
+;;; body — tainted string or #f
;;; scheme — symbol: 'http or 'https
;;; server-port — integer
;;;
@@ -59,6 +59,7 @@
(import (chezscheme)
(std net fiber-httpd)
(std text json)
+ (only (std security taint) taint taint-http tainted? taint-class untaint)
(only (jerboa core) def try catch finally))
;; =========================================================================
@@ -91,14 +92,31 @@
;; Request/Response conversion
;; =========================================================================
+ (def (http-taint-field value)
+ (cond
+ [(not value) value]
+ [(tainted? value) value]
+ [(string? value) (taint-http value)]
+ [else value]))
+
+ (def (http-taint-header-values headers)
+ (map (lambda (header)
+ (if (pair? header)
+ (cons (car header) (http-taint-field (cdr header)))
+ header))
+ (or headers '())))
+
+ (def (maybe-taint-http-class cls value)
+ (if cls (taint cls value) value))
+
(def (request->ring req)
(list
(cons 'request-method (request-method req))
- (cons 'uri (request-path req))
- (cons 'path (request-path-only req))
- (cons 'query-string (request-query-string req))
- (cons 'headers (or (request-headers req) '()))
- (cons 'body (or (request-body req) #f))
+ (cons 'uri (http-taint-field (request-path req)))
+ (cons 'path (http-taint-field (request-path-only req)))
+ (cons 'query-string (http-taint-field (request-query-string req)))
+ (cons 'headers (http-taint-header-values (request-headers req)))
+ (cons 'body (http-taint-field (request-body req)))
(cons 'scheme 'http)))
(def (ring->response ring-resp)
@@ -149,10 +167,11 @@
(def (wrap-json-body handler)
(lambda (req)
(let ([content-type (alist-ref (alist-ref req 'headers '())
- "Content-Type" "")])
- (if (and (alist-ref req 'body)
- (%string-contains content-type "application/json"))
- (try (let ([parsed (string->json-object (alist-ref req 'body))])
+ "Content-Type" "")]
+ [body (alist-ref req 'body)])
+ (if (and body
+ (%string-contains (untaint content-type) "application/json"))
+ (try (let ([parsed (string->json-object (untaint body))]) ; jerboa-security: suppress unguarded-string-to-json-on-hostile -- guarded by try/catch below; malformed JSON falls through to the original request
(handler (alist-set req 'json-body parsed)))
(catch (exn) (handler req)))
(handler req)))))
@@ -198,17 +217,22 @@
(handler (alist-set req 'params params)))))
(def (parse-query-string qs)
- (if (or (not qs) (string=? qs ""))
- '()
- (let ([pairs (string-split-char qs #\&)])
- (filter-map
- (lambda (pair)
- (let ([idx (string-index-of pair #\=)])
- (if idx
- (cons (substring pair 0 idx)
- (url-decode (substring pair (+ idx 1) (string-length pair))))
- (cons pair ""))))
- pairs))))
+ (let ([cls (and (tainted? qs) (taint-class qs))]
+ [raw (untaint qs)])
+ (if (or (not raw) (string=? raw ""))
+ '()
+ (let ([pairs (string-split-char raw #\&)])
+ (filter-map
+ (lambda (pair)
+ (let ([idx (string-index-of pair #\=)])
+ (if idx
+ (cons (substring pair 0 idx)
+ (maybe-taint-http-class
+ cls
+ (url-decode
+ (substring pair (+ idx 1) (string-length pair)))))
+ (cons pair (maybe-taint-http-class cls "")))))
+ pairs)))))
(def (string-split-char s ch)
(let loop ([start 0] [acc '()])
@@ -286,17 +310,21 @@
set-cookies)))))))))
(def (parse-cookies header)
- (if (string=? header "")
- '()
- (filter-map
- (lambda (part)
- (let ([trimmed (string-trim-both part)])
- (let ([idx (string-index-of trimmed #\=)])
- (if idx
- (cons (substring trimmed 0 idx)
- (substring trimmed (+ idx 1) (string-length trimmed)))
- #f))))
- (string-split-char header #\;))))
+ (let ([cls (and (tainted? header) (taint-class header))]
+ [raw (untaint header)])
+ (if (string=? raw "")
+ '()
+ (filter-map
+ (lambda (part)
+ (let ([trimmed (string-trim-both part)])
+ (let ([idx (string-index-of trimmed #\=)])
+ (if idx
+ (cons (substring trimmed 0 idx)
+ (maybe-taint-http-class
+ cls
+ (substring trimmed (+ idx 1) (string-length trimmed))))
+ #f))))
+ (string-split-char raw #\;)))))
(def (format-cookie c)
;; c is an alist: ((name . val) (path . "/") (max-age . 3600) ...)
@@ -335,10 +363,11 @@
(lambda (req)
(let* ([cookies (alist-ref req 'cookies '())]
[sid (alist-ref cookies cookie-name #f)]
- [session (if (and sid (hashtable-contains? store sid))
- (hashtable-ref store sid '())
+ [sid-key (and sid (untaint sid))]
+ [session (if (and sid-key (hashtable-contains? store sid-key))
+ (hashtable-ref store sid-key '())
'())]
- [new-sid (or sid (generate-session-id))]
+ [new-sid (or sid-key (generate-session-id))]
[resp (handler (alist-set req 'session session))])
;; Save updated session from response
(let ([updated-session (alist-ref resp 'session #f)])
@@ -414,7 +443,7 @@
(let ([etag (alist-ref (alist-ref resp 'headers '()) "ETag" #f)]
[if-none-match (alist-ref (alist-ref req 'headers '())
"If-None-Match" #f)])
- (if (and etag if-none-match (string=? etag if-none-match)
+ (if (and etag if-none-match (string=? (untaint etag) (untaint if-none-match))
(= (alist-ref resp 'status 200) 200))
(list (cons 'status 304) (cons 'headers '()) (cons 'body ""))
resp)))))
@@ -452,7 +481,7 @@
(def (wrap-static prefix dir)
(lambda (handler)
(lambda (req)
- (let ([path (alist-ref req 'path "")])
+ (let ([path (untaint (alist-ref req 'path ""))])
(if (and (>= (string-length path) (string-length prefix))
(string=? (substring path 0 (string-length prefix)) prefix))
(let ([file-path (string-append dir
diff --git a/lib/std/net/websocket.ss b/lib/std/net/websocket.ss
index 0dc1029..3ec71b6 100644
--- a/lib/std/net/websocket.ss
+++ b/lib/std/net/websocket.ss
@@ -26,6 +26,7 @@
(import (except (chezscheme) base64-encode base64-decode)
(std crypto native-rust)
(std text base64)
+ (only (std security taint) taint-net untaint)
(only (jerboa core) def defstruct))
;;; ========== Opcode constants ==========
@@ -76,7 +77,9 @@
;;; ========== Masking ==========
;; XOR payload bytes with 4-byte mask key cyclically.
(def (ws-mask-payload payload mask-key)
- (let* ([len (bytevector-length payload)]
+ (let* ([payload (untaint payload)]
+ [mask-key (untaint mask-key)]
+ [len (bytevector-length payload)]
[result (make-bytevector len)])
(do ([i 0 (+ i 1)])
((= i len) result)
@@ -100,8 +103,8 @@
(let* ([fin? (ws-frame-rec-fin? frame)]
[masked? (ws-frame-rec-masked? frame)]
[opcode (ws-frame-rec-opcode frame)]
- [payload (ws-frame-rec-payload frame)]
- [mask-key (ws-frame-rec-mask-key frame)]
+ [payload (untaint (ws-frame-rec-payload frame))]
+ [mask-key (untaint (ws-frame-rec-mask-key frame))]
[plen (bytevector-length payload)]
;; Determine extended length encoding
[ext-bytes (cond [(< plen 126) 0]
@@ -213,7 +216,7 @@
[payload (if (and masked? mask-key)
(ws-unmask-payload raw-payload mask-key)
raw-payload)])
- (make-ws-frame fin? masked? opcode payload mask-key)))))))
+ (make-ws-frame fin? masked? opcode (taint-net payload) mask-key)))))))
;;; ========== Handshake ==========
;; The WebSocket handshake uses SHA-1 of (key + GUID) then base64.
diff --git a/tests/test-fiber-ws.ss b/tests/test-fiber-ws.ss
index 2b3ac46..8d2c6e8 100644
--- a/tests/test-fiber-ws.ss
+++ b/tests/test-fiber-ws.ss
@@ -9,6 +9,7 @@
(import (std net fiber-httpd))
(import (std text base64))
(import (std crypto native-rust))
+(import (std security taint))
(define test-count 0)
(define pass-count 0)
@@ -72,7 +73,7 @@
(let* ([bv (let ([b (make-bytevector n)])
(bytevector-copy! buf 0 b 0 n) b)]
[frame (ws-frame-decode bv)])
- (bytevector->string (ws-frame-payload frame)
+ (bytevector->string (untaint (ws-frame-payload frame))
(make-transcoder (utf-8-codec))))))))
;; Helper: send masked close frame
@@ -94,9 +95,10 @@
(let loop ()
(let ([msg (fiber-ws-recv ws)])
(when msg
- (if (string? msg)
- (fiber-ws-send ws msg)
- (fiber-ws-send-binary ws msg))
+ (let ([raw (untaint msg)])
+ (if (string? raw)
+ (fiber-ws-send ws raw)
+ (fiber-ws-send-binary ws raw)))
(loop))))
(fiber-ws-close ws)))))
(respond-text 200 "not a websocket")))))
@@ -120,7 +122,7 @@
[decoded (ws-frame-decode encoded)])
(assert-true (ws-frame-fin? decoded) "FIN set")
(assert-equal (ws-frame-opcode decoded) ws-opcode-text "opcode text")
- (assert-equal (ws-frame-payload decoded) payload "payload matches")))
+ (assert-equal (untaint (ws-frame-payload decoded)) payload "payload matches")))
;; =========================================================================
;; Test 3: Masked frame round-trip
@@ -137,7 +139,7 @@
[encoded (ws-frame-encode frame)]
[decoded (ws-frame-decode encoded)])
(assert-true (ws-frame-masked? decoded) "masked")
- (assert-equal (ws-frame-payload decoded) payload "unmasked correctly"))))
+ (assert-equal (untaint (ws-frame-payload decoded)) payload "unmasked correctly"))))
;; =========================================================================
;; Test 4: Full WebSocket echo via fiber-httpd
@@ -183,7 +185,7 @@
(let loop ()
(let ([msg (fiber-ws-recv ws)])
(when msg
- (fiber-ws-send ws (string-append "echo:" msg))
+ (fiber-ws-send ws (string-append "echo:" (untaint msg)))
(loop))))
(fiber-ws-close ws)))))
(respond-text 200 "http"))))]
diff --git a/tests/test-ring-taint.ss b/tests/test-ring-taint.ss
new file mode 100644
index 0000000..c64a1ca
--- /dev/null
+++ b/tests/test-ring-taint.ss
@@ -0,0 +1,78 @@
+#!chezscheme
+;;; Ring request boundary taint tests.
+
+(import (scheme)
+ (std net ring)
+ (prefix (std net fiber-httpd) f:)
+ (std security taint))
+
+(define pass 0)
+(define fail 0)
+
+(define-syntax test
+ (syntax-rules ()
+ [(_ name expr expected)
+ (guard (exn [#t (set! fail (+ fail 1))
+ (printf "FAIL ~a: ~a~%" name
+ (if (message-condition? exn) (condition-message exn) exn))])
+ (let ([got expr])
+ (if (equal? got expected)
+ (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name))
+ (begin (set! fail (+ fail 1))
+ (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))]))
+
+(define (alist-ref alist key . default)
+ (let ([entry (assoc key alist)])
+ (if entry
+ (cdr entry)
+ (if (pair? default) (car default) #f))))
+
+(printf "--- Ring protocol taint boundary ---~%~%")
+
+(define req
+ (f:make-request
+ "GET"
+ "/search?q=jerboa&empty="
+ "HTTP/1.1"
+ '(("Host" . "example.test") ("Cookie" . "sid=abc"))
+ "payload"))
+
+(define ring-req (request->ring req))
+
+(test "ring path is tainted"
+ (tainted? (alist-ref ring-req 'path))
+ #t)
+
+(test "ring path taint class"
+ (taint-class (alist-ref ring-req 'path))
+ 'http-input)
+
+(test "ring header values are tainted"
+ (tainted? (cdr (assoc "Host" (alist-ref ring-req 'headers))))
+ #t)
+
+(test "ring body is tainted"
+ (tainted? (alist-ref ring-req 'body))
+ #t)
+
+(test "wrap-params preserves query value taint"
+ (let ([value ((wrap-params
+ (lambda (r)
+ (alist-ref (alist-ref r 'params) "q")))
+ ring-req)])
+ (and (tainted? value) (taint-class value)))
+ 'http-input)
+
+(test "wrap-cookies preserves cookie value taint"
+ (alist-ref
+ ((wrap-cookies
+ (lambda (r)
+ (let ([value (alist-ref (alist-ref r 'cookies) "sid")])
+ (ring-response 200 (and (tainted? value) (taint-class value))))))
+ ring-req)
+ 'body)
+ 'http-input)
+
+(newline)
+(printf "Results: ~a passed, ~a failed~%" pass fail)
+(unless (zero? fail) (exit 1))
diff --git a/tests/test-websocket.ss b/tests/test-websocket.ss
index 6720f15..c2423d5 100644
--- a/tests/test-websocket.ss
+++ b/tests/test-websocket.ss
@@ -1,7 +1,7 @@
#!chezscheme
;;; Tests for (std net websocket) -- WebSocket protocol (RFC 6455)
-(import (scheme) (std net websocket))
+(import (scheme) (std net websocket) (std security taint))
(define pass 0)
(define fail 0)
@@ -66,8 +66,22 @@
[frame (ws-text-frame payload)]
[enc (ws-frame-encode frame)]
[dec (ws-frame-decode enc)])
- (utf8->string (ws-frame-payload dec)))
+ (utf8->string (untaint (ws-frame-payload dec))))
"Hello, WebSocket!")
+(begin
+ (test "decode payload is net-tainted"
+ (let* ([payload (string->utf8 "from wire")]
+ [frame (ws-text-frame payload)]
+ [dec (ws-frame-decode (ws-frame-encode frame))])
+ (tainted? (ws-frame-payload dec)))
+ #t)
+
+ (test "decode payload taint class"
+ (let* ([payload (string->utf8 "from wire")]
+ [frame (ws-text-frame payload)]
+ [dec (ws-frame-decode (ws-frame-encode frame))])
+ (taint-class (ws-frame-payload dec)))
+ 'net-input))
(test "encode-decode-fin"
(let* ([frame (ws-text-frame (string->utf8 "test"))]
@@ -84,7 +98,7 @@
(test "encode-decode-empty-payload"
(let* ([frame (ws-close-frame)]
[dec (ws-frame-decode (ws-frame-encode frame))])
- (bytevector-length (ws-frame-payload dec)))
+ (bytevector-length (untaint (ws-frame-payload dec))))
0)
;;; ======== Large payload (16-bit extended length) ========
@@ -93,7 +107,7 @@
(let* ([payload (make-bytevector 200 42)]
[frame (ws-binary-frame payload)]
[dec (ws-frame-decode (ws-frame-encode frame))]
- [got (ws-frame-payload dec)])
+ [got (untaint (ws-frame-payload dec))])
(and (= (bytevector-length got) 200)
(= (bytevector-u8-ref got 0) 42)
(= (bytevector-u8-ref got 199) 42)))
@@ -111,7 +125,7 @@
[frame (make-ws-frame #t #t ws-opcode-text payload mask)]
[enc (ws-frame-encode frame)]
[dec (ws-frame-decode enc)])
- (utf8->string (ws-frame-payload dec)))
+ (utf8->string (untaint (ws-frame-payload dec))))
"masked data")
(test "masked-frame-flag"