Compare commits

6 Commits

Author SHA1 Message Date
d884ca4179 simplify comments
CI / Test + coverage (push) Successful in 1m1s
2026-09-23 03:21:23 -09:00
2637b69c2c proomptin'
CI / Test + coverage (push) Successful in 58s
2026-09-22 11:49:16 -09:00
a6f49938dc fiddle
CI / Test + coverage (push) Successful in 1m20s
2026-09-22 10:52:29 -09:00
2d606d0620 get agent to use current state
CI / Test + coverage (push) Successful in 57s
2026-09-22 06:24:04 -09:00
a7f12b5d72 migrate to AG-UI state sync
CI / Test + coverage (push) Successful in 1m4s
2026-09-22 06:07:45 -09:00
6569a69463 Merge pull request 'framework-ify. proper agent runtime + adopt ag-ui' (#1) from ag-ui into main
CI / Test + coverage (push) Successful in 59s
Reviewed-on: #1
2026-09-21 18:57:04 -09:00
32 changed files with 2003 additions and 655 deletions
+36 -42
View File
@@ -6,15 +6,14 @@
`:source-paths`) because those are genuinely needed client-side. `:source-paths`) because those are genuinely needed client-side.
The page's own chatbot's system prompt is a separate, server-only concern: it lives in The page's own chatbot's system prompt is a separate, server-only concern: it lives in
tbd.agent.instructions (`src/`, never on the UI's classpath), which reuses `act`, tbd.agent.instructions (`src/`, never on the UI's classpath), which reuses `act`, `work-it-out`
`work-it-out`, `tic-tac-toe-rules` and `examples` from here rather than duplicating them, so the and `examples` from here rather than duplicating them, so the wording stays shared without the
wording stays shared without the chatbot's own instructions being bundled into the browser. chatbot's own instructions being bundled into the browser.
It is about acting. A model that is only asked to be helpful answers a request for action with It is about acting. A model that is only asked to be helpful answers a request for action with
an offer of help, so the text says: call the tool in the same turn, chain the calls, say little an offer of help, so the text says: call the tool in the same turn, chain the calls, say little
afterwards, and the few cases where not to. It is short and concrete on purpose, with examples: afterwards, and the few cases where not to. It is short and concrete on purpose, with examples:
the models behind LM Studio follow that better than a long list of rules." the models behind LM Studio follow that better than a long list of rules.")
(:require [clojure.string :as str]))
(def act (def act
"Shared with tbd.agent.instructions/chat, the in-page chatbot's own system prompt." "Shared with tbd.agent.instructions/chat, the in-page chatbot's own system prompt."
@@ -34,29 +33,29 @@
" and cannot tell what.\n" " and cannot tell what.\n"
chain chain
"- The page changes between messages: the user clicks and types too. A tool result is only what the\n" "- The page changes between messages: the user clicks and types too. A tool result is only what the\n"
" page held when it ran, and results from an earlier message are marked out of date. Before you\n" " page held when it ran, so an earlier one may no longer hold. Before you answer from the page or\n"
" answer from the page or act on it (a board, a list, an id), read it again with a tool. When the\n" " act on it (a board, a list, an id), get what it holds now — current state if you have it, else\n"
" user says it changed or that you are wrong, read it again first: never go by an earlier result\n" " read it again with a tool. When the user says it changed or that you are wrong, check again\n"
" or by what you said before.\n" " first: never go by an earlier result or by what you said before.\n"
"- A call fails: read the error, fix the arguments or read the state, and try once more. No\n" "- A call fails: the result still comes back to you, with what went wrong. Read it, fix the\n"
" apologies, no explanation of what went wrong unless it still fails.\n" " arguments or read the state, and try once more. No apologies, no explanation of what went\n"
" wrong unless it still fails.\n"
"\n")) "\n"))
(def tic-tac-toe-rules (defn examples
"Shared with tbd.agent.instructions/chat." "Shared with tbd.agent.instructions/chat. `reads?` is whether looking something up (a todo's id,
(str "Tic-tac-toe: check whose turn it is, move only for your own side, one move, then stop and let the\n" the board) takes its own call first (an outside agent's list_todos/get_tic_tac_toe) or is
"person play theirs.\n" already in view (the chatbot's state, tbd.chat.schema/RunAgentInput's `state`) — the one place
"\n")) the two agents' examples differ."
[reads?]
(def examples
"Shared with tbd.agent.instructions/chat."
(str "Examples:\n" (str "Examples:\n"
"\"add a todo to buy milk\" -> create_todo{\"todos\":[{\"title\":\"buy milk\"}]} -> \"Added.\"\n" "\"add a todo to buy milk\" -> create_todo{\"todos\":[{\"title\":\"buy milk\"}]} -> \"Added.\"\n"
"\"tick off the milk one\" -> list_todos -> set_todo_done{\"todos\":[{\"id\":\"3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b\",\"done\":true}]} -> \"Ticked off.\"\n" "\"tick off the milk one\" -> " (when reads? "list_todos -> ")
"\"untick all my todos\" -> list_todos -> ONE set_todo_done with every todo in \"todos\" -> \"Unticked them all.\"\n" "set_todo_done{\"todos\":[{\"id\":\"3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b\",\"done\":true}]} -> \"Ticked off.\"\n"
"\"untick all my todos\" -> " (when reads? "list_todos -> ") "ONE set_todo_done with every todo in \"todos\" -> "
"\"Unticked them all.\"\n"
"\"add milk and eggs\" -> ONE create_todo with both titles in \"todos\" -> \"Added both.\"\n" "\"add milk and eggs\" -> ONE create_todo with both titles in \"todos\" -> \"Added both.\"\n"
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\"\n" "\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\""))
"\"play tic tac toe, you're O\" -> get_tic_tac_toe -> it is X's turn -> \"You're up, X starts.\""))
;; --- An MCP client outside the page (Claude, Codex) --- ;; --- An MCP client outside the page (Claude, Codex) ---
@@ -72,9 +71,9 @@
"they are watching, and what you do is done in front of them.\n" "they are watching, and what you do is done in front of them.\n"
"\n" "\n"
"The app has several pages, which the `navigate` tool lists. Every tool is on offer whichever page\n" "The app has several pages, which the `navigate` tool lists. Every tool is on offer whichever page\n"
"is open, and a tool that changes something opens the page it acts on first; `navigate` is for when\n" "is open, and a tool that changes something opens the page it acts on first, so you rarely need to\n"
"the user only wants to look at a page. The `webmcp://app/state` resource says which page is open\n" "navigate yourself. It only moves you there: it does not read what a page holds, so use it when\n"
"and whether anyone is logged in.\n" "the user wants to look at a page, not to check or refresh one.\n"
"\n" "\n"
act act
(work-it-out (str "- Chain calls without stopping. You need an id: list first, then act. Never invent an id, a\n" (work-it-out (str "- Chain calls without stopping. You need an id: list first, then act. Never invent an id, a\n"
@@ -84,8 +83,7 @@
"was done only if a tool result says it was. Not being logged in is the user's to fix, on the page:\n" "was done only if a tool result says it was. Not being logged in is the user's to fix, on the page:\n"
"tell them so.\n" "tell them so.\n"
"\n" "\n"
tic-tac-toe-rules (examples true)))
examples))
(defn task (defn task
"The prompt that hands an outside agent a job on the page: `guide`, then the user's `request` if "The prompt that hands an outside agent a job on the page: `guide`, then the user's `request` if
@@ -97,17 +95,13 @@
(str "The user's request: " request) (str "The user's request: " request)
"Ask the user what they want done in the app, in a sentence, and do that."))) "Ask the user what they want done in the app, in a sentence, and do that.")))
(defn tic-tac-toe (def tic-tac-toe
"The prompt of a game of tic-tac-toe with the person at the page, for an outside agent playing "The prompt of a game of tic-tac-toe with the person at the page, for an outside agent. Names
`side`: \"x\" or \"o\" (anything else is \"o\": X goes first, so the person, who has the board in only the tools: get_tic_tac_toe, move_tic_tac_toe and their descriptions carry the rest — whose
front of them, starts)." turn it is, which side is whose, what a move is refused for — so the agent drives from those and
[side] the game's state, and works out which side it plays from how the conversation started, rather
(let [side (if (contains? #{"x" "o"} side) side "o")] than the prompt assigning one. Starting over is the person's: their page has its own New game
(str "You are playing tic-tac-toe on the app's page against the person who has it open, as " button, no tool for it."
(str/upper-case side) ". The tools are get_tic_tac_toe, move_tic_tac_toe and new_tic_tac_toe_game.\n" (str "You are playing tic-tac-toe with the person on the app's page. The tools are get_tic_tac_toe "
"\n" "and move_tic_tac_toe. Starting a new game is the person's to do, on the page: there is no "
"Read the game with get_tic_tac_toe. If it is your side's turn, make one move with\n" "tool for it."))
"move_tic_tac_toe and stop: never move for the other side, that is the person's, made on the\n"
"page. If it is not your side's turn, say so in a few words and wait for the person to tell\n"
"you they have moved; don't poll. Then read the game again and go on. When it is over, say\n"
"who won, or that it is a draw, and don't start another game unless asked.")))
+10 -14
View File
@@ -1,21 +1,17 @@
(ns tbd.agent.a2a (ns tbd.agent.a2a
"The A2A (Agent2Agent, https://a2a-protocol.org) server, mounted at `/a2a`, with its discovery "The A2A (Agent2Agent, https://a2a-protocol.org) server, mounted at `/a2a`, with its discovery
document at `/.well-known/agent-card.json`. Unlike /api/chat (the in-page chatbot, driven by the document at `/.well-known/agent-card.json`. Unlike /api/chat (driven by the browser's own tools),
browser's own tools) an A2A caller has no page open, so this agent's tools are the app's an A2A caller has no page open, so this agent's tools are the app's server-side ones — the same
server-side ones — the same operations tbd.mcp.tools exposes to MCP clients, defined again here operations tbd.mcp.tools exposes to MCP, defined again here directly over
directly over tbd.todo.service/tbd.math.core (not through plumcp's tool-item wrapper, which tbd.todo.service/tbd.math.core so this ns has no plumcp dependency.
tbd.mcp.tools builds for a different transport) so this ns has no plumcp dependency.
A2A calls are synchronous (`message/send` only: no `message/stream`, and the AgentCard says so A2A calls are synchronous (`message/send` only; the AgentCard's `capabilities.streaming` is
truthfully in `capabilities.streaming`) — /api/chat and the AG-UI protocol are where this app's false). With no browser to run a tool and report back, this ns runs the tool loop itself: ask
streaming surface is. Since there is no browser to run a tool and report back, this ns runs the the agent, run any tools it asks for, ask again, until it answers in text or `max-turns` is hit.
tool loop itself: ask the agent, and if it asks for tools, run them immediately and ask again,
until it answers in text or `max-turns` is reached.
Protected the same way /mcp is (tbd.oauth.middleware/wrap-bearer-auth): any access token this Protected the same way /mcp is (tbd.oauth.middleware/wrap-bearer-auth): a client authorized for
server issued works here too, since verifying one doesn't check which `resource` it was minted MCP can use A2A with the same token, since verifying one doesn't check which `resource` it was
for (see tbd.oauth.middleware) — a client that has authorized for MCP can use A2A with the same minted for."
token."
(:require [clojure.string :as str] (:require [clojure.string :as str]
[malli.json-schema :as json-schema] [malli.json-schema :as json-schema]
[muuntaja.core :as m] [muuntaja.core :as m]
+110 -69
View File
@@ -3,24 +3,21 @@
Studio server named by the environment. No Ring here; tbd.chat.routes owns that, tbd.agent.a2a Studio server named by the environment. No Ring here; tbd.chat.routes owns that, tbd.agent.a2a
drives the same model for the A2A server. drives the same model for the A2A server.
`start` sends the request and gives {:ok pump} or {:error text :kind :unavailable|:upstream}, `start` sends the request and gives {:ok pump} or {:error text :kind :unavailable|:upstream}.
like tbd.todo.service's. `pump` forwards the reply, as it is generated, to a function that takes `pump` forwards the reply, as it's generated, to a function of events: {:thinking \"text\"},
events: {:thinking \"text\"} (a piece of the model's reasoning), {:content \"text\"} (a piece of {:content \"text\"}, {:tool-calls [{:id :name :arguments}]} (arguments is the JSON text the
the reply), {:tool-calls [{:id :name :arguments}]} (the model wants these tools run, once its model wrote), and finally {:done true} or {:error \"text\"}. This event shape is internal —
reply is complete: `arguments` is the JSON text the model wrote), and finally {:done true} or tbd.chat.routes and tbd.agent.a2a each translate it to their own wire protocol — and is what
{:error \"text\"}. This event shape is internal (tbd.chat.routes and tbd.agent.a2a each translate tbd.chat.trace watches.
it to their own wire protocol — AG-UI events, A2A artifacts) and is what tbd.chat.trace watches.
The system prompt is the agent's own (tbd.agent.instructions), not something the caller supplies: `start` takes `system-text` already composed by the caller (tbd.agent.instructions) and sends it
`start` takes `system-text` already composed (tbd.agent.instructions/chat-system-message for the as the first message. `tools` are MCP-style {:name :description :inputSchema}, converted to
in-page chatbot, tbd.agent.instructions/a2a for the A2A server), and always sends it as the first LangChain4j's typed tool specifications (tbd.agent.json-schema); running them and reporting the
message. `tools` are MCP-style {:name :description :inputSchema}, converted to LangChain4j's result back is the caller's job.
typed tool specifications (tbd.agent.json-schema) — the model only sees their metadata; running
them and reporting the result back (as a \"tool\" role message, see tbd.chat.schema/Message) is
the caller's job.
Every turn is traced (see tbd.chat.trace): what was asked, how the reply went, and whether the Every turn is traced (tbd.chat.trace: what was asked, how the reply went, whether the model
model looks stuck in a loop. The config's `:trace` says where that goes." looks stuck in a loop). A turn that loops isn't left running or simply failed: `pump` cancels it
and retries once, nudged to answer, erroring only if the retry loops too."
(:require [clojure.string :as str] (:require [clojure.string :as str]
[tbd.agent.json-schema :as json-schema] [tbd.agent.json-schema :as json-schema]
[tbd.chat.trace :as trace]) [tbd.chat.trace :as trace])
@@ -44,19 +41,16 @@
(let [v (get env k)] (let [v (get env k)]
(when-not (str/blank? v) (str/trim v)))) (when-not (str/blank? v) (str/trim v))))
;; HTTP/1.1 on purpose, same reason as the old tbd.chat.core: the JDK client's default is to ask a ;; HTTP/1.1 on purpose: the JDK client's default asks a plain-http server to upgrade to HTTP/2
;; plain-http server to upgrade to HTTP/2 (`Upgrade: h2c`), and LM Studio's server never answers ;; (`Upgrade: h2c`), and LM Studio never answers that, so requests would hang for the full timeout.
;; that request, so the backend would wait out the whole timeout while the LLM sat idle.
(defn- jdk-http-client-builder [] (defn- jdk-http-client-builder []
(-> (JdkHttpClientBuilder.) (-> (JdkHttpClientBuilder.)
(.httpClientBuilder (-> (HttpClient/newBuilder) (.version HttpClient$Version/HTTP_1_1))))) (.httpClientBuilder (-> (HttpClient/newBuilder) (.version HttpClient$Version/HTTP_1_1)))))
(defn- api-base-url (defn- api-base-url
"`url` (the server's address, no path, see env-config) with the `/v1` LM Studio's OpenAI-compatible "`url` (see env-config) with `/v1` appended if missing: LangChain4j posts straight to
endpoints live under: LangChain4j's OpenAI client posts straight to `<baseUrl>/chat/completions`, `<baseUrl>/chat/completions` without adding it, and LM Studio without it answers 200 with a JSON
it does not add this itself (its own default base url is `https://api.openai.com/v1`). Without error body that reads as an empty reply."
it, LM Studio answers 200 with a JSON error body langchain4j can't tell from an empty reply, so
every turn silently becomes \"the LLM server sent no reply\" instead of a clear error."
[url] [url]
(if (str/ends-with? url "/v1") url (str url "/v1"))) (if (str/ends-with? url "/v1") url (str url "/v1")))
@@ -152,11 +146,22 @@
(println (cond-> (str "[tbd] chat: " text) detail (str " (" detail ")"))) (println (cond-> (str "[tbd] chat: " text) detail (str " (" detail ")")))
text)) text))
(defn- loop-abort-text
"What the user is told when a retried turn (see `pump`) still loops."
[{:keys [kind]}]
(case kind
:repeated-thinking "the model got stuck repeating itself, and the reply was stopped"
:long-reasoning "the model's reasoning went on without end, and the reply was stopped"))
(def ^:private loop-nudge
"Appended to the system prompt for pump's one retry of a looping turn."
"\n\nYou have been reasoning for a long time without answering. Stop reasoning now: give your final answer immediately, or call the tool you need.")
(defn- streaming-handler (defn- streaming-handler
"A StreamingChatResponseHandler that pushes every callback onto `queue` as a map: {:content s}, "A StreamingChatResponseHandler that pushes every callback onto `queue` as a map: {:content s},
{:thinking s}, {:tool-call {:id :name :arguments}} (once a call is fully assembled — LangChain4j {:thinking s}, {:tool-call {:id :name :arguments}} (once a call is fully assembled), {:complete
does the delta accumulation itself), {:complete response} or {:error throwable}. `handle!` is response} or {:error throwable}. `handle!` is called with the first StreamingHandle seen, so the
called with the first StreamingHandle seen, so the caller can cancel a stuck stream." caller can cancel a stuck stream."
^StreamingChatResponseHandler [^LinkedBlockingQueue queue handle!] ^StreamingChatResponseHandler [^LinkedBlockingQueue queue handle!]
(let [capture! (fn [^StreamingHandle h] (when h (handle! h)))] (let [capture! (fn [^StreamingHandle h] (when h (handle! h)))]
;; No type hints on the reify methods' params below: hinting an overloaded interface method's ;; No type hints on the reify methods' params below: hinting an overloaded interface method's
@@ -195,14 +200,37 @@
(defn- finish-reason-of [^ChatResponse response] (defn- finish-reason-of [^ChatResponse response]
(some-> (.finishReason response) str str/lower-case)) (some-> (.finishReason response) str str/lower-case))
(defn- send-request!
"Sends `system-text`/`messages`/`tools`, and waits (up to `timeout-seconds`) for the first sign
of life: {:ok {:queue :handle-atom :first-item}}, or {:error text :detail text} for an LLM that
is down, refuses, or stays silent too long. Used for the turn's first attempt (`start`) and for
the retry `pump` sends after a turn that loops."
[config system-text messages tools timeout-seconds]
(try
(let [queue (LinkedBlockingQueue.)
handle-atom (atom nil)
handler (streaming-handler queue #(reset! handle-atom %))]
(.chat (chat-model config) (chat-request system-text messages tools) handler)
(if-let [first-item (.poll queue (long timeout-seconds) TimeUnit/SECONDS)]
(if (:error first-item)
{:error "the LLM server can't be reached or refused" :detail (exception-detail (:error first-item))}
{:ok {:queue queue :handle-atom handle-atom :first-item first-item}})
{:error "the LLM server took too long to answer" :detail (str timeout-seconds "s of silence")}))
(catch Exception e
{:error "the LLM server can't be reached" :detail (exception-detail e)})))
(defn- pump (defn- pump
"Drains `queue`, starting from the already-polled `first-item` (see `start`, which peeks one item "Drains `queue`, starting from the already-polled `first-item` (see send-request!), calling
before deciding {:ok}/{:error}), calling `emit` with each event (see the ns docstring). `emit` with each event (see the ns docstring). `timeout-seconds` of silence between items is an
`timeout-seconds` of silence between items is an error, closing the stream via `handle-atom` (a error, closing the stream via `handle-atom`.
StreamingHandle, once one has arrived). An exception from `emit` (the client went away, say) ends
it too, closing the stream, and is rethrown. `tracer` (see tbd.chat.trace) sees everything the A looping model is never silent, so that timeout can't catch it; `tracer` (tbd.chat.trace/observe!)
LLM says, and how the turn ended, before the client is told." watches for that instead. The first time a turn loops, the stream is cancelled and resent with
[^LinkedBlockingQueue queue handle-atom timeout-seconds emit tracer first-item] `loop-nudge` appended to `system-text`, as a fresh attempt (the caller only sees a pause); looping
again on the retry, or failing to start it, is an error. An exception from `emit` ends the attempt
too, closing the stream, and is rethrown."
[config system-text messages tools timeout-seconds emit tracer
^LinkedBlockingQueue queue handle-atom first-item retried?]
(let [timer (atom nil) (let [timer (atom nil)
timed-out? (atom false) timed-out? (atom false)
cancel-stream! (fn [] cancel-stream! (fn []
@@ -212,7 +240,20 @@
(some-> ^ScheduledFuture @timer (.cancel false)) (some-> ^ScheduledFuture @timer (.cancel false))
(reset! timer (.schedule ^ScheduledThreadPoolExecutor @watchdog (reset! timer (.schedule ^ScheduledThreadPoolExecutor @watchdog
^Runnable (fn [] (reset! timed-out? true) (cancel-stream!)) ^Runnable (fn [] (reset! timed-out? true) (cancel-stream!))
(long timeout-seconds) TimeUnit/SECONDS)))] (long timeout-seconds) TimeUnit/SECONDS)))
retry! (fn []
(cancel-stream!)
(some-> ^ScheduledFuture @timer (.cancel false))
(let [nudged-text (str system-text loop-nudge)
tracer' (trace/begin! (:trace config) {:messages messages :tools tools :model (:model config)
:system-text nudged-text})
{:keys [ok error detail]} (send-request! config nudged-text messages tools timeout-seconds)]
(if error
(let [text (fail error detail)]
(trace/finish! tracer' {:outcome :upstream-error :error text :detail detail})
(emit {:error text}))
(pump config nudged-text messages tools timeout-seconds emit tracer'
(:queue ok) (:handle-atom ok) (:first-item ok) true))))]
(arm!) (arm!)
(try (try
(loop [item first-item (loop [item first-item
@@ -254,46 +295,46 @@
(emit {:error text})))) (emit {:error text}))))
:else :else
(do (arm!) (let [abort (trace/observe! tracer (select-keys item [:content :thinking]))]
(trace/observe! tracer (select-keys item [:content :thinking])) (when-let [out (not-empty (select-keys item [:content :thinking]))] (emit out))
(when-let [out (not-empty (select-keys item [:content :thinking]))] (emit out)) (cond
(recur (.take queue) (and abort (not retried?))
(or replied? (contains? item :content)) (do (trace/finish! tracer {:outcome :looped}) (retry!))
(cond-> calls (:tool-call item) (conj (:tool-call item)))))))
abort
(let [text (fail (loop-abort-text abort))]
(trace/finish! tracer {:outcome :error :error text})
(cancel-stream!)
(emit {:error text}))
:else
(do (arm!)
(recur (.take queue)
(or replied? (contains? item :content))
(cond-> calls (:tool-call item) (conj (:tool-call item)))))))))
(finally (finally
(trace/finish! tracer {:outcome :aborted}) (trace/finish! tracer {:outcome :aborted})
(some-> ^ScheduledFuture @timer (.cancel false)) (some-> ^ScheduledFuture @timer (.cancel false))
(cancel-stream!))))) (cancel-stream!)))))
(defn start (defn start
"Sends the LLM the conversation `messages` (see tbd.chat.schema/Message), and the `tools` it may "Sends the LLM `messages` (tbd.chat.schema/Message) and the `tools` it may ask to be run (MCP's
ask the caller to run (MCP's {:name :description :inputSchema}; none if nil), after `system-text` {:name :description :inputSchema}; none if nil), after `system-text` (composed by the caller,
(the agent's own system prompt, see tbd.agent.instructions — composed by the caller, not the see tbd.agent.instructions). Waits for the first sign of life so an LLM that is down or refuses
browser). Waits for the first sign of life from the model (a piece of its reply, or an error) so comes back as a clean {:error text :kind :unavailable|:upstream} rather than an error mid-stream.
that an LLM that is down or refuses is still a clean {:error text :kind :unavailable|:upstream}, Otherwise {:ok pump}: `(pump emit)` blocks until the reply is complete (retrying once on its own
not an error inside a stream that has already begun — the same contract the old hand-rolled HTTP if the model loops, see `pump`), calling `emit` with its events. If `emit` throws, the request to
client gave, adapted to LangChain4j's async callbacks (which have no separate \"got the HTTP the LLM is closed and the exception is rethrown."
response\" moment to block on the way a blocking HTTP client's `.send()` did). Otherwise {:ok
pump}: `(pump emit)` blocks until the reply is complete, calling `emit` with its events (see the
ns docstring). If `emit` throws, the request to the LLM is closed (which stops it generating) and
the exception is rethrown."
[{:keys [timeout-seconds trace] :as config} system-text messages tools] [{:keys [timeout-seconds trace] :as config} system-text messages tools]
(if-not (configured? config) (if-not (configured? config)
{:error "chat is not configured" :kind :unavailable} {:error "chat is not configured" :kind :unavailable}
(let [tracer (trace/begin! trace {:messages messages :tools tools :model (:model config)}) (let [tracer (trace/begin! trace {:messages messages :tools tools :model (:model config)
upstream-error (fn [text detail] :system-text system-text})
(fail text detail) {:keys [ok error detail]} (send-request! config system-text messages tools timeout-seconds)]
(trace/finish! tracer {:outcome :upstream-error :error text :detail detail}) (if error
{:error text :kind :upstream})] (do (fail error detail)
(try (trace/finish! tracer {:outcome :upstream-error :error error :detail detail})
(let [queue (LinkedBlockingQueue.) {:error error :kind :upstream})
handle-atom (atom nil) {:ok (fn [emit]
handler (streaming-handler queue #(reset! handle-atom %))] (pump config system-text messages tools timeout-seconds emit tracer
(.chat (chat-model config) (chat-request system-text messages tools) handler) (:queue ok) (:handle-atom ok) (:first-item ok) false))}))))
(if-let [first-item (.poll queue (long timeout-seconds) TimeUnit/SECONDS)]
(if (:error first-item)
(upstream-error "the LLM server can't be reached or refused" (exception-detail (:error first-item)))
{:ok (fn [emit] (pump queue handle-atom timeout-seconds emit tracer first-item))})
(upstream-error "the LLM server took too long to answer" (str timeout-seconds "s of silence"))))
(catch Exception e
(upstream-error "the LLM server can't be reached" (exception-detail e)))))))
+18 -14
View File
@@ -4,9 +4,10 @@
on purpose: unlike tbd.agent.prompt (a .cljc the browser bundle also needs, for WebMCP's on purpose: unlike tbd.agent.prompt (a .cljc the browser bundle also needs, for WebMCP's
`guide`/`task`/`tic-tac-toe`), this ns is never on ui/shadow-cljs.edn's `:source-paths`, so the `guide`/`task`/`tic-tac-toe`), this ns is never on ui/shadow-cljs.edn's `:source-paths`, so the
chatbot's own instructions can never end up in the compiled UI. It reuses the wording that is chatbot's own instructions can never end up in the compiled UI. It reuses the wording that is
genuinely shared (`act`, `work-it-out`, `tic-tac-toe-rules`, `examples`) from tbd.agent.prompt genuinely shared (`act`, `work-it-out`, `examples`) from tbd.agent.prompt rather than
rather than duplicating it." duplicating it."
(:require [clojure.string :as str] (:require [clojure.string :as str]
[jsonista.core :as json]
[tbd.agent.prompt :as prompt])) [tbd.agent.prompt :as prompt]))
(defn chat (defn chat
@@ -19,8 +20,8 @@
"\n" "\n"
prompt/act prompt/act
(prompt/work-it-out (str "- Chain calls without stopping. The tool you need belongs to another page: navigate there, then\n" (prompt/work-it-out (str "- Chain calls without stopping. The tool you need belongs to another page: navigate there, then\n"
" use it. You need an id: list first, then act. Never invent an id, a title or the state of the\n" " use it. Never invent an id, a title or the state of the page: it's in \"Current state of the\n"
" page: read it with a tool.\n")) " page\" below, if there is one, or read it with a tool.\n"))
"Then say one short plain sentence: \"Added it.\" \"That's 23.\" The call and its result are already\n" "Then say one short plain sentence: \"Added it.\" \"That's 23.\" The call and its result are already\n"
"on screen under your message, so never repeat them, never paste JSON, never use markdown,\n" "on screen under your message, so never repeat them, never paste JSON, never use markdown,\n"
"headings or bullet lists. Say something was done only if a tool result says it was.\n" "headings or bullet lists. Say something was done only if a tool result says it was.\n"
@@ -29,21 +30,24 @@
"Answer those in a sentence or two, with no tool call. Asked what you can do, say it plainly from\n" "Answer those in a sentence or two, with no tool call. Asked what you can do, say it plainly from\n"
"the tools you have. Think briefly before you act.\n" "the tools you have. Think briefly before you act.\n"
"\n" "\n"
prompt/tic-tac-toe-rules (prompt/examples false)))
prompt/examples))
(defn chat-system-message (defn chat-system-message
"`chat`'s prompt, with, last, where the user is (`page`) and the names of the `tools` on offer "`chat`'s prompt, with, last, where the user is (`page`), the names of the `tools` on offer
there. The tools' names are in the request's `tools` too, but a model picks them more readily there, and `state` (see tbd.chat.schema/RunAgentInput) — what the page is showing right now, so
when the instructions say them as well, and it can say what it can do without a call. One the model is never told to call a tool to read what it already has. The tools' names are in the
message, and the first: several chat templates (Gemma's, Mistral's) refuse more than one system request's `tools` too, but a model picks them more readily when the instructions say them as
message, or one that isn't first." well, and it can say what it can do without a call. One message, and the first: several chat
[page tools] templates (Gemma's, Mistral's) refuse more than one system message, or one that isn't first."
[page tools state]
(cond-> (chat) (cond-> (chat)
page (str "\n\nThe user is on the \"" page "\" page of the app: what it shows is what they can see.") page (str "\n\nThe user is on the \"" page "\" page of the app: what it shows is what they can see.")
(seq tools) (str (if page " Its" "\n\nYour") (seq tools) (str (if page " Its" "\n\nYour")
" tools: " (str/join ", " (map :name tools)) " tools: " (str/join ", " (map :name tools))
". The tools of other pages are offered once you navigate there."))) ". The tools of other pages are offered once you navigate there.")
(seq state) (str "\n\nCurrent state of the page (JSON), current as of this message. Go by it, not an\n"
"earlier tool result or what you said before: never call a tool just to read it,\n"
"only to act:\n" (json/write-value-as-string state))))
(defn a2a (defn a2a
"The A2A server's system prompt: an outside agent calling this app directly, not through a "The A2A server's system prompt: an outside agent calling this app directly, not through a
@@ -61,4 +65,4 @@
"Then report in one short plain sentence, from the tool results: \"Added it.\" \"That's 23.\" Don't\n" "Then report in one short plain sentence, from the tool results: \"Added it.\" \"That's 23.\" Don't\n"
"paste JSON, don't describe the tool call itself, just its outcome.\n" "paste JSON, don't describe the tool call itself, just its outcome.\n"
"\n" "\n"
prompt/examples)) (prompt/examples true)))
+51
View File
@@ -0,0 +1,51 @@
(ns tbd.chat.db
"SQLite persistence for the chat widget's history, in the app's database (see tbd.sqlite). Not
the AG-UI run itself (tbd.chat.routes' /api/chat stays stateless) — this is the browser's own
conversation (tbd.ui.db's :chat :messages), saved so a reload or a new browser can pick it back
up. One row per user: the whole conversation is kept as one EDN blob and replaced wholesale on
each save, the same way the browser already treats it as a single vector, never a diff."
(:require [clojure.edn :as edn]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]
[tbd.sqlite :as sqlite]))
(def ^:private create-chat-history
;; `owner_id` is the user's id in Gitea, like tbd.todo.db's todos.
"CREATE TABLE IF NOT EXISTS chat_history (
owner_id INTEGER PRIMARY KEY,
messages TEXT NOT NULL,
updated_at INTEGER NOT NULL)")
(defn migrate!
"Creates the chat_history table in the database `ds`, or brings it up to date."
[ds]
(jdbc/execute! ds [create-chat-history]))
(defn open
"A database with just the chat_history table, at `path`; the app opens one with every group's
tables (see tbd.core), which this is for tests of the group on its own."
[path]
(sqlite/open path migrate!))
(def ^:private opts {:builder-fn rs/as-unqualified-kebab-maps})
(defn get-history
"The owner's stored conversation (tbd.chat.schema/HistoryMessage maps), oldest first, or [] if
nothing is stored for them yet."
[ds owner-id]
(if-let [{:keys [messages]} (jdbc/execute-one!
ds ["SELECT messages FROM chat_history WHERE owner_id = ?" owner-id] opts)]
(edn/read-string messages)
[]))
(defn save-history!
"Replaces the owner's stored conversation with `messages`."
[ds owner-id messages now]
(jdbc/execute! ds ["INSERT INTO chat_history (owner_id, messages, updated_at) VALUES (?, ?, ?)
ON CONFLICT (owner_id) DO UPDATE SET messages = excluded.messages, updated_at = excluded.updated_at"
owner-id (pr-str messages) now]))
(defn clear-history!
"Deletes the owner's stored conversation, if any."
[ds owner-id]
(jdbc/execute! ds ["DELETE FROM chat_history WHERE owner_id = ?" owner-id]))
+42 -19
View File
@@ -1,18 +1,15 @@
(ns tbd.chat.routes (ns tbd.chat.routes
"/api/chat: an AG-UI (Agent-User Interaction Protocol, https://docs.ag-ui.com) run. A caller "/api/chat: an AG-UI (https://docs.ag-ui.com) run. A caller POSTs a RunAgentInput
POSTs a RunAgentInput (tbd.chat.schema/RunAgentInput) and gets the agent's reply streamed back (tbd.chat.schema/RunAgentInput) and gets the agent's reply streamed back as AG-UI server-sent
as AG-UI's server-sent events: RUN_STARTED, then TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_* events: RUN_STARTED, then TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_* as the model generates,
as the model generates, then RUN_FINISHED or RUN_ERROR. The agent itself (its system prompt, then RUN_FINISHED or RUN_ERROR. The agent itself is tbd.agent.core; this ns only translates its
the LLM call, tool-call assembly) is tbd.agent.core; this ns only translates its internal event internal event shape ({:thinking}/{:content}/{:tool-calls}/{:done}/{:error}) to AG-UI's wire
shape ({:thinking}/{:content}/{:tool-calls}/{:done}/{:error}, see tbd.agent.core's ns docstring) format. AG-UI's frontend-tool model (the agent asks for a call, the browser runs it and sends
to and from AG-UI's wire format. the result back as a `tool` message on the next run) is exactly the loop tbd.ui.events drives."
AG-UI's frontend-tool model — the agent asks for a call, the browser (tbd.ui.webmcp) runs it and
sends the result back as a `tool` message on the next run — is exactly the loop tbd.ui.events
already drove against the old bespoke SSE shape; nothing about that loop changes here."
(:require [muuntaja.core :as m] (:require [muuntaja.core :as m]
[ring.core.protocols :as ring-protocols] [ring.core.protocols :as ring-protocols]
[tbd.agent.core :as agent] [tbd.agent.core :as agent]
[tbd.chat.db :as chat-db]
[tbd.chat.schema :as schema] [tbd.chat.schema :as schema]
[tbd.http :refer [respond]]) [tbd.http :refer [respond]])
(:import (java.io IOException OutputStream) (:import (java.io IOException OutputStream)
@@ -126,13 +123,39 @@
"X-Accel-Buffering" "no"} "X-Accel-Buffering" "no"}
:body (event-stream ok thread-id run-id)})))) :body (event-stream ok thread-id run-id)}))))
(defn- history-handler [ds]
(fn [{:keys [user]}]
(respond 200 {:messages (chat-db/get-history @ds (:id user))})))
(defn- save-history-handler [ds]
(fn [{{{:keys [messages]} :body} :parameters :keys [user]}]
(chat-db/save-history! @ds (:id user) messages (System/currentTimeMillis))
(respond 200 {:saved true})))
(defn- clear-history-handler [ds]
(fn [{:keys [user]}]
(chat-db/clear-history! @ds (:id user))
(respond 200 {:cleared true})))
(defn routes (defn routes
"`config` is the agent config (see tbd.agent.core/env-config). Only logged-in users may chat: "`config` is the agent config (see tbd.agent.core/env-config). `ds` is a delay of the app's
every message costs the LLM server's time." database (see tbd.sqlite/open), for /api/chat/history. Only logged-in users may chat: every
[config] message costs the LLM server's time."
[config ds]
["/api/chat" ["/api/chat"
{:post {:tags ["chat"] {:tags ["chat"]}
:login? true [""
:summary "An AG-UI (https://docs.ag-ui.com) run: POST a RunAgentInput (the conversation so far, tools on offer, and `context` — the page the user is on travels as {\"description\":\"page\",\"value\":\"...\"}); the reply streams back as AG-UI server-sent events (RUN_STARTED, TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_* as the model generates, then RUN_FINISHED or RUN_ERROR). Failures before the run starts are ordinary errors: 400 for an invalid input, 502 if the LLM server can't be reached or refuses, 503 if the agent isn't configured" {:post {:login? true
:parameters {:body schema/RunAgentInput} :summary "An AG-UI (https://docs.ag-ui.com) run: POST a RunAgentInput (the conversation so far, tools on offer, and `context` — the page the user is on travels as {\"description\":\"page\",\"value\":\"...\"}); the reply streams back as AG-UI server-sent events (RUN_STARTED, TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_* as the model generates, then RUN_FINISHED or RUN_ERROR). Failures before the run starts are ordinary errors: 400 for an invalid input, 502 if the LLM server can't be reached or refuses, 503 if the agent isn't configured"
:handler (chat-handler config)}}]) :parameters {:body schema/RunAgentInput}
:handler (chat-handler config)}}]
["/history"
{:login? true}
[""
{:get {:summary "The logged-in user's stored chat history (tbd.chat.schema/HistoryMessage, oldest first); {:messages []} if there is none"
:handler (history-handler ds)}
:put {:summary "Replaces the logged-in user's stored chat history with the given messages — the browser's own full conversation, saved so a reload or another browser can restore it"
:parameters {:body schema/History}
:handler (save-history-handler ds)}
:delete {:summary "Clears the logged-in user's stored chat history (the \"Clear\" button: the next reload starts a new session)"
:handler (clear-history-handler ds)}}]]])
+74 -5
View File
@@ -24,6 +24,14 @@
(defn- small? [tool] (defn- small? [tool]
(<= (count (pr-str tool)) max-tool-schema-length)) (<= (count (pr-str tool)) max-tool-schema-length))
(def ^:private max-state-length
"How long RunAgentInput's `state` may be, printed: room for a todo list or a game board, not a
free way to put an unbounded payload in every system prompt."
8000)
(defn- small-state? [state]
(<= (count (pr-str state)) max-state-length))
(def Tool (def Tool
"AG-UI's Tool: {name, description, parameters}. `parameters` is JSON Schema for the arguments, "AG-UI's Tool: {name, description, parameters}. `parameters` is JSON Schema for the arguments,
which is the LLM's to read, so it is any (small) object." which is the LLM's to read, so it is any (small) object."
@@ -83,7 +91,10 @@
(def RunAgentInput (def RunAgentInput
"AG-UI's RunAgentInput: the conversation so far, oldest first (`messages`), the tools on offer "AG-UI's RunAgentInput: the conversation so far, oldest first (`messages`), the tools on offer
for this run (`tools`), and ambient information (`context`, which is where `page` travels). for this run (`tools`), ambient information (`context`, which is where `page` travels), and
`state` — what the page is showing right now (its todo list, its tic-tac-toe board, ...), so the
model has it up front instead of spending a tool call to read it (see tbd.ui.model-context's
state registry, which is what fills it on the browser's side).
`threadId`/`runId` identify the run to the client; this server is stateless between turns (the `threadId`/`runId` identify the run to the client; this server is stateless between turns (the
browser resends the whole conversation each time, see tbd.ui.events), so it only echoes them browser resends the whole conversation each time, see tbd.ui.events), so it only echoes them
back, never reads them." back, never reads them."
@@ -92,7 +103,65 @@
[:runId {:optional true} [:string {:max 200}]] [:runId {:optional true} [:string {:max 200}]]
[:messages [:vector {:min 1 :max max-messages} Message]] [:messages [:vector {:min 1 :max max-messages} Message]]
[:tools {:optional true} [:vector {:max max-tools} Tool]] [:tools {:optional true} [:vector {:max max-tools} Tool]]
[:context {:optional true} [:vector {:max 8} Context]]]) [:context {:optional true} [:vector {:max 8} Context]]
[:state {:optional true} [:and [:map-of :keyword :any] [:fn small-state?]]]])
(def max-history-messages
"How many messages of a browser's own conversation (see tbd.ui.db's :chat :messages) the
/api/chat/history endpoint stores for it, the most recent (see tbd.ui.events/storable) — more
than max-messages, since this is scrollback for the user, not context for the LLM."
100)
(def max-history-content-length
"The longest tool result, or reply's reasoning, /api/chat/history stores: far over
`max-message-length` (what the LLM is sent), since the stored conversation is the whole log for
\"Expand tool use\"/\"Show reasoning\" to show after a reload, not context for the LLM."
100000)
(def max-history-length
"How long the stored conversation may be, printed, all told (see tbd.ui.events/storable, which
drops its oldest messages to stay within it)."
1000000)
(defn- small-history? [{:keys [messages]}]
(<= (count (pr-str messages)) max-history-length))
(def HistoryMessage
"A message as the browser's own :chat :messages keeps it (see tbd.ui.db), not AG-UI's wire
Message: /api/chat/history is this app's own addition, not part of the AG-UI run protocol, so it
round-trips the client's fields as-is (kebab-case, a tool result's :name/:error?, and an
assistant reply's :thinking, for display, which AG-UI's Message has no place for) instead of
forcing them through Message's shape."
[:multi {:dispatch :role}
["user" [:map
[:role [:= "user"]]
[:content [:string {:min 1 :max max-message-length}]]]]
["assistant" [:and
[:map
[:role [:= "assistant"]]
[:content {:optional true} [:string {:max max-message-length}]]
[:thinking {:optional true} [:string {:max max-history-content-length}]]
;; the user halted the reply before it was over (see tbd.ui.events/::chat-halt)
[:halted? {:optional true} :boolean]
[:tool-calls {:optional true}
[:vector {:max max-tool-calls}
[:map
[:id Id]
[:name [:string {:min 1 :max 200}]]
[:arguments [:string {:max 100000}]]]]]]
[:fn (fn [{:keys [content tool-calls]}] (or (seq content) (seq tool-calls)))]]]
["tool" [:map
[:role [:= "tool"]]
[:tool-call-id Id]
[:name {:optional true} [:string {:max 200}]]
[:content [:string {:min 1 :max max-history-content-length}]]
[:error? {:optional true} :boolean]]]])
(def History
"The body of a PUT to /api/chat/history: the browser's whole conversation, oldest first."
[:and
[:map [:messages [:vector {:max max-history-messages} HistoryMessage]]]
[:fn small-history?]])
(defn page-of (defn page-of
"The `page` context entry's value, or nil." "The `page` context entry's value, or nil."
@@ -119,6 +188,6 @@
(defn system-text (defn system-text
"The agent's own system prompt for this run (see tbd.agent.instructions), never the caller's to "The agent's own system prompt for this run (see tbd.agent.instructions), never the caller's to
supply: only `page` (from `context`) and `tools` shape it." supply: only `page` (from `context`), `tools` and `state` shape it."
[{:keys [tools context]}] [{:keys [tools context state]}]
(instructions/chat-system-message (page-of context) tools)) (instructions/chat-system-message (page-of context) tools state))
+48 -37
View File
@@ -1,31 +1,22 @@
(ns tbd.chat.trace (ns tbd.chat.trace
"Observability for the chatbot's LLM turns: what the model was asked, what it did with it, how long "Observability for the chatbot's LLM turns: what the model was asked, how it went, and whether it
it took, and whether it looks stuck. No Ring and no LLM here; tbd.agent.core (the chatbot's agent) looks stuck. Called by tbd.agent.core and tbd.agent.a2a; no Ring or LLM code here.
and tbd.agent.a2a (the A2A server) both call it.
One request to /api/chat, or one message to the A2A server, is one turn of the model. The loop that One request to /api/chat, or one message to the A2A server, is one turn. A stuck agent is watched
runs the chatbot's tools lives in the browser for two ways: within a turn, reasoning that never ends (`:long-reasoning`) or repeats a sentence
(tbd.ui.events): a tool's result comes back as a new request holding the conversation so far, so the (`:repeated-thinking`); across turns, the same tool call made over and over (`:repeated-call`).
server keeps nothing between turns. A stuck agent shows up in two ways, and both are watched:
- within a turn, as reasoning that never ends (`:long-reasoning`) or that says the same sentence A turn is one `tracer`: `begin!` logs `:turn-start`, `observe!` runs per reply event (logging
again and again (`:repeated-thinking`); `:loop-suspect` and telling the caller to stop the turn once a loop is confirmed), `finish!` logs
- across turns, as the same tool call made over and over (`:repeated-call`), read off the `:turn-end` with the outcome, timings and flags. A tracer is for one thread.
conversation each request carries.
Every turn is one `tracer`: `begin!` when the request goes out (logs `:turn-start`), `observe!` for Turns are correlated by `req` (per turn) and `run` (a hash of the user's last message, shared by
each event of the reply (logs a `:loop-suspect` when one of the above trips), `finish!` when it ends every turn of the tool loop it started), with `step` counting turns of the run from 0.
(logs `:turn-end`, with the outcome, timings, sizes and flags). A tracer is for one thread, the one
that reads the reply.
Turns are correlated by `req` (one per turn) and `run` (a hash of the user's last message, the same Entries go to a `sink`, which prints one `[tbd] chat <event> k=v ...` line and, if given a file,
for every turn of the tool loop it started), with `step` counting the turns of the run from 0. appends it as JSON. Only the file gets the reasoning/reply text, the run's messages and the
system prompt — the user's words or the app's data — so that's off unless CHAT_TRACE_FILE is set
Entries are maps that go to a `sink`. `sink` prints each as one `[tbd] chat <event> k=v ...` line and, (tbd.agent.core/env-config)."
if given a file, appends it there as JSON. Only the file has the text of the reasoning and the reply
(`:reasoning`, `:reply`) and the run's messages (`:input`): they are what you read to see why a
model is looping, and they are the user's words, so they are off unless a file is asked for
(CHAT_TRACE_FILE, see tbd.agent.core/env-config)."
(:require [clojure.java.io :as io] (:require [clojure.java.io :as io]
[clojure.string :as str] [clojure.string :as str]
[muuntaja.core :as m]) [muuntaja.core :as m])
@@ -48,6 +39,17 @@
"The same tool called with the same arguments this many times in one run is a `:repeated-call`." "The same tool called with the same arguments this many times in one run is a `:repeated-call`."
3) 3)
(def repeat-abort-count
"A sentence said this many times is not a false positive anymore: `observe!` says to stop the
turn. A milestone of `repeat-warn-count` (see `repeat-milestone?`), so it is always hit exactly,
not stepped over."
64)
(def long-reasoning-abort-chars
"Reasoning still going, without an answer or a call, at this many characters: `observe!` says to
stop the turn. A milestone of `reasoning-warn-chars` (each doubling), for the same reason."
32000)
(def ^:private max-distinct-sentences 5000) (def ^:private max-distinct-sentences 5000)
(def ^:private max-pending-chars 1000) (def ^:private max-pending-chars 1000)
(def ^:private max-args-length 500) (def ^:private max-args-length 500)
@@ -162,7 +164,7 @@
(def ^:private heavy-fields (def ^:private heavy-fields
"What only the trace file gets." "What only the trace file gets."
#{:reasoning :reply :input}) #{:reasoning :reply :input :system-text})
(defn- render-field [k v] (defn- render-field [k v]
(str (name k) "=" (str (name k) "="
@@ -219,10 +221,11 @@
(catch Throwable _ nil))) (catch Throwable _ nil)))
(defn begin! (defn begin!
"Starts tracing a turn, and logs `:turn-start`; `messages`, `tools` and `page` are the request's, and "Starts tracing a turn, logging `:turn-start`. `messages`/`tools`/`page`/`model` are the
`model` the LLM's, if the config names one. `trace` is a config of `config-for`, or nil for request's. `system-text` is the turn's system prompt; with `full-text?` on, it's also written to
`default-config`. Returns the tracer." the trace file. `trace` is a config from `config-for`, or nil for `default-config`. Returns the
[trace {:keys [messages tools page model]}] tracer."
[trace {:keys [messages tools page model system-text]}]
(let [{:keys [sink full-text?]} (or trace default-config) (let [{:keys [sink full-text?]} (or trace default-config)
{:keys [run step run-calls top-call input]} (run-summary messages) {:keys [run step run-calls top-call input]} (run-summary messages)
tracer {:sink sink :full-text? full-text? tracer {:sink sink :full-text? full-text?
@@ -234,27 +237,35 @@
(cond-> {:page page :model model :messages (count messages) :tools (count tools) (cond-> {:page page :model model :messages (count messages) :tools (count tools)
:prompt-chars (transduce (map #(count (:content %))) + 0 messages) :prompt-chars (transduce (map #(count (:content %))) + 0 messages)
:run-calls run-calls} :run-calls run-calls}
full-text? (assoc :input input))) full-text? (assoc :input input :system-text system-text)))
(when (and top-call (>= (:count top-call) repeated-call-warn-count)) (when (and top-call (>= (:count top-call) repeated-call-warn-count))
(log! tracer :loop-suspect {:kind :repeated-call :tool (:tool top-call) :count (:count top-call) (log! tracer :loop-suspect {:kind :repeated-call :tool (:tool top-call) :count (:count top-call)
:args (truncate (:args top-call) sample-length)})) :args (truncate (:args top-call) sample-length)}))
tracer)) tracer))
(defn- abortable [alert]
(case (:kind alert)
:repeated-thinking (when (>= (:count alert) repeat-abort-count) alert)
:long-reasoning (when (>= (:chars alert) long-reasoning-abort-chars) alert)
nil))
(defn observe! (defn observe!
"Takes one event of the LLM's reply (see tbd.agent.core, whose pump calls this: :content, :thinking, "Takes one event of the LLM's reply (tbd.agent.core/pump: :content, :thinking, or at the end
or, at the end of a turn, :finish-reason and :usage), logging a `:loop-suspect` if the reasoning has :finish-reason/:usage), logging `:loop-suspect` if the reasoning is running long or repeating.
gone on for long, or is repeating itself." Returns the alert to stop the turn over once it passes repeat-abort-count/long-reasoning-abort-chars,
else nil."
[{:keys [state full-text?] :as tracer} event] [{:keys [state full-text?] :as tracer} event]
(let [[state' alerts] (advance @state event (now-ms) full-text?)] (let [[state' alerts] (advance @state event (now-ms) full-text?)]
(reset! state (update state' :flags into (map :kind) alerts)) (reset! state (update state' :flags into (map :kind) alerts))
(doseq [alert alerts] (doseq [alert alerts]
(log! tracer :loop-suspect alert)))) (log! tracer :loop-suspect alert))
(some abortable alerts)))
(defn finish! (defn finish!
"Ends the turn, logging `:turn-end`; only the first call does anything, so it is safe to call "Ends the turn, logging `:turn-end`. Only the first call does anything, so it's safe to call
again in a `finally`. `outcome` is a map: {:outcome :done | :tool-calls | :error | :upstream-error again in a `finally`. `outcome` is {:outcome :done|:tool-calls|:error|:upstream-error|:looped|:aborted
| :aborted, :calls [{:name :arguments}] for :tool-calls, :error text and :detail text for the :calls [...] :error :detail}. :aborted is a turn that just stopped; :looped is one pump cut short
failures}. :aborted is a turn that just stopped (the client went away, or something threw)." and retried (the retry is a turn of its own)."
[{:keys [state full-text?] :as tracer} {:keys [outcome calls error detail]}] [{:keys [state full-text?] :as tracer} {:keys [outcome calls error detail]}]
(let [s @state] (let [s @state]
(when-not (:finished? s) (when-not (:finished? s)
+7 -8
View File
@@ -19,6 +19,7 @@
[tbd.auth.core :as auth] [tbd.auth.core :as auth]
[tbd.auth.middleware :as auth-mw] [tbd.auth.middleware :as auth-mw]
[tbd.auth.routes :as auth-routes] [tbd.auth.routes :as auth-routes]
[tbd.chat.db :as chat-db]
[tbd.chat.routes :as chat-routes] [tbd.chat.routes :as chat-routes]
[tbd.health.routes :as health] [tbd.health.routes :as health]
[tbd.http :as http] [tbd.http :as http]
@@ -74,7 +75,7 @@
;; namespace that returns its own route subtree; they're concatenated here. ;; namespace that returns its own route subtree; they're concatenated here.
(defn make-router [{:keys [auth nrepl db webmcp chat]}] (defn make-router [{:keys [auth nrepl db webmcp chat]}]
;; One database for every group's tables, opened (and migrated) on first use, not when the app loads. ;; One database for every group's tables, opened (and migrated) on first use, not when the app loads.
(let [ds (delay (sqlite/open (:db-path db) todo-db/migrate! oauth-db/migrate!))] (let [ds (delay (sqlite/open (:db-path db) todo-db/migrate! oauth-db/migrate! chat-db/migrate!))]
(ring/router (ring/router
[["/swagger.json" [["/swagger.json"
;; The spec is JSON, whatever the API default is (Swagger UI can't read EDN). ;; The spec is JSON, whatever the API default is (Swagger UI can't read EDN).
@@ -90,17 +91,15 @@
(a2a/routes auth ds chat) (a2a/routes auth ds chat)
(oauth-routes/routes auth ds) (oauth-routes/routes auth ds)
(auth-routes/routes auth) (auth-routes/routes auth)
(chat-routes/routes chat) (chat-routes/routes chat ds)
(nrepl-routes/routes nrepl) (nrepl-routes/routes nrepl)
(todo-routes/routes ds)] (todo-routes/routes ds)]
{:data {:muuntaja http/muuntaja {:data {:muuntaja http/muuntaja
:coercion malli/coercion :coercion malli/coercion
;; Handlers (and the auth/error middleware) return plain data; the muuntaja ;; Order matters: response-formatting outermost (handlers return plain data), then
;; middleware encodes it as the Accept header asks, so it wraps everything else. ;; auth (so unauthenticated callers are turned away before body parsing/coercion),
;; Auth comes next, so unauthenticated callers to `:admin? true` / `:login? true` ;; then request-formatting split below the exception middleware so a malformed body
;; routes are turned away before any body parsing or coercion runs. The request ;; is caught and answered with a 400 rather than thrown.
;; half of muuntaja is split off below the exception middleware (rather than using the
;; combined format-middleware) so a malformed request body is caught and answered with a 400.
:middleware [muuntaja-middleware/format-negotiate-middleware :middleware [muuntaja-middleware/format-negotiate-middleware
muuntaja-middleware/format-response-middleware muuntaja-middleware/format-response-middleware
(auth-mw/admin-middleware auth) (auth-mw/admin-middleware auth)
+48 -1
View File
@@ -1,7 +1,13 @@
(ns tbd.agent.core-test (ns tbd.agent.core-test
(:require [clojure.test :refer [deftest is testing]] (:require [clojure.test :refer [deftest is testing]]
[tbd.agent.core :as agent] [tbd.agent.core :as agent]
[tbd.agent.test-support :as ts])) [tbd.agent.test-support :as ts]
[tbd.chat.trace :as trace])
(:import (dev.langchain4j.data.message AiMessage SystemMessage)
(dev.langchain4j.model.chat.request ChatRequest)
(dev.langchain4j.model.chat.response PartialResponse PartialResponseContext
PartialThinking PartialThinkingContext)
(dev.langchain4j.model.output FinishReason)))
(defn- turn! [config messages tools] (defn- turn! [config messages tools]
(let [{:keys [ok error kind]} (agent/start config "system prompt" messages tools)] (let [{:keys [ok error kind]} (agent/start config "system prompt" messages tools)]
@@ -53,6 +59,47 @@
(is (= {:error "chat is not configured" :kind :unavailable} (turn! config [] nil))) (is (= {:error "chat is not configured" :kind :unavailable} (turn! config [] nil)))
(is (zero? @calls))))) (is (zero? @calls)))))
(deftest a-loop-is-retried-once-then-recovers
(testing "a turn that repeats itself is cut short and sent again, nudged to answer; the retry's
reply is what the caller sees, not a failure"
(let [calls (atom 0)
reqs (atom [])
sentence "Wait, let me check the board again. "
model (ts/model-of
(fn [req handler]
(swap! reqs conj req)
(let [h (ts/fake-handle)]
(if (= 1 (swap! calls inc))
(dotimes [_ trace/repeat-abort-count]
(.onPartialThinking handler (PartialThinking. ^String sentence) (PartialThinkingContext. h)))
(do (.onPartialResponse handler (PartialResponse. "ok") (PartialResponseContext. h))
(ts/complete handler (AiMessage/from "ok") FinishReason/STOP [10 5]))))))
{:keys [events]} (turn! (ts/config model) [{:role "user" :content "hi"}] nil)]
(is (= 2 @calls) "the model is asked again, once, after the loop")
(is (= [{:content "ok"} {:done true}] (take-last 2 events))
"the retry's reply is what the caller ends up seeing")
(is (= trace/repeat-abort-count (count (filter #(= {:thinking sentence} %) events)))
"the caller still sees what the model was thinking before it was cut off")
(is (not-any? :error events) "a loop that recovers is not shown to the user as a failure")
(is (not (re-find #"Stop reasoning now" (.text ^SystemMessage (first (.messages ^ChatRequest (first @reqs))))))
"the first attempt's prompt is unchanged")
(is (re-find #"Stop reasoning now" (.text ^SystemMessage (first (.messages ^ChatRequest (second @reqs)))))
"the retry's prompt has the nudge appended"))))
(deftest a-loop-that-does-not-recover-is-an-error
(testing "only one retry is made: a turn that loops again on the retry is finally an error"
(let [calls (atom 0)
sentence "Wait, let me check the board again. "
model (ts/model-of
(fn [_ handler]
(swap! calls inc)
(let [h (ts/fake-handle)]
(dotimes [_ trace/repeat-abort-count]
(.onPartialThinking handler (PartialThinking. ^String sentence) (PartialThinkingContext. h))))))
{:keys [events]} (turn! (ts/config model) [{:role "user" :content "hi"}] nil)]
(is (= 2 @calls) "the retry itself is not retried again")
(is (= {:error "the model got stuck repeating itself, and the reply was stopped"} (last events))))))
(deftest conversation-history-round-trips (deftest conversation-history-round-trips
(testing "assistant messages with tool calls, and their tool-role results, reach the model (testing "assistant messages with tool calls, and their tool-role results, reach the model
without error (see tbd.agent.core/llm-message)" without error (see tbd.agent.core/llm-message)"
+16 -5
View File
@@ -15,24 +15,35 @@
(is (str/includes? text "in this same turn")) (is (str/includes? text "in this same turn"))
(is (str/includes? text "Work it out yourself:")) (is (str/includes? text "Work it out yourself:"))
(is (str/includes? text "Say something was done only if a tool result says it was")) (is (str/includes? text "Say something was done only if a tool result says it was"))
(is (str/includes? text "Tic-tac-toe: check whose turn it is"))
(is (str/includes? text "Examples: ")))) (is (str/includes? text "Examples: "))))
(deftest chat-is-framed-as-the-in-page-chatbot (deftest chat-is-framed-as-the-in-page-chatbot
(let [text (instructions/chat)] (let [text (instructions/chat)]
(is (str/includes? text "under your message")) (is (str/includes? text "under your message"))
(is (str/includes? text "Chain calls without stopping")) (is (str/includes? text "Chain calls without stopping"))
(is (str/includes? text "navigate there, then") "the chatbot's tools follow the page it is on"))) (is (str/includes? text "navigate there, then") "the chatbot's tools follow the page it is on")
(is (str/includes? (flat text) "\"Current state of the page\" below")
"it's told where to find what a read tool used to be for")
(is (not (str/includes? text "list_todos")) "it has no list_todos: the state has that")
(is (not (str/includes? text "get_tic_tac_toe")) "nor get_tic_tac_toe")))
(deftest chat-system-message-adds-page-and-tools (deftest chat-system-message-adds-page-and-tools
(is (= (instructions/chat) (instructions/chat-system-message nil nil))) (is (= (instructions/chat) (instructions/chat-system-message nil nil nil)))
(let [text (instructions/chat-system-message "todos" [{:name "create_todo"} {:name "list_todos"}])] (let [text (instructions/chat-system-message "todos" [{:name "create_todo"} {:name "list_todos"}] nil)]
(is (str/includes? text "on the \"todos\" page")) (is (str/includes? text "on the \"todos\" page"))
(is (str/includes? text "Its tools: create_todo, list_todos")))) (is (str/includes? text "Its tools: create_todo, list_todos"))))
(deftest chat-system-message-adds-state
(is (= (instructions/chat) (instructions/chat-system-message nil nil {})) "empty state adds nothing")
(let [text (instructions/chat-system-message nil nil {:todos [{:title "milk" :done false}]})]
(is (str/includes? text "Current state of the page"))
(is (str/includes? text "never call a tool just to read it"))
(is (str/includes? text "\"title\":\"milk\""))))
(deftest a2a-has-no-in-page-framing (deftest a2a-has-no-in-page-framing
(let [text (instructions/a2a)] (let [text (instructions/a2a)]
(is (str/includes? text "Act, don't offer")) (is (str/includes? text "Act, don't offer"))
(is (str/includes? text "Agent2Agent protocol")) (is (str/includes? text "Agent2Agent protocol"))
(is (str/includes? text "no page open")) (is (str/includes? text "no page open"))
(is (not (str/includes? text "under your message"))))) (is (not (str/includes? text "under your message")))
(is (str/includes? text "list_todos -> set_todo_done") "it has no state either: it reads first, like WebMCP's guide")))
+16 -8
View File
@@ -1,6 +1,6 @@
(ns tbd.agent.prompt-test (ns tbd.agent.prompt-test
(:require [clojure.string :as str] (:require [clojure.string :as str]
[clojure.test :refer [deftest is]] [clojure.test :refer [deftest is testing]]
[tbd.agent.prompt :as prompt])) [tbd.agent.prompt :as prompt]))
(defn- flat (defn- flat
@@ -14,10 +14,9 @@
(is (str/includes? text "in this same turn")) (is (str/includes? text "in this same turn"))
(is (str/includes? text "Work it out yourself:")) (is (str/includes? text "Work it out yourself:"))
(is (str/includes? text "Chain calls without stopping")) (is (str/includes? text "Chain calls without stopping"))
(is (str/includes? text "results from an earlier message are marked out of date")) (is (str/includes? text "an earlier one may no longer hold"))
(is (str/includes? text "never go by an earlier result")) (is (str/includes? text "never go by an earlier result"))
(is (str/includes? text "Say something was done only if a tool result says it was")) (is (str/includes? text "Say something was done only if a tool result says it was"))
(is (str/includes? text "Tic-tac-toe: check whose turn it is"))
(is (str/includes? text "Examples: ")) (is (str/includes? text "Examples: "))
(is (not (str/includes? text "navigate there, then")) "an outside agent is offered every tool"))) (is (not (str/includes? text "navigate there, then")) "an outside agent is offered every tool")))
@@ -28,9 +27,18 @@
(is (str/includes? (prompt/task none) "Ask the user what they want") (pr-str none)) (is (str/includes? (prompt/task none) "Ask the user what they want") (pr-str none))
(is (not (str/includes? (prompt/task none) "The user's request")) (pr-str none)))) (is (not (str/includes? (prompt/task none) "The user's request")) (pr-str none))))
(deftest examples-differ-by-reads
(testing "an outside agent (no state channel) is shown reading first"
(is (str/includes? (prompt/examples true) "list_todos -> set_todo_done"))
(is (str/includes? (prompt/examples true) "list_todos -> ONE set_todo_done")))
(testing "the chatbot (state already in view) is not, since it has no list_todos"
(is (not (str/includes? (prompt/examples false) "list_todos"))))
(testing "the rest is the same either way"
(doseq [text [(prompt/examples true) (prompt/examples false)]]
(is (str/includes? text "create_todo{\"todos\":[{\"title\":\"buy milk\"}]} -> \"Added.\""))
(is (str/includes? text "add{\"x\":19,\"y\":4} -> \"23.\"")))))
(deftest tic-tac-toe-prompt (deftest tic-tac-toe-prompt
(is (str/includes? (prompt/tic-tac-toe "x") "as X.")) (is (str/includes? prompt/tic-tac-toe "get_tic_tac_toe and move_tic_tac_toe"))
(is (str/includes? (prompt/tic-tac-toe "o") "as O.")) (is (not (str/includes? prompt/tic-tac-toe "as X")) "no side is assigned by the prompt")
(doseq [other [nil "" "z" :x]] (is (not (str/includes? prompt/tic-tac-toe "as O")) "no side is assigned by the prompt"))
(is (str/includes? (prompt/tic-tac-toe other) "as O.") (pr-str other)))
(is (str/includes? (prompt/tic-tac-toe "x") "never move for the other side")))
+15 -1
View File
@@ -26,7 +26,11 @@
(reify StreamingChatModel (reify StreamingChatModel
(doChat [_ req handler] (script req handler) nil))) (doChat [_ req handler] (script req handler) nil)))
(defn- complete [handler ai-message finish-reason usage] (defn complete
"Finishes a fake model's call: sends `handler` an onCompleteResponse of `ai-message`, with
`finish-reason` and `usage` ([prompt completion], or nil for neither) — for a test whose fake
model needs more control than text-model/tool-call-model/etc give."
[handler ai-message finish-reason usage]
(.onCompleteResponse handler (.onCompleteResponse handler
(-> (ChatResponse/builder) (-> (ChatResponse/builder)
(.aiMessage ai-message) (.aiMessage ai-message)
@@ -44,6 +48,16 @@
(doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h))) (doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h)))
(complete handler (AiMessage/from (apply str pieces)) FinishReason/STOP [10 5]))))) (complete handler (AiMessage/from (apply str pieces)) FinishReason/STOP [10 5])))))
(defn text-model-capturing
"Like text-model, but `(reset! captured req)` with the ChatRequest sent — for a test that checks
what went into the system prompt (tbd.agent.instructions/chat-system-message), tools, or history."
[captured & pieces]
(model-of (fn [req handler]
(reset! captured req)
(let [h (fake-handle)]
(doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h)))
(complete handler (AiMessage/from (apply str pieces)) FinishReason/STOP [10 5])))))
(defn thinking-model (defn thinking-model
"A model that streams `thinking`, then `pieces` as content." "A model that streams `thinking`, then `pieces` as content."
[thinking & pieces] [thinking & pieces]
+43
View File
@@ -0,0 +1,43 @@
(ns tbd.chat.db-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[tbd.chat.db :as db]
[tbd.sqlite-test :refer [temp-db-path]]))
(deftest open-test
(testing "creates the file and its directory"
(let [path (temp-db-path)]
(db/open path)
(is (.exists (io/file path)))))
(testing "reopening keeps the data"
(let [path (temp-db-path)
messages [{:role "user" :content "hi"}]]
(db/save-history! (db/open path) 7 messages 1000)
(is (= messages (db/get-history (db/open path) 7))))))
(deftest crud-test
(let [ds (db/open (temp-db-path))]
(testing "nothing stored yet"
(is (= [] (db/get-history ds 7))))
(testing "save and load"
(db/save-history! ds 7 [{:role "user" :content "hi"}] 1000)
(is (= [{:role "user" :content "hi"}] (db/get-history ds 7))))
(testing "saving again replaces the whole conversation"
(db/save-history! ds 7 [{:role "user" :content "hi"}
{:role "assistant" :content "hello"}]
2000)
(is (= [{:role "user" :content "hi"} {:role "assistant" :content "hello"}]
(db/get-history ds 7))))
(testing "clear"
(db/clear-history! ds 7)
(is (= [] (db/get-history ds 7))))))
(deftest owner-scoping-test
(let [ds (db/open (temp-db-path))]
(db/save-history! ds 7 [{:role "user" :content "mine"}] 1000)
(db/save-history! ds 8 [{:role "user" :content "theirs"}] 1000)
(is (= [{:role "user" :content "mine"}] (db/get-history ds 7)))
(is (= [{:role "user" :content "theirs"}] (db/get-history ds 8)))
(db/clear-history! ds 7)
(is (= [] (db/get-history ds 7)))
(is (= [{:role "user" :content "theirs"}] (db/get-history ds 8)) "clearing one owner's history leaves the other's")))
+96 -3
View File
@@ -5,8 +5,11 @@
[ring.core.protocols :as ring-protocols] [ring.core.protocols :as ring-protocols]
[tbd.agent.test-support :as ts] [tbd.agent.test-support :as ts]
[tbd.auth.routes-test :as t] [tbd.auth.routes-test :as t]
[tbd.sqlite-test :as sqlite-test]
[tbd.test-util :as test-util]) [tbd.test-util :as test-util])
(:import (java.io ByteArrayInputStream ByteArrayOutputStream IOException OutputStream))) (:import (dev.langchain4j.data.message SystemMessage)
(dev.langchain4j.model.chat.request ChatRequest)
(java.io ByteArrayInputStream ByteArrayOutputStream IOException OutputStream)))
(defn- json [data] (slurp (m/encode "application/json" data))) (defn- json [data] (slurp (m/encode "application/json" data)))
@@ -37,8 +40,19 @@
(def ^:private hello (json {:messages [{:id "m1" :role "user" :content "hi"}]})) (def ^:private hello (json {:messages [{:id "m1" :role "user" :content "hi"}]}))
(defn- app-with [chat] (defn- app-with
(t/make-app (t/gitea-stub "alice") :chat chat)) ([chat] (app-with chat "alice" 7 (sqlite-test/temp-db-path)))
([chat login id db-path]
(t/make-app (t/gitea-stub login id) :chat chat :db {:db-path db-path})))
(defn- request
"`body` is EDN data (or nil), sent (and the response read) as EDN, like the browser does."
[app method uri cookie & [body]]
(test-util/decode-body
(app (cond-> {:request-method method :uri uri
:headers (cond-> {} cookie (assoc "cookie" cookie))}
body (-> (assoc :body (ByteArrayInputStream. (.getBytes ^String (pr-str body))))
(assoc-in [:headers "content-type"] "application/edn"))))))
(deftest anonymous-test (deftest anonymous-test
(let [app (app-with (ts/config (ts/text-model "x")))] (let [app (app-with (ts/config (ts/text-model "x")))]
@@ -127,6 +141,26 @@
(json {:messages [{:id "m1" :role "user" :content "hi"}] (json {:messages [{:id "m1" :role "user" :content "hi"}]
:context [{:description "page" :value "ai-setup"}]})))))))) :context [{:description "page" :value "ai-setup"}]}))))))))
(deftest state-test
(let [req (atom nil)
app (app-with (ts/config (ts/text-model-capturing req "ok")))
cookie (t/login! app)
system-text (fn [] (.text ^SystemMessage (first (.messages ^ChatRequest @req))))]
(testing "the page's state reaches the system prompt, so the model doesn't need a tool to read it"
(post-chat app cookie (json {:messages [{:id "m1" :role "user" :content "hi"}]
:state {:todos [{:title "milk" :done false}]}}))
(is (str/includes? (system-text) "Current state of the page"))
(is (str/includes? (system-text) "\"title\":\"milk\"")))
(testing "no state, nothing added"
(post-chat app cookie hello)
(is (not (str/includes? (system-text) "Current state of the page"))))
(testing "state is optional, and bounded like a tool's schema"
(is (= 200 (:status (post-chat app cookie (json {:messages [{:id "m1" :role "user" :content "hi"}]
:state {:board (vec (repeat 9 nil)) :turn "x"}})))))
(is (= 400 (:status (post-chat app cookie
(json {:messages [{:id "m1" :role "user" :content "hi"}]
:state {:huge (apply str (repeat 8000 "x"))}}))))))))
(deftest invalid-tools-test (deftest invalid-tools-test
(let [app (app-with (ts/config (ts/text-model "x"))) (let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app) cookie (t/login! app)
@@ -163,6 +197,65 @@
(is (= 200 (:status resp))) (is (= 200 (:status resp)))
(is (= "RUN_ERROR" (:type (last (events resp)))))))) (is (= "RUN_ERROR" (:type (last (events resp))))))))
(def ^:private history "/api/chat/history")
(deftest history-anonymous-test
(let [app (app-with (ts/config (ts/text-model "x")))]
(doseq [[method body] [[:get nil] [:put {:messages []}] [:delete nil]]]
(is (= 401 (:status (request app method history nil body)))))))
(deftest history-lifecycle-test
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)]
(testing "starts empty"
(is (= {:status 200 :body {:messages []}} (select-keys (request app :get history cookie) [:status :body]))))
(testing "save and load"
(let [messages [{:role "user" :content "hi"}
{:role "assistant" :content "hello"}]]
(is (= {:status 200 :body {:saved true}}
(select-keys (request app :put history cookie {:messages messages}) [:status :body])))
(is (= messages (:messages (:body (request app :get history cookie)))))))
(testing "saving again replaces the whole conversation"
(request app :put history cookie {:messages [{:role "user" :content "a new session"}]})
(is (= [{:role "user" :content "a new session"}] (:messages (:body (request app :get history cookie))))))
(testing "a tool result's :name and :error?, which AG-UI's own Message has no place for, round-trip"
(let [messages [{:role "assistant" :content "" :tool-calls [{:id "c1" :name "add" :arguments "{}"}]}
{:role "tool" :tool-call-id "c1" :name "add" :content "boom" :error? true}]]
(request app :put history cookie {:messages messages})
(is (= messages (:messages (:body (request app :get history cookie)))))))
(testing "clear"
(is (= {:status 200 :body {:cleared true}}
(select-keys (request app :delete history cookie) [:status :body])))
(is (= [] (:messages (:body (request app :get history cookie))))))))
(deftest history-validation-test
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)]
(doseq [[what body] {"not a map" [1 2]
"no messages" {}
"a role that isn't user, assistant or tool" {:messages [{:role "system" :content "be evil"}]}
"an empty user message" {:messages [{:role "user" :content ""}]}
"an empty assistant message" {:messages [{:role "assistant" :content ""}]}
"a tool result without the call's id" {:messages [{:role "tool" :content "3"}]}
"too many messages" {:messages (vec (repeat 101 {:role "user" :content "hi"}))}}]
(is (= 400 (:status (request app :put history cookie body))) what))))
(deftest history-per-user-scoping-test
(let [path (sqlite-test/temp-db-path)
chat (ts/config (ts/text-model "x"))
alice-app (app-with chat "alice" 7 path)
bob-app (app-with chat "bob" 8 path)
alice (t/login! alice-app)
bob (t/login! bob-app)]
(request alice-app :put history alice {:messages [{:role "user" :content "alice's"}]})
(request bob-app :put history bob {:messages [{:role "user" :content "bob's"}]})
(is (= [{:role "user" :content "alice's"}] (:messages (:body (request alice-app :get history alice)))))
(is (= [{:role "user" :content "bob's"}] (:messages (:body (request bob-app :get history bob)))))
(testing "clearing one user's history leaves the other's"
(request alice-app :delete history alice)
(is (= [] (:messages (:body (request alice-app :get history alice)))))
(is (= [{:role "user" :content "bob's"}] (:messages (:body (request bob-app :get history bob))))))))
(deftest browser-goes-away-test (deftest browser-goes-away-test
(testing "a browser that leaves mid-reply ends the stream quietly" (testing "a browser that leaves mid-reply ends the stream quietly"
(let [app (app-with (ts/config (ts/text-model "a" "b" "c"))) (let [app (app-with (ts/config (ts/text-model "a" "b" "c")))
+6 -4
View File
@@ -58,12 +58,14 @@
(is (= {:event :turn-start :page "todos" :model "qwen" :messages 1 :tools 2 :prompt-chars 5 :step 0} (is (= {:event :turn-start :page "todos" :model "qwen" :messages 1 :tools 2 :prompt-chars 5 :step 0}
(select-keys start [:event :page :model :messages :tools :prompt-chars :step]))) (select-keys start [:event :page :model :messages :tools :prompt-chars :step])))
(is (re-matches #"[0-9a-f]{8}" (:req start))) (is (re-matches #"[0-9a-f]{8}" (:req start)))
(is (not (contains? start :input)))))) (is (not (contains? start :input)))
(testing "with the full text on, it has the run's messages" (is (not (contains? start :system-text))))))
(testing "with the full text on, it has the run's messages and the system prompt it was sent"
(let [entries (atom []) (let [entries (atom [])
messages [{:role "user" :content "old"} {:role "assistant" :content "reply"} {:role "user" :content "new"}]] messages [{:role "user" :content "old"} {:role "assistant" :content "reply"} {:role "user" :content "new"}]]
(trace/begin! (collecting entries :full-text? true) {:messages messages}) (trace/begin! (collecting entries :full-text? true) {:messages messages :system-text "You are..."})
(is (= [{:role "user" :content "new"}] (:input (first @entries)))))) (is (= [{:role "user" :content "new"}] (:input (first @entries))))
(is (= "You are..." (:system-text (first @entries))))))
(testing "every turn has its own req id" (testing "every turn has its own req id"
(let [entries (atom [])] (let [entries (atom [])]
(dotimes [_ 3] (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})) (dotimes [_ 3] (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]}))
+4 -1
View File
@@ -12,9 +12,12 @@
(rdc/render @root [views/app])) (rdc/render @root [views/app]))
(defn- offer-tools! (defn- offer-tools!
"The page's tools go to the chatbot in the page, and to an agent outside it, through WebMCP." "The page's tools and state go to the chatbot in the page; the tools (all of them, including the
read-only ones the chatbot itself isn't offered, see tbd.ui.model-context/definitions) also go to
an agent outside it, through WebMCP."
[] []
(model-context/register! webmcp/tools) (model-context/register! webmcp/tools)
(model-context/register-state! webmcp/state-providers)
(webmcp/register!)) (webmcp/register!))
(defn reload (defn reload
+22 -34
View File
@@ -2,57 +2,45 @@
(:require [tbd.ui.tictactoe :as tictactoe])) (:require [tbd.ui.tictactoe :as tictactoe]))
(def default-db (def default-db
{;; The page being shown (see tbd.ui.pages); it follows the URL's fragment. {;; Which page is showing (tbd.ui.pages); follows the URL's fragment.
:page :tic-tac-toe :page :tic-tac-toe
:calc {:x "" :y "" :calc {:x "" :y ""
;; {:status :idle} ;; :result is {:status :idle|:loading}, {:status :ok :x :y :sum}, or
;; {:status :loading} ;; {:status :error :message}.
;; {:status :ok :x "2" :y "3" :sum 5}
;; {:status :error :message "..."}
:result {:status :idle}} :result {:status :idle}}
;; {:status :unknown} (asking /auth/me) ;; :user is {:status :unknown}, {:status :anonymous}, {:status :logged-in :login "alice"}, or
;; {:status :anonymous} (not logged in) ;; {:status :error :message}.
;; {:status :logged-in :login "alice"}
;; {:status :error :message "..."}
:user {:status :unknown} :user {:status :unknown}
;; :status is the list load: :idle, :loading, :ok or :error. :error is the message of the :todos {;; :status is :idle, :loading, :ok or :error; :error is the last failed request's
;; last failed request (a load or a change); it is cleared when the next request starts. ;; message, cleared when the next request starts.
:todos {:status :idle :status :idle
:items [] :items []
:new-title "" :new-title ""
:error nil} :error nil}
;; The "Add this MCP server to Claude Code" page: :copied? is true right after the ;; The "Add this MCP server to Claude Code" page. :copied? is true right after the command was
;; command was copied to the clipboard. ;; copied to the clipboard.
:mcp {:copied? false} :mcp {:copied? false}
;; The chat widget (the green square in the corner): :open? is whether its panel is showing, ;; The chat widget (the green square). A message is {:role "user"|"assistant"|"tool" :content}
;; :messages the conversation so far, :input what is typed, :status :idle or :loading (waiting ;; with :tool-calls [{:id :name :arguments}] and :thinking on an assistant message that used
;; for the reply, or for the tools it asked for), and :error the message of the last failed send. ;; tools or reasoned, and :tool-call-id/:name on a tool message. :size is the panel's dragged
;; A message is one of ;; :width/:height. :tools-expanded?/:reasoning-expanded? control whether tool use/reasoning show
;; {:role "user" :content "..."} ;; in full or collapsed. :pending-calls/:tool-calls-used/:tools-used-this-turn/:thinking-at
;; {:role "assistant" :content "..."}, with :tool-calls [{:id :name :arguments "{...}"}] when ;; track a reply that is still coming or being answered (see tbd.ui.events).
;; the LLM asked for tools of the page to be called (:content may then be empty)
;; {:role "tool" :tool-call-id "..." :name "..." :content "..." :error? bool}: the result of
;; one such call.
;; :size is what the panel was dragged to, in px: its :width and the :height of the conversation
;; in it (the rest of the panel is the same at any size).
;; :tools-expanded? is whether the tool calls and results show whole (wrapped) or, as they do by
;; default, each cut to one line ending in "…" when it doesn't fit.
;; The other two are for a reply that is still coming or being answered: :pending-calls are the
;; calls it has asked for so far, :tool-calls-used how many calls this turn has made.
;; :thinking-at is when (ms since the epoch) the last piece of the model's reasoning came, or nil.
:chat {:open? false :chat {:open? false
:size {:width 320 :height 256} :size {:width 320 :height 256}
:tools-expanded? false :tools-expanded? false
:reasoning-expanded? false
:input "" :input ""
:messages [] :messages []
:status :idle :status :idle
:error nil :error nil
:pending-calls nil :pending-calls nil
;; Tool calls the server is still streaming (AG-UI's TOOL_CALL_START/ARGS/END), keyed by ;; Tool calls still streaming in (AG-UI's TOOL_CALL_START/ARGS/END), keyed by
;; toolCallId, until each is complete and moves into :pending-calls. ;; toolCallId, until complete and moved into :pending-calls.
:tool-call-buffer {} :tool-call-buffer {}
:thinking-at nil :thinking-at nil
:tool-calls-used 0} :tool-calls-used 0
;; Tic-tac-toe, entirely client side: the board (see tbd.ui.tictactoe) and whose turn it is. :tools-used-this-turn #{}}
;; Tic-tac-toe, client side only.
:ttt {:board tictactoe/new-board :ttt {:board tictactoe/new-board
:turn :x}}) :turn :x}})
+381 -189
View File
@@ -8,25 +8,31 @@
[tbd.ui.sse :as sse] [tbd.ui.sse :as sse]
[tbd.ui.tictactoe :as tictactoe])) [tbd.ui.tictactoe :as tictactoe]))
;; A `js/fetch` of `uri` (GET unless `method` is given). A `body` is sent as EDN. (defn- fetch-request
(defn- fetch-request [{:keys [uri method body]}] "GETs (or `method`s) `uri`. `body`, if given, is sent as EDN. `signal` (an AbortSignal) aborts it."
(js/fetch uri (clj->js (cond-> {:method (or method "GET")} [{:keys [uri method body signal]}]
body (assoc :headers {"Content-Type" "application/edn"} (js/fetch uri (cond-> (clj->js (cond-> {:method (or method "GET")}
:body (pr-str body)))))) body (assoc :headers {"Content-Type" "application/edn"}
:body (pr-str body))))
signal (doto (aset "signal" signal)))))
(defn- response-map [resp text] (defn- response-map [resp text]
{:ok? (.-ok resp) :status (.-status resp) :body text}) {:ok? (.-ok resp) :status (.-status resp) :body text})
;; Effect: request `uri` (GET unless `method` is given), then dispatch (defn- do-fetch!
;; `(conj on-response {:ok? bool :status int-or-nil :body string})`. A `body` is sent as EDN. "Fetches `request` (see fetch-request), dispatching `(conj on-response {:ok? :status :body})`.
;; Network failures come back as `{:ok? false :status nil :body <message>}`. A network failure dispatches `{:ok? false :status nil :body message}`."
(rf/reg-fx [{:keys [on-response] :as request}]
::fetch (-> (fetch-request request)
(fn [{:keys [on-response] :as request}] (.then (fn [resp]
(-> (fetch-request request) (.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %))))))
(.then (fn [resp] (.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)})))))
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %))))))
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)})))))) (rf/reg-fx ::fetch do-fetch!)
;; Same as ::fetch, with its own id so chat-history saves don't collide with the chat stream's
;; requests in tests.
(rf/reg-fx ::persist-chat do-fetch!)
(def ^:private connection-lost {:type "RUN_ERROR" :message "the connection was lost"}) (def ^:private connection-lost {:type "RUN_ERROR" :message "the connection was lost"})
@@ -35,21 +41,23 @@
#{"RUN_FINISHED" "RUN_ERROR"}) #{"RUN_FINISHED" "RUN_ERROR"})
(defn- read-events! (defn- read-events!
"Dispatches `(conj on-event event)` for each AG-UI event (see tbd.ui.sse, tbd.chat.routes) in the "Dispatches `(conj on-event event)` for each AG-UI event decoded from `reader`, as it arrives. A
body read by `reader`, as they arrive. A body that ends without a RUN_FINISHED or RUN_ERROR event stream that ends without a RUN_FINISHED/RUN_ERROR event dispatches a RUN_ERROR of its own — unless
(the connection dropped) is a RUN_ERROR event of its own, so whoever waits for the end always `signal` was aborted, in which case nothing more is dispatched."
gets one." [reader on-event ^js signal]
[reader on-event]
(let [decoder (js/TextDecoder. "utf-8") (let [decoder (js/TextDecoder. "utf-8")
ended? (atom false) ended? (atom false)
lost! #(when-not @ended? aborted? #(.-aborted signal)
lost! #(when-not (or @ended? (aborted?))
(reset! ended? true) (reset! ended? true)
(rf/dispatch (conj on-event connection-lost))) (rf/dispatch (conj on-event connection-lost)))
step (fn step [pending] step (fn step [pending]
(-> (.read reader) (-> (.read reader)
(.then (fn [^js chunk] (.then (fn [^js chunk]
(if (.-done chunk) (cond
(lost!) (aborted?) (some-> (.-cancel reader) (.call reader) (.catch (fn [_] nil)))
(.-done chunk) (lost!)
:else
(let [[events pending] (sse/parse (str pending (.decode decoder (.-value chunk) (let [[events pending] (sse/parse (str pending (.decode decoder (.-value chunk)
#js {:stream true})))] #js {:stream true})))]
(doseq [event events] (doseq [event events]
@@ -59,34 +67,84 @@
(.catch (fn [_] (lost!)))))] (.catch (fn [_] (lost!)))))]
(step ""))) (step "")))
;; Effect: like ::fetch, for a response that is a stream of server-sent events. While it comes in, ;; The in-flight stream's AbortController, for ::abort-stream. Only one stream runs at a time.
;; `(conj on-event event)` is dispatched for each event, as a map (see read-events!). When the (defonce ^:private stream-controller (atom nil))
;; request fails instead (a network error or a status that isn't 2xx: no stream came),
;; `(conj on-response {:ok? false :status int-or-nil :body string})` is dispatched, as ::fetch does. ;; Like ::fetch, for a streamed response: dispatches `(conj on-event event)` for each event as it
;; arrives (see read-events!), or `(conj on-response {:ok? false ...})` if the request itself fails.
;; Nothing more is dispatched once ::abort-stream has run.
(rf/reg-fx (rf/reg-fx
::fetch-stream ::fetch-stream
(fn [{:keys [on-event on-response] :as request}] (fn [{:keys [on-event on-response] :as request}]
(-> (fetch-request request) (let [controller (js/AbortController.)
(.then (fn [resp] signal (.-signal controller)
(if (.-ok resp) respond! #(when-not (.-aborted signal) (rf/dispatch (conj on-response %)))]
(read-events! (.getReader (.-body resp)) on-event) (reset! stream-controller controller)
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %))))))) (-> (fetch-request (assoc request :signal signal))
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)})))))) (.then (fn [resp]
(if (.-ok resp)
(read-events! (.getReader (.-body resp)) on-event signal)
(.then (.text resp) #(respond! (response-map resp %))))))
(.catch #(respond! {:ok? false :status nil :body (.-message %)}))))))
;; Coeffect: the URL's fragment, which says which page to start on. ;; Aborts the in-flight stream, if any. Closing the connection is what tells the server to stop
;; the LLM (see tbd.chat.routes/event-stream).
(rf/reg-fx
::abort-stream
(fn [_]
(when-let [controller @stream-controller]
(reset! stream-controller nil)
(.abort controller))))
;; The URL's fragment, which says which page to start on.
(rf/reg-cofx (rf/reg-cofx
::hash ::hash
(fn [cofx _] (fn [cofx _]
(assoc cofx :hash js/location.hash))) (assoc cofx :hash js/location.hash)))
;; Coeffect: the time now, in ms since the epoch.
(rf/reg-cofx (rf/reg-cofx
::now ::now
(fn [cofx _] (fn [cofx _]
(assoc cofx :now (js/Date.now)))) (assoc cofx :now (js/Date.now))))
;; Effect: show the page the URL names whenever it changes (a link was followed, or Back and (def ^:private chat-ui-storage-key "tbd.chat-ui")
;; Forward were pressed). Only one listener is ever installed, however often this runs.
;; The chat widget's saved :open?/:size, or nil if there is none (or it's unreadable).
(rf/reg-cofx
::chat-ui-storage
(fn [cofx _]
(assoc cofx ::chat-ui
(try
(some-> (.getItem js/localStorage chat-ui-storage-key)
reader/read-string
(select-keys [:open? :size]))
(catch :default _ nil)))))
(rf/reg-fx
::persist-chat-ui
(fn [chat-ui]
(.setItem js/localStorage chat-ui-storage-key (pr-str chat-ui))))
(def ^:private ttt-storage-key "tbd.ttt")
;; The tic-tac-toe :board/:turn as last saved, or nil.
(rf/reg-cofx
::ttt-storage
(fn [cofx _]
(assoc cofx ::ttt
(try
(some-> (.getItem js/localStorage ttt-storage-key)
reader/read-string
(select-keys [:board :turn]))
(catch :default _ nil)))))
(rf/reg-fx
::persist-ttt
(fn [ttt]
(.setItem js/localStorage ttt-storage-key (pr-str ttt))))
;; Shows the page named by the URL whenever it changes (a link, or Back/Forward). Installs at
;; most one listener, however often this runs.
(defonce ^:private hash-listener (atom nil)) (defonce ^:private hash-listener (atom nil))
(rf/reg-fx (rf/reg-fx
@@ -97,7 +155,6 @@
(reset! hash-listener #(rf/dispatch [::hash-changed js/location.hash])) (reset! hash-listener #(rf/dispatch [::hash-changed js/location.hash]))
(.addEventListener js/window "hashchange" @hash-listener))) (.addEventListener js/window "hashchange" @hash-listener)))
;; Effect: put `hash` in the URL, which is how a page gets its own address (and a Back button).
(rf/reg-fx (rf/reg-fx
::set-hash ::set-hash
(fn [hash] (fn [hash]
@@ -105,22 +162,22 @@
(rf/reg-event-fx (rf/reg-event-fx
::initialize ::initialize
[(rf/inject-cofx ::hash)] [(rf/inject-cofx ::hash) (rf/inject-cofx ::chat-ui-storage) (rf/inject-cofx ::ttt-storage)]
(fn [{:keys [hash]} _] (fn [{:keys [hash ::chat-ui ::ttt]} _]
{:db (assoc db/default-db :page (pages/hash->page hash)) {:db (cond-> (assoc db/default-db :page (pages/hash->page hash))
chat-ui (update :chat merge chat-ui)
ttt (update :ttt merge ttt))
::listen-for-hash true ::listen-for-hash true
:dispatch [::load-user]})) :dispatch [::load-user]}))
;; --- Pages --- ;; --- Pages ---
;; The URL changed (a link was followed, or Back was pressed): show the page it names.
(rf/reg-event-db (rf/reg-event-db
::hash-changed ::hash-changed
(fn [db [_ hash]] (fn [db [_ hash]]
(assoc db :page (pages/hash->page hash)))) (assoc db :page (pages/hash->page hash))))
;; Go to a page without a link, as the browser tools do. The page changes right away; the URL ;; Navigates without a link: the page changes right away, and the URL follows.
;; follows, and its change event finds the page already shown.
(rf/reg-event-fx (rf/reg-event-fx
::navigate ::navigate
(fn [{:keys [db]} [_ page]] (fn [{:keys [db]} [_ page]]
@@ -172,7 +229,7 @@
(cond (cond
ok? {:db (assoc db :user {:status :logged-in ok? {:db (assoc db :user {:status :logged-in
:login (:login (reader/read-string (:body resp)))}) :login (:login (reader/read-string (:body resp)))})
:dispatch [::load-todos]} :dispatch-n [[::load-chat-history] [::load-todos]]}
(= 401 status) {:db (assoc db :user {:status :anonymous})} (= 401 status) {:db (assoc db :user {:status :anonymous})}
:else {:db (assoc db :user {:status :error :message (error-message resp)})}))) :else {:db (assoc db :user {:status :error :message (error-message resp)})})))
@@ -182,9 +239,10 @@
{::fetch {:uri "/auth/logout" :method "POST" :on-response [::logout-response]}})) {::fetch {:uri "/auth/logout" :method "POST" :on-response [::logout-response]}}))
(defn- reset-chat (defn- reset-chat
"An empty conversation, in a panel that is as open (or closed), and as big, as it was." "An empty conversation, keeping the panel's :open?/:size/:tools-expanded?/:reasoning-expanded?."
[db] [db]
(assoc db :chat (merge (:chat db/default-db) (select-keys (:chat db) [:open? :size :tools-expanded?])))) (assoc db :chat (merge (:chat db/default-db)
(select-keys (:chat db) [:open? :size :tools-expanded? :reasoning-expanded?]))))
(rf/reg-event-db (rf/reg-event-db
::logout-response ::logout-response
@@ -213,8 +271,8 @@
(update db :todos assoc :status :ok :items (:todos (reader/read-string body))) (update db :todos assoc :status :ok :items (:todos (reader/read-string body)))
(update db :todos assoc :status :error :error (error-message resp))))) (update db :todos assoc :status :error :error (error-message resp)))))
;; A failed change keeps the list as it is and shows the message. A 401 means the session ;; A 401 means the session expired: fall back to the logged-out view. Otherwise the list stays,
;; expired, so fall back to the logged-out view (which hides the todos). ;; with the error shown.
(rf/reg-event-db (rf/reg-event-db
::todo-failed ::todo-failed
(fn [db [_ {:keys [status] :as resp}]] (fn [db [_ {:keys [status] :as resp}]]
@@ -278,152 +336,217 @@
;; --- Chat --- ;; --- Chat ---
;; The chat is a loop when the LLM uses the page's tools (see tbd.ui.model-context): the reply to a ;; The chat loops when the LLM calls tools of the page (tbd.ui.model-context): the page runs them
;; message can be a request for tool calls instead of (or after) text; the page makes the calls, ;; and resends the conversation, until the LLM answers without asking for more.
;; and sends the conversation again, now with their results, for the LLM to go on from. It does
;; that until the LLM answers without asking for tools.
(def ^:private max-sent-messages (def ^:private max-sent-messages
"How much of the conversation goes to the server with each message (its limit is "How much of the conversation goes to the server per request (bounded by
tbd.chat.schema/max-messages, which this stays within), the most recent part." tbd.chat.schema/max-messages), the most recent part."
40) 40)
(def ^:private max-tool-calls-per-turn (def ^:private max-tool-calls-per-turn
"How many tool calls the LLM may make in answer to one message of the user's, before the page "Max tool calls the LLM may make answering one message, before the turn is stopped as a runaway
stops it. A model that keeps calling tools never answers, and every call is something done on the loop. (A turn is at most 1 + this many assistant messages and this many results, so it always
user's page. (A turn is at most 1 + this many assistant messages and this many results, so it is stays within max-sent-messages.)"
always inside `max-sent-messages`.)"
12) 12)
(def ^:private max-tool-result-length (def ^:private max-tool-result-length
"The longest result of a tool that goes to the LLM (tbd.chat.schema/max-message-length)." "The longest tool result sent to the LLM (tbd.chat.schema/max-message-length)."
8000) 8000)
(def ^:private truncated " … (truncated)") (def ^:private truncated " … (truncated)")
(defn- fit-result (defn- display-text
"A tool's result text as the content of a message: never empty, and no longer than the server "`text` for the chat log, never empty. Kept in full here; only what leaves the tab is cut down,
takes." by fit-result."
[text] [text]
(cond (if (str/blank? text) "(no output)" text))
(str/blank? text) "(no output)"
(> (count text) max-tool-result-length) (str (subs text 0 (- max-tool-result-length (count truncated))) (defn- fit-result
truncated) "`text`, cut to max-tool-result-length, for a tool result about to leave the tab."
:else text)) [text]
(if (> (count text) max-tool-result-length)
(str (subs text 0 (- max-tool-result-length (count truncated))) truncated)
text))
(defonce ^:private id-counter (atom 0)) (defonce ^:private id-counter (atom 0))
(defn- next-id (defn- next-id
"An id unique within this page's session, for an AG-UI message: they only have to identify a "A fresh id for an AG-UI message, unique within this page's session."
message within one run's conversation, never across page loads."
[] []
(str "m" (swap! id-counter inc))) (str "m" (swap! id-counter inc)))
(defn- wire-message (defn- wire-message
"A message of the conversation as AG-UI's Message has it (see tbd.chat.schema/Message: user, "A conversation message as AG-UI's Message (tbd.chat.schema/Message). A tool result is fit to
assistant with `toolCalls`, or tool)." the server's limit here; the browser's own copy stays whole."
[{:keys [role content tool-calls tool-call-id]}] [{:keys [role content tool-calls tool-call-id]}]
(cond-> {:id (next-id) :role role} (cond-> {:id (next-id) :role role}
(= "tool" role) (assoc :toolCallId tool-call-id :content content) (= "tool" role) (assoc :toolCallId tool-call-id :content (fit-result content))
(not= "tool" role) (assoc :content content) (not= "tool" role) (assoc :content content)
(seq tool-calls) (assoc :toolCalls (mapv (fn [{:keys [id name arguments]}] (seq tool-calls) (assoc :toolCalls (mapv (fn [{:keys [id name arguments]}]
{:id id :type "function" {:id id :type "function"
:function {:name name :arguments arguments}}) :function {:name name :arguments arguments}})
tool-calls)))) tool-calls))))
(defn- recent (defn- windowed
"The most recent `max-sent-messages` of `messages`, without the results of calls whose asking "The most recent `n` of `messages`, dropping a leading tool result whose call fell out of the
is cut off: the LLM server refuses a result that answers nothing." window."
[messages] [n messages]
(drop-while #(= "tool" (:role %)) (take-last max-sent-messages messages))) (drop-while #(= "tool" (:role %)) (take-last n messages)))
(def ^:private stale-result (defn- recent [messages]
"What the LLM is sent in place of a result from before the user's last message." (windowed max-sent-messages messages))
"(out of date: this was read on an earlier turn and the page may have changed since. Call the tool again for the current state.)")
(defn- without-stale-results (def ^:private max-stored-messages
"`messages` with the content of the tool results from before the user's last message replaced by "How much of the conversation is saved for \"restore my last session\" (bounded by
`stale-result`. A result is a snapshot of the page when the tool ran, and the user can change the tbd.chat.schema/max-history-messages): more than max-sent-messages, since this is scrollback."
page between messages, by hand or on another page; a model that is still shown the old snapshot 100)
goes by it, even when told it is wrong. What it did stays (its calls, its own words), only what
it read goes. The results of this turn stay: a chain of calls goes on from the ones before (def ^:private max-stored-content-length
(list, then act on an id)." "The longest tool result or reasoning kept in a saved conversation
(tbd.chat.schema/max-history-content-length): the full log, for \"Expand\"/\"Show reasoning\"
after a reload, not cut to what the LLM sees."
100000)
(def ^:private max-stored-length
"Total length of a saved conversation, printed (tbd.chat.schema/max-history-length)."
1000000)
(declare only-reasoning?)
(defn- fit-stored [text]
(if (> (count text) max-stored-content-length)
(str (subs text 0 (- max-stored-content-length (count truncated))) truncated)
text))
(defn- storable
"The most recent `max-stored-messages` of `messages`, as /api/chat/history's PUT wants them.
Drops replies that came to nothing but reasoning, and fits tool results/reasoning to
max-stored-content-length. If the total is still over max-stored-length, drops whole oldest
turns (never a result without its call, or a reply without its question)."
[messages] [messages]
(let [last-user (or (last (keep-indexed (fn [i {:keys [role]}] (when (= "user" role) i)) messages)) 0)] (let [fitted (into []
(into [] (map-indexed (fn [i message] (comp (remove only-reasoning?)
(cond-> message (map (fn [message]
(and (< i last-user) (= "tool" (:role message))) (cond-> message
(assoc :content stale-result)))) (= "tool" (:role message)) (update :content fit-stored)
messages))) (:thinking message) (update :thinking fit-stored)))))
(windowed max-stored-messages messages))
sizes (mapv #(inc (count (pr-str %))) fitted)]
(loop [messages fitted
size (reduce + 2 sizes)
sizes sizes]
(if (and (> size max-stored-length) (seq messages))
(let [n (inc (count (take-while #(not= "user" (:role %)) (rest messages))))]
(recur (subvec messages n) (- size (reduce + (take n sizes))) (subvec sizes n)))
messages))))
;; Best-effort save of the conversation for /api/chat/history to hand back on next login. Never
;; blocks anything: a failure is retried at the next natural save point.
(defn- save-chat-fx [db]
{:uri "/api/chat/history" :method "PUT"
:body {:messages (storable (get-in db [:chat :messages]))}
:on-response [::save-chat-history-response]})
(rf/reg-event-db
::save-chat-history-response
(fn [db [_ {:keys [status]}]]
(if (= 401 status)
(-> db (assoc :user {:status :anonymous}) reset-chat)
db)))
(defn- wire-tool (defn- wire-tool
"A tool as AG-UI's Tool has it (see tbd.chat.schema/Tool): `parameters`, not MCP's `inputSchema`." "A tool as AG-UI's Tool has it (tbd.chat.schema/Tool): `parameters`, not MCP's `inputSchema`."
[{:keys [name description inputSchema]}] [{:keys [name description inputSchema]}]
(cond-> {:name name :parameters inputSchema} (cond-> {:name name :parameters inputSchema}
description (assoc :description description))) description (assoc :description description)))
;; The request that sends the conversation: an AG-UI RunAgentInput. It goes with the page being ;; An AG-UI RunAgentInput: the page's name (as `context`, so the LLM knows where the user is), the
;; shown (as a `context` entry, for the LLM to know where the user is) and the tools that page ;; tools that page offers, and its current state (model-context/current-state), so the LLM never
;; offers the LLM. Both are read from the db every time, so a conversation that moves between ;; has to spend a call finding out. Read from the db each time, so a conversation that moves
;; pages (the LLM's own `navigate`, say) always tells the LLM where it is now. ;; between pages always reflects where it is now.
(defn- chat-request [db messages] (defn- chat-request [db messages]
(let [tools (model-context/definitions (:page db))] (let [page (:page db)
once (model-context/once-per-turn-names page)
used (get-in db [:chat :tools-used-this-turn])
tools (remove (comp #(and (once %) (used %)) :name) (model-context/definitions page))
state (model-context/current-state page)
messages (remove only-reasoning? messages)]
{:uri "/api/chat" :method "POST" {:uri "/api/chat" :method "POST"
:body (cond-> {:threadId (next-id) :runId (next-id) :body (cond-> {:threadId (next-id) :runId (next-id)
:messages (mapv wire-message (without-stale-results (recent messages))) :messages (mapv wire-message (recent messages))
:context [{:description "page" :value (name (:page db))}]} :context [{:description "page" :value (name page)}]}
(seq tools) (assoc :tools (mapv wire-tool tools))) (seq tools) (assoc :tools (mapv wire-tool tools))
(seq state) (assoc :state state))
:on-event [::chat-event] :on-event [::chat-event]
:on-response [::chat-response]})) :on-response [::chat-response]}))
;; Restores the last session, right after login. Merged in only if nothing has been said in this
;; page load yet, so a slow response can't stomp on a conversation already started.
(rf/reg-event-fx
::load-chat-history
(fn [_ _]
{::fetch {:uri "/api/chat/history" :on-response [::chat-history-response]}}))
(rf/reg-event-db (rf/reg-event-db
::chat-history-response
(fn [db [_ {:keys [ok? body]}]]
(if (and ok? (empty? (get-in db [:chat :messages])))
(assoc-in db [:chat :messages] (:messages (reader/read-string body)))
db)))
(rf/reg-event-fx
::chat-toggle ::chat-toggle
(fn [db _] (fn [{:keys [db]} _]
(update-in db [:chat :open?] not))) (let [db (update-in db [:chat :open?] not)]
{:db db
::persist-chat-ui (select-keys (:chat db) [:open? :size])})))
;; The panel is dragged to `width` px wide and its conversation `height` px high (the view keeps (rf/reg-event-fx
;; them within the window).
(rf/reg-event-db
::chat-resize ::chat-resize
(fn [db [_ width height]] (fn [{:keys [db]} [_ width height]]
(assoc-in db [:chat :size] {:width width :height height}))) (let [db (assoc-in db [:chat :size] {:width width :height height})]
{:db db
::persist-chat-ui (select-keys (:chat db) [:open? :size])})))
;; Whether the tool calls and results show whole, or each cut to one line.
(rf/reg-event-db (rf/reg-event-db
::chat-toggle-tools ::chat-toggle-tools
(fn [db _] (fn [db _]
(update-in db [:chat :tools-expanded?] not))) (update-in db [:chat :tools-expanded?] not)))
(rf/reg-event-db
::chat-toggle-reasoning
(fn [db _]
(update-in db [:chat :reasoning-expanded?] not)))
(rf/reg-event-db (rf/reg-event-db
::chat-set-input ::chat-set-input
(fn [db [_ input]] (fn [db [_ input]]
(assoc-in db [:chat :input] input))) (assoc-in db [:chat :input] input)))
;; Only one message is in flight at a time, and a blank one isn't sent.
(rf/reg-event-fx (rf/reg-event-fx
::chat-send ::chat-send
(fn [{:keys [db]} _] (fn [{:keys [db]} _]
(let [{:keys [input messages status]} (:chat db) (let [{:keys [input messages status]} (:chat db)
content (str/trim input)] content (str/trim input)]
(when (and (not= :loading status) (seq content)) (when (and (not= :loading status) (seq content))
(let [messages (conj messages {:role "user" :content content})] (let [messages (conj messages {:role "user" :content content})
{:db (update db :chat assoc :messages messages :input "" :status :loading :error nil db (update db :chat assoc :messages messages :input "" :status :loading :error nil
:tool-calls-used 0) :tool-calls-used 0 :tools-used-this-turn #{})]
::fetch-stream (chat-request db messages)}))))) {:db db
::fetch-stream (chat-request db messages)
::persist-chat (save-chat-fx db)})))))
(defn- only-reasoning? (defn- only-reasoning?
"Whether `message` is a reply that has come to nothing but the reasoning for it: there is nothing "Whether `message` is a reply that has come to nothing but reasoning: no content, no tool calls
in it for the LLM to be sent (the server refuses an assistant message that says and asks for (the server refuses a message that says and asks for nothing)."
nothing)."
[{:keys [role content tool-calls]}] [{:keys [role content tool-calls]}]
(and (= "assistant" role) (str/blank? content) (empty? tool-calls))) (and (= "assistant" role) (str/blank? content) (empty? tool-calls)))
(defn- chat-failed (defn- chat-failed
"The conversation after a send failed with `message`. If the last message is the user's (nothing "The conversation after a send failed with `message`. If nothing of the reply had come, the
of the reply had come, but perhaps some reasoning, which goes), it leaves the conversation again unanswered user message goes back into the input (so retrying is just pressing Send); otherwise
and goes back in the input, so trying once more is pressing Send (and the next message doesn't whatever came stays, and the next message follows it."
follow one nobody answered). If part of the reply had come, or the tools' results had been sent,
that stays, and the next message follows it."
[db message] [db message]
(let [messages (get-in db [:chat :messages]) (let [messages (get-in db [:chat :messages])
messages (cond-> messages (only-reasoning? (peek messages)) pop) messages (cond-> messages (only-reasoning? (peek messages)) pop)
@@ -433,22 +556,21 @@
(when unanswered? (when unanswered?
{:messages (pop messages) :input (:content (peek messages))})))) {:messages (pop messages) :input (:content (peek messages))}))))
;; The server answered without a stream: the request failed. A 401 means the session expired: fall ;; The server answered without a stream: the request failed. A 401 means the session expired.
;; back to the logged-out view. A response nobody is waiting for (the conversation was reset since, ;; A response nobody is waiting for (the conversation was reset since) is dropped.
;; by logging out) is dropped. (rf/reg-event-fx
(rf/reg-event-db
::chat-response ::chat-response
(fn [db [_ {:keys [status] :as resp}]] (fn [{:keys [db]} [_ {:keys [status] :as resp}]]
(cond (cond
(not= :loading (get-in db [:chat :status])) db (not= :loading (get-in db [:chat :status])) {:db db}
(= 401 status) (-> db (assoc :user {:status :anonymous}) reset-chat) (= 401 status) {:db (-> db (assoc :user {:status :anonymous}) reset-chat)}
:else (chat-failed db (error-message resp))))) :else (let [db (chat-failed db (error-message resp))]
{:db db ::persist-chat (save-chat-fx db)}))))
(defn- append-to-reply (defn- append-to-reply
"The conversation's assistant message being written, with `text` added to its content. The first "The conversation with `text` added to the assistant message being written (starting one if
piece starts the message, the rest are added to it. Leading whitespace is dropped while nothing needed). Leading whitespace is dropped until the message has content (a reasoning model often
has been said yet (the model often opens its answer with a stray blank line right after opens with a stray blank line), then preserved."
reasoning), but preserved once the message has content, since it may be meaningful there."
[db text] [db text]
(update-in db [:chat :messages] (update-in db [:chat :messages]
(fn [messages] (fn [messages]
@@ -458,9 +580,19 @@
(str content (if (str/blank? content) (str/triml text) text)))) (str content (if (str/blank? content) (str/triml text) text))))
(conj messages {:role "assistant" :content (str/triml text)}))))) (conj messages {:role "assistant" :content (str/triml text)})))))
(defn- append-reasoning
"Like append-to-reply, but onto :thinking, kept apart from :content so \"Show reasoning\" can
reveal it for the right reply."
[db text]
(update-in db [:chat :messages]
(fn [messages]
(if (= "assistant" (:role (peek messages)))
(update messages (dec (count messages)) update :thinking str text)
(conj messages {:role "assistant" :content "" :thinking text})))))
(defn- with-tool-calls (defn- with-tool-calls
"The conversation with the calls the LLM asked for: on the reply's text (the message it "The conversation with `calls` attached to the reply (on its text, or a fresh message if it said
started), or on a message of their own when it said nothing." nothing)."
[messages calls] [messages calls]
(if (= "assistant" (:role (peek messages))) (if (= "assistant" (:role (peek messages)))
(update messages (dec (count messages)) assoc :tool-calls calls) (update messages (dec (count messages)) assoc :tool-calls calls)
@@ -469,33 +601,50 @@
(defn- tool-message [{:keys [id name content error?]}] (defn- tool-message [{:keys [id name content error?]}]
{:role "tool" :tool-call-id id :name name :content content :error? (boolean error?)}) {:role "tool" :tool-call-id id :name name :content content :error? (boolean error?)})
(defn- blocked-calls
"`calls`, each marked `:blocked?` when it names a once-per-turn tool (model-context/once-per-turn-names)
already used this turn, or by an earlier call in this same batch."
[once used calls]
(first (reduce (fn [[marked seen] {:keys [name] :as call}]
(let [counts? (once name)]
[(conj marked (cond-> call (and counts? (or (used name) (seen name))) (assoc :blocked? true)))
(cond-> seen counts? (conj name))]))
[[] #{}] calls)))
(defn- finish-reply (defn- finish-reply
"The reply is complete. Without calls that is all; with them, they are made (see ::call-tools) "The reply is complete. With no calls, that's it. With calls, runs them (::call-tools) — except
and the conversation goes on when they are done, unless this turn has used all the calls it may." blocked ones (blocked-calls), refused without running — unless this turn has already used all
its tool calls (max-tool-calls-per-turn), in which case the turn is stopped instead."
[db] [db]
(let [{:keys [pending-calls tool-calls-used]} (:chat db) (let [{:keys [pending-calls tool-calls-used]} (:chat db)
used (+ (or tool-calls-used 0) (count pending-calls)) used (+ (or tool-calls-used 0) (count pending-calls))
page (:page db)
once (model-context/once-per-turn-names page)
calls (blocked-calls once (get-in db [:chat :tools-used-this-turn]) pending-calls)
newly-used (into #{} (comp (remove :blocked?) (map :name) (filter once)) calls)
db (update db :chat assoc :pending-calls nil :thinking-at nil)] db (update db :chat assoc :pending-calls nil :thinking-at nil)]
(cond (cond
(empty? pending-calls) (empty? pending-calls)
{:db (assoc-in db [:chat :status] :idle)} (let [db (assoc-in db [:chat :status] :idle)]
{:db db ::persist-chat (save-chat-fx db)})
(> used max-tool-calls-per-turn) (> used max-tool-calls-per-turn)
;; The calls still get their answers, for the conversation to make sense to the LLM later. (let [db (-> db
{:db (-> db (update-in [:chat :messages] with-tool-calls pending-calls)
(update-in [:chat :messages] with-tool-calls pending-calls) (update-in [:chat :messages] into
(update-in [:chat :messages] into (for [{:keys [id name]} pending-calls]
(for [{:keys [id name]} pending-calls] (tool-message {:id id :name name :error? true
(tool-message {:id id :name name :error? true :content "not run: too many tool calls in one turn"})))
:content "not run: too many tool calls in one turn"}))) (update :chat assoc :status :idle
(update :chat assoc :status :idle :error "The assistant made too many tool calls in a row, so it was stopped."))]
:error "The assistant made too many tool calls in a row, so it was stopped."))} {:db db ::persist-chat (save-chat-fx db)})
:else :else
{:db (-> db {:db (-> db
(update-in [:chat :messages] with-tool-calls pending-calls) (update-in [:chat :messages] with-tool-calls pending-calls)
(update-in [:chat :tools-used-this-turn] into newly-used)
(assoc-in [:chat :tool-calls-used] used)) (assoc-in [:chat :tool-calls-used] used))
::call-tools {:page (:page db) :calls pending-calls :on-results [::chat-tool-results]}}))) ::call-tools {:page page :calls calls :on-results [::chat-tool-results]}})))
(defn- text? [x] (defn- text? [x]
(and (string? x) (seq x))) (and (string? x) (seq x)))
@@ -512,14 +661,10 @@
call (-> (update-in [:chat :pending-calls] (fnil conj []) call) call (-> (update-in [:chat :pending-calls] (fnil conj []) call)
(update-in [:chat :tool-call-buffer] dissoc toolCallId))))) (update-in [:chat :tool-call-buffer] dissoc toolCallId)))))
;; One AG-UI event of the reply (see tbd.chat.routes, https://docs.ag-ui.com): TEXT_MESSAGE_CONTENT ;; One AG-UI event of the reply (tbd.chat.routes, https://docs.ag-ui.com): TEXT_MESSAGE_CONTENT
;; ({:delta "..."}) for the next piece of the reply (the first starts the assistant's message, the ;; and REASONING_MESSAGE_CONTENT append to the reply's :content/:thinking, TOOL_CALL_START/ARGS/END
;; rest are added to it), REASONING_MESSAGE_CONTENT for the next piece of the model's reasoning ;; build up :tool-call-buffer, and RUN_FINISHED/RUN_ERROR end the turn. Events nobody is waiting
;; (which is not kept: the user only sees that the model is thinking, and for as long as pieces ;; for (the conversation was reset since) are dropped.
;; keep coming, which :thinking-at, the time the last one came, is for),
;; TOOL_CALL_START/TOOL_CALL_ARGS/TOOL_CALL_END as it asks for tools to be called (accumulated in
;; :tool-call-buffer until each call is complete), and last RUN_FINISHED or RUN_ERROR. Events
;; nobody is waiting for (the conversation was reset since) are dropped.
(rf/reg-event-fx (rf/reg-event-fx
::chat-event ::chat-event
[(rf/inject-cofx ::now)] [(rf/inject-cofx ::now)]
@@ -531,46 +676,52 @@
(cond (cond
(not loading?) {:db db} (not loading?) {:db db}
(= "TEXT_MESSAGE_CONTENT" type) {:db (append-to-reply db (:delta event))} (= "TEXT_MESSAGE_CONTENT" type) {:db (append-to-reply db (:delta event))}
(= "REASONING_MESSAGE_CONTENT" type)
{:db (cond-> db (text? (:delta event)) (append-reasoning (:delta event)))}
(= "TOOL_CALL_START" type) {:db (start-tool-call db event)} (= "TOOL_CALL_START" type) {:db (start-tool-call db event)}
(= "TOOL_CALL_ARGS" type) {:db (append-tool-call-args db event)} (= "TOOL_CALL_ARGS" type) {:db (append-tool-call-args db event)}
(= "TOOL_CALL_END" type) {:db (end-tool-call db event)} (= "TOOL_CALL_END" type) {:db (end-tool-call db event)}
(= "RUN_FINISHED" type) (finish-reply db) (= "RUN_FINISHED" type) (finish-reply db)
(= "RUN_ERROR" type) {:db (chat-failed db (:message event))} (= "RUN_ERROR" type) (let [db (chat-failed db (:message event))]
{:db db ::persist-chat (save-chat-fx db)})
:else {:db db})))) :else {:db db}))))
(def ^:private blocked-message
"not run: this only runs once per message, and already has this turn — answer instead of calling it again")
(defn- call-all (defn- call-all
"A promise of the results of `calls`, in order, as {:id :name :content :error?}. One after the "A promise of the results of `calls`, in order, as {:id :name :content :error?}. Run one after
other: the tools work on the same page (one may need the page the last one opened). Only the the other (a tool may need the page the last one left). A call marked :blocked? by blocked-calls
tools `page` offers can be called." never reaches the page."
[page calls] [page calls]
(reduce (fn [results {:keys [id name arguments]}] (reduce (fn [results {:keys [id name arguments blocked?]}]
(.then results (.then results
(fn [done] (fn [done]
(.then (model-context/call! page name arguments) (if blocked?
(fn [{:keys [text error?]}] (conj done {:id id :name name :content blocked-message :error? true})
(conj done {:id id :name name :content (fit-result text) :error? error?})))))) (.then (model-context/call! page name arguments)
(fn [{:keys [text error?]}]
(conj done {:id id :name name :content (display-text text) :error? error?})))))))
(js/Promise.resolve []) (js/Promise.resolve [])
calls)) calls))
;; Effect: make the tool calls the LLM asked for, on the tools `page` (the one being shown) offers, ;; Runs the LLM's tool calls on `page`'s tools, and dispatches `(conj on-results results)` when
;; and dispatch `(conj on-results results)` when all are done: one {:id :name :content :error?} ;; done: one {:id :name :content :error?} per call. A call that can't be made (unknown tool, bad
;; for each, in order. A call that can't be made (an unknown tool, one the page doesn't offer, ;; arguments, a tool that throws) comes back as an :error? result, for the LLM to read.
;; arguments that aren't JSON, a tool that fails) is a result with :error?, for the LLM to read.
(rf/reg-fx (rf/reg-fx
::call-tools ::call-tools
(fn [{:keys [page calls on-results]}] (fn [{:keys [page calls on-results]}]
(.then (call-all page calls) #(rf/dispatch (conj on-results %))))) (.then (call-all page calls) #(rf/dispatch (conj on-results %)))))
(defn- answers? (defn- answers?
"Whether `results` are for the calls the conversation is waiting on. Results nobody waits for "Whether `results` answer the calls the conversation is waiting on (not a stale response after
(the conversation was reset while the tools ran) are not." the conversation was reset while the tools ran)."
[db results] [db results]
(let [calls (:tool-calls (peek (get-in db [:chat :messages])))] (let [calls (:tool-calls (peek (get-in db [:chat :messages])))]
(and (= :loading (get-in db [:chat :status])) (and (= :loading (get-in db [:chat :status]))
(seq calls) (seq calls)
(= (map :id calls) (map :id results))))) (= (map :id calls) (map :id results)))))
;; The tools have run: their results join the conversation, and it goes to the LLM again.
(rf/reg-event-fx (rf/reg-event-fx
::chat-tool-results ::chat-tool-results
(fn [{:keys [db]} [_ results]] (fn [{:keys [db]} [_ results]]
@@ -580,18 +731,56 @@
{:db db {:db db
::fetch-stream (chat-request db (get-in db [:chat :messages]))})))) ::fetch-stream (chat-request db (get-in db [:chat :messages]))}))))
;; Starts the conversation over. Not while a reply is on its way: it would land in the new one. (def ^:private halted-result
(rf/reg-event-db "(halted by the user before the result came back: this call may or may not have taken effect)")
;; Marks the reply :halted? and answers any in-flight tool calls with halted-result, since the LLM
;; refuses a call left unanswered.
(defn- halt-reply [messages]
(let [{:keys [role tool-calls]} (peek messages)]
(cond
(not= "assistant" role)
(conj messages {:role "assistant" :content "" :halted? true})
(seq tool-calls)
(into (update messages (dec (count messages)) assoc :halted? true)
(for [{:keys [id name]} tool-calls]
(tool-message {:id id :name name :error? true :content halted-result})))
:else (update messages (dec (count messages)) assoc :halted? true))))
;; The user halts a reply mid-way, to steer it with the next message: stops the stream
;; (::abort-stream), and marks what came so far :halted? (see halt-reply) instead of discarding it.
(rf/reg-event-fx
::chat-halt
(fn [{:keys [db]} _]
(if-not (= :loading (get-in db [:chat :status]))
{:db db}
(let [db (-> db
(update-in [:chat :messages] halt-reply)
(update :chat assoc :status :idle :error nil :pending-calls nil
:tool-call-buffer {} :thinking-at nil))]
{:db db
::abort-stream true
::persist-chat (save-chat-fx db)}))))
;; Starts a new session (not while a reply is in flight), clearing the stored history too.
(rf/reg-event-fx
::chat-clear ::chat-clear
(fn [db _] (fn [{:keys [db]} _]
(if (= :loading (get-in db [:chat :status])) (if (= :loading (get-in db [:chat :status]))
db {:db db}
(reset-chat db)))) {:db (reset-chat db)
::persist-chat {:uri "/api/chat/history" :method "DELETE" :on-response [::clear-chat-history-response]}})))
(rf/reg-event-db
::clear-chat-history-response
(fn [db _] db))
;; --- MCP setup page --- ;; --- MCP setup page ---
;; Effect: put `text` on the clipboard. The Clipboard API only exists on secure origins (https ;; Puts `text` on the clipboard. Requires a secure origin (https or localhost); failures are
;; or localhost), so the view doesn't offer the button without it; failures are ignored. ;; ignored.
(rf/reg-fx (rf/reg-fx
::copy-to-clipboard ::copy-to-clipboard
(fn [text] (fn [text]
@@ -611,16 +800,19 @@
;; --- Tic-tac-toe --- ;; --- Tic-tac-toe ---
;; An illegal move (taken cell, game over) changes nothing. (rf/reg-event-fx
(rf/reg-event-db
::ttt-move ::ttt-move
(fn [db [_ i]] (fn [{:keys [db]} [_ i]]
(let [{:keys [board turn]} (:ttt db)] (let [{:keys [board turn]} (:ttt db)]
(if-let [board' (tictactoe/move board turn i)] (if-let [board' (tictactoe/move board turn i)]
(assoc db :ttt {:board board' :turn (tictactoe/next-player turn)}) (let [ttt {:board board' :turn (tictactoe/next-player turn)}]
db)))) {:db (assoc db :ttt ttt)
::persist-ttt ttt})
{:db db}))))
(rf/reg-event-db (rf/reg-event-fx
::ttt-reset ::ttt-reset
(fn [db _] (fn [{:keys [db]} _]
(assoc db :ttt (:ttt db/default-db)))) (let [ttt (:ttt db/default-db)]
{:db (assoc db :ttt ttt)
::persist-ttt ttt})))
+189
View File
@@ -0,0 +1,189 @@
(ns tbd.ui.markdown
"Turns a chat message's Markdown into Reagent hiccup, for `chat-bubble` to show as blocks
(headings, lists, code, blockquotes, tables) and inline formatting (bold, italic, code, links)
instead of flat text. Hand-rolled rather than an npm library: not full CommonMark (no nested
lists, and a table or list has to start right after a blank line, not mid-paragraph), but
covers what a chat message actually uses.
No HTML is ever built as a string and injected (no :dangerouslySetInnerHTML, so nothing to run
a sanitizer library over either): every leaf here is a plain Clojure string, which Reagent
turns into a text node the same way any other hiccup content is, so it can never be read back
as markup. The one place a message's text becomes an attribute rather than a text node is a
link's `href`, which `safe-href` checks by hand."
(:require [clojure.string :as str]))
;; --- Block matchers (tested against a left-trimmed line) ---
(def ^:private fence-re #"^```\s*(\S*)\s*$")
(def ^:private fence-close-re #"^\s*```\s*$")
(def ^:private heading-re #"^(#{1,6})\s+(.*)$")
(def ^:private hr-re #"^(?:-{3,}|\*{3,}|_{3,})\s*$")
(def ^:private quote-re #"^>\s?(.*)$")
(def ^:private ul-re #"^[-*+]\s+(.*)$")
(def ^:private ol-re #"^\d+[.)]\s+(.*)$")
(def ^:private table-sep-re #"^\|?\s*:?-+:?\s*(\|\s*:?-+:?\s*)*\|?\s*$")
(defn- block-starter?
"Whether `line` begins a block of its own, so a paragraph reading lines one at a time stops
before it even without a blank line in between."
[line]
(let [l (str/triml line)]
(boolean (or (str/blank? l) (re-find fence-re l) (re-find heading-re l) (re-find hr-re l)
(re-find quote-re l) (re-find ul-re l) (re-find ol-re l)))))
;; --- Inline formatting ---
(def ^:private allowed-schemes #{"http" "https" "mailto" "tel"})
(defn- safe-href
"`url` if it's fine to put in an href (no scheme, i.e. relative, or one of `allowed-schemes`),
else nil: the model can write a `javascript:` link too, whether it means to or not (quoting one
from a tool result), and React itself won't stop that from running on a click."
[url]
(let [scheme (second (re-find #"^([A-Za-z][A-Za-z0-9+.-]*):" url))]
(when (or (nil? scheme) (contains? allowed-schemes (str/lower-case scheme)))
url)))
(defn- flanked?
"Whether `s` is a fit inside for an emphasis/strong span: not empty, and not padded with a
space, which is usually a stray `*` or `_` doing something else (\"3 * 4 * 5\") rather than
marking emphasis."
[s]
(and (seq s) (not (str/starts-with? s " ")) (not (str/ends-with? s " "))))
(def ^:private link-re #"^\[([^\]]*)\]\(([^)\s]+)(?:\s+\"[^\"]*\")?\)")
(defn- flush-text
"`out` with the literal text `s[from, to)` appended, if there is any."
[out s from to]
(if (< from to) (conj out (subs s from to)) out))
(defn- inline-line->hiccup
"One line's worth of inline Markdown (no newlines: see `inline->hiccup` for those) as a vector
of hiccup children: plain strings and `:code`/`:strong`/`:em`/`:a` elements."
[s]
(let [n (count s)]
(loop [i 0, flush 0, out []]
(if (>= i n)
(flush-text out s flush n)
(let [c (subs s i (inc i))
two (when (<= (+ i 2) n) (subs s i (+ i 2)))]
(cond
(= c "`")
(if-let [j (str/index-of s "`" (inc i))]
(recur (inc j) (inc j) (conj (flush-text out s flush i) [:code (subs s (inc i) j)]))
(recur (inc i) flush out))
(contains? #{"**" "__"} two)
(let [j (str/index-of s two (+ i 2))
inner (when j (subs s (+ i 2) j))]
(if (flanked? inner)
(recur (+ j 2) (+ j 2)
(conj (flush-text out s flush i) (into [:strong] (inline-line->hiccup inner))))
(recur (inc i) flush out)))
(contains? #{"*" "_"} c)
(let [j (str/index-of s c (inc i))
inner (when j (subs s (inc i) j))]
(if (flanked? inner)
(recur (inc j) (inc j)
(conj (flush-text out s flush i) (into [:em] (inline-line->hiccup inner))))
(recur (inc i) flush out)))
(= c "[")
(if-let [[whole label url] (re-find link-re (subs s i))]
(let [href (safe-href url)
label-pieces (inline-line->hiccup label)
node (if href
(into [:a {:href href :target "_blank" :rel "noopener noreferrer"}] label-pieces)
(into [:span] label-pieces))]
(recur (+ i (count whole)) (+ i (count whole)) (conj (flush-text out s flush i) node)))
(recur (inc i) flush out))
:else (recur (inc i) flush out)))))))
(defn- inline->hiccup
"`text` (possibly several lines: a paragraph's or a blockquote line's own soft-wrapped lines)
as hiccup children, a `:br` between each line, the way a bare newline reads in a chat message
someone typed without Markdown's blank-line-between-paragraphs convention in mind."
[text]
(vec (apply concat (interpose [[:br]] (map inline-line->hiccup (str/split text #"\n"))))))
;; --- Blocks ---
(defn- code-block [lang lines]
[:pre [:code (if (seq lang) {:class (str "language-" lang)} {}) (str/join "\n" lines)]])
(defn- table-cells [line]
(->> (-> (str/trim line)
(str/replace #"^\|" "")
(str/replace #"\|$" "")
(str/split #"\|"))
(mapv str/trim)))
(defn- table [header-line body-lines]
(let [header (table-cells header-line)
rows (mapv table-cells body-lines)]
[:table
[:thead (into [:tr] (map #(into [:th] (inline-line->hiccup %)) header))]
(into [:tbody] (map (fn [row] (into [:tr] (map #(into [:td] (inline-line->hiccup %)) row))) rows))]))
(declare parse-blocks)
(defn- parse-blocks
"`text`'s block-level structure, as a vector of hiccup elements."
[text]
(loop [lines (vec (str/split text #"\n")), out []]
(if (empty? lines)
out
(let [line (first lines)
trimmed (str/triml line)]
(cond
(str/blank? trimmed) (recur (subvec lines 1) out)
(re-find fence-re trimmed)
(let [lang (second (re-find fence-re trimmed))
rest-lines (subvec lines 1)
close (first (keep-indexed #(when (re-find fence-close-re %2) %1) rest-lines))
end (or close (count rest-lines))]
(recur (subvec rest-lines (min (count rest-lines) (inc end)))
(conj out (code-block lang (subvec rest-lines 0 end)))))
(re-find heading-re trimmed)
(let [[_ hashes content] (re-find heading-re trimmed)]
(recur (subvec lines 1)
(conj out (into [(keyword (str "h" (count hashes)))] (inline-line->hiccup content)))))
(re-find hr-re trimmed) (recur (subvec lines 1) (conj out [:hr]))
(re-find quote-re trimmed)
(let [quoted (take-while #(re-find quote-re (str/triml %)) lines)
inner (str/join "\n" (map #(second (re-find quote-re (str/triml %))) quoted))]
(recur (subvec lines (count quoted)) (conj out (into [:blockquote] (parse-blocks inner)))))
(re-find ul-re trimmed)
(let [items (take-while #(re-find ul-re (str/triml %)) lines)]
(recur (subvec lines (count items))
(conj out (into [:ul] (map #(into [:li] (inline-line->hiccup (second (re-find ul-re (str/triml %)))))
items)))))
(re-find ol-re trimmed)
(let [items (take-while #(re-find ol-re (str/triml %)) lines)]
(recur (subvec lines (count items))
(conj out (into [:ol] (map #(into [:li] (inline-line->hiccup (second (re-find ol-re (str/triml %)))))
items)))))
(and (str/includes? trimmed "|") (> (count lines) 1)
(re-find table-sep-re (str/triml (second lines))))
(let [body (->> (subvec lines 2) (take-while #(str/includes? (str/triml %) "|")))]
(recur (subvec lines (+ 2 (count body))) (conj out (table trimmed body))))
:else
(let [para (take-while (complement block-starter?) lines)]
(recur (subvec lines (count para))
(conj out (into [:p] (inline->hiccup (str/join "\n" (map str/trim para))))))))))))
(defn render
"`text` (Markdown, possibly blank) as a Reagent fragment, ready to use as a hiccup child."
[text]
(into [:<>] (parse-blocks (str/trim (or text "")))))
+44 -20
View File
@@ -1,26 +1,20 @@
(ns tbd.ui.model-context (ns tbd.ui.model-context
"The page's `modelContext`: the tools the page offers to an agent, as WebMCP names it (a page "The registry of tools the page's own chatbot offers its LLM, mirroring WebMCP's
registers tools with `navigator.modelContext` in the browsers that have one). Here it is the `navigator.modelContext` (tbd.ui.core registers tbd.ui.webmcp's tools here too). The chatbot
registry the page's own chatbot reads. tbd.ui.core registers the tools of tbd.ui.webmcp, which sends `definitions` (MCP's `tools/list` shape) with the conversation; tbd.ui.events intercepts
are also offered to an outside agent through the WebMCP widget; the chatbot is the same thing the LLM's requested calls and runs them via `call!`, right here in the page.
embedded in the page.
The chatbot passes the tools' metadata (`definitions`, the shape of MCP's `tools/list`) to the A tool is {:name :description :input-schema :handler :pages}. `handler` takes a map of
LLM along with the conversation. The LLM never runs anything: it answers with the calls it wants arguments and returns a value or promise of one (a string as-is, other data as JSON; throwing is
made, tbd.ui.events intercepts them, `call!` invokes the tool right here in the page (the same an error result). `pages` (tbd.ui.pages) is where the tool is offered; omitted means every page.
handlers as WebMCP's, so it shows on screen like a user's own doing) and the result goes back to
the LLM with the next request, as MCP's `tools/call` result would.
A tool is {:name :description :input-schema :handler :pages}: `handler` takes its arguments as a State providers ({:pages :provide}) are the same idea for ambient state: tbd.ui.events attaches
map and returns a value or a promise of one. A string is the result as it is, any other data `(current-state page)` to every /api/chat request (tbd.chat.schema/RunAgentInput's `state`), so
becomes JSON, and throwing (or rejecting) is an error result the agent can read. `pages` is the the model sees what the page shows without spending a call to read it."
set of pages (see tbd.ui.pages) the tool is offered on, so the LLM on the tic-tac-toe page is not
handed the todos' tools; a tool without it is offered on every page. What is offered follows the
page being shown: `definitions` and `call!` both take it, and a tool that is not offered on it
can neither be listed nor called."
(:require [clojure.string :as str])) (:require [clojure.string :as str]))
(defonce ^:private registry (atom [])) (defonce ^:private registry (atom []))
(defonce ^:private state-registry (atom []))
(defn register! (defn register!
"Adds `tools` to what the page offers. A tool with the name of one already there replaces it "Adds `tools` to what the page offers. A tool with the name of one already there replaces it
@@ -31,27 +25,57 @@
nil)) nil))
(defn clear! (defn clear!
"Takes every tool away: for a test to start from a page that offers none." "Takes every tool and state provider away: for a test to start from a page that offers none."
[] []
(reset! registry []) (reset! registry [])
(reset! state-registry [])
nil) nil)
(defn- offered? (defn- offered?
"Whether `tool` is offered on `page`." "Whether `entry` (a tool or a state provider) is offered on `page`."
[page {:keys [pages]}] [page {:keys [pages]}]
(or (nil? pages) (contains? pages page))) (or (nil? pages) (contains? pages page)))
(defn definitions (defn definitions
"What the LLM is told about the tools offered on `page`, as MCP's `tools/list` gives them: "What the LLM is told about the tools offered on `page`, as MCP's `tools/list` gives them:
[{:name :description :inputSchema}], in the order they were registered." [{:name :description :inputSchema}], in the order they were registered. A `:read-only?` tool
(one that only reads what `current-state` already covers, like list_todos) is left out: the
chatbot is handed the state instead of a call to read it, but the tool stays registered for
WebMCP, whose outside agents have no state channel to fall back on."
[page] [page]
(into [] (into []
(comp (filter #(offered? page %)) (comp (filter #(offered? page %))
(remove :read-only?)
(map (fn [{:keys [name description input-schema]}] (map (fn [{:keys [name description input-schema]}]
(cond-> {:name name :inputSchema input-schema} (cond-> {:name name :inputSchema input-schema}
description (assoc :description description))))) description (assoc :description description)))))
@registry)) @registry))
(defn once-per-turn-names
"The names of the tools offered on `page` that do something only one message's worth of
chaining can call for (like a game move — the person asking again is what asks for another one,
not the model on its own): tbd.ui.events stops offering, and stops running, one of these again
once it has run once in the current turn."
[page]
(into #{} (comp (filter #(offered? page %)) (filter :once-per-turn?) (map :name)) @registry))
(defn register-state!
"Replaces what the page offers as state with `providers` ({:pages :provide}, see this ns's
docstring). Unlike `register!`'s tools (registered piecemeal, by name, from more than one
caller), there is one caller (tbd.ui.core) and one list, so registering again — hot reload —
just replaces it, rather than needing a name to replace by."
[providers]
(reset! state-registry (vec providers))
nil)
(defn current-state
"What `page` shows right now, as one map: every state provider offered on it, merged (later ones
win a key both share, though none do today). {} when nothing is registered for it, or nothing
goes to the LLM (tbd.ui.events omits an empty state rather than sending it)."
[page]
(transduce (comp (filter #(offered? page %)) (map (fn [{:keys [provide]}] (provide))))
merge {} @state-registry))
(defn- ->text [value] (defn- ->text [value]
(cond (cond
(string? value) value (string? value) value
+95 -17
View File
@@ -3,6 +3,7 @@
[reagent.core :as r] [reagent.core :as r]
[re-frame.core :as rf] [re-frame.core :as rf]
[tbd.ui.events :as events] [tbd.ui.events :as events]
[tbd.ui.markdown :as markdown]
[tbd.ui.pages :as pages] [tbd.ui.pages :as pages]
[tbd.ui.subs :as subs] [tbd.ui.subs :as subs]
[tbd.ui.webmcp :as webmcp])) [tbd.ui.webmcp :as webmcp]))
@@ -178,14 +179,37 @@
(def ^:private chat-green "#28a745") (def ^:private chat-green "#28a745")
;; Spacing/border defaults for Markdown blocks (tbd.ui.markdown) inside a bubble, plus a low-alpha
;; overlay for code/rules that reads on both the green and grey bubble colors. Global (not scoped
;; to one bubble), but "chat-markdown" is specific enough not to collide with the rest of the page.
(defn- chat-markdown-style []
[:style "
.chat-markdown > :first-child { margin-top: 0; }
.chat-markdown > :last-child { margin-bottom: 0; }
.chat-markdown p, .chat-markdown ul, .chat-markdown ol, .chat-markdown pre,
.chat-markdown blockquote, .chat-markdown table, .chat-markdown h1, .chat-markdown h2,
.chat-markdown h3 { margin: 0 0 0.5em; }
.chat-markdown ul, .chat-markdown ol { padding-left: 1.25em; }
.chat-markdown li { margin: 0.15em 0; }
.chat-markdown pre { padding: 0.5em; overflow-x: auto; background: rgba(0,0,0,0.08); border-radius: 0.35em; }
.chat-markdown code { font-family: monospace; font-size: 0.85em; }
.chat-markdown pre code { background: none; padding: 0; }
.chat-markdown :not(pre) > code { background: rgba(0,0,0,0.1); padding: 0.1em 0.3em; border-radius: 0.25em; }
.chat-markdown blockquote { padding-left: 0.6em; border-left: 2px solid currentColor; opacity: 0.85; }
.chat-markdown table { border-collapse: collapse; }
.chat-markdown th, .chat-markdown td { border: 1px solid currentColor; padding: 0.2em 0.5em; }
.chat-markdown a { color: inherit; text-decoration: underline; }
"])
(defn- chat-bubble [{:keys [role content]}] (defn- chat-bubble [{:keys [role content]}]
(let [user? (= "user" role)] (let [user? (= "user" role)]
[:div {:style {:align-self (if user? "flex-end" "flex-start") [:div {:class "chat-markdown"
:style {:align-self (if user? "flex-end" "flex-start")
:max-width "85%" :padding "0.4rem 0.6rem" :border-radius "0.5rem" :max-width "85%" :padding "0.4rem 0.6rem" :border-radius "0.5rem"
:white-space "pre-wrap" :overflow-wrap "anywhere" :overflow-wrap "anywhere"
:background (if user? chat-green "#f1f1f1") :background (if user? chat-green "#f1f1f1")
:color (if user? "white" "#222")}} :color (if user? "white" "#222")}}
content])) (markdown/render content)]))
(defn- chat-tool-line (defn- chat-tool-line
"A tool the assistant calls, or what came of it, apart from what is said, and in smaller print. "A tool the assistant calls, or what came of it, apart from what is said, and in smaller print.
@@ -208,22 +232,52 @@
(defn- result-text [{:keys [name content error?]}] (defn- result-text [{:keys [name content error?]}]
(str name (if error? " failed: " " → ") content)) (str name (if error? " failed: " " → ") content))
(defn- chat-reasoning-block
"A reply's reasoning, whole (never cut down, unlike a tool line): shown only with \"Show
reasoning\" on, and then all of it, for whichever reply it belongs to."
[text]
[:div {:data-reasoning true
:style {:align-self "flex-start" :max-width "85%" :flex-shrink 0
:overflow-wrap "anywhere" :white-space "pre-wrap"
:font-family "monospace" :font-size "12px" :font-style "italic" :color "#777"}}
text])
(defn- chat-message (defn- chat-message
"What was said, as a bubble, and the tool calls the assistant made with it, and their results, "What was said, as a bubble, and the tool calls the assistant made with it, and their results,
as lines between the bubbles." as lines between the bubbles. The reasoning behind a reply, if any, shows above it, whole, only
[tools-expanded? {:keys [role content tool-calls] :as message}] when `reasoning-expanded?`."
[tools-expanded? reasoning-expanded? {:keys [role content tool-calls thinking halted?] :as message}]
(if (= "tool" role) (if (= "tool" role)
[chat-tool-line tools-expanded? (result-text message) message] [chat-tool-line tools-expanded? (result-text message) message]
[:<> [:<>
(when (and reasoning-expanded? (not (str/blank? thinking))) [chat-reasoning-block thinking])
(when-not (str/blank? content) [chat-bubble message]) (when-not (str/blank? content) [chat-bubble message])
(for [call tool-calls] (for [call tool-calls]
^{:key (:id call)} [chat-tool-line tools-expanded? (call-text call) nil])])) ^{:key (:id call)} [chat-tool-line tools-expanded? (call-text call) nil])
(when halted?
[:div {:data-halted true
:style {:align-self "flex-start" :font-size "12px" :font-style "italic" :color "#777"}}
"Stopped"])]))
(defn- tool-use? (defn- tool-use?
"Whether the conversation has any tool call or result." "Whether the conversation has any tool call or result."
[messages] [messages]
(some #(or (= "tool" (:role %)) (seq (:tool-calls %))) messages)) (some #(or (= "tool" (:role %)) (seq (:tool-calls %))) messages))
(defn- reasoning-use?
"Whether the conversation has any reasoning to show."
[messages]
(some (comp not str/blank? :thinking) messages))
(defn- reply-pending?
"Whether `message` (the last of the conversation) has yet to become the reply: it isn't the
assistant's yet, or, now that reasoning joins the conversation as it comes (see
::events/chat-event), it is an assistant message that is still only that reasoning — no content
said, no tool calls asked for. \"Thinking…\" shows for as long as this holds."
[{:keys [role content tool-calls]}]
(or (not= "assistant" role)
(and (str/blank? content) (empty? tool-calls))))
(def ^:private chat-min-width 260) (def ^:private chat-min-width 260)
(def ^:private chat-min-height 96) (def ^:private chat-min-height 96)
;; What the panel has besides the conversation (header, form, padding, and the gap under the ;; What the panel has besides the conversation (header, form, padding, and the gap under the
@@ -252,22 +306,38 @@
timer (js/setInterval #(reset! clock (js/Date.now)) thinking-tick-ms)] timer (js/setInterval #(reset! clock (js/Date.now)) thinking-tick-ms)]
(let [now @clock (let [now @clock
live? (and thinking-at (< (- now thinking-at) thinking-live-ms))] live? (and thinking-at (< (- now thinking-at) thinking-live-ms))]
;; The dots sit in a box of their own fixed width, so what follows (the stop button) stays put
;; however many there are.
[:div {:role "status" :style {:color "#777"}} [:div {:role "status" :style {:color "#777"}}
(if live? "Thinking"
(str "Thinking" (apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) "."))) [:span {:style {:display "inline-block" :width "1.2em"}}
"Thinking…")]) (if live?
(apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) "."))
"…")]])
(finally (js/clearInterval timer)))) (finally (js/clearInterval timer))))
(defn- halt-button
"The little square that stops the reply (see ::events/chat-halt), so the next message can steer it."
[]
[:button {:type "button" :aria-label "Stop" :title "Stop the reply"
:on-click #(rf/dispatch [::events/chat-halt])
:style {:display "inline-flex" :align-items "center" :justify-content "center"
:width "1.25rem" :height "1.25rem" :padding 0 :cursor "pointer"
:border "1px solid #bbb" :border-radius "50%" :background "white"}}
[:span {:style {:width "0.5rem" :height "0.5rem" :background "#777" :border-radius "1px"}}]])
(defn- chat-log (defn- chat-log
"The conversation, which follows its end (as the pieces of a reply come in) for as long as it is "The conversation, which follows its end (as the pieces of a reply come in) for as long as it is
scrolled to it. Scroll up to read back and it stays where it is, until you send a message or scrolled to it. Scroll up to read back and it stays where it is, until you send a message or
scroll down to the end again (a message sent is among the ones that came since the last render, scroll down to the end again (a message sent is among the ones that came since the last render,
which may also hold the first of the reply). \"Thinking…\" shows from the sending until the reply's first piece which may also hold the first of the reply). \"Thinking…\" shows from the sending until the reply's first piece
(animated while the model's reasoning is coming in); what the model reasons is not shown." (animated while the model's reasoning is coming in), and a stop button beside it, for as long as
the reply is on its way; what the model reasons shows, in full, only
with \"Show reasoning\" on (see chat-reasoning-block)."
[_chat _size] [_chat _size]
(let [stuck? (atom true) (let [stuck? (atom true)
seen (atom 0)] seen (atom 0)]
(fn [{:keys [messages status thinking-at tools-expanded?]} {:keys [height]}] (fn [{:keys [messages status thinking-at tools-expanded? reasoning-expanded?]} {:keys [height]}]
[:div {:role "log" :aria-live "polite" [:div {:role "log" :aria-live "polite"
:ref (fn [el] :ref (fn [el]
(when el (when el
@@ -283,9 +353,12 @@
(if (and (empty? messages) (not= :loading status)) (if (and (empty? messages) (not= :loading status))
[:p {:style {:color "#777" :margin 0}} "Ask me anything."] [:p {:style {:color "#777" :margin 0}} "Ask me anything."]
(for [[i message] (map-indexed vector messages)] (for [[i message] (map-indexed vector messages)]
^{:key i} [chat-message tools-expanded? message])) ^{:key i} [chat-message tools-expanded? reasoning-expanded? message]))
(when (and (= :loading status) (not= "assistant" (:role (peek messages)))) (when (= :loading status)
[thinking-line thinking-at])]))) [:div {:data-pending true
:style {:display "flex" :align-items "center" :gap "0.4rem" :flex-shrink 0}}
(when (reply-pending? (peek messages)) [thinking-line thinking-at])
[halt-button]])])))
(defn- chat-form [{:keys [input status]}] (defn- chat-form [{:keys [input status]}]
(let [loading? (= :loading status)] (let [loading? (= :loading status)]
@@ -293,9 +366,10 @@
(.preventDefault e) (.preventDefault e)
(rf/dispatch [::events/chat-send])) (rf/dispatch [::events/chat-send]))
:style {:display "flex" :gap "0.4rem"}} :style {:display "flex" :gap "0.4rem"}}
;; Read-only while waiting (rather than disabled) so it keeps the focus. ;; Not disabled or read-only while waiting, so you can type the next message ahead of the
;; reply; ::chat-send itself ignores a submit while a reply is still loading.
[:input {:type "text" :name "message" :aria-label "Message" :placeholder "Message" [:input {:type "text" :name "message" :aria-label "Message" :placeholder "Message"
:auto-focus true :auto-complete "off" :read-only loading? :auto-focus true :auto-complete "off"
:style {:flex 1 :min-width 0} :style {:flex 1 :min-width 0}
:value input :value input
:on-change #(rf/dispatch [::events/chat-set-input (.. % -target -value)])}] :on-change #(rf/dispatch [::events/chat-set-input (.. % -target -value)])}]
@@ -344,7 +418,7 @@
:cursor "nesw-resize" :touch-action "none" :cursor "nesw-resize" :touch-action "none"
:background "linear-gradient(225deg, #bbb 0 2px, transparent 2px 5px, #bbb 5px 7px, transparent 7px)"}}]) :background "linear-gradient(225deg, #bbb 0 2px, transparent 2px 5px, #bbb 5px 7px, transparent 7px)"}}])
(defn- chat-panel [{:keys [messages status size tools-expanded?] :as chat} user] (defn- chat-panel [{:keys [messages status size tools-expanded? reasoning-expanded?] :as chat} user]
[:div {:role "dialog" :aria-label "Chat" [:div {:role "dialog" :aria-label "Chat"
:style {:position "absolute" :bottom "40px" :left 0 :box-sizing "border-box" :style {:position "absolute" :bottom "40px" :left 0 :box-sizing "border-box"
:width (str (:width size) "px") :width (str (:width size) "px")
@@ -356,6 +430,9 @@
(when (tool-use? messages) (when (tool-use? messages)
[link-button {:on-click #(rf/dispatch [::events/chat-toggle-tools])} [link-button {:on-click #(rf/dispatch [::events/chat-toggle-tools])}
(if tools-expanded? "Collapse tool use" "Expand tool use")]) (if tools-expanded? "Collapse tool use" "Expand tool use")])
(when (reasoning-use? messages)
[link-button {:on-click #(rf/dispatch [::events/chat-toggle-reasoning])}
(if reasoning-expanded? "Hide reasoning" "Show reasoning")])
(when (and (seq messages) (not= :loading status)) (when (and (seq messages) (not= :loading status))
[link-button {:on-click #(rf/dispatch [::events/chat-clear])} "Clear"]) [link-button {:on-click #(rf/dispatch [::events/chat-clear])} "Clear"])
[:button {:type "button" :aria-label "Close chat" [:button {:type "button" :aria-label "Close chat"
@@ -375,6 +452,7 @@
user @(rf/subscribe [::subs/user])] user @(rf/subscribe [::subs/user])]
[:div {:style {:position "fixed" :left "20px" :bottom "20px" :z-index 9999 [:div {:style {:position "fixed" :left "20px" :bottom "20px" :z-index 9999
:font-family "Arial, sans-serif" :font-size "14px"}} :font-family "Arial, sans-serif" :font-size "14px"}}
[chat-markdown-style]
(when open? [chat-panel chat user]) (when open? [chat-panel chat user])
[:button {:type "button" :aria-label "Chat" :title "Chat" :aria-expanded (boolean open?) [:button {:type "button" :aria-label "Chat" :title "Chat" :aria-expanded (boolean open?)
:style {:display "block" :width "30px" :height "30px" :padding 0 :border 0 :style {:display "block" :width "30px" :height "30px" :padding 0 :border 0
+68 -70
View File
@@ -1,26 +1,18 @@
(ns tbd.ui.webmcp (ns tbd.ui.webmcp
"The page's own MCP tools, for an agent running in the browser: the client-side counterpart of "The page's own MCP tools, for an agent running in the browser: the client-side counterpart of
tbd.mcp.tools. They are offered through WebMCP (https://webmcp.dev, the `@jason.today/webmcp` tbd.mcp.tools, offered through WebMCP (https://webmcp.dev). Each tool does what a user could do
library): it adds a small widget to the page, the user pastes a token from their MCP client on the page (type in a form, press a button) by dispatching the same re-frame events the views
(Claude) into it, and the client then sees the tools registered here. Where tbd.mcp.tools works do, and reads results from the app-db. A tool takes a map of arguments and returns a value or a
on the server's data, these work the UI: each one does what a user could do on the page (type in promise of one (a string, or data that becomes JSON); throwing becomes an error result.
the form, press a button, tick a box) by dispatching the same re-frame events the views do, so
everything shows on screen, and reads what the page shows from the app-db.
Besides the tools, the page registers prompts and resources (`prompts`, `resources`), which is `tools` also feeds tbd.ui.model-context (via tbd.ui.core), which offers the page's chatbot the
what an MCP client lists next to the tools (Claude Code shows the prompts as slash commands and same tools. `:read-only? true` tools are left out there — the chatbot gets that information as
the resources as @-mentions). They are the same instructions the page's own chatbot is given ambient state instead (`state-providers`) — but stay registered here for WebMCP's outside
(tbd.agent.prompt, shared with the server), so Claude or Codex is told to act rather than offer, agents. `:once-per-turn? true` tools (e.g. move_tic_tac_toe) are offered to the chatbot only
to chain calls and to play tic-tac-toe by the turn, and can read what page is open. until used once per turn (tbd.ui.events); that cap doesn't apply to WebMCP's outside agents.
The same tools are registered with tbd.ui.model-context (by tbd.ui.core), which is how the page's `prompts` and `resources` carry the same instructions as the chatbot's system prompt
own chatbot offers them to its LLM and calls them, the ones of the page being shown (see (tbd.agent.prompt), so an outside MCP client is told to act instead of offer, chain calls, etc."
`tools`): this ns says what the tools are, and has the WebMCP way of offering them all to an
agent outside the page.
A tool takes its arguments as a map and returns a value or a promise of one: a string, or data
that becomes JSON. Throwing (or rejecting) becomes an error result the agent can read. Input
schemas are JSON Schema, written here: the UI has no Malli to share with the server's."
(:require ["@jason.today/webmcp/src/webmcp.js" :as WebMCP] (:require ["@jason.today/webmcp/src/webmcp.js" :as WebMCP]
[clojure.string :as str] [clojure.string :as str]
[re-frame.core :as rf] [re-frame.core :as rf]
@@ -215,13 +207,16 @@
(.then #(last (get-in % [:todos :items]))))) (.then #(last (get-in % [:todos :items])))))
(defn- create-todo (defn- create-todo
"Adds todos, one after the other: a promise of the todos that were created." "Adds todos, one after the other, and resolves to nil (\"ok\"): the page shows them as they're
added, and the next request's state (tbd.ui.webmcp/state-providers) has them, ids included, so
there is nothing left for the result itself to say."
[{:keys [todos]}] [{:keys [todos]}]
(check-todos! todos (fn [{:keys [title]}] (check-todos! todos (fn [{:keys [title]}]
(when-not (and (string? title) (seq title)) (when-not (and (string? title) (seq title))
(fail! "invalid arguments: title must be a non-empty string")))) (fail! "invalid arguments: title must be a non-empty string"))))
(-> (logged-in-todos) (-> (logged-in-todos)
(.then (fn [_] (in-order create-one todos))))) (.then (fn [_] (in-order create-one todos)))
(.then (constantly nil))))
(defn- set-one-done (defn- set-one-done
"Ticks or unticks one todo's checkbox, unless it is already so (no request then). A promise of "Ticks or unticks one todo's checkbox, unless it is already so (no request then). A promise of
@@ -237,7 +232,7 @@
(defn- set-todo-done (defn- set-todo-done
"Ticks or unticks the checkboxes of several todos. Every change is checked before the first is "Ticks or unticks the checkboxes of several todos. Every change is checked before the first is
made. A promise of the todos as they are then." made. Resolves to nil (\"ok\"): the checkboxes show it, and the next request's state has it too."
[{:keys [todos]}] [{:keys [todos]}]
(check-todos! todos (fn [{:keys [id done]}] (check-todos! todos (fn [{:keys [id done]}]
(check-id! id) (check-id! id)
@@ -247,7 +242,8 @@
(.then (fn [items] (.then (fn [items]
(run! #(find-todo! items (:id %)) todos) (run! #(find-todo! items (:id %)) todos)
(show! :todos) (show! :todos)
(in-order set-one-done todos))))) (in-order set-one-done todos)))
(.then (constantly nil))))
(defn- delete-one (defn- delete-one
"Presses a todo's Delete button. A promise of its id." "Presses a todo's Delete button. A promise of its id."
@@ -258,7 +254,8 @@
(.then (fn [_] id)))) (.then (fn [_] id))))
(defn- delete-todo (defn- delete-todo
"Presses the Delete button of several todos. Every id is looked up before the first is deleted." "Presses the Delete button of several todos. Every id is looked up before the first is deleted.
Resolves to nil (\"ok\"): they're gone from the page, and from the next request's state."
[{:keys [todos]}] [{:keys [todos]}]
(check-todos! todos #(check-id! (:id %))) (check-todos! todos #(check-id! (:id %)))
(let [ids (distinct (map :id todos))] (let [ids (distinct (map :id todos))]
@@ -267,12 +264,7 @@
(run! #(find-todo! items %) ids) (run! #(find-todo! items %) ids)
(show! :todos) (show! :todos)
(in-order delete-one ids))) (in-order delete-one ids)))
(.then (fn [deleted] {:deleted deleted}))))) (.then (constantly nil)))))
;; Tic-tac-toe is moves taken in turns: X, then O, on the same board. A person plays on the same
;; board, so a move names the side it is for, and is refused when it is not that side's turn: an
;; agent that lost track of whose turn it is cannot play the person's move (or both sides).
;; Every result says whose turn it is.
(defn- tic-tac-toe-state (defn- tic-tac-toe-state
"The game as the page shows it: the 9 cells (row by row, cell 0 is the top left; null when "The game as the page shows it: the 9 cells (row by row, cell 0 is the top left; null when
@@ -289,8 +281,28 @@
(defn- get-tic-tac-toe [_] (defn- get-tic-tac-toe [_]
(tic-tac-toe-state)) (tic-tac-toe-state))
;; --- State (tbd.ui.model-context/current-state, attached to every request of the page's own
;; chatbot instead of spent as a read tool's call; see tbd.ui.model-context's docstring) ---
(defn- todos-state
"The todos, once they have loaded: nil (nothing to add to the state) while they haven't, or
there is no login, rather than an empty list that would read as \"there are none\"."
[]
(let [{:keys [status items]} (:todos (db))]
(when (= :ok status)
{:todos (mapv #(select-keys % [:id :title :done]) items)})))
(def state-providers
"{:pages :provide}, one per page that has state worth telling the model up front. `provide`
returns the page's state as a map, or nil for nothing to add right now (see
tbd.ui.model-context/current-state, which merges them)."
[{:pages #{:todos} :provide todos-state}
{:pages #{:tic-tac-toe} :provide tic-tac-toe-state}
{:pages #{:calculator} :provide (fn [] (:calc (db)))}])
(defn- move-tic-tac-toe (defn- move-tic-tac-toe
"Presses cell `cell` as `player` (\"x\" or \"o\"), only if it is that player's turn." "Presses cell `cell` as `player` (\"x\" or \"o\"), only if it is that player's turn. Returns the
board afterwards (the same shape as get_tic_tac_toe), so the result itself says what changed."
[{:keys [cell player]}] [{:keys [cell player]}]
(when-not (and (number? cell) (js/Number.isInteger cell) (<= 0 cell 8)) (when-not (and (number? cell) (js/Number.isInteger cell) (<= 0 cell 8))
(fail! "invalid arguments: cell must be an integer from 0 to 8")) (fail! "invalid arguments: cell must be an integer from 0 to 8"))
@@ -298,7 +310,7 @@
(fail! "invalid arguments: player must be \"x\" or \"o\"")) (fail! "invalid arguments: player must be \"x\" or \"o\""))
(let [{:keys [board turn]} (:ttt (db))] (let [{:keys [board turn]} (:ttt (db))]
(when (tictactoe/outcome board) (when (tictactoe/outcome board)
(fail! "the game is over: start a new game")) (fail! "the game is over: the person starts a new one, with the page's own New game button"))
(when (not= player (name turn)) (when (not= player (name turn))
(fail! (str "it is " (name turn) "'s turn, not " player "'s: wait for the other side to move"))) (fail! (str "it is " (name turn) "'s turn, not " player "'s: wait for the other side to move")))
(when (board cell) (when (board cell)
@@ -307,13 +319,6 @@
(rf/dispatch-sync [::events/ttt-move cell]) (rf/dispatch-sync [::events/ttt-move cell])
(tic-tac-toe-state))) (tic-tac-toe-state)))
(defn- new-tic-tac-toe-game
"Presses New game."
[_]
(show! :tic-tac-toe)
(rf/dispatch-sync [::events/ttt-reset])
(tic-tac-toe-state))
(defn- object-schema [properties required] (defn- object-schema [properties required]
{:type "object" :properties properties :required required}) {:type "object" :properties properties :required required})
@@ -340,8 +345,9 @@
:input-schema (object-schema {} []) :handler whoami} :input-schema (object-schema {} []) :handler whoami}
{:name "navigate" {:name "navigate"
:description (str "Opens one of the pages of the app, as a click on its tab would, and returns the page " :description (str "Opens one of the pages of the app, as a click on its tab would. It only moves you "
"that is shown now (JSON). The pages are: " "there: it does not read what the page holds, so it is not a way to check or refresh "
"anything. The pages are: "
(str/join ", " (map (fn [{:keys [id title login?]}] (str/join ", " (map (fn [{:keys [id title login?]}]
(str (name id) " (" title (when login? ", needs a login") ")")) (str (name id) " (" title (when login? ", needs a login") ")"))
pages/pages)) pages/pages))
@@ -352,7 +358,7 @@
["page"]) ["page"])
:handler navigate} :handler navigate}
{:name "get_calculator" :pages #{:calculator} {:name "get_calculator" :pages #{:calculator} :read-only? true
:description (str "What the calculator form on this page holds (JSON): the x and y in its fields, and " :description (str "What the calculator form on this page holds (JSON): the x and y in its fields, and "
"the result it is showing (status idle, loading, ok with the sum, or error with the message)") "the result it is showing (status idle, loading, ok with the sum, or error with the message)")
:input-schema (object-schema {} []) :handler get-calculator} :input-schema (object-schema {} []) :handler get-calculator}
@@ -365,29 +371,28 @@
["x" "y"]) ["x" "y"])
:handler add} :handler add}
{:name "list_todos" :pages #{:todos} {:name "list_todos" :pages #{:todos} :read-only? true
:description (str "Lists the todos this page shows (JSON: id, title, done, created-at, updated-at), oldest first. " :description (str "Lists the todos this page shows (JSON: id, title, done, created-at, updated-at), oldest first. "
"Needs a login on the page") "Needs a login on the page")
:input-schema (object-schema {} []) :handler list-todos} :input-schema (object-schema {} []) :handler list-todos}
{:name "get_todo" :pages #{:todos} {:name "get_todo" :pages #{:todos} :read-only? true
:description (str "Gets todos this page shows, by id (JSON list). Takes a list: to read several, make ONE call " :description (str "Gets todos this page shows, by id (JSON list). Takes a list: to read several, make ONE call "
"with all of them") "with all of them")
:input-schema (todos-schema "The todos to get, one per todo" {:id todo-id} ["id"]) :input-schema (todos-schema "The todos to get, one per todo" {:id todo-id} ["id"])
:handler get-todo} :handler get-todo}
{:name "create_todo" :pages #{:todos} {:name "create_todo" :pages #{:todos}
:description (str "Adds todos: types each title into the new-todo field and presses Add, and returns the todos " :description (str "Adds todos: types each title into the new-todo field and presses Add. Takes a list: to add "
"that were created (JSON list). Takes a list: to add several, make ONE call with all of them, " "several, make ONE call with all of them, never one call per todo")
"never one call per todo")
:input-schema (todos-schema "The todos to add, one per todo" :input-schema (todos-schema "The todos to add, one per todo"
{:title {:type "string" :minLength 1 :maxLength 200 :description "What needs doing"}} {:title {:type "string" :minLength 1 :maxLength 200 :description "What needs doing"}}
["title"]) ["title"])
:handler create-todo} :handler create-todo}
{:name "set_todo_done" :pages #{:todos} {:name "set_todo_done" :pages #{:todos}
:description (str "Ticks or unticks the checkboxes of todos, and returns those todos (JSON list). Takes a list: " :description (str "Ticks or unticks the checkboxes of todos. Takes a list: to change several, make ONE call "
"to change several, make ONE call with all of them, never one call per todo") "with all of them, never one call per todo")
:input-schema (todos-schema "The changes to make, one per todo" :input-schema (todos-schema "The changes to make, one per todo"
{:id todo-id {:id todo-id
:done {:type "boolean" :description "true to tick it off, false to untick it"}} :done {:type "boolean" :description "true to tick it off, false to untick it"}}
@@ -395,37 +400,32 @@
:handler set-todo-done} :handler set-todo-done}
{:name "delete_todo" :pages #{:todos} {:name "delete_todo" :pages #{:todos}
:description (str "Deletes todos for good, by pressing their Delete buttons, and returns the ids that were " :description (str "Deletes todos for good, by pressing their Delete buttons. Find the id first — from the "
"deleted (JSON). Find the ids with list_todos first; never guess one, and never delete a " "page's current state if you have it, or list_todos — never guess one, and never delete a "
"todo the user did not clearly point at. Takes a list: to delete several, make ONE call " "todo the user did not clearly point at. Takes a list: to delete several, make ONE call "
"with all of them") "with all of them")
:input-schema (todos-schema "The todos to delete, one per todo" {:id todo-id} ["id"]) :input-schema (todos-schema "The todos to delete, one per todo" {:id todo-id} ["id"])
:handler delete-todo} :handler delete-todo}
{:name "get_tic_tac_toe" :pages #{:tic-tac-toe} {:name "get_tic_tac_toe" :pages #{:tic-tac-toe} :read-only? true
:description (str "The tic-tac-toe game on this page (JSON): board (9 cells, row by row, cell 0 the top left " :description (str "The tic-tac-toe game on this page (JSON): board (9 cells, row by row, cell 0 the top left "
"and cell 8 the bottom right; null when empty, else \"x\" or \"o\"), turn (whose move it " "and cell 8 the bottom right; null when empty, else \"x\" or \"o\"), turn (whose move it "
"is, \"x\" or \"o\": X goes first, and they alternate) and status (in_progress, won or draw; " "is, \"x\" or \"o\": X goes first, and they alternate) and status (in_progress, won or draw; "
"when won, also winner and line). A person moves on the same board, so check the turn " "when won, also winner and line)")
"before you move, and only move for your own side")
:input-schema (object-schema {} []) :handler get-tic-tac-toe} :input-schema (object-schema {} []) :handler get-tic-tac-toe}
{:name "move_tic_tac_toe" :pages #{:tic-tac-toe} {:name "move_tic_tac_toe" :pages #{:tic-tac-toe} :once-per-turn? true
:description (str "Presses a cell of the tic-tac-toe board as `player`, your side, and returns the game as " :description (str "Presses a cell of the tic-tac-toe board as `player`, and returns the board afterwards "
"get_tic_tac_toe does (including whose turn is next). Fails, and changes nothing, if it " "(JSON, the same shape as get_tic_tac_toe). Fails, and changes nothing, if it isn't that "
"is not your side's turn (the other side is the person's: wait for them to move), the " "side's turn yet, the cell is taken or the game is over. Runs at most once per message: "
"cell is taken or the game is over. Never move for the other side") "asked for a move, make the one call and answer with a short line, a board sketch if that "
"helps — a second call this turn is refused, unasked")
:input-schema (object-schema {:cell {:type "integer" :minimum 0 :maximum 8 :input-schema (object-schema {:cell {:type "integer" :minimum 0 :maximum 8
:description "0 is the top left, 2 the top right, 8 the bottom right"} :description "0 is the top left, 2 the top right, 8 the bottom right"}
:player {:type "string" :enum ["x" "o"] :player {:type "string" :enum ["x" "o"]
:description (str "The side you play. The move is refused if it " :description "Which side this move is for"}}
"is the other side's turn")}}
["cell" "player"]) ["cell" "player"])
:handler move-tic-tac-toe} :handler move-tic-tac-toe}])
{:name "new_tic_tac_toe_game" :pages #{:tic-tac-toe}
:description "Presses New game: clears the tic-tac-toe board, X to move (JSON, as get_tic_tac_toe)"
:input-schema (object-schema {} []) :handler new-tic-tac-toe-game}])
;; --- Prompts and resources --- ;; --- Prompts and resources ---
@@ -441,10 +441,8 @@
:handler (fn [{:keys [task]}] (prompt/task task))} :handler (fn [{:keys [task]}] (prompt/task task))}
{:name "play_tic_tac_toe" {:name "play_tic_tac_toe"
:description "Plays tic-tac-toe with you on the page: moves only on its own side's turn, one move at a time" :description "Plays tic-tac-toe with you on the page"
:arguments [{:name "side" :required false :handler (fn [_] prompt/tic-tac-toe)}])
:description "The side the agent plays, \"x\" or \"o\" (default o: you play X and start)"}]
:handler (fn [{:keys [side]}] (prompt/tic-tac-toe side))}])
(defn- page-state (defn- page-state
"A promise of what the page is showing: the open page, the pages and who is logged in." "A promise of what the page is showing: the open page, the pages and who is logged in."
+3
View File
@@ -57,6 +57,9 @@
(is (= (set (map :name webmcp/tools)) (tools-in-widget)) "it offers the page's tools to the agent") (is (= (set (map :name webmcp/tools)) (tools-in-widget)) "it offers the page's tools to the agent")
(is (= (map :name (remove :pages webmcp/tools)) (map :name (model-context/definitions :ai-setup))) (is (= (map :name (remove :pages webmcp/tools)) (map :name (model-context/definitions :ai-setup)))
"and to the chatbot, the ones of the page it is on") "and to the chatbot, the ones of the page it is on")
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn :x}
(model-context/current-state :tic-tac-toe))
"and its state, for the page it starts on")
;; A tool, as the agent's client calls it. ;; A tool, as the agent's client calls it.
(let [ping (.-execute (.get (.-availableTools ^js (widget)) "ping"))] (let [ping (.-execute (.get (.-availableTools ^js (widget)) "ping"))]
(-> (ping #js {}) (-> (ping #js {})
+291 -37
View File
@@ -1,6 +1,5 @@
(ns tbd.ui.events-test (ns tbd.ui.events-test
(:require [cljs.test :refer [deftest is testing async use-fixtures]] (:require [cljs.test :refer [deftest is testing async use-fixtures]]
[clojure.string :as str]
[re-frame.core :as rf] [re-frame.core :as rf]
[re-frame.db :as rf-db] [re-frame.db :as rf-db]
[tbd.ui.db :as db] [tbd.ui.db :as db]
@@ -25,10 +24,13 @@
:after model-context/clear!} :after model-context/clear!}
(tu/stub-effects-fixture {::events/fetch (record ::events/fetch) (tu/stub-effects-fixture {::events/fetch (record ::events/fetch)
::events/fetch-stream (record ::events/fetch-stream) ::events/fetch-stream (record ::events/fetch-stream)
::events/abort-stream (record ::events/abort-stream)
::events/persist-chat (record ::events/persist-chat)
::events/call-tools (record ::events/call-tools) ::events/call-tools (record ::events/call-tools)
::events/copy-to-clipboard (record ::events/copy-to-clipboard) ::events/copy-to-clipboard (record ::events/copy-to-clipboard)
:dispatch-later (record :dispatch-later) :dispatch-later (record :dispatch-later)
:dispatch #(swap! queued conj %)})) :dispatch #(swap! queued conj %)
:dispatch-n #(swap! queued into %)}))
(defn- dispatch! (defn- dispatch!
"Dispatches `event` and, one after the other, the events it sets off." "Dispatches `event` and, one after the other, the events it sets off."
@@ -49,6 +51,14 @@
(defn- last-request [] (last (requests))) (defn- last-request [] (last (requests)))
(defn- persist-requests
"The chat history save/clear requests asked for so far (see ::events/persist-chat), as
{:uri :method :body :on-response}."
[]
(mapv second (filter (comp #{::events/persist-chat} first) @effects)))
(defn- last-persist-request [] (last (persist-requests)))
(defn- answer! (defn- answer!
"The server answers the last request." "The server answers the last request."
([status body] (answer! (last-request) status body)) ([status body] (answer! (last-request) status body))
@@ -162,10 +172,11 @@
;; --- Login --- ;; --- Login ---
(deftest user-response-test (deftest user-response-test
(testing "logged in: remembers who, and loads the todos" (testing "logged in: remembers who, loads the todos, and asks for the last chat session"
(start!) (start!)
(answer! 200 {:login "alice" :id 7}) (answer! 200 {:login "alice" :id 7})
(is (= {:status :logged-in :login "alice"} (:user (app-db)))) (is (= {:status :logged-in :login "alice"} (:user (app-db))))
(is (= #{"/auth/me" "/api/todos" "/api/chat/history"} (set (map :uri (requests)))))
(is (= "/api/todos" (:uri (last-request))))) (is (= "/api/todos" (:uri (last-request)))))
(testing "401 only means nobody is logged in" (testing "401 only means nobody is logged in"
(start!) (start!)
@@ -323,6 +334,18 @@
(dispatch! [::events/chat-toggle]) (dispatch! [::events/chat-toggle])
(is (false? (:open? (chat))))) (is (false? (:open? (chat)))))
(deftest chat-toggle-persists-across-a-reload-test
(start!)
(dispatch! [::events/chat-toggle])
(is (true? (:open? (chat))))
(testing "a fresh start picks the open panel back up"
(dispatch! [::events/initialize])
(is (true? (:open? (chat)))))
(dispatch! [::events/chat-toggle])
(testing "and its being closed again"
(dispatch! [::events/initialize])
(is (false? (:open? (chat))))))
(defn- without-ids (defn- without-ids
"`messages`, as AG-UI has them on the wire, with the per-message `:id` (a counter, unpredictable "`messages`, as AG-UI has them on the wire, with the per-message `:id` (a counter, unpredictable
from a test) dropped, so what is left can be compared." from a test) dropped, so what is left can be compared."
@@ -338,8 +361,7 @@
(logged-in! []) (logged-in! [])
(say! " hello there ") (say! " hello there ")
(testing "the trimmed message joins the conversation and goes to the server, for a stream back" (testing "the trimmed message joins the conversation and goes to the server, for a stream back"
(let [[effect request] (last @effects)] (let [request (last-request)]
(is (= ::events/fetch-stream effect))
(is (= "/api/chat" (:uri request))) (is (= "/api/chat" (:uri request)))
(is (= "POST" (:method request))) (is (= "POST" (:method request)))
(is (= [::events/chat-event] (:on-event request))) (is (= [::events/chat-event] (:on-event request)))
@@ -347,7 +369,11 @@
(is (= [{:role "user" :content "hello there"}] (sent-messages request))) (is (= [{:role "user" :content "hello there"}] (sent-messages request)))
(is (= [{:description "page" :value "tic-tac-toe"}] (get-in request [:body :context])))) (is (= [{:description "page" :value "tic-tac-toe"}] (get-in request [:body :context]))))
(is (= {:messages [{:role "user" :content "hello there"}] :input "" :status :loading :error nil} (is (= {:messages [{:role "user" :content "hello there"}] :input "" :status :loading :error nil}
(select-keys (chat) [:messages :input :status :error])))) (select-keys (chat) [:messages :input :status :error])))
(testing "and is saved for the next login, right away (not only once the reply comes)"
(is (= {:uri "/api/chat/history" :method "PUT"
:body {:messages [{:role "user" :content "hello there"}]}}
(select-keys (last-persist-request) [:uri :method :body])))))
(testing "only one message is in flight, so sending again does nothing" (testing "only one message is in flight, so sending again does nothing"
(say! "and another") (say! "and another")
(is (= 1 (count (requests)))) (is (= 1 (count (requests))))
@@ -365,19 +391,22 @@
(deftest chat-streaming-reply-test (deftest chat-streaming-reply-test
(logged-in! []) (logged-in! [])
(say! "hello") (say! "hello")
(testing "the model's reasoning is not kept, and it keeps waiting" (testing "the model's reasoning joins the conversation of its own reply, and it keeps waiting"
(event! {:thinking "Let me "}) (event! {:thinking "Let me "})
(event! {:thinking "think."}) (event! {:thinking "think."})
(is (= [{:role "user" :content "hello"}] (:messages (chat)))) (is (= [{:role "user" :content "hello"}
{:role "assistant" :content "" :thinking "Let me think."}]
(:messages (chat))))
(is (= :loading (:status (chat))))) (is (= :loading (:status (chat)))))
(testing "the first piece of the reply, and the ones that follow, are added to that message" (testing "the first piece of the reply, and the ones that follow, are added to that message"
(event! {:content "Hel"}) (event! {:content "Hel"})
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hel"}] (is (= [{:role "user" :content "hello"}
{:role "assistant" :content "Hel" :thinking "Let me think."}]
(:messages (chat)))) (:messages (chat))))
(event! {:content "lo, "}) (event! {:content "lo, "})
(event! {:content "world"}) (event! {:content "world"})
(is (= [{:role "user" :content "hello"} (is (= [{:role "user" :content "hello"}
{:role "assistant" :content "Hello, world"}] {:role "assistant" :content "Hello, world" :thinking "Let me think."}]
(:messages (chat)))) (:messages (chat))))
(is (= :loading (:status (chat))) "it isn't over until it says so")) (is (= :loading (:status (chat))) "it isn't over until it says so"))
(testing "another message can't be sent while the reply is coming in" (testing "another message can't be sent while the reply is coming in"
@@ -387,12 +416,12 @@
(event! {:done true}) (event! {:done true})
(is (= {:status :idle :error nil} (select-keys (chat) [:status :error]))) (is (= {:status :idle :error nil} (select-keys (chat) [:status :error])))
(is (= [{:role "user" :content "hello"} (is (= [{:role "user" :content "hello"}
{:role "assistant" :content "Hello, world"}] {:role "assistant" :content "Hello, world" :thinking "Let me think."}]
(:messages (chat))))) (:messages (chat)))))
(testing "events that come after the end are dropped" (testing "events that come after the end are dropped"
(event! {:content "late"}) (event! {:content "late"})
(is (= "Hello, world" (:content (last (:messages (chat))))))) (is (= "Hello, world" (:content (last (:messages (chat)))))))
(testing "the next message has the conversation so far" (testing "the next message has the conversation so far, without the reasoning (which stays only for display)"
(say! "again") (say! "again")
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hello, world"} (is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hello, world"}
{:role "user" :content "again"}] {:role "user" :content "again"}]
@@ -434,15 +463,16 @@
(say! "hello") (say! "hello")
(event! {:thinking "hm" :content "Hi"}) (event! {:thinking "hm" :content "Hi"})
(event! {:thinking "m" :content "!"}) (event! {:thinking "m" :content "!"})
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!"}] (is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!" :thinking "hmm"}]
(:messages (chat)))) (:messages (chat))))
(testing "an empty piece changes nothing" (testing "an empty piece changes nothing"
(event! {:thinking "" :content ""}) (event! {:thinking "" :content ""})
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!"}] (is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!" :thinking "hmm"}]
(:messages (chat)))))) (:messages (chat))))))
(deftest chat-thinking-is-never-kept-test (deftest chat-thinking-per-reply-test
;; The reasoning of each reply of a turn, before and after tools, leaves nothing in the conversation. ;; Each reply of a turn (before and after tools) keeps its own reasoning, on its own message, not
;; sent to the LLM, but there for "Show reasoning" to reveal.
(logged-in! []) (logged-in! [])
(say! "hi") (say! "hi")
(event! {:thinking "first"}) (event! {:thinking "first"})
@@ -451,9 +481,9 @@
(dispatch! [::events/chat-tool-results [{:id "c1" :name "ping" :content "pong" :error? false}]]) (dispatch! [::events/chat-tool-results [{:id "c1" :name "ping" :content "pong" :error? false}]])
(event! {:thinking "second"}) (event! {:thinking "second"})
(event! {:content "done"}) (event! {:content "done"})
(is (= [["user" nil] ["assistant" nil] ["tool" nil] ["assistant" nil]] (is (= [["user" nil] ["assistant" "first"] ["tool" nil] ["assistant" "second"]]
(map (juxt :role :thinking) (:messages (chat))))) (map (juxt :role :thinking) (:messages (chat)))))
(is (not-any? #(re-find #"first|second" (pr-str %)) (:messages (chat))))) (is (not-any? #(re-find #"first|second" (pr-str %)) (sent-messages (last-request)))))
(deftest chat-blank-message-test (deftest chat-blank-message-test
(logged-in! []) (logged-in! [])
@@ -532,7 +562,41 @@
(event! {:done true}) (event! {:done true})
(dispatch! [::events/chat-toggle]) (dispatch! [::events/chat-toggle])
(dispatch! [::events/chat-clear]) (dispatch! [::events/chat-clear])
(is (= (assoc (:chat db/default-db) :open? true) (chat)) "starts over, and the panel stays as it was")) (is (= (assoc (:chat db/default-db) :open? true) (chat)) "starts over, and the panel stays as it was")
(testing "the stored session goes with it, so a reload doesn't bring the old conversation back"
(is (= {:uri "/api/chat/history" :method "DELETE"} (select-keys (last-persist-request) [:uri :method])))))
(deftest chat-history-restore-test
(testing "the last session comes back, once, right after login"
(start!)
(answer! 200 {:login "alice" :id 7})
(let [history-request (first (filter #(= "/api/chat/history" (:uri %)) (requests)))
messages [{:role "user" :content "hi"} {:role "assistant" :content "echo: hi"}]]
(answer! history-request 200 {:messages messages})
(answer! 200 {:todos []})
(is (= messages (:messages (chat))))))
(testing "an empty history leaves the conversation empty"
(start!)
(answer! 200 {:login "bob" :id 8})
(let [history-request (first (filter #(= "/api/chat/history" (:uri %)) (requests)))]
(answer! history-request 200 {:messages []})
(answer! 200 {:todos []})
(is (= [] (:messages (chat))))))
(testing "a conversation already started (the response arriving late) is not overwritten"
(start!)
(answer! 200 {:login "alice" :id 7})
(let [history-request (first (filter #(= "/api/chat/history" (:uri %)) (requests)))]
(answer! 200 {:todos []})
(say! "already started")
(answer! history-request 200 {:messages [{:role "user" :content "old session"}]})
(is (= [{:role "user" :content "already started"}] (:messages (chat))))))
(testing "a failed load (a 401, say) just leaves the conversation empty"
(start!)
(answer! 200 {:login "alice" :id 7})
(let [history-request (first (filter #(= "/api/chat/history" (:uri %)) (requests)))]
(answer! history-request 401 {:error "login required"})
(answer! 200 {:todos []})
(is (= [] (:messages (chat)))))))
(deftest chat-toggle-tools-test (deftest chat-toggle-tools-test
(logged-in! []) (logged-in! [])
@@ -547,6 +611,19 @@
(dispatch! [::events/chat-toggle-tools]) (dispatch! [::events/chat-toggle-tools])
(is (false? (:tools-expanded? (chat))))) (is (false? (:tools-expanded? (chat)))))
(deftest chat-toggle-reasoning-test
(logged-in! [])
(is (false? (:reasoning-expanded? (chat))) "reasoning is hidden by default")
(dispatch! [::events/chat-toggle-reasoning])
(is (true? (:reasoning-expanded? (chat))))
(testing "the choice stays when the conversation starts over"
(say! "hello")
(reply! "Hi!")
(dispatch! [::events/chat-clear])
(is (true? (:reasoning-expanded? (chat)))))
(dispatch! [::events/chat-toggle-reasoning])
(is (false? (:reasoning-expanded? (chat)))))
(deftest chat-resize-test (deftest chat-resize-test
(logged-in! []) (logged-in! [])
(is (= {:width 320 :height 256} (:size (chat))) "the size it starts with") (is (= {:width 320 :height 256} (:size (chat))) "the size it starts with")
@@ -563,6 +640,12 @@
(answer! 200 {:logged-out true}) (answer! 200 {:logged-out true})
(is (= {:width 500 :height 400} (:size (chat)))))) (is (= {:width 500 :height 400} (:size (chat))))))
(deftest chat-resize-persists-across-a-reload-test
(logged-in! [])
(dispatch! [::events/chat-resize 500 400])
(dispatch! [::events/initialize])
(is (= {:width 500 :height 400} (:size (chat)))))
(deftest chat-forgotten-on-logout-test (deftest chat-forgotten-on-logout-test
(logged-in! []) (logged-in! [])
(say! "hello") (say! "hello")
@@ -606,6 +689,62 @@
{:id id :name tool-name :content content :error? error?}) {:id id :name tool-name :content content :error? error?})
results)))) results))))
(defn- aborted-streams [] (count (filter (comp #{::events/abort-stream} first) @effects)))
(deftest chat-halt-test
(testing "halting while it only reasons: the stream stops, and the reasoning stays on screen, marked"
(logged-in! [])
(say! "hello")
(event! {:thinking "hmm, maybe"})
(dispatch! [::events/chat-halt])
(is (= 1 (aborted-streams)))
(is (= {:messages [{:role "user" :content "hello"}
{:role "assistant" :content "" :thinking "hmm, maybe" :halted? true}]
:input "" :status :idle :error nil}
(select-keys (chat) [:messages :input :status :error])))
(testing "but isn't saved, nor sent: there is nothing in it for the server"
(is (= {:messages [{:role "user" :content "hello"}]} (:body (last-persist-request))))
(say! "no, do it this way")
(is (= [{:role "user" :content "hello"} {:role "user" :content "no, do it this way"}]
(sent-messages (last-request))))))
(testing "halting mid-reply keeps what was said, and the next message steers from it"
(logged-in! [])
(say! "hello")
(event! {:content "Hel"})
(dispatch! [::events/chat-halt])
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hel" :halted? true}]
(:messages (chat))))
(testing "events that come after are dropped"
(event! {:content "lo"})
(event! {:done true})
(is (= "Hel" (:content (last (:messages (chat)))))))
(say! "shorter please")
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hel"}
{:role "user" :content "shorter please"}]
(sent-messages (last-request)))))
(testing "halting before anything came"
(logged-in! [])
(say! "hello")
(dispatch! [::events/chat-halt])
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "" :halted? true}]
(:messages (chat)))))
(testing "halting while the tools run: each call gets an answer, and their real results are dropped"
(logged-in! [])
(say! "hello")
(asks! (call "c1" "add" "{}"))
(dispatch! [::events/chat-halt])
(is (= :idle (:status (chat))))
(is (= {:role "tool" :tool-call-id "c1" :name "add" :error? true}
(dissoc (last (:messages (chat))) :content)))
(let [n (count (:messages (chat)))]
(ran! ["c1" "add" "5"])
(is (= n (count (:messages (chat))))))
(is (= 1 (count (requests))) "nothing more went to the LLM"))
(testing "halting when nothing is on its way does nothing"
(logged-in! [])
(dispatch! [::events/chat-halt])
(is (zero? (aborted-streams)))))
(deftest chat-offers-the-tools-test (deftest chat-offers-the-tools-test
(logged-in! []) (logged-in! [])
(testing "no tools on the page, none offered" (testing "no tools on the page, none offered"
@@ -618,6 +757,27 @@
(is (= [{:name "add" :description "Adds" :parameters add-schema}] (is (= [{:name "add" :description "Adds" :parameters add-schema}]
(:tools (:body (last-request))))))) (:tools (:body (last-request)))))))
(deftest chat-offers-the-state-test
(logged-in! [])
(testing "no state provider on the page, none offered"
(say! "hi")
(is (not (contains? (:body (last-request)) :state))))
(testing "the page's state goes along with the conversation, as tbd.chat.schema/RunAgentInput's state"
(reply! "hello")
(model-context/register-state! [{:provide (fn [] {:board (vec (repeat 9 nil))})}])
(say! "again")
(is (= {:board (vec (repeat 9 nil))} (:state (:body (last-request))))))
(testing "a provider offered on another page adds nothing here"
(reply! "hello")
(model-context/register-state! [{:provide (fn [] {:todos []}) :pages #{:todos}}])
(say! "once more")
(is (not (contains? (:body (last-request)) :state))))
(testing "a provider that has nothing to say (nil) adds nothing"
(reply! "hello")
(model-context/register-state! [{:provide (fn [] nil)}])
(say! "again")
(is (not (contains? (:body (last-request)) :state)))))
(defn- page-of [request] (defn- page-of [request]
(some #(when (= "page" (:description %)) (:value %)) (get-in request [:body :context]))) (some #(when (= "page" (:description %)) (:value %)) (get-in request [:body :context])))
@@ -681,15 +841,17 @@
(logged-in! []) (logged-in! [])
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}]) (model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
(say! "1+2?") (say! "1+2?")
(testing "while the model reasons or writes a call, nothing is done, and the conversation has neither" (testing "while the model reasons or writes a call, nothing is done, and no tools have run"
(event! {:thinking "I should add."}) (event! {:thinking "I should add."})
(event! {:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}) (event! {:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]})
(is (= [{:role "user" :content "1+2?"}] (:messages (chat)))) (is (= [{:role "user" :content "1+2?"}
{:role "assistant" :content "" :thinking "I should add."}]
(:messages (chat))))
(is (= [] (tool-calls-asked)))) (is (= [] (tool-calls-asked))))
(testing "when the reply is over, the calls join the conversation and are made" (testing "when the reply is over, the calls join the conversation and are made"
(event! {:done true}) (event! {:done true})
(is (= [{:role "user" :content "1+2?"} (is (= [{:role "user" :content "1+2?"}
{:role "assistant" :content "" {:role "assistant" :content "" :thinking "I should add."
:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}] :tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}]
(:messages (chat)))) (:messages (chat))))
(is (= :loading (:status (chat))) "the LLM still has to answer") (is (= :loading (:status (chat))) "the LLM still has to answer")
@@ -716,6 +878,57 @@
(is (= {:status :idle :error nil} (select-keys (chat) [:status :error]))) (is (= {:status :idle :error nil} (select-keys (chat) [:status :error])))
(is (nil? (:pending-calls (chat)))))) (is (nil? (:pending-calls (chat))))))
(deftest chat-tool-result-too-big-for-the-server-test
;; A result over the LLM's limit is kept whole in the tab and in /api/chat/history (for "Expand
;; tool use" to show all of it, even after a reload), but fit to that limit for the LLM.
(logged-in! [])
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
(let [huge (apply str (repeat 9000 "x"))]
(say! "1+2?")
(event! {:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")] :done true})
(ran! ["c1" "add" huge false])
(testing "the tab's own copy is whole"
(is (= huge (:content (last (:messages (chat)))))))
(testing "what goes to the LLM is fit to the server's limit"
(let [sent (:content (last (sent-messages (last-request))))]
(is (= 8000 (count sent)))
(is (= "xxx … (truncated)" (subs sent 7983)))))
(reply! "It's 3.")
(testing "what's saved for next login is whole, once the turn ends"
(let [saved (:content (first (filter #(= "tool" (:role %)) (:messages (:body (last-persist-request))))))]
(is (= huge saved))))))
(deftest chat-reasoning-too-big-for-history-test
;; Reasoning, like a tool result, is kept whole in the tab and in what's saved (for "Show
;; reasoning" to show all of it, even after a reload), up to the history's own, larger limit.
(logged-in! [])
(say! "hello")
(let [huge (apply str (repeat 100010 "x"))]
(event! {:thinking huge})
(testing "the tab's own copy is whole"
(is (= huge (:thinking (last (:messages (chat)))))))
(reply! "Hi!")
(testing "what's saved for next login is fit to the history's limit"
(let [saved (:thinking (first (filter :thinking (:messages (:body (last-persist-request))))))]
(is (= 100000 (count saved)))
(is (= "xxx … (truncated)" (subs saved 99983)))))))
(deftest chat-history-too-big-drops-oldest-test
;; Past the history's total limit, the oldest turns go, whole.
(logged-in! [])
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
(let [big (apply str (repeat 90000 "x"))]
(dotimes [i 12]
(say! (str "q" i))
(event! {:tool-calls [(call (str "c" i) "add" "{}")] :done true})
(ran! [(str "c" i) "add" big false])
(reply! (str "a" i)))
(let [saved (:messages (:body (last-persist-request)))]
(is (<= (count (pr-str saved)) 1000000))
(is (= "user" (:role (first saved))))
(is (= "a11" (:content (last saved))))
(is (every? #(= big (:content %)) (filter #(= "tool" (:role %)) saved))))))
(deftest chat-tool-call-with-text-test (deftest chat-tool-call-with-text-test
(logged-in! []) (logged-in! [])
(say! "hi") (say! "hi")
@@ -751,6 +964,41 @@
(dispatch! [::events/chat-send]) (dispatch! [::events/chat-send])
(is (zero? (:tool-calls-used (chat)))))) (is (zero? (:tool-calls-used (chat))))))
(deftest chat-once-per-turn-tools-test
;; A once-per-turn tool (like tic-tac-toe's move_tic_tac_toe: the bug this guards against was
;; the chatbot happily playing both sides of one game in answer to a single "make a move") may
;; run once in a turn; a second attempt, whether the model asks again after the first result or
;; in the very same reply, is refused without ever reaching the page.
(logged-in! [])
(model-context/register! [{:name "move" :once-per-turn? true :description "d" :input-schema add-schema
:handler identity}
{:name "ping" :description "d" :input-schema add-schema :handler identity}])
(say! "make a move")
(testing "offered like any other tool, the first time"
(is (= ["move" "ping"] (map :name (:tools (:body (last-request)))))))
(testing "once it has run, it is no longer offered for the rest of the turn"
(asks! (call "a" "move" "{}"))
(is (= [(call "a" "move" "{}")] (:calls (last (tool-calls-asked)))) "the first call goes through, unmarked")
(ran! ["a" "move" "ok" false])
(is (= ["ping"] (map :name (:tools (:body (last-request)))))))
(testing "asking for it again anyway this turn is refused before it ever reaches the page"
(asks! (call "b" "move" "{}"))
(is (= [(assoc (call "b" "move" "{}") :blocked? true)] (:calls (last (tool-calls-asked))))))
(testing "two calls to it in the very same reply: only the first of them runs"
(ran! ["b" "move" "n/a" true])
(reply! "Can't move again this turn.")
(say! "go again")
(asks! (call "c" "move" "{}") (call "d" "move" "{}"))
(is (= [(call "c" "move" "{}") (assoc (call "d" "move" "{}") :blocked? true)]
(:calls (last (tool-calls-asked))))))
(testing "a new message starts a fresh turn: the tool is offered, and may run, again"
(ran! ["c" "move" "n/a" false] ["d" "move" "n/a" true])
(reply! "Moved.")
(say! "make another")
(is (= ["move" "ping"] (map :name (:tools (:body (last-request))))))
(asks! (call "e" "move" "{}"))
(is (= [(call "e" "move" "{}")] (:calls (last (tool-calls-asked)))))))
(deftest chat-tool-call-budget-test (deftest chat-tool-call-budget-test
(logged-in! []) (logged-in! [])
(say! "go wild") (say! "go wild")
@@ -827,7 +1075,11 @@
(select-keys (chat) [:messages :input :status :error :pending-calls]))) (select-keys (chat) [:messages :input :status :error :pending-calls])))
(is (= [] (tool-calls-asked))))) (is (= [] (tool-calls-asked)))))
(deftest chat-sends-results-of-earlier-turns-as-out-of-date-test (deftest chat-sends-results-of-earlier-turns-as-they-are-test
;; Nothing here marks an old result stale: the request's `state` (tbd.ui.model-context/
;; current-state) is refreshed on every message, and the system prompt tells the model that is
;; what to trust over anything said earlier, an old result included — so there is nothing left
;; for a marker on the result itself to do.
(logged-in! []) (logged-in! [])
(swap! rf-db/app-db assoc-in [:chat :messages] (swap! rf-db/app-db assoc-in [:chat :messages]
[{:role "user" :content "play"} [{:role "user" :content "play"}
@@ -835,20 +1087,19 @@
{:role "tool" :tool-call-id "old" :name "get_tic_tac_toe" :content "{\"turn\":\"x\"}" :error? false} {:role "tool" :tool-call-id "old" :name "get_tic_tac_toe" :content "{\"turn\":\"x\"}" :error? false}
{:role "assistant" :content "Your move."}]) {:role "assistant" :content "Your move."}])
(say! "that's wrong, it's my turn") (say! "that's wrong, it's my turn")
(testing "a result from before the user's last message is no longer sent, its call and reply are" (testing "an earlier result is sent as it was, like its call and reply"
(let [sent (get-in (last-request) [:body :messages])] (let [sent (get-in (last-request) [:body :messages])]
(is (= ["user" "assistant" "tool" "assistant" "user"] (map :role sent))) (is (= ["user" "assistant" "tool" "assistant" "user"] (map :role sent)))
(is (= "old" (:toolCallId (nth sent 2)))) (is (= "old" (:toolCallId (nth sent 2))))
(is (str/includes? (:content (nth sent 2)) "out of date")) (is (= "{\"turn\":\"x\"}" (:content (nth sent 2))))
(is (not (str/includes? (:content (nth sent 2)) "\"turn\"")) "what it read is gone")
(is (= "Your move." (:content (nth sent 3)))))) (is (= "Your move." (:content (nth sent 3))))))
(testing "the conversation the user sees keeps the result" (testing "the conversation the user sees keeps the result"
(is (= "{\"turn\":\"x\"}" (:content (nth (:messages (chat)) 2))))) (is (= "{\"turn\":\"x\"}" (:content (nth (:messages (chat)) 2)))))
(testing "the results of the turn going on are sent as they are, for the chain to continue" (testing "the results of the turn going on are sent as they are too, for the chain to continue"
(asks! (call "new" "get_tic_tac_toe" "{}")) (asks! (call "new" "get_tic_tac_toe" "{}"))
(ran! ["new" "get_tic_tac_toe" "{\"turn\":\"o\"}" false]) (ran! ["new" "get_tic_tac_toe" "{\"turn\":\"o\"}" false])
(let [sent (get-in (last-request) [:body :messages])] (let [sent (get-in (last-request) [:body :messages])]
(is (str/includes? (:content (nth sent 2)) "out of date")) (is (= "{\"turn\":\"x\"}" (:content (nth sent 2))))
(is (= "{\"turn\":\"o\"}" (:content (last sent))))))) (is (= "{\"turn\":\"o\"}" (:content (last sent)))))))
(deftest chat-sends-no-orphaned-result-test (deftest chat-sends-no-orphaned-result-test
@@ -916,23 +1167,26 @@
(call "4" "blank" "") (call "4" "blank" "")
(call "5" "fails" "{}") (call "5" "fails" "{}")
(call "6" "nope" "{}") (call "6" "nope" "{}")
(call "7" "fast" "oops")] (call "7" "fast" "oops")
(assoc (call "8" "fast" "{}") :blocked? true)]
:on-results [::ran]}))) :on-results [::ran]})))
(fn [results] (fn [results]
(testing "one after the other, in order: the tools work on the same page" (testing "one after the other, in order: the tools work on the same page"
(is (= [:slow :fast] @order))) (is (= [:slow :fast] @order)) "the blocked call never touches the tool, so \"fast\" runs only once")
(testing "a result for each call, whatever became of it" (testing "a result for each call, whatever became of it"
(is (= ["1" "2" "3" "4" "5" "6" "7"] (map :id results))) (is (= ["1" "2" "3" "4" "5" "6" "7" "8"] (map :id results)))
(is (= ["slow" "fast" "huge" "blank" "fails" "nope" "fast"] (map :name results))) (is (= ["slow" "fast" "huge" "blank" "fails" "nope" "fast" "fast"] (map :name results)))
(is (= ["slow done" "fast {:x 1}"] (map :content (take 2 results))))) (is (= ["slow done" "fast {:x 1}"] (map :content (take 2 results)))))
(testing "a result is never empty, and never longer than the server takes" (testing "a result is never empty, and kept whole (fit to the server's limit only once it leaves the tab)"
(is (= "(no output)" (:content (nth results 3)))) (is (= "(no output)" (:content (nth results 3))))
(is (= 8000 (count (:content (nth results 2))))) (is (= 9000 (count (:content (nth results 2))))))
(is (= "xxx … (truncated)" (subs (:content (nth results 2)) 7983))))
(testing "failures are results for the LLM to read" (testing "failures are results for the LLM to read"
(is (= [false false false false true true true] (map (comp boolean :error?) results))) (is (= [false false false false true true true true] (map (comp boolean :error?) results)))
(is (= ["it broke" "unknown tool: nope" "invalid arguments: they must be a JSON object"] (is (= ["it broke" "unknown tool: nope" "invalid arguments: they must be a JSON object"]
(map :content (drop 4 results)))))) (map :content (drop 4 (take 7 results))))))
(testing "a blocked call is refused before it ever reaches the tool"
(is (= "not run: this only runs once per message, and already has this turn — answer instead of calling it again"
(:content (last results))))))
#(js/Promise. (fn [resolve] #(js/Promise. (fn [resolve]
(reset! answer resolve) (reset! answer resolve)
(call-tools-fx {:calls [] :on-results [::ran]}))) (call-tools-fx {:calls [] :on-results [::ran]})))
+37 -4
View File
@@ -55,10 +55,43 @@
(tu/steps (tu/steps
#(stream! (streaming asked (sse {:type "RUN_FINISHED"})) 1) #(stream! (streaming asked (sse {:type "RUN_FINISHED"})) 1)
(fn [_] (fn [_]
(is (= ["/api/chat" {:method "POST" (let [[uri opts] @asked]
:headers {:Content-Type "application/edn"} (is (= ["/api/chat" {:method "POST"
:body "{:x 1}"}] :headers {:Content-Type "application/edn"}
@asked)))) :body "{:x 1}"}]
[uri (dissoc opts :signal)]))
(is (instance? js/AbortSignal (:signal opts)) "with a signal, for ::abort-stream"))))
done))))
(deftest abort-test
;; Halted (see ::events/chat-halt): nothing more is dispatched — not the rest of the stream, nor
;; the \"connection lost\" its end would otherwise be.
(async done
(let [release (atom nil)
fetch (fn [_ _]
(js/Promise.resolve
#js {:ok true :status 200
:body #js {:getReader
(fn []
(let [reads (atom [(sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}) :wait])]
#js {:read (fn []
(let [r (first @reads)]
(swap! reads rest)
(cond
(= :wait r) (js/Promise. #(reset! release %))
(nil? r) (js/Promise.resolve #js {:done true})
:else (js/Promise.resolve #js {:done false :value r}))))
:cancel (fn [] (js/Promise.resolve nil))}))}}))]
(tu/finish
(tu/steps
#(stream! fetch 1)
(fn [got]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] got))
((tu/real-effect ::events/abort-stream) true)
(@release #js {:done false :value (sse {:type "TEXT_MESSAGE_CONTENT" :delta "late"})})
(js/Promise. (fn [resolve] (js/setTimeout resolve 30))))
(fn [_]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] @got) "nothing after the abort")))
done)))) done))))
(deftest events-test (deftest events-test
+34
View File
@@ -0,0 +1,34 @@
(ns tbd.ui.markdown-test
(:require [cljs.test :refer [deftest is testing]]
[tbd.ui.markdown :as markdown]))
(deftest render-test
(testing "plain text, wrapped in a paragraph"
(is (= [:<> [:p "hello"]] (markdown/render "hello"))))
(testing "inline formatting"
(is (= [:<> [:p "a " [:strong "bold"] " " [:em "word"] " and " [:code "code"]]]
(markdown/render "a **bold** *word* and `code`"))))
(testing "a single newline is a line break, not a new paragraph"
(is (= [:<> [:p "one" [:br] "two"]] (markdown/render "one\ntwo"))))
(testing "a stray * or _ that isn't emphasis (padded with a space) is left alone"
(is (= [:<> [:p "3 * 4 * 5"]] (markdown/render "3 * 4 * 5"))))
(testing "headings, a list, a fenced code block"
(is (= [:<>
[:h1 "Title"]
[:ul [:li "a"] [:li "b"]]
[:pre [:code {:class "language-js"} "1"]]]
(markdown/render "# Title\n\n- a\n- b\n\n```js\n1\n```"))))
(testing "an ordered list and a blockquote"
(is (= [:<> [:ol [:li "a"] [:li "b"]]] (markdown/render "1. a\n2. b")))
(is (= [:<> [:blockquote [:p "hi"]]] (markdown/render "> hi"))))
(testing "a table"
(is (= [:<> [:table [:thead [:tr [:th "a"] [:th "b"]]]
[:tbody [:tr [:td "1"] [:td "2"]]]]]
(markdown/render "a | b\n-|-\n1 | 2"))))
(testing "no markup leaks through as HTML: it's always a plain string, never dangerouslySetInnerHTML"
(is (= [:<> [:p "hi<script>alert(1)</script>"]] (markdown/render "hi<script>alert(1)</script>"))))
(testing "a link opens in its own tab, not the app's"
(is (= [:<> [:p [:a {:href "https://example.com" :target "_blank" :rel "noopener noreferrer"} "x"]]]
(markdown/render "[x](https://example.com)"))))
(testing "a javascript: link loses its href (and so its target/rel), the text stays"
(is (= [:<> [:p [:span "x"]]] (markdown/render "[x](javascript:evil)")))))
+14
View File
@@ -122,6 +122,20 @@
(fn [_] (is (= [:tic-tac-toe-only :everywhere] @ran) "and never run"))) (fn [_] (is (= [:tic-tac-toe-only :everywhere] @ran) "and never run")))
done)))) done))))
(deftest current-state-test
(testing "nothing registered, nothing to offer"
(is (= {} (model-context/current-state :todos))))
(model-context/register-state! [{:provide (fn [] {:todos [{:title "milk"}]}) :pages #{:todos}}
{:provide (fn [] {:board (vec (repeat 9 nil))}) :pages #{:tic-tac-toe}}
{:provide (fn [] {:page-status "ok"})}])
(testing "only the providers offered on the page run, merged into one map"
(is (= {:todos [{:title "milk"}] :page-status "ok"} (model-context/current-state :todos)))
(is (= {:board (vec (repeat 9 nil)) :page-status "ok"} (model-context/current-state :tic-tac-toe)))
(is (= {:page-status "ok"} (model-context/current-state :calculator))))
(testing "clear! takes state providers away too"
(model-context/clear!)
(is (= {} (model-context/current-state :todos)))))
(deftest call-failures-test (deftest call-failures-test
(let [ran? (atom false)] (let [ran? (atom false)]
(model-context/register! [(tool "t" (fn [_] (reset! ran? true) "ran"))]) (model-context/register! [(tool "t" (fn [_] (reset! ran? true) "ran"))])
+14 -4
View File
@@ -76,6 +76,13 @@
{:content "echo: "} {:content "echo: "}
{:content (:content (last (:messages body)))} {:content (:content (last (:messages body)))}
{:done true}])))) {:done true}]))))
(and (= "GET" method) (= "/api/chat/history" uri)) (respond 200 {:messages (:chat-history @server [])})
(and (= "PUT" method) (= "/api/chat/history" uri))
(do (swap! server assoc :chat-history (:messages body))
(respond 200 {:saved true}))
(and (= "DELETE" method) (= "/api/chat/history" uri))
(do (swap! server assoc :chat-history [])
(respond 200 {:cleared true}))
(and (= "GET" method) (= "/api/todos" uri)) (respond 200 {:todos todos}) (and (= "GET" method) (= "/api/todos" uri)) (respond 200 {:todos todos})
(and (= "POST" method) (= "/api/todos" uri)) (and (= "POST" method) (= "/api/todos" uri))
(if (seq (.trim (:title body))) (if (seq (.trim (:title body)))
@@ -167,10 +174,13 @@
(aset js/globalThis "fetch" real-fetch))}) (aset js/globalThis "fetch" real-fetch))})
(def url-fixture (def url-fixture
"Each test starts on the page's own address, with no fragment (the page shown is the first)." "Each test starts on the page's own address, with no fragment (the page shown is the first), and
(let [reset-hash! #(set! js/location.hash "")] with nothing saved in localStorage (e.g. the chat widget's :open?/:size, see
{:before reset-hash! tbd.ui.events/persist-chat-ui) — jsdom's window, and so its localStorage, is shared by every
:after reset-hash!})) test in the process."
(let [reset! #(do (set! js/location.hash "") (.clear js/localStorage))]
{:before reset!
:after reset!}))
(defn log-in! [] (swap! server assoc :user {:login "alice" :id 7})) (defn log-in! [] (swap! server assoc :user {:login "alice" :id 7}))
+17 -1
View File
@@ -1,10 +1,13 @@
(ns tbd.ui.tictactoe-test (ns tbd.ui.tictactoe-test
(:require [cljs.test :refer [deftest is testing]] (:require [cljs.test :refer [deftest is testing use-fixtures]]
[re-frame.core :as rf] [re-frame.core :as rf]
[re-frame.db :as rf-db] [re-frame.db :as rf-db]
[tbd.ui.events :as events] [tbd.ui.events :as events]
[tbd.ui.test-util :as tu]
[tbd.ui.tictactoe :as ttt])) [tbd.ui.tictactoe :as ttt]))
(use-fixtures :each tu/url-fixture)
(defn- board (defn- board
"A board from a string of 9 characters: x, o or anything else for an empty cell." "A board from a string of 9 characters: x, o or anything else for an empty cell."
[s] [s]
@@ -70,3 +73,16 @@
(testing "a draw" (testing "a draw"
(move! 0 1 2 4 3 5 7 6 8) (move! 0 1 2 4 3 5 7 6 8)
(is (= :draw (:outcome (game))))))) (is (= :draw (:outcome (game)))))))
(deftest persistence-test
(rf/dispatch-sync [::events/initialize])
(move! 0 3)
(testing "a reload finds the game where it was left"
(rf/dispatch-sync [::events/initialize])
(let [{:keys [board turn]} (:ttt @rf-db/app-db)]
(is (= [:x nil nil :o] (subvec board 0 4)))
(is (= :x turn))))
(testing "a reset is also remembered"
(rf/dispatch-sync [::events/ttt-reset])
(rf/dispatch-sync [::events/initialize])
(is (= ttt/new-board (:board (:ttt @rf-db/app-db))))))
+73 -15
View File
@@ -483,7 +483,9 @@
(defn- chat-messages (defn- chat-messages
"What the conversation shows, message by message." "What the conversation shows, message by message."
[] []
(mapv #(.-textContent %) (q-all "[role=log] > div:not([role=status]):not([data-tool])"))) (mapv #(.-textContent %) (q-all "[role=log] > div:not([data-pending]):not([data-tool]):not([data-halted])")))
(defn- chat-status [] (:status (:chat @rf-db/app-db)))
(defn- chat-tool-lines (defn- chat-tool-lines
"The tool calls and results the conversation shows, line by line." "The tool calls and results the conversation shows, line by line."
@@ -500,6 +502,16 @@
[] []
(mapv #(.-textContent %) (tool-toggle-buttons))) (mapv #(.-textContent %) (tool-toggle-buttons)))
(defn- reasoning-toggle-buttons []
(filterv #(re-find #"reasoning$" (.-textContent %)) (q-all "[role=dialog] button")))
(defn- reasoning-toggle [] (first (reasoning-toggle-buttons)))
(defn- reasoning-toggle-labels
"The label of the button that shows or hides the reasoning, if the panel has one."
[]
(mapv #(.-textContent %) (reasoning-toggle-buttons)))
(deftest chat-widget-test (deftest chat-widget-test
;; A green square in the bottom left corner, opposite WebMCP's blue one; it opens the panel. ;; A green square in the bottom left corner, opposite WebMCP's blue one; it opens the panel.
(async done (async done
@@ -549,7 +561,9 @@
(fn [_] (fn [_]
(is (= "" (.-value (q "input[name=message]"))) "the input is emptied when sent") (is (= "" (.-value (q "input[name=message]"))) "the input is emptied when sent")
(is (nil? (q "[role=status]")) "no longer thinking") (is (nil? (q "[role=status]")) "no longer thinking")
(is (= ["Clear" "×"] (mapv #(.-textContent %) (q-all "[role=dialog] > div:first-child button")))) (is (= ["Show reasoning" "Clear" "×"]
(mapv #(.-textContent %) (q-all "[role=dialog] > div:first-child button")))
"the fake server reasons before it echoes, so the toggle shows too")
(type! (q "input[name=message]") "again") (type! (q "input[name=message]") "again")
(tu/eventually (fn [] (= "again" (.-value (q "input[name=message]")))))) (tu/eventually (fn [] (= "again" (.-value (q "input[name=message]"))))))
(fn [_] (fn [_]
@@ -589,7 +603,7 @@
(fn [_] (fn [_]
(is (= "Thinking…" (text "[role=status]"))) (is (= "Thinking…" (text "[role=status]")))
(is (= ["hello"] (chat-messages))) (is (= ["hello"] (chat-messages)))
(is (true? (.-readOnly (q "input[name=message]")))) (is (false? (.-readOnly (q "input[name=message]"))) "typing ahead is still possible")
(is (true? (.-disabled (q "[role=dialog] button[type=submit]")))) (is (true? (.-disabled (q "[role=dialog] button[type=submit]"))))
(is (nil? (first (filter #(= "Clear" (.-textContent %)) (q-all "[role=dialog] button")))) (is (nil? (first (filter #(= "Clear" (.-textContent %)) (q-all "[role=dialog] button"))))
"can't start over mid-reply") "can't start over mid-reply")
@@ -622,7 +636,8 @@
(deftest chat-streaming-test (deftest chat-streaming-test
;; The reply shows as it arrives: "Thinking…" until the model's first word (however long it ;; The reply shows as it arrives: "Thinking…" until the model's first word (however long it
;; reasons, which is never shown), then the reply growing piece by piece, and only at its end can ;; reasons, which is not shown unless "Show reasoning" is turned on — see
;; chat-reasoning-toggle-test), then the reply growing piece by piece, and only at its end can
;; another message be sent. ;; another message be sent.
(async done (async done
(swap! tu/server assoc :chat-script [:pause (swap! tu/server assoc :chat-script [:pause
@@ -645,22 +660,52 @@
"still thinking while the model reasons") "still thinking while the model reasons")
(is (not (str/includes? (panel-text) "Let me think.")) "and what it reasons is not shown") (is (not (str/includes? (panel-text) "Let me think.")) "and what it reasons is not shown")
(is (= ["hi"] (chat-messages)) "it hasn't said anything") (is (= ["hi"] (chat-messages)) "it hasn't said anything")
(is (true? (.-readOnly (q "input[name=message]"))) "and it isn't over") (is (= :loading (chat-status)) "and it isn't over")
(is (false? (.-readOnly (q "input[name=message]"))) "but typing ahead still works")
(resume-stream!)) (resume-stream!))
#(tu/eventually (fn [] (and (:resume @tu/server) (= ["hi" "Hello"] (chat-messages))))) #(tu/eventually (fn [] (and (:resume @tu/server) (= ["hi" "Hello"] (chat-messages)))))
(fn [_] (fn [_]
(is (nil? (q "[role=status]")) "the model has begun to answer") (is (nil? (q "[role=status]")) "the model has begun to answer")
(is (true? (.-readOnly (q "input[name=message]"))) "but it isn't over") (is (= :loading (chat-status)) "but it isn't over")
(is (true? (.-disabled (q "[role=dialog] button[type=submit]")))) (is (true? (.-disabled (q "[role=dialog] button[type=submit]"))))
(resume-stream!)) (resume-stream!))
#(tu/eventually (fn [] (= ["hi" "Hello, world"] (chat-messages)))) #(tu/eventually (fn [] (= ["hi" "Hello, world"] (chat-messages))))
#(tu/eventually (fn [] (false? (.-readOnly (q "input[name=message]"))))) #(tu/eventually (fn [] (= :idle (chat-status))))
(fn [_] (fn [_]
(is (not (str/includes? (panel-text) "Let me think.")) "the reasoning is not shown after it either") (is (not (str/includes? (panel-text) "Let me think.")) "the reasoning is not shown after it either")
(is (nil? (q "[role=status]"))) (is (nil? (q "[role=status]")))
(is (nil? (q "[role=dialog] [role=alert]"))))) (is (nil? (q "[role=dialog] [role=alert]")))))
done))) done)))
(deftest chat-halt-test
;; The stop button beside "Thinking…" halts the reply mid-thought, so the next message can steer
;; it; what the stream would have sent after is never shown.
(async done
(swap! tu/server assoc :chat-scripts [[{:thinking "Let me "} :pause {:content "late"} {:done true}]])
(tu/finish
(tu/steps
#(log-in-page! [])
(fn [] (click! (q "button[aria-label=Chat]")))
(fn [] (is (nil? (q "button[aria-label=Stop]")) "nothing to stop yet"))
#(send-chat! "hi")
#(tu/eventually (fn [] (and (:resume @tu/server) (q "button[aria-label=Stop]"))))
(fn [stop]
(is (re-matches #"Thinking(\.{1,3}|…)" (text "[role=status]")))
(click! stop))
#(tu/eventually (fn [] (q "[data-halted]")))
(fn [_]
(is (nil? (q "button[aria-label=Stop]")))
(is (nil? (q "[role=status]")))
(is (some? (q "[data-halted]")) "the reply is marked as stopped")
(resume-stream!))
#(tu/eventually (fn [] true))
(fn [_]
(is (not (str/includes? (panel-text) "late")) "what came after the halt is dropped")
(is (= ["hi"] (chat-messages))))
#(send-chat! "try this instead")
#(tu/eventually (fn [] (= ["hi" "try this instead" "echo: try this instead"] (chat-messages)))))
done)))
(deftest chat-thinking-animation-test (deftest chat-thinking-animation-test
;; While pieces of the reasoning are coming in "Thinking" has one to three dots; once they stop ;; While pieces of the reasoning are coming in "Thinking" has one to three dots; once they stop
;; (for a moment) it is "Thinking…" again. ;; (for a moment) it is "Thinking…" again.
@@ -687,8 +732,10 @@
#(tu/eventually (fn [] (nil? (q "[role=status]"))))) #(tu/eventually (fn [] (nil? (q "[role=status]")))))
done))) done)))
(deftest chat-reasoning-is-never-shown-test (deftest chat-reasoning-toggle-test
;; Neither while it comes nor in the finished conversation, in any element of the panel. ;; The reasoning behind a reply is never shown by default, in any element of the panel, while it
;; comes or after; "Show reasoning" reveals it, whole (nothing cut off), for every reply that
;; reasoned; "Hide reasoning" hides it again.
(async done (async done
(let [thought "secret reasoning about the answer"] (let [thought "secret reasoning about the answer"]
(swap! tu/server assoc :chat-script [{:thinking thought} {:content "Done."} {:done true}]) (swap! tu/server assoc :chat-script [{:thinking thought} {:content "Done."} {:done true}])
@@ -699,7 +746,16 @@
#(send-chat! "hi") #(send-chat! "hi")
#(tu/eventually (fn [] (= ["hi" "Done."] (chat-messages)))) #(tu/eventually (fn [] (= ["hi" "Done."] (chat-messages))))
(fn [_] (fn [_]
(is (not (str/includes? (panel-text) "secret"))))) (is (not (str/includes? (panel-text) "secret")) "hidden by default")
(is (= ["Show reasoning"] (reasoning-toggle-labels)))
(click! (reasoning-toggle)))
#(tu/eventually (fn [] (= ["Hide reasoning"] (reasoning-toggle-labels))))
(fn [_]
(is (str/includes? (panel-text) thought) "shown, whole, once expanded")
(click! (reasoning-toggle)))
#(tu/eventually (fn [] (= ["Show reasoning"] (reasoning-toggle-labels))))
(fn [_]
(is (not (str/includes? (panel-text) "secret")) "hidden again")))
done)))) done))))
(defn- pointer! (defn- pointer!
@@ -798,7 +854,7 @@
(is (= 1000 @@top) "back near the end, it follows again") (is (= 1000 @@top) "back near the end, it follows again")
(reset! @top 200) (reset! @top 200)
(.dispatchEvent (q "[role=log]") (js/window.Event. "scroll"))) (.dispatchEvent (q "[role=log]") (js/window.Event. "scroll")))
#(tu/eventually (fn [] (false? (.-readOnly (q "input[name=message]"))))) #(tu/eventually (fn [] (= :idle (chat-status))))
#(send-chat! "again") #(send-chat! "again")
#(tu/eventually (fn [] (and (:resume @tu/server) (= 1000 @@top)))) #(tu/eventually (fn [] (and (:resume @tu/server) (= 1000 @@top))))
(fn [_] (fn [_]
@@ -828,8 +884,10 @@
#(tu/eventually (fn [] (= ["what is 2 + 3? use the calculator" "I'll add them." "2 + 3 is 5."] #(tu/eventually (fn [] (= ["what is 2 + 3? use the calculator" "I'll add them." "2 + 3 is 5."]
(chat-messages)))) (chat-messages))))
(fn [_] (fn [_]
(testing "the LLM was told about the tools of the page it was on (the calculator), not all of them" (testing "the LLM was told about the tools of the page it was on (the calculator), not all of them,
(is (= (set (map :name (filter #(contains? (or (:pages %) #{:calculator}) :calculator) webmcp/tools))) and not the read-only ones (get_calculator): its state covers those"
(is (= (set (map :name (remove :read-only? (filter #(contains? (or (:pages %) #{:calculator}) :calculator)
webmcp/tools))))
(set (map :name (:tools (first (:chat-requests @tu/server)))))))) (set (map :name (:tools (first (:chat-requests @tu/server))))))))
(testing "the page made the call, as a user would: the calculator holds what was typed and its sum" (testing "the page made the call, as a user would: the calculator holds what was typed and its sum"
(is (= {:x "2" :y "3" :result {:status :ok :x "2" :y "3" :sum 5}} (is (= {:x "2" :y "3" :result {:status :ok :x "2" :y "3" :sum 5}}
@@ -853,7 +911,7 @@
{:role "tool" :toolCallId "call_1" :content "{\"x\":2,\"y\":3,\"sum\":5}"}] {:role "tool" :toolCallId "call_1" :content "{\"x\":2,\"y\":3,\"sum\":5}"}]
(mapv #(dissoc % :id) (:messages (second (:chat-requests @tu/server))))))) (mapv #(dissoc % :id) (:messages (second (:chat-requests @tu/server)))))))
(testing "and it is over: the panel takes messages again" (testing "and it is over: the panel takes messages again"
(is (false? (.-readOnly (q "input[name=message]"))))) (is (= :idle (chat-status))))
(click! (tool-toggle))) (click! (tool-toggle)))
#(tu/eventually (fn [] (= ["Collapse tool use"] (tool-toggle-labels)))) #(tu/eventually (fn [] (= ["Collapse tool use"] (tool-toggle-labels))))
(fn [_] (fn [_]
@@ -917,7 +975,7 @@
(is (= ["hi" "Hel"] (chat-messages))) (is (= ["hi" "Hel"] (chat-messages)))
(is (nil? (q "[role=status]"))) (is (nil? (q "[role=status]")))
(is (= "" (.-value (q "input[name=message]")))) (is (= "" (.-value (q "input[name=message]"))))
(is (false? (.-readOnly (q "input[name=message]"))) "another message can be sent"))) (is (= :idle (chat-status)) "another message can be sent")))
done))) done)))
(deftest chat-stream-cut-test (deftest chat-stream-cut-test
+81 -33
View File
@@ -188,10 +188,6 @@
(.then (fn [_] (.then (fn [_]
(is (= :ai-setup (page)) "reading changes nothing") (is (= :ai-setup (page)) "reading changes nothing")
(call "move_tic_tac_toe" {:cell 4 :player "x"}))) (call "move_tic_tac_toe" {:cell 4 :player "x"})))
(.then (fn [_]
(is (= :tic-tac-toe (page)))
(rf/dispatch-sync [::events/navigate :ai-setup])
(call "new_tic_tac_toe_game" {})))
(.then (fn [_] (.then (fn [_]
(is (= :tic-tac-toe (page))) (is (= :tic-tac-toe (page)))
(rf/dispatch-sync [::events/navigate :ai-setup]) (rf/dispatch-sync [::events/navigate :ai-setup])
@@ -225,9 +221,7 @@
(-> (call "whoami" {}) (-> (call "whoami" {})
(.then (fn [_] (call "set_todo_done" {:todos (mapv #(hash-map :id (tu/todo-uuid %) :done false) (range 1 4))}))) (.then (fn [_] (call "set_todo_done" {:todos (mapv #(hash-map :id (tu/todo-uuid %) :done false) (range 1 4))})))
(.then (fn [r] (.then (fn [r]
(is (false? (:error? r))) (is (= {:text "ok" :error? false} r) "nothing left to say: the page shows it, and so will the next state")
(is (= ["todo-1" "todo-2" "todo-3"] (map :title (json (:text r)))))
(is (= [false false false] (map :done (json (:text r)))))
(is (= [false false false] (map :done (get-in @rf-db/app-db [:todos :items])))) (is (= [false false false] (map :done (get-in @rf-db/app-db [:todos :items]))))
(is (= :todos (page))) (is (= :todos (page)))
;; A bad entry, or an unknown todo, refuses the whole batch before anything changes. ;; A bad entry, or an unknown todo, refuses the whole batch before anything changes.
@@ -254,9 +248,8 @@
(-> (call "whoami" {}) (-> (call "whoami" {})
(.then (fn [_] (call "create_todo" {:todos [{:title "milk"} {:title "eggs"} {:title "bread"}]}))) (.then (fn [_] (call "create_todo" {:todos [{:title "milk"} {:title "eggs"} {:title "bread"}]})))
(.then (fn [r] (.then (fn [r]
(is (false? (:error? r))) (is (= {:text "ok" :error? false} r))
(is (= ["milk" "eggs" "bread"] (map :title (json (:text r)))) "in the order given") (is (= ["milk" "eggs" "bread"] (map :title (get-in @rf-db/app-db [:todos :items]))) "in the order given")
(is (= ["milk" "eggs" "bread"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(is (= :todos (page))) (is (= :todos (page)))
(call "get_todo" {:todos [{:id (tu/todo-uuid 3)} {:id (tu/todo-uuid 1)}]}))) (call "get_todo" {:todos [{:id (tu/todo-uuid 3)} {:id (tu/todo-uuid 1)}]})))
(.then (fn [r] (.then (fn [r]
@@ -272,8 +265,7 @@
(is (= 3 (count (get-in @rf-db/app-db [:todos :items]))) "an unknown id deletes nothing") (is (= 3 (count (get-in @rf-db/app-db [:todos :items]))) "an unknown id deletes nothing")
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)} {:id (tu/todo-uuid 1)} {:id (tu/todo-uuid 2)}]}))) (call "delete_todo" {:todos [{:id (tu/todo-uuid 1)} {:id (tu/todo-uuid 1)} {:id (tu/todo-uuid 2)}]})))
(.then (fn [r] (.then (fn [r]
(is (false? (:error? r))) (is (= {:text "ok" :error? false} r) "a repeated id is deleted once, not refused as unknown the second time")
(is (= {:deleted [(tu/todo-uuid 1) (tu/todo-uuid 2)]} (json (:text r))) "a repeated id is deleted once")
(is (= ["bread"] (map :title (get-in @rf-db/app-db [:todos :items])))) (is (= ["bread"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(is (= ["bread"] (map :title (:todos @tu/server)))) (is (= ["bread"] (map :title (:todos @tu/server))))
;; The server refuses a blank title, which the page only sees after the first was added. ;; The server refuses a blank title, which the page only sees after the first was added.
@@ -367,27 +359,25 @@
(is (= {:text (str "todo not found: " (tu/todo-uuid 99)) :error? true} r)) (is (= {:text (str "todo not found: " (tu/todo-uuid 99)) :error? true} r))
(call "create_todo" {:todos [{:title "buy milk"}]}))) (call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [r] (.then (fn [r]
(is (false? (:error? r))) (is (= {:text "ok" :error? false} r))
(is (= [{:id (tu/todo-uuid 2) :title "buy milk" :done false}]
(map #(select-keys % [:id :title :done]) (json (:text r)))))
;; The page shows it, and the field is empty again. ;; The page shows it, and the field is empty again.
(is (= ["old" "buy milk"] (map :title (get-in @rf-db/app-db [:todos :items])))) (is (= ["old" "buy milk"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(is (= "" (get-in @rf-db/app-db [:todos :new-title]))) (is (= "" (get-in @rf-db/app-db [:todos :new-title])))
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]}))) (call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]})))
(.then (fn [r] (.then (fn [r]
(is (= [true] (map :done (json (:text r))))) (is (= {:text "ok" :error? false} r))
(is (true? (:done (last (get-in @rf-db/app-db [:todos :items]))))) (is (true? (:done (last (get-in @rf-db/app-db [:todos :items])))))
;; Already ticked: nothing to do, and no request. ;; Already ticked: nothing to do, and no request.
(swap! tu/server assoc :todos []) (swap! tu/server assoc :todos [])
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]}))) (call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]})))
(.then (fn [r] (.then (fn [r]
(is (= [true] (map :done (json (:text r))))) (is (= {:text "ok" :error? false} r) "still nothing to do: the now-empty server list was never asked")
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done "yes"}]}))) (call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done "yes"}]})))
(.then (fn [r] (.then (fn [r]
(is (:error? r)) (is (:error? r))
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]}))) (call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
(.then (fn [r] (.then (fn [r]
(is (= {:text (str "{\"deleted\":[\"" (tu/todo-uuid 1) "\"]}") :error? false} r)) (is (= {:text "ok" :error? false} r))
(is (= ["buy milk"] (map :title (get-in @rf-db/app-db [:todos :items])))) (is (= ["buy milk"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]}))) (call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
(.then (fn [r] (.then (fn [r]
@@ -408,6 +398,11 @@
(is (empty? (get-in @rf-db/app-db [:todos :items]))) (is (empty? (get-in @rf-db/app-db [:todos :items])))
(done)))))) (done))))))
(deftest tic-tac-toe-tools-are-once-per-turn
;; A move is the person's to ask for again, not the model's to repeat on its own: tbd.ui.events
;; (see its once-per-turn tests) only lets the chatbot's turn call it once.
(is (true? (:once-per-turn? (first (filter #(= "move_tic_tac_toe" (:name %)) webmcp/tools))))))
(deftest tic-tac-toe (deftest tic-tac-toe
(open-page!) (open-page!)
(async done (async done
@@ -417,10 +412,13 @@
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r)))) (is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
(call "move_tic_tac_toe" {:cell 4 :player "x"}))) (call "move_tic_tac_toe" {:cell 4 :player "x"})))
(.then (fn [r] (.then (fn [r]
;; It pressed the cell, as a user would, and says it is O's turn now. ;; It pressed the cell, as a user would; the result says the board it left (see
(is (= :x (get-in @rf-db/app-db [:ttt :board 4]))) ;; provider-for's tic-tac-toe assertions for the shape it takes in the state).
(is (false? (:error? r)))
(is (= {:board [nil nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "o"} (is (= {:board [nil nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "o"}
(json (:text r)))) (json (:text r))))
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])))
(is (= :o (get-in @rf-db/app-db [:ttt :turn])) "it is O's turn now")
(call "move_tic_tac_toe" {:cell 4 :player "o"}))) (call "move_tic_tac_toe" {:cell 4 :player "o"})))
(.then (fn [r] (.then (fn [r]
(is (= {:text "cell 4 is taken" :error? true} r)) (is (= {:text "cell 4 is taken" :error? true} r))
@@ -448,21 +446,74 @@
(is (:error? r)) (is (:error? r))
(call "move_tic_tac_toe" {:cell 0 :player "o"}))) (call "move_tic_tac_toe" {:cell 0 :player "o"})))
(.then (fn [r] (.then (fn [r]
(is (= "x" (:turn (json (:text r))))) (is (false? (:error? r)))
(is (= {:board ["o" nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "x"}
(json (:text r))))
(is (= :x (get-in @rf-db/app-db [:ttt :turn])))
;; The person moves X to 3 and O to 1; the agent's X then completes the middle row. ;; The person moves X to 3 and O to 1; the agent's X then completes the middle row.
(rf/dispatch-sync [::events/ttt-move 3]) (rf/dispatch-sync [::events/ttt-move 3])
(rf/dispatch-sync [::events/ttt-move 1]) (rf/dispatch-sync [::events/ttt-move 1])
(call "move_tic_tac_toe" {:cell 5 :player "x"}))) (call "move_tic_tac_toe" {:cell 5 :player "x"})))
(.then (fn [r] (.then (fn [r]
(is (false? (:error? r)))
(is (= {:board ["o" "o" nil "x" "x" "x" nil nil nil] (is (= {:board ["o" "o" nil "x" "x" "x" nil nil nil]
:status "won" :winner "x" :line [3 4 5]} :status "won" :winner "x" :line [3 4 5]}
(json (:text r)))) (json (:text r))))
(is (= [:o :o nil :x :x :x nil nil nil] (get-in @rf-db/app-db [:ttt :board])) "X won the middle row")
(call "move_tic_tac_toe" {:cell 8 :player "o"}))) (call "move_tic_tac_toe" {:cell 8 :player "o"})))
(.then (fn [r] (.then (fn [r]
(is (= {:text "the game is over: start a new game" :error? true} r)) (is (= {:text "the game is over: the person starts a new one, with the page's own New game button"
(call "new_tic_tac_toe_game" {}))) :error? true}
(.then (fn [r] r))
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r)))) (done))))))
;; --- State (tbd.ui.model-context's registry, filled from webmcp/state-providers) ---
(defn- provider-for
"The `:provide` fn of the state provider registered for exactly `pages`."
[pages]
(:provide (first (filter #(= pages (:pages %)) webmcp/state-providers))))
(deftest calculator-state-provider-test
(open-page!)
(async done
(-> (page-loaded)
(.then (fn [_]
(is (= {:x "" :y "" :result {:status :idle}} ((provider-for #{:calculator}))))
(call "add" {:x 2 :y 3})))
(.then (fn [_]
(is (= {:x "2" :y "3" :result {:status :ok :x "2" :y "3" :sum 5}}
((provider-for #{:calculator}))))
(done))))))
(deftest tic-tac-toe-state-provider-test
(open-page!)
;; Raw, as tbd.ui.tictactoe keeps it (:x/:o, not the "x"/"o" strings get_tic_tac_toe's JSON gave:
;; there is no JSON round trip here, only on the wire to the server).
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn :x} ((provider-for #{:tic-tac-toe})))
"the same state get_tic_tac_toe used to hand back")
(async done
(-> (call "move_tic_tac_toe" {:cell 4 :player "x"})
(.then (fn [_]
(is (= {:board [nil nil nil nil :x nil nil nil nil] :status "in_progress" :turn :o}
((provider-for #{:tic-tac-toe}))))
(done))))))
(deftest todos-state-provider-test
(testing "nothing until the todos have loaded (no login, or not fetched yet): not an empty list,
which would read as \"there are none\""
(is (nil? ((provider-for #{:todos})))))
(tu/log-in!)
(swap! tu/server assoc :todos [{:id (tu/todo-uuid 1) :owner-id 7 :title "old" :done false :created-at 1 :updated-at 1}]
:next-id 2)
(open-page!)
(async done
(-> (call "list_todos" {}) ; waits for the load, the way logged-in-todos does
(.then (fn [_]
(is (= {:todos [{:id (tu/todo-uuid 1) :title "old" :done false}]} ((provider-for #{:todos}))))
(call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [_]
(is (= ["old" "buy milk"] (map :title (:todos ((provider-for #{:todos}))))))
(done)))))) (done))))))
;; --- Prompts and resources --- ;; --- Prompts and resources ---
@@ -515,19 +566,16 @@
(deftest every-tool-the-prompts-name-exists (deftest every-tool-the-prompts-name-exists
(let [tool-names (set (map :name webmcp/tools))] (let [tool-names (set (map :name webmcp/tools))]
(doseq [text [prompt/guide (prompt/tic-tac-toe "o") (prompt/task nil)] (doseq [text [prompt/guide prompt/tic-tac-toe (prompt/task nil)]
tool-name (re-seq #"\b(?:get|move|new|list|set|create|delete)_[a-z_]+|\badd\{" text)] tool-name (re-seq #"\b(?:get|move|new|list|set|create|delete)_[a-z_]+|\badd\{" text)]
(is (contains? tool-names (str/replace tool-name "{" "")) (str tool-name))))) (is (contains? tool-names (str/replace tool-name "{" "")) (str tool-name)))))
(deftest tic-tac-toe-prompt (deftest tic-tac-toe-prompt
(webmcp/register-prompts! fake-mcp) (webmcp/register-prompts! fake-mcp)
(testing "the side is the one asked for, and O by default" (testing "no side is assigned by the prompt; the tools and state carry the game"
(is (re-find #"as X\." (:text (prompt-text "play_tic_tac_toe" {:side "x"})))) (is (= prompt/tic-tac-toe (:text (prompt-text "play_tic_tac_toe" nil))))
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" {:side "o"})))) (is (re-find #"get_tic_tac_toe and move_tic_tac_toe"
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" nil)))) (:text (prompt-text "play_tic_tac_toe" {:side "x"}))))))
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" {:side "z"})))))
(testing "it says to move on the agent's own turn only"
(is (re-find #"never move for the other side" (:text (prompt-text "play_tic_tac_toe" nil))))))
(deftest registers-the-resources (deftest registers-the-resources
(is (identical? fake-mcp (webmcp/register-resources! fake-mcp))) (is (identical? fake-mcp (webmcp/register-resources! fake-mcp)))