Compare commits
6 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| d884ca4179 | |||
| 2637b69c2c | |||
| a6f49938dc | |||
| 2d606d0620 | |||
| a7f12b5d72 | |||
| 6569a69463 |
@@ -6,15 +6,14 @@
|
||||
`: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
|
||||
tbd.agent.instructions (`src/`, never on the UI's classpath), which reuses `act`,
|
||||
`work-it-out`, `tic-tac-toe-rules` and `examples` from here rather than duplicating them, so the
|
||||
wording stays shared without the chatbot's own instructions being bundled into the browser.
|
||||
tbd.agent.instructions (`src/`, never on the UI's classpath), which reuses `act`, `work-it-out`
|
||||
and `examples` from here rather than duplicating them, so the wording stays shared without the
|
||||
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
|
||||
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:
|
||||
the models behind LM Studio follow that better than a long list of rules."
|
||||
(:require [clojure.string :as str]))
|
||||
the models behind LM Studio follow that better than a long list of rules.")
|
||||
|
||||
(def act
|
||||
"Shared with tbd.agent.instructions/chat, the in-page chatbot's own system prompt."
|
||||
@@ -34,29 +33,29 @@
|
||||
" and cannot tell what.\n"
|
||||
chain
|
||||
"- 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"
|
||||
" answer from the page or act on it (a board, a list, an id), read it again with a tool. When the\n"
|
||||
" user says it changed or that you are wrong, read it again first: never go by an earlier result\n"
|
||||
" 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"
|
||||
" apologies, no explanation of what went wrong unless it still fails.\n"
|
||||
" page held when it ran, so an earlier one may no longer hold. Before you answer from the page or\n"
|
||||
" act on it (a board, a list, an id), get what it holds now — current state if you have it, else\n"
|
||||
" read it again with a tool. When the user says it changed or that you are wrong, check again\n"
|
||||
" first: never go by an earlier result or by what you said before.\n"
|
||||
"- A call fails: the result still comes back to you, with what went wrong. Read it, fix the\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"))
|
||||
|
||||
(def tic-tac-toe-rules
|
||||
"Shared with tbd.agent.instructions/chat."
|
||||
(str "Tic-tac-toe: check whose turn it is, move only for your own side, one move, then stop and let the\n"
|
||||
"person play theirs.\n"
|
||||
"\n"))
|
||||
|
||||
(def examples
|
||||
"Shared with tbd.agent.instructions/chat."
|
||||
(defn examples
|
||||
"Shared with tbd.agent.instructions/chat. `reads?` is whether looking something up (a todo's id,
|
||||
the board) takes its own call first (an outside agent's list_todos/get_tic_tac_toe) or is
|
||||
already in view (the chatbot's state, tbd.chat.schema/RunAgentInput's `state`) — the one place
|
||||
the two agents' examples differ."
|
||||
[reads?]
|
||||
(str "Examples:\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"
|
||||
"\"untick all my todos\" -> list_todos -> ONE set_todo_done with every todo in \"todos\" -> \"Unticked them all.\"\n"
|
||||
"\"tick off the milk one\" -> " (when reads? "list_todos -> ")
|
||||
"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"
|
||||
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\"\n"
|
||||
"\"play tic tac toe, you're O\" -> get_tic_tac_toe -> it is X's turn -> \"You're up, X starts.\""))
|
||||
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\""))
|
||||
|
||||
;; --- 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"
|
||||
"\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"
|
||||
"the user only wants to look at a page. The `webmcp://app/state` resource says which page is open\n"
|
||||
"and whether anyone is logged in.\n"
|
||||
"is open, and a tool that changes something opens the page it acts on first, so you rarely need to\n"
|
||||
"navigate yourself. It only moves you there: it does not read what a page holds, so use it when\n"
|
||||
"the user wants to look at a page, not to check or refresh one.\n"
|
||||
"\n"
|
||||
act
|
||||
(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"
|
||||
"tell them so.\n"
|
||||
"\n"
|
||||
tic-tac-toe-rules
|
||||
examples))
|
||||
(examples true)))
|
||||
|
||||
(defn task
|
||||
"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)
|
||||
"Ask the user what they want done in the app, in a sentence, and do that.")))
|
||||
|
||||
(defn tic-tac-toe
|
||||
"The prompt of a game of tic-tac-toe with the person at the page, for an outside agent playing
|
||||
`side`: \"x\" or \"o\" (anything else is \"o\": X goes first, so the person, who has the board in
|
||||
front of them, starts)."
|
||||
[side]
|
||||
(let [side (if (contains? #{"x" "o"} side) side "o")]
|
||||
(str "You are playing tic-tac-toe on the app's page against the person who has it open, as "
|
||||
(str/upper-case side) ". The tools are get_tic_tac_toe, move_tic_tac_toe and new_tic_tac_toe_game.\n"
|
||||
"\n"
|
||||
"Read the game with get_tic_tac_toe. If it is your side's turn, make one move with\n"
|
||||
"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.")))
|
||||
(def tic-tac-toe
|
||||
"The prompt of a game of tic-tac-toe with the person at the page, for an outside agent. Names
|
||||
only the tools: get_tic_tac_toe, move_tic_tac_toe and their descriptions carry the rest — whose
|
||||
turn it is, which side is whose, what a move is refused for — so the agent drives from those and
|
||||
the game's state, and works out which side it plays from how the conversation started, rather
|
||||
than the prompt assigning one. Starting over is the person's: their page has its own New game
|
||||
button, no tool for it."
|
||||
(str "You are playing tic-tac-toe with the person on the app's page. The tools are get_tic_tac_toe "
|
||||
"and move_tic_tac_toe. Starting a new game is the person's to do, on the page: there is no "
|
||||
"tool for it."))
|
||||
|
||||
+10
-14
@@ -1,21 +1,17 @@
|
||||
(ns tbd.agent.a2a
|
||||
"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
|
||||
browser's own tools) an A2A caller has no page open, so this agent's tools are the app's
|
||||
server-side ones — the same operations tbd.mcp.tools exposes to MCP clients, defined again here
|
||||
directly over tbd.todo.service/tbd.math.core (not through plumcp's tool-item wrapper, which
|
||||
tbd.mcp.tools builds for a different transport) so this ns has no plumcp dependency.
|
||||
document at `/.well-known/agent-card.json`. Unlike /api/chat (driven by the browser's own tools),
|
||||
an A2A caller has no page open, so this agent's tools are the app's server-side ones — the same
|
||||
operations tbd.mcp.tools exposes to MCP, defined again here directly over
|
||||
tbd.todo.service/tbd.math.core so this ns has no plumcp dependency.
|
||||
|
||||
A2A calls are synchronous (`message/send` only: no `message/stream`, and the AgentCard says so
|
||||
truthfully in `capabilities.streaming`) — /api/chat and the AG-UI protocol are where this app's
|
||||
streaming surface is. Since there is no browser to run a tool and report back, this ns runs the
|
||||
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.
|
||||
A2A calls are synchronous (`message/send` only; the AgentCard's `capabilities.streaming` is
|
||||
false). With no browser to run a tool and report back, this ns runs the tool loop itself: ask
|
||||
the agent, run any tools it asks for, ask again, until it answers in text or `max-turns` is hit.
|
||||
|
||||
Protected the same way /mcp is (tbd.oauth.middleware/wrap-bearer-auth): any access token this
|
||||
server issued works here too, since verifying one doesn't check which `resource` it was minted
|
||||
for (see tbd.oauth.middleware) — a client that has authorized for MCP can use A2A with the same
|
||||
token."
|
||||
Protected the same way /mcp is (tbd.oauth.middleware/wrap-bearer-auth): a client authorized for
|
||||
MCP can use A2A with the same token, since verifying one doesn't check which `resource` it was
|
||||
minted for."
|
||||
(:require [clojure.string :as str]
|
||||
[malli.json-schema :as json-schema]
|
||||
[muuntaja.core :as m]
|
||||
|
||||
+107
-66
@@ -3,24 +3,21 @@
|
||||
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.
|
||||
|
||||
`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
|
||||
events: {:thinking \"text\"} (a piece of the model's reasoning), {:content \"text\"} (a piece of
|
||||
the reply), {:tool-calls [{:id :name :arguments}]} (the model wants these tools run, once its
|
||||
reply is complete: `arguments` is the JSON text the model wrote), and finally {:done true} or
|
||||
{:error \"text\"}. This event shape is internal (tbd.chat.routes and tbd.agent.a2a each translate
|
||||
it to their own wire protocol — AG-UI events, A2A artifacts) and is what tbd.chat.trace watches.
|
||||
`start` sends the request and gives {:ok pump} or {:error text :kind :unavailable|:upstream}.
|
||||
`pump` forwards the reply, as it's generated, to a function of events: {:thinking \"text\"},
|
||||
{:content \"text\"}, {:tool-calls [{:id :name :arguments}]} (arguments is the JSON text the
|
||||
model wrote), and finally {:done true} or {:error \"text\"}. This event shape is internal —
|
||||
tbd.chat.routes and tbd.agent.a2a each translate it to their own wire protocol — 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 (tbd.agent.instructions/chat-system-message for the
|
||||
in-page chatbot, tbd.agent.instructions/a2a for the A2A server), and always sends it as the first
|
||||
message. `tools` are MCP-style {:name :description :inputSchema}, converted to LangChain4j's
|
||||
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.
|
||||
`start` takes `system-text` already composed by the caller (tbd.agent.instructions) and sends it
|
||||
as the first message. `tools` are MCP-style {:name :description :inputSchema}, converted to
|
||||
LangChain4j's typed tool specifications (tbd.agent.json-schema); running them and reporting the
|
||||
result back is the caller's job.
|
||||
|
||||
Every turn is traced (see tbd.chat.trace): what was asked, how the reply went, and whether the
|
||||
model looks stuck in a loop. The config's `:trace` says where that goes."
|
||||
Every turn is traced (tbd.chat.trace: what was asked, how the reply went, whether the model
|
||||
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]
|
||||
[tbd.agent.json-schema :as json-schema]
|
||||
[tbd.chat.trace :as trace])
|
||||
@@ -44,19 +41,16 @@
|
||||
(let [v (get env k)]
|
||||
(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
|
||||
;; plain-http server to upgrade to HTTP/2 (`Upgrade: h2c`), and LM Studio's server never answers
|
||||
;; that request, so the backend would wait out the whole timeout while the LLM sat idle.
|
||||
;; HTTP/1.1 on purpose: the JDK client's default asks a plain-http server to upgrade to HTTP/2
|
||||
;; (`Upgrade: h2c`), and LM Studio never answers that, so requests would hang for the full timeout.
|
||||
(defn- jdk-http-client-builder []
|
||||
(-> (JdkHttpClientBuilder.)
|
||||
(.httpClientBuilder (-> (HttpClient/newBuilder) (.version HttpClient$Version/HTTP_1_1)))))
|
||||
|
||||
(defn- api-base-url
|
||||
"`url` (the server's address, no path, see env-config) with the `/v1` LM Studio's OpenAI-compatible
|
||||
endpoints live under: LangChain4j's OpenAI client posts straight to `<baseUrl>/chat/completions`,
|
||||
it does not add this itself (its own default base url is `https://api.openai.com/v1`). Without
|
||||
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` (see env-config) with `/v1` appended if missing: LangChain4j posts straight to
|
||||
`<baseUrl>/chat/completions` without adding it, and LM Studio without it answers 200 with a JSON
|
||||
error body that reads as an empty reply."
|
||||
[url]
|
||||
(if (str/ends-with? url "/v1") url (str url "/v1")))
|
||||
|
||||
@@ -152,11 +146,22 @@
|
||||
(println (cond-> (str "[tbd] chat: " text) detail (str " (" detail ")")))
|
||||
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
|
||||
"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
|
||||
does the delta accumulation itself), {:complete response} or {:error throwable}. `handle!` is
|
||||
called with the first StreamingHandle seen, so the caller can cancel a stuck stream."
|
||||
{:thinking s}, {:tool-call {:id :name :arguments}} (once a call is fully assembled), {:complete
|
||||
response} or {:error throwable}. `handle!` is called with the first StreamingHandle seen, so the
|
||||
caller can cancel a stuck stream."
|
||||
^StreamingChatResponseHandler [^LinkedBlockingQueue queue handle!]
|
||||
(let [capture! (fn [^StreamingHandle h] (when h (handle! h)))]
|
||||
;; 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]
|
||||
(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
|
||||
"Drains `queue`, starting from the already-polled `first-item` (see `start`, which peeks one item
|
||||
before deciding {:ok}/{:error}), calling `emit` with each event (see the ns docstring).
|
||||
`timeout-seconds` of silence between items is an error, closing the stream via `handle-atom` (a
|
||||
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
|
||||
LLM says, and how the turn ended, before the client is told."
|
||||
[^LinkedBlockingQueue queue handle-atom timeout-seconds emit tracer first-item]
|
||||
"Drains `queue`, starting from the already-polled `first-item` (see send-request!), calling
|
||||
`emit` with each event (see the ns docstring). `timeout-seconds` of silence between items is an
|
||||
error, closing the stream via `handle-atom`.
|
||||
|
||||
A looping model is never silent, so that timeout can't catch it; `tracer` (tbd.chat.trace/observe!)
|
||||
watches for that instead. The first time a turn loops, the stream is cancelled and resent with
|
||||
`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)
|
||||
timed-out? (atom false)
|
||||
cancel-stream! (fn []
|
||||
@@ -212,7 +240,20 @@
|
||||
(some-> ^ScheduledFuture @timer (.cancel false))
|
||||
(reset! timer (.schedule ^ScheduledThreadPoolExecutor @watchdog
|
||||
^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!)
|
||||
(try
|
||||
(loop [item first-item
|
||||
@@ -254,46 +295,46 @@
|
||||
(emit {:error text}))))
|
||||
|
||||
:else
|
||||
(do (arm!)
|
||||
(trace/observe! tracer (select-keys item [:content :thinking]))
|
||||
(let [abort (trace/observe! tracer (select-keys item [:content :thinking]))]
|
||||
(when-let [out (not-empty (select-keys item [:content :thinking]))] (emit out))
|
||||
(cond
|
||||
(and abort (not retried?))
|
||||
(do (trace/finish! tracer {:outcome :looped}) (retry!))
|
||||
|
||||
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)))))))
|
||||
(cond-> calls (:tool-call item) (conj (:tool-call item)))))))))
|
||||
(finally
|
||||
(trace/finish! tracer {:outcome :aborted})
|
||||
(some-> ^ScheduledFuture @timer (.cancel false))
|
||||
(cancel-stream!)))))
|
||||
|
||||
(defn start
|
||||
"Sends the LLM the conversation `messages` (see tbd.chat.schema/Message), and the `tools` it may
|
||||
ask the caller to run (MCP's {:name :description :inputSchema}; none if nil), after `system-text`
|
||||
(the agent's own system prompt, see tbd.agent.instructions — composed by the caller, not the
|
||||
browser). Waits for the first sign of life from the model (a piece of its reply, or an error) so
|
||||
that an LLM that is down or refuses is still a clean {:error text :kind :unavailable|:upstream},
|
||||
not an error inside a stream that has already begun — the same contract the old hand-rolled HTTP
|
||||
client gave, adapted to LangChain4j's async callbacks (which have no separate \"got the HTTP
|
||||
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."
|
||||
"Sends the LLM `messages` (tbd.chat.schema/Message) and the `tools` it may ask to be run (MCP's
|
||||
{:name :description :inputSchema}; none if nil), after `system-text` (composed by the caller,
|
||||
see tbd.agent.instructions). Waits for the first sign of life so an LLM that is down or refuses
|
||||
comes back as a clean {:error text :kind :unavailable|:upstream} rather than an error mid-stream.
|
||||
Otherwise {:ok pump}: `(pump emit)` blocks until the reply is complete (retrying once on its own
|
||||
if the model loops, see `pump`), calling `emit` with its events. If `emit` throws, the request to
|
||||
the LLM is closed and the exception is rethrown."
|
||||
[{:keys [timeout-seconds trace] :as config} system-text messages tools]
|
||||
(if-not (configured? config)
|
||||
{:error "chat is not configured" :kind :unavailable}
|
||||
(let [tracer (trace/begin! trace {:messages messages :tools tools :model (:model config)})
|
||||
upstream-error (fn [text detail]
|
||||
(fail text detail)
|
||||
(trace/finish! tracer {:outcome :upstream-error :error text :detail detail})
|
||||
{:error text :kind :upstream})]
|
||||
(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)
|
||||
(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)))))))
|
||||
(let [tracer (trace/begin! trace {:messages messages :tools tools :model (:model config)
|
||||
:system-text system-text})
|
||||
{:keys [ok error detail]} (send-request! config system-text messages tools timeout-seconds)]
|
||||
(if error
|
||||
(do (fail error detail)
|
||||
(trace/finish! tracer {:outcome :upstream-error :error error :detail detail})
|
||||
{:error error :kind :upstream})
|
||||
{:ok (fn [emit]
|
||||
(pump config system-text messages tools timeout-seconds emit tracer
|
||||
(:queue ok) (:handle-atom ok) (:first-item ok) false))}))))
|
||||
|
||||
@@ -4,9 +4,10 @@
|
||||
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
|
||||
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
|
||||
rather than duplicating it."
|
||||
genuinely shared (`act`, `work-it-out`, `examples`) from tbd.agent.prompt rather than
|
||||
duplicating it."
|
||||
(:require [clojure.string :as str]
|
||||
[jsonista.core :as json]
|
||||
[tbd.agent.prompt :as prompt]))
|
||||
|
||||
(defn chat
|
||||
@@ -19,8 +20,8 @@
|
||||
"\n"
|
||||
prompt/act
|
||||
(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"
|
||||
" page: read it with a tool.\n"))
|
||||
" use it. Never invent an id, a title or the state of the page: it's in \"Current state of the\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"
|
||||
"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"
|
||||
@@ -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"
|
||||
"the tools you have. Think briefly before you act.\n"
|
||||
"\n"
|
||||
prompt/tic-tac-toe-rules
|
||||
prompt/examples))
|
||||
(prompt/examples false)))
|
||||
|
||||
(defn chat-system-message
|
||||
"`chat`'s prompt, with, last, where the user is (`page`) and 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
|
||||
when the instructions say them as well, and it can say what it can do without a call. One
|
||||
message, and the first: several chat templates (Gemma's, Mistral's) refuse more than one system
|
||||
message, or one that isn't first."
|
||||
[page tools]
|
||||
"`chat`'s prompt, with, last, where the user is (`page`), the names of the `tools` on offer
|
||||
there, and `state` (see tbd.chat.schema/RunAgentInput) — what the page is showing right now, so
|
||||
the model is never told to call a tool to read what it already has. The tools' names are in the
|
||||
request's `tools` too, but a model picks them more readily when the instructions say them as
|
||||
well, and it can say what it can do without a call. One message, and the first: several chat
|
||||
templates (Gemma's, Mistral's) refuse more than one system message, or one that isn't first."
|
||||
[page tools state]
|
||||
(cond-> (chat)
|
||||
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")
|
||||
" 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
|
||||
"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"
|
||||
"paste JSON, don't describe the tool call itself, just its outcome.\n"
|
||||
"\n"
|
||||
prompt/examples))
|
||||
(prompt/examples true)))
|
||||
|
||||
@@ -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]))
|
||||
+40
-17
@@ -1,18 +1,15 @@
|
||||
(ns tbd.chat.routes
|
||||
"/api/chat: an AG-UI (Agent-User Interaction Protocol, https://docs.ag-ui.com) run. A caller
|
||||
POSTs a RunAgentInput (tbd.chat.schema/RunAgentInput) and gets the agent's reply streamed back
|
||||
as AG-UI's server-sent events: RUN_STARTED, then TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_*
|
||||
as the model generates, then RUN_FINISHED or RUN_ERROR. The agent itself (its system prompt,
|
||||
the LLM call, tool-call assembly) is tbd.agent.core; this ns only translates its internal event
|
||||
shape ({:thinking}/{:content}/{:tool-calls}/{:done}/{:error}, see tbd.agent.core's ns docstring)
|
||||
to and from AG-UI's wire format.
|
||||
|
||||
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."
|
||||
"/api/chat: an AG-UI (https://docs.ag-ui.com) run. A caller POSTs a RunAgentInput
|
||||
(tbd.chat.schema/RunAgentInput) and gets the agent's reply streamed back as AG-UI server-sent
|
||||
events: RUN_STARTED, then TEXT_MESSAGE_*/REASONING_MESSAGE_*/TOOL_CALL_* as the model generates,
|
||||
then RUN_FINISHED or RUN_ERROR. The agent itself is tbd.agent.core; this ns only translates its
|
||||
internal event shape ({:thinking}/{:content}/{:tool-calls}/{:done}/{:error}) to AG-UI's wire
|
||||
format. AG-UI's frontend-tool model (the agent asks for a call, the browser runs it and sends
|
||||
the result back as a `tool` message on the next run) is exactly the loop tbd.ui.events drives."
|
||||
(:require [muuntaja.core :as m]
|
||||
[ring.core.protocols :as ring-protocols]
|
||||
[tbd.agent.core :as agent]
|
||||
[tbd.chat.db :as chat-db]
|
||||
[tbd.chat.schema :as schema]
|
||||
[tbd.http :refer [respond]])
|
||||
(:import (java.io IOException OutputStream)
|
||||
@@ -126,13 +123,39 @@
|
||||
"X-Accel-Buffering" "no"}
|
||||
: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
|
||||
"`config` is the agent config (see tbd.agent.core/env-config). Only logged-in users may chat:
|
||||
every message costs the LLM server's time."
|
||||
[config]
|
||||
"`config` is the agent config (see tbd.agent.core/env-config). `ds` is a delay of the app's
|
||||
database (see tbd.sqlite/open), for /api/chat/history. Only logged-in users may chat: every
|
||||
message costs the LLM server's time."
|
||||
[config ds]
|
||||
["/api/chat"
|
||||
{:post {:tags ["chat"]
|
||||
:login? true
|
||||
{:tags ["chat"]}
|
||||
[""
|
||||
{:post {: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"
|
||||
:parameters {:body schema/RunAgentInput}
|
||||
:handler (chat-handler config)}}])
|
||||
: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
@@ -24,6 +24,14 @@
|
||||
(defn- small? [tool]
|
||||
(<= (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
|
||||
"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."
|
||||
@@ -83,7 +91,10 @@
|
||||
|
||||
(def RunAgentInput
|
||||
"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
|
||||
browser resends the whole conversation each time, see tbd.ui.events), so it only echoes them
|
||||
back, never reads them."
|
||||
@@ -92,7 +103,65 @@
|
||||
[:runId {:optional true} [:string {:max 200}]]
|
||||
[:messages [:vector {:min 1 :max max-messages} Message]]
|
||||
[: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
|
||||
"The `page` context entry's value, or nil."
|
||||
@@ -119,6 +188,6 @@
|
||||
|
||||
(defn system-text
|
||||
"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."
|
||||
[{:keys [tools context]}]
|
||||
(instructions/chat-system-message (page-of context) tools))
|
||||
supply: only `page` (from `context`), `tools` and `state` shape it."
|
||||
[{:keys [tools context state]}]
|
||||
(instructions/chat-system-message (page-of context) tools state))
|
||||
|
||||
+48
-37
@@ -1,31 +1,22 @@
|
||||
(ns tbd.chat.trace
|
||||
"Observability for the chatbot's LLM turns: what the model was asked, what it did with it, how long
|
||||
it took, and whether it looks stuck. No Ring and no LLM here; tbd.agent.core (the chatbot's agent)
|
||||
and tbd.agent.a2a (the A2A server) both call it.
|
||||
"Observability for the chatbot's LLM turns: what the model was asked, how it went, and whether it
|
||||
looks stuck. Called by tbd.agent.core and tbd.agent.a2a; no Ring or LLM code here.
|
||||
|
||||
One request to /api/chat, or one message to the A2A server, is one turn of the model. The loop that
|
||||
runs the chatbot's tools lives in the browser
|
||||
(tbd.ui.events): a tool's result comes back as a new request holding the conversation so far, so the
|
||||
server keeps nothing between turns. A stuck agent shows up in two ways, and both are watched:
|
||||
One request to /api/chat, or one message to the A2A server, is one turn. A stuck agent is watched
|
||||
for two ways: within a turn, reasoning that never ends (`:long-reasoning`) or repeats a sentence
|
||||
(`:repeated-thinking`); across turns, the same tool call made over and over (`:repeated-call`).
|
||||
|
||||
- within a turn, as reasoning that never ends (`:long-reasoning`) or that says the same sentence
|
||||
again and again (`:repeated-thinking`);
|
||||
- across turns, as the same tool call made over and over (`:repeated-call`), read off the
|
||||
conversation each request carries.
|
||||
A turn is one `tracer`: `begin!` logs `:turn-start`, `observe!` runs per reply event (logging
|
||||
`:loop-suspect` and telling the caller to stop the turn once a loop is confirmed), `finish!` logs
|
||||
`:turn-end` with the outcome, timings and flags. A tracer is for one thread.
|
||||
|
||||
Every turn is one `tracer`: `begin!` when the request goes out (logs `:turn-start`), `observe!` for
|
||||
each event of the reply (logs a `:loop-suspect` when one of the above trips), `finish!` when it ends
|
||||
(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` (per turn) and `run` (a hash of the user's last message, shared by
|
||||
every turn of the tool loop it started), with `step` counting turns of the run from 0.
|
||||
|
||||
Turns are correlated by `req` (one per turn) and `run` (a hash of the user's last message, the same
|
||||
for every turn of the tool loop it started), with `step` counting the turns of the run from 0.
|
||||
|
||||
Entries are maps that go to a `sink`. `sink` prints each as one `[tbd] chat <event> k=v ...` line and,
|
||||
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)."
|
||||
Entries go to a `sink`, which prints one `[tbd] chat <event> k=v ...` line and, if given a file,
|
||||
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
|
||||
(tbd.agent.core/env-config)."
|
||||
(:require [clojure.java.io :as io]
|
||||
[clojure.string :as str]
|
||||
[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`."
|
||||
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-pending-chars 1000)
|
||||
(def ^:private max-args-length 500)
|
||||
@@ -162,7 +164,7 @@
|
||||
|
||||
(def ^:private heavy-fields
|
||||
"What only the trace file gets."
|
||||
#{:reasoning :reply :input})
|
||||
#{:reasoning :reply :input :system-text})
|
||||
|
||||
(defn- render-field [k v]
|
||||
(str (name k) "="
|
||||
@@ -219,10 +221,11 @@
|
||||
(catch Throwable _ nil)))
|
||||
|
||||
(defn begin!
|
||||
"Starts tracing a turn, and logs `:turn-start`; `messages`, `tools` and `page` are the request's, and
|
||||
`model` the LLM's, if the config names one. `trace` is a config of `config-for`, or nil for
|
||||
`default-config`. Returns the tracer."
|
||||
[trace {:keys [messages tools page model]}]
|
||||
"Starts tracing a turn, logging `:turn-start`. `messages`/`tools`/`page`/`model` are the
|
||||
request's. `system-text` is the turn's system prompt; with `full-text?` on, it's also written to
|
||||
the trace file. `trace` is a config from `config-for`, or nil for `default-config`. Returns the
|
||||
tracer."
|
||||
[trace {:keys [messages tools page model system-text]}]
|
||||
(let [{:keys [sink full-text?]} (or trace default-config)
|
||||
{:keys [run step run-calls top-call input]} (run-summary messages)
|
||||
tracer {:sink sink :full-text? full-text?
|
||||
@@ -234,27 +237,35 @@
|
||||
(cond-> {:page page :model model :messages (count messages) :tools (count tools)
|
||||
:prompt-chars (transduce (map #(count (:content %))) + 0 messages)
|
||||
: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))
|
||||
(log! tracer :loop-suspect {:kind :repeated-call :tool (:tool top-call) :count (:count top-call)
|
||||
:args (truncate (:args top-call) sample-length)}))
|
||||
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!
|
||||
"Takes one event of the LLM's reply (see tbd.agent.core, whose pump calls this: :content, :thinking,
|
||||
or, at the end of a turn, :finish-reason and :usage), logging a `:loop-suspect` if the reasoning has
|
||||
gone on for long, or is repeating itself."
|
||||
"Takes one event of the LLM's reply (tbd.agent.core/pump: :content, :thinking, or at the end
|
||||
:finish-reason/:usage), logging `:loop-suspect` if the reasoning is running long or repeating.
|
||||
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]
|
||||
(let [[state' alerts] (advance @state event (now-ms) full-text?)]
|
||||
(reset! state (update state' :flags into (map :kind) alerts))
|
||||
(doseq [alert alerts]
|
||||
(log! tracer :loop-suspect alert))))
|
||||
(log! tracer :loop-suspect alert))
|
||||
(some abortable alerts)))
|
||||
|
||||
(defn finish!
|
||||
"Ends the turn, logging `:turn-end`; only the first call does anything, so it is safe to call
|
||||
again in a `finally`. `outcome` is a map: {:outcome :done | :tool-calls | :error | :upstream-error
|
||||
| :aborted, :calls [{:name :arguments}] for :tool-calls, :error text and :detail text for the
|
||||
failures}. :aborted is a turn that just stopped (the client went away, or something threw)."
|
||||
"Ends the turn, logging `:turn-end`. Only the first call does anything, so it's safe to call
|
||||
again in a `finally`. `outcome` is {:outcome :done|:tool-calls|:error|:upstream-error|:looped|:aborted
|
||||
:calls [...] :error :detail}. :aborted is a turn that just stopped; :looped is one pump cut short
|
||||
and retried (the retry is a turn of its own)."
|
||||
[{:keys [state full-text?] :as tracer} {:keys [outcome calls error detail]}]
|
||||
(let [s @state]
|
||||
(when-not (:finished? s)
|
||||
|
||||
+7
-8
@@ -19,6 +19,7 @@
|
||||
[tbd.auth.core :as auth]
|
||||
[tbd.auth.middleware :as auth-mw]
|
||||
[tbd.auth.routes :as auth-routes]
|
||||
[tbd.chat.db :as chat-db]
|
||||
[tbd.chat.routes :as chat-routes]
|
||||
[tbd.health.routes :as health]
|
||||
[tbd.http :as http]
|
||||
@@ -74,7 +75,7 @@
|
||||
;; namespace that returns its own route subtree; they're concatenated here.
|
||||
(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.
|
||||
(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
|
||||
[["/swagger.json"
|
||||
;; The spec is JSON, whatever the API default is (Swagger UI can't read EDN).
|
||||
@@ -90,17 +91,15 @@
|
||||
(a2a/routes auth ds chat)
|
||||
(oauth-routes/routes auth ds)
|
||||
(auth-routes/routes auth)
|
||||
(chat-routes/routes chat)
|
||||
(chat-routes/routes chat ds)
|
||||
(nrepl-routes/routes nrepl)
|
||||
(todo-routes/routes ds)]
|
||||
{:data {:muuntaja http/muuntaja
|
||||
:coercion malli/coercion
|
||||
;; Handlers (and the auth/error middleware) return plain data; the muuntaja
|
||||
;; middleware encodes it as the Accept header asks, so it wraps everything else.
|
||||
;; Auth comes next, so unauthenticated callers to `:admin? true` / `:login? true`
|
||||
;; routes are turned away before any body parsing or coercion runs. The request
|
||||
;; 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.
|
||||
;; Order matters: response-formatting outermost (handlers return plain data), then
|
||||
;; auth (so unauthenticated callers are turned away before body parsing/coercion),
|
||||
;; then request-formatting split below the exception middleware so a malformed body
|
||||
;; is caught and answered with a 400 rather than thrown.
|
||||
:middleware [muuntaja-middleware/format-negotiate-middleware
|
||||
muuntaja-middleware/format-response-middleware
|
||||
(auth-mw/admin-middleware auth)
|
||||
|
||||
@@ -1,7 +1,13 @@
|
||||
(ns tbd.agent.core-test
|
||||
(:require [clojure.test :refer [deftest is testing]]
|
||||
[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]
|
||||
(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 (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
|
||||
(testing "assistant messages with tool calls, and their tool-role results, reach the model
|
||||
without error (see tbd.agent.core/llm-message)"
|
||||
|
||||
@@ -15,24 +15,35 @@
|
||||
(is (str/includes? text "in this same turn"))
|
||||
(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 "Tic-tac-toe: check whose turn it is"))
|
||||
(is (str/includes? text "Examples: "))))
|
||||
|
||||
(deftest chat-is-framed-as-the-in-page-chatbot
|
||||
(let [text (instructions/chat)]
|
||||
(is (str/includes? text "under your message"))
|
||||
(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
|
||||
(is (= (instructions/chat) (instructions/chat-system-message nil nil)))
|
||||
(let [text (instructions/chat-system-message "todos" [{:name "create_todo"} {:name "list_todos"}])]
|
||||
(is (= (instructions/chat) (instructions/chat-system-message nil nil nil)))
|
||||
(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 "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
|
||||
(let [text (instructions/a2a)]
|
||||
(is (str/includes? text "Act, don't offer"))
|
||||
(is (str/includes? text "Agent2Agent protocol"))
|
||||
(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")))
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
(ns tbd.agent.prompt-test
|
||||
(:require [clojure.string :as str]
|
||||
[clojure.test :refer [deftest is]]
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[tbd.agent.prompt :as prompt]))
|
||||
|
||||
(defn- flat
|
||||
@@ -14,10 +14,9 @@
|
||||
(is (str/includes? text "in this same turn"))
|
||||
(is (str/includes? text "Work it out yourself:"))
|
||||
(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 "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 (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 (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
|
||||
(is (str/includes? (prompt/tic-tac-toe "x") "as X."))
|
||||
(is (str/includes? (prompt/tic-tac-toe "o") "as O."))
|
||||
(doseq [other [nil "" "z" :x]]
|
||||
(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")))
|
||||
(is (str/includes? prompt/tic-tac-toe "get_tic_tac_toe and move_tic_tac_toe"))
|
||||
(is (not (str/includes? prompt/tic-tac-toe "as X")) "no side is assigned by the prompt")
|
||||
(is (not (str/includes? prompt/tic-tac-toe "as O")) "no side is assigned by the prompt"))
|
||||
|
||||
@@ -26,7 +26,11 @@
|
||||
(reify StreamingChatModel
|
||||
(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
|
||||
(-> (ChatResponse/builder)
|
||||
(.aiMessage ai-message)
|
||||
@@ -44,6 +48,16 @@
|
||||
(doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h)))
|
||||
(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
|
||||
"A model that streams `thinking`, then `pieces` as content."
|
||||
[thinking & pieces]
|
||||
|
||||
@@ -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")))
|
||||
@@ -5,8 +5,11 @@
|
||||
[ring.core.protocols :as ring-protocols]
|
||||
[tbd.agent.test-support :as ts]
|
||||
[tbd.auth.routes-test :as t]
|
||||
[tbd.sqlite-test :as sqlite-test]
|
||||
[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)))
|
||||
|
||||
@@ -37,8 +40,19 @@
|
||||
|
||||
(def ^:private hello (json {:messages [{:id "m1" :role "user" :content "hi"}]}))
|
||||
|
||||
(defn- app-with [chat]
|
||||
(t/make-app (t/gitea-stub "alice") :chat chat))
|
||||
(defn- app-with
|
||||
([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
|
||||
(let [app (app-with (ts/config (ts/text-model "x")))]
|
||||
@@ -127,6 +141,26 @@
|
||||
(json {:messages [{:id "m1" :role "user" :content "hi"}]
|
||||
: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
|
||||
(let [app (app-with (ts/config (ts/text-model "x")))
|
||||
cookie (t/login! app)
|
||||
@@ -163,6 +197,65 @@
|
||||
(is (= 200 (:status 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
|
||||
(testing "a browser that leaves mid-reply ends the stream quietly"
|
||||
(let [app (app-with (ts/config (ts/text-model "a" "b" "c")))
|
||||
|
||||
@@ -58,12 +58,14 @@
|
||||
(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])))
|
||||
(is (re-matches #"[0-9a-f]{8}" (:req start)))
|
||||
(is (not (contains? start :input))))))
|
||||
(testing "with the full text on, it has the run's messages"
|
||||
(is (not (contains? start :input)))
|
||||
(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 [])
|
||||
messages [{:role "user" :content "old"} {:role "assistant" :content "reply"} {:role "user" :content "new"}]]
|
||||
(trace/begin! (collecting entries :full-text? true) {:messages messages})
|
||||
(is (= [{:role "user" :content "new"}] (:input (first @entries))))))
|
||||
(trace/begin! (collecting entries :full-text? true) {:messages messages :system-text "You are..."})
|
||||
(is (= [{:role "user" :content "new"}] (:input (first @entries))))
|
||||
(is (= "You are..." (:system-text (first @entries))))))
|
||||
(testing "every turn has its own req id"
|
||||
(let [entries (atom [])]
|
||||
(dotimes [_ 3] (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]}))
|
||||
|
||||
@@ -12,9 +12,12 @@
|
||||
(rdc/render @root [views/app]))
|
||||
|
||||
(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-state! webmcp/state-providers)
|
||||
(webmcp/register!))
|
||||
|
||||
(defn reload
|
||||
|
||||
+22
-34
@@ -2,57 +2,45 @@
|
||||
(:require [tbd.ui.tictactoe :as tictactoe]))
|
||||
|
||||
(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
|
||||
:calc {:x "" :y ""
|
||||
;; {:status :idle}
|
||||
;; {:status :loading}
|
||||
;; {:status :ok :x "2" :y "3" :sum 5}
|
||||
;; {:status :error :message "..."}
|
||||
;; :result is {:status :idle|:loading}, {:status :ok :x :y :sum}, or
|
||||
;; {:status :error :message}.
|
||||
:result {:status :idle}}
|
||||
;; {:status :unknown} (asking /auth/me)
|
||||
;; {:status :anonymous} (not logged in)
|
||||
;; {:status :logged-in :login "alice"}
|
||||
;; {:status :error :message "..."}
|
||||
;; :user is {:status :unknown}, {:status :anonymous}, {:status :logged-in :login "alice"}, or
|
||||
;; {:status :error :message}.
|
||||
:user {:status :unknown}
|
||||
;; :status is the list load: :idle, :loading, :ok or :error. :error is the message of the
|
||||
;; last failed request (a load or a change); it is cleared when the next request starts.
|
||||
:todos {:status :idle
|
||||
:todos {;; :status is :idle, :loading, :ok or :error; :error is the last failed request's
|
||||
;; message, cleared when the next request starts.
|
||||
:status :idle
|
||||
:items []
|
||||
:new-title ""
|
||||
:error nil}
|
||||
;; The "Add this MCP server to Claude Code" page: :copied? is true right after the
|
||||
;; command was copied to the clipboard.
|
||||
;; The "Add this MCP server to Claude Code" page. :copied? is true right after the command was
|
||||
;; copied to the clipboard.
|
||||
:mcp {:copied? false}
|
||||
;; The chat widget (the green square in the corner): :open? is whether its panel is showing,
|
||||
;; :messages the conversation so far, :input what is typed, :status :idle or :loading (waiting
|
||||
;; for the reply, or for the tools it asked for), and :error the message of the last failed send.
|
||||
;; A message is one of
|
||||
;; {:role "user" :content "..."}
|
||||
;; {:role "assistant" :content "..."}, with :tool-calls [{:id :name :arguments "{...}"}] when
|
||||
;; 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.
|
||||
;; The chat widget (the green square). A message is {:role "user"|"assistant"|"tool" :content}
|
||||
;; with :tool-calls [{:id :name :arguments}] and :thinking on an assistant message that used
|
||||
;; tools or reasoned, and :tool-call-id/:name on a tool message. :size is the panel's dragged
|
||||
;; :width/:height. :tools-expanded?/:reasoning-expanded? control whether tool use/reasoning show
|
||||
;; in full or collapsed. :pending-calls/:tool-calls-used/:tools-used-this-turn/:thinking-at
|
||||
;; track a reply that is still coming or being answered (see tbd.ui.events).
|
||||
:chat {:open? false
|
||||
:size {:width 320 :height 256}
|
||||
:tools-expanded? false
|
||||
:reasoning-expanded? false
|
||||
:input ""
|
||||
:messages []
|
||||
:status :idle
|
||||
:error nil
|
||||
:pending-calls nil
|
||||
;; Tool calls the server is still streaming (AG-UI's TOOL_CALL_START/ARGS/END), keyed by
|
||||
;; toolCallId, until each is complete and moves into :pending-calls.
|
||||
;; Tool calls still streaming in (AG-UI's TOOL_CALL_START/ARGS/END), keyed by
|
||||
;; toolCallId, until complete and moved into :pending-calls.
|
||||
:tool-call-buffer {}
|
||||
:thinking-at nil
|
||||
:tool-calls-used 0}
|
||||
;; Tic-tac-toe, entirely client side: the board (see tbd.ui.tictactoe) and whose turn it is.
|
||||
:tool-calls-used 0
|
||||
:tools-used-this-turn #{}}
|
||||
;; Tic-tac-toe, client side only.
|
||||
:ttt {:board tictactoe/new-board
|
||||
:turn :x}})
|
||||
|
||||
+366
-174
@@ -8,25 +8,31 @@
|
||||
[tbd.ui.sse :as sse]
|
||||
[tbd.ui.tictactoe :as tictactoe]))
|
||||
|
||||
;; A `js/fetch` of `uri` (GET unless `method` is given). A `body` is sent as EDN.
|
||||
(defn- fetch-request [{:keys [uri method body]}]
|
||||
(js/fetch uri (clj->js (cond-> {:method (or method "GET")}
|
||||
(defn- fetch-request
|
||||
"GETs (or `method`s) `uri`. `body`, if given, is sent as EDN. `signal` (an AbortSignal) aborts it."
|
||||
[{:keys [uri method body signal]}]
|
||||
(js/fetch uri (cond-> (clj->js (cond-> {:method (or method "GET")}
|
||||
body (assoc :headers {"Content-Type" "application/edn"}
|
||||
:body (pr-str body))))))
|
||||
:body (pr-str body))))
|
||||
signal (doto (aset "signal" signal)))))
|
||||
|
||||
(defn- response-map [resp text]
|
||||
{:ok? (.-ok resp) :status (.-status resp) :body text})
|
||||
|
||||
;; Effect: request `uri` (GET unless `method` is given), then dispatch
|
||||
;; `(conj on-response {:ok? bool :status int-or-nil :body string})`. A `body` is sent as EDN.
|
||||
;; Network failures come back as `{:ok? false :status nil :body <message>}`.
|
||||
(rf/reg-fx
|
||||
::fetch
|
||||
(fn [{:keys [on-response] :as request}]
|
||||
(defn- do-fetch!
|
||||
"Fetches `request` (see fetch-request), dispatching `(conj on-response {:ok? :status :body})`.
|
||||
A network failure dispatches `{:ok? false :status nil :body message}`."
|
||||
[{:keys [on-response] :as request}]
|
||||
(-> (fetch-request request)
|
||||
(.then (fn [resp]
|
||||
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %))))))
|
||||
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)}))))))
|
||||
(.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"})
|
||||
|
||||
@@ -35,21 +41,23 @@
|
||||
#{"RUN_FINISHED" "RUN_ERROR"})
|
||||
|
||||
(defn- read-events!
|
||||
"Dispatches `(conj on-event event)` for each AG-UI event (see tbd.ui.sse, tbd.chat.routes) in the
|
||||
body read by `reader`, as they arrive. A body that ends without a RUN_FINISHED or RUN_ERROR event
|
||||
(the connection dropped) is a RUN_ERROR event of its own, so whoever waits for the end always
|
||||
gets one."
|
||||
[reader on-event]
|
||||
"Dispatches `(conj on-event event)` for each AG-UI event decoded from `reader`, as it arrives. A
|
||||
stream that ends without a RUN_FINISHED/RUN_ERROR event dispatches a RUN_ERROR of its own — unless
|
||||
`signal` was aborted, in which case nothing more is dispatched."
|
||||
[reader on-event ^js signal]
|
||||
(let [decoder (js/TextDecoder. "utf-8")
|
||||
ended? (atom false)
|
||||
lost! #(when-not @ended?
|
||||
aborted? #(.-aborted signal)
|
||||
lost! #(when-not (or @ended? (aborted?))
|
||||
(reset! ended? true)
|
||||
(rf/dispatch (conj on-event connection-lost)))
|
||||
step (fn step [pending]
|
||||
(-> (.read reader)
|
||||
(.then (fn [^js chunk]
|
||||
(if (.-done chunk)
|
||||
(lost!)
|
||||
(cond
|
||||
(aborted?) (some-> (.-cancel reader) (.call reader) (.catch (fn [_] nil)))
|
||||
(.-done chunk) (lost!)
|
||||
:else
|
||||
(let [[events pending] (sse/parse (str pending (.decode decoder (.-value chunk)
|
||||
#js {:stream true})))]
|
||||
(doseq [event events]
|
||||
@@ -59,34 +67,84 @@
|
||||
(.catch (fn [_] (lost!)))))]
|
||||
(step "")))
|
||||
|
||||
;; Effect: like ::fetch, for a response that is a stream of server-sent events. While it comes in,
|
||||
;; `(conj on-event event)` is dispatched for each event, as a map (see read-events!). When the
|
||||
;; 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.
|
||||
;; The in-flight stream's AbortController, for ::abort-stream. Only one stream runs at a time.
|
||||
(defonce ^:private stream-controller (atom nil))
|
||||
|
||||
;; 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
|
||||
::fetch-stream
|
||||
(fn [{:keys [on-event on-response] :as request}]
|
||||
(-> (fetch-request request)
|
||||
(let [controller (js/AbortController.)
|
||||
signal (.-signal controller)
|
||||
respond! #(when-not (.-aborted signal) (rf/dispatch (conj on-response %)))]
|
||||
(reset! stream-controller controller)
|
||||
(-> (fetch-request (assoc request :signal signal))
|
||||
(.then (fn [resp]
|
||||
(if (.-ok resp)
|
||||
(read-events! (.getReader (.-body resp)) on-event)
|
||||
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %)))))))
|
||||
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)}))))))
|
||||
(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
|
||||
::hash
|
||||
(fn [cofx _]
|
||||
(assoc cofx :hash js/location.hash)))
|
||||
|
||||
;; Coeffect: the time now, in ms since the epoch.
|
||||
(rf/reg-cofx
|
||||
::now
|
||||
(fn [cofx _]
|
||||
(assoc cofx :now (js/Date.now))))
|
||||
|
||||
;; Effect: show the page the URL names whenever it changes (a link was followed, or Back and
|
||||
;; Forward were pressed). Only one listener is ever installed, however often this runs.
|
||||
(def ^:private chat-ui-storage-key "tbd.chat-ui")
|
||||
|
||||
;; 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))
|
||||
|
||||
(rf/reg-fx
|
||||
@@ -97,7 +155,6 @@
|
||||
(reset! hash-listener #(rf/dispatch [::hash-changed js/location.hash]))
|
||||
(.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
|
||||
::set-hash
|
||||
(fn [hash]
|
||||
@@ -105,22 +162,22 @@
|
||||
|
||||
(rf/reg-event-fx
|
||||
::initialize
|
||||
[(rf/inject-cofx ::hash)]
|
||||
(fn [{:keys [hash]} _]
|
||||
{:db (assoc db/default-db :page (pages/hash->page hash))
|
||||
[(rf/inject-cofx ::hash) (rf/inject-cofx ::chat-ui-storage) (rf/inject-cofx ::ttt-storage)]
|
||||
(fn [{:keys [hash ::chat-ui ::ttt]} _]
|
||||
{: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
|
||||
:dispatch [::load-user]}))
|
||||
|
||||
;; --- Pages ---
|
||||
|
||||
;; The URL changed (a link was followed, or Back was pressed): show the page it names.
|
||||
(rf/reg-event-db
|
||||
::hash-changed
|
||||
(fn [db [_ 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
|
||||
;; follows, and its change event finds the page already shown.
|
||||
;; Navigates without a link: the page changes right away, and the URL follows.
|
||||
(rf/reg-event-fx
|
||||
::navigate
|
||||
(fn [{:keys [db]} [_ page]]
|
||||
@@ -172,7 +229,7 @@
|
||||
(cond
|
||||
ok? {:db (assoc db :user {:status :logged-in
|
||||
: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})}
|
||||
: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]}}))
|
||||
|
||||
(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]
|
||||
(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
|
||||
::logout-response
|
||||
@@ -213,8 +271,8 @@
|
||||
(update db :todos assoc :status :ok :items (:todos (reader/read-string body)))
|
||||
(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
|
||||
;; expired, so fall back to the logged-out view (which hides the todos).
|
||||
;; A 401 means the session expired: fall back to the logged-out view. Otherwise the list stays,
|
||||
;; with the error shown.
|
||||
(rf/reg-event-db
|
||||
::todo-failed
|
||||
(fn [db [_ {:keys [status] :as resp}]]
|
||||
@@ -278,152 +336,217 @@
|
||||
|
||||
;; --- Chat ---
|
||||
|
||||
;; The chat is a loop when the LLM uses the page's tools (see tbd.ui.model-context): the reply to a
|
||||
;; message can be a request for tool calls instead of (or after) text; the page makes the calls,
|
||||
;; 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.
|
||||
;; The chat loops when the LLM calls tools of the page (tbd.ui.model-context): the page runs them
|
||||
;; and resends the conversation, until the LLM answers without asking for more.
|
||||
|
||||
(def ^:private max-sent-messages
|
||||
"How much of the conversation goes to the server with each message (its limit is
|
||||
tbd.chat.schema/max-messages, which this stays within), the most recent part."
|
||||
"How much of the conversation goes to the server per request (bounded by
|
||||
tbd.chat.schema/max-messages), the most recent part."
|
||||
40)
|
||||
|
||||
(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
|
||||
stops it. A model that keeps calling tools never answers, and every call is something done on the
|
||||
user's page. (A turn is at most 1 + this many assistant messages and this many results, so it is
|
||||
always inside `max-sent-messages`.)"
|
||||
"Max tool calls the LLM may make answering one message, before the turn is stopped as a runaway
|
||||
loop. (A turn is at most 1 + this many assistant messages and this many results, so it always
|
||||
stays within max-sent-messages.)"
|
||||
12)
|
||||
|
||||
(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)
|
||||
|
||||
(def ^:private truncated " … (truncated)")
|
||||
|
||||
(defn- fit-result
|
||||
"A tool's result text as the content of a message: never empty, and no longer than the server
|
||||
takes."
|
||||
(defn- display-text
|
||||
"`text` for the chat log, never empty. Kept in full here; only what leaves the tab is cut down,
|
||||
by fit-result."
|
||||
[text]
|
||||
(cond
|
||||
(str/blank? text) "(no output)"
|
||||
(> (count text) max-tool-result-length) (str (subs text 0 (- max-tool-result-length (count truncated)))
|
||||
truncated)
|
||||
:else text))
|
||||
(if (str/blank? text) "(no output)" text))
|
||||
|
||||
(defn- fit-result
|
||||
"`text`, cut to max-tool-result-length, for a tool result about to leave the tab."
|
||||
[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))
|
||||
|
||||
(defn- next-id
|
||||
"An id unique within this page's session, for an AG-UI message: they only have to identify a
|
||||
message within one run's conversation, never across page loads."
|
||||
"A fresh id for an AG-UI message, unique within this page's session."
|
||||
[]
|
||||
(str "m" (swap! id-counter inc)))
|
||||
|
||||
(defn- wire-message
|
||||
"A message of the conversation as AG-UI's Message has it (see tbd.chat.schema/Message: user,
|
||||
assistant with `toolCalls`, or tool)."
|
||||
"A conversation message as AG-UI's Message (tbd.chat.schema/Message). A tool result is fit to
|
||||
the server's limit here; the browser's own copy stays whole."
|
||||
[{:keys [role content tool-calls tool-call-id]}]
|
||||
(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)
|
||||
(seq tool-calls) (assoc :toolCalls (mapv (fn [{:keys [id name arguments]}]
|
||||
{:id id :type "function"
|
||||
:function {:name name :arguments arguments}})
|
||||
tool-calls))))
|
||||
|
||||
(defn- recent
|
||||
"The most recent `max-sent-messages` of `messages`, without the results of calls whose asking
|
||||
is cut off: the LLM server refuses a result that answers nothing."
|
||||
[messages]
|
||||
(drop-while #(= "tool" (:role %)) (take-last max-sent-messages messages)))
|
||||
(defn- windowed
|
||||
"The most recent `n` of `messages`, dropping a leading tool result whose call fell out of the
|
||||
window."
|
||||
[n messages]
|
||||
(drop-while #(= "tool" (:role %)) (take-last n messages)))
|
||||
|
||||
(def ^:private stale-result
|
||||
"What the LLM is sent in place of a result from before the user's last message."
|
||||
"(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- recent [messages]
|
||||
(windowed max-sent-messages messages))
|
||||
|
||||
(defn- without-stale-results
|
||||
"`messages` with the content of the tool results from before the user's last message replaced by
|
||||
`stale-result`. A result is a snapshot of the page when the tool ran, and the user can change the
|
||||
page between messages, by hand or on another page; a model that is still shown the old snapshot
|
||||
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
|
||||
(list, then act on an id)."
|
||||
(def ^:private max-stored-messages
|
||||
"How much of the conversation is saved for \"restore my last session\" (bounded by
|
||||
tbd.chat.schema/max-history-messages): more than max-sent-messages, since this is scrollback."
|
||||
100)
|
||||
|
||||
(def ^:private max-stored-content-length
|
||||
"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]
|
||||
(let [last-user (or (last (keep-indexed (fn [i {:keys [role]}] (when (= "user" role) i)) messages)) 0)]
|
||||
(into [] (map-indexed (fn [i message]
|
||||
(let [fitted (into []
|
||||
(comp (remove only-reasoning?)
|
||||
(map (fn [message]
|
||||
(cond-> message
|
||||
(and (< i last-user) (= "tool" (:role message)))
|
||||
(assoc :content stale-result))))
|
||||
messages)))
|
||||
(= "tool" (:role message)) (update :content fit-stored)
|
||||
(: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
|
||||
"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]}]
|
||||
(cond-> {:name name :parameters inputSchema}
|
||||
description (assoc :description description)))
|
||||
|
||||
;; The request that sends the conversation: an AG-UI RunAgentInput. It goes with the page being
|
||||
;; shown (as a `context` entry, for the LLM to know where the user is) and the tools that page
|
||||
;; offers the LLM. Both are read from the db every time, so a conversation that moves between
|
||||
;; pages (the LLM's own `navigate`, say) always tells the LLM where it is now.
|
||||
;; An AG-UI RunAgentInput: the page's name (as `context`, so the LLM knows where the user is), the
|
||||
;; tools that page offers, and its current state (model-context/current-state), so the LLM never
|
||||
;; has to spend a call finding out. Read from the db each time, so a conversation that moves
|
||||
;; between pages always reflects where it is now.
|
||||
(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"
|
||||
:body (cond-> {:threadId (next-id) :runId (next-id)
|
||||
:messages (mapv wire-message (without-stale-results (recent messages)))
|
||||
:context [{:description "page" :value (name (:page db))}]}
|
||||
(seq tools) (assoc :tools (mapv wire-tool tools)))
|
||||
:messages (mapv wire-message (recent messages))
|
||||
:context [{:description "page" :value (name page)}]}
|
||||
(seq tools) (assoc :tools (mapv wire-tool tools))
|
||||
(seq state) (assoc :state state))
|
||||
:on-event [::chat-event]
|
||||
: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
|
||||
::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
|
||||
(fn [db _]
|
||||
(update-in db [:chat :open?] not)))
|
||||
(fn [{:keys [db]} _]
|
||||
(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
|
||||
;; them within the window).
|
||||
(rf/reg-event-db
|
||||
(rf/reg-event-fx
|
||||
::chat-resize
|
||||
(fn [db [_ width height]]
|
||||
(assoc-in db [:chat :size] {:width width :height height})))
|
||||
(fn [{:keys [db]} [_ width 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
|
||||
::chat-toggle-tools
|
||||
(fn [db _]
|
||||
(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
|
||||
::chat-set-input
|
||||
(fn [db [_ 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
|
||||
::chat-send
|
||||
(fn [{:keys [db]} _]
|
||||
(let [{:keys [input messages status]} (:chat db)
|
||||
content (str/trim input)]
|
||||
(when (and (not= :loading status) (seq content))
|
||||
(let [messages (conj messages {:role "user" :content content})]
|
||||
{:db (update db :chat assoc :messages messages :input "" :status :loading :error nil
|
||||
:tool-calls-used 0)
|
||||
::fetch-stream (chat-request db messages)})))))
|
||||
(let [messages (conj messages {:role "user" :content content})
|
||||
db (update db :chat assoc :messages messages :input "" :status :loading :error nil
|
||||
:tool-calls-used 0 :tools-used-this-turn #{})]
|
||||
{:db db
|
||||
::fetch-stream (chat-request db messages)
|
||||
::persist-chat (save-chat-fx db)})))))
|
||||
|
||||
(defn- only-reasoning?
|
||||
"Whether `message` is a reply that has come to nothing but the reasoning for it: there is nothing
|
||||
in it for the LLM to be sent (the server refuses an assistant message that says and asks for
|
||||
nothing)."
|
||||
"Whether `message` is a reply that has come to nothing but reasoning: no content, no tool calls
|
||||
(the server refuses a message that says and asks for nothing)."
|
||||
[{:keys [role content tool-calls]}]
|
||||
(and (= "assistant" role) (str/blank? content) (empty? tool-calls)))
|
||||
|
||||
(defn- chat-failed
|
||||
"The conversation after a send failed with `message`. If the last message is the user's (nothing
|
||||
of the reply had come, but perhaps some reasoning, which goes), it leaves the conversation again
|
||||
and goes back in the input, so trying once more is pressing Send (and the next message doesn't
|
||||
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."
|
||||
"The conversation after a send failed with `message`. If nothing of the reply had come, the
|
||||
unanswered user message goes back into the input (so retrying is just pressing Send); otherwise
|
||||
whatever came stays, and the next message follows it."
|
||||
[db message]
|
||||
(let [messages (get-in db [:chat :messages])
|
||||
messages (cond-> messages (only-reasoning? (peek messages)) pop)
|
||||
@@ -433,22 +556,21 @@
|
||||
(when unanswered?
|
||||
{:messages (pop messages) :input (:content (peek messages))}))))
|
||||
|
||||
;; The server answered without a stream: the request failed. A 401 means the session expired: fall
|
||||
;; back to the logged-out view. A response nobody is waiting for (the conversation was reset since,
|
||||
;; by logging out) is dropped.
|
||||
(rf/reg-event-db
|
||||
;; The server answered without a stream: the request failed. A 401 means the session expired.
|
||||
;; A response nobody is waiting for (the conversation was reset since) is dropped.
|
||||
(rf/reg-event-fx
|
||||
::chat-response
|
||||
(fn [db [_ {:keys [status] :as resp}]]
|
||||
(fn [{:keys [db]} [_ {:keys [status] :as resp}]]
|
||||
(cond
|
||||
(not= :loading (get-in db [:chat :status])) db
|
||||
(= 401 status) (-> db (assoc :user {:status :anonymous}) reset-chat)
|
||||
:else (chat-failed db (error-message resp)))))
|
||||
(not= :loading (get-in db [:chat :status])) {:db db}
|
||||
(= 401 status) {:db (-> db (assoc :user {:status :anonymous}) reset-chat)}
|
||||
:else (let [db (chat-failed db (error-message resp))]
|
||||
{:db db ::persist-chat (save-chat-fx db)}))))
|
||||
|
||||
(defn- append-to-reply
|
||||
"The conversation's assistant message being written, with `text` added to its content. The first
|
||||
piece starts the message, the rest are added to it. Leading whitespace is dropped while nothing
|
||||
has been said yet (the model often opens its answer with a stray blank line right after
|
||||
reasoning), but preserved once the message has content, since it may be meaningful there."
|
||||
"The conversation with `text` added to the assistant message being written (starting one if
|
||||
needed). Leading whitespace is dropped until the message has content (a reasoning model often
|
||||
opens with a stray blank line), then preserved."
|
||||
[db text]
|
||||
(update-in db [:chat :messages]
|
||||
(fn [messages]
|
||||
@@ -458,9 +580,19 @@
|
||||
(str content (if (str/blank? content) (str/triml text) 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
|
||||
"The conversation with the calls the LLM asked for: on the reply's text (the message it
|
||||
started), or on a message of their own when it said nothing."
|
||||
"The conversation with `calls` attached to the reply (on its text, or a fresh message if it said
|
||||
nothing)."
|
||||
[messages calls]
|
||||
(if (= "assistant" (:role (peek messages)))
|
||||
(update messages (dec (count messages)) assoc :tool-calls calls)
|
||||
@@ -469,33 +601,50 @@
|
||||
(defn- tool-message [{:keys [id name content 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
|
||||
"The reply is complete. Without calls that is all; with them, they are made (see ::call-tools)
|
||||
and the conversation goes on when they are done, unless this turn has used all the calls it may."
|
||||
"The reply is complete. With no calls, that's it. With calls, runs them (::call-tools) — except
|
||||
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]
|
||||
(let [{:keys [pending-calls tool-calls-used]} (:chat db)
|
||||
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)]
|
||||
(cond
|
||||
(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)
|
||||
;; The calls still get their answers, for the conversation to make sense to the LLM later.
|
||||
{:db (-> db
|
||||
(let [db (-> db
|
||||
(update-in [:chat :messages] with-tool-calls pending-calls)
|
||||
(update-in [:chat :messages] into
|
||||
(for [{:keys [id name]} pending-calls]
|
||||
(tool-message {:id id :name name :error? true
|
||||
:content "not run: too many tool calls in one turn"})))
|
||||
(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
|
||||
{:db (-> db
|
||||
(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))
|
||||
::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]
|
||||
(and (string? x) (seq x)))
|
||||
@@ -512,14 +661,10 @@
|
||||
call (-> (update-in [:chat :pending-calls] (fnil conj []) call)
|
||||
(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
|
||||
;; ({:delta "..."}) for the next piece of the reply (the first starts the assistant's message, the
|
||||
;; rest are added to it), REASONING_MESSAGE_CONTENT for the next piece of the model's reasoning
|
||||
;; (which is not kept: the user only sees that the model is thinking, and for as long as pieces
|
||||
;; 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.
|
||||
;; One AG-UI event of the reply (tbd.chat.routes, https://docs.ag-ui.com): TEXT_MESSAGE_CONTENT
|
||||
;; and REASONING_MESSAGE_CONTENT append to the reply's :content/:thinking, TOOL_CALL_START/ARGS/END
|
||||
;; build up :tool-call-buffer, and RUN_FINISHED/RUN_ERROR end the turn. Events nobody is waiting
|
||||
;; for (the conversation was reset since) are dropped.
|
||||
(rf/reg-event-fx
|
||||
::chat-event
|
||||
[(rf/inject-cofx ::now)]
|
||||
@@ -531,46 +676,52 @@
|
||||
(cond
|
||||
(not loading?) {:db db}
|
||||
(= "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_ARGS" type) {:db (append-tool-call-args db event)}
|
||||
(= "TOOL_CALL_END" type) {:db (end-tool-call db event)}
|
||||
(= "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}))))
|
||||
|
||||
(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
|
||||
"A promise of the results of `calls`, in order, as {:id :name :content :error?}. One after the
|
||||
other: the tools work on the same page (one may need the page the last one opened). Only the
|
||||
tools `page` offers can be called."
|
||||
"A promise of the results of `calls`, in order, as {:id :name :content :error?}. Run one after
|
||||
the other (a tool may need the page the last one left). A call marked :blocked? by blocked-calls
|
||||
never reaches the page."
|
||||
[page calls]
|
||||
(reduce (fn [results {:keys [id name arguments]}]
|
||||
(reduce (fn [results {:keys [id name arguments blocked?]}]
|
||||
(.then results
|
||||
(fn [done]
|
||||
(if blocked?
|
||||
(conj done {:id id :name name :content blocked-message :error? true})
|
||||
(.then (model-context/call! page name arguments)
|
||||
(fn [{:keys [text error?]}]
|
||||
(conj done {:id id :name name :content (fit-result text) :error? error?}))))))
|
||||
(conj done {:id id :name name :content (display-text text) :error? error?})))))))
|
||||
(js/Promise.resolve [])
|
||||
calls))
|
||||
|
||||
;; Effect: make the tool calls the LLM asked for, on the tools `page` (the one being shown) offers,
|
||||
;; and dispatch `(conj on-results results)` when all are done: one {:id :name :content :error?}
|
||||
;; for each, in order. A call that can't be made (an unknown tool, one the page doesn't offer,
|
||||
;; arguments that aren't JSON, a tool that fails) is a result with :error?, for the LLM to read.
|
||||
;; Runs the LLM's tool calls on `page`'s tools, and dispatches `(conj on-results results)` when
|
||||
;; done: one {:id :name :content :error?} per call. A call that can't be made (unknown tool, bad
|
||||
;; arguments, a tool that throws) comes back as an :error? result, for the LLM to read.
|
||||
(rf/reg-fx
|
||||
::call-tools
|
||||
(fn [{:keys [page calls on-results]}]
|
||||
(.then (call-all page calls) #(rf/dispatch (conj on-results %)))))
|
||||
|
||||
(defn- answers?
|
||||
"Whether `results` are for the calls the conversation is waiting on. Results nobody waits for
|
||||
(the conversation was reset while the tools ran) are not."
|
||||
"Whether `results` answer the calls the conversation is waiting on (not a stale response after
|
||||
the conversation was reset while the tools ran)."
|
||||
[db results]
|
||||
(let [calls (:tool-calls (peek (get-in db [:chat :messages])))]
|
||||
(and (= :loading (get-in db [:chat :status]))
|
||||
(seq calls)
|
||||
(= (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
|
||||
::chat-tool-results
|
||||
(fn [{:keys [db]} [_ results]]
|
||||
@@ -580,18 +731,56 @@
|
||||
{:db db
|
||||
::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.
|
||||
(rf/reg-event-db
|
||||
(def ^:private halted-result
|
||||
"(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
|
||||
(fn [db _]
|
||||
(fn [{:keys [db]} _]
|
||||
(if (= :loading (get-in db [:chat :status]))
|
||||
db
|
||||
(reset-chat db))))
|
||||
{:db 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 ---
|
||||
|
||||
;; Effect: put `text` on the clipboard. The Clipboard API only exists on secure origins (https
|
||||
;; or localhost), so the view doesn't offer the button without it; failures are ignored.
|
||||
;; Puts `text` on the clipboard. Requires a secure origin (https or localhost); failures are
|
||||
;; ignored.
|
||||
(rf/reg-fx
|
||||
::copy-to-clipboard
|
||||
(fn [text]
|
||||
@@ -611,16 +800,19 @@
|
||||
|
||||
;; --- Tic-tac-toe ---
|
||||
|
||||
;; An illegal move (taken cell, game over) changes nothing.
|
||||
(rf/reg-event-db
|
||||
(rf/reg-event-fx
|
||||
::ttt-move
|
||||
(fn [db [_ i]]
|
||||
(fn [{:keys [db]} [_ i]]
|
||||
(let [{:keys [board turn]} (:ttt db)]
|
||||
(if-let [board' (tictactoe/move board turn i)]
|
||||
(assoc db :ttt {:board board' :turn (tictactoe/next-player turn)})
|
||||
db))))
|
||||
(let [ttt {:board board' :turn (tictactoe/next-player turn)}]
|
||||
{:db (assoc db :ttt ttt)
|
||||
::persist-ttt ttt})
|
||||
{:db db}))))
|
||||
|
||||
(rf/reg-event-db
|
||||
(rf/reg-event-fx
|
||||
::ttt-reset
|
||||
(fn [db _]
|
||||
(assoc db :ttt (:ttt db/default-db))))
|
||||
(fn [{:keys [db]} _]
|
||||
(let [ttt (:ttt db/default-db)]
|
||||
{:db (assoc db :ttt ttt)
|
||||
::persist-ttt ttt})))
|
||||
|
||||
@@ -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 "")))))
|
||||
@@ -1,26 +1,20 @@
|
||||
(ns tbd.ui.model-context
|
||||
"The page's `modelContext`: the tools the page offers to an agent, as WebMCP names it (a page
|
||||
registers tools with `navigator.modelContext` in the browsers that have one). Here it is the
|
||||
registry the page's own chatbot reads. tbd.ui.core registers the tools of tbd.ui.webmcp, which
|
||||
are also offered to an outside agent through the WebMCP widget; the chatbot is the same thing
|
||||
embedded in the page.
|
||||
"The registry of tools the page's own chatbot offers its LLM, mirroring WebMCP's
|
||||
`navigator.modelContext` (tbd.ui.core registers tbd.ui.webmcp's tools here too). The chatbot
|
||||
sends `definitions` (MCP's `tools/list` shape) with the conversation; tbd.ui.events intercepts
|
||||
the LLM's requested calls and runs them via `call!`, right here in the page.
|
||||
|
||||
The chatbot passes the tools' metadata (`definitions`, the shape of MCP's `tools/list`) to the
|
||||
LLM along with the conversation. The LLM never runs anything: it answers with the calls it wants
|
||||
made, tbd.ui.events intercepts them, `call!` invokes the tool right here in the page (the same
|
||||
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 a map of
|
||||
arguments and returns a value or promise of one (a string as-is, other data as JSON; throwing is
|
||||
an error result). `pages` (tbd.ui.pages) is where the tool is offered; omitted means every page.
|
||||
|
||||
A tool is {:name :description :input-schema :handler :pages}: `handler` takes its arguments as a
|
||||
map and returns a value or a promise of one. A string is the result as it is, any other data
|
||||
becomes JSON, and throwing (or rejecting) is an error result the agent can read. `pages` is the
|
||||
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."
|
||||
State providers ({:pages :provide}) are the same idea for ambient state: tbd.ui.events attaches
|
||||
`(current-state page)` to every /api/chat request (tbd.chat.schema/RunAgentInput's `state`), so
|
||||
the model sees what the page shows without spending a call to read it."
|
||||
(:require [clojure.string :as str]))
|
||||
|
||||
(defonce ^:private registry (atom []))
|
||||
(defonce ^:private state-registry (atom []))
|
||||
|
||||
(defn register!
|
||||
"Adds `tools` to what the page offers. A tool with the name of one already there replaces it
|
||||
@@ -31,27 +25,57 @@
|
||||
nil))
|
||||
|
||||
(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! state-registry [])
|
||||
nil)
|
||||
|
||||
(defn- offered?
|
||||
"Whether `tool` is offered on `page`."
|
||||
"Whether `entry` (a tool or a state provider) is offered on `page`."
|
||||
[page {:keys [pages]}]
|
||||
(or (nil? pages) (contains? pages page)))
|
||||
|
||||
(defn definitions
|
||||
"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]
|
||||
(into []
|
||||
(comp (filter #(offered? page %))
|
||||
(remove :read-only?)
|
||||
(map (fn [{:keys [name description input-schema]}]
|
||||
(cond-> {:name name :inputSchema input-schema}
|
||||
description (assoc :description description)))))
|
||||
@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]
|
||||
(cond
|
||||
(string? value) value
|
||||
|
||||
+94
-16
@@ -3,6 +3,7 @@
|
||||
[reagent.core :as r]
|
||||
[re-frame.core :as rf]
|
||||
[tbd.ui.events :as events]
|
||||
[tbd.ui.markdown :as markdown]
|
||||
[tbd.ui.pages :as pages]
|
||||
[tbd.ui.subs :as subs]
|
||||
[tbd.ui.webmcp :as webmcp]))
|
||||
@@ -178,14 +179,37 @@
|
||||
|
||||
(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]}]
|
||||
(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"
|
||||
:white-space "pre-wrap" :overflow-wrap "anywhere"
|
||||
:overflow-wrap "anywhere"
|
||||
:background (if user? chat-green "#f1f1f1")
|
||||
:color (if user? "white" "#222")}}
|
||||
content]))
|
||||
(markdown/render content)]))
|
||||
|
||||
(defn- chat-tool-line
|
||||
"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?]}]
|
||||
(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
|
||||
"What was said, as a bubble, and the tool calls the assistant made with it, and their results,
|
||||
as lines between the bubbles."
|
||||
[tools-expanded? {:keys [role content tool-calls] :as message}]
|
||||
as lines between the bubbles. The reasoning behind a reply, if any, shows above it, whole, only
|
||||
when `reasoning-expanded?`."
|
||||
[tools-expanded? reasoning-expanded? {:keys [role content tool-calls thinking halted?] :as message}]
|
||||
(if (= "tool" role)
|
||||
[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])
|
||||
(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?
|
||||
"Whether the conversation has any tool call or result."
|
||||
[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-height 96)
|
||||
;; 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)]
|
||||
(let [now @clock
|
||||
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"}}
|
||||
"Thinking"
|
||||
[:span {:style {:display "inline-block" :width "1.2em"}}
|
||||
(if live?
|
||||
(str "Thinking" (apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) ".")))
|
||||
"Thinking…")])
|
||||
(apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) "."))
|
||||
"…")]])
|
||||
(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
|
||||
"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
|
||||
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
|
||||
(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]
|
||||
(let [stuck? (atom true)
|
||||
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"
|
||||
:ref (fn [el]
|
||||
(when el
|
||||
@@ -283,9 +353,12 @@
|
||||
(if (and (empty? messages) (not= :loading status))
|
||||
[:p {:style {:color "#777" :margin 0}} "Ask me anything."]
|
||||
(for [[i message] (map-indexed vector messages)]
|
||||
^{:key i} [chat-message tools-expanded? message]))
|
||||
(when (and (= :loading status) (not= "assistant" (:role (peek messages))))
|
||||
[thinking-line thinking-at])])))
|
||||
^{:key i} [chat-message tools-expanded? reasoning-expanded? message]))
|
||||
(when (= :loading status)
|
||||
[: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]}]
|
||||
(let [loading? (= :loading status)]
|
||||
@@ -293,9 +366,10 @@
|
||||
(.preventDefault e)
|
||||
(rf/dispatch [::events/chat-send]))
|
||||
: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"
|
||||
:auto-focus true :auto-complete "off" :read-only loading?
|
||||
:auto-focus true :auto-complete "off"
|
||||
:style {:flex 1 :min-width 0}
|
||||
:value input
|
||||
:on-change #(rf/dispatch [::events/chat-set-input (.. % -target -value)])}]
|
||||
@@ -344,7 +418,7 @@
|
||||
:cursor "nesw-resize" :touch-action "none"
|
||||
: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"
|
||||
:style {:position "absolute" :bottom "40px" :left 0 :box-sizing "border-box"
|
||||
:width (str (:width size) "px")
|
||||
@@ -356,6 +430,9 @@
|
||||
(when (tool-use? messages)
|
||||
[link-button {:on-click #(rf/dispatch [::events/chat-toggle-tools])}
|
||||
(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))
|
||||
[link-button {:on-click #(rf/dispatch [::events/chat-clear])} "Clear"])
|
||||
[:button {:type "button" :aria-label "Close chat"
|
||||
@@ -375,6 +452,7 @@
|
||||
user @(rf/subscribe [::subs/user])]
|
||||
[:div {:style {:position "fixed" :left "20px" :bottom "20px" :z-index 9999
|
||||
:font-family "Arial, sans-serif" :font-size "14px"}}
|
||||
[chat-markdown-style]
|
||||
(when open? [chat-panel chat user])
|
||||
[:button {:type "button" :aria-label "Chat" :title "Chat" :aria-expanded (boolean open?)
|
||||
:style {:display "block" :width "30px" :height "30px" :padding 0 :border 0
|
||||
|
||||
+68
-70
@@ -1,26 +1,18 @@
|
||||
(ns tbd.ui.webmcp
|
||||
"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`
|
||||
library): it adds a small widget to the page, the user pastes a token from their MCP client
|
||||
(Claude) into it, and the client then sees the tools registered here. Where tbd.mcp.tools works
|
||||
on the server's data, these work the UI: each one does what a user could do on the page (type in
|
||||
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.
|
||||
tbd.mcp.tools, offered through WebMCP (https://webmcp.dev). Each tool does what a user could do
|
||||
on the page (type in a form, press a button) by dispatching the same re-frame events the views
|
||||
do, and reads results from the app-db. A tool takes a map of arguments and returns a value or a
|
||||
promise of one (a string, or data that becomes JSON); throwing becomes an error result.
|
||||
|
||||
Besides the tools, the page registers prompts and resources (`prompts`, `resources`), which is
|
||||
what an MCP client lists next to the tools (Claude Code shows the prompts as slash commands and
|
||||
the resources as @-mentions). They are the same instructions the page's own chatbot is given
|
||||
(tbd.agent.prompt, shared with the server), so Claude or Codex is told to act rather than offer,
|
||||
to chain calls and to play tic-tac-toe by the turn, and can read what page is open.
|
||||
`tools` also feeds tbd.ui.model-context (via tbd.ui.core), which offers the page's chatbot the
|
||||
same tools. `:read-only? true` tools are left out there — the chatbot gets that information as
|
||||
ambient state instead (`state-providers`) — but stay registered here for WebMCP's outside
|
||||
agents. `:once-per-turn? true` tools (e.g. move_tic_tac_toe) are offered to the chatbot only
|
||||
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
|
||||
own chatbot offers them to its LLM and calls them, the ones of the page being shown (see
|
||||
`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."
|
||||
`prompts` and `resources` carry the same instructions as the chatbot's system prompt
|
||||
(tbd.agent.prompt), so an outside MCP client is told to act instead of offer, chain calls, etc."
|
||||
(:require ["@jason.today/webmcp/src/webmcp.js" :as WebMCP]
|
||||
[clojure.string :as str]
|
||||
[re-frame.core :as rf]
|
||||
@@ -215,13 +207,16 @@
|
||||
(.then #(last (get-in % [:todos :items])))))
|
||||
|
||||
(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]}]
|
||||
(check-todos! todos (fn [{:keys [title]}]
|
||||
(when-not (and (string? title) (seq title))
|
||||
(fail! "invalid arguments: title must be a non-empty string"))))
|
||||
(-> (logged-in-todos)
|
||||
(.then (fn [_] (in-order create-one todos)))))
|
||||
(.then (fn [_] (in-order create-one todos)))
|
||||
(.then (constantly nil))))
|
||||
|
||||
(defn- set-one-done
|
||||
"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
|
||||
"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]}]
|
||||
(check-todos! todos (fn [{:keys [id done]}]
|
||||
(check-id! id)
|
||||
@@ -247,7 +242,8 @@
|
||||
(.then (fn [items]
|
||||
(run! #(find-todo! items (:id %)) todos)
|
||||
(show! :todos)
|
||||
(in-order set-one-done todos)))))
|
||||
(in-order set-one-done todos)))
|
||||
(.then (constantly nil))))
|
||||
|
||||
(defn- delete-one
|
||||
"Presses a todo's Delete button. A promise of its id."
|
||||
@@ -258,7 +254,8 @@
|
||||
(.then (fn [_] id))))
|
||||
|
||||
(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]}]
|
||||
(check-todos! todos #(check-id! (:id %)))
|
||||
(let [ids (distinct (map :id todos))]
|
||||
@@ -267,12 +264,7 @@
|
||||
(run! #(find-todo! items %) ids)
|
||||
(show! :todos)
|
||||
(in-order delete-one ids)))
|
||||
(.then (fn [deleted] {:deleted deleted})))))
|
||||
|
||||
;; 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.
|
||||
(.then (constantly nil)))))
|
||||
|
||||
(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
|
||||
@@ -289,8 +281,28 @@
|
||||
(defn- get-tic-tac-toe [_]
|
||||
(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
|
||||
"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]}]
|
||||
(when-not (and (number? cell) (js/Number.isInteger cell) (<= 0 cell 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\""))
|
||||
(let [{:keys [board turn]} (:ttt (db))]
|
||||
(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))
|
||||
(fail! (str "it is " (name turn) "'s turn, not " player "'s: wait for the other side to move")))
|
||||
(when (board cell)
|
||||
@@ -307,13 +319,6 @@
|
||||
(rf/dispatch-sync [::events/ttt-move cell])
|
||||
(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]
|
||||
{:type "object" :properties properties :required required})
|
||||
|
||||
@@ -340,8 +345,9 @@
|
||||
:input-schema (object-schema {} []) :handler whoami}
|
||||
|
||||
{:name "navigate"
|
||||
:description (str "Opens one of the pages of the app, as a click on its tab would, and returns the page "
|
||||
"that is shown now (JSON). The pages are: "
|
||||
:description (str "Opens one of the pages of the app, as a click on its tab would. It only moves you "
|
||||
"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 (name id) " (" title (when login? ", needs a login") ")"))
|
||||
pages/pages))
|
||||
@@ -352,7 +358,7 @@
|
||||
["page"])
|
||||
: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 "
|
||||
"the result it is showing (status idle, loading, ok with the sum, or error with the message)")
|
||||
:input-schema (object-schema {} []) :handler get-calculator}
|
||||
@@ -365,29 +371,28 @@
|
||||
["x" "y"])
|
||||
: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. "
|
||||
"Needs a login on the page")
|
||||
: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 "
|
||||
"with all of them")
|
||||
:input-schema (todos-schema "The todos to get, one per todo" {:id todo-id} ["id"])
|
||||
:handler get-todo}
|
||||
|
||||
{:name "create_todo" :pages #{:todos}
|
||||
:description (str "Adds todos: types each title into the new-todo field and presses Add, and returns the todos "
|
||||
"that were created (JSON list). Takes a list: to add several, make ONE call with all of them, "
|
||||
"never one call per todo")
|
||||
:description (str "Adds todos: types each title into the new-todo field and presses Add. Takes a list: to add "
|
||||
"several, make ONE call with all of them, never one call 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"])
|
||||
:handler create-todo}
|
||||
|
||||
{:name "set_todo_done" :pages #{:todos}
|
||||
:description (str "Ticks or unticks the checkboxes of todos, and returns those todos (JSON list). Takes a list: "
|
||||
"to change several, make ONE call with all of them, never one call per todo")
|
||||
:description (str "Ticks or unticks the checkboxes of todos. Takes a list: to change several, make ONE call "
|
||||
"with all of them, never one call per todo")
|
||||
:input-schema (todos-schema "The changes to make, one per todo"
|
||||
{:id todo-id
|
||||
:done {:type "boolean" :description "true to tick it off, false to untick it"}}
|
||||
@@ -395,37 +400,32 @@
|
||||
:handler set-todo-done}
|
||||
|
||||
{:name "delete_todo" :pages #{:todos}
|
||||
:description (str "Deletes todos for good, by pressing their Delete buttons, and returns the ids that were "
|
||||
"deleted (JSON). Find the ids with list_todos first; never guess one, and never delete a "
|
||||
:description (str "Deletes todos for good, by pressing their Delete buttons. Find the id first — from the "
|
||||
"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 "
|
||||
"with all of them")
|
||||
:input-schema (todos-schema "The todos to delete, one per todo" {:id todo-id} ["id"])
|
||||
: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 "
|
||||
"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; "
|
||||
"when won, also winner and line). A person moves on the same board, so check the turn "
|
||||
"before you move, and only move for your own side")
|
||||
"when won, also winner and line)")
|
||||
:input-schema (object-schema {} []) :handler get-tic-tac-toe}
|
||||
|
||||
{:name "move_tic_tac_toe" :pages #{:tic-tac-toe}
|
||||
:description (str "Presses a cell of the tic-tac-toe board as `player`, your side, and returns the game as "
|
||||
"get_tic_tac_toe does (including whose turn is next). Fails, and changes nothing, if it "
|
||||
"is not your side's turn (the other side is the person's: wait for them to move), the "
|
||||
"cell is taken or the game is over. Never move for the other side")
|
||||
{: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`, and returns the board afterwards "
|
||||
"(JSON, the same shape as get_tic_tac_toe). Fails, and changes nothing, if it isn't that "
|
||||
"side's turn yet, the cell is taken or the game is over. Runs at most once per message: "
|
||||
"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
|
||||
:description "0 is the top left, 2 the top right, 8 the bottom right"}
|
||||
:player {:type "string" :enum ["x" "o"]
|
||||
:description (str "The side you play. The move is refused if it "
|
||||
"is the other side's turn")}}
|
||||
:description "Which side this move is for"}}
|
||||
["cell" "player"])
|
||||
: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}])
|
||||
:handler move-tic-tac-toe}])
|
||||
|
||||
;; --- Prompts and resources ---
|
||||
|
||||
@@ -441,10 +441,8 @@
|
||||
:handler (fn [{:keys [task]}] (prompt/task task))}
|
||||
|
||||
{: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"
|
||||
:arguments [{:name "side" :required false
|
||||
: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))}])
|
||||
:description "Plays tic-tac-toe with you on the page"
|
||||
:handler (fn [_] prompt/tic-tac-toe)}])
|
||||
|
||||
(defn- page-state
|
||||
"A promise of what the page is showing: the open page, the pages and who is logged in."
|
||||
|
||||
@@ -57,6 +57,9 @@
|
||||
(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)))
|
||||
"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.
|
||||
(let [ping (.-execute (.get (.-availableTools ^js (widget)) "ping"))]
|
||||
(-> (ping #js {})
|
||||
|
||||
+291
-37
@@ -1,6 +1,5 @@
|
||||
(ns tbd.ui.events-test
|
||||
(:require [cljs.test :refer [deftest is testing async use-fixtures]]
|
||||
[clojure.string :as str]
|
||||
[re-frame.core :as rf]
|
||||
[re-frame.db :as rf-db]
|
||||
[tbd.ui.db :as db]
|
||||
@@ -25,10 +24,13 @@
|
||||
:after model-context/clear!}
|
||||
(tu/stub-effects-fixture {::events/fetch (record ::events/fetch)
|
||||
::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/copy-to-clipboard (record ::events/copy-to-clipboard)
|
||||
:dispatch-later (record :dispatch-later)
|
||||
:dispatch #(swap! queued conj %)}))
|
||||
:dispatch #(swap! queued conj %)
|
||||
:dispatch-n #(swap! queued into %)}))
|
||||
|
||||
(defn- dispatch!
|
||||
"Dispatches `event` and, one after the other, the events it sets off."
|
||||
@@ -49,6 +51,14 @@
|
||||
|
||||
(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!
|
||||
"The server answers the last request."
|
||||
([status body] (answer! (last-request) status body))
|
||||
@@ -162,10 +172,11 @@
|
||||
;; --- Login ---
|
||||
|
||||
(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!)
|
||||
(answer! 200 {:login "alice" :id 7})
|
||||
(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)))))
|
||||
(testing "401 only means nobody is logged in"
|
||||
(start!)
|
||||
@@ -323,6 +334,18 @@
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(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
|
||||
"`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."
|
||||
@@ -338,8 +361,7 @@
|
||||
(logged-in! [])
|
||||
(say! " hello there ")
|
||||
(testing "the trimmed message joins the conversation and goes to the server, for a stream back"
|
||||
(let [[effect request] (last @effects)]
|
||||
(is (= ::events/fetch-stream effect))
|
||||
(let [request (last-request)]
|
||||
(is (= "/api/chat" (:uri request)))
|
||||
(is (= "POST" (:method request)))
|
||||
(is (= [::events/chat-event] (:on-event request)))
|
||||
@@ -347,7 +369,11 @@
|
||||
(is (= [{:role "user" :content "hello there"}] (sent-messages request)))
|
||||
(is (= [{:description "page" :value "tic-tac-toe"}] (get-in request [:body :context]))))
|
||||
(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"
|
||||
(say! "and another")
|
||||
(is (= 1 (count (requests))))
|
||||
@@ -365,19 +391,22 @@
|
||||
(deftest chat-streaming-reply-test
|
||||
(logged-in! [])
|
||||
(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 "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)))))
|
||||
(testing "the first piece of the reply, and the ones that follow, are added to that message"
|
||||
(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))))
|
||||
(event! {:content "lo, "})
|
||||
(event! {:content "world"})
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "Hello, world"}]
|
||||
{:role "assistant" :content "Hello, world" :thinking "Let me think."}]
|
||||
(:messages (chat))))
|
||||
(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"
|
||||
@@ -387,12 +416,12 @@
|
||||
(event! {:done true})
|
||||
(is (= {:status :idle :error nil} (select-keys (chat) [:status :error])))
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "Hello, world"}]
|
||||
{:role "assistant" :content "Hello, world" :thinking "Let me think."}]
|
||||
(:messages (chat)))))
|
||||
(testing "events that come after the end are dropped"
|
||||
(event! {:content "late"})
|
||||
(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")
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hello, world"}
|
||||
{:role "user" :content "again"}]
|
||||
@@ -434,15 +463,16 @@
|
||||
(say! "hello")
|
||||
(event! {:thinking "hm" :content "Hi"})
|
||||
(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))))
|
||||
(testing "an empty piece changes nothing"
|
||||
(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))))))
|
||||
|
||||
(deftest chat-thinking-is-never-kept-test
|
||||
;; The reasoning of each reply of a turn, before and after tools, leaves nothing in the conversation.
|
||||
(deftest chat-thinking-per-reply-test
|
||||
;; 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! [])
|
||||
(say! "hi")
|
||||
(event! {:thinking "first"})
|
||||
@@ -451,9 +481,9 @@
|
||||
(dispatch! [::events/chat-tool-results [{:id "c1" :name "ping" :content "pong" :error? false}]])
|
||||
(event! {:thinking "second"})
|
||||
(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)))))
|
||||
(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
|
||||
(logged-in! [])
|
||||
@@ -532,7 +562,41 @@
|
||||
(event! {:done true})
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(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
|
||||
(logged-in! [])
|
||||
@@ -547,6 +611,19 @@
|
||||
(dispatch! [::events/chat-toggle-tools])
|
||||
(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
|
||||
(logged-in! [])
|
||||
(is (= {:width 320 :height 256} (:size (chat))) "the size it starts with")
|
||||
@@ -563,6 +640,12 @@
|
||||
(answer! 200 {:logged-out true})
|
||||
(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
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
@@ -606,6 +689,62 @@
|
||||
{:id id :name tool-name :content content :error? error?})
|
||||
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
|
||||
(logged-in! [])
|
||||
(testing "no tools on the page, none offered"
|
||||
@@ -618,6 +757,27 @@
|
||||
(is (= [{:name "add" :description "Adds" :parameters add-schema}]
|
||||
(: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]
|
||||
(some #(when (= "page" (:description %)) (:value %)) (get-in request [:body :context])))
|
||||
|
||||
@@ -681,15 +841,17 @@
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
|
||||
(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! {: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))))
|
||||
(testing "when the reply is over, the calls join the conversation and are made"
|
||||
(event! {:done true})
|
||||
(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}")]}]
|
||||
(:messages (chat))))
|
||||
(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 (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
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
@@ -751,6 +964,41 @@
|
||||
(dispatch! [::events/chat-send])
|
||||
(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
|
||||
(logged-in! [])
|
||||
(say! "go wild")
|
||||
@@ -827,7 +1075,11 @@
|
||||
(select-keys (chat) [:messages :input :status :error :pending-calls])))
|
||||
(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! [])
|
||||
(swap! rf-db/app-db assoc-in [:chat :messages]
|
||||
[{: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 "assistant" :content "Your move."}])
|
||||
(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])]
|
||||
(is (= ["user" "assistant" "tool" "assistant" "user"] (map :role sent)))
|
||||
(is (= "old" (:toolCallId (nth sent 2))))
|
||||
(is (str/includes? (:content (nth sent 2)) "out of date"))
|
||||
(is (not (str/includes? (:content (nth sent 2)) "\"turn\"")) "what it read is gone")
|
||||
(is (= "{\"turn\":\"x\"}" (:content (nth sent 2))))
|
||||
(is (= "Your move." (:content (nth sent 3))))))
|
||||
(testing "the conversation the user sees keeps the result"
|
||||
(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" "{}"))
|
||||
(ran! ["new" "get_tic_tac_toe" "{\"turn\":\"o\"}" false])
|
||||
(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)))))))
|
||||
|
||||
(deftest chat-sends-no-orphaned-result-test
|
||||
@@ -916,23 +1167,26 @@
|
||||
(call "4" "blank" "")
|
||||
(call "5" "fails" "{}")
|
||||
(call "6" "nope" "{}")
|
||||
(call "7" "fast" "oops")]
|
||||
(call "7" "fast" "oops")
|
||||
(assoc (call "8" "fast" "{}") :blocked? true)]
|
||||
:on-results [::ran]})))
|
||||
(fn [results]
|
||||
(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"
|
||||
(is (= ["1" "2" "3" "4" "5" "6" "7"] (map :id results)))
|
||||
(is (= ["slow" "fast" "huge" "blank" "fails" "nope" "fast"] (map :name results)))
|
||||
(is (= ["1" "2" "3" "4" "5" "6" "7" "8"] (map :id results)))
|
||||
(is (= ["slow" "fast" "huge" "blank" "fails" "nope" "fast" "fast"] (map :name 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 (= 8000 (count (:content (nth results 2)))))
|
||||
(is (= "xxx … (truncated)" (subs (:content (nth results 2)) 7983))))
|
||||
(is (= 9000 (count (:content (nth results 2))))))
|
||||
(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"]
|
||||
(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]
|
||||
(reset! answer resolve)
|
||||
(call-tools-fx {:calls [] :on-results [::ran]})))
|
||||
|
||||
@@ -55,10 +55,43 @@
|
||||
(tu/steps
|
||||
#(stream! (streaming asked (sse {:type "RUN_FINISHED"})) 1)
|
||||
(fn [_]
|
||||
(let [[uri opts] @asked]
|
||||
(is (= ["/api/chat" {:method "POST"
|
||||
:headers {:Content-Type "application/edn"}
|
||||
:body "{:x 1}"}]
|
||||
@asked))))
|
||||
[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))))
|
||||
|
||||
(deftest events-test
|
||||
|
||||
@@ -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)")))))
|
||||
@@ -122,6 +122,20 @@
|
||||
(fn [_] (is (= [:tic-tac-toe-only :everywhere] @ran) "and never run")))
|
||||
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
|
||||
(let [ran? (atom false)]
|
||||
(model-context/register! [(tool "t" (fn [_] (reset! ran? true) "ran"))])
|
||||
|
||||
@@ -76,6 +76,13 @@
|
||||
{:content "echo: "}
|
||||
{:content (:content (last (:messages body)))}
|
||||
{: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 (= "POST" method) (= "/api/todos" uri))
|
||||
(if (seq (.trim (:title body)))
|
||||
@@ -167,10 +174,13 @@
|
||||
(aset js/globalThis "fetch" real-fetch))})
|
||||
|
||||
(def url-fixture
|
||||
"Each test starts on the page's own address, with no fragment (the page shown is the first)."
|
||||
(let [reset-hash! #(set! js/location.hash "")]
|
||||
{:before reset-hash!
|
||||
:after reset-hash!}))
|
||||
"Each test starts on the page's own address, with no fragment (the page shown is the first), and
|
||||
with nothing saved in localStorage (e.g. the chat widget's :open?/:size, see
|
||||
tbd.ui.events/persist-chat-ui) — jsdom's window, and so its localStorage, is shared by every
|
||||
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}))
|
||||
|
||||
|
||||
@@ -1,10 +1,13 @@
|
||||
(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.db :as rf-db]
|
||||
[tbd.ui.events :as events]
|
||||
[tbd.ui.test-util :as tu]
|
||||
[tbd.ui.tictactoe :as ttt]))
|
||||
|
||||
(use-fixtures :each tu/url-fixture)
|
||||
|
||||
(defn- board
|
||||
"A board from a string of 9 characters: x, o or anything else for an empty cell."
|
||||
[s]
|
||||
@@ -70,3 +73,16 @@
|
||||
(testing "a draw"
|
||||
(move! 0 1 2 4 3 5 7 6 8)
|
||||
(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))))))
|
||||
|
||||
@@ -483,7 +483,9 @@
|
||||
(defn- chat-messages
|
||||
"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
|
||||
"The tool calls and results the conversation shows, line by line."
|
||||
@@ -500,6 +502,16 @@
|
||||
[]
|
||||
(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
|
||||
;; A green square in the bottom left corner, opposite WebMCP's blue one; it opens the panel.
|
||||
(async done
|
||||
@@ -549,7 +561,9 @@
|
||||
(fn [_]
|
||||
(is (= "" (.-value (q "input[name=message]"))) "the input is emptied when sent")
|
||||
(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")
|
||||
(tu/eventually (fn [] (= "again" (.-value (q "input[name=message]"))))))
|
||||
(fn [_]
|
||||
@@ -589,7 +603,7 @@
|
||||
(fn [_]
|
||||
(is (= "Thinking…" (text "[role=status]")))
|
||||
(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 (nil? (first (filter #(= "Clear" (.-textContent %)) (q-all "[role=dialog] button"))))
|
||||
"can't start over mid-reply")
|
||||
@@ -622,7 +636,8 @@
|
||||
|
||||
(deftest chat-streaming-test
|
||||
;; 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.
|
||||
(async done
|
||||
(swap! tu/server assoc :chat-script [:pause
|
||||
@@ -645,22 +660,52 @@
|
||||
"still thinking while the model reasons")
|
||||
(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 (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!))
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (= ["hi" "Hello"] (chat-messages)))))
|
||||
(fn [_]
|
||||
(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]"))))
|
||||
(resume-stream!))
|
||||
#(tu/eventually (fn [] (= ["hi" "Hello, world"] (chat-messages))))
|
||||
#(tu/eventually (fn [] (false? (.-readOnly (q "input[name=message]")))))
|
||||
#(tu/eventually (fn [] (= :idle (chat-status))))
|
||||
(fn [_]
|
||||
(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=dialog] [role=alert]")))))
|
||||
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
|
||||
;; While pieces of the reasoning are coming in "Thinking" has one to three dots; once they stop
|
||||
;; (for a moment) it is "Thinking…" again.
|
||||
@@ -687,8 +732,10 @@
|
||||
#(tu/eventually (fn [] (nil? (q "[role=status]")))))
|
||||
done)))
|
||||
|
||||
(deftest chat-reasoning-is-never-shown-test
|
||||
;; Neither while it comes nor in the finished conversation, in any element of the panel.
|
||||
(deftest chat-reasoning-toggle-test
|
||||
;; 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
|
||||
(let [thought "secret reasoning about the answer"]
|
||||
(swap! tu/server assoc :chat-script [{:thinking thought} {:content "Done."} {:done true}])
|
||||
@@ -699,7 +746,16 @@
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (= ["hi" "Done."] (chat-messages))))
|
||||
(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))))
|
||||
|
||||
(defn- pointer!
|
||||
@@ -798,7 +854,7 @@
|
||||
(is (= 1000 @@top) "back near the end, it follows again")
|
||||
(reset! @top 200)
|
||||
(.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")
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (= 1000 @@top))))
|
||||
(fn [_]
|
||||
@@ -828,8 +884,10 @@
|
||||
#(tu/eventually (fn [] (= ["what is 2 + 3? use the calculator" "I'll add them." "2 + 3 is 5."]
|
||||
(chat-messages))))
|
||||
(fn [_]
|
||||
(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)))
|
||||
(testing "the LLM was told about the tools of the page it was on (the calculator), not all of them,
|
||||
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))))))))
|
||||
(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}}
|
||||
@@ -853,7 +911,7 @@
|
||||
{:role "tool" :toolCallId "call_1" :content "{\"x\":2,\"y\":3,\"sum\":5}"}]
|
||||
(mapv #(dissoc % :id) (:messages (second (:chat-requests @tu/server)))))))
|
||||
(testing "and it is over: the panel takes messages again"
|
||||
(is (false? (.-readOnly (q "input[name=message]")))))
|
||||
(is (= :idle (chat-status))))
|
||||
(click! (tool-toggle)))
|
||||
#(tu/eventually (fn [] (= ["Collapse tool use"] (tool-toggle-labels))))
|
||||
(fn [_]
|
||||
@@ -917,7 +975,7 @@
|
||||
(is (= ["hi" "Hel"] (chat-messages)))
|
||||
(is (nil? (q "[role=status]")))
|
||||
(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)))
|
||||
|
||||
(deftest chat-stream-cut-test
|
||||
|
||||
@@ -188,10 +188,6 @@
|
||||
(.then (fn [_]
|
||||
(is (= :ai-setup (page)) "reading changes nothing")
|
||||
(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 [_]
|
||||
(is (= :tic-tac-toe (page)))
|
||||
(rf/dispatch-sync [::events/navigate :ai-setup])
|
||||
@@ -225,9 +221,7 @@
|
||||
(-> (call "whoami" {})
|
||||
(.then (fn [_] (call "set_todo_done" {:todos (mapv #(hash-map :id (tu/todo-uuid %) :done false) (range 1 4))})))
|
||||
(.then (fn [r]
|
||||
(is (false? (:error? r)))
|
||||
(is (= ["todo-1" "todo-2" "todo-3"] (map :title (json (:text r)))))
|
||||
(is (= [false false false] (map :done (json (:text r)))))
|
||||
(is (= {:text "ok" :error? false} r) "nothing left to say: the page shows it, and so will the next state")
|
||||
(is (= [false false false] (map :done (get-in @rf-db/app-db [:todos :items]))))
|
||||
(is (= :todos (page)))
|
||||
;; A bad entry, or an unknown todo, refuses the whole batch before anything changes.
|
||||
@@ -254,9 +248,8 @@
|
||||
(-> (call "whoami" {})
|
||||
(.then (fn [_] (call "create_todo" {:todos [{:title "milk"} {:title "eggs"} {:title "bread"}]})))
|
||||
(.then (fn [r]
|
||||
(is (false? (:error? 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]))))
|
||||
(is (= {:text "ok" :error? false} r))
|
||||
(is (= ["milk" "eggs" "bread"] (map :title (get-in @rf-db/app-db [:todos :items]))) "in the order given")
|
||||
(is (= :todos (page)))
|
||||
(call "get_todo" {:todos [{:id (tu/todo-uuid 3)} {:id (tu/todo-uuid 1)}]})))
|
||||
(.then (fn [r]
|
||||
@@ -272,8 +265,7 @@
|
||||
(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)}]})))
|
||||
(.then (fn [r]
|
||||
(is (false? (:error? r)))
|
||||
(is (= {:deleted [(tu/todo-uuid 1) (tu/todo-uuid 2)]} (json (:text r))) "a repeated id is deleted once")
|
||||
(is (= {:text "ok" :error? false} r) "a repeated id is deleted once, not refused as unknown the second time")
|
||||
(is (= ["bread"] (map :title (get-in @rf-db/app-db [:todos :items]))))
|
||||
(is (= ["bread"] (map :title (:todos @tu/server))))
|
||||
;; 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))
|
||||
(call "create_todo" {:todos [{:title "buy milk"}]})))
|
||||
(.then (fn [r]
|
||||
(is (false? (:error? r)))
|
||||
(is (= [{:id (tu/todo-uuid 2) :title "buy milk" :done false}]
|
||||
(map #(select-keys % [:id :title :done]) (json (:text r)))))
|
||||
(is (= {:text "ok" :error? false} r))
|
||||
;; 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 (= "" (get-in @rf-db/app-db [:todos :new-title])))
|
||||
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]})))
|
||||
(.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])))))
|
||||
;; Already ticked: nothing to do, and no request.
|
||||
(swap! tu/server assoc :todos [])
|
||||
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]})))
|
||||
(.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"}]})))
|
||||
(.then (fn [r]
|
||||
(is (:error? r))
|
||||
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
|
||||
(.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]))))
|
||||
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
|
||||
(.then (fn [r]
|
||||
@@ -408,6 +398,11 @@
|
||||
(is (empty? (get-in @rf-db/app-db [:todos :items])))
|
||||
(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
|
||||
(open-page!)
|
||||
(async done
|
||||
@@ -417,10 +412,13 @@
|
||||
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
|
||||
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
|
||||
(.then (fn [r]
|
||||
;; It pressed the cell, as a user would, and says it is O's turn now.
|
||||
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])))
|
||||
;; It pressed the cell, as a user would; the result says the board it left (see
|
||||
;; 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"}
|
||||
(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"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "cell 4 is taken" :error? true} r))
|
||||
@@ -448,21 +446,74 @@
|
||||
(is (:error? r))
|
||||
(call "move_tic_tac_toe" {:cell 0 :player "o"})))
|
||||
(.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.
|
||||
(rf/dispatch-sync [::events/ttt-move 3])
|
||||
(rf/dispatch-sync [::events/ttt-move 1])
|
||||
(call "move_tic_tac_toe" {:cell 5 :player "x"})))
|
||||
(.then (fn [r]
|
||||
(is (false? (:error? r)))
|
||||
(is (= {:board ["o" "o" nil "x" "x" "x" nil nil nil]
|
||||
:status "won" :winner "x" :line [3 4 5]}
|
||||
(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"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "the game is over: start a new game" :error? true} r))
|
||||
(call "new_tic_tac_toe_game" {})))
|
||||
(.then (fn [r]
|
||||
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
|
||||
(is (= {:text "the game is over: the person starts a new one, with the page's own New game button"
|
||||
:error? true}
|
||||
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))))))
|
||||
|
||||
;; --- Prompts and resources ---
|
||||
@@ -515,19 +566,16 @@
|
||||
|
||||
(deftest every-tool-the-prompts-name-exists
|
||||
(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)]
|
||||
(is (contains? tool-names (str/replace tool-name "{" "")) (str tool-name)))))
|
||||
|
||||
(deftest tic-tac-toe-prompt
|
||||
(webmcp/register-prompts! fake-mcp)
|
||||
(testing "the side is the one asked for, and O by default"
|
||||
(is (re-find #"as X\." (:text (prompt-text "play_tic_tac_toe" {:side "x"}))))
|
||||
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" {:side "o"}))))
|
||||
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" nil))))
|
||||
(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))))))
|
||||
(testing "no side is assigned by the prompt; the tools and state carry the game"
|
||||
(is (= prompt/tic-tac-toe (:text (prompt-text "play_tic_tac_toe" nil))))
|
||||
(is (re-find #"get_tic_tac_toe and move_tic_tac_toe"
|
||||
(:text (prompt-text "play_tic_tac_toe" {:side "x"}))))))
|
||||
|
||||
(deftest registers-the-resources
|
||||
(is (identical? fake-mcp (webmcp/register-resources! fake-mcp)))
|
||||
|
||||
Reference in New Issue
Block a user