Resolve security audit findings
ober
46038ee043921c63e28d0bc760f7470efa198435
--- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -12,14 +12,13 @@ permissions: env: JERBOA_VERSION: v0.2.3 JERBUILD: ${{ github.workspace }}/.jerboa/bin/jerbuild - JERBOA_SSL_REPO: https://git.sr.ht/~lisp/jerboa-ssl SSL_DIR: ${{ github.workspace }}/../jerboa-ssl jobs: verify: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@34e114876b0b11c390a56381ad16ebd13914f8d5 # v4 - name: Install system tools run: | @@ -36,7 +35,7 @@ jobs: - name: Fetch TLS dependency run: | set -eu - git clone --depth 1 "$JERBOA_SSL_REPO" "$SSL_DIR" + support/locked-dependency.sh fetch dependencies.lock jerboa-ssl "$SSL_DIR" - name: Verify run: make verify --- a/.github/workflows/security-baseline.yml +++ b/.github/workflows/security-baseline.yml @@ -13,7 +13,7 @@ jobs: baseline: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@34e114876b0b11c390a56381ad16ebd13914f8d5 # v4 - name: Required release files run: | --- a/.jerboa/security.json +++ b/.jerboa/security.json @@ -16,7 +16,12 @@ "parser": { "requireMalformedInputCorpus": true, "requireSmugglingTests": true }, "filesystem": { "staticServingRequiresTraversalTests": true }, "tls": { "requireModernProtocolDefaults": true }, - "supplyChain": { "sbom": "required", "reproducibilityReport": "required", "dependencyEvidence": ["jerboa-ssl"] }, + "supplyChain": { + "sbom": "required", + "reproducibilityReport": "required", + "dependencyLock": "dependencies.lock", + "dependencyEvidence": ["jerboa-ssl"] + }, "releaseEvidence": { "httpdLoadProof": { "proofFileEnv": "JHTTPS_TARGET_LOAD_PROOF_FILE", --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ ifeq ($(JH),) $(error jerbuild not found on PATH (or '$(JERBUILD) --jerboa-home' failed). Install jerbuild, or set JERBUILD=/path/to/jerbuild) endif -SSL_DIR ?= ../jerboa-ssl +SSL_DIR ?= $(abspath ../jerboa-ssl) LIBDIRS = lib:$(SSL_DIR)/lib:$(JH)/lib NATIVE_DIR := $(JH)/jerboa-native-rs/target/release RUNTIME_LIBDIRS = $(SSL_DIR):$(NATIVE_DIR) @@ -27,11 +27,15 @@ else LD_VAR = LD_LIBRARY_PATH endif -.PHONY: all build transpile wasm wasm-clean test test-https test-httpd security audit fuzz-check load-smoke fuzz-evidence tls-proxy-evidence sbom reproducibility-report soak-evidence verify release-evidence clean deps +.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 all: build -deps: +dependency-lock-check: + support/locked-dependency.sh check dependencies.lock + support/locked-dependency.sh verify dependencies.lock jerboa-ssl "$(SSL_DIR)" + +deps: dependency-lock-check $(MAKE) -C $(SSL_DIR) build transpile: @@ -45,14 +49,24 @@ wasm-clean: build: deps wasm transpile -test: test-https test-httpd +test: test-https test-https-security test-httpd test-https: build + JERBOA_SSL_ALLOW_DYNAMIC_NATIVE=1 \ JERBOA_SSL_LIB=$(SSL_DIR) \ $(LD_VAR)=$(RUNTIME_LIBDIRS) \ $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/https-test.ss +test-https-security: build + JERBUILD="$(JERBUILD)" \ + LIBDIRS="$(LIBDIRS)" \ + SSL_DIR="$(SSL_DIR)" \ + JHTTPS_LD_VAR="$(LD_VAR)" \ + JHTTPS_RUNTIME_LIBDIRS="$(RUNTIME_LIBDIRS)" \ + tests/run-https-security-test.sh + test-httpd: build + JERBOA_SSL_ALLOW_DYNAMIC_NATIVE=1 \ JERBOA_SSL_LIB=$(SSL_DIR) \ $(LD_VAR)=$(RUNTIME_LIBDIRS) \ $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/httpd-test.ss @@ -79,11 +93,13 @@ fuzz-check: build echo "cargo-fuzz with nightly Rust unavailable; falling back to cargo check"; \ cargo check --manifest-path fuzz/Cargo.toml --bins; \ fi + JERBOA_SSL_ALLOW_DYNAMIC_NATIVE=1 \ JERBOA_SSL_LIB=$(SSL_DIR) \ $(LD_VAR)=$(RUNTIME_LIBDIRS) \ $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/httpd-fuzz-test.ss load-smoke: build + JERBOA_SSL_ALLOW_DYNAMIC_NATIVE=1 \ JERBOA_SSL_LIB=$(SSL_DIR) \ $(LD_VAR)=$(RUNTIME_LIBDIRS) \ $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/httpd-load-smoke.ss @@ -110,6 +126,8 @@ release-evidence: verify mkdir -p "$(DIST_DIR)" git rev-parse HEAD > "$(DIST_DIR)/git-commit.txt" git status --short > "$(DIST_DIR)/git-status.txt" + cp dependencies.lock "$(DIST_DIR)/dependencies.lock" + support/locked-dependency.sh verify dependencies.lock jerboa-ssl "$(SSL_DIR)" > "$(DIST_DIR)/dependency-lock-verification.txt" { \ printf 'os=%s\n' "$$(uname -s)"; \ printf 'kernel_release=%s\n' "$$(uname -r)"; \ --- a/README.md +++ b/README.md @@ -4,25 +4,23 @@ Native HTTP/1.1 client over TLS for Chez Scheme. No subprocesses. No curl. Pure ## Dependencies -- [chez-ssl](https://github.com/ober/chez-ssl) — TLS transport layer -- [chez-zlib](https://github.com/ober/chez-zlib) — zlib compression (optional, for decompressing gzip response bodies) +- `jerboa-ssl` — TLS transport layer, locked by commit and tree in + `dependencies.lock` - Chez Scheme 10.x - OpenSSL (`libssl`, `libcrypto`) ## Installation ```bash -# Clone dependencies -git clone https://github.com/ober/chez-ssl.git ~/mine/chez-ssl -git clone https://github.com/ober/chez-zlib.git ~/mine/chez-zlib - -# Build chez-ssl -cd ~/mine/chez-ssl && make - -# Clone this library -git clone https://github.com/ober/chez-https.git ~/mine/chez-https +# From this checkout, fetch the reviewed dependency revision. +support/locked-dependency.sh fetch dependencies.lock jerboa-ssl ~/mine/jerboa-ssl +make ``` +CI uses the same lock verifier. Updating `jerboa-ssl` requires a reviewed +commit and tree-hash change in `dependencies.lock`; default branches are never +consumed by the build. + ## Usage ```scheme @@ -86,15 +84,30 @@ git clone https://github.com/ober/chez-https.git ~/mine/chez-https | `(flatten-request-headers hdrs)` | Flatten `(name :: value)` format to alist | | `(build-query-string params)` | Build URL query string from params | +### Response policy + +`(http-client-config)` returns the active bounded response policy. Set startup +limits with options such as `max-header-bytes:`, `max-headers:`, `max-body:`, +`max-chunk:`, `max-chunked-wire:`, `idle-timeout:`, and `total-timeout:`. +Values must be positive exact integers. Configure the policy before issuing +concurrent requests. + ## Features - HTTPS via OpenSSL (TLS 1.2/1.3) - SNI and hostname verification -- Chunked transfer encoding +- Streaming, bounded chunked transfer decoding +- Strict duplicate/conflicting response-framing rejection +- Header, decoded-body, raw-chunked-body, chunk-size, idle, and total limits +- RFC-token/control-character validation before request serialization - 100 Continue handling - Binary response body preservation (critical for gzip/binary downloads) - Configurable HTTPD worker count, listen backlog, queue capacity, request timeout, response timeout, header count, and body size limits +- Bounded TLS handshake workers, queue, short handshake deadline, and + global/per-IP pre-authentication limits +- Descriptor-pinned static-file serving with canonical containment and inode + identity verification - S3-compatible header format (`::` separator convention) - URL encoding (RFC 3986) - Automatic SSL initialization @@ -105,6 +118,11 @@ git clone https://github.com/ober/chez-https.git ~/mine/chez-https make test ``` +The tests include a local self-signed TLS peer for hostile response framing and +deadline cases. Interpreter-based development explicitly opts into loading +`jerboa-ssl` from its canonical absolute directory; production binaries should +statically register the TLS shim. + ## Release Evidence The HTTPD surface is private until the daemon release gate is complete. Run: @@ -131,7 +149,7 @@ into `dist/release-evidence/tls-proxy-policy.txt`. ``` chez-https (this library) │ - └── chez-ssl (TLS transport) + └── jerboa-ssl (TLS transport) │ └── OpenSSL (libssl, libcrypto) ``` --- a/SECURITY.md +++ b/SECURITY.md @@ -57,10 +57,21 @@ generated libraries or build logs. - Bounded sequential, concurrent, and queue-recovery behavior must stay covered by `make load-smoke`. - Static file serving must remain traversal-resistant. +- Client response parsing must retain strict framing validation, bounded + header/body/chunk policies, overflow-safe lengths, and idle plus total + deadlines. `make test-https-security` is required evidence. +- Request and response serialization must reject invalid token names and + control characters before writing any bytes. +- Static serving must use the same descriptor for authorization and response + data; path-only authorization followed by reopen is prohibited. +- HTTPS handshakes must remain outside the accept loop behind bounded workers, + a bounded queue, a short deadline, and global/per-IP pre-auth limits. - Timeout, max header, max body, worker, backlog, queue-capacity, and slow-client behavior are release gates; `request-timeout:`, `response-timeout:`, `workers:`, `backlog:`, and `queue-capacity:` must be set explicitly for daemon deployments. +- The `jerboa-ssl` commit and tree must match `dependencies.lock`; release CI + must not clone or fetch a mutable default branch. - Plain HTTP listeners must remain private or behind a reviewed TLS proxy. - Public production deployment still requires queue-exhaustion/load evidence, TLS dependency evidence from `jerboa-ssl`, SBOM/reproducibility evidence, and --- a/chez-https.md +++ b/chez-https.md @@ -120,12 +120,20 @@ Content-Length: 12345\r\n Read the response in two phases: -1. **Read headers**: Read bytes until `\r\n\r\n`. Parse the status line (`HTTP/1.1 200 OK`) and headers. +1. **Read headers**: Stream CRLF-delimited lines through a bounded transport + buffer. Enforce status-line, header-line, total-header-byte, and header-count + limits before parsing. 2. **Read body**: Based on headers: - - If `Content-Length` is present: read exactly that many bytes - - If `Transfer-Encoding: chunked`: read chunked encoding (each chunk prefixed with hex length) - - Otherwise: read until connection close (EOF) + - Reject duplicate/conflicting framing and parse decimal/hex sizes without + overflowing the configured bounds. + - If `Content-Length` is present: read exactly that many bounded bytes. + - If `Transfer-Encoding: chunked`: stream chunks with individual, decoded, + and raw-wire limits, strict CRLF, and bounded trailers. + - Otherwise: read until connection close (EOF), subject to the body cap. + +Both idle I/O timeouts and a monotonic total response deadline apply. Truncated +bodies are errors; partial hostile responses are never returned as success. **Chunked transfer encoding** is used by some AWS responses. Format: new file mode 100644 --- /dev/null +++ b/dependencies.lock @@ -0,0 +1,2 @@ +# name repository commit tree +jerboa-ssl https://git.sr.ht/~lisp/jerboa-ssl 270b858534941baad6420e4906a26c279f4a8678 4d629174bbff9b1cd2ff1aa696be0cd33bf462e4 --- a/docs/release-evidence.md +++ b/docs/release-evidence.md @@ -16,6 +16,8 @@ The `release-evidence` target runs `make verify` first, then writes untracked artifacts under `dist/release-evidence/`: - `git-commit.txt` and `git-status.txt`. +- `dependencies.lock` and `dependency-lock-verification.txt`, proving the + exact `jerboa-ssl` commit and tree used by the build. - `build-environment.txt` with OS and Jerboa toolchain identity. - `sbom/` and `sbom.log` with toolchain identity, source hashes, generated library hashes, and local `jerboa-ssl` dependency hashes. @@ -38,6 +40,8 @@ artifacts under `dist/release-evidence/`: and `rustsec-wasm.txt` for the HTTP parser sandbox supply chain. - `scheme-inputs.txt` listing the Scheme source and generated library inputs used by tests. +- Local TLS security-test output covers hostile client responses and bounded + TLS pre-authentication admission/recovery as part of `make test`. - `tls-dependency-inputs.txt` and `tls-shim-sha256.txt` for the local `jerboa-ssl` dependency. - `tls-proxy-policy.txt`, generated from `docs/tls-proxy-policy.md`, with TLS --- a/docs/threat-model.md +++ b/docs/threat-model.md @@ -6,16 +6,16 @@ release plan and production-readiness tracker are complete. ## Scope -This model covers the HTTPD surface in `src/jerboa-https/httpd.ss`: request -parsing, response generation, static file serving, body handling, and network -service behavior. TLS termination, certificate provisioning, reverse-proxy -configuration, and deployment firewalls are external unless a future server -entrypoint manages them directly. +This model covers the HTTP client response/request boundary and the HTTPD +surface: parsing, serialization, static file serving, body handling, TLS +handshake admission, and network service behavior. Certificate provisioning, +reverse-proxy configuration, and deployment firewalls remain external. ## Assets - Static file roots and any files reachable from them. - Service availability and worker queue capacity. +- Client-process memory and availability while reading hostile responses. - Request/response logs that may contain paths, headers, query strings, or credentials. - TLS private keys if a deployment colocates termination with the service. @@ -25,13 +25,16 @@ entrypoint manages them directly. - Network boundary: every request line, header, body byte, and connection timing pattern is hostile. +- Client-response boundary: status lines, framing headers, chunks, trailers, + close-delimited bodies, and response timing are hostile. - Filesystem boundary: URL paths must not escape the configured static root. - Parser boundary: request-line, header-line, and chunk-size parsing prefer the sandboxed Rust/WASM parser before application code sees the request. The Scheme parser remains a development fallback unless `JHTTPS_REQUIRE_WASM_HTTP=1` is set. -- Queue boundary: accepted sockets are handed to bounded worker capacity and - must be closed when admission fails. +- Queue boundary: raw TLS sockets first pass global/per-IP pre-authentication + limits and a bounded handshake pool; authenticated sockets then pass to the + bounded request-worker queue. Admission failure closes the socket. ## Threat Actors @@ -49,11 +52,20 @@ entrypoint manages them directly. malformed chunk terminators. - Enforce maximum request line length, header line length, header count, and body size before allocation grows unbounded. +- Enforce client status/header-line/header-total/header-count, decoded-body, + individual-chunk, and raw chunked-wire limits with overflow-safe numeric + parsing, a bounded transport buffer, and one final body concatenation. +- Enforce both an idle timeout and a monotonic total response deadline. +- Reject CR/LF, controls, invalid header names, hostile Host values, and + non-origin-form targets before request or response bytes are serialized. - Close file ports, accepted sockets, and client ports on all success and error paths. -- Keep static file serving traversal-resistant after percent decoding. +- Serve static files only from the descriptor opened during authorization; + canonical containment is checked before and after open and descriptor/path + device+inode identity must match. - Make slow-client timeout, worker count, worker queue capacity, listen backlog, - and TLS termination policy explicit in deployment guidance. + TLS handshake workers/queue/deadline/pre-auth limits, and TLS termination + policy explicit in deployment guidance. - Treat forwarded headers as untrusted by default; proxy deployments must strip client-provided forwarding headers before adding trusted values. @@ -70,6 +82,10 @@ entrypoint manages them directly. bodies, percent-encoding, traversal attempts, malformed methods, slow clients, and bounded local queue pressure. Sustained queue exhaustion remains a separate release-host load-test gate. +- Local TLS adversarial tests must retain duplicate/conflicting response + framing, truncated/oversized fixed and close-delimited bodies, chunk decoded + and wire limits, malformed terminators, buffered interim responses, total + deadlines, and bounded pre-auth admission/recovery coverage. - Static roots must be explicit and must not default to a sensitive directory. - Logs must redact authorization headers, cookies, tokens, and query parameters likely to hold credentials. @@ -98,6 +114,8 @@ entrypoint manages them directly. `JHTTPS_REQUIRE_TARGET_TLS_PROXY_PROOF=1`. - Keep SBOM/toolchain provenance and repeated generated-library build evidence current for release artifacts. +- Keep `dependencies.lock` commit/tree verification current; CI must fetch the + exact locked `jerboa-ssl` object rather than a default branch. - Schedule external review before any public production claim for HTTPD. - Replace private reporting instructions in `SECURITY.md` with a public advisory contact before public release. --- a/docs/tls-proxy-policy.md +++ b/docs/tls-proxy-policy.md @@ -65,8 +65,13 @@ When a proxy terminates TLS: ## Application Listener Requirements -- Set `workers:`, `backlog:`, `queue-capacity:`, `request-timeout:`, and - `response-timeout:` explicitly for daemon deployments. +- Set `workers:`, `backlog:`, `queue-capacity:`, `request-timeout:`, + `response-timeout:`, `tls-handshake-workers:`, `tls-handshake-queue:`, + `tls-handshake-timeout:`, `tls-max-preauth:`, and + `tls-max-preauth-per-ip:` explicitly for daemon deployments. +- Keep the handshake deadline short and size the global/per-IP pre-auth limits + below the host's descriptor and memory budgets. Handshake workers are + separate from the accept loop and authenticated request workers. - Keep static roots narrow and separate from config, keys, logs, generated release evidence, and source checkouts. - Keep authorization headers, cookies, bearer tokens, and query parameters that --- a/lib/jerboa-https.sls +++ b/lib/jerboa-https.sls @@ -4,9 +4,10 @@ (library (jerboa-https) (export http-get http-post http-put http-delete http-head - request-status request-text request-content request-headers - request-header request-close parse-url - flatten-request-headers build-query-string url-encode) + http-client-config request-status request-text + request-content request-headers request-header request-close + parse-url flatten-request-headers build-query-string + url-encode) (import (except (chezscheme) make-hash-table hash-table? sort sort! printf fprintf format path-extension path-absolute? @@ -93,7 +94,65 @@ (cdr bvs) (+ offset (bytevector-length bv))))))))) (define request-body-write-chunk-size 8388608) - (define request-io-timeout-seconds 300) + (define request-write-timeout-seconds 300) + (def *response-policy* + (vector 8192 8192 65536 100 67108864 8388608 83886080 30 300 + 8)) + (def (response-policy-ref i) + (vector-ref *response-policy* i)) + (def (positive-exact-integer? value) + (and (integer? value) (exact? value) (> value 0))) + (def (set-response-policy! who index value) + (unless (positive-exact-integer? value) + (error who + "policy value must be a positive exact integer" + value)) + (vector-set! *response-policy* index value)) + (def (http-client-config . args) + (if (null? args) + (list (cons 'max-status-line (response-policy-ref 0)) + (cons 'max-header-line (response-policy-ref 1)) + (cons 'max-header-bytes (response-policy-ref 2)) + (cons 'max-headers (response-policy-ref 3)) + (cons 'max-body (response-policy-ref 4)) + (cons 'max-chunk (response-policy-ref 5)) + (cons 'max-chunked-wire (response-policy-ref 6)) + (cons 'idle-timeout (response-policy-ref 7)) + (cons 'total-timeout (response-policy-ref 8)) + (cons 'max-interim-responses (response-policy-ref 9))) + (let loop ([rest args]) + (cond + [(null? rest) (void)] + [(null? (cdr rest)) + (error 'http-client-config + "missing value for option" + (car rest))] + [else + (let ([key (car rest)] [value (cadr rest)]) + (cond + [(eq? key 'max-status-line:) + (set-response-policy! 'http-client-config 0 value)] + [(eq? key 'max-header-line:) + (set-response-policy! 'http-client-config 1 value)] + [(eq? key 'max-header-bytes:) + (set-response-policy! 'http-client-config 2 value)] + [(eq? key 'max-headers:) + (set-response-policy! 'http-client-config 3 value)] + [(eq? key 'max-body:) + (set-response-policy! 'http-client-config 4 value)] + [(eq? key 'max-chunk:) + (set-response-policy! 'http-client-config 5 value)] + [(eq? key 'max-chunked-wire:) + (set-response-policy! 'http-client-config 6 value)] + [(eq? key 'idle-timeout:) + (set-response-policy! 'http-client-config 7 value)] + [(eq? key 'total-timeout:) + (set-response-policy! 'http-client-config 8 value)] + [(eq? key 'max-interim-responses:) + (set-response-policy! 'http-client-config 9 value)] + [else + (error 'http-client-config "unknown option" key)]) + (loop (cddr rest)))])))) (def (ssl-write-bytevector-chunked conn bv) (let ([len (bytevector-length bv)]) (let loop ([offset 0]) @@ -148,7 +207,81 @@ (loop (+ i 1) len)))))]))) str) (get-output-string out))) + (def (string-index-from str ch start) + (let ([len (string-length str)]) + (let loop ([i start]) + (cond + [(= i len) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (+ i 1))])))) + (def (first-authority-delimiter str) + (let ([slash (string-index str #\/)] + [query (string-index str #\?)] + [fragment (string-index str #\#)]) + (fold-left + (lambda (best candidate) + (cond + [(not candidate) best] + [(not best) candidate] + [else (min best candidate)])) + #f + (list slash query fragment)))) + (def (parse-port who text) + (let ([port (bounded-unsigned-integer text 10 65535)]) + (unless (and port (> port 0)) + (error who "invalid URL port" text)) + port)) + (def (parse-authority authority default-port) + (when (= (string-length authority) 0) + (error 'parse-url "URL host is empty")) + (when (string-index authority #\@) + (error 'parse-url "userinfo is not supported in URLs")) + (if (char=? (string-ref authority 0) #\[) + (let ([close (string-index authority #\])]) + (unless close + (error 'parse-url "unterminated IPv6 host" authority)) + (let ([host (substring authority 1 close)] + [suffix (substring + authority + (+ close 1) + (string-length authority))]) + (when (= (string-length host) 0) + (error 'parse-url "URL host is empty")) + (cond + [(string=? suffix "") (values host default-port)] + [(and (> (string-length suffix) 1) + (char=? (string-ref suffix 0) #\:)) + (values + host + (parse-port + 'parse-url + (substring suffix 1 (string-length suffix))))] + [else + (error 'parse-url + "invalid text after IPv6 host" + suffix)]))) + (let ([colon (string-index authority #\:)]) + (if colon + (begin + (when (string-index-from authority #\: (+ colon 1)) + (error 'parse-url + "IPv6 hosts must use brackets" + authority)) + (let ([host (substring authority 0 colon)]) + (when (= (string-length host) 0) + (error 'parse-url "URL host is empty")) + (values + host + (parse-port + 'parse-url + (substring + authority + (+ colon 1) + (string-length authority)))))) + (values authority default-port))))) (def (parse-url url) + (unless (string? url) + (error 'parse-url "URL must be a string" url)) (let* ([https? (string-prefix? "https://" url)] [http? (string-prefix? "http://" url)] [_ (unless (or https? http?) @@ -157,52 +290,67 @@ url (if https? 8 7) (string-length url))] - [slash-pos (string-index after-scheme #\/)] - [host-port (if slash-pos - (substring after-scheme 0 slash-pos) + [delimiter (first-authority-delimiter after-scheme)] + [authority (if delimiter + (substring after-scheme 0 delimiter) after-scheme)] - [path (if slash-pos + [tail (if delimiter (substring after-scheme - slash-pos + delimiter (string-length after-scheme)) - "/")] - [colon-pos (string-index host-port #\:)] - [host (if colon-pos - (substring host-port 0 colon-pos) - host-port)] - [port (if colon-pos - (string->number - (substring - host-port - (+ colon-pos 1) - (string-length host-port))) - (if https? 443 80))]) - (values host port path))) + "")]) + (when (string-index tail #\#) + (error 'parse-url + "URL fragments are not sent in HTTP requests" + url)) + (let ([path (cond + [(string=? tail "") "/"] + [(char=? (string-ref tail 0) #\?) + (string-append "/" tail)] + [else tail])]) + (let-values ([(host port) + (parse-authority authority (if https? 443 80))]) + (validate-host! 'parse-url host) + (validate-request-target! 'parse-url path) + (values host port path))))) (def (flatten-request-headers hdrs) - (if (or (not hdrs) (null? hdrs) (not (pair? hdrs))) + (if (or (not hdrs) (null? hdrs)) '() - (let loop ([items hdrs] [result '()]) - (cond - [(null? items) (reverse result)] - [(and (symbol? (car items)) (eq? (car items) '::)) - (loop (cdr items) result)] - [(pair? (car items)) - (let ([item (car items)]) - (if (and (pair? item) - (string? (car item)) - (pair? (cdr item)) - (eq? (cadr item) '::) - (pair? (cddr item))) - (loop - (cdr items) - (cons (cons (car item) (caddr item)) result)) - (loop - (cdr items) - (append - (reverse (flatten-request-headers item)) - result))))] - [else (loop (cdr items) result)])))) + (begin + (unless (list? hdrs) + (error 'flatten-request-headers + "headers must be a proper list" + hdrs)) + (let loop ([items hdrs] [result '()]) + (cond + [(null? items) (reverse result)] + [(and (symbol? (car items)) (eq? (car items) '::)) + (loop (cdr items) result)] + [(pair? (car items)) + (let ([item (car items)]) + (if (and (pair? item) + (string? (car item)) + (pair? (cdr item)) + (eq? (cadr item) '::) + (pair? (cddr item)) + (null? (cdddr item))) + (loop + (cdr items) + (cons (cons (car item) (caddr item)) result)) + (if (string? (car item)) + (error 'flatten-request-headers + "malformed name :: value entry" + item) + (loop + (cdr items) + (append + (reverse (flatten-request-headers item)) + result)))))] + [else + (error 'flatten-request-headers + "invalid header list entry" + (car items))]))))) (def (build-query-string params) (if (or (not params) (null? params)) "" @@ -222,8 +370,128 @@ [(null? h) #f] [(string=? name-lower (string-downcase (caar h))) (car h)] [else (loop (cdr h))])))) - (def (build-request method path host headers body-bv - keep-alive?) + (def (header-count name headers) + (let ([name-lower (string-downcase name)]) + (let loop ([rest headers] [count 0]) + (cond + [(null? rest) count] + [(and (pair? (car rest)) + (string? (caar rest)) + (string=? name-lower (string-downcase (caar rest)))) + (loop (cdr rest) (+ count 1))] + [else (loop (cdr rest) count)])))) + (def (http-token-char? c) + (let ([n (char->integer c)]) + (or (and (>= n 48) (<= n 57)) + (and (>= n 65) (<= n 90)) + (and (>= n 97) (<= n 122)) + (memv + c + '(#\! #\# #\$ #\% #\& #\' #\* #\+ #\- #\. #\^ #\_ #\` #\| + #\~))))) + (def (valid-http-token? value) + (and (string? value) + (> (string-length value) 0) + (let loop ([i 0]) + (or (= i (string-length value)) + (and (http-token-char? (string-ref value i)) + (loop (+ i 1))))))) + (def (valid-header-value? value) + (and (string? value) + (let loop ([i 0]) + (if (= i (string-length value)) + #t + (let ([n (char->integer (string-ref value i))]) + (and (>= n 32) (not (= n 127)) (loop (+ i 1)))))))) + (def (valid-host-field? value) + (and (valid-header-value? value) + (> (string-length value) 0) + (let loop ([i 0]) + (or (= i (string-length value)) + (and (not (char-whitespace? (string-ref value i))) + (loop (+ i 1))))))) + (def (validate-host! who host) + (unless (valid-host-field? host) + (error who + "host contains whitespace or control characters" + host)) + (when (or (string-index host #\/) + (string-index host #\?) + (string-index host #\#) + (string-index host #\@)) + (error who "host contains an authority delimiter" host))) + (def (validate-request-target! who target) + (unless (and (string? target) + (> (string-length target) 0) + (char=? (string-ref target 0) #\/)) + (error who "request target must be origin-form" target)) + (let loop ([i 0]) + (when (< i (string-length target)) + (let ([c (string-ref target i)]) + (when (or (char-whitespace? c) + (< (char->integer c) 32) + (= (char->integer c) 127) + (char=? c #\#)) + (error who + "request target contains forbidden characters" + target)) + (loop (+ i 1)))))) + (def (bounded-unsigned-integer text radix limit) + (and (string? text) + (> (string-length text) 0) + (let loop ([i 0] [value 0]) + (if (= i (string-length text)) + value + (let* ([c (string-ref text i)] + [n (char->integer c)] + [digit (cond + [(and (>= n 48) (<= n 57)) (- n 48)] + [(and (= radix 16) (>= n 65) (<= n 70)) + (+ 10 (- n 65))] + [(and (= radix 16) (>= n 97) (<= n 102)) + (+ 10 (- n 97))] + [else #f])]) + (and digit + (< digit radix) + (<= digit limit) + (<= value (quotient (- limit digit) radix)) + (loop (+ i 1) (+ (* value radix) digit)))))))) + (def (validate-outbound-headers! headers body-bv) + (for-each + (lambda (header) + (unless (and (pair? header) + (valid-http-token? (car header)) + (valid-header-value? (cdr header))) + (error 'build-request "invalid HTTP header" header)) + (when (and (string-ci=? (car header) "Host") + (not (valid-host-field? (cdr header)))) + (error 'build-request "invalid Host header" (cdr header)))) + headers) + (when (> (header-count "Host" headers) 1) + (error 'build-request "duplicate Host header")) + (when (> (header-count "Content-Length" headers) 1) + (error 'build-request "duplicate Content-Length header")) + (when (> (header-count "Transfer-Encoding" headers) 0) + (error 'build-request + "Transfer-Encoding is not supported for requests")) + (let ([cl (header-assoc "Content-Length" headers)] + [actual (if body-bv (bytevector-length body-bv) 0)]) + (when cl + (let ([declared (bounded-unsigned-integer + (cdr cl) + 10 + actual)]) + (unless (and declared (= declared actual)) + (error 'build-request + "Content-Length does not match request body" + (cdr cl) + actual)))))) + (def (build-request method path host headers body-bv keep-alive?) + (unless (valid-http-token? method) + (error 'build-request "invalid HTTP method" method)) + (validate-request-target! 'build-request path) + (validate-host! 'build-request host) + (validate-outbound-headers! headers body-bv) (let ([out (open-output-string)]) (put-string out method) (put-string out " ") @@ -258,71 +526,82 @@ (def (parse-status-line line) (let ([space (string-index line #\space)]) (unless space - (error 'parse-status-line "malformed status line" line)) - (let* ([rest (substring - line - (+ space 1) - (string-length line))] + (error 'read-response "malformed status line")) + (let* ([version (substring line 0 space)] + [rest (substring line (+ space 1) (string-length line))] [space2 (string-index rest #\space)] - [code-str (if space2 (substring rest 0 space2) rest)]) - (or (string->number code-str) - (error 'parse-status-line - "invalid status code" - code-str))))) - (def (parse-headers lines) - (let loop ([lines lines] [acc '()]) - (if (null? lines) - (reverse acc) - (let* ([line (car lines)] [colon (string-index line #\:)]) - (if colon - (loop - (cdr lines) - (cons - (cons - (string-downcase (substring line 0 colon)) - (string-trim-left - (substring - line - (+ colon 1) - (string-length line)))) - acc)) - (loop (cdr lines) acc)))))) + [code-str (if space2 (substring rest 0 space2) rest)] + [status (bounded-unsigned-integer code-str 10 999)]) + (unless (or (string=? version "HTTP/1.0") + (string=? version "HTTP/1.1")) + (error 'read-response + "unsupported HTTP response version" + version)) + (unless (and (= (string-length code-str) 3) + status + (>= status 100)) + (error 'read-response "invalid HTTP status code" code-str)) + (values version status)))) + (def (trim-http-ows value) + (let* ([len (string-length value)] + [start (let loop ([i 0]) + (if (and (< i len) + (or (char=? (string-ref value i) #\space) + (char=? (string-ref value i) #\tab))) + (loop (+ i 1)) + i))] + [end (let loop ([i len]) + (if (and (> i start) + (or (char=? + (string-ref value (- i 1)) + #\space) + (char=? + (string-ref value (- i 1)) + #\tab))) + (loop (- i 1)) + i))]) + (substring value start end))) + (def (parse-header-line line) + (let ([colon (string-index line #\:)]) + (unless (and colon (> colon 0)) + (error 'read-response "malformed response header")) + (let ([name (substring line 0 colon)] + [value (trim-http-ows + (substring + line + (+ colon 1) + (string-length line)))]) + (unless (valid-http-token? name) + (error 'read-response "invalid response header name" name)) + (unless (valid-header-value? value) + (error 'read-response + "response header contains control characters" + name)) + (cons (string-downcase name) value)))) (def (header-value headers name) (let ([pair (assoc name headers)]) (and pair (cdr pair)))) - (def (chunked-encoding? headers) - (let ([te (header-value headers "transfer-encoding")]) - (and te - (string-contains (string-downcase te) "chunked") - #t))) - (def (decode-chunked bv) - (let ([len (bytevector-length bv)]) - (let loop ([pos 0] [chunks '()]) - (if (>= pos len) - (bytevector-concat-list (reverse chunks)) - (let-values ([(size-str next-pos) - (read-bv-line bv pos len)]) - (let* ([semi (string-index size-str #\;)] - [hex-str (string-trim - (if semi - (substring size-str 0 semi) - size-str))] - [chunk-size (string->number hex-str 16)]) - (cond - [(or (not chunk-size) (= chunk-size 0)) - (bytevector-concat-list (reverse chunks))] - [(> (+ next-pos chunk-size) len) - (bytevector-concat-list - (reverse - (cons (subbytevector bv next-pos len) chunks)))] - [else - (loop - (+ next-pos chunk-size 2) - (cons - (subbytevector - bv - next-pos - (+ next-pos chunk-size)) - chunks))]))))))) + (def (header-values headers name) + (let ([target (string-downcase name)]) + (let loop ([rest headers] [result '()]) + (cond + [(null? rest) (reverse result)] + [(string=? (caar rest) target) + (loop (cdr rest) (cons (cdar rest) result))] + [else (loop (cdr rest) result)])))) + (def (header-has-token? headers name token) + (let ([target (string-downcase token)]) + (let value-loop ([values (header-values headers name)]) + (and (pair? values) + (or (let token-loop ([tokens (string-split + (car values) + #\,)]) + (and (pair? tokens) + (or (string=? + (string-downcase + (trim-http-ows (car tokens))) + target) + (token-loop (cdr tokens))))) + (value-loop (cdr values))))))) (def *ssl-initialized* #f) (def (ensure-ssl-init!) (unless *ssl-initialized* @@ -348,199 +627,331 @@ (if (< (length conns) 4) (hashtable-set! *conn-pool* key (cons conn conns)) (ssl-close conn)))))) - (def (ssl-read-bytes conn n) - (let ([result (make-bytevector n)] - [buf (make-bytevector (min n 32768))]) + (def (monotonic-seconds) + (let ([now (current-time 'time-monotonic)]) + (+ (time-second now) (/ (time-nanosecond now) 1000000000)))) + (def (make-response-deadline) + (+ (monotonic-seconds) (response-policy-ref 8))) + (def (make-response-reader conn deadline) + (vector conn (make-bytevector 32768) 0 0 deadline)) + (def (response-reader-conn reader) (vector-ref reader 0)) + (def (response-reader-buffer reader) (vector-ref reader 1)) + (def (response-reader-position reader) + (vector-ref reader 2)) + (def (response-reader-end reader) (vector-ref reader 3)) + (def (response-reader-deadline reader) + (vector-ref reader 4)) + (def (response-reader-position-set! reader value) + (vector-set! reader 2 value)) + (def (response-reader-end-set! reader value) + (vector-set! reader 3 value)) + (def (response-reader-available reader) + (- (response-reader-end reader) + (response-reader-position reader))) + (def (response-reader-fill! reader) + (let ([remaining (- (response-reader-deadline reader) + (monotonic-seconds))]) + (when (<= remaining 0) + (error 'read-response "total response deadline exceeded")) + (let ([timeout (max 1 + (min (response-policy-ref 7) + (ceiling remaining)))] + [buf (response-reader-buffer reader)]) + (ssl-set-timeout + (response-reader-conn reader) + timeout + request-write-timeout-seconds) + (let ([count (ssl-read + (response-reader-conn reader) + buf + (bytevector-length buf))]) + (response-reader-position-set! reader 0) + (response-reader-end-set! reader (max count 0)) + count)))) + (def (response-reader-read-byte reader) + (when (= (response-reader-available reader) 0) + (response-reader-fill! reader)) + (if (= (response-reader-available reader) 0) + #f + (let* ([position (response-reader-position reader)] + [byte (bytevector-u8-ref + (response-reader-buffer reader) + position)]) + (response-reader-position-set! reader (+ position 1)) + byte))) + (def (response-reader-read-line reader limit who)