Fix stream aborts and repeated glob hangs
ober
b58336131cc85afc2f6f90065ad3d6a842fa5f86
--- a/src/jcode/core/agent.ss +++ b/src/jcode/core/agent.ss @@ -13,6 +13,7 @@ get-current-provider forge-respond-enforced? forge-max-repeated-calls + forge-max-similar-search-calls forge-breaker-state make-forge-breaker-state forge-no-progress? @@ -62,13 +63,15 @@ ;; search with ls/read calls, so per-turn seen-counts catch non-consecutive ;; repeats too. #f disables. Per-turn state lives in forge-breaker-state. (def forge-max-repeated-calls (make-parameter 3)) +(def forge-max-similar-search-calls (make-parameter 2)) (def forge-breaker-state (make-parameter #f)) (def forge-no-progress-message "[stopped: repeated the same tool call(s) with no progress]") (def (make-forge-breaker-state) - ;; #(last-batch-sig consecutive-count seen-batches seen-individual-calls) - (vector #f 0 '() '())) + ;; #(last-batch-sig consecutive-count seen-batches seen-individual-calls + ;; seen-similar-search-paths) + (vector #f 0 '() '() '())) (def (chat-call-signature tc) (let ((a (tool-call-arguments tc))) @@ -80,6 +83,32 @@ (map chat-call-signature calls) ";")) +(def (chat-call-arg tc key) + (guard (e [#t #f]) + (let ((a (tool-call-arguments tc))) + (cond + ((string? a) + (let ((h (string->json-object a))) + (and (hash-table? h) (hash-get h key)))) + ((hash-table? a) (hash-get a key)) + (else #f))))) + +(def (chat-call-similar-search-signature tc) + ;; A local model that keeps globbing the same pattern in narrower paths is + ;; usually failing to switch to a recursive glob. Count that as low progress + ;; before it burns another full prompt/prefill round. + (let ((name (tool-call-name tc))) + (cond + ((equal? name "glob") + (let ((pattern (chat-call-arg tc "pattern"))) + (and (string? pattern) + (string-append "glob-pattern|" pattern)))) + (else #f)))) + +(def (chat-call-search-path tc) + (let ((path (chat-call-arg tc "path"))) + (and (string? path) path))) + (def (forge-count-bump! st slot sig) (let ((hit (assoc sig (vector-ref st slot)))) (if hit @@ -90,6 +119,19 @@ (vector-set! st slot (cons (cons sig 1) (vector-ref st slot))) 1)))) +(def (forge-distinct-search-path-count! st sig path) + (let ((hit (assoc sig (vector-ref st 4)))) + (if hit + (let ((paths (cdr hit))) + (if (member path paths) + (length paths) + (begin + (set-cdr! hit (cons path paths)) + (+ (length paths) 1)))) + (begin + (vector-set! st 4 (cons (cons sig (list path)) (vector-ref st 4))) + 1)))) + (def (forge-max-call-count! st calls) (let loop ((rest calls) (mx 0)) (if (null? rest) @@ -98,21 +140,38 @@ (max mx (forge-count-bump! st 3 (chat-call-signature (car rest)))))))) +(def (forge-max-similar-search-count! st calls) + (let loop ((rest calls) (mx 0)) + (if (null? rest) + mx + (let ((sig (chat-call-similar-search-signature (car rest)))) + (loop (cdr rest) + (if sig + (max mx (forge-distinct-search-path-count! st sig + (or (chat-call-search-path (car rest)) ""))) + mx)))))) + ;; Update the per-turn breaker state with CALLS; report whether executing them ;; now crosses the configured repeat limit. (def (forge-no-progress? calls) (let ((limit (forge-max-repeated-calls)) + (similar-limit (forge-max-similar-search-calls)) (st (forge-breaker-state))) - (and limit st (pair? calls) + (and st (pair? calls) (or limit similar-limit) (let* ((sig (chat-calls-signature calls)) - (batch-seen (forge-count-bump! st 2 sig)) - (call-seen (forge-max-call-count! st calls))) + (batch-seen (if limit (forge-count-bump! st 2 sig) 0)) + (call-seen (if limit (forge-max-call-count! st calls) 0)) + (similar-seen + (if similar-limit + (forge-max-similar-search-count! st calls) + 0))) (if (equal? sig (vector-ref st 0)) (vector-set! st 1 (+ (vector-ref st 1) 1)) (begin (vector-set! st 0 sig) (vector-set! st 1 1))) - (or (>= (vector-ref st 1) limit) - (>= batch-seen limit) - (>= call-seen limit)))))) + (or (and limit (>= (vector-ref st 1) limit)) + (and limit (>= batch-seen limit)) + (and limit (>= call-seen limit)) + (and similar-limit (>= similar-seen similar-limit))))))) (def (system-prompt) (format "You are an expert AI coding assistant. You help users with software development tasks. --- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -11,6 +11,7 @@ provider-name provider-model provider-base-url + current-stream-abort? model-rejects-tools? extract-text-tool-calls recover-text-tool-calls @@ -42,6 +43,19 @@ (def logger (make-logger "provider")) +;; Optional per-stream abort predicate. UI layers set this while a request is +;; in flight so provider loops can stop on keepalive/empty SSE events, not only +;; when a real token reaches the normal token callback. +(def current-stream-abort? (make-parameter (lambda () #f))) + +(def (stream-aborted?) + (let ((abort? (current-stream-abort?))) + (and abort? (guard (e [#t #f]) (abort?))))) + +(def (check-stream-abort!) + (when (stream-aborted?) + (error 'stream-aborted "interrupted by user"))) + ;; ---- Redaction helpers (used for trace logging) ---- ;; The trace file captures full HTTP requests; we strip credentials so the ;; file is safe to share when debugging. Header names are matched verbatim @@ -610,12 +624,14 @@ (dynamic-wind (lambda () (void)) (lambda () + (check-stream-abort!) (tls-write-string conn req) (touch!) (let* ((status-line (tls-read-line conn)) (status (parse-http-status status-line)) (_headers (read-tls-headers conn))) (touch!) + (check-stream-abort!) (unless (= status 200) (let ((body (read-http-body-lines (lambda () (tls-read-line conn))))) (error 'jcode-http-post-stream @@ -627,13 +643,17 @@ ;; (e.g. "27a") between data chunks — filter those out so they ;; never reach the SSE parser. (let loop () + (check-stream-abort!) (let ((line (tls-read-line conn))) (touch!) + (check-stream-abort!) (when line (cond ((equal? line "0") (void)) ;; chunked end ((chunk-size-line? line) (loop)) - (else (line-cb line) (loop)))))) + (else (line-cb line) + (check-stream-abort!) + (loop)))))) (when (vector-ref timed-out? 0) (error 'jcode-http-post-stream (format "stream read timed out after ~as of silence (host: ~a)" @@ -681,21 +701,26 @@ (dynamic-wind (lambda () (void)) (lambda () + (check-stream-abort!) (port-write-string out req) (touch!) (let* ((status-line (port-read-line in)) (status (parse-http-status status-line)) (_headers (port-read-headers in))) (touch!) + (check-stream-abort!) (unless (= status 200) (let ((body (read-http-body-lines (lambda () + (check-stream-abort!) (let ((c (peek-char in))) (touch!) + (check-stream-abort!) (if (eof-object? c) #f (let ((line (port-read-line in))) (touch!) + (check-stream-abort!) line))))))) (error 'jcode-http-post-stream (if (= status 0) @@ -705,15 +730,20 @@ ;; Filter HTTP chunked transfer-encoding size lines — see ;; above (TLS branch) for details. (let loop () + (check-stream-abort!) (let ((c (peek-char in))) (touch!) + (check-stream-abort!) (unless (eof-object? c) (let ((line (port-read-line in))) (touch!) + (check-stream-abort!) (cond ((equal? line "0") (void)) ((chunk-size-line? line) (loop)) - (else (line-cb line) (loop))))))) + (else (line-cb line) + (check-stream-abort!) + (loop))))))) (when (vector-ref timed-out? 0) (error 'jcode-http-post-stream (format "stream read timed out after ~as of silence (host: ~a)" --- a/src/jcode/ui/cli.ss +++ b/src/jcode/ui/cli.ss @@ -27,6 +27,7 @@ :jcode/tool/web :jcode/tool/batch :jcode/tool/git + :jcode/provider/provider :jcode/provider/sampling :jcode/core/hardware :jcode/core/compaction-strategy @@ -1031,7 +1032,8 @@ EXAMPLES: (flush-output-port (current-output-port)) (md-reset!) (let ((watcher (start-escape-watcher!))) - (parameterize ((current-stream-cb interruptible-stream-cb) + (parameterize ((current-stream-abort? (lambda () (car *stream-abort*))) + (current-stream-cb interruptible-stream-cb) (current-tool-cb tool-indicator)) (agent-run session-id input))) (catch (e) --- a/src/jcode/ui/tui.ss +++ b/src/jcode/ui/tui.ss @@ -1474,6 +1474,7 @@ (current-log-level log-lvl) (current-provider-override p-override) (current-model-override m-override) + (current-stream-abort? (lambda () (car abort))) (current-stream-cb (lambda (token) (when (car abort) --- a/test/run.ss +++ b/test/run.ss @@ -1590,6 +1590,14 @@ (check! "agent breaker second ls ok" (forge-no-progress? ls-bin) #f) (check! "agent breaker non-consecutive third glob trips" (forge-no-progress? glob-bin) #t))) +(let ([glob-src (list (make-tool-call "glob" "{\"pattern\":\"*.ss\",\"path\":\"/repo/src\"}"))] + [glob-lib (list (make-tool-call "glob" "{\"pattern\":\"*.ss\",\"path\":\"/repo/lib\"}"))]) + (parameterize ([forge-max-repeated-calls 3] + [forge-max-similar-search-calls 2] + [forge-breaker-state (make-forge-breaker-state)]) + (check! "agent breaker first similar glob ok" (forge-no-progress? glob-src) #f) + (check! "agent breaker second same-pattern glob trips" + (forge-no-progress? glob-lib) #t))) (section "=== verified-run: coding workflow on a REAL file + REAL shell verify ===") ;; The verify-gate/best-of-k tests above use mock callables. This one drives the