From: Jakub Czajka Date: Mon, 7 Sep 2026 10:57:52 +0000 (+0000) Subject: [tests] Gate the live DeepSeek probe on claude-proxy changes. X-Git-Url: https://git.ekhem.eu.org/?a=commitdiff_plain;h=refs%2Fheads%2Fworktree-492376b2-cc2d-4b8b-b36f-61feecb49b7c;p=guix.git [tests] Gate the live DeepSeek probe on claude-proxy changes. Rename test-vps-live to test-claude-proxy-live to make its scope clear, and make it a stamp-gated target: the probe runs only when conf/common/claude-proxy.scm is newer than .claude/.stamp-claude-proxy-live, so unchanged proxies skip the live API call entirely. No longer chained into test-vps-fresh — the hermetic VM suite stays the deterministic gate. Also sanitize the environment for every guix invocation: sourced profile files put the system profile's guix modules ahead of the current guix's on GUILE_LOAD_PATH, which makes guix fail with record ABI mismatches when evaluating repository modules. Strip the GUILE_* variables via a single guix-env prefix and use $(CURDIR) instead of backtick pwd throughout. Co-Authored-By: Claude --- diff --git a/.gitignore b/.gitignore index 4824265..c62d8cf 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .claude/.build-queue.* +.claude/.stamp-* .claude/worktrees .dir-locals.el pi-built-*/ diff --git a/Makefile b/Makefile index dcd683f..4ed073c 100644 --- a/Makefile +++ b/Makefile @@ -3,30 +3,42 @@ guix-profile := ~/.guix-home/profile guix-store := /gnu/store -guix-version := $(shell guix show guix | sed -n '/^version/s/^.*: //gp') + +# Strip the GUILE_* variables before running guix: sourced profile +# files put the system profile's guix modules ahead of the current +# guix's, which makes the latter fail with record ABI mismatches. +guix-env := env -u GUILE_LOAD_PATH -u GUILE_LOAD_COMPILED_PATH \ + -u GUILE_EXTENSIONS_PATH + +guix-version := $(shell $(guix-env) guix show guix | sed -n '/^version/s/^.*: //gp') home-nonfree: - GUIX_PACKAGE_PATH=`pwd` PROFILE=nonfree guix home reconfigure home.scm + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=nonfree \ + guix home reconfigure home.scm . $(guix-profile)/etc/profile home-libre: - GUIX_PACKAGE_PATH=`pwd` PROFILE=libre guix home reconfigure home.scm + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=libre \ + guix home reconfigure home.scm . $(guix-profile)/etc/profile system-nonfree: - sudo GUIX_PACKAGE_PATH=`pwd` PROFILE=nonfree guix system reconfigure system.scm + sudo $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=nonfree \ + guix system reconfigure system.scm system-libre: - sudo GUIX_PACKAGE_PATH=`pwd` PROFILE=libre guix system reconfigure system.scm + sudo $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=libre \ + guix system reconfigure system.scm vps-home: - GUIX_PACKAGE_PATH=`pwd` guix home reconfigure \ - -L `pwd` -e '(@ (vps-home) vps-home-environment)' + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix home reconfigure \ + -L $(CURDIR) -e '(@ (vps-home) vps-home-environment)' . $(guix-profile)/etc/profile vps-system: - sudo GUIX_PACKAGE_PATH=`pwd` guix system reconfigure \ - -L `pwd` -e '(@ (vps-system) vps-operating-system)' --substitute-urls="https://substitutes.nonguix.org https://bordeaux.guix.gnu.org https://ci.guix.gnu.org" + sudo $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix system reconfigure \ + -L $(CURDIR) -e '(@ (vps-system) vps-operating-system)' \ + --substitute-urls="https://substitutes.nonguix.org https://bordeaux.guix.gnu.org https://ci.guix.gnu.org" # Build-only targets — validate configuration without activating. @@ -35,28 +47,28 @@ vps-system: # these on non-main branches; on main it runs the reconfigure # targets directly. build-home-nonfree: - GUIX_PACKAGE_PATH=`pwd` PROFILE=nonfree \ + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=nonfree \ guix home build home.scm build-home-libre: - GUIX_PACKAGE_PATH=`pwd` PROFILE=libre \ + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=libre \ guix home build home.scm build-system-nonfree: - GUIX_PACKAGE_PATH=`pwd` PROFILE=nonfree \ + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=nonfree \ guix system build system.scm build-system-libre: - GUIX_PACKAGE_PATH=`pwd` PROFILE=libre \ + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) PROFILE=libre \ guix system build system.scm build-vps-system: - GUIX_PACKAGE_PATH=`pwd` guix system build \ - -L `pwd` -e '(@ (vps-system) vps-operating-system)' + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix system build \ + -L $(CURDIR) -e '(@ (vps-system) vps-operating-system)' build-vps-home: - GUIX_PACKAGE_PATH=`pwd` guix home build \ - -L `pwd` -e '(@ (vps-home) vps-home-environment)' + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix home build \ + -L $(CURDIR) -e '(@ (vps-home) vps-home-environment)' build-vps: build-vps-system build-vps-home @@ -64,76 +76,72 @@ build-vps: build-vps-system build-vps-home # runs all test cases. Uses cache by default; tests are # deterministic for given inputs. test-vps: build-vps-system build-vps-home - @out=$$(GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ + @out=$$($(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ -e '(@ (tests vps-base) %test-vps)' 2>/dev/null); \ if [ -n "$$out" ] && [ -e "$$out" ]; then \ echo "📋 Cached: $$out"; \ echo " Run 'make test-vps-fresh' to re-execute."; \ else \ - GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ -e '(@ (tests vps-base) %test-vps)'; \ fi # Force fresh tests — delete cached result and rebuild. test-vps-fresh: build-vps-system build-vps-home - @out=$$(GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ + @out=$$($(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ -e '(@ (tests vps-base) %test-vps)' 2>/dev/null); \ [ -n "$$out" ] && [ -e "$$out" ] \ && guix gc --delete "$$out" 2>/dev/null; \ - GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ + $(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ -e '(@ (tests vps-base) %test-vps)' -# Live rehearsal of claude-proxy against the real DeepSeek API: -# starts the built proxy pointed at https://api.deepseek.com/anthropic -# and sends one streaming and one non-streaming request through it. -# The API key is read from the per-user runtime cache -# (/run/user/$(id -u)/claude-apikey); without a key the requests -# still exercise the chain and expect relayed 401s. Not hermetic — -# never part of the deterministic suite. -test-vps-live: - @key=""; \ - keyfile="/run/user/$$(id -u)/claude-apikey"; \ +# Live rehearsal of claude-proxy against the real DeepSeek API — only +# for claude-proxy changes. Runs the current tree's proxy against +# https://api.deepseek.com/anthropic and sends one streaming and one +# non-streaming request through it. The API key is read from the +# per-user runtime cache (/run/user/$(id -u)/claude-apikey); without +# a key the requests still exercise the chain and expect relayed +# 401s. The stamp makes the probe run only when +# conf/common/claude-proxy.scm changed since the last run. Not +# hermetic — never part of the deterministic suite. +stamp := .claude/.stamp-claude-proxy-live + +$(stamp): conf/common/claude-proxy.scm + @keyfile="/run/user/$$(id -u)/claude-apikey"; \ + key=""; \ if [ -r "$$keyfile" ] && [ -s "$$keyfile" ]; then \ - key="$$(/run/current-system/profile/bin/tr -d '\n' < "$$keyfile")"; \ + key="$$(cat "$$keyfile")"; \ fi; \ - proxy="$$(GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ - -e '(@ (conf common claude-proxy) claude-proxy-script)' \ - 2>/dev/null)"; \ + proxy="$$($(guix-env) GUIX_PACKAGE_PATH=$(CURDIR) guix build -L $(CURDIR) \ + -e '(@ (conf common claude-proxy) claude-proxy-script)')"; \ log="/tmp/claude-proxy-live.log"; \ rm -f "$$log"; \ - env -u GUILE_LOAD_PATH -u GUILE_LOAD_COMPILED_PATH \ - PROXY_PORT=16998 \ + PROXY_PORT=16998 \ CLAUDE_PROXY_UPSTREAM=https://api.deepseek.com/anthropic \ CLAUDE_PROXY_TIMEOUT=60 "$$proxy" > "$$log" 2>&1 & \ pid=$$!; \ trap 'kill $$pid 2>/dev/null' EXIT; \ sleep 1; \ + cat "$$log"; \ auth=""; \ if [ -n "$$key" ]; then auth="x-api-key: $$key"; fi; \ - echo "--- proxy log:"; \ - /run/current-system/profile/bin/cat "$$log"; \ - body='{"stream":false,"model":"deepseek-chat","max_tokens":32,"messages":[{"role":"user","content":"Reply with the single word OK"}]}'; \ + probe() { \ + curl -sS -N -m 90 -w '\nHTTP %{http_code} in %{time_total}s\n' \ + http://127.0.0.1:16998/v1/messages \ + -H 'content-type: application/json' \ + $${auth:+-H "$$auth"} -d "$$2" | head -c "$$3"; \ + echo; \ + }; \ echo "--- non-stream request:"; \ - /home/dak/.guix-profile/bin/curl -sS -m 90 \ - -w '\nHTTP %{http_code} in %{time_total}s\n' \ - http://127.0.0.1:16998/v1/messages \ - -H 'content-type: application/json' \ - $${auth:+-H "$$auth"} \ - -d "$$body" | /run/current-system/profile/bin/head -c 1500; \ - echo; \ - body='{"stream":true,"model":"deepseek-chat","max_tokens":32,"messages":[{"role":"user","content":"Reply with the single word OK"}]}'; \ + probe plain '{"stream":false,"model":"deepseek-chat","max_tokens":32,"messages":[{"role":"user","content":"Reply with the single word OK"}]}' 1500; \ echo "--- stream request:"; \ - /home/dak/.guix-profile/bin/curl -sS -N -m 90 \ - -w '\nHTTP %{http_code} in %{time_total}s\n' \ - http://127.0.0.1:16998/v1/messages \ - -H 'content-type: application/json' \ - $${auth:+-H "$$auth"} \ - -d "$$body" | /run/current-system/profile/bin/head -c 2500; \ - echo; \ + probe stream '{"stream":true,"model":"deepseek-chat","max_tokens":32,"messages":[{"role":"user","content":"Reply with the single word OK"}]}' 2500; \ echo "--- proxy log events:"; \ - /run/current-system/profile/bin/grep -o 'event=[a-z-]*' "$$log" \ - | /run/current-system/profile/bin/sort \ - | /run/current-system/profile/bin/uniq -c + grep -o 'event=[a-z-]*' "$$log" | sort | uniq -c; \ + touch "$@" + +.PHONY: test-claude-proxy-live +test-claude-proxy-live: $(stamp) tags: find $(guix-store) -wholename "*guix-$(guix-version)*.scm" -or \ diff --git a/conf/common/claude-proxy.scm b/conf/common/claude-proxy.scm index 68a0939..4653046 100644 --- a/conf/common/claude-proxy.scm +++ b/conf/common/claude-proxy.scm @@ -1,17 +1,17 @@ ;; Copyright (c) 2026 Jakub Czajka ;; License: GPL-3.0 or later. ;; -;; Guile HTTP proxy for Claude Code: forwards Anthropic-format -;; requests to DeepSeek, injects thinking:disabled on non-streaming -;; requests without a thinking field, streams responses back -;; incrementally, and bounds every wait with an idle timeout. Every -;; request logs one line per event, traceable by req=. +;; Guile HTTP proxy for Claude Code: forwards Anthropic-format requests to +;; DeepSeek, injects thinking:disabled on non-streaming requests without a +;; thinking field, streams responses back incrementally, and bounds every wait +;; with an idle timeout. Every request logs one line per event, traceable by +;; req=. ;; ;; Reads PROXY_PORT, CLAUDE_PROXY_UPSTREAM, CLAUDE_PROXY_TIMEOUT and -;; CLAUDE_PROXY_WATCHDOG_SECONDS from the environment in the -;; Configuration block at the top of the script body. The -;; program-file wraps the code in with-extensions, putting the -;; off-prefix (gnutls) and (json) modules on the load path. +;; CLAUDE_PROXY_WATCHDOG_SECONDS from the environment in the Configuration block +;; at the top of the script body. The program-file wraps the code in +;; with-extensions, putting the off-prefix (gnutls) and (json) modules on the +;; load path. (define-module (conf common claude-proxy) #:use-module (gnu packages guile) @@ -22,10 +22,9 @@ #:export (claude-proxy-script claude-proxy-daemon-service)) (define claude-proxy-code - ;; One top-level (begin ...): use-modules resolves at expansion - ;; time, after the with-extensions prologue (see - ;; claude-proxy-script) has put (gnutls) and (json) on the load - ;; paths. + ;; One top-level (begin ...): use-modules resolves at expansion time, after + ;; the with-extensions prologue (see claude-proxy-script) has put (gnutls) and + ;; (json) on the load paths. #~(begin (use-modules (gnutls) (web client) @@ -43,16 +42,12 @@ (ice-9 regex) (srfi srfi-1)) - ;; Make the GnuTLS bindings visible to (web client) so its - ;; internal TLS helpers (certificate verification) resolve. - (catch #t - (lambda () - (module-use! (resolve-module '(web client)) - (resolve-interface '(gnutls))) - (format (current-error-port) "[claude-proxy] gnutls loaded~%")) - (lambda _ - (format (current-error-port) - "[claude-proxy] gnutls NOT available~%"))) + ;; (web client) is built without gnutls; its certificate helpers resolve + ;; only after its own loader links the (gnutls) interface into the module. + ;; The upstream is https-only, so a missing gnutls is fatal: the + ;; 'gnutls-not-available error aborts startup and shepherd respawns (see + ;; the bind-failure path below). + ((@@ (web client) load-gnutls)) ;; ── Configuration ─────────────────────────────── @@ -63,9 +58,9 @@ (string->uri (or (getenv "CLAUDE_PROXY_UPSTREAM") "https://api.deepseek.com/anthropic"))) - ;; Idle timeout in seconds: bounds connect, waiting for - ;; upstream response headers, and every gap in a streamed - ;; response. Long generations survive as long as bytes flow. + ;; Idle timeout in seconds: bounds connect, waiting for upstream response + ;; headers, and every gap in a streamed response. Long generations + ;; survive as long as bytes flow. (define idle-timeout (or (and=> (getenv "CLAUDE_PROXY_TIMEOUT") string->number) 60)) @@ -112,12 +107,11 @@ ;; ── Deadline port ─────────────────────────────── ;; - ;; Every network read and write goes through this custom - ;; port. Before pulling from the underlying socket the port - ;; waits on select(2) with an idle deadline; each pull drains - ;; everything that is available (a whole TLS record for - ;; https upstreams) so select never hides data buffered at a - ;; lower layer. + ;; Every network read and write goes through this custom port. Before + ;; pulling from the underlying socket the port waits on select(2) with an + ;; idle deadline; each pull drains everything that is available (a whole + ;; TLS record for https upstreams) so select never hides data buffered at + ;; a lower layer. (define stage-size 65536) @@ -144,9 +138,8 @@ deadline passes before any data arrives." (throw 'claude-proxy-timeout kind)) (let* ((read? (eq? kind 'read)) - ;; SELECT returns lists of fds; the single fd shows - ;; up in the first list when readable and in the - ;; second when writable. + ;; SELECT returns lists of fds; the single fd shows up in the + ;; first list when readable and in the second when writable. (ready (select (if read? (list fdes) '()) @@ -165,9 +158,9 @@ deadline passes before any data arrives." (and session (eq? err error/premature-termination))) (define (tls-again? err) - ;; GnuTLS consumed bytes that do not yet form a complete - ;; record; select cannot see them, so wait for more and - ;; retry instead of reporting an error. + ;; GnuTLS consumed bytes that do not yet form a complete record; + ;; select cannot see them, so wait for more and retry instead of + ;; reporting an error. (and session (eq? err error/again))) (define (fill! deadline-ms) @@ -251,9 +244,7 @@ deadline passes before any data arrives." (define (wrap-tls sock host) (define session (make-session connection-end/client)) - (if (module-defined? (resolve-interface '(gnutls)) - 'set-session-server-name!) - (set-session-server-name! session server-name-type/dns host)) + (set-session-server-name! session server-name-type/dns host) (set-session-transport-fd! session (fileno sock)) (set-session-default-priority! session) @@ -293,8 +284,8 @@ deadline passes before any data arrives." session) (define (uri-effective-port url) - ;; Portless URLs fall back to the scheme default, as guile's - ;; own (web client) does. + ;; Portless URLs fall back to the scheme default, as guile's own (web + ;; client) does. (or (uri-port url) (match (uri-scheme url) ((or 'http @@ -306,8 +297,8 @@ deadline passes before any data arrives." (_ #f)))) (define (host-header url) - ;; Host as a (host . port) pair — the shape guile validates — - ;; with the port omitted when it is the scheme default. + ;; Host as a (host . port) pair — the shape guile validates — with the + ;; port omitted when it is the scheme default. (let ((p (uri-effective-port url))) (if (or (and (eq? (uri-scheme url) 'https) @@ -319,8 +310,8 @@ deadline passes before any data arrives." (cons (uri-host url) p)))) (define (open-upstream url) - ;; Connect in a worker thread, bounded by IDLE-TIMEOUT; - ;; throws 'claude-proxy-timeout on expiry. + ;; Connect in a worker thread, bounded by IDLE-TIMEOUT; throws + ;; 'claude-proxy-timeout on expiry. (define host (uri-host url)) (define svc @@ -338,9 +329,8 @@ deadline passes before any data arrives." (lambda () (let ((sock (socket PF_INET SOCK_STREAM 0))) (set-car! sock-cell sock) - ;; Backstop for GnuTLS's own C-level reads and - ;; writes; the select-based deadline port is the - ;; primary bound. + ;; Backstop for GnuTLS's own C-level reads and writes; the + ;; select-based deadline port is the primary bound. (setsockopt sock SOL_SOCKET SO_RCVTIMEO (cons idle-timeout 0)) (setsockopt sock SOL_SOCKET SO_SNDTIMEO @@ -369,10 +359,10 @@ deadline passes before any data arrives." (unlock-mutex result-mutex)))) (define worker-thread (call-with-new-thread worker)) - ;; Re-check RESULT before waiting: the worker may publish and - ;; signal before the wait starts, and a signal with no waiter - ;; is lost. WAIT-CONDITION-VARIABLE returns #t when awakened - ;; and #f once the absolute DEADLINE has passed. + ;; Re-check RESULT before waiting: the worker may publish and signal + ;; before the wait starts, and a signal with no waiter is lost. + ;; WAIT-CONDITION-VARIABLE returns #t when awakened and #f once the + ;; absolute DEADLINE has passed. (lock-mutex result-mutex) (let* ((t0 (gettimeofday)) (deadline (cons (+ (car t0) idle-timeout) @@ -394,9 +384,9 @@ deadline passes before any data arrives." (cadr result) (cddr result)))) (begin - ;; Closing the socket bounds the damage if the worker - ;; is still blocked in connect(2) or the handshake; - ;; cancel-thread cannot interrupt C-level blocking. + ;; Closing the socket bounds the damage if the worker is still + ;; blocked in connect(2) or the handshake; cancel-thread cannot + ;; interrupt C-level blocking. (cancel-thread worker-thread) (let ((sock (car sock-cell))) (when (port? sock) @@ -407,8 +397,8 @@ deadline passes before any data arrives." ;; ── Request rewriting ─────────────────────────── (define (prepare-payload json id) - ;; DeepSeek reasoning models default to thinking on, which - ;; stalls non-streaming calls behind full reasoning time. + ;; DeepSeek reasoning models default to thinking on, which stalls + ;; non-streaming calls behind full reasoning time. (let ((stream? (eq? (assoc-ref json "stream") #t)) (thinking (assoc-ref json "thinking"))) (cond @@ -464,8 +454,8 @@ framing, so each upstream chunk reaches the client as it arrives." (define ct (assoc-ref (response-headers rsp) 'content-type)) - ;; The parsed header value is a list whose car is the - ;; media-type symbol, e.g. (text/event-stream). + ;; The parsed header value is a list whose car is the media-type symbol, + ;; e.g. (text/event-stream). (define sse? (and (pair? ct) (eq? (car ct) @@ -484,8 +474,8 @@ framing, so each upstream chunk reaches the client as it arrives." (put-string cp (string-append "HTTP/1.1 " (number->string status) " " reason "\r\n")) - ;; Content-type arrives parsed (e.g. (text/event-stream)); - ;; write-header knows how to serialize that form. + ;; Content-type arrives parsed (e.g. (text/event-stream)); write-header + ;; knows how to serialize that form. (when ct (write-header 'content-type ct cp)) (put-string cp @@ -498,9 +488,9 @@ framing, so each upstream chunk reaches the client as it arrives." (let ((chunked? (equal? version '(1 . 1)))) (define (emit bv count) - ;; One client chunk (HTTP/1.1) or raw (HTTP/1.0), flushed - ;; directly: make-chunked-output-port buffers instead of - ;; relaying incrementally. + ;; One client chunk (HTTP/1.1) or raw (HTTP/1.0), flushed directly: + ;; make-chunked-output-port buffers instead of relaying + ;; incrementally. (when chunked? (put-string cp (string-append (number->string count 16) "\r\n"))) @@ -549,8 +539,8 @@ framing, so each upstream chunk reaches the client as it arrives." (emit buf n) (loop (- left n)))))))) (define (decode-chunked) - ;; Exact-count reads keep chunk data from bleeding into - ;; the next chunk header. + ;; Exact-count reads keep chunk data from bleeding into the next + ;; chunk header. (let loop () (let* ((line (attempt (lambda () @@ -564,8 +554,8 @@ framing, so each upstream chunk reaches the client as it arrives." (attempt (lambda () (throw 'bad-chunk-size)))) ((zero? size) - ;; Final chunk: swallow the closing CRLF; any - ;; trailers are ignored, the connection closes. + ;; Final chunk: swallow the closing CRLF; any trailers are + ;; ignored, the connection closes. (attempt (lambda () (get-bytevector-n! up buf 0 2))) 'done) @@ -578,8 +568,8 @@ framing, so each upstream chunk reaches the client as it arrives." (cond ((response-must-not-include-body? rsp) 'done) - ;; Response-transfer-encoding holds a list of codings, - ;; e.g. ((chunked)); match guile's response-body-port. + ;; Response-transfer-encoding holds a list of codings, e.g. + ;; ((chunked)); match guile's response-body-port. ((member '(chunked) (response-transfer-encoding rsp)) (decode-chunked)) @@ -588,8 +578,8 @@ framing, so each upstream chunk reaches the client as it arrives." (lambda (len) (read-exact! len))) (else - ;; No framing at all: relay bytes until the upstream - ;; closes the connection. + ;; No framing at all: relay bytes until the upstream closes the + ;; connection. (let loop () (let ((chunk (attempt (lambda () @@ -601,8 +591,8 @@ framing, so each upstream chunk reaches the client as it arrives." (bytevector-length chunk)) (loop)))))))) (define (emit-error-frame reason) - ;; Leading newline keeps the frame line-aligned; the - ;; client sees a typed error, not a truncated stream. + ;; Leading newline keeps the frame line-aligned; the client sees a + ;; typed error, not a truncated stream. (let* ((msg (case reason ((claude-proxy-timeout) "upstream idle timeout") @@ -633,23 +623,22 @@ framing, so each upstream chunk reaches the client as it arrives." "event=done status=~d bytes=~d ms=~d" status total (- (ms-now) t0)) #t) - ;; The throw argument is the abort - ;; reason; see ATTEMPT and PREMATURE!. + ;; The throw argument is the abort reason; see + ;; ATTEMPT and PREMATURE!. (lambda (key reason) (req-log id "event=aborted status=~d bytes=~d ms=~d" status total (- (ms-now) t0)) - ;; SSE clients get a typed error event - ;; and a well-formed body; everything - ;; else keeps the hard truncation. + ;; SSE clients get a typed error event and a + ;; well-formed body; everything else keeps the + ;; hard truncation. (if sse? (try-error-frame reason) #f))))) (when (and clean? chunked?) - ;; Clean end: HTTP/1.1 bodies close with the final zero - ;; chunk; HTTP/1.0 clients end at the close. Non-SSE - ;; aborts close without it so the client sees an - ;; incomplete body. + ;; Clean end: HTTP/1.1 bodies close with the final zero chunk; + ;; HTTP/1.0 clients end at the close. Non-SSE aborts close + ;; without it so the client sees an incomplete body. (false-if-exception (put-string cp "0\r\n\r\n"))) (when clean? (force-output cp)) @@ -665,8 +654,8 @@ framing, so each upstream chunk reaches the client as it arrives." hdrs payload) ;; UP is read raw: RELAY decodes the framing itself, since - ;; http-request's body port would swallow whole small bodies - ;; before yielding a single byte. + ;; http-request's body port would swallow whole small bodies before + ;; yielding a single byte. (let* ((up (open-upstream url)) (request (lambda () (http-request url @@ -836,8 +825,8 @@ framing, so each upstream chunk reaches the client as it arrives." "{\"error\":\"method not allowed\"}")) ((let ((cl (assoc-ref (request-headers request) 'content-length))) - ;; read-headers decodes content-length to an - ;; integer; clients that omit it leave no header. + ;; read-headers decodes content-length to an integer; clients + ;; that omit it leave no header. (and cl (> (if (number? cl) cl (or (string->number cl) 0)) max-body))) @@ -888,10 +877,9 @@ framing, so each upstream chunk reaches the client as it arrives." (sigaction SIGPIPE SIG_IGN) (let ((listener (socket PF_INET SOCK_STREAM 0)) (start-ppid (getppid))) - ;; One handler for TERM and INT: log, close the listener, - ;; die cleanly. PRIMITIVE-EXIT, not EXIT: a handler can run - ;; on any thread, and EXIT only unwinds its own thread (it - ;; is a THROW to 'quit). + ;; One handler for TERM and INT: log, close the listener, die cleanly. + ;; PRIMITIVE-EXIT, not EXIT: a handler can run on any thread, and EXIT + ;; only unwinds its own thread (it is a THROW to 'quit). (for-each (lambda (sig) (sigaction sig (lambda (sig) @@ -907,8 +895,8 @@ framing, so each upstream chunk reaches the client as it arrives." (make-socket-address AF_INET INADDR_LOOPBACK port)) (listen listener 64)) (lambda args - ;; One line, no backtrace; shepherd respawns and - ;; retries until the port is free again. + ;; One line, no backtrace; shepherd respawns and retries + ;; until the port is free again. (log "bind failed port=~d: ~a (errno ~d); exiting" port (strerror (system-error-errno args)) (system-error-errno args)) @@ -916,10 +904,10 @@ framing, so each upstream chunk reaches the client as it arrives." (log "startup listen=~d ppid=~d upstream=~a timeout=~d" port start-ppid (uri->string upstream) idle-timeout) - ;; Orphan watchdog: when the launching shepherd dies without - ;; stopping us (guix home reconfigure kills the daemon), we - ;; are reparented; free the port so the next daemon's - ;; respawn can bind. Dormant when the parent is PID 1. + ;; Orphan watchdog: when the launching shepherd dies without stopping + ;; us (guix home reconfigure kills the daemon), we are reparented; + ;; free the port so the next daemon's respawn can bind. Dormant when + ;; the parent is PID 1. (when (> start-ppid 1) (call-with-new-thread (lambda () (let loop @@ -935,16 +923,16 @@ framing, so each upstream chunk reaches the client as it arrives." (primitive-exit 0))))))) (let loop () - ;; SELECT, not ACCEPT: a blocked select runs pending - ;; signal asyncs on EINTR, so the TERM/INT handlers - ;; fire even while the server idles in the kernel - ;; wait (a blocked accept swallows the interrupt). + ;; SELECT, not ACCEPT: a blocked select runs pending signal asyncs + ;; on EINTR, so the TERM/INT handlers fire even while the server + ;; idles in the kernel wait (a blocked accept swallows the + ;; interrupt). (when (pair? (car (select (list listener) '() '() 60.0))) (let ((client (accept listener))) - ;; One thread per connection; handle-connection takes - ;; care of its own errors and cleanup. + ;; One thread per connection; handle-connection takes care of + ;; its own errors and cleanup. (call-with-new-thread (lambda () (handle-connection (car client) (cdr client)))))) @@ -969,21 +957,19 @@ framing, so each upstream chunk reaches the client as it arrives." (define claude-proxy-service (shepherd-service (provision '(claude-proxy)) (start claude-proxy-start) - ;; Explicit TERM with a short SIGKILL escalation: - ;; the proxy's signal handler exits promptly, and - ;; the grace period covers any handler latency. + ;; Explicit TERM with a short SIGKILL escalation: the + ;; proxy's signal handler exits promptly, and the grace + ;; period covers any handler latency. (stop #~(make-kill-destructor SIGTERM #:grace-period 3)) - ;; Respawn with a 5-second pace: a guix home - ;; reconfigure overlaps two shepherd daemons for - ;; tens of seconds while the old proxy still holds - ;; the port, and slow retries keep the default - ;; 5-in-7s respawn limit from disabling the - ;; service before the port frees. (respawn-limit - ;; cannot express that here: guix emits the value - ;; unquoted into shepherd.conf, so a pair is a - ;; syntax error and an integer crashes shepherd's - ;; respawn bookkeeping.) + ;; Respawn with a 5-second pace: a guix home reconfigure + ;; overlaps two shepherd daemons for tens of seconds while + ;; the old proxy still holds the port, and slow retries keep + ;; the default 5-in-7s respawn limit from disabling the + ;; service before the port frees. (respawn-limit cannot + ;; express that here: guix emits the value unquoted into + ;; shepherd.conf, so a pair is a syntax error and an integer + ;; crashes shepherd's respawn bookkeeping.) (respawn? #t) (respawn-delay 5) (auto-start? #t)