fix: parse Hermes XML tool calls from local mlx provider; static-link new crypto FFI
ober
8eca66149b208ab4abdc80367d61c74da23fba7c
--- a/build-binary.ss +++ b/build-binary.ss @@ -314,6 +314,7 @@ "std/misc/alist" "std/misc/func" "std/misc/thread" + "std/misc/channel" "std/misc/ports" "std/misc/retry" "std/misc/uuid" @@ -324,6 +325,7 @@ "std/misc/nested" "std/debug/pp" "std/os/platform" + "std/os/errno" "std/os/path" "std/os/shell" "std/os/aproc" @@ -345,7 +347,8 @@ "std/net/http" "std/db/sqlite" "std/crypto/aead" - "std/crypto/compare"))) + "std/crypto/compare" + "std/crypto/native-rust"))) ;; jerbsearch (vendored) — used by jcode/tool/web for in-process metasearch. ;; Compiled .so files live under vendor/jerboa-websearch/src/jerbsearch/. @@ -415,7 +418,17 @@ "jerboa_tls_connect_mtls" "jerboa_tls_close" "jerboa_tls_read" "jerboa_tls_write" "jerboa_tls_flush" "jerboa_tls_get_fd" "jerboa_tls_set_nonblock" - "jerboa_last_error")) + "jerboa_last_error" + ;; jerboa-native (crypto/ring) — used by (std crypto native-rust) via secrets.ss + "jerboa_sha1" "jerboa_sha256" "jerboa_sha384" "jerboa_sha512" + "jerboa_random_bytes" + "jerboa_hmac_sha256" "jerboa_hmac_sha256_verify" + "jerboa_timing_safe_equal" + "jerboa_aead_seal" "jerboa_aead_open" + "jerboa_chacha20_seal" "jerboa_chacha20_open" + "jerboa_scrypt" + "jerboa_pbkdf2_derive" "jerboa_pbkdf2_verify" + "jerboa_argon2id_hash" "jerboa_argon2id_verify")) (call-with-output-file "jcode-main.c" (lambda (out) --- a/src/jcode/core/agent.ss +++ b/src/jcode/core/agent.ss @@ -216,6 +216,191 @@ Be concise. Prefer edit over write for modifying existing files. (and (> (length (hash-keys ht)) 0) (json-object->string ht)))))))) +;;; Hermes / Qwen3-style XML tool call detection ;;; +;;; Some local backends (notably mlx_lm.server with the jerboa-mlx LoRA) do +;;; not parse the model's tool calls server-side. The model then emits the +;;; raw Hermes-style XML inline in the assistant content: +;;; +;;; <tool_call> +;;; <function name="NAME"> +;;; <parameter name="K">V</parameter> +;;; ... +;;; </function> +;;; </tool_call> +;;; +;;; Without local parsing, jcode would: (a) leak the closing tags onto the +;;; user's screen (Q/A turn looks broken), and (b) never execute the call. + +(def *hermes-open* "<tool_call>") +(def *hermes-close* "</tool_call>") + +(def (try-parse-hermes-tool-calls text) + "Extract every <tool_call>...</tool_call> block from TEXT and return them + as tool-call records. Returns '() if none found. Malformed blocks are + skipped silently." + (let ((open-len (string-length *hermes-open*)) + (close-len (string-length *hermes-close*))) + (let loop ((rest text) (acc '())) + (let ((open (string-contains rest *hermes-open*))) + (if (not open) + (reverse acc) + (let* ((after (substring rest (+ open open-len) (string-length rest))) + (close (string-contains after *hermes-close*))) + (if (not close) + (reverse acc) + (let* ((block (substring after 0 close)) + (tail (substring after (+ close close-len) + (string-length after))) + (tc (parse-hermes-block block))) + (loop tail (if tc (cons tc acc) acc)))))))))) + +(def (parse-hermes-block block) + "Parse one <tool_call> body — looks for <function name=\"NAME\"> plus any + number of <parameter name=\"K\">V</parameter> children. Returns a + tool-call or #f." + (let ((fn-name (extract-quoted-attr block "<function name="))) + (and fn-name + (let ((args (make-hash-table))) + (collect-hermes-parameters! block args) + (restore-tool-call + (format "hermes_~a_~a" fn-name (time-second (current-time))) + fn-name + (json-object->string args)))))) + +(def (collect-hermes-parameters! block args) + "Find every <parameter name=\"K\">V</parameter> in BLOCK and store K->V + in ARGS. Trims surrounding whitespace from V (mlx-lm wraps values in + newlines). Tolerates either single or double quoted attribute values." + (let ((p-tag "<parameter name=") + (close-p "</parameter>")) + (let loop ((rest block)) + (let ((p-start (string-contains rest p-tag))) + (when p-start + (let* ((after (substring rest (+ p-start (string-length p-tag)) + (string-length rest))) + (q-char (and (> (string-length after) 0) + (string-ref after 0)))) + (when (and q-char (or (char=? q-char #\") (char=? q-char #\'))) + (let* ((after-q1 (substring after 1 (string-length after))) + (q2 (string-index after-q1 q-char))) + (when q2 + (let* ((key (substring after-q1 0 q2)) + (after-q2 (substring after-q1 (+ q2 1) + (string-length after-q1))) + (gt (string-index after-q2 #\>))) + (when gt + (let* ((val-region (substring after-q2 (+ gt 1) + (string-length after-q2))) + (val-end (string-contains val-region close-p))) + (when val-end + (let* ((val (substring val-region 0 val-end)) + (after-end (substring val-region + (+ val-end (string-length close-p)) + (string-length val-region)))) + (hash-put! args key (string-trim val)) + (loop after-end))))))))))))))) + +(def (extract-quoted-attr block prefix) + "Find PREFIX in BLOCK then return the immediately following quoted value + as a string (handles \" or '). Returns #f if not found." + (let ((pos (string-contains block prefix))) + (and pos + (let* ((after (substring block (+ pos (string-length prefix)) + (string-length block)))) + (and (>= (string-length after) 2) + (let ((q (string-ref after 0))) + (and (or (char=? q #\") (char=? q #\')) + (let* ((tail (substring after 1 (string-length after))) + (end (string-index tail q))) + (and end (substring tail 0 end)))))))))) + +(def (strip-hermes-blocks text) + "Return TEXT with all <tool_call>...</tool_call> blocks removed and any + stray closing tags (</parameter>, </function>, </tool_call>) stripped. + The result is right-trimmed." + (let* ((open-len (string-length *hermes-open*)) + (close-len (string-length *hermes-close*)) + (no-blocks + (let loop ((rest text) (acc '())) + (let ((open (string-contains rest *hermes-open*))) + (if (not open) + (apply string-append (reverse (cons rest acc))) + (let* ((before (substring rest 0 open)) + (after (substring rest (+ open open-len) + (string-length rest))) + (close (string-contains after *hermes-close*))) + (if (not close) + ;; Unclosed — drop everything from <tool_call> onward. + (apply string-append (reverse (cons before acc))) + (let ((tail (substring after (+ close close-len) + (string-length after)))) + (loop tail (cons before acc)))))))))) + (string-trim (strip-orphan-hermes-tags no-blocks)))) + +(def (strip-orphan-hermes-tags text) + (let loop ((s text) + (tags '("</parameter>" "</function>" "</tool_call>" + "<tool_call>"))) + (if (null? tags) + s + (loop (string-replace-all s (car tags) "") (cdr tags))))) + +(def (string-replace-all s pat repl) + (let loop ((rest s) (acc '())) + (let ((idx (string-contains rest pat))) + (if (not idx) + (apply string-append (reverse (cons rest acc))) + (loop (substring rest (+ idx (string-length pat)) + (string-length rest)) + (cons repl (cons (substring rest 0 idx) acc))))))) + +;; Streaming filter: wrap an inner token-cb so that any text inside a +;; <tool_call>...</tool_call> block is suppressed. Tags split across token +;; boundaries are buffered until we can disambiguate. The full token text +;; is still accumulated by the provider into the response content, so the +;; agent can post-process for tool calls; only the *display* is filtered. +(def (make-tool-call-stream-filter inner-cb) + (let ((in-block? #f) + (pending "")) + (lambda (token) + (set! pending (string-append pending token)) + (let process () + (cond + (in-block? + (let ((idx (string-contains pending *hermes-close*))) + (cond + (idx + (set! pending + (substring pending (+ idx (string-length *hermes-close*)) + (string-length pending))) + (set! in-block? #f) + (process)) + (else + ;; Keep last close-len-1 chars (might be a partial close). + (let* ((slen (string-length pending)) + (keep (min (- (string-length *hermes-close*) 1) slen))) + (set! pending (substring pending (- slen keep) slen))))))) + (else + (let ((idx (string-contains pending *hermes-open*))) + (cond + (idx + (let ((before (substring pending 0 idx))) + (when (> (string-length before) 0) + (inner-cb before))) + (set! pending + (substring pending (+ idx (string-length *hermes-open*)) + (string-length pending))) + (set! in-block? #t) + (process)) + (else + ;; Forward all but the last open-len-1 chars (partial open?). + (let* ((slen (string-length pending)) + (keep (min (- (string-length *hermes-open*) 1) slen)) + (fwd (- slen keep))) + (when (> fwd 0) + (inner-cb (substring pending 0 fwd)) + (set! pending (substring pending fwd slen))))))))))))) + (def (agent-run session-id user-input) (log-info logger "agent-run" `((session . ,session-id))) (let ((existing (session-get-messages session-id))) @@ -238,9 +423,20 @@ Be concise. Prefer edit over write for modifying existing files. (text-tcs (if (and (not real-tcs) (not (string=? content ""))) (try-parse-text-tool-calls content) '())) - (effective (if (null? text-tcs) - response - (make-assistant-message #f text-tcs))) + (hermes-tcs (if (and (not real-tcs) (null? text-tcs) + (not (string=? content ""))) + (try-parse-hermes-tool-calls content) + '())) + (effective + (cond + ((not (null? text-tcs)) + (make-assistant-message #f text-tcs)) + ((not (null? hermes-tcs)) + (let ((clean (strip-hermes-blocks content))) + (make-assistant-message + (if (string=? clean "") #f clean) + hermes-tcs))) + (else response))) (tcs (or (message-tool-calls effective) '()))) (session-add-message session-id effective) (cond @@ -264,19 +460,34 @@ Be concise. Prefer edit over write for modifying existing files. ;; Streaming version: calls (current-stream-cb) for each text token. (let* ((provider (get-current-provider)) (tools (get-tool-schemas)) - (msgs (refresh-system-prompt messages))) + (msgs (refresh-system-prompt messages)) + (raw-cb (current-stream-cb)) + (cb (and raw-cb (make-tool-call-stream-filter raw-cb)))) (let-values (((content tool-calls usage) - (stream-chat-with-expert provider msgs tools (current-stream-cb)))) + (stream-chat-with-expert provider msgs tools cb))) (when (and usage (current-usage-cb)) ((current-usage-cb) usage)) ;; Detect text-format tool calls (some models output tool calls as text) (let* ((text-tcs (if (and (null? tool-calls) (not (string=? content ""))) (try-parse-text-tool-calls content) '())) - (effective-tcs (if (null? tool-calls) text-tcs tool-calls)) - (effective-content (if (and (null? tool-calls) (not (null? text-tcs))) - #f - (if (string=? content "") #f content))) + (hermes-tcs (if (and (null? tool-calls) (null? text-tcs) + (not (string=? content ""))) + (try-parse-hermes-tool-calls content) + '())) + (effective-tcs + (cond + ((not (null? tool-calls)) tool-calls) + ((not (null? text-tcs)) text-tcs) + ((not (null? hermes-tcs)) hermes-tcs) + (else '()))) + (effective-content + (cond + ((not (null? text-tcs)) #f) + ((not (null? hermes-tcs)) + (let ((clean (strip-hermes-blocks content))) + (if (string=? clean "") #f clean))) + (else (if (string=? content "") #f content)))) (response (make-assistant-message effective-content (if (null? effective-tcs) #f effective-tcs)))) @@ -290,7 +501,8 @@ Be concise. Prefer edit over write for modifying existing files. (let-values (((fc _tc _u) (stream-chat-with-expert provider (refresh-system-prompt (session-get-messages session-id)) - '() (current-stream-cb)))) + '() + (and raw-cb (make-tool-call-stream-filter raw-cb))))) (let ((final (make-assistant-message (if (string=? fc "") #f fc) #f))) (session-add-message session-id final) @@ -393,27 +605,36 @@ Be concise. Prefer edit over write for modifying existing files. (agent-chat-loop provider new-messages tools (+ round 1))))))) (def (agent-chat-loop-stream provider messages tools round) - (let* ((msgs messages)) + (let* ((msgs messages) + (raw-cb (current-stream-cb)) + (cb (and raw-cb (make-tool-call-stream-filter raw-cb)))) (let-values (((content tool-calls usage) - (stream-chat-with-expert provider msgs tools (current-stream-cb)))) - (cond - ((null? tool-calls) content) - ((>= round *max-tool-rounds*) - (let* ((response (make-assistant-message - (if (string=? content "") #f content) - tool-calls)) - (results (execute-tool-calls tool-calls)) - (new-msgs (append msgs (list response) results))) - (let-values (((fc _tc _u) - (stream-chat-with-expert provider new-msgs '() (current-stream-cb)))) - fc))) - (else - (let* ((response (make-assistant-message - (if (string=? content "") #f content) - tool-calls)) - (results (execute-tool-calls tool-calls)) - (new-msgs (append msgs (list response) results))) - (agent-chat-loop-stream provider new-msgs tools (+ round 1)))))))) + (stream-chat-with-expert provider msgs tools cb))) + (let* ((hermes-tcs (if (and (null? tool-calls) (not (string=? content ""))) + (try-parse-hermes-tool-calls content) + '())) + (effective-tcs (if (null? tool-calls) hermes-tcs tool-calls)) + (effective-content + (cond + ((not (null? hermes-tcs)) + (let ((clean (strip-hermes-blocks content))) + (if (string=? clean "") #f clean))) + (else (if (string=? content "") #f content))))) + (cond + ((null? effective-tcs) (or effective-content "")) + ((>= round *max-tool-rounds*) + (let* ((response (make-assistant-message effective-content effective-tcs)) + (results (execute-tool-calls effective-tcs)) + (new-msgs (append msgs (list response) results))) + (let-values (((fc _tc _u) + (stream-chat-with-expert provider new-msgs '() + (and raw-cb (make-tool-call-stream-filter raw-cb))))) + fc))) + (else + (let* ((response (make-assistant-message effective-content effective-tcs)) + (results (execute-tool-calls effective-tcs)) + (new-msgs (append msgs (list response) results))) + (agent-chat-loop-stream provider new-msgs tools (+ round 1))))))))) (def (agent-step messages) (let* ((provider (get-current-provider))