Compare commits

..

7 Commits

Author SHA1 Message Date
d884ca4179 simplify comments
CI / Test + coverage (push) Successful in 1m1s
2026-09-23 03:21:23 -09:00
2637b69c2c proomptin'
CI / Test + coverage (push) Successful in 58s
2026-09-22 11:49:16 -09:00
a6f49938dc fiddle
CI / Test + coverage (push) Successful in 1m20s
2026-09-22 10:52:29 -09:00
2d606d0620 get agent to use current state
CI / Test + coverage (push) Successful in 57s
2026-09-22 06:24:04 -09:00
a7f12b5d72 migrate to AG-UI state sync
CI / Test + coverage (push) Successful in 1m4s
2026-09-22 06:07:45 -09:00
6569a69463 Merge pull request 'framework-ify. proper agent runtime + adopt ag-ui' (#1) from ag-ui into main
CI / Test + coverage (push) Successful in 59s
Reviewed-on: #1
2026-09-21 18:57:04 -09:00
a3ef6ec077 framework-ify. proper agent runtime + adopt ag-ui
CI / Test + coverage (pull_request) Successful in 1m41s
2026-09-21 18:34:19 -09:00
39 changed files with 3340 additions and 1678 deletions
+9 -7
View File
@@ -33,11 +33,13 @@ ADMIN_USERS=
# address MCP clients use.
# DB_PATH=data/tbd.db
# --- Chatbot (LM Studio) ------------------------------------------------------
# The chat widget in the UI (the green square, bottom left) talks to an LM Studio server through
# the backend (POST /api/chat, logged-in users only). Point it at your instance: LM Studio's
# --- Agent (LM Studio, via LangChain4j) ---------------------------------------
# The agent (tbd.agent.core, a LangChain4j streaming chat model) talks to an LM Studio server.
# Two surfaces use it: the chat widget in the UI (the green square, bottom left; POST /api/chat, an
# AG-UI run, logged-in users only) and the A2A server for other agents (POST /a2a, the same OAuth
# access token as /mcp; see /.well-known/agent-card.json). Point it at your LM Studio instance:
# server address, no /v1 (start its server, and enable "Serve on Local Network" for a remote one).
# Unset LMSTUDIO_URL = the chatbot answers "not configured".
# Unset LMSTUDIO_URL = both surfaces answer "not configured".
# LMSTUDIO_URL=http://192.168.1.20:1234
# Model id to ask for; empty = whichever model LM Studio has loaded.
# LMSTUDIO_MODEL=
@@ -46,9 +48,9 @@ ADMIN_USERS=
# Seconds the LLM server may stay silent (before it starts answering, or between two pieces of the
# reply) before giving up (default 120).
# LMSTUDIO_TIMEOUT_SECONDS=120
# Every chatbot turn is summarised in the server's log. To also keep the model's full reasoning and
# replies, and the messages it was sent (for finding out why it loops), append a JSON trace to this
# file. It holds what users typed, so keep it private.
# Every turn (chat or A2A) is summarised in the server's log. To also keep the model's full
# reasoning and replies, and the messages it was sent (for finding out why it loops), append a JSON
# trace to this file. It holds what users typed, so keep it private.
# CHAT_TRACE_FILE=data/chat-trace.jsonl
# --- WebMCP origin trial ------------------------------------------------------
+74 -39
View File
@@ -48,7 +48,9 @@ docker run --rm -p 3000:3000 tbd
| `POST` | `/oauth/register` | Dynamic client registration (RFC 7591) for MCP clients |
| `GET`, `POST` | `/oauth/authorize` | Where an MCP client sends the user's browser: Gitea login if needed, then a consent page |
| `POST` | `/oauth/token` | Trades an authorization code (with its PKCE verifier) or a refresh token for tokens |
| `POST` | `/api/chat` | **Login required.** Body `{"messages": [{"role": "user", "content": "hi"}]}` (the conversation so far, 1 to 40 messages of up to 8000 characters, roles `user`, `assistant` or `tool`; and optionally `"page"`, the id of the UI page the user is on (`"tic-tac-toe"`, `"ai-setup"`: a lowercase slug of up to 64 characters), which the LLM is told in a system message, and `"tools"`, the page's tools as MCP describes them: see [the chatbot's tools](#the-chatbots-tools)) sends it to the [chatbot's](#chatbot) LLM and **streams the reply back** as server-sent events (`text/event-stream`): `data: {"thinking":"Let me"}` for each piece of the model's reasoning, `data: {"content":"Hel"}` for each piece of the reply, `data: {"tool-calls":[{"id":"call_1","name":"add","arguments":"{\"x\":1,\"y\":2}"}]}` if the model asks for tools to be called, and last `data: {"done":true}` or `data: {"error":"..."}`. Failures before the reply starts are ordinary errors: 400 for an invalid conversation, 502 if the LLM server can't be reached or refuses, 503 if `LMSTUDIO_URL` isn't set |
| `POST` | `/api/chat` | **Login required.** An [AG-UI](https://docs.ag-ui.com) run: body a `RunAgentInput` (`{"messages": [{"id": "m1", "role": "user", "content": "hi"}], ...}`, the conversation so far, 1 to 40 messages of up to 8000 characters, roles `user`, `assistant` or `tool`; optionally `"tools"`, the page's tools as AG-UI describes them: see [the chatbot's tools](#the-chatbots-tools), and `"context"`, ambient information for the run — the id of the UI page the user is on travels as `{"description": "page", "value": "tic-tac-toe"}`) sends it to the [chatbot's](#chatbot) agent and **streams the reply back** as AG-UI server-sent events (`text/event-stream`): `RUN_STARTED`, then `TEXT_MESSAGE_START`/`TEXT_MESSAGE_CONTENT`/`TEXT_MESSAGE_END` for the reply, `REASONING_MESSAGE_START`/`_CONTENT`/`_END` for the model's reasoning, `TOOL_CALL_START`/`_ARGS`/`_END` if it asks for tools to be called, and last `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 `LMSTUDIO_URL` isn't set |
| `POST` | `/a2a` | The [A2A server](#a2a-server): JSON-RPC 2.0, `message/send` only (no streaming; see below). **Needs an OAuth access token**, the same one an MCP client uses (`401` without one) |
| `GET` | `/.well-known/agent-card.json` | The A2A server's [AgentCard](https://a2a-protocol.org): its name, url, capabilities and skills |
| `GET` | `/api-docs` | Swagger UI |
| `GET` | `/swagger.json` | OpenAPI/Swagger spec |
| `GET` | `/auth/login` | Starts the Gitea OAuth login (redirects to Gitea) |
@@ -171,6 +173,32 @@ the token: it is looked up in `ADMIN_USERS` on every request, so removing someon
effect at once. A Gitea account that is disabled keeps working until its refresh token expires (up to 30
days without use) or its grant is deleted, since Gitea isn't asked again after the login.
## A2A server
The server also speaks [A2A](https://a2a-protocol.org) (Agent2Agent) at `/a2a`, for other agents
(Claude Code, Codex, ...) to call directly, the way `/mcp` lets an MCP client call its tools. It's a
second face of the same agent as the chatbot (`tbd.agent.core`), but not tied to a browser page: an
A2A caller has no page open, so `tbd.agent.a2a` gives it the app's *server-side* tools instead —
todo CRUD and math, the same operations `tbd.mcp.tools` exposes to MCP clients, defined again over
`tbd.todo.service`/`tbd.math.core` directly (this ns doesn't depend on plumcp). Its system prompt
(`tbd.agent.instructions/a2a`) is framed for a caller with no page and no visual feedback, not the
chatbot's in-page persona.
```bash
curl https://tbd.example.com/.well-known/agent-card.json # <BASE_URL>/a2a, its capabilities and skills
curl -H "Authorization: Bearer $TOKEN" -H 'Content-Type: application/json' \
-d '{"jsonrpc":"2.0","id":1,"method":"message/send","params":{"message":{"role":"user","kind":"message","messageId":"m1","parts":[{"kind":"text","text":"list my todos"}]}}}' \
https://tbd.example.com/a2a
```
`$TOKEN` is the same OAuth access token an MCP client gets ([above](#connecting-an-mcp-client)):
`wrap-bearer-auth` verifies a token by looking it up, not by which `resource` it names, so a token
minted for `/mcp` works here too. Only `message/send` is implemented — the AgentCard says so
(`capabilities.streaming: false`) — so a call is synchronous: if the agent asks for a tool, this ns
runs it itself immediately (server-side, no browser to hand it to) and asks the agent again, up to 8
rounds, until it answers in text, which comes back as the JSON-RPC result (an A2A `Message`, role
`"agent"`). Streaming for a browser-driven conversation is what [AG-UI](#chatbot) is for.
## Authentication and the admin API
Login is OAuth2 (authorization-code flow) against a [Gitea](https://about.gitea.com/) instance.
@@ -186,7 +214,7 @@ login, **403** for a logged-in non-admin. With no allowlist, nobody is an admin.
| Variable | Purpose |
|----------|---------|
| `GITEA_URL`, `GITEA_CLIENT_ID`, `GITEA_CLIENT_SECRET` | The Gitea OAuth2 application. Without all three (and `BASE_URL`), `/auth/login` answers 503 |
| `BASE_URL` | Public URL of this app; an `https://` one also marks the session cookie `Secure`. It is also the address of the MCP server: the OAuth issuer, and what MCP clients are told to use (`<BASE_URL>/mcp`) |
| `BASE_URL` | Public URL of this app; an `https://` one also marks the session cookie `Secure`. It is also the address of the MCP and A2A servers: the OAuth issuer, what MCP clients are told to use (`<BASE_URL>/mcp`), and the A2A AgentCard's `url` (`<BASE_URL>/a2a`) |
| `ADMIN_USERS` | Comma-separated Gitea usernames (case-insensitive) allowed to use the admin API |
| `SESSION_SECRET` | Signs and encrypts session cookies. Unset = a random key per start, so logins don't survive a restart |
| `DB_PATH` | The app's SQLite file: todos, and the MCP OAuth server's registered clients, codes and tokens (default `data/tbd.db`). Mount a volume for it in Docker, or todos are lost and every MCP client has to be approved again after each restart |
@@ -245,14 +273,17 @@ in another stage of the same Dockerfile (`--target ui-test`), which the server i
### Chatbot
The green square opens a small chat panel. What you type goes to `POST /api/chat`, and the backend
forwards the conversation to an [LM Studio](https://lmstudio.ai) server (its OpenAI-compatible
`/v1/chat/completions`) and returns the reply. The browser never talks to the LLM directly, so the
server's address (and key) stay on the backend. The reply is streamed: the panel shows "Thinking…" until the
model's first word (a reasoning model can take a while), then the reply appears as it is generated. What
the model reasons is never shown, only that it is thinking; the tool calls (see below) show as small grey
lines between the replies, in full, however long, and the conversation scrolls. The conversation lives in the page only (a reload or logging out clears it), and the UI sends
the last 40 messages of it. Chat needs a login, like the todos: every message costs the LLM server's time.
The green square opens a small chat panel. What you type goes to `POST /api/chat`, an
[AG-UI](https://docs.ag-ui.com) run; the backend's agent (`tbd.agent.core`, a
[LangChain4j](https://docs.langchain4j.dev/) streaming chat model) forwards the conversation to an
[LM Studio](https://lmstudio.ai) server (its OpenAI-compatible `/v1/chat/completions`) and streams
the reply back as AG-UI events. The browser never talks to the LLM directly, so the server's address
(and key) stay on the backend. The panel shows "Thinking…" until the model's first word (a reasoning
model can take a while), then the reply appears as it is generated. What the model reasons is never
shown, only that it is thinking; the tool calls (see below) show as small grey lines between the
replies, in full, however long, and the conversation scrolls. The conversation lives in the page only
(a reload or logging out clears it), and the UI sends the last 40 messages of it. Chat needs a login,
like the todos: every message costs the LLM server's time.
The conversation scrolls. It follows the reply while you are at its end; scroll up to read back and it
stays put until you send a message or scroll down again. Drag the panel's top right corner to make it
@@ -262,35 +293,36 @@ wider or taller (the size is kept while the page is open, through Clear and clos
```bash
curl -N -H "Cookie: $COOKIE" -H 'Content-Type: application/json' \
-d '{"messages":[{"role":"user","content":"hi"}]}' http://localhost:3000/api/chat
-d '{"messages":[{"id":"m1","role":"user","content":"hi"}]}' http://localhost:3000/api/chat
```
#### The chatbot's tools
The chatbot can use the page. The [browser tools](#browser-mcp-tools-webmcp) (the calculator, the todos,
tic-tac-toe) are registered in the page's *model context*, `ui/src/tbd/ui/model_context.cljs`, which is
what WebMCP's `navigator.modelContext` is to an agent outside the page. The chat is that agent, embedded:
what WebMCP's `navigator.modelContext` is to an agent outside the page. The chat is that agent, embedded,
and this is exactly the shape of AG-UI's **frontend tools**: the agent asks, the browser runs them.
1. Each `POST /api/chat` carries `"page"`, the page the user is on, and `"tools"`: the tools' metadata, exactly what an MCP server answers
`tools/list` with (`{"name", "description", "inputSchema"}`, the schema being JSON Schema).
The backend gives it to the LLM as OpenAI-style `tools` (LM Studio's own tool use), and stays stateless.
Only the tools of the page being shown are listed: a tool registered with `:pages #{:calculator}` is
offered on the Calculator page and nowhere else (tic-tac-toe's tools are the Tic-tac-toe page's, the
todos' are the Todos page's), and one with no `:pages` (`ping`, `whoami`, `navigate`) on every page. The
list follows the page the user is on each time the conversation is sent (so does `"page"`, which the
backend puts in the system message ahead of the conversation for the LLM to know where the user is,
with the names of the tools it has),
and a call for a tool the page doesn't offer is refused with an error the LLM reads. The LLM
can move between pages with `navigate`; its next request then carries the new page and that
page's tools. An agent outside the page, through WebMCP, is still offered all of them.
2. The LLM never runs anything. When it wants a tool, it says so: the reply ends with a
`{"tool-calls": [...]}` event (the calls are put together from the pieces the model writes, the
`arguments` being the JSON text it wrote). The backend only relays them.
1. Each `POST /api/chat` carries `"tools"`, the ones the page currently offers, as AG-UI describes them
(`{"name", "description", "parameters"}`, the schema being JSON Schema), and `"context"` naming the
page (`{"description": "page", "value": "tic-tac-toe"}`). The backend converts them to LangChain4j's
typed tool specifications for the LLM, and stays stateless. Only the tools of the page being shown are
listed: a tool registered with `:pages #{:calculator}` is offered on the Calculator page and nowhere
else (tic-tac-toe's tools are the Tic-tac-toe page's, the todos' are the Todos page's), and one with no
`:pages` (`ping`, `whoami`, `navigate`) on every page. The list follows the page the user is on each
time the conversation is sent (so does the page's name, which the backend's agent puts in the system
message ahead of the conversation, with the names of the tools it has), and a call for a tool the page
doesn't offer is refused with an error the LLM reads. The LLM can move between pages with `navigate`;
its next request then carries the new page and that page's tools. An agent outside the page, through
WebMCP, is still offered all of them.
2. The LLM never runs anything. When it wants a tool, it says so: the reply ends with
`TOOL_CALL_START`/`TOOL_CALL_ARGS`/`TOOL_CALL_END` events, one triple per call (`TOOL_CALL_ARGS`'s
`delta` being the JSON text the model wrote). The backend only relays them.
3. The page intercepts them and calls the tools right there (one after the other), through the same
handlers WebMCP uses, so they act on the page as a user would and you see it happen. The chat panel
shows each call and its result in small print between the messages.
4. The results go back as messages with the role `tool` (`{"role": "tool", "tool-call-id": "call_1",
"content": "..."}`, after the assistant message that asked, which carries `"tool-calls"`), in
4. The results go back as messages with the role `tool` (`{"role": "tool", "toolCallId": "call_1",
"content": "..."}`, after the assistant message that asked, which carries `"toolCalls"`), in
another request with the conversation so far, for the LLM to go on from, until it answers with words.
A call that can't be made (a tool that isn't there, arguments that aren't a JSON object, a tool that
@@ -298,21 +330,23 @@ fails) is a result with the reason, for the model to read and try again from. To
stops calling tools from acting on your page for ever, one message of yours gets it at most 12 calls;
then the chat stops, and says so. Results are cut to the 8000 characters the server accepts.
The chatbot is told to be an agent, not a conversationalist: the system message (`tbd.agent.prompt/chat`, in
`shared/tbd/agent/prompt.cljc`, which `default-system-prompt` in `src/tbd/chat/core.clj` is) says that what it
The chatbot is told to be an agent, not a conversationalist: its system prompt
(`tbd.agent.instructions/chat`, in `src/tbd/agent/instructions.clj` — a JVM-only namespace, never on the
UI's classpath, so the chatbot's own instructions are never bundled into the browser) says that what it
does shows on your screen at once, so it should call a tool in the same turn rather than offer to, chain
calls (navigate, list, then act), take obvious defaults instead of asking, and answer in one short
sentence, since the call and its result are already shown. If a model still answers requests with offers,
that prompt (and its four examples, which name tools) is what to tune for it; the tool descriptions in
`webmcp.cljs` are the other lever. The same file gives an MCP client outside the page the same
instructions, [see below](#browser-mcp-tools-webmcp).
sentence, since the call and its result are already shown. It reuses the wording that genuinely is shared
with an outside agent (`act`, `work-it-out`, `tic-tac-toe-rules`, `examples`) from `tbd.agent.prompt` (the
shared `.cljc`, [see below](#browser-mcp-tools-webmcp)) rather than duplicating it. If a model still
answers requests with offers, that's what to tune for it; the tool descriptions in `webmcp.cljs` are the
other lever.
To try it, use a model that supports tool use in LM Studio, log in, and ask the chat something the page
can do: *"add 2 and 3 with the calculator"*, *"add a todo to buy milk"*, *"play tic-tac-toe with me, you're O"*.
A reverse proxy in front of tbd must not buffer responses, or the reply arrives all at once at the end
(the server sends `X-Accel-Buffering: no`, which nginx obeys; for others, turn buffering off for `/api/chat`).
The `thinking` events (the reasoning) also keep the connection from looking idle to a proxy while the model reasons; the UI drops them.
The `REASONING_MESSAGE_CONTENT` events also keep the connection from looking idle to a proxy while the model reasons; the UI drops their text, only using them to show "Thinking…".
Anything that goes wrong is logged on the server's stdout, with a `[tbd] chat:` prefix.
Point the backend at your instance with environment variables (see [.env-template](.env-template)):
@@ -483,11 +517,12 @@ src/tbd/
<group>/schema.clj Malli schemas of the group's input, shared by its routes and the MCP tools
auth/ Gitea OAuth (core), session + admin middleware (middleware), /auth routes
mcp/ MCP server (PluMCP) mounted at `/mcp`: tools (tools.clj), Malli-to-tool glue (schema.clj) and the Ring handler (routes.clj)
oauth/ tbd as the OAuth authorization server for MCP clients: rules (core), SQLite storage (db), `/oauth` + discovery routes, and the bearer-token middleware guarding `/mcp` (middleware)
chat/ The chatbot: request to the LM Studio server, tool calls included (core), the request's Malli schema (schema), `/api/chat` route, per-turn logging and loop detection (trace)
oauth/ tbd as the OAuth authorization server for MCP and A2A clients: rules (core), SQLite storage (db), `/oauth` + discovery routes, and the bearer-token middleware guarding `/mcp` and `/a2a` (middleware)
agent/ The agent: a LangChain4j streaming chat model (core), JSON-Schema translation for tool specs (json_schema), its system prompts (instructions), and the A2A server mounted at `/a2a` (a2a)
chat/ /api/chat: the AG-UI wire protocol (routes), the request's Malli schema (schema), per-turn logging and loop detection (trace) — the agent itself is agent/core.clj
nrepl/ On-demand nREPL server (core) and the admin-only `/nrepl` routes
todo/ Per-user todos: pure rules (core), Malli schemas of the input (schema), SQLite storage (db), `/api/todos` routes
shared/ .cljc read by both the server and the UI (tbd.agent.prompt: the instructions an LLM is given)
shared/ .cljc read by both the server and the UI (tbd.agent.prompt: the instructions an outside agent, through WebMCP, is given — the chatbot's own system prompt is server-only, in src/tbd/agent/instructions.clj)
ui/ ClojureScript re-frame app (shadow-cljs project); ui/src/tbd/ui/{db,events,subs,views,webmcp,model_context,core}.cljs, tests in ui/test/
.env-template Settings the server reads from the environment; copy to .env (git-ignored)
resources/public/ index.html (the shell served at /) and js/ (compiled UI output, git-ignored)
+5 -1
View File
@@ -12,7 +12,11 @@
;; The MCP server, mounted at /mcp (see tbd.mcp.routes). Needs JDK 21+ (virtual threads).
;; plumcp needs exactly one JSON module; jsonista is already on the classpath via muuntaja.
io.github.plumce/plumcp.core {:mvn/version "0.3.0-beta2"}
io.github.plumce/plumcp.core-json-jsonista {:mvn/version "0.3.0-beta2"}}
io.github.plumce/plumcp.core-json-jsonista {:mvn/version "0.3.0-beta2"}
;; The agent (see tbd.agent.core): a LangChain4j streaming chat model talking to LM Studio's
;; OpenAI-compatible server. Plain libraries, no Spring/Quarkus runtime pulled in.
dev.langchain4j/langchain4j {:mvn/version "1.20.0"}
dev.langchain4j/langchain4j-open-ai {:mvn/version "1.20.0"}}
:aliases
{:dev
+48 -75
View File
@@ -1,31 +1,31 @@
(ns tbd.agent.prompt
"What an LLM is told about driving this app through the page's tools (tbd.ui.webmcp): one piece
of prompt engineering, worn by two agents. The page's own chatbot gets it as its system message
(tbd.chat.core, on the server: `chat`); an MCP client outside the page, Claude or Codex,
connected through WebMCP, gets it as the prompts and resources the page registers (tbd.ui.webmcp,
in the browser: `guide`, `task`, `tic-tac-toe`). It is a .cljc so that both read the same text:
tune it here, and both agents follow.
"What an LLM is told about driving this app through the page's tools (tbd.ui.webmcp), for an
MCP client outside the page (Claude, Codex) connected through WebMCP: it gets this as the
prompts and resources the page registers (tbd.ui.webmcp, in the browser: `guide`, `task`,
`tic-tac-toe`). This is a .cljc (compiled into the browser bundle, see ui/shadow-cljs.edn's
`: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`
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.
the models behind LM Studio follow that better than a long list of rules.")
What the two agents share (`act`, `tic-tac-toe-rules`, `examples`) is written once. What differs is
where the agent stands: the chatbot is in the page, and its calls and their results are
displayed under its message; the outside agent is in a terminal or an editor, is offered every
tool at once, and has its own conversation, so it needs a report of what happened."
(:require [clojure.string :as str]))
(def ^:private act
(def act
"Shared with tbd.agent.instructions/chat, the in-page chatbot's own system prompt."
(str "Act, don't offer. When the user asks for something a tool can do, call the tool in this same\n"
"turn. Never say you are about to do something, never ask \"would you like me to\", never ask them\n"
"to confirm what they just asked for.\n"
"\n"))
(defn- work-it-out
(defn work-it-out
"How to get on without asking: `chain` is the bullet about chaining calls, which is where the
two agents differ (the chatbot's tools follow the page it is on, an outside agent has them all)."
two agents differ (the chatbot's tools follow the page it is on, an outside agent has them all).
Shared with tbd.agent.instructions/chat."
[chain]
(str "Work it out yourself:\n"
"- Detail missing: take the obvious default and go. Ask only when a required argument is genuinely\n"
@@ -33,51 +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 ^:private tic-tac-toe-rules
(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 ^:private examples
(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.\""))
;; --- The page's own chatbot ---
(def chat
"The chatbot's instructions, the start of its system message: tbd.chat.core adds where the user
is and the tools it has. Its calls show under its message, so it answers in a sentence and
never repeats them."
(str "You are the assistant built into this web app. Your tools type, click and read on the page the\n"
"user is looking at, and every call shows on their screen the moment you make it.\n"
"\n"
act
(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"))
"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"
"\n"
"Some things are not tool work: greetings, questions about you, questions you can simply answer.\n"
"Answer those in a sentence or two, with no tool call. Asked what you can do, say it plainly from\n"
"the tools you have. Think briefly before you act.\n"
"\n"
tic-tac-toe-rules
examples))
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\""))
;; --- An MCP client outside the page (Claude, Codex) ---
@@ -93,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"
@@ -105,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
@@ -118,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."))
+178
View File
@@ -0,0 +1,178 @@
(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 (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; 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): 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]
[tbd.agent.core :as agent]
[tbd.agent.instructions :as instructions]
[tbd.math.core :as math]
[tbd.math.schema :as math-schema]
[tbd.mcp.schema :refer [coerce!]]
[tbd.oauth.middleware :as oauth-mw]
[tbd.todo.schema :as todo-schema]
[tbd.todo.service :as todo]))
(def ^:private max-turns
"How many rounds of tool calls the agent may make before answering, for one A2A message."
8)
;; --- Tools: the same operations tbd.mcp.tools offers MCP clients, for a caller with no page ---
(defn- ok! [{:keys [ok error]}]
(if error (throw (ex-info error {})) ok))
(defn- ->json [data] (slurp (m/encode "application/json" data)))
(defn- tool [name description schema handler]
{:name name :description description
:inputSchema (json-schema/transform schema)
:handler (fn [args {:keys [user ds]}] (str (handler (coerce! schema args) user ds)))})
(def tools
[(tool "add" "Add two numbers" math-schema/Add
(fn [{:keys [x y]} _ _] (math/add x y)))
(tool "whoami" "Says which user this call acts as, and whether they are an admin" [:map]
(fn [_ {:keys [login id admin?]} _]
(format "%s (Gitea user %d)%s" login id (if admin? ", admin" ""))))
(tool "list_todos" "Lists your todos (JSON: id, title, done, created-at, updated-at), oldest first" [:map]
(fn [_ user ds] (->json (ok! (todo/list-todos ds user)))))
(tool "get_todo" "Gets one of your todos by id (JSON)" todo-schema/IdParam
(fn [{:keys [id]} user ds] (->json (ok! (todo/find-todo ds user id)))))
(tool "create_todo" "Creates a todo for you and returns it (JSON)" todo-schema/NewTodo
(fn [{:keys [title]} user ds] (->json (ok! (todo/create! ds user title)))))
(tool "update_todo" "Changes the title and/or done flag of one of your todos and returns it (JSON)"
todo-schema/UpdateTodo
(fn [{:keys [id] :as input} user ds] (->json (ok! (todo/update! ds user id (dissoc input :id))))))
(tool "delete_todo" "Deletes one of your todos" todo-schema/IdParam
(fn [{:keys [id]} user ds] (ok! (todo/delete! ds user id)) "deleted"))])
(defn- execute-tool [ctx {:keys [name arguments]}]
(if-let [{:keys [handler]} (first (filter #(= name (:name %)) tools))]
(try (handler (m/decode "application/json" (or arguments "{}")) ctx)
(catch Exception e (str "error: " (ex-message e))))
(str "error: no such tool " (pr-str name))))
;; --- Driving the agent, running its own tool loop (no browser here) ---
(defn- collect
"Drains `pump` (see tbd.agent.core/start), returning {:text s} or {:tool-calls [...]} or
{:error s}: exactly one of them, whichever the turn ended with."
[pump]
(let [text (StringBuilder.) result (atom nil)]
(pump (fn [{:keys [content tool-calls done error]}]
(cond
content (.append text ^String content)
tool-calls (reset! result {:tool-calls tool-calls})
error (reset! result {:error error})
done (when-not @result (reset! result {:text (.toString text)})))))
@result))
(defn- run-tools!
"Answers `messages` (tbd.agent.core's internal Message shape), running any tool calls the agent
makes itself, `ctx` ({:user :ds}) being what the tools need. {:text s} or {:error s :kind ...}."
[config ctx messages]
(loop [messages messages turn 0]
(if (>= turn max-turns)
{:error "the agent didn't reach an answer in time" :kind :upstream}
(let [{:keys [ok error kind]} (agent/start config (instructions/a2a) messages tools)]
(if error
{:error error :kind kind}
(let [{:keys [text tool-calls error]} (collect ok)]
(cond
error {:error error :kind :upstream}
(seq tool-calls)
(recur (into (conj (vec messages) {:role "assistant" :content "" :tool-calls tool-calls})
(map (fn [{:keys [id name arguments]}]
{:role "tool" :tool-call-id id
:content (execute-tool ctx {:name name :arguments arguments})}))
tool-calls)
(inc turn))
:else {:text text})))))))
(defn- message-text
"The plain text of an A2A Message's `parts` ([{kind: \"text\" text: \"...\"}, ...]), joined."
[parts]
(->> parts (filter #(= "text" (or (:kind %) (get % "kind")))) (map #(or (:text %) (get % "text"))) (str/join "\n")))
(defn- agent-message
"A reply as an A2A Message: role \"agent\", one TextPart."
[text]
{:role "agent" :parts [{:kind "text" :text text}] :messageId (str (random-uuid)) :kind "message"})
;; --- JSON-RPC over HTTP ---
(defn- json [status body]
{:status status
:headers {"Content-Type" "application/json" "Cache-Control" "no-store"}
:body (m/encode "application/json" body)})
(defn- rpc-result [id result] {:jsonrpc "2.0" :id id :result result})
(defn- rpc-error [id code message] {:jsonrpc "2.0" :id id :error {:code code :message message}})
(def ^:private error-status {:unavailable 503 :upstream 502})
(defn- handle-message-send [config ctx {:keys [message]}]
(let [text (message-text (:parts message))]
(if (str/blank? text)
{:jsonrpc-error [-32602 "message has no text parts"]}
(let [{:keys [text error kind]} (run-tools! config ctx [{:role "user" :content text}])]
(if error
{:error [(get error-status kind 502) error]}
{:result (agent-message text)})))))
(defn- handler [config ds]
(fn [{:keys [user body]}]
(let [{:keys [jsonrpc id method params]} (m/decode "application/json" (slurp body))]
(cond
(not= "2.0" jsonrpc)
(json 200 (rpc-error id -32600 "invalid JSON-RPC request"))
(= "message/send" method)
(let [{:keys [result jsonrpc-error error]} (handle-message-send config {:user user :ds ds} params)]
(cond
result (json 200 (rpc-result id result))
jsonrpc-error (json 200 (apply rpc-error id jsonrpc-error))
:else (let [[status text] error] (json status (rpc-error id -32000 text)))))
:else (json 200 (rpc-error id -32601 (str "method not found: " method)))))))
(defn- agent-card [base-url]
{:name "tbd"
:description "tbd's agent: todo management and simple math, on behalf of the user who authorized this connection."
:url (str base-url "/a2a")
:version "1.0.0"
:protocolVersion "0.3.0"
:preferredTransport "JSONRPC"
:capabilities {:streaming false :pushNotifications false}
:defaultInputModes ["text/plain"]
:defaultOutputModes ["text/plain"]
:securitySchemes {"bearer" {:type "http" :scheme "bearer"
:description "An OAuth access token from this server's own authorization server (see /.well-known/oauth-protected-resource/mcp; the same token works here)."}}
:security [{"bearer" []}]
:skills (mapv (fn [{:keys [name description]}]
{:id name :name name :description description :tags ["tbd"]})
tools)})
(defn routes
"`auth` is the auth config (for `:base-url` and the OAuth check), `ds` a delay of the app's
database, `chat` the agent config (see tbd.agent.core/env-config)."
[auth ds chat]
["" {:no-doc true}
["/.well-known/agent-card.json"
{:middleware ^:replace []
:get {:handler (fn [_req] (json 200 (agent-card (:base-url auth))))}}]
["/a2a"
{:middleware ^:replace []
:post {:handler (-> (handler chat ds) (oauth-mw/wrap-bearer-auth auth ds))}}]])
+340
View File
@@ -0,0 +1,340 @@
(ns tbd.agent.core
"The chatbot's agent: a LangChain4j `StreamingChatModel` talking to the OpenAI-compatible LM
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}.
`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.
`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 (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])
(:import (dev.langchain4j.agent.tool ToolExecutionRequest ToolSpecification)
(dev.langchain4j.data.message AiMessage ChatMessage SystemMessage ToolExecutionResultMessage UserMessage)
(dev.langchain4j.http.client.jdk JdkHttpClientBuilder)
(dev.langchain4j.model.chat StreamingChatModel)
(dev.langchain4j.model.chat.request ChatRequest)
(dev.langchain4j.model.chat.response
ChatResponse CompleteToolCall PartialResponse PartialResponseContext
PartialThinking PartialThinkingContext PartialToolCallContext
StreamingChatResponseHandler StreamingHandle)
(dev.langchain4j.model.openai OpenAiStreamingChatModel)
(java.net.http HttpClient HttpClient$Version)
(java.time Duration)
(java.util.concurrent LinkedBlockingQueue ScheduledFuture ScheduledThreadPoolExecutor ThreadFactory TimeUnit)))
(def default-timeout-seconds 120)
(defn- env-val [env k]
(let [v (get env k)]
(when-not (str/blank? v) (str/trim v))))
;; 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` (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")))
(defn- build-chat-model ^StreamingChatModel [{:keys [url model api-key timeout-seconds]}]
(let [builder (-> (OpenAiStreamingChatModel/builder)
(.httpClientBuilder (jdk-http-client-builder))
(.baseUrl (api-base-url url))
(.apiKey (or api-key "not-needed"))
(.timeout (Duration/ofSeconds timeout-seconds))
;; LM Studio's reasoning models send `reasoning_content`; this is what maps it
;; onto onPartialThinking instead of dropping it.
(.returnThinking true))]
(when model (.modelName builder model))
(.build builder)))
(defn env-config
"Chat config from environment variables:
LMSTUDIO_URL where the LM Studio server is, e.g. http://192.168.1.20:1234 (chat is off without it)
LMSTUDIO_MODEL the model id to ask for (optional: LM Studio uses the model that is loaded)
LMSTUDIO_API_KEY sent as a bearer token, when the server wants one (optional)
LMSTUDIO_TIMEOUT_SECONDS how long the server may stay silent before giving up (default 120)
CHAT_TRACE_FILE a file to append a JSON trace of every turn to, with the model's full reasoning and
replies and the messages it was sent (optional: without it, each turn is only
summarised in the log)"
([] (env-config (System/getenv)))
([env]
(let [config {:url (some-> (env-val env "LMSTUDIO_URL") (str/replace #"/+$" ""))
:model (env-val env "LMSTUDIO_MODEL")
:api-key (env-val env "LMSTUDIO_API_KEY")
:timeout-seconds (or (some-> (env-val env "LMSTUDIO_TIMEOUT_SECONDS") parse-long)
default-timeout-seconds)
:trace (trace/config-for (env-val env "CHAT_TRACE_FILE"))}]
(assoc config :chat-model-delay (delay (build-chat-model config))))))
(defn configured? [{:keys [url]}] (some? url))
(defn- chat-model
"The config's `StreamingChatModel`: `:chat-model` directly, when a caller (a test) gives one, else
the one built from `:url`/`:model`/`:api-key`/`:timeout-seconds`, built once and reused."
^StreamingChatModel [config]
(or (:chat-model config) (force (:chat-model-delay config))))
;; --- Building the request ---
(defn- llm-message
"One message of the conversation (see tbd.chat.schema/Message) as a LangChain4j ChatMessage."
^ChatMessage [{:keys [role content tool-calls tool-call-id]}]
(case role
"user" (UserMessage/from ^String content)
"assistant" (if (seq tool-calls)
(AiMessage/from (str content)
^java.util.List
(mapv (fn [{:keys [id name arguments]}]
(-> (ToolExecutionRequest/builder)
(.id id) (.name name) (.arguments arguments)
.build))
tool-calls))
(AiMessage/from ^String content))
"tool" (ToolExecutionResultMessage/toolExecutionResultMessage
^String tool-call-id "" ^String content)))
(defn- llm-tool
"An MCP tool's metadata as a function the LLM may call."
^ToolSpecification [{:keys [name description inputSchema]}]
(let [builder (-> (ToolSpecification/builder)
(.name name)
(.parameters (json-schema/tool-parameters inputSchema)))]
(when description (.description builder description))
(.build builder)))
(defn- chat-request ^ChatRequest [system-text messages tools]
(let [builder (-> (ChatRequest/builder)
(.messages ^java.util.List (into [(SystemMessage/from ^String system-text)]
(map llm-message) messages)))]
(when (seq tools)
(.toolSpecifications builder ^java.util.List (mapv llm-tool tools)))
(.build builder)))
;; --- Reading the reply ---
(def ^:private watchdog
(delay (doto (ScheduledThreadPoolExecutor.
1 (reify ThreadFactory
(newThread [_ r] (doto (Thread. ^Runnable r "chat-watchdog") (.setDaemon true)))))
(.setRemoveOnCancelPolicy true))))
(defn- exception-detail [^Throwable e]
(str (class e) ": " (.getMessage e)))
(defn- fail
([text] (fail text nil))
([text detail]
(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), {: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
;; params (onPartialResponse/onPartialThinking/onPartialToolCall each have a 1- and a 2-arg
;; overload) confuses Clojure's overload resolution (`NewInstanceMethod.parse`), which throws
;; "Mismatched return type" instead of picking the right one. Arity alone disambiguates fine.
(reify StreamingChatResponseHandler
(onPartialResponse [_ partial ctx]
(capture! (.streamingHandle ^PartialResponseContext ctx))
(.put queue {:content (.text ^PartialResponse partial)})
nil)
(onPartialThinking [_ partial ctx]
(capture! (.streamingHandle ^PartialThinkingContext ctx))
(.put queue {:thinking (.text ^PartialThinking partial)})
nil)
(onPartialToolCall [_ _partial ctx]
(capture! (.streamingHandle ^PartialToolCallContext ctx))
nil)
(onCompleteToolCall [_ complete]
(let [req (.toolExecutionRequest ^CompleteToolCall complete)]
(.put queue {:tool-call {:id (.id req) :name (.name req) :arguments (.arguments req)}}))
nil)
(onCompleteResponse [_ response]
(.put queue {:complete response})
nil)
(onError [_ error]
(.put queue {:error error})
nil))))
(defn- usage-of [^ChatResponse response]
(when-let [usage (.tokenUsage response)]
{:prompt_tokens (.inputTokenCount usage)
:completion_tokens (.outputTokenCount usage)
:total_tokens (.totalTokenCount usage)}))
(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 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 []
(when-let [^StreamingHandle h @handle-atom]
(try (.cancel h) (catch Exception _ nil))))
arm! (fn []
(some-> ^ScheduledFuture @timer (.cancel false))
(reset! timer (.schedule ^ScheduledThreadPoolExecutor @watchdog
^Runnable (fn [] (reset! timed-out? true) (cancel-stream!))
(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
replied? false
calls []]
(cond
(:error item)
(let [^Throwable e (:error item)
text (if @timed-out?
(fail "the LLM server took too long to answer" (str timeout-seconds "s of silence"))
(fail "the LLM server can't be reached or refused" (exception-detail e)))]
(trace/finish! tracer {:outcome :error :error text :detail (exception-detail e)})
(emit {:error text}))
(:complete item)
(let [^ChatResponse response (:complete item)
ai (.aiMessage response)
calls (if (seq calls) calls
(mapv (fn [^ToolExecutionRequest r]
{:id (.id r) :name (.name r) :arguments (.arguments r)})
(.toolExecutionRequests ai)))
;; A provider that never streamed tokens (batched the whole reply) has its text
;; only here, never through :content items above.
batched-text (when (and (not replied?) (empty? calls) (not (str/blank? (.text ai))))
(.text ai))
event {:finish-reason (finish-reason-of response) :usage (usage-of response)}]
(trace/observe! tracer event)
(cond
(seq calls) (do (trace/finish! tracer {:outcome :tool-calls :calls calls})
(emit {:tool-calls calls})
(emit {:done true}))
batched-text (do (trace/finish! tracer {:outcome :done})
(emit {:content batched-text})
(emit {:done true}))
(or replied? (not (str/blank? (.text ai))))
(do (trace/finish! tracer {:outcome :done}) (emit {:done true}))
:else (let [text (fail "the LLM server sent no reply")]
(trace/finish! tracer {:outcome :error :error text})
(emit {:error text}))))
:else
(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)))))))))
(finally
(trace/finish! tracer {:outcome :aborted})
(some-> ^ScheduledFuture @timer (.cancel false))
(cancel-stream!)))))
(defn start
"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)
: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))}))))
+68
View File
@@ -0,0 +1,68 @@
(ns tbd.agent.instructions
"The system prompts of the two agents tbd.agent.core drives: `chat`, for the in-page chatbot
behind /api/chat, and `a2a`, for the A2A server (tbd.agent.a2a) other agents call. Server-only
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`, `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
"The in-page chatbot's system prompt, the start of its system message: tbd.agent.core adds
where the user is and the tools it has. Its calls show under its message, so it answers in a
sentence and never repeats them."
[]
(str "You are the assistant built into this web app. Your tools type, click and read on the page the\n"
"user is looking at, and every call shows on their screen the moment you make it.\n"
"\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. 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"
"\n"
"Some things are not tool work: greetings, questions about you, questions you can simply answer.\n"
"Answer those in a sentence or two, with no tool call. Asked what you can do, say it plainly from\n"
"the tools you have. Think briefly before you act.\n"
"\n"
(prompt/examples false)))
(defn chat-system-message
"`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.")
(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
page, so it has no DOM to act on and no visual feedback to lean on. Its tools are the app's
server-side ones (tbd.mcp.tools, the same the MCP server offers), not a page's."
[]
(str "You are tbd's agent, reachable over the Agent2Agent protocol. You act on behalf of the user\n"
"who authorized the caller, using the tools you were given: todo management and anything else\n"
"this server exposes as a tool. You have no page open and no visual feedback beyond what a tool\n"
"returns.\n"
"\n"
prompt/act
(prompt/work-it-out (str "- You need an id: list first, then act. Never invent an id, a title or the state of the data:\n"
" read it with a tool.\n"))
"Then report in one short plain sentence, from the tool results: \"Added it.\" \"That's 23.\" Don't\n"
"paste JSON, don't describe the tool call itself, just its outcome.\n"
"\n"
(prompt/examples true)))
+80
View File
@@ -0,0 +1,80 @@
(ns tbd.agent.json-schema
"Translates a tool's `inputSchema` (plain JSON Schema, decoded to a Clojure map — see
tbd.chat.schema/Tool) into LangChain4j's typed `JsonSchemaElement` tree, which is what
`ToolSpecification.Builder/parameters` needs (dev.langchain4j.model.chat.request.json). The
browser is the one authoring these schemas (tbd.ui.webmcp), so this only has to cover the shapes
MCP-style tool schemas actually use: object/string/number/integer/boolean/array/enum, nested
arbitrarily. Anything else (a bare `:enum` without a `:type`, an unrecognized `:type`) falls back
to a permissive `JsonRawSchema` dump of the schema as JSON, rather than failing the request."
(:require [clojure.string :as str]
[muuntaja.core :as m])
(:import (dev.langchain4j.model.chat.request.json
JsonArraySchema JsonBooleanSchema JsonEnumSchema JsonIntegerSchema
JsonNumberSchema JsonObjectSchema JsonRawSchema JsonSchemaElement JsonStringSchema)))
(defn- field
"`m`'s value at `k`, trying the keyword first (how muuntaja decodes JSON) then the string, so
this works whether or not something upstream keywordized the nested schema too."
[m k]
(or (get m (keyword k)) (get m (name k))))
(defn- raw
"A schema element that isn't one of the shapes below: dumped as JSON and wrapped in
`JsonRawSchema` rather than dropped, so the LLM still sees it."
[schema]
(JsonRawSchema/from (slurp (m/encode "application/json" schema))))
(declare of)
(defn- object-schema ^JsonObjectSchema [schema]
(let [builder (JsonObjectSchema/builder)]
(doseq [[k v] (field schema :properties)]
(.addProperty builder (name k) (of v)))
(when-let [required (seq (field schema :required))]
(.required builder ^java.util.List (mapv name required)))
(when-let [d (field schema :description)]
(.description builder d))
(.build builder)))
(defn- array-schema ^JsonArraySchema [schema]
(let [builder (JsonArraySchema/builder)]
(when-let [items (field schema :items)]
(.items builder (of items)))
(when-let [d (field schema :description)]
(.description builder d))
(.build builder)))
(defn- enum-schema ^JsonEnumSchema [schema enum-values]
(let [builder (.enumValues (JsonEnumSchema/builder) ^java.util.List (mapv str enum-values))]
(when-let [d (field schema :description)]
(.description builder d))
(.build builder)))
(defmacro ^:private simple-schema [ctor schema]
`(let [builder# (~ctor)]
(when-let [d# (field ~schema :description)]
(.description builder# d#))
(.build builder#)))
(defn of
"`schema` (a JSON Schema map, keys keyword or string) as a `JsonSchemaElement`."
^JsonSchemaElement [schema]
(if-not (map? schema)
(raw schema)
(let [type (some-> (field schema :type) name str/lower-case)
enum-values (field schema :enum)]
(cond
(and (seq enum-values) (or (nil? type) (= "string" type))) (enum-schema schema enum-values)
(= "object" type) (object-schema schema)
(= "array" type) (array-schema schema)
(= "string" type) (simple-schema #(JsonStringSchema/builder) schema)
(= "integer" type) (simple-schema #(JsonIntegerSchema/builder) schema)
(= "number" type) (simple-schema #(JsonNumberSchema/builder) schema)
(= "boolean" type) (simple-schema #(JsonBooleanSchema/builder) schema)
:else (raw schema)))))
(defn tool-parameters
"A tool's MCP-style `inputSchema` (already validated as an object schema, see tbd.chat.schema/Tool)
as the `JsonObjectSchema` a `ToolSpecification` needs."
^JsonObjectSchema [input-schema]
(object-schema input-schema))
-302
View File
@@ -1,302 +0,0 @@
(ns tbd.chat.core
"The chatbot's side of the LLM: a streaming, OpenAI-compatible chat completion request to the LM
Studio server named by the environment. No Ring here; tbd.chat.routes owns that.
`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\"}.
The chatbot lives on the UI's pages and acts on them, so every request starts with a system
message (`default-system-prompt`, then which page the user is on, `page`, and the tools it has).
The tools are the ones the page offers to the chatbot (see tbd.ui.model-context), described as
MCP does in `tools/list`: {:name :description :inputSchema}. The LLM only sees their metadata: it
asks for a call, the browser makes it and sends the result back with the next request, as a
message with the role \"tool\" (see tbd.chat.schema/Message). This ns translates all of that to
and from the OpenAI-style `tools`, `tool_calls` and `tool_call_id` of the LLM server.
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."
(:require [clojure.string :as str]
[muuntaja.core :as m]
[tbd.agent.prompt :as prompt]
[tbd.chat.trace :as trace])
(:import (java.io BufferedReader Closeable IOException InputStream InputStreamReader)
(java.net URI)
(java.net.http HttpClient HttpClient$Version HttpRequest HttpRequest$BodyPublishers HttpResponse$BodyHandlers)
(java.nio.charset StandardCharsets)
(java.time Duration)
(java.util.concurrent ScheduledFuture ScheduledThreadPoolExecutor ThreadFactory TimeUnit)))
(def default-timeout-seconds 120)
;; HTTP/1.1 on purpose: 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.
(def ^:private http-client
(delay (-> (HttpClient/newBuilder)
(.version HttpClient$Version/HTTP_1_1)
(.connectTimeout (Duration/ofSeconds 5))
.build)))
(defn java-http
"Default `:http` fn: {:url, :headers, :body, :timeout-seconds} is POSTed, giving {:status, :body}
as soon as the response starts; :body is an InputStream of the rest, which the caller closes.
Configs can swap it out, which is how the tests stub the LLM server. It throws when the server
can't be reached or doesn't start answering in time."
[{:keys [url headers body timeout-seconds]}]
(let [builder (-> (HttpRequest/newBuilder (URI/create url))
(.timeout (Duration/ofSeconds timeout-seconds))
(.POST (HttpRequest$BodyPublishers/ofString body)))]
(doseq [[k v] headers] (.header builder k v))
(let [resp (.send ^HttpClient @http-client (.build builder) (HttpResponse$BodyHandlers/ofInputStream))]
{:status (.statusCode resp) :body (.body resp)})))
(defn- env-val [env k]
(let [v (get env k)]
(when-not (str/blank? v) (str/trim v))))
(defn env-config
"Chat config from environment variables:
LMSTUDIO_URL where the LM Studio server is, e.g. http://192.168.1.20:1234 (chat is off without it)
LMSTUDIO_MODEL the model id to ask for (optional: LM Studio uses the model that is loaded)
LMSTUDIO_API_KEY sent as a bearer token, when the server wants one (optional)
LMSTUDIO_TIMEOUT_SECONDS how long the server may stay silent before giving up (default 120)
CHAT_TRACE_FILE a file to append a JSON trace of every turn to, with the model's full reasoning and
replies and the messages it was sent (optional: without it, each turn is only
summarised in the log)"
([] (env-config (System/getenv)))
([env]
{:url (some-> (env-val env "LMSTUDIO_URL") (str/replace #"/+$" ""))
:model (env-val env "LMSTUDIO_MODEL")
:api-key (env-val env "LMSTUDIO_API_KEY")
:timeout-seconds (or (some-> (env-val env "LMSTUDIO_TIMEOUT_SECONDS") parse-long)
default-timeout-seconds)
:trace (trace/config-for (env-val env "CHAT_TRACE_FILE"))
:http java-http}))
(defn configured? [{:keys [url]}]
(some? url))
(defn- fail
"Logs a failure and returns the error text for the client. `text` says nothing about the LLM
server's address or its own message; `detail` (for the log only) does, and is where to look when
chat doesn't work."
([text] (fail text nil))
([text detail]
(println (cond-> (str "[tbd] chat: " text) detail (str " (" detail ")")))
text))
(defn- exception-detail [^Exception e]
(str (class e) ": " (.getMessage e)))
(defn- llm-message
"A message of the conversation (see tbd.chat.schema/Message) as the LLM server has it."
[{:keys [role content tool-calls tool-call-id]}]
(case role
"assistant" (cond-> {:role role :content content}
(seq tool-calls) (assoc :tool_calls
(mapv (fn [{:keys [id name arguments]}]
{:id id :type "function"
:function {:name name :arguments arguments}})
tool-calls)))
"tool" {:role role :tool_call_id tool-call-id :content content}
{:role role :content content}))
(defn- llm-tool
"An MCP tool's metadata as a function the LLM may call."
[{:keys [name description inputSchema]}]
{:type "function"
:function (cond-> {:name name :parameters inputSchema}
description (assoc :description description))})
(def default-system-prompt
"What the LLM is told about its job: an agent embedded in a UI, not a conversationalist. The text
is tbd.agent.prompt/chat, shared with the prompts the page offers to an MCP client outside it
(Claude, Codex, through WebMCP), so that tuning it tunes both."
prompt/chat)
(defn- system-message
"Everything the LLM is told before the conversation, as one message: the instructions
(`default-system-prompt`), then, 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]
{:role "system"
:content (cond-> default-system-prompt
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."))})
(defn- request [{:keys [model api-key timeout-seconds] :as config} messages tools page]
{:url (str (:url config) "/v1/chat/completions")
:headers (cond-> {"Content-Type" "application/json"}
api-key (assoc "Authorization" (str "Bearer " api-key)))
:body (slurp (m/encode "application/json"
(cond-> {:messages (into [(system-message page tools)] (map llm-message) messages)
:stream true}
model (assoc :model model)
(seq tools) (assoc :tools (mapv llm-tool tools)))))
:timeout-seconds timeout-seconds})
;; --- Reading the reply ---
(def ^:private watchdog
(delay (doto (ScheduledThreadPoolExecutor.
1 (reify ThreadFactory
(newThread [_ r] (doto (Thread. ^Runnable r "chat-watchdog") (.setDaemon true)))))
(.setRemoveOnCancelPolicy true))))
(defn- call-deltas
"The pieces of tool calls in a delta: the model writes a call bit by bit, over many events. The
first piece of a call has its id and the tool's name, the rest the JSON of its arguments; `index`
says which call (of the several a reply may ask for) a piece belongs to."
[delta]
(when (sequential? (:tool_calls delta))
(for [{:keys [index id function]} (:tool_calls delta)]
{:index (or index 0) :id id :name (:name function) :arguments (:arguments function)})))
(defn- event-of
"What one line of the LLM's event stream says: a map with :content s and/or :thinking s (a piece
of the reasoning: kept as it is, blanks too, since a piece can be just the line break between two
paragraphs), and :call-deltas (see call-deltas) if there are any; {:error text :detail text}; or
:end (`data: [DONE]`). nil for a line that says nothing: blank, a comment, or an event without
text. A map may also have :finish-reason (why the model stopped: \"stop\", \"tool_calls\",
\"length\" for a reply that ran out of tokens) and :usage ({:prompt_tokens :completion_tokens
:total_tokens}, when the server counts): they are for the trace, not the client."
[line]
(when-let [data (some-> (re-matches #"data:\s?(.*)" line) second str/trim)]
(if (= "[DONE]" data)
:end
(let [event (try (m/decode "application/json" data) (catch Exception _ nil))
delta (get-in event [:choices 0 :delta])
text? (not (str/blank? (:content delta)))
thinking (:reasoning_content delta)
finish-reason (get-in event [:choices 0 :finish_reason])
usage (:usage event)]
(if (:error event)
{:error "the LLM server reported an error" :detail (pr-str (:error event))}
(not-empty
(cond-> {}
text? (assoc :content (:content delta))
(and (string? thinking) (seq thinking)) (assoc :thinking thinking)
(seq (call-deltas delta)) (assoc :call-deltas (vec (call-deltas delta)))
(string? finish-reason) (assoc :finish-reason finish-reason)
(map? usage) (assoc :usage (select-keys usage [:prompt_tokens :completion_tokens :total_tokens])))))))))
(defn- add-deltas
"`calls` ({index {:id :name :arguments}}, in order) with the pieces of calls in `deltas`."
[calls deltas]
(reduce (fn [calls {:keys [index id arguments] :as delta}]
(update calls index
(fn [call]
(cond-> (or call {:arguments ""})
id (assoc :id id)
(:name delta) (assoc :name (:name delta))
arguments (update :arguments str arguments)))))
calls
deltas))
(defn- finished-calls
"The calls the model asked for, as {:id :name :arguments}. A call that never got a tool's name
is no call."
[calls]
(vec (for [[index {:keys [id arguments] :as call}] calls
:when (not (str/blank? (:name call)))]
{:id (or id (str "call_" index)) :name (:name call) :arguments arguments})))
(defn- pump
"Reads the LLM's event stream `in`, calling `emit` with each event (see the ns docstring), and
closes `in`. More than `timeout-seconds` of silence from the LLM is an error. An exception from
`emit` (the client went away, say) ends it too, and is thrown to the caller. `tracer` (see
tbd.chat.trace) sees everything the LLM says, and how the turn ended, before the client is told."
[^InputStream in timeout-seconds emit tracer]
(let [timer (atom nil)
timed-out? (atom false)
arm! (fn []
(some-> ^ScheduledFuture @timer (.cancel false))
(reset! timer (.schedule ^ScheduledThreadPoolExecutor @watchdog
^Runnable (fn []
(reset! timed-out? true)
(try (.close in) (catch IOException _ nil)))
(long timeout-seconds) TimeUnit/SECONDS)))]
(arm!)
(try
(with-open [reader (BufferedReader. (InputStreamReader. in StandardCharsets/UTF_8))]
(loop [replied? false
calls (sorted-map)]
(let [line (try (.readLine reader)
(catch IOException e
(if @timed-out?
{:error "the LLM server took too long to answer"
:detail (str timeout-seconds "s of silence")}
{:error "the LLM server's reply was cut off" :detail (exception-detail e)})))
event (cond (map? line) line ; the read failed
(nil? line) :end ; the stream ended without [DONE]
:else (event-of line))]
(cond
(nil? event) (do (arm!) (recur replied? calls))
(= :end event) (let [calls (finished-calls calls)]
(cond
(seq calls) (do (trace/finish! tracer {:outcome :tool-calls :calls calls})
(emit {:tool-calls calls})
(emit {:done true}))
replied? (do (trace/finish! tracer {:outcome :done})
(emit {:done true}))
:else (let [text (fail "the LLM server sent no reply")]
(trace/finish! tracer {:outcome :error :error text})
(emit {:error text}))))
(:error event) (let [text (fail (:error event) (:detail event))]
(trace/finish! tracer {:outcome :error :error text :detail (:detail event)})
(emit {:error text}))
:else (do (arm!)
(trace/observe! tracer event)
(when-let [out (not-empty (select-keys event [:content :thinking]))] (emit out))
(recur (or replied? (contains? event :content))
(add-deltas calls (:call-deltas event))))))))
(finally
;; Only does anything if the turn ended some other way than the ones above: `emit` threw
;; (the client went away), or something else did.
(trace/finish! tracer {:outcome :aborted})
(some-> ^ScheduledFuture @timer (.cancel false))
(try (.close in) (catch IOException _ nil))))))
(defn start
"Sends the LLM the conversation `messages` (see tbd.chat.schema/Message), and the `tools` it may
ask the page to call (MCP's {:name :description :inputSchema}; none if nil). `page`, if there is
one, is the page of the UI the user is on: the LLM is told so, and which tools it has, in the
system message that goes ahead of the conversation. Gives {:error text
:kind :unavailable|:upstream} when chat isn't configured, or the LLM server can't be reached or
refuses; nothing is streamed then. 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."
([config messages] (start config messages nil nil))
([config messages tools] (start config messages tools nil))
([{:keys [timeout-seconds http trace] :as config} messages tools page]
(if-not (configured? config)
{:error "chat is not configured" :kind :unavailable}
(let [tracer (trace/begin! trace {:messages messages :tools tools :page page :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 [{:keys [status body]} (http (request config messages tools page))]
(if (= 200 status)
{:ok (fn [emit] (pump body timeout-seconds emit tracer))}
(let [snippet (try (String. (.readNBytes ^InputStream body 200) StandardCharsets/UTF_8)
(catch Exception _ nil))]
(some-> ^Closeable body .close)
(upstream-error (str "the LLM server answered HTTP " status) (str "body: " snippet)))))
(catch java.net.http.HttpTimeoutException e
(upstream-error "the LLM server took too long to answer" (.getMessage e)))
(catch IOException e
(upstream-error "the LLM server can't be reached" (exception-detail e)))
(catch Exception e
(upstream-error "the LLM server sent an unreadable reply" (exception-detail e))))))))
+51
View File
@@ -0,0 +1,51 @@
(ns tbd.chat.db
"SQLite persistence for the chat widget's history, in the app's database (see tbd.sqlite). Not
the AG-UI run itself (tbd.chat.routes' /api/chat stays stateless) — this is the browser's own
conversation (tbd.ui.db's :chat :messages), saved so a reload or a new browser can pick it back
up. One row per user: the whole conversation is kept as one EDN blob and replaced wholesale on
each save, the same way the browser already treats it as a single vector, never a diff."
(:require [clojure.edn :as edn]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]
[tbd.sqlite :as sqlite]))
(def ^:private create-chat-history
;; `owner_id` is the user's id in Gitea, like tbd.todo.db's todos.
"CREATE TABLE IF NOT EXISTS chat_history (
owner_id INTEGER PRIMARY KEY,
messages TEXT NOT NULL,
updated_at INTEGER NOT NULL)")
(defn migrate!
"Creates the chat_history table in the database `ds`, or brings it up to date."
[ds]
(jdbc/execute! ds [create-chat-history]))
(defn open
"A database with just the chat_history table, at `path`; the app opens one with every group's
tables (see tbd.core), which this is for tests of the group on its own."
[path]
(sqlite/open path migrate!))
(def ^:private opts {:builder-fn rs/as-unqualified-kebab-maps})
(defn get-history
"The owner's stored conversation (tbd.chat.schema/HistoryMessage maps), oldest first, or [] if
nothing is stored for them yet."
[ds owner-id]
(if-let [{:keys [messages]} (jdbc/execute-one!
ds ["SELECT messages FROM chat_history WHERE owner_id = ?" owner-id] opts)]
(edn/read-string messages)
[]))
(defn save-history!
"Replaces the owner's stored conversation with `messages`."
[ds owner-id messages now]
(jdbc/execute! ds ["INSERT INTO chat_history (owner_id, messages, updated_at) VALUES (?, ?, ?)
ON CONFLICT (owner_id) DO UPDATE SET messages = excluded.messages, updated_at = excluded.updated_at"
owner-id (pr-str messages) now]))
(defn clear-history!
"Deletes the owner's stored conversation, if any."
[ds owner-id]
(jdbc/execute! ds ["DELETE FROM chat_history WHERE owner_id = ?" owner-id]))
+132 -24
View File
@@ -1,7 +1,15 @@
(ns tbd.chat.routes
"/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.chat.core :as chat]
[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)
@@ -10,28 +18,102 @@
(def ^:private error-status {:unavailable 503 :upstream 502})
(defn- sse-event
"One server-sent event: its data is `event` as JSON, on a single line."
"One server-sent event: `event` (an AG-UI BaseEvent, a plain map with a `:type`) as JSON, on a
single line."
^bytes [event]
(.getBytes (str "data: " (slurp (m/encode "application/json" event)) "\n\n") StandardCharsets/UTF_8))
;; --- Internal pump events -> AG-UI events ---
(defn- open-reasoning [{:keys [reasoning-id] :as state}]
(if (:reasoning-open? state)
[state []]
[(assoc state :reasoning-open? true)
[{:type "REASONING_START" :messageId reasoning-id}
{:type "REASONING_MESSAGE_START" :messageId reasoning-id :role "reasoning"}]]))
(defn- close-reasoning [{:keys [reasoning-id] :as state}]
(if-not (:reasoning-open? state)
[state []]
[(assoc state :reasoning-open? false)
[{:type "REASONING_MESSAGE_END" :messageId reasoning-id}
{:type "REASONING_END" :messageId reasoning-id}]]))
(defn- open-text [{:keys [text-id] :as state}]
(if (:text-open? state)
[state []]
[(assoc state :text-open? true)
[{:type "TEXT_MESSAGE_START" :messageId text-id :role "assistant"}]]))
(defn- close-text [{:keys [text-id] :as state}]
(if-not (:text-open? state)
[state []]
[(assoc state :text-open? false)
[{:type "TEXT_MESSAGE_END" :messageId text-id}]]))
(defn- close-all [state]
(let [[state text-events] (close-text state)
[state reasoning-events] (close-reasoning state)]
[state (into text-events reasoning-events)]))
(defn- tool-call-events [{:keys [id name arguments]}]
[{:type "TOOL_CALL_START" :toolCallId id :toolCallName name}
{:type "TOOL_CALL_ARGS" :toolCallId id :delta (str arguments)}
{:type "TOOL_CALL_END" :toolCallId id}])
(defn- ag-ui-events
"[state' events]: `state` ({:reasoning-id :text-id :reasoning-open? :text-open?}) and the AG-UI
events `event` (tbd.agent.core's internal shape) translates to, opening/closing the
reasoning/text message streams as the model switches between them."
[state {:keys [thinking content tool-calls done error]} thread-id run-id]
(cond
thinking (let [[state closed] (close-text state)
[state opened] (open-reasoning state)]
[state (conj (into closed opened)
{:type "REASONING_MESSAGE_CONTENT" :messageId (:reasoning-id state) :delta thinking})])
content (let [[state closed] (close-reasoning state)
[state opened] (open-text state)]
[state (conj (into closed opened)
{:type "TEXT_MESSAGE_CONTENT" :messageId (:text-id state) :delta content})])
tool-calls (let [[state closing] (close-all state)]
[state (into closing (mapcat tool-call-events) tool-calls)])
done (let [[state closing] (close-all state)]
[state (conj closing {:type "RUN_FINISHED" :threadId thread-id :runId run-id})])
error (let [[state closing] (close-all state)]
[state (conj closing {:type "RUN_ERROR" :message error})])
:else [state []]))
(defn- event-stream
"A response body that writes what `pump` (see tbd.chat.core/start) forwards, one server-sent
event each, flushing after every one so they arrive as they are generated. A browser that goes
away stops it, and the LLM's request with it."
[pump]
"A response body that writes what `pump` (see tbd.agent.core/start) forwards, translated to AG-UI
events, flushing after every one so they arrive as they are generated. A browser that goes away
stops it, and the LLM's request with it."
[pump thread-id run-id]
(reify ring-protocols/StreamableResponseBody
(write-body-to-stream [_ _ out]
(try
(pump (fn [event]
(.write ^OutputStream out (sse-event event))
(.flush ^OutputStream out)))
(catch IOException _ nil)))))
(let [state (atom {:reasoning-id (str (random-uuid)) :text-id (str (random-uuid))
:reasoning-open? false :text-open? false})
write! (fn [event] (.write ^OutputStream out (sse-event event)) (.flush ^OutputStream out))]
(try
(write! {:type "RUN_STARTED" :threadId thread-id :runId run-id})
(pump (fn [internal-event]
(let [[state' events] (ag-ui-events @state internal-event thread-id run-id)]
(reset! state state')
(run! write! events))))
(catch IOException _ nil))))))
(defn- chat-handler [config]
(fn [{{{:keys [messages tools page]} :body} :parameters}]
;; The LLM is asked before the response starts, so an LLM that is down is still a 502, not an
;; error inside a stream that has already begun.
(let [{:keys [ok error kind]} (chat/start config messages tools page)]
(fn [{{{:keys [messages tools threadId runId] :as input} :body} :parameters}]
(let [thread-id (or threadId (str (random-uuid)))
run-id (or runId (str (random-uuid)))
system-text (schema/system-text input)
internal-messages (mapv schema/->internal-message messages)
internal-tools (mapv schema/->internal-tool tools)
{:keys [ok error kind]} (agent/start config system-text internal-messages internal-tools)]
(if error
(respond (error-status kind) {:error error})
{:status 200
@@ -39,15 +121,41 @@
"Cache-Control" "no-cache"
;; nginx would otherwise hold the events back until the reply is over
"X-Accel-Buffering" "no"}
:body (event-stream ok)}))))
: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 chat config (see tbd.chat.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
:summary "Send a conversation to the LLM (LM Studio); the reply streams back as server-sent events: data: {\"thinking\":\"...\"} for each piece of its reasoning, data: {\"content\":\"...\"} for each piece of the reply, data: {\"tool-calls\":[{\"id\":\"...\",\"name\":\"...\",\"arguments\":\"{...}\"}]} if the model asks for tools of the page (the `tools` in the body, as MCP describes them) to be called, and last data: {\"done\":true} or data: {\"error\":\"...\"}"
:parameters {:body schema/Chat}
:handler (chat-handler config)}}])
{: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)}}]
["/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)}}]]])
+149 -30
View File
@@ -1,11 +1,15 @@
(ns tbd.chat.schema
"The shape of the chat request, as Malli schemas, coerced by tbd.chat.routes. The limits are
what keeps the endpoint from being a free pipe to the LLM: a conversation is bounded in
length, and the UI (tbd.ui.events) sends no more than `max-messages` of it.
"The shape of /api/chat's request, as Malli schemas, coerced by tbd.chat.routes: an AG-UI
RunAgentInput (https://docs.ag-ui.com), the standard wire format for an agent↔frontend run. The
limits are what keeps the endpoint from being a free pipe to the LLM: a conversation is bounded
in length, and the UI (tbd.ui.events) sends no more than `max-messages` of it.
The conversation can hold the model's use of the page's tools (see tbd.ui.model-context): an
assistant message that asks for calls (`:tool-calls`), followed by one \"tool\" message with the
result of each. Those are the browser's to say, so they are as bounded as the rest.")
assistant message that asks for calls (`:toolCalls`), followed by one \"tool\" role message with
the result of each. Those are the browser's to say, so they are as bounded as the rest. Which
page the user is on travels as a `context` entry ({:description \"page\" :value \"todos\"}) rather
than a dedicated field — AG-UI's place for ambient, non-conversation information."
(:require [tbd.agent.instructions :as instructions]))
(def max-messages 40)
(def max-message-length 8000)
@@ -20,30 +24,114 @@
(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
"What the page says about one of its tools, as MCP's `tools/list` does. `inputSchema` is JSON Schema
for the arguments, which is the LLM's to read, so it is any (small) object schema."
"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."
[:and
[:map
[:name [:re #"^[a-zA-Z0-9_-]{1,64}$"]]
[:description {:optional true} [:string {:max 2000}]]
;; A map-of, not a :map with a :type: the coercion strips the keys a :map doesn't name, and
;; these are all the LLM's to read (`properties`, `required`, ...).
[:inputSchema [:and [:map-of :keyword :any] [:fn (fn [schema] (= "object" (:type schema)))]]]]
[:parameters {:optional true} [:map-of :keyword :any]]]
[:fn small?]])
(def ^:private Id [:string {:min 1 :max 200}])
(def ToolCall
"A call the model asked for. Its name and arguments are the model's own words: nothing says they
are a tool of the page, or JSON, so they are only bounded, generously (a conversation that the
server refused would be stuck: the UI sends it again with the next message)."
(def FunctionCall
[:map
[:id Id]
[:name [:string {:min 1 :max 200}]]
[:arguments [:string {:max 100000}]]])
(def ToolCall
"AG-UI's ToolCall: a call the model asked for. Its name and arguments are the model's own
words: nothing says they are a tool of the page, or JSON, so they are only bounded, generously
(a conversation that the server refused would be stuck: the UI sends it again with the next
message)."
[:map
[:id Id]
[:type [:= "function"]]
[:function FunctionCall]])
(def Message
"AG-UI's Message, narrowed to the roles this endpoint accepts from a caller: user, assistant
(optionally with `toolCalls`) and tool (answering one). `id` identifies the message within the
conversation (AG-UI requires it); this endpoint doesn't need it to be unique or stable, only
present."
[:multi {:dispatch :role}
["user" [:map
[:id Id]
[:role [:= "user"]]
[:content [:string {:min 1 :max max-message-length}]]]]
["assistant" [:and
[:map
[:id Id]
[:role [:= "assistant"]]
[:content {:optional true} [:string {:max max-message-length}]]
[:toolCalls {:optional true} [:vector {:max max-tool-calls} ToolCall]]]
[:fn (fn [{:keys [content toolCalls]}] (or (seq content) (seq toolCalls)))]]]
["tool" [:map
[:id Id]
[:role [:= "tool"]]
[:toolCallId Id]
[:content [:string {:min 1 :max max-message-length}]]]]])
(def Context
"AG-UI's Context: a named piece of ambient information for the run. The page the user is on is
sent as {:description \"page\" :value \"<page id>\"}."
[:map
[:description [:string {:max 200}]]
[:value [:string {:max 2000}]]])
(def RunAgentInput
"AG-UI's RunAgentInput: the conversation so far, oldest first (`messages`), the tools on offer
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."
[:map
[:threadId {:optional true} [:string {:max 200}]]
[: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]]
[: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"]]
@@ -51,24 +139,55 @@
["assistant" [:and
[:map
[:role [:= "assistant"]]
[:content [:string {:max max-message-length}]]
[:tool-calls {:optional true} [:vector {:max max-tool-calls} ToolCall]]]
[: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]
[:content [:string {:min 1 :max max-message-length}]]]]])
[:name {:optional true} [:string {:max 200}]]
[:content [:string {:min 1 :max max-history-content-length}]]
[:error? {:optional true} :boolean]]]])
(def Page
"Which page of the UI the user is on: its id, as the UI has it (\"tic-tac-toe\", \"ai-setup\"). The server
doesn't know the pages, but the LLM is told it, so it is a short slug and nothing that reads as
an instruction."
[:re #"^[a-z0-9-]{1,64}$"])
(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?]])
(def Chat
"The conversation so far, oldest first; the LLM's reply follows the last message. `page` is the
page the user is on, and `tools` the ones that page offers to the LLM, for this reply."
[:map
[:messages [:vector {:min 1 :max max-messages} Message]]
[:page {:optional true} Page]
[:tools {:optional true} [:vector {:max max-tools} Tool]]])
(defn page-of
"The `page` context entry's value, or nil."
[context]
(some #(when (= "page" (:description %)) (:value %)) context))
(defn ->internal-tool
"An AG-UI Tool as the MCP-style {:name :description :inputSchema} tbd.agent.core and
tbd.agent.json-schema expect."
[{:keys [name description parameters]}]
(cond-> {:name name :inputSchema (or parameters {})}
description (assoc :description description)))
(defn ->internal-message
"An AG-UI Message as tbd.agent.core's internal {:role :content :tool-calls :tool-call-id} (see
tbd.agent.core/llm-message)."
[{:keys [role content toolCalls toolCallId]}]
(cond-> {:role role :content content}
(seq toolCalls) (assoc :tool-calls
(mapv (fn [{:keys [id function]}]
{:id id :name (:name function) :arguments (:arguments function)})
toolCalls))
toolCallId (assoc :tool-call-id toolCallId)))
(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`), `tools` and `state` shape it."
[{:keys [tools context state]}]
(instructions/chat-system-message (page-of context) tools state))
+50 -36
View File
@@ -1,29 +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.chat.core calls 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 is one turn of the model. The loop that runs 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.chat.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])
@@ -46,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)
@@ -133,7 +137,8 @@
long? (conj {:kind :long-reasoning :chars chars :elapsed-ms (- now (:t0 state))}))]))
(defn- advance
"[state' alerts]: `state` after one event of the LLM's reply (tbd.chat.core/event-of's map)."
"[state' alerts]: `state` after one event of the LLM's reply (the map tbd.agent.core/observe! is
called with: any of :content, :thinking, :finish-reason, :usage)."
[state {:keys [content thinking call-deltas finish-reason usage]} now full?]
(let [state (cond-> (-> state
(update :events inc)
@@ -159,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) "="
@@ -216,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?
@@ -231,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.chat.core/event-of: any of :content, :thinking,
:call-deltas, :finish-reason, :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)
+12 -11
View File
@@ -14,10 +14,12 @@
[reitit.ring.middleware.parameters :as parameters]
[muuntaja.core :as m]
[ring.util.response :as response]
[tbd.agent.a2a :as a2a]
[tbd.agent.core :as agent]
[tbd.auth.core :as auth]
[tbd.auth.middleware :as auth-mw]
[tbd.auth.routes :as auth-routes]
[tbd.chat.core :as chat]
[tbd.chat.db :as chat-db]
[tbd.chat.routes :as chat-routes]
[tbd.health.routes :as health]
[tbd.http :as http]
@@ -73,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).
@@ -86,19 +88,18 @@
(health/routes)
(math/routes)
(mcp-routes/routes auth ds)
(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)
@@ -123,7 +124,7 @@
(def config
{:auth (auth/env-config)
:nrepl (nrepl/env-config)
:chat (chat/env-config)
:chat (agent/env-config)
:db (sqlite/env-config)
:webmcp {:origin-trial-token (some-> (System/getenv "WEBMCP_ORIGIN_TRIAL_TOKEN") str/trim not-empty)}})
@@ -144,7 +145,7 @@
(println "[tbd] WARNING: ADMIN_USERS is empty; nobody can use the admin API"))
(when-not (get-in config [:auth :session-secret])
(println "[tbd] WARNING: SESSION_SECRET is not set; logins won't survive a restart"))
(when-not (chat/configured? (:chat config))
(when-not (agent/configured? (:chat config))
(println "[tbd] LMSTUDIO_URL is not set; the chatbot is unavailable"))
(when-let [file (get-in config [:chat :trace :file])]
(println (str "[tbd] chat: tracing every turn, reasoning and replies included, to " file)))
+94
View File
@@ -0,0 +1,94 @@
(ns tbd.agent.a2a-test
(:require [clojure.test :refer [deftest is testing]]
[muuntaja.core :as m]
[tbd.agent.test-support :as ts]
[tbd.auth.routes-test :as t]
[tbd.oauth.core :as oauth]
[tbd.oauth.db :as db]
[tbd.sqlite-test :as sqlite-test])
(:import (java.io ByteArrayInputStream)))
;; A2A sits behind its own transport, like /mcp, so these go through the real app (tbd.core) and
;; speak JSON-RPC to /a2a the way an A2A client does, with an OAuth access token.
(defn- mint-token!
[path login id]
(let [token (oauth/random-token)
expires-at (+ (System/currentTimeMillis) 60000)]
(db/insert-grant! (db/open path) {:client-id "test-client" :user-id id :login login :scope "mcp"
:access-hash (oauth/hash-token token) :access-expires-at expires-at
:refresh-hash (oauth/hash-token (oauth/random-token))
:refresh-expires-at expires-at :created-at 1})
token))
(defn- rpc [app token message]
(let [body (slurp (m/encode "application/json" message))
resp (app {:request-method :post :uri "/a2a"
:headers (cond-> {"content-type" "application/json"}
token (assoc "authorization" (str "Bearer " token)))
:body (ByteArrayInputStream. (.getBytes ^String body))})]
(update resp :body #(when % (m/decode "application/json" %)))))
(defn- app-with [chat & {:keys [db-path] :or {db-path (sqlite-test/temp-db-path)}}]
[(t/make-app (t/gitea-stub "alice") :chat chat :db {:db-path db-path}) db-path])
(defn- send-message [text]
{:jsonrpc "2.0" :id 1 :method "message/send"
:params {:message {:role "user" :parts [{:kind "text" :text text}] :messageId "m1" :kind "message"}}})
(deftest agent-card-test
(let [[app] (app-with (ts/config (ts/text-model "hi")))
resp (app {:request-method :get :uri "/.well-known/agent-card.json"})]
(is (= 200 (:status resp)))
(let [card (m/decode "application/json" (:body resp))]
(is (= "tbd" (:name card)))
(is (= "http://tbd.test/a2a" (:url card)))
(is (false? (get-in card [:capabilities :streaming])))
(is (contains? (:securitySchemes card) :bearer))
(is (some #(= "add" (:id %)) (:skills card))))))
(deftest message-send-test
(let [[app path] (app-with (ts/config (ts/text-model "Hi there")))
token (mint-token! path "alice" 7)
resp (rpc app token (send-message "hi"))]
(is (= 200 (:status resp)))
(is (= "2.0" (get-in resp [:body :jsonrpc])))
(is (= 1 (get-in resp [:body :id])))
(is (= "agent" (get-in resp [:body :result :role])))
(is (= "Hi there" (get-in resp [:body :result :parts 0 :text])))))
(deftest unauthorized-test
(let [[app] (app-with (ts/config (ts/text-model "x")))]
(is (= 401 (:status (rpc app nil (send-message "hi")))))
(is (= 401 (:status (rpc app "not-a-real-token" (send-message "hi")))))))
(deftest tool-loop-test
(testing "the agent's own tool calls are run immediately, server-side, and the loop continues
until it answers in text"
(let [[app path] (app-with (ts/config (ts/tool-call-model {:id "c1" :name "add" :arguments "{\"x\":1,\"y\":2}"})))
token (mint-token! path "alice" 7)]
;; tool-call-model always asks for the same call; run-tools! must give up rather than loop forever
(is (= 502 (:status (rpc app token (send-message "add 1 and 2"))))))))
(deftest tool-loop-runs-a-real-tool-test
;; A regression test for the tool handlers themselves (create_todo etc. return JSON via
;; tbd.agent.a2a/->json): the first turn asks for a call, the second answers from its result.
(let [turn (atom 0)
first-model (ts/tool-call-model {:id "c1" :name "create_todo" :arguments "{\"title\":\"milk\"}"})
second-model (ts/text-model "Added it.")
model (ts/model-of
(fn [req handler]
(if (zero? @turn)
(do (swap! turn inc) (.doChat first-model req handler))
(.doChat second-model req handler))))
[app path] (app-with (ts/config model))
token (mint-token! path "alice" 7)
resp (rpc app token (send-message "add a todo to buy milk"))]
(is (= 200 (:status resp)))
(is (= "Added it." (get-in resp [:body :result :parts 0 :text])))))
(deftest invalid-jsonrpc-test
(let [[app path] (app-with (ts/config (ts/text-model "x")))
token (mint-token! path "alice" 7)]
(is (= "invalid JSON-RPC request" (get-in (rpc app token {:id 1 :method "message/send"}) [:body :error :message])))
(is (= "method not found: nope" (get-in (rpc app token {:jsonrpc "2.0" :id 1 :method "nope"}) [:body :error :message])))))
+110
View File
@@ -0,0 +1,110 @@
(ns tbd.agent.core-test
(:require [clojure.test :refer [deftest is testing]]
[tbd.agent.core :as agent]
[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)]
(if error
{:error error :kind kind}
(let [events (atom [])]
(ok (fn [e] (swap! events conj e)))
{:events @events}))))
(deftest not-configured
(is (= {:error "chat is not configured" :kind :unavailable}
(agent/start {} "sys" [{:role "user" :content "hi"}] nil))))
(deftest api-base-url-adds-v1
(testing "LM Studio's OpenAI-compatible endpoints live under /v1, which LangChain4j does not add
on its own (see tbd.agent.core/api-base-url); LMSTUDIO_URL is documented as the bare
server address, so this has to be added for every request to land"
(is (= "http://llm.test/v1" (#'agent/api-base-url "http://llm.test")))
(is (= "http://llm.test/v1" (#'agent/api-base-url "http://llm.test/v1")))))
(deftest a-plain-reply
(is (= {:events [{:thinking "hm"} {:content "Hel"} {:content "lo"} {:done true}]}
(turn! (ts/config (ts/thinking-model "hm" "Hel" "lo")) [{:role "user" :content "hi"}] nil))))
(deftest a-tool-call
(is (= {:events [{:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":1}"}]} {:done true}]}
(turn! (ts/config (ts/tool-call-model {:id "call_1" :name "add" :arguments "{\"x\":1}"}))
[{:role "user" :content "add 1"}]
[{:name "add" :description "adds" :inputSchema {:type "object" :properties {}}}]))))
(deftest no-reply-is-an-error
(is (= {:events [{:error "the LLM server sent no reply"}]}
(turn! (ts/config (ts/no-reply-model)) [{:role "user" :content "hi"}] nil))))
(deftest tools-optional
(is (= {:events [{:content "x"} {:done true}]}
(turn! (ts/config (ts/text-model "x")) [{:role "user" :content "hi"}] nil))))
(deftest connection-failure-is-caught-before-the-stream-starts
(testing "the model errors before ever saying anything: {:error}, no {:ok}"
(is (= {:error "the LLM server can't be reached or refused" :kind :upstream}
(turn! (ts/config (ts/error-model "boom")) [{:role "user" :content "hi"}] nil))))
(testing "the fake model itself throws synchronously"
(let [config (ts/config (ts/model-of (fn [_ _] (throw (RuntimeException. "no such host")))))]
(is (= :upstream (:kind (turn! config [{:role "user" :content "hi"}] nil))))))
(testing ".chat is never called when chat isn't configured, whatever the model would have said"
(let [calls (atom 0)
config (assoc (ts/config (ts/model-of (fn [_ _] (swap! calls inc)))) :url nil)]
(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)"
(let [messages [{:role "user" :content "add 1 and 2"}
{:role "assistant" :content "" :tool-calls [{:id "c1" :name "add" :arguments "{\"x\":1,\"y\":2}"}]}
{:role "tool" :tool-call-id "c1" :content "3"}]]
(is (= {:events [{:content "3"} {:done true}]}
(turn! (ts/config (ts/text-model "3")) messages nil))))))
+49
View File
@@ -0,0 +1,49 @@
(ns tbd.agent.instructions-test
(:require [clojure.string :as str]
[clojure.test :refer [deftest is]]
[tbd.agent.instructions :as instructions]
[tbd.agent.prompt :as prompt]))
(defn- flat
"`text` on one line: the prompts are wrapped in the source, where they wrap is not the point."
[text]
(str/replace text #"\s+" " "))
(deftest chat-and-guide-share-the-instructions
(doseq [text (map flat [(instructions/chat) prompt/guide])]
(is (str/includes? text "Act, don't offer"))
(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 "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? (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 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 (str/includes? text "list_todos -> set_todo_done") "it has no state either: it reads first, like WebMCP's guide")))
+25 -21
View File
@@ -8,22 +8,17 @@
[text]
(str/replace text #"\s+" " "))
(deftest chat-and-guide-share-the-instructions
(testing "both tell the agent to act, to chain calls and to report only what a result says"
(doseq [text (map flat [prompt/chat prompt/guide])]
(is (str/includes? text "Act, don't offer"))
(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 "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: "))))
(testing "what only fits the chatbot is not said to an agent outside the page"
(is (str/includes? prompt/chat "under your message"))
(is (not (str/includes? prompt/guide "under your message")))
(is (not (str/includes? prompt/guide "navigate there, then")) "an outside agent is offered every tool")))
(deftest guide-tells-the-agent-to-act
(let [text (flat prompt/guide)]
(is (str/includes? text "Act, don't offer"))
(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 "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 "Examples: "))
(is (not (str/includes? text "navigate there, then")) "an outside agent is offered every tool")))
(deftest task-prompt
(is (str/starts-with? (prompt/task "add a todo") prompt/guide))
@@ -32,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"))
+92
View File
@@ -0,0 +1,92 @@
(ns tbd.agent.test-support
"A fake LangChain4j StreamingChatModel for tests: no real network, no LM Studio. `model-of`
builds one from a script — a function of the ChatRequest that calls the handler's callbacks
directly, exactly as a real provider's client would, so tbd.agent.core's pump code is exercised
for real. `text-model`/`tool-call-model`/`error-model`/`thinking-model` cover the common cases."
(:require [tbd.agent.core :as agent])
(:import (dev.langchain4j.agent.tool ToolExecutionRequest)
(dev.langchain4j.data.message AiMessage)
(dev.langchain4j.model.chat StreamingChatModel)
(dev.langchain4j.model.chat.response
ChatResponse ChatResponseMetadata$Builder CompleteToolCall PartialResponse
PartialResponseContext PartialThinking PartialThinkingContext StreamingHandle)
(dev.langchain4j.model.output FinishReason TokenUsage)))
(defn fake-handle
"A StreamingHandle whose `cancel` is observable through the atom `cancelled?`."
([] (fake-handle (atom false)))
([cancelled?]
(reify StreamingHandle
(cancel [_] (reset! cancelled? true))
(isCancelled [_] @cancelled?))))
(defn model-of
"A StreamingChatModel whose `doChat` calls `(script req handler)`."
^StreamingChatModel [script]
(reify StreamingChatModel
(doChat [_ req handler] (script req handler) nil)))
(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)
(.metadata (cond-> (ChatResponseMetadata$Builder.)
finish-reason (.finishReason finish-reason)
usage (.tokenUsage (TokenUsage. (int (first usage)) (int (second usage))))
true .build))
.build)))
(defn text-model
"A model that streams `pieces` as :content, then finishes with their concatenation as the reply."
[& pieces]
(model-of (fn [_ handler]
(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 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]
(model-of (fn [_ handler]
(let [h (fake-handle)]
(.onPartialThinking handler (PartialThinking. ^String thinking) (PartialThinkingContext. h))
(doseq [p pieces] (.onPartialResponse handler (PartialResponse. ^String p) (PartialResponseContext. h)))
(complete handler (AiMessage/from (apply str pieces)) FinishReason/STOP [10 5])))))
(defn tool-call-model
"A model that asks for one tool call: {:id :name :arguments}."
[{:keys [id name arguments]}]
(model-of (fn [_ handler]
(let [req (-> (ToolExecutionRequest/builder) (.id id) (.name name) (.arguments arguments) .build)]
(.onCompleteToolCall handler (CompleteToolCall. (int 0) req))
(complete handler (AiMessage/from "" [req]) FinishReason/TOOL_EXECUTION nil)))))
(defn error-model
"A model whose call always fails with `message`."
[message]
(model-of (fn [_ handler] (.onError handler (RuntimeException. ^String message)))))
(defn no-reply-model
"A model that ends the turn with nothing said and no calls (the LLM sent no reply)."
[]
(model-of (fn [_ handler] (complete handler (AiMessage/from "") FinishReason/STOP nil))))
(defn config
"A chat config (see tbd.agent.core/env-config) using `model` instead of a real LM Studio."
([model] (config model {}))
([model overrides]
(merge (agent/env-config {"LMSTUDIO_URL" "http://llm.test"}) {:chat-model model} overrides)))
-534
View File
@@ -1,534 +0,0 @@
(ns tbd.chat.core-test
(:require [clojure.string :as str]
[clojure.test :refer [deftest is testing]]
[muuntaja.core :as m]
[tbd.chat.core :as chat])
(:import (com.sun.net.httpserver HttpExchange HttpHandler HttpServer)
(java.io ByteArrayInputStream FilterInputStream IOException InputStream PipedInputStream PipedOutputStream)
(java.net InetAddress InetSocketAddress)
(java.net.http HttpTimeoutException)
(java.util.concurrent CountDownLatch TimeUnit)))
;; --- The LLM's side: what LM Studio's event stream looks like ---
(defn- json [data] (slurp (m/encode "application/json" data)))
(defn- data-line
"One event of the stream: a completion chunk whose delta is `delta`."
[delta]
(str "data: " (json {:choices [{:index 0 :delta delta :finish_reason nil}]}) "\n\n"))
(defn- content [text] (data-line {:content text}))
(defn- reasoning [text] (data-line {:reasoning_content text}))
(def ^:private done "data: [DONE]\n\n")
(defn- call-piece
"A piece of the tool call number `index`: `fields` are its :id, :name and :arguments, as far as this piece has them."
[index {:keys [id name arguments]}]
(data-line {:tool_calls [(cond-> {:index index}
id (assoc :id id :type "function")
(or name arguments) (assoc :function (cond-> {}
name (assoc :name name)
arguments (assoc :arguments arguments))))]}))
(defn- stream-of ^InputStream [& parts]
(ByteArrayInputStream. (.getBytes ^String (apply str parts) "UTF-8")))
(def ^:private quiet
"A trace config that says nothing (see tbd.chat.trace/config-for): the tests' log is for failures."
{:sink (fn [_]) :full-text? false})
(defn- config
"A configured chat whose LLM server is `http`; `calls` (an atom) collects what it was sent."
[calls http & {:as overrides}]
(merge {:url "http://llm.test:1234" :timeout-seconds 30
:trace quiet
:http (fn [req] (swap! calls conj req) (http req))}
overrides))
(defn- replying
"An `http` fn that answers 200 with the event stream made of `parts`."
[& parts]
(fn [_] {:status 200 :body (apply stream-of parts)}))
(def ^:private hello [{:role "user" :content "hi"}])
(defn- sent-body
"The request body `json` the LLM server got, without the system message that starts every
conversation (system-message-test is about that one): its `:messages` are the conversation's."
[json]
(update (m/decode "application/json" json) :messages #(vec (rest %))))
(defn- run
"Starts a chat with `hello` and forwards the whole reply: the events it gave, or start's error.
`on-event`, if given, is called with each event as it arrives."
([config] (run config identity))
([config on-event]
(let [{:keys [ok] :as started} (chat/start config hello)]
(if ok
(let [events (atom [])]
(ok (fn [event] (swap! events conj event) (on-event event)))
@events)
started))))
(defn- run*
"Like `run`, for the conversation `messages` and the `tools` on offer."
[config messages tools]
(let [{:keys [ok] :as started} (chat/start config messages tools)]
(if ok
(let [events (atom [])]
(ok #(swap! events conj %))
@events)
started)))
(defn- closing
"`in`, and an atom that says whether it was closed."
[in]
(let [closed? (atom false)]
[(proxy [FilterInputStream] [in]
(close [] (reset! closed? true) (proxy-super close)))
closed?]))
(defn- cut-off
"A stream that gives `text` and then fails, as when the connection drops mid-reply."
^InputStream [^String text]
(let [in (ByteArrayInputStream. (.getBytes text "UTF-8"))]
(proxy [InputStream] []
(read
([] (let [b (.read in)] (if (neg? b) (throw (IOException. "connection reset")) b)))
([buf off len] (let [n (.read in buf off len)]
(if (neg? n) (throw (IOException. "connection reset")) n))))
(close []))))
(defn- silent
"A stream that gives nothing until it is closed, when the read that waits fails, as a socket's
does. (A PipedInputStream would keep waiting: it only checks for a close when a read starts.)"
^InputStream []
(let [closed (CountDownLatch. 1)]
(proxy [InputStream] []
(read
([] (.await closed) (throw (IOException. "Socket closed")))
([buf off len] (.await closed) (throw (IOException. "Socket closed"))))
(close [] (.countDown closed)))))
;; --- Tests ---
(deftest env-config-test
(testing "nothing set: chat is off, with the defaults for the rest"
(let [c (chat/env-config {})]
(is (not (chat/configured? c)))
(is (= chat/default-timeout-seconds (:timeout-seconds c)))
(is (nil? (:model c)))))
(testing "values are trimmed, and a trailing slash on the URL is dropped"
(let [c (chat/env-config {"LMSTUDIO_URL" " http://10.0.0.5:1234// "
"LMSTUDIO_MODEL" " qwen "
"LMSTUDIO_API_KEY" "k"
"LMSTUDIO_TIMEOUT_SECONDS" "7"})]
(is (chat/configured? c))
(is (= {:url "http://10.0.0.5:1234" :model "qwen" :api-key "k" :timeout-seconds 7}
(select-keys c [:url :model :api-key :timeout-seconds])))))
(testing "blank values count as unset"
(is (not (chat/configured? (chat/env-config {"LMSTUDIO_URL" " "}))))))
(deftest request-test
(testing "the conversation goes to the chat completions endpoint, and asks for a stream"
(let [calls (atom [])]
(run (config calls (replying (content "x") done) :model "qwen" :api-key "secret"))
(let [[{:keys [url headers body timeout-seconds]}] @calls]
(is (= "http://llm.test:1234/v1/chat/completions" url))
(is (= "Bearer secret" (get headers "Authorization")))
(is (= "application/json" (get headers "Content-Type")))
(is (= 30 timeout-seconds))
(is (= {:model "qwen" :stream true :messages hello} (sent-body body))))))
(testing "no model and no key: neither is sent"
(let [calls (atom [])]
(run (config calls (replying (content "x") done)))
(is (= {:messages hello :stream true} (sent-body (:body (first @calls)))))
(is (nil? (get-in (first @calls) [:headers "Authorization"])))))
(testing "not configured: the server is never called"
(let [calls (atom [])]
(is (= {:error "chat is not configured" :kind :unavailable}
(chat/start (dissoc (config calls (fn [_] nil)) :url) hello)))
(is (empty? @calls)))))
(deftest reply-events-test
(testing "each piece of the reply is passed on as it comes, and the end is marked"
(is (= [{:content "Hel"} {:content "lo!"} {:done true}]
(run (config (atom []) (replying (content "Hel") (content "lo!") done))))))
(testing "the model's reasoning is passed on too, piece by piece"
(is (= [{:thinking "Let me"} {:thinking " think"} {:content "Hi"} {:done true}]
(run (config (atom []) (replying (reasoning "Let me") (reasoning " think") (content "Hi") done))))))
(testing "a piece of reasoning that is only whitespace is kept (it can be the break between paragraphs)"
(is (= [{:thinking "One."} {:thinking "\n\n"} {:thinking "Two."} {:content "Hi"} {:done true}]
(run (config (atom []) (replying (reasoning "One.") (reasoning "\n\n") (reasoning "Two.")
(content "Hi") done))))))
(testing "reasoning and text in one event are both passed on"
(is (= [{:thinking "hm" :content "Hi"} {:done true}]
(run (config (atom []) (replying (data-line {:reasoning_content "hm" :content "Hi"}) done))))))
(testing "an empty piece of reasoning says nothing"
(is (= [{:content "Hi"} {:done true}]
(run (config (atom []) (replying (reasoning "") (content "Hi") done))))))
(testing "whitespace inside the reply is kept, as it is part of the text"
(is (= [{:content "a"} {:content " b\n"} {:done true}]
(run (config (atom []) (replying (content "a") (content " b\n") done))))))
(testing "text in any script comes through intact"
(is (= [{:content "héllo 👋 世界"} {:done true}]
(run (config (atom []) (replying (content "héllo 👋 世界") done))))))
(testing "events that say nothing are skipped: role-only and finishing chunks, comments, blank lines"
(is (= [{:content "Hi"} {:done true}]
(run (config (atom [])
(replying ": keep-alive\n\n"
(data-line {:role "assistant"})
(content "Hi")
(data-line {})
"event: ping\n\n"
"data: not json\n\n"
done))))))
(testing "a stream that ends without [DONE] is still a whole reply"
(is (= [{:content "Hi"} {:done true}]
(run (config (atom []) (replying (content "Hi")))))))
(testing "the stream is closed when it's over"
(let [[in closed?] (closing (stream-of (content "Hi") done))]
(run (config (atom []) (fn [_] {:status 200 :body in})))
(is @closed?))))
(deftest reply-failures-test
(testing "a reply with no text in it"
(doseq [parts [[done] [] [(reasoning "hmm") done] [(content " ") done] [(data-line {:role "assistant"}) done]]]
(is (= [{:error "the LLM server sent no reply"}]
(remove :thinking (run (config (atom []) (apply replying parts)))))
(pr-str parts))))
(testing "an error inside the stream ends it, without the server's own words"
(is (= [{:content "Hi"} {:error "the LLM server reported an error"}]
(run (config (atom []) (replying (content "Hi")
(str "data: " (json {:error {:message "model crashed at /home/x"}}) "\n\n")
(content "never seen")))))))
(testing "the connection drops in the middle of the reply: what came is kept, and the error follows"
(let [[in closed?] (closing (cut-off (content "Hel")))]
(is (= [{:content "Hel"} {:error "the LLM server's reply was cut off"}]
(run (config (atom []) (fn [_] {:status 200 :body in})))))
(is @closed?))))
(deftest silent-llm-test
(testing "an LLM that goes quiet is given up on after the timeout, and its request closed"
(let [[in closed?] (closing (silent))
started (System/nanoTime)]
(is (= [{:error "the LLM server took too long to answer"}]
(run (config (atom []) (fn [_] {:status 200 :body in}) :timeout-seconds 1))))
(is @closed?)
(is (< (/ (- (System/nanoTime) started) 1e9) 5) "it doesn't wait for the default")))
(testing "the timeout is for silence, not the whole reply: a reply that takes longer is fine"
(let [out (PipedOutputStream.)
in (PipedInputStream. out)
writer (future (doseq [text ["a" "b" "c"]]
(Thread/sleep 600)
(.write out (.getBytes ^String (content text) "UTF-8"))
(.flush out))
(.write out (.getBytes ^String done "UTF-8"))
(.close out))]
(is (= [{:content "a"} {:content "b"} {:content "c"} {:done true}]
(run (config (atom []) (fn [_] {:status 200 :body in}) :timeout-seconds 1))))
@writer)))
(deftest client-goes-away-test
(testing "when the events can't be delivered any more, the LLM's request is closed and the error is passed on"
(let [[in closed?] (closing (stream-of (content "a") (content "b") (content "c") done))
{:keys [ok]} (chat/start (config (atom []) (fn [_] {:status 200 :body in})) hello)
seen (atom [])]
(is (thrown-with-msg? IOException #"broken pipe"
(ok (fn [event]
(swap! seen conj event)
(throw (IOException. "broken pipe"))))))
(is (= [{:content "a"}] @seen) "nothing more is read once the client is gone")
(is @closed?))))
(deftest start-failures-test
(let [fail (fn [http] (chat/start (config (atom []) http) hello))]
(testing "an error status from the LLM server: nothing is streamed, and its body isn't passed on"
(let [[in closed?] (closing (stream-of "secret internal details"))]
(is (= {:error "the LLM server answered HTTP 500" :kind :upstream}
(fail (fn [_] {:status 500 :body in}))))
(is @closed?)))
(testing "the server can't be reached, or doesn't start answering in time"
(is (= {:error "the LLM server can't be reached" :kind :upstream}
(fail (fn [_] (throw (java.net.ConnectException. "refused"))))))
(is (= {:error "the LLM server took too long to answer" :kind :upstream}
(fail (fn [_] (throw (HttpTimeoutException. "request timed out")))))))
(testing "anything else that goes wrong"
(is (= :upstream (:kind (fail (fn [_] (throw (IllegalStateException. "?"))))))))))
(def ^:private add-tool
{:name "add" :description "Adds two numbers"
:inputSchema {:type "object" :properties {:x {:type "number"} :y {:type "number"}} :required ["x" "y"]}})
(deftest system-message-test
(let [sent-messages (fn [messages tools page]
(let [calls (atom [])
{:keys [ok]} (chat/start (config calls (replying (content "x") done)) messages tools page)]
(ok identity)
(:messages (m/decode "application/json" (:body (first @calls))))))
system (fn [messages] (:content (first messages)))]
(testing "the instructions come first, in one system message, whatever the conversation"
(let [messages (sent-messages [{:role "user" :content "hi"}
{:role "assistant" :content "hello"}
{:role "user" :content "add a todo"}]
[add-tool] "todos")]
(is (= ["system" "user" "assistant" "user"] (map :role messages)))
(is (str/starts-with? (system messages) chat/default-system-prompt))
(is (= "hi" (:content (second messages))))))
(testing "the page the user is on and the tools it offers are its last words"
(let [content (system (sent-messages hello [add-tool {:name "navigate" :inputSchema {:type "object"}}] "todos"))]
(is (str/ends-with? content (str "The user is on the \"todos\" page of the app: what it shows is what they can see."
" Its tools: add, navigate. The tools of other pages are offered once you navigate there.")))))
(testing "without tools it says nothing of them"
(let [content (system (sent-messages hello nil "todos"))]
(is (str/includes? content "\"todos\" page"))
(is (not (str/includes? content "tools:")))))
(testing "without a page the instructions still go, and the tools are simply its own"
(let [messages (sent-messages hello [add-tool] nil)]
(is (= ["system" "user"] (map :role messages)))
(is (not (str/includes? (system messages) "page of the app")))
(is (str/ends-with? (system messages) "Your tools: add. The tools of other pages are offered once you navigate there.")))
(is (= chat/default-system-prompt (system (sent-messages hello nil nil)))))))
(deftest default-system-prompt-test
(testing "it tells the model to act, not to offer"
(is (str/includes? chat/default-system-prompt "Act, don't offer"))
(is (str/includes? chat/default-system-prompt "in this same\nturn")))
(testing "its examples are tools of the page (a renamed tool must be renamed here too)"
(doseq [tool ["create_todo" "list_todos" "set_todo_done" "add" "get_tic_tac_toe"]]
(is (str/includes? chat/default-system-prompt tool) tool))))
(deftest tools-request-test
(testing "the page's tools go to the LLM as functions, described as MCP describes them"
(let [calls (atom [])]
(run* (config calls (replying (content "x") done)) hello [add-tool])
(is (= [{:type "function"
:function {:name "add" :description "Adds two numbers"
:parameters (:inputSchema add-tool)}}]
(:tools (m/decode "application/json" (:body (first @calls))))))))
(testing "a tool without a description has none sent"
(let [calls (atom [])]
(run* (config calls (replying (content "x") done)) hello [(dissoc add-tool :description)])
(is (= {:name "add" :parameters (:inputSchema add-tool)}
(get-in (m/decode "application/json" (:body (first @calls))) [:tools 0 :function])))))
(testing "no tools (nil or empty): no `tools` at all, which some models take for tool support"
(doseq [tools [nil []]]
(let [calls (atom [])]
(run* (config calls (replying (content "x") done)) hello tools)
(is (not (contains? (m/decode "application/json" (:body (first @calls))) :tools))))))
(testing "a conversation that used them: the model's calls and their results, as the LLM server has them"
(let [calls (atom [])
conversation [{:role "user" :content "1+2?"}
{:role "assistant" :content ""
:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":1,\"y\":2}"}]}
{:role "tool" :tool-call-id "call_1" :content "3"}]]
(run* (config calls (replying (content "3") done)) conversation [add-tool])
(is (= [{:role "user" :content "1+2?"}
{:role "assistant" :content ""
:tool_calls [{:id "call_1" :type "function"
:function {:name "add" :arguments "{\"x\":1,\"y\":2}"}}]}
{:role "tool" :tool_call_id "call_1" :content "3"}]
(:messages (sent-body (:body (first @calls)))))))))
(deftest tool-call-events-test
(testing "a call the model writes bit by bit is passed on whole, when the reply is complete"
(is (= [{:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":1,\"y\":2}"}]} {:done true}]
(run (config (atom []) (replying (call-piece 0 {:id "call_1" :name "add" :arguments ""})
(call-piece 0 {:arguments "{\"x\":1,"})
(call-piece 0 {:arguments "\"y\":2}"})
(data-line {})
done))))))
(testing "a call that comes in one piece"
(is (= [{:tool-calls [{:id "c" :name "ping" :arguments "{}"}]} {:done true}]
(run (config (atom []) (replying (call-piece 0 {:id "c" :name "ping" :arguments "{}"}) done))))))
(testing "several calls, whose pieces are mixed, come in the order of their index"
(is (= [{:tool-calls [{:id "a" :name "add" :arguments "{\"x\":1}"}
{:id "b" :name "ping" :arguments "{}"}]}
{:done true}]
(run (config (atom []) (replying (call-piece 1 {:id "b" :name "ping"})
(call-piece 0 {:id "a" :name "add" :arguments "{\"x\""})
(call-piece 1 {:arguments "{}"})
(call-piece 0 {:arguments ":1}"})
done))))))
(testing "text before the calls is passed on as it comes; the calls follow it"
(is (= [{:content "Let me add."} {:tool-calls [{:id "a" :name "add" :arguments "{}"}]} {:done true}]
(run (config (atom []) (replying (content "Let me add.")
(call-piece 0 {:id "a" :name "add" :arguments "{}"})
done))))))
(testing "a reply that is only a call is a reply, and one without arguments has an empty text for them"
(is (= [{:thinking "hm"} {:tool-calls [{:id "a" :name "ping" :arguments ""}]} {:done true}]
(run (config (atom []) (replying (reasoning "hm") (call-piece 0 {:id "a" :name "ping"}) done))))))
(testing "a call has an id even when the server sends none"
(is (= [{:tool-calls [{:id "call_0" :name "ping" :arguments "{}"}]} {:done true}]
(run (config (atom []) (replying (call-piece 0 {:name "ping" :arguments "{}"}) done))))))
(testing "pieces that never got a tool's name are no call"
(is (= [{:error "the LLM server sent no reply"}]
(run (config (atom []) (replying (call-piece 0 {:arguments "{}"}) done))))))
(testing "a stream that ends without [DONE] still has its calls"
(is (= [{:tool-calls [{:id "a" :name "ping" :arguments "{}"}]} {:done true}]
(run (config (atom []) (replying (call-piece 0 {:id "a" :name "ping" :arguments "{}"})))))))
(testing "calls that were cut off are dropped along with the error"
(let [[in _] (closing (cut-off (call-piece 0 {:id "a" :name "add" :arguments "{\"x\""})))]
(is (= [{:error "the LLM server's reply was cut off"}]
(run (config (atom []) (fn [_] {:status 200 :body in}))))))))
;; --- Tracing: what the operator sees of a turn ---
(defn- traced
"Runs a chat over `conversation` with `http`, tracing into an atom: [what the client was sent, entries]."
([http] (traced http hello))
([http conversation]
(let [entries (atom [])
result (run* (config (atom []) http :trace {:sink #(swap! entries conj %) :full-text? true}
:model "qwen")
conversation nil)]
[result @entries])))
(defn- turn-end [entries] (first (filter #(= :turn-end (:event %)) entries)))
(deftest tracing-test
(testing "a turn is logged when it starts, and when it ends, with the same ids"
(let [[events entries] (traced (replying (reasoning "Let me think. ") (content "Hi") done))
[start end] entries]
(is (= [{:thinking "Let me think. "} {:content "Hi"} {:done true}] events))
(is (= [:turn-start :turn-end] (map :event entries)))
(is (= (select-keys start [:req :run :step]) (select-keys end [:req :run :step])))
(is (= {:model "qwen" :messages 1 :tools 0 :step 0 :run-calls 0} (select-keys start [:model :messages :tools :step :run-calls])))
(is (= {:outcome :done :thinking-chars 14 :content-chars 2 :events 2}
(select-keys end [:outcome :thinking-chars :content-chars :events])))
(is (every? #(number? (get end %)) [:duration-ms :ttft-ms :think-ms]))
(is (= "Let me think. " (:reasoning end)))
(is (= "Hi" (:reply end)))
(is (= hello (:input start)))))
(testing "the calls the model asked for are in the outcome"
(let [[_ entries] (traced (replying (call-piece 0 {:id "a" :name "add" :arguments "{\"x\":1}"}) done))]
(is (= :tool-calls (:outcome (turn-end entries))))
(is (= [{:name "add" :args "{\"x\":1}"}] (:calls (turn-end entries))))))
(testing "why the model stopped, and what it cost, are logged, and are not the client's business"
(let [[events entries] (traced (replying (content "Hi")
(str "data: " (json {:choices [{:index 0 :delta {} :finish_reason "length"}]}) "\n\n")
(str "data: " (json {:choices [] :usage {:prompt_tokens 10 :completion_tokens 5
:total_tokens 15 :other "x"}}) "\n\n")
done))
end (turn-end entries)]
(is (= [{:content "Hi"} {:done true}] events))
(is (= {:finish-reason "length" :prompt-tokens 10 :completion-tokens 5 :flags [:truncated]}
(select-keys end [:finish-reason :prompt-tokens :completion-tokens :flags])))))
(testing "the failures of the LLM are outcomes too"
(is (= {:outcome :error :error "the LLM server sent no reply"}
(select-keys (turn-end (second (traced (replying done)))) [:outcome :error])))
(let [end (turn-end (second (traced (fn [_] {:status 200 :body (cut-off (content "Hel"))}))))]
(is (= {:outcome :error :error "the LLM server's reply was cut off"} (select-keys end [:outcome :error])))
(is (str/includes? (:detail end) "connection reset")))
(let [entries (atom [])
{:keys [ok]} (chat/start (config (atom []) (fn [_] {:status 200 :body (silent)}) :timeout-seconds 1
:trace {:sink #(swap! entries conj %)}) hello)]
(ok identity)
(is (= "1s of silence" (:detail (turn-end @entries))))))
(testing "a turn that never got a reply says why"
(let [entries (atom [])
result (chat/start (config (atom []) (fn [_] {:status 500 :body (stream-of "oops")})
:trace {:sink #(swap! entries conj %)}) hello)
end (turn-end @entries)]
(is (= :upstream (:kind result)))
(is (= [:turn-start :turn-end] (map :event @entries)))
(is (= {:outcome :upstream-error :error "the LLM server answered HTTP 500" :detail "body: oops"}
(select-keys end [:outcome :error :detail])))))
(testing "a client that goes away ends the turn as aborted, once"
(let [entries (atom [])
{:keys [ok]} (chat/start (config (atom []) (replying (content "a") (content "b") done)
:trace {:sink #(swap! entries conj %)}) hello)]
(is (thrown? IOException (ok (fn [_] (throw (IOException. "broken pipe"))))))
(is (= [:aborted] (map :outcome (filter #(= :turn-end (:event %)) @entries))))))
(testing "a tracer that breaks doesn't break the chat"
(is (= [{:content "Hi"} {:done true}]
(run (config (atom []) (replying (content "Hi") done)
:trace {:sink (fn [_] (throw (IllegalStateException. "disk full")))})))))
(testing "without a trace config the turn is still logged, to the log"
(let [out (with-out-str (run (dissoc (config (atom []) (replying (content "Hi") done)) :trace)))]
(is (str/includes? out "[tbd] chat turn-start"))
(is (str/includes? out "[tbd] chat turn-end")))))
(deftest tracing-the-tool-loop-test
(let [call {:role "assistant" :content "" :tool-calls [{:id "c" :name "get_tic_tac_toe" :arguments "{}"}]}
result {:role "tool" :tool-call-id "c" :content "board"}
conversation (fn [n] (into [{:role "user" :content "play"}] (take (* 2 n) (cycle [call result]))))
starts (fn [n] (filter #(#{:turn-start :loop-suspect} (:event %))
(second (traced (replying (content "x") done) (conversation n)))))]
(testing "the turns of one run share a run id, and count their steps"
(let [[a b] (map (comp first starts) [1 2])]
(is (= (:run a) (:run b)))
(is (= [1 2] [(:step a) (:step b)]))
(is (= [1 2] [(:run-calls a) (:run-calls b)]))))
(testing "the same call over and over is a suspect"
(is (= [:turn-start] (map :event (starts 2))))
(let [[_ suspect] (starts 3)]
(is (= {:event :loop-suspect :kind :repeated-call :tool "get_tic_tac_toe" :count 3 :args "{}"}
(select-keys suspect [:event :kind :tool :count :args])))))))
;; --- The default HTTP client, against a real server on loopback ---
(defn- llm-server
"Runs `handle` (a fn of the exchange) as a server like LM Studio's on loopback, and calls `f`
with its URL. Like LM Studio's server, it never answers a request that offers an upgrade to
HTTP/2 (`Upgrade: h2c`, which the JDK client sends by default): here that is a 400, so a failure
shows up at once instead of after the timeout."
[handle f]
(let [server (HttpServer/create (InetSocketAddress. (InetAddress/getLoopbackAddress) 0) 0)]
(.createContext server "/v1/chat/completions"
(reify HttpHandler
(handle [_ ex]
(let [headers (.getRequestHeaders ex)]
(if (or (.containsKey headers "Upgrade") (.containsKey headers "Http2-settings"))
(let [msg (.getBytes "h2c upgrade offered")]
(.sendResponseHeaders ex 400 (count msg))
(with-open [out (.getResponseBody ex)] (.write out msg)))
(handle ex))))))
(.start server)
(try (f (str "http://" (.getHostString (.getAddress server)) ":" (.getPort (.getAddress server))))
(finally (.stop server 0)))))
(defn- write! [^HttpExchange ex ^String text]
(let [out (.getResponseBody ex)]
(.write out (.getBytes text "UTF-8"))
(.flush out)))
(deftest java-http-test
(testing "an unreachable server is an error result"
;; Port 1 on loopback: nothing listens there, so the connection is refused at once.
(is (= {:error "the LLM server can't be reached" :kind :upstream}
(chat/start {:url "http://127.0.0.1:1" :timeout-seconds 5 :trace quiet :http chat/java-http} hello))))
(testing "a plain HTTP/1.1 request, with no upgrade to HTTP/2 offered, that gets the whole reply"
(let [seen (atom nil)]
(llm-server
(fn [^HttpExchange ex]
(reset! seen {:method (.getRequestMethod ex)
:content-type (.getFirst (.getRequestHeaders ex) "Content-Type")
:body (slurp (.getRequestBody ex))})
(.sendResponseHeaders ex 200 0)
(write! ex (str (content "Hello ") (content "from the LLM") done))
(.close ex))
(fn [url]
(is (= [{:content "Hello "} {:content "from the LLM"} {:done true}]
(run {:url url :model "qwen" :timeout-seconds 10 :trace quiet :http chat/java-http})))))
(is (= "POST" (:method @seen)))
(is (= "application/json" (:content-type @seen)))
(is (= {:model "qwen" :stream true :messages hello} (sent-body (:body @seen))))))
(testing "the reply is passed on as it arrives, not when it is over"
;; The server holds back the rest of the reply until it hears that the first piece arrived. A
;; client that buffers the reply never gets there.
(let [first-arrived (CountDownLatch. 1)
released? (atom nil)]
(llm-server
(fn [^HttpExchange ex]
(.sendResponseHeaders ex 200 0)
(write! ex (content "first"))
(reset! released? (.await first-arrived 5 TimeUnit/SECONDS))
(write! ex (str (content "second") done))
(.close ex))
(fn [url]
(is (= [{:content "first"} {:content "second"} {:done true}]
(run {:url url :timeout-seconds 10 :trace quiet :http chat/java-http}
#(when (= {:content "first"} %) (.countDown first-arrived)))))))
(is (true? @released?) "the first piece was delivered while the server was still replying"))))
+43
View File
@@ -0,0 +1,43 @@
(ns tbd.chat.db-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[tbd.chat.db :as db]
[tbd.sqlite-test :refer [temp-db-path]]))
(deftest open-test
(testing "creates the file and its directory"
(let [path (temp-db-path)]
(db/open path)
(is (.exists (io/file path)))))
(testing "reopening keeps the data"
(let [path (temp-db-path)
messages [{:role "user" :content "hi"}]]
(db/save-history! (db/open path) 7 messages 1000)
(is (= messages (db/get-history (db/open path) 7))))))
(deftest crud-test
(let [ds (db/open (temp-db-path))]
(testing "nothing stored yet"
(is (= [] (db/get-history ds 7))))
(testing "save and load"
(db/save-history! ds 7 [{:role "user" :content "hi"}] 1000)
(is (= [{:role "user" :content "hi"}] (db/get-history ds 7))))
(testing "saving again replaces the whole conversation"
(db/save-history! ds 7 [{:role "user" :content "hi"}
{:role "assistant" :content "hello"}]
2000)
(is (= [{:role "user" :content "hi"} {:role "assistant" :content "hello"}]
(db/get-history ds 7))))
(testing "clear"
(db/clear-history! ds 7)
(is (= [] (db/get-history ds 7))))))
(deftest owner-scoping-test
(let [ds (db/open (temp-db-path))]
(db/save-history! ds 7 [{:role "user" :content "mine"}] 1000)
(db/save-history! ds 8 [{:role "user" :content "theirs"}] 1000)
(is (= [{:role "user" :content "mine"}] (db/get-history ds 7)))
(is (= [{:role "user" :content "theirs"}] (db/get-history ds 8)))
(db/clear-history! ds 7)
(is (= [] (db/get-history ds 7)))
(is (= [{:role "user" :content "theirs"}] (db/get-history ds 8)) "clearing one owner's history leaves the other's")))
+180 -126
View File
@@ -3,36 +3,24 @@
[clojure.test :refer [deftest is testing]]
[muuntaja.core :as m]
[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 FilterInputStream IOException OutputStream)))
(:import (dev.langchain4j.data.message SystemMessage)
(dev.langchain4j.model.chat.request ChatRequest)
(java.io ByteArrayInputStream ByteArrayOutputStream IOException OutputStream)))
(defn- json [data] (slurp (m/encode "application/json" data)))
(defn- delta-event [delta]
(str "data: " (json {:choices [{:index 0 :delta delta}]}) "\n\n"))
(defn- llm-stream
"The event stream of an LLM that says `pieces`."
[& pieces]
(str (apply str (map #(delta-event {:content %}) pieces)) "data: [DONE]\n\n"))
(defn- streaming
"An `http` fn for the chat config that answers 200 with `text` as the event stream."
[text]
(fn [_] {:status 200 :body (ByteArrayInputStream. (.getBytes ^String text "UTF-8"))}))
(defn- chat-config [http]
{:url "http://llm.test" :timeout-seconds 5 :http http})
(defn- post-chat
"POST /api/chat with `body`, a JSON string (or nil for none)."
[app cookie body]
(test-util/decode-body
(app (cond-> {:request-method :post :uri "/api/chat"
:headers (cond-> {"content-type" "application/json"}
cookie (assoc "cookie" cookie))}
body (assoc :body (ByteArrayInputStream. (.getBytes ^String body)))))))
(app (cond-> {:request-method :post :uri "/api/chat"
:headers (cond-> {"content-type" "application/json"}
cookie (assoc "cookie" cookie))}
body (assoc :body (ByteArrayInputStream. (.getBytes ^String body)))))))
(defn- body-text
"What a response's streaming body writes, as the server would write it to the browser."
@@ -42,138 +30,154 @@
(.toString out "UTF-8")))
(defn- events
"The events of a chat response: the JSON of each `data:` line."
"The AG-UI events of a chat response: the JSON of each `data:` line, `:type` and one message/call
id dropped (a random uuid, not what these tests are about) unless a test keeps it."
[resp]
(->> (str/split (body-text resp) #"\n\n")
(map #(m/decode "application/json" (str/replace-first % "data: " "")))))
(def ^:private hello "{\"messages\":[{\"role\":\"user\",\"content\":\"hi\"}]}")
(defn- types [resp] (map :type (events resp)))
(defn- app-with [chat]
(t/make-app (t/gitea-stub "alice") :chat chat))
(def ^:private hello (json {:messages [{:id "m1" :role "user" :content "hi"}]}))
(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 [calls (atom 0)
app (app-with (chat-config (fn [_] (swap! calls inc) ((streaming (llm-stream "x")) nil))))]
(let [app (app-with (ts/config (ts/text-model "x")))]
(doseq [body [hello "nope" nil]]
(let [resp (post-chat app nil body)]
(is (= 401 (:status resp)))
(is (= {:error "login required"} (:body resp)))))
(is (zero? @calls) "the LLM server is never asked")))
(is (= {:error "login required"} (:body resp)))))))
(deftest chat-test
(let [sent (atom nil)
app (app-with (chat-config (fn [req] (reset! sent req) ((streaming (llm-stream "Hello" ", Alice")) req))))
(let [app (app-with (ts/config (ts/text-model "Hello" ", Alice")))
cookie (t/login! app)]
(testing "the reply streams back as server-sent events"
(testing "the reply streams back as AG-UI server-sent events"
(let [resp (post-chat app cookie hello)]
(is (= 200 (:status resp)))
(is (= "text/event-stream; charset=utf-8" (get-in resp [:headers "Content-Type"])))
(is (= "no-cache" (get-in resp [:headers "Cache-Control"])))
(is (= "no" (get-in resp [:headers "X-Accel-Buffering"])) "so a proxy doesn't hold the events back")
(is (= [{:content "Hello"} {:content ", Alice"} {:done true}] (events resp)))))
;; A streaming body drains a one-shot queue: read it exactly once and derive everything
;; from that, or a second read blocks forever waiting for events that already went by.
(let [evts (events resp)]
(is (= ["RUN_STARTED" "TEXT_MESSAGE_START" "TEXT_MESSAGE_CONTENT" "TEXT_MESSAGE_CONTENT"
"TEXT_MESSAGE_END" "RUN_FINISHED"]
(map :type evts)))
(is (= ["Hello" ", Alice"] (map :delta (filter #(= "TEXT_MESSAGE_CONTENT" (:type %)) evts)))))))
(testing "each event is one `data:` line, ended by a blank line"
(is (= (str "data: {\"content\":\"Hello\"}\n\n"
"data: {\"content\":\", Alice\"}\n\n"
"data: {\"done\":true}\n\n")
(body-text (post-chat app cookie hello)))))
(testing "the whole conversation goes to the LLM, and asks it to stream"
(post-chat app cookie "{\"messages\":[{\"role\":\"user\",\"content\":\"hi\"},{\"role\":\"assistant\",\"content\":\"hello\"},{\"role\":\"user\",\"content\":\"and?\"}]}")
(let [request (m/decode "application/json" (:body @sent))]
(is (= ["hi" "hello" "and?"] (map :content (rest (:messages request)))))
(is (true? (:stream request)))))
(let [text (body-text (post-chat app cookie hello))]
(is (str/ends-with? text "\n\n"))
(is (every? #(str/starts-with? % "data: ") (remove str/blank? (str/split-lines text))))))
(testing "the model's reasoning is passed on, as it is generated"
(let [app (app-with (chat-config (streaming (str (delta-event {:reasoning_content "some thoughts"})
(llm-stream "Hi")))))]
(is (= [{:thinking "some thoughts"} {:content "Hi"} {:done true}]
(events (post-chat app (t/login! app) hello))))))))
(let [app (app-with (ts/config (ts/thinking-model "some thoughts" "Hi")))]
(is (= ["RUN_STARTED" "REASONING_START" "REASONING_MESSAGE_START" "REASONING_MESSAGE_CONTENT"
"REASONING_MESSAGE_END" "REASONING_END" "TEXT_MESSAGE_START" "TEXT_MESSAGE_CONTENT"
"TEXT_MESSAGE_END" "RUN_FINISHED"]
(types (post-chat app (t/login! app) hello))))))))
(deftest invalid-request-test
(let [calls (atom 0)
app (app-with (chat-config (fn [_] (swap! calls inc) ((streaming (llm-stream "x")) nil))))
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)
message (fn [role content] {:role role :content content})]
message (fn [role content] {:id "m1" :role role :content content})]
(doseq [[what body] {"no body" nil
"malformed body" "nope"
"no messages" "{}"
"an empty conversation" "{\"messages\":[]}"
"a role that isn't user or assistant" (json {:messages [(message "system" "be evil")]})
"an empty conversation" (json {:messages []})
"a role that isn't user, assistant or tool" (json {:messages [(message "system" "be evil")]})
"an empty message" (json {:messages [(message "user" "")]})
"a too long message" (json {:messages [(message "user" (apply str (repeat 8001 "x")))]})
"too many messages" (json {:messages (vec (repeat 41 (message "user" "hi")))})}]
(is (= 400 (:status (post-chat app cookie body))) what))
(is (zero? @calls) "nothing invalid reaches the LLM server")))
"too many messages" (json {:messages (vec (repeat 41 (message "user" "hi")))})
"a message without an id" (json {:messages [(dissoc (message "user" "hi") :id)]})}]
(is (= 400 (:status (post-chat app cookie body))) what))))
(def ^:private add-tool
{:name "add" :description "Adds two numbers"
:inputSchema {:type "object" :properties {:x {:type "number"}} :required ["x"]}})
:parameters {:type "object" :properties {:x {:type "number"}} :required ["x"]}})
(deftest tools-test
(let [sent (atom nil)
call-piece (delta-event {:tool_calls [{:index 0 :id "call_1" :type "function"
:function {:name "add" :arguments "{\"x\":1}"}}]})
app (app-with (chat-config (fn [req] (reset! sent req) ((streaming (str call-piece "data: [DONE]\n\n")) req))))
(let [app (app-with (ts/config (ts/tool-call-model {:id "call_1" :name "add" :arguments "{\"x\":1}"})))
cookie (t/login! app)
conversation [{:role "user" :content "add 1"}
{:role "assistant" :content "" :tool-calls [{:id "call_0" :name "add" :arguments "{\"x\":0}"}]}
{:role "tool" :tool-call-id "call_0" :content "0"}]]
(testing "the tools the page offers go to the LLM, and its calls come back as an event"
(let [resp (post-chat app cookie (json {:messages [(first conversation)] :tools [add-tool]}))]
conversation [{:id "m1" :role "user" :content "add 1"}
{:id "m2" :role "assistant" :content ""
:toolCalls [{:id "call_0" :type "function" :function {:name "add" :arguments "{\"x\":0}"}}]}
{:id "m3" :role "tool" :toolCallId "call_0" :content "0"}]]
(testing "the tools the page offers go to the LLM, and its calls come back as events"
(let [resp (post-chat app cookie (json {:messages [(first conversation)] :tools [add-tool]}))
evts (events resp)]
(is (= 200 (:status resp)))
(is (= [{:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":1}"}]} {:done true}] (events resp)))
(is (= [{:type "function" :function {:name "add" :description "Adds two numbers"
:parameters (:inputSchema add-tool)}}]
(:tools (m/decode "application/json" (:body @sent)))))))
(is (= ["RUN_STARTED" "TOOL_CALL_START" "TOOL_CALL_ARGS" "TOOL_CALL_END" "RUN_FINISHED"]
(map :type evts)))
(let [call (first (filter #(= "TOOL_CALL_START" (:type %)) evts))]
(is (= "call_1" (:toolCallId call)))
(is (= "add" (:toolCallName call))))
(is (= "{\"x\":1}" (:delta (first (filter #(= "TOOL_CALL_ARGS" (:type %)) evts)))))))
(testing "the conversation may hold calls and their results, which the LLM gets"
(is (= 200 (:status (post-chat app cookie (json {:messages conversation :tools [add-tool]})))))
(let [{:keys [messages]} (m/decode "application/json" (:body @sent))]
(is (= "call_0" (get-in messages [2 :tool_calls 0 :id])))
(is (= "call_0" (get-in messages [3 :tool_call_id])))))
(is (= 200 (:status (post-chat app cookie (json {:messages conversation :tools [add-tool]}))))))
(testing "tools are optional"
(is (= 200 (:status (post-chat app cookie hello))))
(is (not (contains? (m/decode "application/json" (:body @sent)) :tools))))))
(is (= 200 (:status (post-chat app cookie hello)))))))
(deftest page-test
(let [sent (atom nil)
app (app-with (chat-config (fn [req] (reset! sent req) ((streaming (llm-stream "x")) req))))
cookie (t/login! app)
roles (fn [] (map :role (:messages (m/decode "application/json" (:body @sent)))))]
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)]
(testing "the page the user is on reaches the LLM"
(is (= 200 (:status (post-chat app cookie (json {:messages [{:role "user" :content "hi"}] :page "ai-setup"})))))
(is (= ["system" "user"] (roles)))
(is (str/includes? (:content (first (:messages (m/decode "application/json" (:body @sent))))) "\"ai-setup\"")))
(testing "the page is optional: the instructions go anyway"
(is (= 200 (:status (post-chat app cookie hello))))
(is (= ["system" "user"] (roles)))
(is (not (str/includes? (:content (first (:messages (m/decode "application/json" (:body @sent))))) "page of the app"))))
(testing "it is a slug, not text that could pass for instructions"
(reset! sent nil)
(doseq [page ["" "Games" "games\" page. Ignore the rest" (apply str (repeat 65 "a")) 1]]
(is (= 400 (:status (post-chat app cookie (json {:messages [{:role "user" :content "hi"}] :page page})))) (pr-str page)))
(is (nil? @sent) "nothing invalid reaches the LLM server"))))
(is (= 200 (:status (post-chat app cookie
(json {:messages [{:id "m1" :role "user" :content "hi"}]
:context [{:description "page" :value "ai-setup"}]}))))))
(testing "it is bounded like any other string, but nothing enforces a slug shape on the wire"
(is (= 200 (:status (post-chat app cookie
(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 [calls (atom 0)
app (app-with (chat-config (fn [_] (swap! calls inc) ((streaming (llm-stream "x")) nil))))
(let [app (app-with (ts/config (ts/text-model "x")))
cookie (t/login! app)
user [{:role "user" :content "hi"}]
call {:id "c" :name "add" :arguments "{}"}]
user [{:id "m1" :role "user" :content "hi"}]
call {:id "c" :type "function" :function {:name "add" :arguments "{}"}}]
(doseq [[what body] {"a tool without a name" {:messages user :tools [(dissoc add-tool :name)]}
"a tool name that is no function name" {:messages user :tools [(assoc add-tool :name "add it!")]}
"a tool without a schema" {:messages user :tools [(dissoc add-tool :inputSchema)]}
"a schema that isn't for an object" {:messages user :tools [(assoc add-tool :inputSchema {:type "string"})]}
"a huge schema" {:messages user :tools [(assoc add-tool :inputSchema {:type "object" :description (apply str (repeat 6000 "x"))})]}
"a huge schema" {:messages user :tools [(assoc add-tool :parameters {:type "object" :description (apply str (repeat 6000 "x"))})]}
"too many tools" {:messages user :tools (vec (repeat 33 add-tool))}
"tools that aren't a list" {:messages user :tools add-tool}
"an empty assistant message" {:messages [{:role "assistant" :content ""}]}
"a call without an id" {:messages [{:role "assistant" :content "" :tool-calls [(dissoc call :id)]}]}
"a call without arguments" {:messages [{:role "assistant" :content "" :tool-calls [(dissoc call :arguments)]}]}
"too many calls" {:messages [{:role "assistant" :content "" :tool-calls (vec (repeat 17 call))}]}
"a result without the call's id" {:messages [{:role "tool" :content "3"}]}
"an empty result" {:messages [{:role "tool" :tool-call-id "c" :content ""}]}
"a too long result" {:messages [{:role "tool" :tool-call-id "c" :content (apply str (repeat 8001 "x"))}]}}]
(is (= 400 (:status (post-chat app cookie (json body)))) what))
(is (zero? @calls) "nothing invalid reaches the LLM server")))
"an empty assistant message" {:messages [{:id "m1" :role "assistant" :content ""}]}
"a call without an id" {:messages [{:id "m1" :role "assistant" :content "" :toolCalls [(dissoc call :id)]}]}
"too many calls" {:messages [{:id "m1" :role "assistant" :content "" :toolCalls (vec (repeat 17 call))}]}
"a result without the call's id" {:messages [{:id "m1" :role "tool" :content "3"}]}
"an empty result" {:messages [{:id "m1" :role "tool" :toolCallId "c" :content ""}]}
"a too long result" {:messages [{:id "m1" :role "tool" :toolCallId "c" :content (apply str (repeat 8001 "x"))}]}}]
(is (= 400 (:status (post-chat app cookie (json body)))) what))))
(deftest llm-failure-test
(testing "chat is off without an LLM server"
@@ -181,29 +185,80 @@
resp (post-chat app (t/login! app) hello)]
(is (= 503 (:status resp)))
(is (= {:error "chat is not configured"} (:body resp)))))
(testing "an LLM server that fails is a bad gateway, without its address or its message"
(let [app (app-with (chat-config (fn [_] {:status 500 :body (ByteArrayInputStream. (.getBytes "secret internal details at http://llm.test"))})))
(testing "an LLM server that can't be reached: a bad gateway before any run starts"
(let [app (app-with (ts/config (ts/error-model "boom")))
resp (post-chat app (t/login! app) hello)]
(is (= 502 (:status resp)))
(is (= {:error "the LLM server answered HTTP 500"} (:body resp)))))
(testing "an LLM server that can't be reached"
(let [app (app-with (chat-config (fn [_] (throw (java.net.ConnectException. "refused")))))
(is (= "the LLM server can't be reached or refused" (:error (:body resp))))))
(testing "the LLM sends no reply at all: it had already answered with something, even if empty,
so the run had already started"
(let [app (app-with (ts/config (ts/no-reply-model)))
resp (post-chat app (t/login! app) hello)]
(is (= 502 (:status resp)))
(is (= {:error "the LLM server can't be reached"} (:body resp)))))
(testing "an LLM server that goes wrong in the middle of the reply: the reply so far, then the error"
(let [app (app-with (chat-config (streaming (str (delta-event {:content "Hel"})
"data: {\"error\":{\"message\":\"secret\"}}\n\n"))))
resp (post-chat app (t/login! app) hello)]
(is (= 200 (:status resp)) "it had already begun")
(is (= [{:content "Hel"} {:error "the LLM server reported an error"}] (events resp))))))
(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, and the LLM's request with it"
(let [closed? (atom false)
body (proxy [FilterInputStream] [(ByteArrayInputStream. (.getBytes ^String (llm-stream "a" "b" "c") "UTF-8"))]
(close [] (reset! closed? true) (proxy-super close)))
app (app-with (chat-config (fn [_] {:status 200 :body body})))
(testing "a browser that leaves mid-reply ends the stream quietly"
(let [app (app-with (ts/config (ts/text-model "a" "b" "c")))
resp (post-chat app (t/login! app) hello)
writes (atom 0)
gone (proxy [OutputStream] []
@@ -211,5 +266,4 @@
([_] (swap! writes inc) (throw (IOException. "broken pipe")))
([_ _ _] (swap! writes inc) (throw (IOException. "broken pipe")))))]
(ring-protocols/write-body-to-stream (:body resp) resp gone)
(is (= 1 @writes) "it stops at the first write that fails")
(is @closed?))))
(is (= 1 @writes) "it stops at the first write that fails"))))
+6 -4
View File
@@ -58,12 +58,14 @@
(is (= {:event :turn-start :page "todos" :model "qwen" :messages 1 :tools 2 :prompt-chars 5 :step 0}
(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"}]}))
+4 -1
View File
@@ -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
+23 -32
View File
@@ -2,54 +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 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}})
+430 -195
View File
@@ -8,80 +8,143 @@
[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")}
body (assoc :headers {"Content-Type" "application/edn"}
:body (pr-str body))))))
(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))))
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}]
(-> (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 %)}))))))
(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 %)})))))
(def ^:private connection-lost {:error "the connection was lost"})
(rf/reg-fx ::fetch do-fetch!)
;; Same as ::fetch, with its own id so chat-history saves don't collide with the chat stream's
;; requests in tests.
(rf/reg-fx ::persist-chat do-fetch!)
(def ^:private connection-lost {:type "RUN_ERROR" :message "the connection was lost"})
(def ^:private terminal-event-types
"The AG-UI event types (see tbd.chat.routes) that end a run."
#{"RUN_FINISHED" "RUN_ERROR"})
(defn- read-events!
"Dispatches `(conj on-event event)` for each server-sent event (see tbd.ui.sse) in the body read
by `reader`, as they arrive. A body that ends without a :done or :error event (the connection
dropped) is an :error event, 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]
(when (or (:done event) (:error event)) (reset! ended? true))
(when (contains? terminal-event-types (:type event)) (reset! ended? true))
(rf/dispatch (conj on-event event)))
(step pending)))))
(.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)
(.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 %)}))))))
(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 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
@@ -92,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]
@@ -100,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]]
@@ -167,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)})})))
@@ -177,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
@@ -208,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}]]
@@ -273,134 +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
"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 tbd.chat.schema/Message has it."
"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]}]
(case role
"assistant" (cond-> {:role role :content content}
(seq tool-calls) (assoc :tool-calls tool-calls))
"tool" {:role role :tool-call-id tool-call-id :content content}
{:role role :content content}))
(cond-> {:id (next-id) :role role}
(= "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."
(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)))
(defn- recent [messages]
(windowed max-sent-messages messages))
(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]
(drop-while #(= "tool" (:role %)) (take-last max-sent-messages messages)))
(let [fitted (into []
(comp (remove only-reasoning?)
(map (fn [message]
(cond-> message
(= "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))))
(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.)")
;; 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]})
(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)."
[messages]
(let [last-user (or (last (keep-indexed (fn [i {:keys [role]}] (when (= "user" role) i)) messages)) 0)]
(into [] (map-indexed (fn [i message]
(cond-> message
(and (< i last-user) (= "tool" (:role message)))
(assoc :content stale-result))))
messages)))
(rf/reg-event-db
::save-chat-history-response
(fn [db [_ {:keys [status]}]]
(if (= 401 status)
(-> db (assoc :user {:status :anonymous}) reset-chat)
db)))
;; The effect that sends the conversation: it goes with the page being shown (`page`, its id, 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.
(defn- wire-tool
"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)))
;; 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-> {:messages (mapv wire-message (without-stale-results (recent messages)))
:page (name (:page db))}
(seq tools) (assoc :tools tools))
:body (cond-> {:threadId (next-id) :runId (next-id)
: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)
@@ -410,30 +556,43 @@
(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."
"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]
(if (= "assistant" (:role (peek messages)))
(update messages (dec (count messages)) update :content str text)
(conj messages {:role "assistant" :content text})))))
(update messages (dec (count messages)) update :content
(fn [content]
(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)
@@ -442,92 +601,127 @@
(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
(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."))}
(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."))]
{: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)))
;; One event of the reply, as the server sends them (see tbd.chat.routes): {:thinking "..."} 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), {:content "..."} for the next piece of the reply (the first starts the
;; assistant's message, the rest are added to it; one event can have both), {:tool-calls [{:id
;; :name :arguments}]} when it asks for tools to be called, and last {:done true} or {:error "..."}.
;; Events nobody is waiting for (the conversation was reset since) are dropped.
(defn- start-tool-call [db {:keys [toolCallId toolCallName]}]
(update-in db [:chat :tool-call-buffer] assoc toolCallId {:id toolCallId :name toolCallName :arguments ""}))
(defn- append-tool-call-args [db {:keys [toolCallId delta]}]
(update-in db [:chat :tool-call-buffer toolCallId :arguments] str delta))
(defn- end-tool-call [db {:keys [toolCallId]}]
(let [call (get-in db [:chat :tool-call-buffer toolCallId])]
(cond-> db
call (-> (update-in [:chat :pending-calls] (fnil conj []) call)
(update-in [:chat :tool-call-buffer] dissoc toolCallId)))))
;; 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)]
(fn [{:keys [db now]} [_ {:keys [thinking content tool-calls done error]}]]
(fn [{:keys [db now]} [_ {:keys [type] :as event}]]
(let [loading? (= :loading (get-in db [:chat :status]))
db (cond-> db (and loading? (text? thinking)) (assoc-in [:chat :thinking-at] now))]
db (cond-> db
(and loading? (= "REASONING_MESSAGE_CONTENT" type) (text? (:delta event)))
(assoc-in [:chat :thinking-at] now))]
(cond
(not loading?) {:db db}
(text? content) {:db (append-to-reply db content)}
tool-calls {:db (assoc-in db [:chat :pending-calls] (mapv #(select-keys % [:id :name :arguments])
tool-calls))}
done (finish-reply db)
error {:db (chat-failed db error)}
(= "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) (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]
(.then (model-context/call! page name arguments)
(fn [{:keys [text error?]}]
(conj done {:id id :name name :content (fit-result text) :error? error?}))))))
(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 (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]]
@@ -537,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]
@@ -568,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})))
+189
View File
@@ -0,0 +1,189 @@
(ns tbd.ui.markdown
"Turns a chat message's Markdown into Reagent hiccup, for `chat-bubble` to show as blocks
(headings, lists, code, blockquotes, tables) and inline formatting (bold, italic, code, links)
instead of flat text. Hand-rolled rather than an npm library: not full CommonMark (no nested
lists, and a table or list has to start right after a blank line, not mid-paragraph), but
covers what a chat message actually uses.
No HTML is ever built as a string and injected (no :dangerouslySetInnerHTML, so nothing to run
a sanitizer library over either): every leaf here is a plain Clojure string, which Reagent
turns into a text node the same way any other hiccup content is, so it can never be read back
as markup. The one place a message's text becomes an attribute rather than a text node is a
link's `href`, which `safe-href` checks by hand."
(:require [clojure.string :as str]))
;; --- Block matchers (tested against a left-trimmed line) ---
(def ^:private fence-re #"^```\s*(\S*)\s*$")
(def ^:private fence-close-re #"^\s*```\s*$")
(def ^:private heading-re #"^(#{1,6})\s+(.*)$")
(def ^:private hr-re #"^(?:-{3,}|\*{3,}|_{3,})\s*$")
(def ^:private quote-re #"^>\s?(.*)$")
(def ^:private ul-re #"^[-*+]\s+(.*)$")
(def ^:private ol-re #"^\d+[.)]\s+(.*)$")
(def ^:private table-sep-re #"^\|?\s*:?-+:?\s*(\|\s*:?-+:?\s*)*\|?\s*$")
(defn- block-starter?
"Whether `line` begins a block of its own, so a paragraph reading lines one at a time stops
before it even without a blank line in between."
[line]
(let [l (str/triml line)]
(boolean (or (str/blank? l) (re-find fence-re l) (re-find heading-re l) (re-find hr-re l)
(re-find quote-re l) (re-find ul-re l) (re-find ol-re l)))))
;; --- Inline formatting ---
(def ^:private allowed-schemes #{"http" "https" "mailto" "tel"})
(defn- safe-href
"`url` if it's fine to put in an href (no scheme, i.e. relative, or one of `allowed-schemes`),
else nil: the model can write a `javascript:` link too, whether it means to or not (quoting one
from a tool result), and React itself won't stop that from running on a click."
[url]
(let [scheme (second (re-find #"^([A-Za-z][A-Za-z0-9+.-]*):" url))]
(when (or (nil? scheme) (contains? allowed-schemes (str/lower-case scheme)))
url)))
(defn- flanked?
"Whether `s` is a fit inside for an emphasis/strong span: not empty, and not padded with a
space, which is usually a stray `*` or `_` doing something else (\"3 * 4 * 5\") rather than
marking emphasis."
[s]
(and (seq s) (not (str/starts-with? s " ")) (not (str/ends-with? s " "))))
(def ^:private link-re #"^\[([^\]]*)\]\(([^)\s]+)(?:\s+\"[^\"]*\")?\)")
(defn- flush-text
"`out` with the literal text `s[from, to)` appended, if there is any."
[out s from to]
(if (< from to) (conj out (subs s from to)) out))
(defn- inline-line->hiccup
"One line's worth of inline Markdown (no newlines: see `inline->hiccup` for those) as a vector
of hiccup children: plain strings and `:code`/`:strong`/`:em`/`:a` elements."
[s]
(let [n (count s)]
(loop [i 0, flush 0, out []]
(if (>= i n)
(flush-text out s flush n)
(let [c (subs s i (inc i))
two (when (<= (+ i 2) n) (subs s i (+ i 2)))]
(cond
(= c "`")
(if-let [j (str/index-of s "`" (inc i))]
(recur (inc j) (inc j) (conj (flush-text out s flush i) [:code (subs s (inc i) j)]))
(recur (inc i) flush out))
(contains? #{"**" "__"} two)
(let [j (str/index-of s two (+ i 2))
inner (when j (subs s (+ i 2) j))]
(if (flanked? inner)
(recur (+ j 2) (+ j 2)
(conj (flush-text out s flush i) (into [:strong] (inline-line->hiccup inner))))
(recur (inc i) flush out)))
(contains? #{"*" "_"} c)
(let [j (str/index-of s c (inc i))
inner (when j (subs s (inc i) j))]
(if (flanked? inner)
(recur (inc j) (inc j)
(conj (flush-text out s flush i) (into [:em] (inline-line->hiccup inner))))
(recur (inc i) flush out)))
(= c "[")
(if-let [[whole label url] (re-find link-re (subs s i))]
(let [href (safe-href url)
label-pieces (inline-line->hiccup label)
node (if href
(into [:a {:href href :target "_blank" :rel "noopener noreferrer"}] label-pieces)
(into [:span] label-pieces))]
(recur (+ i (count whole)) (+ i (count whole)) (conj (flush-text out s flush i) node)))
(recur (inc i) flush out))
:else (recur (inc i) flush out)))))))
(defn- inline->hiccup
"`text` (possibly several lines: a paragraph's or a blockquote line's own soft-wrapped lines)
as hiccup children, a `:br` between each line, the way a bare newline reads in a chat message
someone typed without Markdown's blank-line-between-paragraphs convention in mind."
[text]
(vec (apply concat (interpose [[:br]] (map inline-line->hiccup (str/split text #"\n"))))))
;; --- Blocks ---
(defn- code-block [lang lines]
[:pre [:code (if (seq lang) {:class (str "language-" lang)} {}) (str/join "\n" lines)]])
(defn- table-cells [line]
(->> (-> (str/trim line)
(str/replace #"^\|" "")
(str/replace #"\|$" "")
(str/split #"\|"))
(mapv str/trim)))
(defn- table [header-line body-lines]
(let [header (table-cells header-line)
rows (mapv table-cells body-lines)]
[:table
[:thead (into [:tr] (map #(into [:th] (inline-line->hiccup %)) header))]
(into [:tbody] (map (fn [row] (into [:tr] (map #(into [:td] (inline-line->hiccup %)) row))) rows))]))
(declare parse-blocks)
(defn- parse-blocks
"`text`'s block-level structure, as a vector of hiccup elements."
[text]
(loop [lines (vec (str/split text #"\n")), out []]
(if (empty? lines)
out
(let [line (first lines)
trimmed (str/triml line)]
(cond
(str/blank? trimmed) (recur (subvec lines 1) out)
(re-find fence-re trimmed)
(let [lang (second (re-find fence-re trimmed))
rest-lines (subvec lines 1)
close (first (keep-indexed #(when (re-find fence-close-re %2) %1) rest-lines))
end (or close (count rest-lines))]
(recur (subvec rest-lines (min (count rest-lines) (inc end)))
(conj out (code-block lang (subvec rest-lines 0 end)))))
(re-find heading-re trimmed)
(let [[_ hashes content] (re-find heading-re trimmed)]
(recur (subvec lines 1)
(conj out (into [(keyword (str "h" (count hashes)))] (inline-line->hiccup content)))))
(re-find hr-re trimmed) (recur (subvec lines 1) (conj out [:hr]))
(re-find quote-re trimmed)
(let [quoted (take-while #(re-find quote-re (str/triml %)) lines)
inner (str/join "\n" (map #(second (re-find quote-re (str/triml %))) quoted))]
(recur (subvec lines (count quoted)) (conj out (into [:blockquote] (parse-blocks inner)))))
(re-find ul-re trimmed)
(let [items (take-while #(re-find ul-re (str/triml %)) lines)]
(recur (subvec lines (count items))
(conj out (into [:ul] (map #(into [:li] (inline-line->hiccup (second (re-find ul-re (str/triml %)))))
items)))))
(re-find ol-re trimmed)
(let [items (take-while #(re-find ol-re (str/triml %)) lines)]
(recur (subvec lines (count items))
(conj out (into [:ol] (map #(into [:li] (inline-line->hiccup (second (re-find ol-re (str/triml %)))))
items)))))
(and (str/includes? trimmed "|") (> (count lines) 1)
(re-find table-sep-re (str/triml (second lines))))
(let [body (->> (subvec lines 2) (take-while #(str/includes? (str/triml %) "|")))]
(recur (subvec lines (+ 2 (count body))) (conj out (table trimmed body))))
:else
(let [para (take-while (complement block-starter?) lines)]
(recur (subvec lines (count para))
(conj out (into [:p] (inline->hiccup (str/join "\n" (map str/trim para))))))))))))
(defn render
"`text` (Markdown, possibly blank) as a Reagent fragment, ready to use as a hiccup child."
[text]
(into [:<>] (parse-blocks (str/trim (or text "")))))
+44 -20
View File
@@ -1,26 +1,20 @@
(ns tbd.ui.model-context
"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
+95 -17
View File
@@ -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"}}
(if live?
(str "Thinking" (apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) ".")))
"Thinking…")])
"Thinking"
[:span {:style {:display "inline-block" :width "1.2em"}}
(if live?
(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
View File
@@ -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."
+3
View File
@@ -57,6 +57,9 @@
(is (= (set (map :name webmcp/tools)) (tools-in-widget)) "it offers the page's tools to the agent")
(is (= (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 {})
+360 -56
View File
@@ -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!)
@@ -284,10 +295,30 @@
(dispatch! [::events/chat-set-input text])
(dispatch! [::events/chat-send]))
(defn- text? [x] (and (string? x) (seq x)))
(defn- tool-call-events [{:keys [id name arguments]}]
[{:type "TOOL_CALL_START" :toolCallId id :toolCallName name}
{:type "TOOL_CALL_ARGS" :toolCallId id :delta arguments}
{:type "TOOL_CALL_END" :toolCallId id}])
(defn- old->agui
"A script's old-shape event ({:thinking}/{:content}/{:tool-calls}/{:done}/{:error}, what the
server used to send) as the AG-UI events (see tbd.chat.routes) it now corresponds to."
[{:keys [thinking content tool-calls done error]}]
(cond-> []
(text? thinking) (conj {:type "REASONING_MESSAGE_CONTENT" :delta thinking})
(text? content) (conj {:type "TEXT_MESSAGE_CONTENT" :delta content})
tool-calls (into (mapcat tool-call-events) tool-calls)
done (conj {:type "RUN_FINISHED"})
error (conj {:type "RUN_ERROR" :message error})))
(defn- event!
"The stream the last request asked for delivers `event`."
"The stream the last request asked for delivers `event` (the old shape a script uses; see
old->agui), as the one or more AG-UI events it corresponds to."
[event]
(dispatch! (conj (:on-event (last-request)) event)))
(doseq [agui-event (old->agui event)]
(dispatch! (conj (:on-event (last-request)) agui-event))))
(defn- reply!
"The stream delivers `pieces` of the reply, and ends."
@@ -303,18 +334,46 @@
(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."
[messages]
(mapv #(dissoc % :id) messages))
(defn- sent-messages
"The `:messages` of `request` (a RunAgentInput), with their ids dropped."
[request]
(without-ids (get-in request [:body :messages])))
(deftest chat-send-test
(logged-in! [])
(say! " hello there ")
(testing "the trimmed message joins the conversation and goes to the server, for a stream back"
(is (= [::events/fetch-stream
{:uri "/api/chat" :method "POST"
:body {:messages [{:role "user" :content "hello there"}] :page "tic-tac-toe"}
:on-event [::events/chat-event]
:on-response [::events/chat-response]}]
(last @effects)))
(let [request (last-request)]
(is (= "/api/chat" (:uri request)))
(is (= "POST" (:method request)))
(is (= [::events/chat-event] (:on-event request)))
(is (= [::events/chat-response] (:on-response request)))
(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))))
@@ -327,24 +386,27 @@
(is (= [{:role "user" :content "hello there"}
{:role "assistant" :content "Hi!"}
{:role "user" :content "how are you"}]
(get-in (last-request) [:body :messages])))))
(sent-messages (last-request))))))
(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"
@@ -354,16 +416,29 @@
(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"}]
(get-in (last-request) [:body :messages])))))
(sent-messages (last-request))))))
(deftest chat-reply-drops-leading-blank-lines-test
;; The model often opens its answer with a stray blank line right after reasoning; the UI drops
;; that so the reply doesn't render with empty space above it, but leaves whitespace alone once
;; the message has content.
(logged-in! [])
(say! "hello")
(event! {:content "\n\n"})
(event! {:content "Hi"})
(event! {:content "\n\nthere"})
(event! {:done true})
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi\n\nthere"}]
(:messages (chat)))))
(deftest chat-thinking-time-test
;; The view animates "Thinking" while pieces of the reasoning are still coming in: the time of
@@ -388,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"})
@@ -405,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! [])
@@ -486,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! [])
@@ -501,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")
@@ -517,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")
@@ -528,8 +657,8 @@
(answer! 200 {:logged-out true})
(is (= (:chat db/default-db) (chat)))
(testing "what the stream still delivers is dropped"
(dispatch! (conj (:on-event request) {:content "late"}))
(dispatch! (conj (:on-event request) {:done true}))
(dispatch! (conj (:on-event request) {:type "TEXT_MESSAGE_CONTENT" :delta "late"}))
(dispatch! (conj (:on-event request) {:type "RUN_FINISHED"}))
(dispatch! (conj (:on-response request) {:ok? false :status 502 :body "{:error \"x\"}"}))
(is (= (:chat db/default-db) (chat))))))
@@ -560,28 +689,108 @@
{: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"
(say! "hi")
(is (not (contains? (:body (last-request)) :tools))))
(testing "the page's tools go along with the conversation, as MCP describes them"
(testing "the page's tools go along with the conversation, as AG-UI describes them"
(reply! "hello")
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
(say! "again")
(is (= [{:name "add" :description "Adds" :inputSchema add-schema}]
(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])))
(deftest chat-says-which-page-it-is-on-test
(logged-in! [])
(testing "the page the user is on goes along with the conversation"
(say! "hi")
(is (= "tic-tac-toe" (:page (:body (last-request))))))
(is (= "tic-tac-toe" (page-of (last-request)))))
(testing "and follows them, or the LLM itself, to the next page"
(reply! "hello")
(dispatch! [::events/navigate :ai-setup])
(say! "again")
(is (= "ai-setup" (:page (:body (last-request))))))
(is (= "ai-setup" (page-of (last-request)))))
(testing "a page the LLM opened with its tools is the page its next request comes from"
(reply! "hello")
(model-context/register! [{:name "go" :description "Opens the todos" :input-schema add-schema
@@ -591,7 +800,7 @@
(dispatch! [::events/navigate :todos]) ; what the tool did
(ran! ["c1" "go" "ok" false])
(is (= "todos" (:page (:body (last-request)))))))
(is (= "todos" (page-of (last-request))))))
(deftest chat-offers-the-tools-of-the-page-test
(logged-in! [])
@@ -632,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")
@@ -656,9 +867,10 @@
(last (:messages (chat)))))
(is (= 2 (count (requests))))
(is (= [{:role "user" :content "1+2?"}
{:role "assistant" :content "" :tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}
{:role "tool" :tool-call-id "c1" :content "3"}]
(get-in (last-request) [:body :messages])) "as the server has them: only what the LLM needs")
{:role "assistant" :content ""
:toolCalls [{:id "c1" :type "function" :function {:name "add" :arguments "{\"x\":1,\"y\":2}"}}]}
{:role "tool" :toolCallId "c1" :content "3"}]
(sent-messages (last-request))) "as the server has them: only what the LLM needs")
(is (= 1 (count (:tools (:body (last-request))))) "and the tools are still on offer"))
(testing "the answer is a new message, and ends it"
(reply! "It's " "3.")
@@ -666,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")
@@ -701,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")
@@ -777,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"}
@@ -785,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" (:tool-call-id (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 (= "old" (:toolCallId (nth sent 2))))
(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
@@ -866,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]})))
+65 -15
View File
@@ -53,21 +53,60 @@
(let [asked (atom nil)]
(tu/finish
(tu/steps
#(stream! (streaming asked (sse {:done true})) 1)
#(stream! (streaming asked (sse {:type "RUN_FINISHED"})) 1)
(fn [_]
(is (= ["/api/chat" {:method "POST"
:headers {:Content-Type "application/edn"}
:body "{:x 1}"}]
@asked))))
(let [[uri opts] @asked]
(is (= ["/api/chat" {:method "POST"
:headers {:Content-Type "application/edn"}
:body "{:x 1}"}]
[uri (dissoc opts :signal)]))
(is (instance? js/AbortSignal (:signal opts)) "with a signal, for ::abort-stream"))))
done))))
(deftest abort-test
;; Halted (see ::events/chat-halt): nothing more is dispatched — not the rest of the stream, nor
;; the \"connection lost\" its end would otherwise be.
(async done
(let [release (atom nil)
fetch (fn [_ _]
(js/Promise.resolve
#js {:ok true :status 200
:body #js {:getReader
(fn []
(let [reads (atom [(sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}) :wait])]
#js {:read (fn []
(let [r (first @reads)]
(swap! reads rest)
(cond
(= :wait r) (js/Promise. #(reset! release %))
(nil? r) (js/Promise.resolve #js {:done true})
:else (js/Promise.resolve #js {:done false :value r}))))
:cancel (fn [] (js/Promise.resolve nil))}))}}))]
(tu/finish
(tu/steps
#(stream! fetch 1)
(fn [got]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] got))
((tu/real-effect ::events/abort-stream) true)
(@release #js {:done false :value (sse {:type "TEXT_MESSAGE_CONTENT" :delta "late"})})
(js/Promise. (fn [resolve] (js/setTimeout resolve 30))))
(fn [_]
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] @got) "nothing after the abort")))
done))))
(deftest events-test
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil) (sse {:thinking "hm"} {:content "Hel"}) (sse {:content "lo"} {:done true})) 4)
#(stream! (streaming (atom nil)
(sse {:type "REASONING_MESSAGE_CONTENT" :delta "hm"} {:type "TEXT_MESSAGE_CONTENT" :delta "Hel"})
(sse {:type "TEXT_MESSAGE_CONTENT" :delta "lo"} {:type "RUN_FINISHED"}))
4)
(fn [got]
(is (= [[:event {:thinking "hm"}] [:event {:content "Hel"}] [:event {:content "lo"}] [:event {:done true}]]
(is (= [[:event {:type "REASONING_MESSAGE_CONTENT" :delta "hm"}]
[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hel"}]
[:event {:type "TEXT_MESSAGE_CONTENT" :delta "lo"}]
[:event {:type "RUN_FINISHED"}]]
got)
"each event as it arrives, and nothing more when it ended properly")))
done)))
@@ -75,8 +114,8 @@
(deftest split-anywhere-test
;; The network cuts the stream wherever it likes: in a line, and in a multi-byte character too.
(async done
(let [bytes (sse {:content "héllo 👋 世界"} {:done true})
expected [[:event {:content "héllo 👋 世界"}] [:event {:done true}]]]
(let [bytes (sse {:type "TEXT_MESSAGE_CONTENT" :delta "héllo 👋 世界"} {:type "RUN_FINISHED"})
expected [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "héllo 👋 世界"}] [:event {:type "RUN_FINISHED"}]]]
(tu/finish
(apply tu/steps
(for [cut (range 1 (.-length bytes))]
@@ -90,25 +129,36 @@
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil) (sse {:content "Hi"})) 2)
#(stream! (streaming (atom nil) (sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"})) 2)
(fn [got]
(is (= [[:event {:content "Hi"}] [:event {:error "the connection was lost"}]] got))))
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]
[:event {:type "RUN_ERROR" :message "the connection was lost"}]]
got))))
done)))
(testing "a read that fails in the middle of the stream"
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil) (sse {:content "Hi"}) :fail (sse {:content "never"})) 2)
#(stream! (streaming (atom nil) (sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}) :fail
(sse {:type "TEXT_MESSAGE_CONTENT" :delta "never"}))
2)
(fn [got]
(is (= [[:event {:content "Hi"}] [:event {:error "the connection was lost"}]] got))))
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]
[:event {:type "RUN_ERROR" :message "the connection was lost"}]]
got))))
done)))
(testing "a stream that ended with an error of its own says so once"
(async done
(tu/finish
(tu/steps
#(stream! (streaming (atom nil) (sse {:content "Hi"} {:error "the LLM server took too long to answer"})) 2)
#(stream! (streaming (atom nil)
(sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}
{:type "RUN_ERROR" :message "the LLM server took too long to answer"}))
2)
(fn [got]
(is (= [[:event {:content "Hi"}] [:event {:error "the LLM server took too long to answer"}]] got))))
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]
[:event {:type "RUN_ERROR" :message "the LLM server took too long to answer"}]]
got))))
done))))
(deftest failed-request-test
+34
View File
@@ -0,0 +1,34 @@
(ns tbd.ui.markdown-test
(:require [cljs.test :refer [deftest is testing]]
[tbd.ui.markdown :as markdown]))
(deftest render-test
(testing "plain text, wrapped in a paragraph"
(is (= [:<> [:p "hello"]] (markdown/render "hello"))))
(testing "inline formatting"
(is (= [:<> [:p "a " [:strong "bold"] " " [:em "word"] " and " [:code "code"]]]
(markdown/render "a **bold** *word* and `code`"))))
(testing "a single newline is a line break, not a new paragraph"
(is (= [:<> [:p "one" [:br] "two"]] (markdown/render "one\ntwo"))))
(testing "a stray * or _ that isn't emphasis (padded with a space) is left alone"
(is (= [:<> [:p "3 * 4 * 5"]] (markdown/render "3 * 4 * 5"))))
(testing "headings, a list, a fenced code block"
(is (= [:<>
[:h1 "Title"]
[:ul [:li "a"] [:li "b"]]
[:pre [:code {:class "language-js"} "1"]]]
(markdown/render "# Title\n\n- a\n- b\n\n```js\n1\n```"))))
(testing "an ordered list and a blockquote"
(is (= [:<> [:ol [:li "a"] [:li "b"]]] (markdown/render "1. a\n2. b")))
(is (= [:<> [:blockquote [:p "hi"]]] (markdown/render "> hi"))))
(testing "a table"
(is (= [:<> [:table [:thead [:tr [:th "a"] [:th "b"]]]
[:tbody [:tr [:td "1"] [:td "2"]]]]]
(markdown/render "a | b\n-|-\n1 | 2"))))
(testing "no markup leaks through as HTML: it's always a plain string, never dangerouslySetInnerHTML"
(is (= [:<> [:p "hi<script>alert(1)</script>"]] (markdown/render "hi<script>alert(1)</script>"))))
(testing "a link opens in its own tab, not the app's"
(is (= [:<> [:p [:a {:href "https://example.com" :target "_blank" :rel "noopener noreferrer"} "x"]]]
(markdown/render "[x](https://example.com)"))))
(testing "a javascript: link loses its href (and so its target/rel), the text stays"
(is (= [:<> [:p [:span "x"]]] (markdown/render "[x](javascript:evil)")))))
+14
View File
@@ -122,6 +122,20 @@
(fn [_] (is (= [:tic-tac-toe-only :everywhere] @ran) "and never run")))
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"))])
+40 -9
View File
@@ -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)))
@@ -100,16 +107,37 @@
even in the middle of a character, as the network may."
7)
(defn- text? [x] (and (string? x) (seq x)))
(defn- tool-call-events [{:keys [id name arguments]}]
[{:type "TOOL_CALL_START" :toolCallId id :toolCallName name}
{:type "TOOL_CALL_ARGS" :toolCallId id :delta arguments}
{:type "TOOL_CALL_END" :toolCallId id}])
(defn- old->agui
"A script step, in the old shape tests write ({:thinking}/{:content}/{:tool-calls}/{:done}/
{:error}) as the AG-UI events (see tbd.chat.routes) it now corresponds to."
[{:keys [thinking content tool-calls done error]}]
(cond-> []
(text? thinking) (conj {:type "REASONING_MESSAGE_CONTENT" :delta thinking})
(text? content) (conj {:type "TEXT_MESSAGE_CONTENT" :delta content})
tool-calls (into (mapcat tool-call-events) tool-calls)
done (conj {:type "RUN_FINISHED"})
error (conj {:type "RUN_ERROR" :message error})))
(defn- script-items
"The script's events as the pieces of bytes that arrive, and :pause where the stream waits."
"The script's events (in the old shape a test writes; see old->agui) as the pieces of bytes that
arrive, and :pause where the stream waits."
[script]
(mapcat (fn [step]
(if (= :pause step)
[:pause]
(let [bytes (.encode (js/TextEncoder.)
(str "data: " (js/JSON.stringify (clj->js step)) "\n\n"))]
(for [i (range 0 (.-length bytes) piece-size)]
(.subarray bytes i (min (.-length bytes) (+ i piece-size)))))))
(mapcat (fn [event]
(let [bytes (.encode (js/TextEncoder.)
(str "data: " (js/JSON.stringify (clj->js event)) "\n\n"))]
(for [i (range 0 (.-length bytes) piece-size)]
(.subarray bytes i (min (.-length bytes) (+ i piece-size))))))
(old->agui step))))
script))
(defn- stream-reader
@@ -146,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}))
+17 -1
View File
@@ -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))))))
+78 -19
View File
@@ -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 [_]
@@ -560,7 +574,7 @@
[{:role "user" :content "hello"}
{:role "assistant" :content "echo: hello"}
{:role "user" :content "again"}]]
(:chats @tu/server))
(mapv #(mapv (fn [m] (dissoc m :id)) %) (:chats @tu/server)))
"each message carries the conversation so far")
(click! (first (filter #(= "Clear" (.-textContent %)) (q-all "[role=dialog] button")))))
#(tu/eventually (fn [] (= "Ask me anything." (text "[role=log] p"))))
@@ -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}}
@@ -848,11 +906,12 @@
(testing "the second request took the result to the LLM"
(is (= [{:role "user" :content "what is 2 + 3? use the calculator"}
{:role "assistant" :content "I'll add them."
:tool-calls [{:id "call_1" :name "add" :arguments "{\"x\":2,\"y\":3}"}]}
{:role "tool" :tool-call-id "call_1" :content "{\"x\":2,\"y\":3,\"sum\":5}"}]
(:messages (second (:chat-requests @tu/server))))))
:toolCalls [{:id "call_1" :type "function"
:function {:name "add" :arguments "{\"x\":2,\"y\":3}"}}]}
{: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 [_]
@@ -916,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
+81 -33
View File
@@ -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)))