Clean stream error bodies and add reply copy command
ober
b9df8267cebed7b946057ff603afd648a80ecaec
--- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -527,6 +527,27 @@ ;; Streaming HTTP POST: calls line-cb with each line of the response body. ;; Used for SSE (Server-Sent Events) streaming from LLM APIs. +;; Read a (possibly chunked) HTTP body to a clean string by reading lines and +;; dropping chunked-transfer size lines — the same filtering the SSE loop does. +;; Used for non-200 error bodies: without this, chunked framing (the hex size +;; lines like "6f" and CRLFs) leaks into the error message and a per-block +;; UTF-8 decode mangles bytes into U+FFFD. (line-reader) returns the next line +;; or #f at EOF. Each line was already UTF-8-decoded as a whole, so no +;; multibyte char is split. +(def (read-http-body-lines line-reader) + (let ((out (open-output-string))) + (let loop ((first? #t)) + (let ((line (line-reader))) + (when line + (cond + ((equal? line "0") (void)) ;; chunked terminator + ((chunk-size-line? line) (loop first?));; drop chunk-size lines + (else + (unless first? (newline out)) ;; preserve line breaks + (put-string out line) + (loop #f)))))) + (get-output-string out))) + (def (jcode-http-post-stream url headers body-json line-cb) (let-values (((scheme host port path) (parse-url-parts url))) (let ((req (build-http-request "POST" path host headers body-json)) @@ -589,7 +610,7 @@ (_headers (read-tls-headers conn))) (touch!) (unless (= status 200) - (let ((body (tls-read-all conn))) + (let ((body (read-http-body-lines (lambda () (tls-read-line conn))))) (error 'jcode-http-post-stream (if (= status 0) (format "connection closed before HTTP status received (host: ~a)" host) @@ -624,7 +645,10 @@ (status (parse-http-status status-line)) (_headers (port-read-headers in))) (unless (= status 200) - (let ((body (port-read-all in))) + (let ((body (read-http-body-lines + (lambda () + (let ((c (peek-char in))) + (if (eof-object? c) #f (port-read-line in))))))) (error 'jcode-http-post-stream (if (= status 0) (format "connection closed before HTTP status received (host: ~a)" host) --- a/src/jcode/ui/tui-input.ss +++ b/src/jcode/ui/tui-input.ss @@ -49,6 +49,7 @@ ("/sessions" . "List saved sessions") ("/search" . "Search session history") ("/compact" . "Compact conversation") + ("/copy" . "Copy last reply to a file") ("/quit" . "Exit jcode") ("/themes" . "List color themes") ("/theme" . "Switch color theme") --- a/src/jcode/ui/tui.ss +++ b/src/jcode/ui/tui.ss @@ -549,6 +549,7 @@ " /agents List named sub-agent roles (task tool)" " /clear Start new session" " /compact Summarize older turns to free up context" + " /copy [path] Copy last assistant reply to a file (default ~/jcode-last-reply-<id>.md)" " /sessions List sessions" " /save [path] Export current session to markdown (default ~/jcode-session-<id>.md)" " /search <term> Search session history" @@ -679,6 +680,11 @@ ((string-prefix? "save " cmd) (handle-save! state (substring cmd 5 (string-length cmd)))) + ((equal? cmd "copy") + (handle-copy! state "")) + ((string-prefix? "copy " cmd) + (handle-copy! state + (substring cmd 5 (string-length cmd)))) ((string-prefix? "search " cmd) (let* ((term (string-trim (substring cmd 7 (string-length cmd)))) (results (session-search term))) @@ -1255,6 +1261,62 @@ (send-worker-event! gen (list 'ask-result provider result)))))))) +(def (expand-output-path arg default-path) + (let* ((raw (string-trim arg)) + (home (or (getenv "HOME") ".")) + (p1 (if (string=? raw "") default-path raw))) + (if (and (>= (string-length p1) 2) + (string=? (substring p1 0 2) "~/")) + (string-append home (substring p1 1 (string-length p1))) + p1))) + +;; ---- /copy [path] ---- +;; Copy the latest assistant/expert reply body to a plain markdown file. System +;; notices after the reply are ignored, so repeated /copy calls keep copying +;; the same answer. +(def (reply-block? blk) + (let ((role (msg-block-role blk))) + (or (eq? role 'assistant) (eq? role 'expert)))) + +(def (last-reply-block state) + (let loop ((msgs (reverse (app-state-messages state)))) + (cond + ((null? msgs) #f) + ((reply-block? (car msgs)) (car msgs)) + (else (loop (cdr msgs)))))) + +(def (write-output-string path body) + (let ((p (open-file-output-port + path + (file-options no-fail) + (buffer-mode block) + (make-transcoder (utf-8-codec))))) + (dynamic-wind + (lambda () (void)) + (lambda () (display body p)) + (lambda () (close-port p))))) + +(def (handle-copy! state arg) + (finalize-last-assistant! state) + (let ((blk (last-reply-block state))) + (cond + ((not blk) + (add-message! state (msg-block-system "No assistant reply to copy yet."))) + (else + (let* ((home (or (getenv "HOME") ".")) + (sid (or (app-state-session-id state) "untitled")) + (default-path + (string-append home "/jcode-last-reply-" sid ".md")) + (path (expand-output-path arg default-path)) + (body (or (msg-block-content blk) ""))) + (guard (e [(condition? e) + (add-message! state + (msg-block-error + (format "Copy failed: ~a" (err->string e))))]) + (write-output-string path body) + (add-message! state + (msg-block-system (format "Copied last reply to ~a" path))))))))) + ;; ---- /save [path] ---- ;; Dump the visible message thread to a markdown file. Sessions persist in ;; ~/.jcode/sessions.db but a plain-text artifact is easier to share/diff. @@ -1289,16 +1351,11 @@ (display "\n\n" port)))) (def (handle-save! state arg) - (let* ((raw (string-trim arg)) - (home (or (getenv "HOME") ".")) + (let* ((home (or (getenv "HOME") ".")) (sid (or (app-state-session-id state) "untitled")) (default-path (string-append home "/jcode-session-" sid ".md")) - (p1 (if (string=? raw "") default-path raw)) - (path (if (and (>= (string-length p1) 2) - (string=? (substring p1 0 2) "~/")) - (string-append home (substring p1 1 (string-length p1))) - p1))) + (path (expand-output-path arg default-path))) (guard (e [#t (add-message! state (msg-block-error (format "Save failed: ~a" (err->string e))))]) --- a/test/run.ss +++ b/test/run.ss @@ -41,7 +41,8 @@ (jcode eval scenario) (jcode eval ablation) (jcode eval runner) - (std text json)) + (std text json) + (std net tcp)) ;; ── Helpers ────────────────────────────────────────────────────── @@ -90,6 +91,57 @@ (loop (- i 1)) (substring s 0 i)))) +(define (condition->string thunk) + (guard (e [(condition? e) + (with-output-to-string (lambda () (display-condition e)))]) + (call-with-values thunk (lambda vals #f)))) + +(define (read-test-http-request in) + (let header-loop ([content-length 0]) + (let ([line (get-line in)]) + (cond + [(eof-object? line) (void)] + [(or (string=? line "") (string=? line "\r")) + (let drain ([remaining content-length]) + (when (> remaining 0) + (let ([c (read-char in)]) + (unless (eof-object? c) + (drain (- remaining 1))))))] + [else + (let ([clean (string-trim-right line)]) + (header-loop + (if (str-prefix? "Content-Length: " clean) + (or (string->number + (substring clean (string-length "Content-Length: ") + (string-length clean))) + content-length) + content-length)))])))) + +(define (serve-one-chunked-500! srv body) + (fork-thread + (lambda () + (let-values ([(in out) (tcp-accept srv)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (read-test-http-request in) + (let ([chunk-size (number->string (string-length body) 16)]) + (put-string out + (string-append + "HTTP/1.1 500 Internal Server Error\r\n" + "Content-Type: application/json\r\n" + "Transfer-Encoding: chunked\r\n" + "Connection: close\r\n" + "\r\n" + chunk-size "\r\n" + body "\r\n" + "0\r\n" + "\r\n")) + (flush-output-port out))) + (lambda () + (close-port out) + (close-port in))))))) + ;; ── Setup ───────────────────────────────────────────────────────── (current-log-level 'warn) @@ -1773,6 +1825,46 @@ (grok-list-models (make-provider "grok" "" "grok-build" "https://x/v1")) (lambda (ms) (assoc "grok-build" ms))) +;; ── provider: streaming HTTP error bodies ───────────────────────── + +(section "=== provider: streaming HTTP error bodies ===") + +(let* ([body "{\"error\":{\"message\":\"unexpected EOF while reading stream; context window exhausted while decoding response!!\"}}"] + [srv (tcp-listen "127.0.0.1" 0)] + [base-url (format "http://127.0.0.1:~a/v1" (tcp-server-port srv))] + [chunk-size (number->string (string-length body) 16)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (serve-one-chunked-500! srv body) + (let* ([p (make-provider "ollama" "" "unit-test-model" base-url)] + [err (condition->string + (lambda () + (provider-stream-chat + p + (list (make-user-message "hi")) + '() + (lambda (token) #f))))]) + (check-pred! "stream chunked 500 raises" err string?) + (check-pred! "stream chunked 500 includes status" + err + (lambda (s) (and (string? s) + (str-contains? s "API error 500:")))) + (check-pred! "stream chunked 500 keeps body" + err + (lambda (s) (and (string? s) + (str-contains? s "unexpected EOF")))) + (check! "stream chunked 500 strips chunk-size" + (and (string? err) + (str-contains? err + (string-append "API error 500: " + chunk-size))) + #f) + (check! "stream chunked 500 strips terminator" + (and (string? err) (str-contains? err "\n0")) + #f))) + (lambda () (tcp-close srv)))) + ;; ── secrets-import: grok known-providers entry ──────────────────── ;; *known-providers* (secrets-import) is the single-env-var-per-provider ;; mapping used by import-from-env! / aider import / interactive prompts.