+ #:export (fake-upstream-service claude-proxy-test-service
+ fake-upstream-tls-service
+ claude-proxy-tls-test-service
+ claude-proxy-test-os-services
+ claude-proxy-test-cases))
+
+;;;
+;;; Fake upstream — a raw-socket HTTP/1.1 server on 127.0.0.1:19998.
+;;; Routes:
+;;; POST /v1/messages with "stream":true — chunked SSE: one frame,
+;;; sleep 3 s, two more frames + [DONE] (the 3 s gap proves the
+;;; proxy relays incrementally instead of buffering).
+;;; POST /v1/messages otherwise — 200 JSON echoing the
+;;; received body (asserts thinking injection).
+;;; POST /slow-headers — sleep 15 s, then reply.
+;;; POST /mid-stall — chunked headers + one
+;;; frame, then sleep 15 s.
+;;; anything else — 401 authentication_error.
+;;;
+
+(define fake-upstream-code
+ #~(begin
+ (use-modules (ice-9 match)
+ (ice-9 rdelim)
+ (ice-9 threads)
+ (rnrs bytevectors)
+ (rnrs io ports)
+ (srfi srfi-13))
+ (define (read-headers sock)
+ "Read header lines until the blank line; return an alist of
+lowercased names to values. Right-trim each line: guile read-line
+keeps the \\r of CRLF endings, which would otherwise make the blank
+line read as \"\\r\" and the header scan run on into the body."
+ (let loop
+ ((acc '()))
+ (let* ((raw (read-line sock))
+ (line (if (eof-object? raw) raw
+ (string-trim-right raw))))
+ (if (or (eof-object? line)
+ (string-null? line)) acc
+ (let ((i (string-index line #\:)))
+ (if i
+ (loop (acons (string-downcase (substring line 0 i))
+ (string-trim (substring line
+ (+ i 1))) acc))
+ (loop acc)))))))
+ (define (respond sock code reason content-type body)
+ (display (string-append "HTTP/1.1 "
+ code
+ " "
+ reason
+ "\r\n"
+ "Content-Type: "
+ content-type
+ "\r\n"
+ "Content-Length: "
+ (number->string (string-length body))
+ "\r\n"
+ "Connection: close\r\n\r\n"
+ body) sock)
+ (force-output sock))
+ (define (chunk sock str)
+ "Write STR as one HTTP chunk."
+ (let ((b (string->utf8 str)))
+ (display (number->string (bytevector-length b) 16) sock)
+ (display "\r\n" sock)
+ (put-bytevector sock b)
+ (display "\r\n" sock)
+ (force-output sock)))
+ (define (respond-stream sock)
+ "Stream three SSE frames with a 3-second gap after the first,
+then terminate the chunked body."
+ (display "HTTP/1.1 200 OK\r\n" sock)
+ (display "Content-Type: text/event-stream\r\n" sock)
+ (display "Transfer-Encoding: chunked\r\n" sock)
+ (display "Connection: close\r\n\r\n" sock)
+ (force-output sock)
+ (chunk sock
+ (string-append "event: message_start\n"
+ "data: {\"type\":\"message_start\","
+ "\"message\":{\"id\":\"msg_01\","
+ "\"content\":[]}}\n\n"))
+ (sleep 3)
+ (chunk sock
+ (string-append "event: content_block_delta\n"
+ "data: {\"type\":\"content_block_delta\","
+ "\"index\":0,"
+ "\"delta\":{\"type\":\"text_delta\","
+ "\"text\":\"Hello from \"}}\n\n"))
+ (chunk sock
+ (string-append "event: content_block_delta\n"
+ "data: {\"type\":\"content_block_delta\","
+ "\"index\":0,"
+ "\"delta\":{\"type\":\"text_delta\","
+ "\"text\":\"the fake\"}}\n\n"
+ "event: message_delta\n"
+ "data: {\"type\":\"message_delta\","
+ "\"delta\":{\"stop_reason\":\"end_turn\"}}\n\n"
+ "event: message_stop\n"
+ "data: {\"type\":\"message_stop\"}\n\n"
+ "data: [DONE]\n\n"))
+ (display "0\r\n\r\n" sock)
+ (force-output sock))
+ (define (respond-mid-stall sock)
+ "Reply with headers and one frame, then stall forever (until
+the proxy gives up and closes)."
+ (display "HTTP/1.1 200 OK\r\n" sock)
+ (display "Content-Type: text/event-stream\r\n" sock)
+ (display "Transfer-Encoding: chunked\r\n" sock)
+ (display "Connection: close\r\n\r\n" sock)
+ (force-output sock)
+ (chunk sock "event: ping\ndata: {\"type\":\"ping\"}\n\n")
+ (sleep 15)
+ (false-if-exception (chunk sock "event: message_stop
+data: {\"type\":\"message_stop\"}
+
+"))
+ (false-if-exception (begin
+ (display "0\r\n\r\n" sock)
+ (force-output sock))))
+ (define (handle sock)
+ (catch #t
+ (lambda ()
+ (let* ((line (read-line sock))
+ (parts (and (not (eof-object? line))
+ (string-split line #\space)))
+ (path (and (>= (length parts) 2)
+ (list-ref parts 1)))
+ (hdrs (read-headers sock))
+ (cl (assoc-ref hdrs "content-length"))
+ (body (if cl
+ (get-bytevector-n sock
+ (string->number cl))
+ #vu8()))
+ (body-str (utf8->string body)))
+ (cond
+ ((and (equal? path "/v1/messages")
+ (string-contains body-str "\"stream\":true"))
+ (respond-stream sock))
+ ((equal? path "/v1/messages")
+ (respond sock "200" "OK" "application/json" body-str))
+ ((equal? path "/slow-headers")
+ (sleep 15)
+ (respond sock "200" "OK" "application/json"
+ "{\"done\":true}"))
+ ((equal? path "/mid-stall")
+ (respond-mid-stall sock))
+ (else (respond sock "401" "Unauthorized"
+ "application/json"
+ (string-append
+ "{\"type\":\"error\",\"error\":"
+ "{\"type\":\"authentication_error\","
+ "\"message\":\"invalid x-api-key\"}}"))))))
+ (lambda _
+ #f))
+ (false-if-exception (close-port sock)))
+ ;; Clients (the proxy under test) close connections mid-stream;
+ ;; a write to a closed socket must not kill the fake via SIGPIPE.
+ (sigaction SIGPIPE SIG_IGN)
+ (let ((listener (socket PF_INET SOCK_STREAM 0)))
+ (setsockopt listener SOL_SOCKET SO_REUSEADDR 1)
+ (bind listener
+ (make-socket-address AF_INET INADDR_LOOPBACK 19998))
+ (listen listener 16)
+ (let loop
+ ()
+ (match (accept listener)
+ ((conn . peer) (setvbuf conn
+ 'none)
+ (call-with-new-thread (lambda ()
+ (handle conn)))
+ (loop)))))))
+
+(define fake-upstream-script
+ (program-file "fake-claude-upstream" fake-upstream-code))
+
+(define fake-upstream-start
+ #~(make-forkexec-constructor (list #$fake-upstream-script)
+ #:log-file "/var/log/fake-upstream.log"))
+
+(define fake-upstream-service
+ (shepherd-service (provision '(fake-upstream))
+ (start fake-upstream-start)
+ (stop #~(make-kill-destructor))
+ (auto-start? #t)))
+
+;;;
+;;; Test proxy — env vars point it at the fake upstream and set a
+;;; 5-second idle timeout, so every stall test completes quickly.
+;;;
+
+(define claude-proxy-test-wrapper
+ (program-file "test-claude-proxy-start"
+ #~(begin
+ (setenv "PROXY_PORT" "16890")
+ (setenv "CLAUDE_PROXY_UPSTREAM" "http://127.0.0.1:19998")
+ (setenv "CLAUDE_PROXY_TIMEOUT" "5")
+ ;; 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-test-start
+ #~(make-forkexec-constructor (list #$claude-proxy-test-wrapper)
+ #:log-file "/var/log/claude-proxy.log"))
+
+(define claude-proxy-test-service
+ (shepherd-service (provision '(claude-proxy))
+ (start claude-proxy-test-start)
+ (stop #~(make-kill-destructor))
+ (auto-start? #t)))
+
+;;;
+;;; TLS fake upstream — the HTTPS twin of the plain fake: a GnuTLS
+;;; server session on 127.0.0.1:443, serving the same routes over
+;;; the session record port. Its certificate and key (self-signed,
+;;; CN=127.0.0.1, SAN IP:127.0.0.1, CA:TRUE) are passed as
+;;; arguments; a third, optional argument overrides the port (used
+;;; for host-side rehearsal, where binding 443 needs root).
+;;; Responding in TLS 1.3 sends a post-handshake NewSessionTicket,
+;;; which is what makes the proxy's record reads hit their
+;;; transient error/again retry path.
+;;;
+
+(define fake-tls-code
+ #~(begin
+ (use-modules (gnutls)
+ (ice-9 match)
+ (ice-9 rdelim)
+ (ice-9 threads)
+ (rnrs bytevectors)
+ (rnrs io ports)
+ (srfi srfi-13))
+ (define (read-headers sock)
+ "Read header lines until the blank line; return an alist of
+lowercased names to values."
+ (let loop
+ ((acc '()))
+ (let* ((raw (read-line sock))
+ (line (if (eof-object? raw) raw
+ (string-trim-right raw))))
+ (if (or (eof-object? line)
+ (string-null? line)) acc
+ (let ((i (string-index line #\:)))
+ (if i
+ (loop (acons (string-downcase (substring line 0 i))
+ (string-trim (substring line
+ (+ i 1))) acc))
+ (loop acc)))))))
+ (define (respond sock code reason content-type body)
+ (display (string-append "HTTP/1.1 "
+ code
+ " "
+ reason
+ "\r\n"
+ "Content-Type: "
+ content-type
+ "\r\n"
+ "Content-Length: "
+ (number->string (string-length body))
+ "\r\n"
+ "Connection: close\r\n\r\n"
+ body) sock)
+ (force-output sock))
+ (define (chunk sock str)
+ "Write STR as one HTTP chunk."
+ (let ((b (string->utf8 str)))
+ (display (number->string (bytevector-length b) 16) sock)
+ (display "\r\n" sock)
+ (put-bytevector sock b)
+ (display "\r\n" sock)
+ (force-output sock)))
+ (define (respond-stream sock)
+ "Stream three SSE frames with a 3-second gap after the first,
+then terminate the chunked body."
+ (display "HTTP/1.1 200 OK\r\n" sock)
+ (display "Content-Type: text/event-stream\r\n" sock)
+ (display "Transfer-Encoding: chunked\r\n" sock)
+ (display "Connection: close\r\n\r\n" sock)
+ (force-output sock)
+ (chunk sock
+ (string-append "event: message_start\n"
+ "data: {\"type\":\"message_start\","
+ "\"message\":{\"id\":\"msg_01\","
+ "\"content\":[]}}\n\n"))
+ (sleep 3)
+ (chunk sock
+ (string-append "event: content_block_delta\n"
+ "data: {\"type\":\"content_block_delta\","
+ "\"index\":0,"
+ "\"delta\":{\"type\":\"text_delta\","
+ "\"text\":\"Hello from \"}}\n\n"))
+ (chunk sock
+ (string-append "event: content_block_delta\n"
+ "data: {\"type\":\"content_block_delta\","
+ "\"index\":0,"
+ "\"delta\":{\"type\":\"text_delta\","
+ "\"text\":\"the fake\"}}\n\n"
+ "event: message_delta\n"
+ "data: {\"type\":\"message_delta\","
+ "\"delta\":{\"stop_reason\":\"end_turn\"}}\n\n"
+ "event: message_stop\n"
+ "data: {\"type\":\"message_stop\"}\n\n"
+ "data: [DONE]\n\n"))
+ (display "0\r\n\r\n" sock)
+ (force-output sock))
+ (define (handle io)
+ "Dispatch one HTTP request read from IO, mirroring the plain
+fake's routes."
+ (catch #t
+ (lambda ()
+ (let* ((line (read-line io))
+ (parts (and (not (eof-object? line))
+ (string-split line #\space)))
+ (path (and (>= (length parts) 2)
+ (list-ref parts 1)))
+ (hdrs (read-headers io))
+ (cl (assoc-ref hdrs "content-length"))
+ (body (if cl
+ (get-bytevector-n io
+ (string->number cl))
+ #vu8()))
+ (body-str (utf8->string body)))
+ (cond
+ ((and (equal? path "/v1/messages")
+ (string-contains body-str "\"stream\":true"))
+ (respond-stream io))
+ ((equal? path "/v1/messages")
+ (respond io "200" "OK" "application/json" body-str))
+ (else (respond io "401" "Unauthorized" "application/json"
+ (string-append
+ "{\"type\":\"error\",\"error\":"
+ "{\"type\":\"authentication_error\","
+ "\"message\":\"invalid x-api-key\"}}"))))))
+ (lambda _
+ #f))
+ (false-if-exception (close-port io)))
+ (define (serve conn cert key)
+ "Complete a TLS handshake with CONN, then serve HTTP over
+the session record port."
+ (catch #t
+ (lambda ()
+ (let* ((session (make-session connection-end/server))
+ (cred (make-certificate-credentials)))
+ (set-session-default-priority! session)
+ (set-session-priorities! session
+ "NORMAL:%COMPAT:-VERS-SSL3.0")
+ (set-session-transport-fd! session
+ (fileno conn))
+ (set-certificate-credentials-x509-key-files! cred cert key
+ x509-certificate-format/pem)
+ (set-session-credentials! session cred)
+ (handshake session)
+ (handle (session-record-port session))))
+ (lambda _
+ #f))
+ (false-if-exception (close-port conn)))
+ ;; Clients (the proxy under test) close connections mid-stream;
+ ;; a write to a closed socket must not kill the fake via SIGPIPE.
+ (sigaction SIGPIPE SIG_IGN)
+ (let* ((argv (command-line))
+ (cert (list-ref argv 1))
+ (key (list-ref argv 2))
+ (pnum (if (> (length argv) 3)
+ (string->number (list-ref argv 3)) 443)))
+ (let ((listener (socket PF_INET SOCK_STREAM 0)))
+ (setsockopt listener SOL_SOCKET SO_REUSEADDR 1)
+ (bind listener
+ (make-socket-address AF_INET INADDR_LOOPBACK pnum))
+ (listen listener 16)
+ (let loop
+ ()
+ (match (accept listener)
+ ((conn . peer) (call-with-new-thread (lambda ()
+ (serve conn cert key)))
+ (loop))))))))
+
+(define fake-upstream-tls-script
+ (program-file "fake-claude-upstream-tls" fake-tls-code))
+
+(define fake-upstream-tls-wrapper
+ ;; Sets the load path for (gnutls) — off the shepherd path — then
+ ;; execs the fake with the certificate and key passed as arguments.
+ (program-file "fake-claude-upstream-tls-start"
+ #~(begin
+ (setenv "GUILE_LOAD_PATH"
+ (string-append #$(file-append guile-gnutls
+ "/share/guile/site/3.0")))
+ (setenv "GUILE_LOAD_COMPILED_PATH"
+ (string-append #$(file-append guile-gnutls
+ "/lib/guile/3.0/site-ccache")))
+ (apply execl
+ #$fake-upstream-tls-script
+ "fake-claude-upstream-tls"
+ (cdr (command-line))))))
+
+(define fake-tls-cert
+ ;; Literal relative names: local-file resolves them against the
+ ;; directory of the module's source file — the worktree's tests/
+ ;; during guix builds. Nothing touches the file system until the
+ ;; object is lowered, so hook compiles (which load the module from
+ ;; the main checkout, where these files do not exist) stay clean.
+ (local-file "claude-proxy-test-cert.pem" "claude-proxy-test-cert.pem"))
+
+(define fake-tls-key
+ (local-file "claude-proxy-test-key.pem" "claude-proxy-test-key.pem"))
+
+(define claude-proxy-test-ca-dir
+ ;; Directory the proxy scans for CA certificates (see
+ ;; GUILE_TLS_CERTIFICATE_DIRECTORY in web/client.scm).
+ (file-union "claude-proxy-test-ca"
+ `(("ca.pem" ,fake-tls-cert))))
+
+(define fake-upstream-tls-start
+ #~(make-forkexec-constructor (list #$fake-upstream-tls-wrapper
+ #$fake-tls-cert
+ #$fake-tls-key)
+ #:log-file "/var/log/fake-upstream-tls.log"))
+
+(define fake-upstream-tls-service
+ (shepherd-service (provision '(fake-upstream-tls))
+ (start fake-upstream-tls-start)
+ (stop #~(make-kill-destructor))
+ (auto-start? #t)))
+
+;;;
+;;; TLS test proxy — same test env as the plain proxy, but pointed
+;;; at the portless URL https://127.0.0.1. The upstream port is
+;;; then the scheme default (443), which is where the TLS fake
+;;; listens; the proxy must also trust the test certificate via
+;;; GUILE_TLS_CERTIFICATE_DIRECTORY.
+;;;
+
+(define claude-proxy-tls-test-wrapper
+ (program-file "test-claude-proxy-tls-start"
+ #~(begin
+ (setenv "PROXY_PORT" "16892")
+ (setenv "CLAUDE_PROXY_UPSTREAM" "https://127.0.0.1")
+ (setenv "CLAUDE_PROXY_TIMEOUT" "5")
+ (setenv "GUILE_TLS_CERTIFICATE_DIRECTORY"
+ #$claude-proxy-test-ca-dir)
+ (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-tls"
+ '()))))
+
+(define claude-proxy-tls-test-start
+ #~(make-forkexec-constructor (list #$claude-proxy-tls-test-wrapper)
+ #:log-file "/var/log/claude-proxy-tls.log"))
+
+(define claude-proxy-tls-test-service
+ (shepherd-service (provision '(claude-proxy-tls))
+ (start claude-proxy-tls-test-start)
+ (stop #~(make-kill-destructor))
+ (auto-start? #t)))
+
+;;;
+;;; Test bodies.
+;;;
projects / guix.git / commitdiff