;; Copyright (c) 2026 Jakub Czajka <jakub@ekhem.eu.org>
;; License: GPL-3.0 or later.
;;
-;; claude-proxy.scm — Guile HTTP proxy for Claude Code.
-;; Forwards Anthropic-format requests to DeepSeek: injects
-;; thinking:disabled on non-streaming requests that do not set a
-;; thinking field, streams the upstream response back incrementally,
-;; and bounds every network wait with an idle timeout. Logs one
-;; line per event with a per-request id so a single request can be
-;; traced with grep 'req=<id>'. Provides both the proxy
-;; program-file and a home Shepherd service.
+;; 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=<id>.
+;;
+;; 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.
(define-module (conf common claude-proxy)
#:use-module (gnu packages guile)
#:use-module (gnu home services)
#:use-module (gnu home services shepherd)
#:use-module (guix gexp)
- #:use-module (guix packages)
#:export (claude-proxy-script claude-proxy-daemon-service))
(define claude-proxy-code
- ;; The whole script is one top-level (begin ...), so use-modules
- ;; here resolves its modules at expansion time. The launching
- ;; wrapper therefore sets GUILE_LOAD_PATH and GUILE_LOAD_COMPILED_PATH
- ;; to the store directories of the off-path (gnutls) and (json)
- ;; modules before exec'ing guile.
+ ;; 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)
(ice-9 binary-ports)
(ice-9 threads)
(ice-9 match)
- (ice-9 receive)
(ice-9 rdelim)
- (srfi srfi-1)
- (srfi srfi-13))
+ (ice-9 regex)
+ (srfi srfi-1))
;; Make the GnuTLS bindings visible to (web client) so its
;; internal TLS helpers (certificate verification) resolve.
(define idle-timeout
(or (and=> (getenv "CLAUDE_PROXY_TIMEOUT") string->number) 60))
+ ;; Orphan watchdog cadence in seconds.
+ (define watch-interval
+ (or (and=> (getenv "CLAUDE_PROXY_WATCHDOG_SECONDS") string->number) 15))
+
;; ── Logging and request ids ─────────────────────
(define (log fmt . args)
(force-output (current-error-port)))
(define (req-log id fmt . args)
- (apply format
- (current-error-port)
- (string-append "[claude-proxy] req=" id " " fmt "~%") args)
- (force-output (current-error-port)))
+ (apply log
+ (string-append "req=" id " " fmt) args))
(define (ms-now)
(let ((t (gettimeofday)))
0)
(define stage-len
0)
+ (define (deadline-ms)
+ (+ (ms-now)
+ (* timeout-s 1000)))
(define (wait! kind deadline-ms)
(let ((left (- deadline-ms
(ms-now))))
(when (<= left 0)
(throw 'claude-proxy-timeout kind))
- (let* ((ready (if (eq? kind
- 'read)
- (select (list fdes)
- '()
- '()
- (/ left 1000.0))
- (select '()
- (list fdes)
- '()
- (/ left 1000.0))))
+ (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.
- (got (if (eq? kind
- 'read)
+ (ready (select (if read?
+ (list fdes)
+ '())
+ (if read?
+ '()
+ (list fdes))
+ '()
+ (/ left 1000.0)))
+ (got (if read?
(car ready)
(cadr ready))))
(if (pair? got) #t
(and session
(eq? err error/premature-termination)))
(define (tls-again? err)
- ;; GnuTLS asks to be called again: it consumed bytes that do
- ;; not yet form a complete record (TLS 1.3 post-handshake
- ;; messages, a partial record). SELECT cannot see the bytes
- ;; GnuTLS already buffered, so on error/again 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)
(bytevector-copy! stage stage-start bv start n)
(set! stage-start
(+ stage-start n)) n))
- (else (let ((deadline (+ (ms-now)
- (* timeout-s 1000))))
- (if (eq? (fill! deadline)
- 'eof) 0
- (read! bv start count))))))
+ (else (if (eq? (fill! (deadline-ms))
+ 'eof) 0
+ (read! bv start count)))))
(define (send-slice! slice)
"Write SLICE, retrying when GnuTLS asks for more time."
(let attempt
()
(wait! 'write
- (+ (ms-now)
- (* timeout-s 1000)))
+ (deadline-ms))
(catch 'gnutls-error
(lambda ()
(if session
(let loop
((off 0))
(if (= off count) count
- (let* ((left (- (+ start count)
- (+ start off)))
+ (let* ((left (- count off))
(slice (make-bytevector left))
(n (begin
(bytevector-copy! bv
;; ── Upstream connection ─────────────────────────
(define (wrap-tls sock host)
- "Perform the (web client) tls-wrap handshake over SOCK for
-HOST, reusing its certificate-verification helpers, but return the
-GnuTLS session so reads can pull whole TLS records via
-record-receive!."
(define session
(make-session connection-end/client))
(if (module-defined? (resolve-interface '(gnutls))
session)
(define (uri-effective-port url)
- "The port URL connects to: its explicit port, or the scheme
- default when none is written (uri-port returns #f then, and
- guile's own (web client) falls back the same way)."
+ ;; 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
(_ #f))))
(define (host-header url)
- "Return the Host header value for URL as a (host . port)
-pair — guile validates Host values in that shape — with the port
-when it is not 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)
(cons (uri-host url) p))))
(define (open-upstream url)
- "Connect to URL (with TLS when https) in a worker thread,
-bounded by IDLE-TIMEOUT seconds, and return the deadline-wrapped
-port. Throws 'claude-proxy-timeout on expiry or rethrows the
-worker's error."
+ ;; Connect in a worker thread, bounded by IDLE-TIMEOUT;
+ ;; throws 'claude-proxy-timeout on expiry.
(define host
(uri-host url))
(define svc
(cadr result)
(cddr result))))
(begin
- ;; The worker may still be blocked in connect(2) or
- ;; the TLS handshake; closing the socket bounds the
- ;; damage. cancel-thread cannot interrupt C-level
- ;; blocking, so the thread may linger until the
- ;; kernel gives up — it only publishes a result
- ;; nobody reads.
+ ;; 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)
;; ── Request rewriting ───────────────────────────
(define (prepare-payload json id)
- "Return JSON with thinking disabled on non-streaming
-requests that do not set a thinking field themselves. 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
reason
content-type
body-str)
- (let ((body (string->utf8 body-str)))
+ (let* ((body (string->utf8 body-str))
+ (len (bytevector-length body)))
+ (put-string cp
+ (format #f "HTTP/1.1 ~d ~a\r\n" code reason))
(put-string cp
- (string-append (format #f "HTTP/1.1 ~d ~a\r\n" code
- reason)
- (format #f "Content-Type: ~a\r\n"
- content-type)
- (format #f "Content-Length: ~d\r\n"
- (bytevector-length body))
- "Connection: close\r\n\r\n"))
+ (format #f "Content-Type: ~a\r\n" content-type))
+ (put-string cp
+ (format #f "Content-Length: ~d\r\n" len))
+ (put-string cp "Connection: close\r\n\r\n")
(put-bytevector cp body)
(force-output cp)
- (req-log id "event=response code=~d bytes=~d ms=~d" code
- (bytevector-length body)
+ (req-log id "event=response code=~d bytes=~d ms=~d" code len
(- (ms-now) t0))))
(define (relay id
#t)
(define (parse-chunk-size line)
;; Chunk size is 1*HEXDIG with an optional extension.
- (define (hex? c)
- (or (char-numeric? c)
- (and (char>=? c #\a)
- (char<=? c #\f))
- (and (char>=? c #\A)
- (char<=? c #\F))))
- (let ((end (or (string-index line
- (lambda (c)
- (not (hex? c))))
- (string-length line))))
- (if (zero? end) #f
- (string->number (substring line 0 end) 16))))
+ (let ((m (string-match "^[0-9a-fA-F]+" line)))
+ (and m
+ (string->number (match:substring m) 16))))
(put-string cp
(string-append "HTTP/1.1 "
(number->string status) " " reason "\r\n"))
(let ((chunked? (equal? version
'(1 . 1))))
(define (emit bv count)
- "Write COUNT bytes of BV to the client as one chunk
-(HTTP/1.1) or raw (HTTP/1.0), then flush CP itself. Chunk framing
-is written by hand: make-chunked-output-port cannot relay
-incrementally — its flush only moves bytes into CP's conversion
-buffer, which is transmitted only when CP is flushed or closed."
+ ;; 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")))
(req-log id "event=first-byte ms=~d bytes=~d"
(- (ms-now) t0) total)))
(define (attempt thunk)
- "Run THUNK; a deadline expiry logs a mid-stream timeout,
-any other error a mid-stream error. Both abandon the relay with
-the reason as the throw argument."
+ ;; Errors and deadline expiries abandon the relay.
(catch #t thunk
(lambda (key . args)
(cond
(throw 'relay-abort
'premature-eof))
(define (read-exact! left)
- "Read exactly LEFT bytes from UP in buffer-sized slices,
-emitting each; an EOF beforehand aborts the relay."
(let loop
((left left))
(if (zero? left)
(emit buf n)
(loop (- left n))))))))
(define (decode-chunked)
- "Relay a chunked body one chunk at a time. 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 ()
(emit chunk
(bytevector-length chunk))
(loop))))))))
- (define (abort-message reason)
- (case reason
- ((claude-proxy-timeout)
- "upstream idle timeout")
- ((premature-eof)
- "upstream connection closed")
- ((bad-chunk-size)
- "upstream sent invalid chunked framing")
- (else "upstream error")))
(define (emit-error-frame reason)
- "Terminate an SSE body with the Anthropic-style error
-event: a leading newline keeps the frame line-aligned even when the
-upstream stalled mid-frame. The body then ends normally, so the
-client sees a typed error instead of a truncated stream."
- (let* ((frame (string-append
+ ;; 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")
+ ((premature-eof)
+ "upstream connection closed")
+ ((bad-chunk-size)
+ "upstream sent invalid chunked framing")
+ (else "upstream error")))
+ (frame (string-append
"\nevent: error\ndata: {\"type\":\"error\","
"\"error\":{\"type\":\"api_error\",\"message\":\""
- (abort-message reason) "\"}}\n\n"))
+ msg "\"}}\n\n"))
(b (string->utf8 frame)))
(emit b
(bytevector-length b))))
(define (try-error-frame reason)
- "Emit the typed SSE error frame for REASON, surviving a
-client that vanished mid-abort. Returns #t on success."
+ ;; Survive a client that vanished mid-abort.
(catch #t
(lambda ()
(emit-error-frame reason) #t)
;; else keeps the hard truncation.
(if sse?
(try-error-frame reason) #f)))))
- (if clean?
- ;; Clean end: HTTP/1.1 bodies close with the final
- ;; zero chunk; HTTP/1.0 clients end at the close.
- (if chunked?
- (begin
- (false-if-exception (put-string cp "0\r\n\r\n"))
- (force-output cp)
- (false-if-exception (close-port cp)))
- (false-if-exception (close-port cp)))
- ;; Non-SSE abort: close without the terminating chunk
- ;; so the client sees an incomplete body.
- (false-if-exception (close-port cp))))))
+ (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.
+ (false-if-exception (put-string cp "0\r\n\r\n")))
+ (when clean?
+ (force-output cp))
+ (false-if-exception (close-port cp)))))
;; ── Request handling ────────────────────────────
url
hdrs
payload)
- ;; Only the response is kept; the body port http-request
- ;; returns is discarded. UP is read raw: RELAY decodes the
- ;; framing itself, since that decoder port would swallow
- ;; whole small bodies before yielding a single byte.
+ ;; 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.
(let* ((up (open-upstream url))
(request (lambda ()
(http-request url
rsp
up
t0))))
- (dynamic-wind (lambda ()
- #f)
+ (dynamic-wind (const #f)
(lambda ()
(req-log id "event=upstream-connect ms=~d"
(- (ms-now) t0))
cp
version
t0)
- (define timeout-body
- "{\"error\":\"upstream timeout\"}")
- (define unavailable-body
- "{\"error\":\"upstream unavailable\"}")
+ (define (hdr name value)
+ (if value
+ (list (cons name value))
+ '()))
(define (fail code reason msg)
(send-simple id
cp
(host-header upstream))
(cons 'content-type
(list 'application/json)))
- (if auth
- (list (cons 'x-api-key auth))
- '())
- (if av
- (list (cons 'anthropic-version av))
- '()))))
+ (hdr 'x-api-key auth)
+ (hdr 'anthropic-version av))))
(req-log id "event=upstream url=~a ms=~d"
(uri->string url)
(- (ms-now) t0))
'claude-proxy-timeout)
(req-log id "event=timeout phase=headers ms=~d"
(- (ms-now) t0))
- (fail 504 "Gateway Timeout" timeout-body))
+ (fail 504 "Gateway Timeout"
+ "{\"error\":\"upstream timeout\"}"))
(else (req-log id
- "event=error phase=headers key=~s ms=~d" key
- (- (ms-now) t0))
- (req-log id "event=error phase=headers msg=~s"
- args)
- (fail 502 "Bad Gateway" unavailable-body)))))))
+ "event=error phase=headers key=~s args=~s" key
+ args)
+ (req-log id "event=error phase=headers ms=~d"
+ (- (ms-now) t0))
+ (fail 502 "Bad Gateway"
+ "{\"error\":\"upstream unavailable\"}")))))))
(let ((json (catch #t
(lambda ()
(json-string->scm (utf8->string body)))
(fail 400 "Bad Request" "{\"error\":\"invalid json\"}")
(try-upstream json))))
+ ;; 16 MiB request-body cap.
(define max-body
(expt 2 24))
- ;; 16 MiB request-body cap
-
- (define (body-allowed? request)
- ;; read-headers decodes content-length to an integer; clients
- ;; that omit it leave no header at all.
- (let ((cl (assoc-ref (request-headers request)
- 'content-length)))
- (or (not cl)
- (<= (if (number? cl) cl
- (or (string->number cl) 0)) max-body))))
(define (read-request* id cp t0)
(catch #t
"Method Not Allowed"
"application/json"
"{\"error\":\"method not allowed\"}"))
- ((not (body-allowed? request))
+ ((let ((cl (assoc-ref (request-headers request)
+ 'content-length)))
+ ;; 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)))
(send-simple id
cp
t0
(let ((cp (make-deadline-port client-sock
(fileno client-sock)
idle-timeout #f)))
- (dynamic-wind (lambda ()
- #f)
+ (dynamic-wind (const #f)
(lambda ()
(serve-one id cp t0))
(lambda ()
(false-if-exception (close-port cp))))))
(lambda (key . args)
- (req-log id "event=error phase=connection key=~s" key)
- (req-log id "event=error phase=connection msg=~s"
+ (req-log id "event=error phase=connection key=~s msg=~s"
+ key
(and (pair? args)
(car args)))
(req-log id "event=error phase=connection ms=~d"
(- (ms-now) t0))))))
- ;; Orphan watchdog cadence in seconds.
- (define watch-interval
- (or (and=> (getenv "CLAUDE_PROXY_WATCHDOG_SECONDS") string->number) 15))
-
(define (run-proxy)
(sigaction SIGPIPE SIG_IGN)
(let ((listener (socket PF_INET SOCK_STREAM 0))
(run-proxy)))
(define claude-proxy-script
- (program-file "claude-proxy" claude-proxy-code))
+ (program-file "claude-proxy"
+ (with-extensions (list guile-gnutls guile-json-4)
+ #~#$claude-proxy-code)))
;; ── Shepherd service ─────────────────────────────────
-(define proxy-wrapper
- (program-file "claude-proxy-start"
- #~(begin
- (setenv "PROXY_PORT" "16890")
- (setenv "CLAUDE_PROXY_UPSTREAM"
- "https://api.deepseek.com/anthropic")
- (setenv "CLAUDE_PROXY_TIMEOUT" "60")
- ;; Off-path modules: (gnutls) and (json) live in
- ;; these store directories, which shepherd does
- ;; not put on GUILE_LOAD_PATH.
- (setenv "GUILE_LOAD_PATH"
- (string-append #$(file-append guile-gnutls
- "/share/guile/site/3.0") ":"
- #$(file-append guile-json-4
- "/share/guile/site/3.0")))
- (setenv "GUILE_LOAD_COMPILED_PATH"
- (string-append #$(file-append guile-gnutls
- "/lib/guile/3.0/site-ccache")
- ":"
- #$(file-append guile-json-4
- "/lib/guile/3.0/site-ccache")))
- (apply execl
- #$claude-proxy-script "claude-proxy"
- '()))))
-
(define claude-proxy-start
#~(let ((log-dir (or (getenv "XDG_STATE_HOME")
(string-append (getenv "HOME") "/.local/state"))))
- (make-forkexec-constructor (list #$proxy-wrapper)
+ (make-forkexec-constructor (list #$claude-proxy-script)
#:log-file (string-append log-dir
"/claude-proxy.log"))))
projects / guix.git / commitdiff