Fix TUI races via mailbox pattern; add /refresh-models
ober
9130563b95ff0ca32e0d7f7c61a04f5413b56269
--- a/lib/jcode/core/models.sls +++ b/lib/jcode/core/models.sls @@ -3,16 +3,14 @@ ;;; Source: src/jcode/core/models.ss (library (jcode core models) - (export - provider-models - all-providers - provider-display-name - provider-default-model) + (export provider-models all-providers provider-display-name + provider-default-model models-cache-path load-models-cache! + write-models-cache!) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (jerboa core) + (std text json) (std os path) (jerboa core) (jerboa runtime)) (def (all-providers) '("anthropic" "openai" "openrouter" "deepseek" "google" @@ -36,6 +34,13 @@ [(ollama) "llama3.2"] [else "gpt-4o"])) (def (provider-models provider) + (unless (*models-cache*) (load-models-cache!)) + (let ([cached (and (*models-cache*) + (hash-get (*models-cache*) provider))]) + (if (and cached (pair? cached)) + (cache-entries->pairs cached) + (provider-default-models provider)))) + (def (provider-default-models provider) (case (string->symbol provider) [(anthropic) anthropic-models] [(openai) openai-models] @@ -44,6 +49,54 @@ [(openrouter) openrouter-models] [(ollama) ollama-models] [else '()])) + (def *models-cache* (make-parameter #f)) + (def (models-cache-path) + (path-join + (or (getenv "HOME") ".") + ".jcode" + "models-cache.json")) + (def (cache-entries->pairs entries) + (map (lambda (e) + (cond + [(pair? e) (if (pair? (cdr e)) (cons (car e) (cadr e)) e)] + [(string? e) (cons e e)] + [else (cons (format "~a" e) (format "~a" e))])) + entries)) + (def (load-models-cache!) + (let ([path (models-cache-path)]) + (if (file-exists? path) + (try (let ([data (call-with-input-file path read-json)]) + (*models-cache* + (if (hash-table? data) data (make-hash-table))) + (*models-cache*)) + (catch + (e) + (*models-cache* (make-hash-table)) + (*models-cache*))) + (begin + (*models-cache* (make-hash-table)) + (*models-cache*))))) + (def (write-models-cache! data) + "Persist {provider -> list-of-(id . display)} to ~/.jcode/models-cache.json.\n Also updates the in-memory cache so /model popup sees the new data immediately." + (let* ([path (models-cache-path)] + [dir (path-directory path)] + [json-data (make-hash-table)]) + (hash-for-each + (lambda (provider models) + (hash-put! + json-data + provider + (map (lambda (m) (list (car m) (cdr m))) models))) + data) + (unless (file-exists? dir) (mkdir dir)) + (when (file-exists? path) (delete-file path)) + (let ([port (open-output-file path)]) + (dynamic-wind + (lambda () (void)) + (lambda () (write-json json-data port)) + (lambda () (close-output-port port)))) + (*models-cache* data) + path)) (def anthropic-models '(("claude-sonnet-4-20250514" . "Claude Sonnet 4") ("claude-opus-4-20250514" . "Claude Opus 4") @@ -53,8 +106,8 @@ ("gpt-4-turbo" . "GPT-4 Turbo") ("o3" . "o3") ("o3-mini" . "o3 Mini") ("o4-mini" . "o4 Mini"))) (def deepseek-models - '(("deepseek-chat" . "DeepSeek V3") - ("deepseek-reasoner" . "DeepSeek R1"))) + '(("deepseek-chat" . "DeepSeek Chat (non-thinking)") + ("deepseek-reasoner" . "DeepSeek Reasoner (thinking)"))) (def google-models '(("gemini-2.5-pro" . "Gemini 2.5 Pro") ("gemini-2.5-flash" . "Gemini 2.5 Flash") --- a/lib/jcode/provider/provider.sls +++ b/lib/jcode/provider/provider.sls @@ -4,7 +4,8 @@ (library (jcode provider provider) (export make-provider provider-chat provider-stream - provider-stream-chat provider-name provider-model) + provider-stream-chat provider-list-models provider-name + provider-model) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -797,7 +798,8 @@ [text-acc (open-output-string)] [tu-table (make-hash-table)] [current-idx (make-parameter #f)] - [usage-acc (make-hash-table)]) + [usage-acc (make-hash-table)] + [event-type #f]) (let ([http-status (http-post-stream url headers @@ -807,7 +809,6 @@ (let* ([lines (string-split event-str #\newline)] - [event-type #f] [data-str #f]) (for-each (lambda (line) @@ -1002,4 +1003,237 @@ (error 'provider-stream-chat (format "Unknown provider '~a'" + (provider-name provider)))])) + (def (tls-read-all-bytes conn) + (let ([chunks '()] [buf (make-bytevector 4096)]) + (let loop () + (let ([n (rustls-read conn buf 4096)]) + (if (<= n 0) + (concat-bytevectors (reverse chunks)) + (let ([chunk (make-bytevector n)]) + (bytevector-copy! buf 0 chunk 0 n) + (set! chunks (cons chunk chunks)) + (loop))))))) + (def (port-read-all-bytes in) + (let ([chunks '()] [buf (make-bytevector 4096)]) + (let loop () + (let ([n (get-bytevector-n! in buf 0 4096)]) + (cond + [(or (eof-object? n) (not n) (<= n 0)) + (concat-bytevectors (reverse chunks))] + [else + (let ([chunk (make-bytevector n)]) + (bytevector-copy! buf 0 chunk 0 n) + (set! chunks (cons chunk chunks)) + (loop))]))))) + (def (concat-bytevectors bvs) + (let* ([total (let sum ([l bvs] [s 0]) + (if (null? l) + s + (sum (cdr l) + (+ s (bytevector-length (car l))))))] + [out (make-bytevector total)]) + (let loop ([l bvs] [offset 0]) + (if (null? l) + out + (let* ([part (car l)] [plen (bytevector-length part)]) + (bytevector-copy! part 0 out offset plen) + (loop (cdr l) (+ offset plen))))))) + (def (decode-chunked-bytes bv) + (let ([len (bytevector-length bv)] [chunks '()]) + (def (finalize) (concat-bytevectors (reverse chunks))) + (let loop ([pos 0]) + (cond + [(>= pos (- len 1)) (finalize)] + [else + (let find-eol ([i pos]) + (cond + [(>= i (- len 1)) (finalize)] + [(and (= (bytevector-u8-ref bv i) 13) + (= (bytevector-u8-ref bv (+ i 1)) 10)) + (let* ([size-bv (make-bytevector (- i pos))] + [_ (bytevector-copy! bv pos size-bv 0 (- i pos))] + [size-str (utf8->string size-bv)] + [semi (string-contains size-str ";")] + [hex (if semi + (substring size-str 0 semi) + size-str)] + [size (string->number (string-trim hex) 16)]) + (cond + [(or (not size) (<= size 0)) (finalize)] + [else + (let* ([data-start (+ i 2)] + [data-end (+ data-start size)]) + (cond + [(> data-end len) (finalize)] + [else + (let ([chunk (make-bytevector size)]) + (bytevector-copy! bv data-start chunk 0 + size) + (set! chunks (cons chunk chunks)) + (loop (+ data-end 2)))]))]))] + [else (find-eol (+ i 1))]))])))) + (def (header-value headers name) + (let ([h (assoc (string-downcase name) headers)]) + (and h (cdr h)))) + (def (http-get-json url headers) + (let-values ([(scheme host port path) + (parse-url-parts url)]) + (let* ([hdrs (if (assoc "Connection" headers) + headers + (cons '("Connection" . "close") headers))] + [req (build-http-request "GET" path host hdrs #f)]) + (if (equal? scheme "https") + (let ([conn (rustls-connect host port)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (tls-write-string conn req) + (let* ([status-line (tls-read-line conn)] + [status (parse-http-status status-line)] + [resp-headers (read-tls-headers conn)] + [cl (header-value + resp-headers + "content-length")] + [te (header-value + resp-headers + "transfer-encoding")] + [body-bv (cond + [cl + (let ([s (tls-read-n + conn + (string->number cl))]) + (string->utf8 s))] + [(and te + (string-contains + te + "chunked")) + (decode-chunked-bytes + (tls-read-all-bytes conn))] + [else (tls-read-all-bytes conn)])] + [body (utf8->string body-bv)]) + (values status body))) + (lambda () (rustls-close conn)))) + (let-values ([(in out) (tcp-connect host port)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (port-write-string out req) + (let* ([status-line (port-read-line in)] + [status (parse-http-status status-line)] + [resp-headers (port-read-headers in)] + [te (header-value + resp-headers + "transfer-encoding")] + [raw (port-read-all-bytes in)] + [body-bv (if (and te + (string-contains + te + "chunked")) + (decode-chunked-bytes raw) + raw)] + [body (utf8->string body-bv)]) + (values status body))) + (lambda () (close-port in) (close-port out)))))))) + (def (openai-list-models provider) + (let* ([url (string-append + (provider-base-url provider) + "/models")] + [headers (openai-headers provider)]) + (let-values ([(status text) (http-get-json url headers)]) + (if (= status 200) + (let* ([json (string->json-object text)] + [data (or (hash-get json "data") '())]) + (map (lambda (entry) + (let* ([id (hash-ref entry "id")] + [name (or (hash-get entry "name") id)]) + (cons id name))) + data)) + (error 'openai-list-models + (format "API error ~a: ~a" status text)))))) + (def (anthropic-list-models provider) + (let* ([url (string-append + (provider-base-url provider) + "/models?limit=1000")] + [headers (anthropic-headers provider)]) + (let-values ([(status text) (http-get-json url headers)]) + (if (= status 200) + (let* ([json (string->json-object text)] + [data (or (hash-get json "data") '())]) + (map (lambda (entry) + (cons + (hash-ref entry "id") + (or (hash-get entry "display_name") + (hash-ref entry "id")))) + data)) + (error 'anthropic-list-models + (format "API error ~a: ~a" status text)))))) + (def (google-list-models provider) + (let* ([key (or (provider-api-key provider) "")] + [url (string-append + (provider-base-url provider) + "/models?pageSize=1000&key=" + key)] + [headers '(("Content-Type" . "application/json"))]) + (let-values ([(status text) (http-get-json url headers)]) + (if (= status 200) + (let* ([json (string->json-object text)] + [models (or (hash-get json "models") '())]) + (filter-map + (lambda (entry) + (let* ([raw-name (or (hash-get entry "name") "")] + [id (if (string-prefix? "models/" raw-name) + (substring + raw-name + 7 + (string-length raw-name)) + raw-name)] + [display-name (or (hash-get + entry + "displayName") + id)] + [methods (or (hash-get + entry + "supportedGenerationMethods") + '())]) + (if (member "generateContent" methods) + (cons id display-name) + #f))) + models)) + (error 'google-list-models + (format "API error ~a: ~a" status text)))))) + (def (ollama-list-models provider) + (let* ([url (string-append + (provider-base-url provider) + "/models")] + [headers '(("Content-Type" . "application/json"))]) + (let-values ([(status text) (http-get-json url headers)]) + (if (= status 200) + (let* ([json (string->json-object text)] + [data (or (hash-get json "data") '())]) + (map (lambda (entry) + (let ([id (hash-ref entry "id")]) (cons id id))) + data)) + (error 'ollama-list-models + (format "API error ~a: ~a" status text)))))) + (def (provider-list-models provider) + (unless (or (provider-api-key provider) + (equal? (provider-name provider) "ollama")) + (error 'provider-list-models + (format + "No API key for provider '~a'" + (provider-name provider)))) + (log-info + logger + "list-models" + `((provider . ,(provider-name provider)))) + (case (string->symbol (provider-name provider)) + [(openai openrouter deepseek) (openai-list-models provider)] + [(anthropic) (anthropic-list-models provider)] + [(google) (google-list-models provider)] + [(ollama) (ollama-list-models provider)] + [else + (error 'provider-list-models + (format + "Unknown provider '~a'" (provider-name provider)))]))) --- a/lib/jcode/ui/tui.sls +++ b/lib/jcode/ui/tui.sls @@ -8,13 +8,14 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std misc string) (std text json) (jcode ui tui-ffi) - (jcode ui tui-theme) (jcode ui tui-keys) + (std misc string) (std misc thread) (std text json) + (jcode ui tui-ffi) (jcode ui tui-theme) (jcode ui tui-keys) (jcode ui tui-markdown) (jcode ui tui-diff) (jcode ui tui-message) (jcode ui tui-status) (jcode ui tui-input) (jcode ui tui-sidebar) (jcode ui tui-dialog) (jcode core config) - (jcode core models) (jcode core agent) (jcode core session) + (jcode core models) (jcode core agent) + (jcode provider provider) (jcode core session) (jcode core log) (jcode tool registry) (jcode tool file) (jcode tool bash) (jcode tool web) (jcode tool batch) (jcode tool git) (jcode mcp client) (jcode tool lsp) @@ -22,6 +23,7 @@ (def logger (make-logger "tui")) (def *version* "0.1.0") (def *tui-log-port* (make-parameter #f)) + (def *main-thread* (make-parameter #f)) (def (tui-log fmt . args) (let ([p (*tui-log-port*)]) (when p @@ -128,7 +130,10 @@ (reflow-all! state) (draw-all! state) (tb-present!) - (tui-log "tui-main: entering event loop") + (*main-thread* (current-thread)) + (tui-log + "tui-main: entering event loop, main-thread=~a" + (*main-thread*)) (event-loop state) (restore-stderr!) (close-tui-log!)))) @@ -159,6 +164,10 @@ (def (event-loop state) (let loop () (app-state-tick-set! state (+ (app-state-tick state) 1)) + (let ([n (drain-agent-events! state)]) + (when (> n 0) + (tui-log "event-loop: drained ~a agent events" n) + (app-state-dirty?-set! state #t))) (when (app-state-agent-busy? state) (app-state-dirty?-set! state #t)) (let ([ev (tb-peek-event 50)]) @@ -302,6 +311,7 @@ " /model <id> Set model directly" " /provider Select provider (popup)" " /provider <name> Set provider directly" + " /refresh-models Fetch live model lists from all providers" " /tools List available tools" " /clear Start new session" " /sessions List sessions" @@ -329,6 +339,8 @@ "Tools: " (string-join (list-tools) ", "))))] [(equal? cmd "model") (handle-model-popup! state)] + [(equal? cmd "refresh-models") + (handle-refresh-models! state)] [(string-prefix? "model " cmd) (let ([m (string-trim (substring cmd 6 (string-length cmd)))]) @@ -419,6 +431,71 @@ (app-state-height state))]) (when result (switch-provider! state result)) (app-state-dirty?-set! state #t)))) + (def (handle-refresh-models! state) + "Fetch live /models from every provider with a key and write the cache.\n Runs synchronously — expect up to a few seconds of UI stall." + (add-message! + state + (msg-block-system "Refreshing models from providers…")) + (draw-all! state) + (let ([results (make-hash-table)] [lines '()]) + (for-each + (lambda (p-name) + (let ([key (config-get-provider-key p-name)]) + (cond + [(or key (equal? p-name "ollama")) + (try (let* ([prov (make-provider + p-name + (or key "") + (provider-default-model p-name))] + [models (provider-list-models prov)]) + (hash-put! results p-name models) + (set! lines + (cons + (format + " ✓ ~a: ~a models" + (provider-display-name p-name) + (length models)) + lines))) + (catch + (e) + (let ([msg (string-trim + (with-output-to-string + (lambda () + (display-condition e))))]) + (set! lines + (cons + (format + " ✗ ~a: ~a" + (provider-display-name p-name) + msg) + lines)))))] + [else + (set! lines + (cons + (format + " — ~a: skipped (no key)" + (provider-display-name p-name)) + lines))]))) + (all-providers)) + (cond + [(> (length (hash-keys results)) 0) + (let ([path (write-models-cache! results)]) + (add-message! + state + (msg-block-system + (string-append + "Model cache updated.\n" + (string-join (reverse lines) "\n") + "\n\nCache: " + path))))] + [else + (add-message! + state + (msg-block-system + (string-append + "No providers refreshed.\n" + (string-join (reverse lines) "\n"))))]) + (app-state-dirty?-set! state #t))) (def (handle-model-popup! state) "Show a popup list of models for the current provider." (let* ([cur-p (or (current-provider-override) @@ -466,6 +543,33 @@ "Update sidebar MCP connection info." (let ([servers (try (mcp-active-servers) (catch (e) '()))]) (sidebar-state-mcp-set! (app-state-sidebar state) servers))) + (def (send-agent-event! ev) + (let ([main (*main-thread*)]) + (when main (thread-send main ev)))) + (def (drain-agent-events! state) + "Drain all pending agent events from the main thread's mailbox.\n Apply them to state synchronously. Returns the number drained." + (let loop ([n 0]) + (let ([ev (guard (e [#t 'EMPTY]) (thread-receive 0))]) + (if (eq? ev 'EMPTY) + n + (begin (apply-agent-event! state ev) (loop (+ n 1))))))) + (def (apply-agent-event! state ev) + (match ev + [(list 'stream-token token) (tui-stream-token! state token)] + [(list 'tool-event op name args) + (tui-tool-event! state op name args)] + [(list 'usage-update usage) (tui-usage-update! state usage)] + [(list 'agent-error msg) + (tui-log "apply-agent-event: agent-error ~a" msg) + (add-message! state (msg-block-error msg)) + (app-state-agent-busy?-set! state #f) + (app-state-dirty?-set! state #t)] + [(list 'agent-done) + (tui-log "apply-agent-event: agent-done") + (app-state-agent-busy?-set! state #f) + (app-state-scroll-offset-set! state 0) + (app-state-dirty?-set! state #t)] + [_ (tui-log "apply-agent-event: unknown event ~s" ev)])) (def (run-agent! state text) (app-state-agent-busy?-set! state #t) (app-state-stream-buf-set! state "") @@ -478,7 +582,7 @@ [m-override (current-model-override)] [s-id (app-state-session-id state)]) (tui-log - "run-agent: spawning thread, session=~a provider=~a model=~a key?=~a" + "run-agent: spawning worker thread, session=~a provider=~a model=~a key?=~a" s-id p-name m-name (and (config-get-provider-key p-name) #t)) (spawn @@ -487,33 +591,22 @@ [current-model-override m-override] [current-stream-cb (lambda (token) - (tui-stream-token! state token))] + (send-agent-event! + (list 'stream-token token)))] [current-tool-cb (lambda (event name args) - (tui-tool-event! - state - event - name - args))] + (send-agent-event! + (list 'tool-event event name args)))] [current-usage-cb (lambda (usage) - (tui-usage-update! state usage))]) + (send-agent-event! + (list 'usage-update usage)))]) (agent-run s-id text) - (tui-log - "run-agent: agent-run returned, buf-len=~a" - (string-length (app-state-stream-buf state))) - (let ([buf (app-state-stream-buf state)]) - (unless (string-empty? buf) - (update-last-assistant! state buf)))) + (send-agent-event! (list 'agent-done))) (catch (e) - (tui-log "run-agent: ERROR ~a" (err->string e)) - (add-message! - state - (msg-block-error (err->string e))))) - (app-state-agent-busy?-set! state #f) - (app-state-scroll-offset-set! state 0) - (app-state-dirty?-set! state #t))))) + (send-agent-event! + (list 'agent-error (err->string e))))))))) (def (tui-stream-token! state token) "Handle a streaming token from the LLM — called from agent thread." (let ([buf (app-state-stream-buf state)]) --- a/src/jcode/core/models.ss +++ b/src/jcode/core/models.ss @@ -1,10 +1,17 @@ ;;; jcode model registry -;;; Pre-populated model lists per provider. +;;; Pre-populated model lists per provider, with optional disk cache +;;; populated by the /refresh-models command. (export provider-models all-providers provider-display-name - provider-default-model) + provider-default-model + models-cache-path + load-models-cache! + write-models-cache!) + +(import :std/text/json + :std/os/path) ;; ---- Provider metadata ---- @@ -35,6 +42,14 @@ ;; Each entry: (model-id . display-name) (def (provider-models provider) + ;; Lazy-load cache on first call. Cache wins over hardcoded defaults. + (unless (*models-cache*) (load-models-cache!)) + (let ((cached (and (*models-cache*) (hash-get (*models-cache*) provider)))) + (if (and cached (pair? cached)) + (cache-entries->pairs cached) + (provider-default-models provider)))) + +(def (provider-default-models provider) (case (string->symbol provider) ((anthropic) anthropic-models) ((openai) openai-models) @@ -44,6 +59,59 @@ ((ollama) ollama-models) (else '()))) +;; ---- On-disk cache ---- +;; Stored as JSON: { "deepseek": [["id", "display"], ...], ... } +;; Populated by the /refresh-models slash command in the TUI. + +(def *models-cache* (make-parameter #f)) + +(def (models-cache-path) + (path-join (or (getenv "HOME") ".") ".jcode" "models-cache.json")) + +(def (cache-entries->pairs entries) + ;; JSON parses [id, display] as a 2-element list; normalize to (id . display). + (map (lambda (e) + (cond + ((pair? e) (if (pair? (cdr e)) (cons (car e) (cadr e)) e)) + ((string? e) (cons e e)) + (else (cons (format "~a" e) (format "~a" e))))) + entries)) + +(def (load-models-cache!) + (let ((path (models-cache-path))) + (if (file-exists? path) + (try + (let ((data (call-with-input-file path read-json))) + (*models-cache* (if (hash-table? data) data (make-hash-table))) + (*models-cache*)) + (catch (e) + (*models-cache* (make-hash-table)) + (*models-cache*))) + (begin + (*models-cache* (make-hash-table)) + (*models-cache*))))) + +(def (write-models-cache! data) + "Persist {provider -> list-of-(id . display)} to ~/.jcode/models-cache.json. + Also updates the in-memory cache so /model popup sees the new data immediately." + (let* ((path (models-cache-path)) + (dir (path-directory path)) + (json-data (make-hash-table))) + (hash-for-each + (lambda (provider models) + (hash-put! json-data provider + (map (lambda (m) (list (car m) (cdr m))) models))) + data) + (unless (file-exists? dir) (mkdir dir)) + (when (file-exists? path) (delete-file path)) + (let ((port (open-output-file path))) + (dynamic-wind + (lambda () (void)) + (lambda () (write-json json-data port)) + (lambda () (close-output-port port)))) + (*models-cache* data) + path)) + (def anthropic-models '(("claude-sonnet-4-20250514" . "Claude Sonnet 4") ("claude-opus-4-20250514" . "Claude Opus 4") @@ -58,8 +126,11 @@ ("o4-mini" . "o4 Mini"))) (def deepseek-models - '(("deepseek-chat" . "DeepSeek V3") - ("deepseek-reasoner" . "DeepSeek R1"))) + ;; NOTE: As of V3.1+ both endpoints share the same base weights and differ + ;; only in thinking mode. DeepSeek's /v1/models returns exactly these two + ;; IDs and nothing else. Use /refresh-models to confirm against upstream. + '(("deepseek-chat" . "DeepSeek Chat (non-thinking)") + ("deepseek-reasoner" . "DeepSeek Reasoner (thinking)"))) (def google-models '(("gemini-2.5-pro" . "Gemini 2.5 Pro") --- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -4,6 +4,7 @@ provider-chat provider-stream provider-stream-chat + provider-list-models provider-name provider-model) @@ -678,14 +679,14 @@ ;; tool use accumulators: id -> alist (tu-table (make-hash-table)) (current-idx (make-parameter #f)) - (usage-acc (make-hash-table))) + (usage-acc (make-hash-table)) + (event-type #f)) (let ((http-status (http-post-stream url headers (json-object->string body) (lambda (event-str) (when event-str ;; Anthropic SSE uses multiple lines per event: "event: ...\ndata: ..." (let* ((lines (string-split event-str #\newline)) - (event-type #f) (data-str #f)) (for-each (lambda (line) @@ -789,3 +790,231 @@ (else (error 'provider-stream-chat (format "Unknown provider '~a'" (provider-name provider)))))) + +;;; ================================================================ +;;; Model listing: live fetch from provider /models endpoints +;;; ================================================================ + +;; Byte-returning TLS reader — accumulates chunks, no UTF-8 slicing. +(def (tls-read-all-bytes conn) + (let ((chunks '()) + (buf (make-bytevector 4096))) + (let loop () + (let ((n (rustls-read conn buf 4096))) + (if (<= n 0) + (concat-bytevectors (reverse chunks)) + (let ((chunk (make-bytevector n))) + (bytevector-copy! buf 0 chunk 0 n) + (set! chunks (cons chunk chunks)) + (loop))))))) + +(def (port-read-all-bytes in) + (let ((chunks '()) + (buf (make-bytevector 4096))) + (let loop () + (let ((n (get-bytevector-n! in buf 0 4096))) + (cond + ((or (eof-object? n) (not n) (<= n 0)) + (concat-bytevectors (reverse chunks))) + (else + (let ((chunk (make-bytevector n))) + (bytevector-copy! buf 0 chunk 0 n) + (set! chunks (cons chunk chunks)) + (loop)))))))) + +(def (concat-bytevectors bvs) + (let* ((total (let sum ((l bvs) (s 0)) + (if (null? l) s + (sum (cdr l) (+ s (bytevector-length (car l))))))) + (out (make-bytevector total))) + (let loop ((l bvs) (offset 0)) + (if (null? l) out + (let* ((part (car l)) + (plen (bytevector-length part))) + (bytevector-copy! part 0 out offset plen) + (loop (cdr l) (+ offset plen))))))) + +;; Decode HTTP/1.1 Transfer-Encoding: chunked body from raw bytes. +;; Chunk format: <hex-size>[;ext]\r\n<data>\r\n ... 0\r\n\r\n +(def (decode-chunked-bytes bv) + (let ((len (bytevector-length bv)) + (chunks '())) + (def (finalize) + (concat-bytevectors (reverse chunks))) + (let loop ((pos 0)) + (cond + ((>= pos (- len 1)) (finalize)) + (else + ;; Scan for \r\n terminating the size line + (let find-eol ((i pos)) + (cond + ((>= i (- len 1)) (finalize)) + ((and (= (bytevector-u8-ref bv i) 13) + (= (bytevector-u8-ref bv (+ i 1)) 10)) + ;; Parse hex size from [pos..i) + (let* ((size-bv (make-bytevector (- i pos))) + (_ (bytevector-copy! bv pos size-bv 0 (- i pos))) + (size-str (utf8->string size-bv)) + (semi (string-contains size-str ";")) + (hex (if semi (substring size-str 0 semi) size-str)) + (size (string->number (string-trim hex) 16))) + (cond + ((or (not size) (<= size 0)) + (finalize)) + (else + (let* ((data-start (+ i 2)) + (data-end (+ data-start size))) + (cond + ((> data-end len) (finalize)) + (else + (let ((chunk (make-bytevector size))) + (bytevector-copy! bv data-start chunk 0 size) + (set! chunks (cons chunk chunks)) + ;; Skip trailing \r\n + (loop (+ data-end 2)))))))))) + (else (find-eol (+ i 1)))))))))) + +(def (header-value headers name) + (let ((h (assoc (string-downcase name) headers))) + (and h (cdr h)))) + +;; HTTP GET → (values status body-string). Handles Content-Length, chunked, +;; and connection-close framing. Body is decoded UTF-8. +(def (http-get-json url headers) + (let-values (((scheme host port path) (parse-url-parts url))) + (let* ((hdrs (if (assoc "Connection" headers) + headers + (cons '("Connection" . "close") headers))) + (req (build-http-request "GET" path host hdrs #f))) + (if (equal? scheme "https") + (let ((conn (rustls-connect host port))) + (dynamic-wind + (lambda () (void)) + (lambda () + (tls-write-string conn req) + (let* ((status-line (tls-read-line conn)) + (status (parse-http-status status-line)) + (resp-headers (read-tls-headers conn)) + (cl (header-value resp-headers "content-length")) + (te (header-value resp-headers "transfer-encoding")) + (body-bv (cond + (cl (let ((s (tls-read-n conn (string->number cl)))) + (string->utf8 s))) + ((and te (string-contains te "chunked")) + (decode-chunked-bytes (tls-read-all-bytes conn))) + (else (tls-read-all-bytes conn)))) + (body (utf8->string body-bv))) + (values status body))) + (lambda () (rustls-close conn)))) + (let-values (((in out) (tcp-connect host port))) + (dynamic-wind + (lambda () (void)) + (lambda () + (port-write-string out req) + (let* ((status-line (port-read-line in)) + (status (parse-http-status status-line)) + (resp-headers (port-read-headers in)) + (te (header-value resp-headers "transfer-encoding")) + (raw (port-read-all-bytes in)) + (body-bv (if (and te (string-contains te "chunked")) + (decode-chunked-bytes raw) + raw)) + (body (utf8->string body-bv))) + (values status body))) + (lambda () + (close-port in) + (close-port out)))))))) + +;; ---- Per-provider /models parsers ---- + +;; OpenAI-compatible: {data: [{id, ...}]}. OpenRouter also exposes {name}. +(def (openai-list-models provider) + (let* ((url (string-append (provider-base-url provider) "/models")) + (headers (openai-headers provider))) + (let-values (((status text) (http-get-json url headers))) + (if (= status 200) + (let* ((json (string->json-object text)) + (data (or (hash-get json "data") '()))) + (map (lambda (entry) + (let* ((id (hash-ref entry "id")) + (name (or (hash-get entry "name") id))) + (cons id name))) + data)) + (error 'openai-list-models + (format "API error ~a: ~a" status text)))))) + +;; Anthropic: /v1/models?limit=1000 → {data: [{id, display_name, ...}]}. +(def (anthropic-list-models provider) + (let* ((url (string-append (provider-base-url provider) "/models?limit=1000")) + (headers (anthropic-headers provider))) + (let-values (((status text) (http-get-json url headers))) + (if (= status 200) + (let* ((json (string->json-object text)) + (data (or (hash-get json "data") '()))) + (map (lambda (entry) + (cons (hash-ref entry "id") + (or (hash-get entry "display_name") + (hash-ref entry "id")))) + data)) + (error 'anthropic-list-models + (format "API error ~a: ~a" status text)))))) + +;; Google: /v1beta/models?pageSize=1000&key=KEY → {models: [...]}. +;; Name field is "models/gemini-..."; strip the prefix. +;; Filter to models that support generateContent (excludes embeddings, etc.). +(def (google-list-models provider) + (let* ((key (or (provider-api-key provider) "")) + (url (string-append (provider-base-url provider) + "/models?pageSize=1000&key=" key)) + (headers '(("Content-Type" . "application/json")))) + (let-values (((status text) (http-get-json url headers))) + (if (= status 200) + (let* ((json (string->json-object text)) + (models (or (hash-get json "models") '()))) + (filter-map + (lambda (entry) + (let* ((raw-name (or (hash-get entry "name") "")) + (id (if (string-prefix? "models/" raw-name) + (substring raw-name 7 (string-length raw-name)) + raw-name)) + (display-name (or (hash-get entry "displayName") id)) + (methods (or (hash-get entry "supportedGenerationMethods") '()))) + (if (member "generateContent" methods) + (cons id display-name) + #f))) + models)) + (error 'google-list-models + (format "API error ~a: ~a" status text)))))) + +;; Ollama local: /v1/models (OpenAI-compatible), no auth. +(def (ollama-list-models provider) + (let* ((url (string-append (provider-base-url provider) "/models")) + (headers '(("Content-Type" . "application/json")))) + (let-values (((status text) (http-get-json url headers))) + (if (= status 200) + (let* ((json (string->json-object text)) + (data (or (hash-get json "data") '()))) + (map (lambda (entry) + (let ((id (hash-ref entry "id"))) + (cons id id))) + data)) + (error 'ollama-list-models + (format "API error ~a: ~a" status text)))))) + +;; Dispatcher — returns list of (id . display-name) pairs for the provider. +;; Raises on network/API errors. Ollama does not require a key. +(def (provider-list-models provider) + (unless (or (provider-api-key provider) + (equal? (provider-name provider) "ollama")) + (error 'provider-list-models + (format "No API key for provider '~a'" (provider-name provider)))) + (log-info logger "list-models" + `((provider . ,(provider-name provider)))) + (case (string->symbol (provider-name provider)) + ((openai openrouter deepseek) (openai-list-models provider)) + ((anthropic) (anthropic-list-models provider)) + ((google) (google-list-models provider)) + ((ollama) (ollama-list-models provider)) + (else + (error 'provider-list-models + (format "Unknown provider '~a'" (provider-name provider)))))) --- a/src/jcode/ui/tui.ss +++ b/src/jcode/ui/tui.ss @@ -4,6 +4,7 @@ (export tui-main) (import :std/misc/string + :std/misc/thread :std/text/json :jcode/ui/tui-ffi :jcode/ui/tui-theme @@ -18,6 +19,7 @@ :jcode/core/config :jcode/core/models :jcode/core/agent + :jcode/provider/provider :jcode/core/session :jcode/core/log :jcode/tool/registry @@ -38,6 +40,13 @@ (def *tui-log-port* (make-parameter #f)) +;; ---- Main thread handle ---- +;; Captured in tui-main before the event loop starts. Worker threads (agent) +;; send events to this thread's mailbox via thread-send instead of mutating +;; app-state directly — Chez hash tables and lists are not thread-safe under +;; preemptive pthreads, so all state mutation must happen on the main thread. +(def *main-thread* (make-parameter #f)) + (def (tui-log fmt . args) (let ((p (*tui-log-port*))) (when p @@ -184,7 +193,8 @@ (reflow-all! state) (draw-all! state) (tb-present!) - (tui-log "tui-main: entering event loop") + (*main-thread* (current-thread))