updates from kimi3
ober
93ec56eab1cba8eef57740add39f09cbf5eea2be
--- a/src/jcode/core/compaction.ss +++ b/src/jcode/core/compaction.ss @@ -130,6 +130,7 @@ (cond ((null? msgs) (let ((result (reverse acc))) + (invalidate-message-json-cache!) (log-info logger "compacted" `((before . ,total) (after . ,(length result)) --- a/src/jcode/core/message.ss +++ b/src/jcode/core/message.ss @@ -16,6 +16,8 @@ message-thinking-set! extract-thinking message->json + message->json-cached + invalidate-message-json-cache! json->message tool-call-id tool-call-name @@ -93,6 +95,24 @@ (hash-put! ht "tool_call_id" (message-tool-call-id msg))) ht)) +(def *message-json-cache* (make-hash-table-eq)) + +(def (message->json-cached msg) + "message->json memoized by eq? identity of the message struct. Messages + are effectively immutable w.r.t. their JSON projection (only + message-thinking-set! exists and it does not affect message->json), so + the cache is safe without per-mutation invalidation. Callers that need + to mutate the returned hash table MUST copy it first — never mutate the + cached object in place." + (or (hash-get *message-json-cache* msg) + (let ((j (message->json msg))) + (hash-put! *message-json-cache* msg j) + j))) + +(def (invalidate-message-json-cache!) + "Drop every cached message->json hash table. Called after compaction so + pruned/replaced messages stop holding space in the cache." + (hash-clear! *message-json-cache*)) (def (assoc-args? args) (and (pair? args) (pair? (car args)))) --- a/src/jcode/core/models.ss +++ b/src/jcode/core/models.ss @@ -158,9 +158,19 @@ (filter (lambda (s) (not (string=? s ""))) (string-split (string-downcase (string-trim (or query ""))) #\space))) +(def *model-search-haystack* (make-hash-table)) + +(def (model-haystack model) + "Downcased search string for MODEL, memoized in *model-search-haystack*. + Keyed by the (id . display) pair under equal? so it works for both the + hardcoded default lists (constant pairs) and the JSON-derived cache path + (rebuilt pairs). Cleared in load/write-models-cache!." + (or (hash-get *model-search-haystack* model) + (let ((h (string-downcase (format "~a ~a" (car model) (cdr model))))) + (hash-put! *model-search-haystack* model h) + h))) (def (model-search-hit? model terms) - (let ((haystack (string-downcase - (format "~a ~a" (car model) (cdr model))))) + (let ((haystack (model-haystack model))) (every (lambda (term) (number? (string-contains haystack term))) terms))) @@ -218,14 +228,17 @@ (try (let ((data (call-with-input-file path read-json))) (*models-cache* (if (hash-table? data) data (make-hash-table))) + (hash-clear! *model-search-haystack*) (*models-cache*)) (catch (e) (log-warn logger "cache-parse-failed" `((path . ,path) (error . ,(err->string e)))) (*models-cache* (make-hash-table)) + (hash-clear! *model-search-haystack*) (*models-cache*))) (begin (*models-cache* (make-hash-table)) + (hash-clear! *model-search-haystack*) (*models-cache*))))) (def (write-models-cache! data) @@ -242,6 +255,7 @@ (unless (file-exists? dir) (mkdir dir)) (write-json-cache-file! path json-data) (*models-cache* data) + (hash-clear! *model-search-haystack*) path)) (def anthropic-models --- a/src/jcode/mcp/client.ss +++ b/src/jcode/mcp/client.ss @@ -26,6 +26,7 @@ :jcode/core/log :jcode/core/config :jcode/core/secrets + :jcode/core/permissions ;; glob-style-match for tool_deny/tool_allow ACL :jcode/tool/registry :jerboa/core :jerboa/runtime @@ -307,26 +308,51 @@ ;; --- tool registration --- +(def (mcp-tool-allowed? server-name tool-name) + "Check tool_deny (global config always applies) then tool_allow + (project-config under trust-project-config?) for an MCP tool." + (let ((deny-list (config-global-ref "mcpServers" server-name "tool_deny"))) + (cond + ((and deny-list (list? deny-list) + (any (lambda (p) (glob-style-match p tool-name)) deny-list)) + (log-info logger "tool-denied" + `((server . ,server-name) (tool . ,tool-name))) + #f) + (else + (let ((allow-list (config-secure-ref "mcpServers" server-name "tool_allow"))) + (if (and allow-list (list? allow-list)) + (let ((allowed (any (lambda (p) (glob-style-match p tool-name)) allow-list))) + (unless allowed + (log-info logger "tool-not-allowed" + `((server . ,server-name) (tool . ,tool-name)))) + allowed) + #t)))))) + (def (register-mcp-tools conn prefix) "Discover tools from MCP server and register them in jcode." (let ((tools (mcp-list-tools conn))) (log-info logger "discovered" `((server . ,(mcp-conn-name conn)) (tools . ,(length tools)))) - (for-each - (lambda (tool) - (let ((name (hash-get tool "name")) - (desc (or (hash-get tool "description") "MCP tool")) - (schema (or (hash-get tool "inputSchema") (make-hash-table)))) - (let ((jcode-name (string-append prefix name))) - (register-tool! jcode-name desc schema - (lambda (args) - (mcp-call-tool conn name args))) - (set-tool-origin! jcode-name 'mcp)))) - tools) - ;; Cache the count so mcp-active-servers can return it without - ;; doing a blocking JSON-RPC call later. - (hash-put! *mcp-tool-counts* (mcp-conn-name conn) (length tools)) - (length tools))) + (let ((server-name (mcp-conn-name conn)) + (registered 0)) + (for-each + (lambda (tool) + (let ((name (hash-get tool "name")) + (desc (or (hash-get tool "description") "MCP tool")) + (schema (or (hash-get tool "inputSchema") (make-hash-table)))) + (let ((jcode-name (string-append prefix name))) + (if (mcp-tool-allowed? server-name jcode-name) + (begin + (register-tool! jcode-name desc schema + (lambda (args) + (mcp-call-tool conn name args))) + (set-tool-origin! jcode-name 'mcp) + (set! registered (+ registered 1))) + (log-info logger "tool-skipped" + `((server . ,server-name) (tool . ,jcode-name))))))) + tools) + (hash-put! *mcp-tool-counts* (mcp-conn-name conn) registered) + registered))) ;; --- config and init --- new file mode 100644 --- /dev/null +++ b/src/jcode/provider/anthropic.ss @@ -0,0 +1,363 @@ +;;; jcode provider Anthropic Messages API + +(export anthropic-chat + anthropic-headers + anthropic-body + cache-control-1h + mark-last-tool-cached + cache-control-ephemeral + anthropic-apply-caching + anthropic-add-cache-control + find-system-message + remove-system-messages + anthropic-convert-message + anthropic-convert-tool + anthropic-parse-response + anthropic-stream-headers + anthropic-stream-body + anthropic-stream-chat + anthropic-list-models) + +(import :std/text/json + :std/misc/string + :jcode/core/log + :jcode/core/message + :jcode/core/models + :jcode/core/errors + :jcode/provider/http + :jcode/provider/base + :jerboa/core + :jerboa/runtime) + +(def logger (make-logger "provider.anthropic")) + +;;; Anthropic API ;;; + +(def (anthropic-chat provider messages tools) + (let* ((url (string-append (provider-base-url provider) "/messages")) + (headers (anthropic-headers provider)) + (body (anthropic-body provider messages tools)) + (body-json (json-object->string body))) + (when (tracing?) + (log-trace logger "anthropic-request" + `((url . ,(redact-url url)) + (headers . ,(redact-headers headers)) + (body . ,body-json)))) + (let-values (((status text) (http-post-json url headers body-json))) + (when (tracing?) + (log-trace logger "anthropic-response" + `((status . ,status) (body . ,text)))) + (if (= status 200) + (anthropic-parse-response (string->json-object text)) + (error 'anthropic-chat (format "API error ~a: ~a" status text)))))) + +(def (anthropic-headers provider) + ;; Prompt caching is GA — no beta header needed. Extended cache TTL + ;; (1h) is also GA on current models. + `(("Content-Type" . "application/json") + ("x-api-key" . ,(provider-api-key provider)) + ("anthropic-version" . "2023-06-01"))) + +(def (anthropic-body provider messages tools) + (let ((body (make-hash-table)) + (system-msg (find-system-message messages)) + (other-msgs (remove-system-messages messages))) + (hash-put! body "model" (provider-model provider)) + (hash-put! body "max_tokens" 8192) + ;; System message with prompt caching + (when system-msg + (let ((block (make-hash-table))) + (hash-put! block "type" "text") + (hash-put! block "text" (message-content system-msg)) + (hash-put! block "cache_control" (cache-control-1h)) + (hash-put! body "system" (list block)))) + ;; Convert messages and apply caching to last 2 turns + (let ((converted (map anthropic-convert-message other-msgs))) + (hash-put! body "messages" (anthropic-apply-caching converted))) + (when (and tools (not (null? tools))) + ;; Tools render first in the cache prefix and change rarely within a + ;; session — mark the last tool ephemeral with 1h TTL so the entire + ;; tool block is cached and reused across turns. + (hash-put! body "tools" + (mark-last-tool-cached (map anthropic-convert-tool tools))) + (hash-put! body "tool_choice" (let ((tc (make-hash-table))) + (hash-put! tc "type" "auto") + tc))) + body)) + +(def (cache-control-1h) + (let ((cc (make-hash-table))) + (hash-put! cc "type" "ephemeral") + (hash-put! cc "ttl" "1h") + cc)) + +(def (mark-last-tool-cached tools) + (cond + ((or (not tools) (null? tools)) tools) + (else + (let ((rev (reverse tools))) + (hash-put! (car rev) "cache_control" (cache-control-1h)) + (reverse rev))))) + +(def (cache-control-ephemeral) + (let ((cc (make-hash-table))) + (hash-put! cc "type" "ephemeral") + cc)) + +(def (anthropic-apply-caching messages) + "Add cache_control to the last 2 messages for Anthropic prompt caching." + (let* ((len (length messages)) + (cache-start (max 0 (- len 2)))) + (let loop ((msgs messages) (i 0) (acc '())) + (if (null? msgs) + (reverse acc) + (let ((msg (car msgs))) + (loop (cdr msgs) (+ i 1) + (cons (if (>= i cache-start) + (anthropic-add-cache-control msg) + msg) + acc))))))) + +(def (anthropic-add-cache-control msg) + "Add cache_control to the last content block in a message. Plain string + content (ordinary text turns) is promoted to a one-element text-block + list so it can carry a breakpoint too — otherwise only tool_use / + tool_result turns ever get cached and plain-text turns silently re-bill + the whole history." + (let ((content (hash-get msg "content"))) + (cond + ((and (list? content) (not (null? content))) + (let* ((last-block (car (reverse content)))) + (when (hash-table? last-block) + (hash-put! last-block "cache_control" (cache-control-ephemeral)))) + msg) + ((and (string? content) (> (string-length content) 0)) + (let ((block (make-hash-table))) + (hash-put! block "type" "text") + (hash-put! block "text" content) + (hash-put! block "cache_control" (cache-control-ephemeral)) + (hash-put! msg "content" (list block))) + msg) + (else msg)))) + +(def (find-system-message messages) + (find (lambda (m) (equal? (message-role m) "system")) messages)) + +(def (remove-system-messages messages) + (filter (lambda (m) (not (equal? (message-role m) "system"))) messages)) + +(def (anthropic-convert-message msg) + (let ((ht (make-hash-table))) + (hash-put! ht "role" + (if (equal? (message-role msg) "tool") "user" (message-role msg))) + (cond + ((message-tool-call-id msg) + (hash-put! ht "content" + (list (let ((r (make-hash-table))) + (hash-put! r "type" "tool_result") + (hash-put! r "tool_use_id" (message-tool-call-id msg)) + (hash-put! r "content" (message-content msg)) + r)))) + ((message-tool-calls msg) + (hash-put! ht "content" + (map (lambda (tc) + (let ((t (make-hash-table))) + (hash-put! t "type" "tool_use") + (hash-put! t "id" (tool-call-id tc)) + (hash-put! t "name" (tool-call-name tc)) + (hash-put! t "input" + (string->json-object (tool-call-arguments tc))) + t)) + (message-tool-calls msg)))) + (else + (hash-put! ht "content" (message-content msg)))) + ht)) + +(def (anthropic-convert-tool tool) + (let ((ht (make-hash-table))) + (hash-put! ht "name" (hash-ref tool "name" "")) + (hash-put! ht "description" (hash-ref tool "description" "")) + (hash-put! ht "input_schema" + (hash-ref tool "parameters" (make-hash-table))) + ht)) + +(def (anthropic-parse-response json) + (let* ((content (hash-ref json "content" '())) + (tool-uses (filter (lambda (c) + (equal? (hash-ref c "type" "") "tool_use")) + content)) + (text-parts (filter (lambda (c) + (equal? (hash-ref c "type" "") "text")) + content)) + (text (if (null? text-parts) + #f + (hash-ref (car text-parts) "text" "")))) + (if (null? tool-uses) + (make-assistant-message text) + (make-assistant-message text + (map (lambda (tu) + ;; Preserve the Anthropic-provided tool use ID + (restore-tool-call + (hash-ref tu "id" "") + (hash-ref tu "name" "") + (json-object->string (hash-ref tu "input" #f)))) + tool-uses))))) +;;; Anthropic Streaming ;;; + +(def (anthropic-stream-headers provider) + ;; Prompt caching is GA — the old prompt-caching beta header is obsolete + ;; (kept the non-stream path's header set in sync). + `(("Content-Type" . "application/json") + ("x-api-key" . ,(provider-api-key provider)) + ("anthropic-version" . "2023-06-01"))) + +(def (anthropic-stream-body provider messages tools) + (let ((body (anthropic-body provider messages tools))) + (hash-put! body "stream" #t) + body)) + +(def (anthropic-stream-chat provider messages tools token-cb) + ;; Anthropic SSE streaming. Returns (values content tool-call-list usage-alist) + (let* ((url (string-append (provider-base-url provider) "/messages")) + (headers (anthropic-stream-headers provider)) + (body (anthropic-stream-body provider messages tools)) + (body-json (json-object->string body)) + (text-acc (open-output-string)) + ;; tool use accumulators: id -> alist + (tu-table (make-hash-table)) + (current-idx (make-parameter #f)) + (usage-acc (make-hash-table)) + (finish-reason-box (box #f)) + (event-type #f)) + (when (tracing?) + (log-trace logger "anthropic-stream-request" + `((url . ,(redact-url url)) + (headers . ,(redact-headers headers)) + (body . ,body-json)))) + (let ((http-status + (jcode-http-post-stream url headers body-json + (lambda (event-str) + (when event-str + (when (tracing?) + (log-trace logger "anthropic-sse-event" `((data . ,event-str)))) + ;; Anthropic SSE uses multiple lines per event: "event: ...\ndata: ..." + (let* ((lines (string-split event-str #\newline)) + (data-str #f)) + (for-each + (lambda (line) + (cond + ((string-prefix? "event: " line) + (set! event-type (substring line 7 (string-length line)))) + ((string-prefix? "data: " line) + (set! data-str (substring line 6 (string-length line)))))) + lines) + (when (and event-type data-str) + (let ((json (guard (e [(error? e) #f]) (string->json-object data-str)))) + (when (and json (hash-table? json)) + (case (if (string? event-type) (string->symbol event-type) 'unknown) + ((content_block_delta) + (let ((delta (hash-get json "delta"))) + (when (and delta (hash-table? delta)) + (let ((dtype (hash-get delta "type"))) + (case (if (string? dtype) (string->symbol dtype) 'unknown) + ((text_delta) + (let ((text (hash-get delta "text"))) + (when text + (put-string text-acc text) + (token-cb text)))) + ((input_json_delta) + ;; Accumulate tool input + (let ((idx (current-idx)) + (partial (hash-get delta "partial_json"))) + (when (and idx partial) + (let ((acc (hash-ref tu-table idx #f))) + (when acc + (hash-put! acc "args" + (string-append + (or (hash-get acc "args") "") + partial))))))) + (else (void))))))) + ;; Tool use block start + ((content_block_start) + (let ((block (hash-get json "content_block"))) + (when (and block (equal? (hash-get block "type") "tool_use")) + (let ((idx (hash-get json "index"))) + (current-idx idx) + (let ((acc (make-hash-table))) + (hash-put! acc "id" (hash-get block "id")) + (hash-put! acc "name" (hash-get block "name")) + (hash-put! tu-table idx acc)))))) + ;; Block ended + ((content_block_stop) + (current-idx #f)) + ;; Usage from message lifecycle events + ((message_start) + (let ((msg (hash-get json "message"))) + (when msg + (let ((usage (hash-get msg "usage"))) + (when (and usage (hash-table? usage)) + (hash-for-each (lambda (k v) (hash-put! usage-acc k v)) usage)))))) + ((message_delta) + ;; delta.stop_reason: "end_turn" | "max_tokens" | + ;; "stop_sequence" | "tool_use". We map max_tokens to + ;; the OpenAI-style "length" so detect-truncated fires. + (let ((delta (hash-get json "delta"))) + (when (and delta (hash-table? delta)) + (let ((sr (hash-get delta "stop_reason"))) + (when (and sr (string? sr)) + (set-box! finish-reason-box + (if (equal? sr "max_tokens") "length" sr)))))) + (let ((usage (hash-get json "usage"))) + (when (and usage (hash-table? usage)) + (hash-for-each (lambda (k v) (hash-put! usage-acc k v)) usage)))) + (else (void)))))))))))) + (unless (= http-status 200) + (log-error logger "stream-http-error" + `((status . ,http-status) (url . ,url))))) + ;; Build result + (let* ((content (get-output-string text-acc)) + (indices (list-sort < (hash-keys tu-table))) + (tool-calls + (map (lambda (idx) + (let ((acc (hash-ref tu-table idx))) + (restore-tool-call + (or (hash-get acc "id") (format "tu_~a" idx)) + (or (hash-get acc "name") "unknown") + (or (hash-get acc "args") "{}")))) + indices))) + (when (tracing?) + (log-trace logger "anthropic-stream-result" + `((content . ,content) + (tool-calls . ,(map (lambda (tc) + (cons (tool-call-name tc) + (tool-call-arguments tc))) + tool-calls))))) + (values content tool-calls + (list (cons 'tokens-in (or (hash-get usage-acc "input_tokens") 0)) + (cons 'tokens-out (or (hash-get usage-acc "output_tokens") 0)) + (cons 'cache-read (or (hash-get usage-acc "cache_read_input_tokens") 0)) + (cons 'cache-creation (or (hash-get usage-acc "cache_creation_input_tokens") 0)) + (cons 'cost (compute-cost (provider-model provider) + usage-acc))) + ;; Anthropic streaming does not surface logprobs, but stop_reason + ;; is captured above so detect-truncated still works. + `((finish_reason . ,(unbox finish-reason-box)) + (mean_logprob . #f) + (min_logprob . #f) + (mean_entropy . #f)))))) +;; 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)))))) + new file mode 100644 --- /dev/null +++ b/src/jcode/provider/base.ss @@ -0,0 +1,24 @@ +;;; jcode provider base record and accessors + +(export make-provider-record + provider-record? + provider-record-name + provider-record-api-key + provider-record-model + provider-record-base-url + provider? + provider-name + provider-api-key + provider-model + provider-base-url) + +(import :jerboa/core + :jerboa/runtime) + +(defstruct provider-record (name api-key model base-url)) + +(def (provider? x) (provider-record? x)) +(def (provider-name p) (provider-record-name p)) +(def (provider-api-key p) (provider-record-api-key p)) +(def (provider-model p) (provider-record-model p)) +(def (provider-base-url p) (provider-record-base-url p)) new file mode 100644 --- /dev/null +++ b/src/jcode/provider/google.ss @@ -0,0 +1,201 @@ +;;; jcode provider Google Gemini API + +(export google-chat + google-chat-with-usage + google-body + google-convert-message + google-convert-tool + google-parse-response + google-usage->alist + google-list-models) + +(import :std/text/json + :std/misc/string + :jcode/core/config + :jcode/core/log + :jcode/core/message + :jcode/core/models + :jcode/core/errors + :jcode/provider/http + :jcode/provider/anthropic + :jerboa/core + :jerboa/runtime) + +(import :jcode/provider/base) + +(def logger (make-logger "provider.google")) + +;;; Google Gemini API ;;; + +(def (google-chat provider messages tools) + (let-values (((message _usage) (google-chat-with-usage provider messages tools))) + message)) + +(def (google-chat-with-usage provider messages tools) + (let* ((url (string-append + (provider-base-url provider) + "/models/" (provider-model provider) + ":generateContent?key=" (provider-api-key provider))) + (headers '(("Content-Type" . "application/json"))) + (body (google-body provider messages tools)) + (body-json (json-object->string body))) + (when (tracing?) + (log-trace logger "google-request" + `((url . ,(redact-url url)) + (headers . ,(redact-headers headers)) + (body . ,body-json)))) + (let-values (((status text) (http-post-json url headers body-json))) + (when (tracing?) + (log-trace logger "google-response" + `((status . ,status) (body . ,text)))) + (if (= status 200) + (let ((json (string->json-object text))) + (values (google-parse-response json) + (google-usage->alist provider (hash-get json "usageMetadata")))) + (error 'google-chat (format "API error ~a: ~a" status text)))))) + +(def (google-body provider messages tools) + (let ((body (make-hash-table)) + (system-msg (find-system-message messages)) + (other-msgs (remove-system-messages messages)) + (cached-content (config-ref "providers" "google" "cached_content"))) + (when (and (string? cached-content) + (> (string-length cached-content) 0)) + ;; Gemini explicit context caching uses cachedContent handles created via + ;; cachedContents.create. Implicit caching remains automatic on Gemini 2.5+. + (hash-put! body "cachedContent" cached-content)) + (when system-msg + (let ((si (make-hash-table)) + (part (make-hash-table))) + (hash-put! part "text" (message-content system-msg)) + (hash-put! si "parts" (list part)) + (hash-put! body "systemInstruction" si))) + (hash-put! body "contents" (map google-convert-message other-msgs)) + (when (and tools (not (null? tools))) + (let ((td (make-hash-table))) + (hash-put! td "function_declarations" (map google-convert-tool tools)) + (hash-put! body "tools" (list td)))) + body)) + +(def (google-convert-message msg) + (let ((ht (make-hash-table))) + (cond + ;; Tool result — role "tool" maps to Gemini functionResponse + ((message-tool-call-id msg) + (hash-put! ht "role" "user") + (let ((part (make-hash-table)) + (fr (make-hash-table)) + (resp (make-hash-table))) + (hash-put! resp "output" (or (message-content msg) "")) + (hash-put! fr "name" (message-tool-call-id msg)) + (hash-put! fr "response" resp) + (hash-put! part "functionResponse" fr) + (hash-put! ht "parts" (list part)))) + ;; Assistant message — may have text and/or tool calls + ((equal? (message-role msg) "assistant") + (hash-put! ht "role" "model") + (let ((text-parts + (if (message-content msg) + (let ((p (make-hash-table))) + (hash-put! p "text" (message-content msg)) + (list p)) + '())) + (call-parts + (if (message-tool-calls msg) + (map (lambda (tc) + (let ((p (make-hash-table)) + (fc (make-hash-table))) + (hash-put! fc "name" (tool-call-name tc)) + (hash-put! fc "args" + (string->json-object (tool-call-arguments tc))) + (hash-put! p "functionCall" fc) + p)) + (message-tool-calls msg)) + '()))) + (hash-put! ht "parts" (append text-parts call-parts)))) + ;; User message + (else + (hash-put! ht "role" "user") + (let ((p (make-hash-table))) + (hash-put! p "text" (or (message-content msg) "")) + (hash-put! ht "parts" (list p))))) + ht)) + +(def (google-convert-tool tool) + (let ((fn (hash-ref tool "function" (make-hash-table))) + (ht (make-hash-table))) + (hash-put! ht "name" (hash-ref fn "name" "")) + (hash-put! ht "description" (hash-ref fn "description" "")) + (hash-put! ht "parameters" (hash-ref fn "parameters" (make-hash-table))) + ht)) + +(def (google-parse-response json) + (let* ((candidates (hash-ref json "candidates" '())) + (candidate (if (null? candidates) #f (car candidates))) + (content (and candidate (hash-get candidate "content"))) + (parts (if content (hash-ref content "parts" '()) '())) + (text-parts (filter (lambda (p) (hash-get p "text")) parts)) + (fn-calls (filter (lambda (p) (hash-get p "functionCall")) parts)) + (text (if (null? text-parts) #f + (hash-ref (car text-parts) "text" "")))) + (if (null? fn-calls) + (make-assistant-message text) + (make-assistant-message text + (map (lambda (p) + (let ((fc (hash-ref p "functionCall" (make-hash-table)))) + (let ((name (hash-ref fc "name" "")) + (args (json-object->string + (hash-ref fc "args" (make-hash-table))))) + ;; Use function name as ID — Gemini has no separate call IDs + (restore-tool-call name name args)))) + fn-calls))))) + + +(def (google-usage->alist provider usage) + "Convert Gemini usageMetadata into jcode's common usage shape. Gemini reports + cachedContentTokenCount for both implicit and explicit cache hits; prompt + token count includes cached tokens, matching OpenAI's accounting model." + (let* ((u (if (and usage (hash-table? usage)) usage (make-hash-table))) + (prompt (json-number-or-zero (hash-get u "promptTokenCount"))) + (cached (json-number-or-zero (hash-get u "cachedContentTokenCount"))) + (candidates (json-number-or-zero (hash-get u "candidatesTokenCount"))) + (thoughts (json-number-or-zero (hash-get u "thoughtsTokenCount"))) + (out (+ candidates thoughts)) + (cost-usage (make-hash-table)) + (details (make-hash-table))) + (hash-put! details "cached_tokens" cached) + (hash-put! cost-usage "prompt_tokens" prompt) + (hash-put! cost-usage "completion_tokens" out) + (hash-put! cost-usage "prompt_tokens_details" details) + (list (cons 'tokens-in prompt) + (cons 'tokens-out out) + (cons 'cache-read cached) + (cons 'cache-creation 0) + (cons 'cost (compute-cost (provider-model provider) cost-usage))))) + +;; 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)))))) new file mode 100644 --- /dev/null +++ b/src/jcode/provider/grok.ss @@ -0,0 +1,232 @@ +;;; jcode provider Grok CLI — OpenAI Responses-API adapter + +(export grok-backend-from + grok-backend + grok-list-models + grok-dispatch-chat + responses-headers + message->responses-input + responses-body + responses-collect-text + responses-collect-tool-calls + responses-parse-response + grok-responses-chat + grok-responses-stream-chat + http-post-json) + +(import :std/text/json + :std/misc/string + :jcode/core/log + :jcode/core/message + :jcode/core/models + :jcode/core/errors + :jcode/core/grok-auth + :jcode/provider/http + :jcode/provider/base + :jcode/provider/openai + :jerboa/core + :jerboa/runtime) + +(def logger (make-logger "provider.grok")) + +;; ---- backend detection ---- + +(def (grok-backend-from info) + ;; Pure: returns "chat_completions" | "responses" | other-string from an + ;; info-alist (as returned by grok-default-model-info / grok-model-info-from). + ;; Defaults to "responses" when the field is missing or not a string. + (or (grok-model-info-ref info "api_backend" "responses") "responses")) + +(def (grok-backend provider) + (grok-backend-from (grok-default-model-info))) + +(def (grok-list-models provider) + ;; Read the user's ~/.grok/models_cache.json directly — the Grok CLI proxy + ;; doesn't expose a public /models listing, but the cache mirrors what + ;; `grok login` discovered. Fall back to the canonical grok-build pair. + (let ((cached (grok-models-cache-models))) + (if (pair? cached) cached '(("grok-build" . "Grok Build"))))) + +(def (grok-dispatch-chat provider messages tools) + (case (string->symbol (grok-backend provider)) + ((chat_completions) (openai-chat provider messages tools)) + (else (grok-responses-chat provider messages tools)))) + +;; ---- Responses API: payload helpers ---- + +(def (responses-headers provider) + (let ((key (or (provider-api-key provider) ""))) + `(("Content-Type" . "application/json") + ("Authorization" . ,(string-append "Bearer " key))))) + +(def (message->responses-input msg) + ;; Responses API expects {role, content} entries. For first pass we send + ;; content as a plain string for all roles, mapping "tool" results to + ;; "user" so the model still sees the text (no tool calling support yet). + (let ((ht (make-hash-table))) + (hash-put! ht "role" + (if (equal? (message-role msg) "tool") "user" (message-role msg))) + (hash-put! ht "content" + (cdr (extract-thinking (or (message-content msg) "")))) + ht)) + +(def (responses-body provider messages tools) + (let ((body (make-hash-table))) + (hash-put! body "model" (provider-model provider)) + (hash-put! body "input" (map message->responses-input messages)) + (when (and tools (not (null? tools))) + (log-info logger "grok-responses-tools-skipped" + `((count . ,(length tools)) + (reason . "tool spec not yet verified vs cli-chat-proxy")))) + body)) + +;; ---- Responses API: response parsing ---- + +(def (responses-collect-text output) + ;; Concatenate every output_text block under message-type output items. + (let ((acc (open-output-string))) + (for-each + (lambda (item) + (when (and (hash-table? item) + (equal? (hash-get item "type") "message")) + (let ((content (hash-get item "content"))) + (when (list? content) + (for-each + (lambda (block) + (when (and (hash-table? block) + (equal? (hash-get block "type") "output_text")) + (let ((t (hash-get block "text"))) + (when (string? t) (put-string acc t))))) + content))))) + output) + (get-output-string acc))) + +(def (responses-collect-tool-calls output) + ;; Pull function_call output items into tool-call records (will be ignored + ;; until Responses tool calling is wired into responses-body). + (let ((acc (box '()))) + (for-each + (lambda (item) + (when (and (hash-table? item) + (equal? (hash-get item "type") "function_call")) + (let ((name (hash-get item "name")) + (args (or (hash-get item "arguments") "{}")) + (id (or (hash-get item "id") ""))) + (when (and name (string? name)) + (set-box! acc (cons (restore-tool-call id name args) + (unbox acc))))))) + output) + (reverse (unbox acc)))) + +(def (responses-parse-response json) + ;; Parse an OpenAI Responses non-streaming envelope into an assistant + ;; message. Accepts the parsed JSON hash directly so tests can drive it. + (let* ((output (or (hash-get json "output") '())) + (text (responses-collect-text output)) + (tcs (responses-collect-tool-calls output))) + (if (null? tcs) + (make-assistant-message text) + (make-assistant-message text tcs)))) + +;; ---- Responses API: non-streaming chat ---- + +(def (grok-responses-chat provider messages tools) + (let* ((url (string-append (provider-base-url provider) "/responses")) + (headers (responses-headers provider)) + (body (responses-body provider messages tools)) + (body-json (json-object->string body))) + (when (tracing?) + (log-trace logger "grok-responses-request" + `((url . ,(redact-url url)) + (headers . ,(redact-headers headers)) + (body . ,body-json)))) + (let-values (((status text) (http-post-json url headers body-json))) + (when (tracing?) + (log-trace logger "grok-responses-response" + `((status . ,status) (body . ,text)))) + (cond + ((= status 200) + (responses-parse-response (string->json-object text))) + ((= status 401) + (error 'grok-responses-chat + "Grok authentication failed (HTTP 401). Run `grok login` to refresh ~/.grok/auth.json.")) + (else + (error 'grok-responses-chat + (format "Grok Responses API error ~a: ~a" status text))))))) + +;; ---- Responses API: streaming chat ---- + +(def (grok-responses-stream-chat provider messages tools token-cb) + ;; Stream via SSE. Returns (values content tool-calls usage-alist stats-alist) + ;; matching openai-stream-chat / anthropic-stream-chat. Responses SSE events + ;; carry their type either in an "event: <type>" line or in the JSON's "type" + ;; field — we prefer JSON and fall back to the line. + (let* ((url (string-append (provider-base-url provider) "/responses")) + (headers (responses-headers provider)) + (body (let ((b (responses-body provider messages tools))) + (hash-put! b "stream" #t) b)) + (body-json (json-object->string body)) + (text-acc (open-output-string)) + (tool-calls-box (box '())) + (usage-acc (make-hash-table)) + (finish-reason-box (box #f)) + (event-type #f)) + (when (tracing?) + (log-trace logger "grok-responses-stream-request" + `((url . ,(redact-url url)) + (headers . ,(redact-headers headers)) + (body . ,body-json)))) + (let ((http-status + (jcode-http-post-stream url headers body-json + (lambda (line) + (when line + (when (tracing?) + (log-trace logger "grok-responses-sse" `((line . ,line)))) + (cond + ((string-prefix? "event: " line) + (set! event-type (substring line 7 (string-length line)))) + ((string-prefix? "data: " line) + (let* ((data-str (substring line 6 (string-length line))) + (json (guard (e [(error? e) #f]) (string->json-object data-str)))) + (when (and json (hash-table? json)) + (let ((etype (or (and (string? (hash-get json "type")) + (hash-get json "type")) + event-type))) + (cond + ((equal? etype "response.output_text.delta") + (let ((delta (hash-get json "delta"))) + (when (and delta (string? delta) (> (string-length delta) 0)) + (put-string text-acc delta) + (token-cb delta)))) + ((equal? etype "response.completed") + (let* ((resp (hash-get json "response")) + (usage (and (hash-table? resp) (hash-get resp "usage"))) + (st (and (hash-table? resp) (hash-get resp "status")))) + (when (and usage (hash-table? usage)) + (hash-for-each (lambda (k v) (hash-put! usage-acc k v)) usage)) + (when (string? st) (set-box! finish-reason-box st)) + (let ((out (and (hash-table? resp) (hash-get resp "output")))) + (when (list? out) + (let ((extra (responses-collect-tool-calls out))) + (when (pair? extra) + (set-box! tool-calls-box + (append (unbox tool-calls-box) extra))))))))))))))))))) + (unless (= http-status 200) + (log-error logger "grok-responses-stream-http-error" + `((status . ,http-status) (url . ,url))))) + (let* ((content (get-output-string text-acc)) + (in-tok (or (hash-get usage-acc "input_tokens") 0)) + (out-tok (or (hash-get usage-acc "output_tokens") 0)) + (cost (compute-cost (provider-model provider) usage-acc)) + (tcs (unbox tool-calls-box))) + (when (tracing?) + (log-trace logger "grok-responses-stream-result" + `((content . ,content) + (tokens-in . ,in-tok) + (tokens-out . ,out-tok) + (tool-calls . ,(length tcs))))) + (values content tcs + (list (cons 'tokens-in in-tok) + (cons 'tokens-out out-tok) + (cons 'cost cost)) + (build-stats (unbox finish-reason-box) '() '()))))) new file mode 100644 --- /dev/null +++ b/src/jcode/provider/http.ss @@ -0,0 +1,969 @@