ajet/tbd
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

scope tools by page
CI / Test + coverage (push) Successful in 3m34s
Details

Browse Source
This commit is contained in:
Adam Jeniski
2026-09-21 14:01:34 -09:00
parent a53f0c3621
commit bf38f7b1be
37 changed files with 1894 additions and 359 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.env-template
+4
View File
@@ -49,6 +49,10 @@ 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.
# CHAT_TRACE_FILE=data/chat-trace.jsonl
# --- WebMCP origin trial ------------------------------------------------------
# Chrome's WebMCP (the UI's browser tools) is in an origin trial. Register BASE_URL's origin at
Dockerfile
+2
View File
@@ -17,6 +17,7 @@ COPY ui/shadow-cljs.edn ./
RUN npx shadow-cljs classpath > /dev/null
FROM ui-base AS ui
COPY shared /build/shared
COPY ui/src ./src
RUN npx shadow-cljs release app
@@ -25,6 +26,7 @@ RUN npx shadow-cljs release app
# `npm run coverage` (script/docker-ui-coverage) also writes the report to /build/target/coverage/ui.
FROM ui-base AS ui-test
COPY ui/.c8rc.json ./
COPY shared /build/shared
COPY ui/src ./src
COPY ui/test ./test
CMD ["npm", "test"]
README.md
+96 -20
View File
@@ -48,14 +48,14 @@ 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 (`"games"`, `"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.** 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 |
| `GET` | `/api-docs` | Swagger UI |
| `GET` | `/swagger.json` | OpenAPI/Swagger spec |
| `GET` | `/auth/login` | Starts the Gitea OAuth login (redirects to Gitea) |
| `GET` | `/auth/callback` | OAuth redirect target: completes the login, sets the session cookie, redirects to `/` |
| `POST` | `/auth/logout` | Ends the session |
| `GET` | `/auth/me` | The logged-in user, `{:login "alice" :id 7 :admin? true}` (401 if not logged in) |
| `GET` | `/api/todos` | **Login required.** Your todos: `{:todos [{:id 1 :owner-id 7 :title "buy milk" :done false :created-at 1700000000000 :updated-at 1700000000000}]}` |
| `GET` | `/api/todos` | **Login required.** Your todos: `{:todos [{:id "3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b" :owner-id 7 :title "buy milk" :done false :created-at 1700000000000 :updated-at 1700000000000}]}` |
| `POST` | `/api/todos` | **Login required.** Body `{"title": "buy milk"}` creates a todo and returns it with `201` (400 if the title is blank or over 200 characters) |
| `GET` | `/api/todos/:id` | **Login required.** One todo (404 if it doesn't exist or isn't yours) |
| `PATCH` | `/api/todos/:id` | **Login required.** Body with `title` and/or `done` (`{"done": true}`) updates the todo and returns it (400 for an empty or invalid change, 404 as above) |
@@ -95,6 +95,11 @@ Todos are stored in a local [SQLite](https://www.sqlite.org/) file, `data/todo.d
elsewhere. In Docker, mount a volume at that path (e.g. `docker run -v tbd-data:/app/data ...`), or the
todos are lost with the container.
Every id the app issues (a todo's, an OAuth grant's) is a UUID, never a number: a model that reads `7` as a
todo's id mixes it up with a 7 in a title. (`owner-id` is the user's id in Gitea, which it issues, so it stays
a number.) A database from before that is migrated when it is opened: rows keep their order and get UUIDs, so
the ids in URLs or notes from before no longer work.
```bash
# after logging in in a browser, copy the `tbd-session` cookie value:
curl -XPOST localhost:3000/api/todos -H 'Cookie: tbd-session=...' \
@@ -186,6 +191,7 @@ login, **403** for a logged-in non-admin. With no allowlist, nobody is an admin.
| `TODO_DB_PATH` | SQLite file for the todo group (default `data/todo.db`) |
| `OAUTH_DB_PATH` | SQLite file for the MCP OAuth server: registered clients, codes and tokens (default `data/oauth.db`). Mount a volume for it in Docker too, or every MCP client has to be approved again after each restart |
| `LMSTUDIO_URL`, `LMSTUDIO_MODEL`, `LMSTUDIO_API_KEY`, `LMSTUDIO_TIMEOUT_SECONDS` | The LM Studio server behind the [chatbot](#chatbot). Only the URL is needed |
| `CHAT_TRACE_FILE` | Optional. A file to append a JSON trace of every chatbot turn to, [with the model's full reasoning and replies](#watching-the-chatbot-think). Off by default |
| `NREPL_PORT`, `NREPL_BIND` | Where the debug nREPL listens (default `7888` on `127.0.0.1`) |
Sessions live in an encrypted, signed, `HttpOnly`, `SameSite=Lax` cookie and expire after 8 hours
@@ -211,12 +217,13 @@ restarts), so switch it off when you're done.
`ui/` is a [re-frame](https://github.com/day8/re-frame) app (ClojureScript, React 19 via
[Reagent](https://reagent-project.github.io/)) built with [shadow-cljs](https://github.com/thheller/shadow-cljs).
It has three pages, as tabs across the top. Each has its own address in the URL's fragment (`/#/games`,
`/#/todos`, `/#/ai-setup`), so the server only ever serves `/`, and a page can be bookmarked or reloaded.
It has four pages, as tabs across the top. Each has its own address in the URL's fragment (`/#/tic-tac-toe`,
`/#/calculator`, `/#/todos`, `/#/ai-setup`), so the server only ever serves `/`, and a page can be bookmarked or reloaded.
| Tab | What's on it |
|-----|--------------|
| Games | Tic-tac-toe (two players on one board, all client side), and a small calculator form that calls `GET /api/add` and shows the sum (or the server's validation error) |
| Tic-tac-toe | Two players on one board, all client side |
| Calculator | A small form that calls `GET /api/add` and shows the sum (or the server's validation error) |
| Todos | Your todo list (add, tick off, delete), backed by `/api/todos`. The tab only shows once you're logged in; its address shows a "Log in" prompt otherwise |
| AI setup | The `claude mcp add ...` command to copy (with this page's own address in it) and the steps to sign in, for adding the [MCP server](#mcp-server) to Claude Code; and how to connect an MCP client to the page's own [browser tools](#browser-mcp-tools-webmcp) |
@@ -267,8 +274,8 @@ what WebMCP's `navigator.modelContext` is to an agent outside the page. The chat
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 #{:games}` is
offered on the Games page and nowhere else (the calculator and tic-tac-toe are games' tools, the
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,
@@ -291,12 +298,14 @@ 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 (`default-system-prompt` in
`src/tbd/chat/core.clj`) 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 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
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).
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"*.
@@ -319,29 +328,95 @@ has loaded), `LMSTUDIO_API_KEY` is sent as a bearer token if the server wants on
answering or between two pieces of it, before the server gives up. Without `LMSTUDIO_URL` the server
still starts (it says so), and the chat panel shows "chat is not configured".
#### Watching the chatbot think
Every request to `/api/chat` is one turn of the model, and every turn is logged on stdout: one
`turn-start` line when it goes out and one `turn-end` line when it ends. The tool loop runs in the browser,
so the server sees each tool result as a fresh request; the turns of one loop are tied together by a `run`
id (a hash of the user's last message), with `step` counting them from 0.
```
[tbd] chat turn-start req=9c1e4a07 run=d4a6cdb3 step=3 page=tic-tac-toe model=qwen messages=8 tools=6 prompt-chars=1180 run-calls=3
[tbd] chat loop-suspect req=9c1e4a07 run=d4a6cdb3 step=3 kind=repeated-call tool=get_tic_tac_toe count=3 args={}
[tbd] chat loop-suspect req=9c1e4a07 run=d4a6cdb3 step=3 kind=repeated-thinking count=8 text="Let me check the board again."
[tbd] chat turn-end req=9c1e4a07 run=d4a6cdb3 step=3 outcome=tool-calls duration-ms=18040 ttft-ms=2210 think-ms=15100 events=1830 thinking-chars=9210 content-chars=0 calls="get_tic_tac_toe{}" flags=repeated-thinking
```
`turn-end` says how it ended (`outcome`: `done`, `tool-calls`, `error`, `upstream-error`, or `aborted` when the
browser went away), how long it took (`ttft-ms` is the wait for the first piece, which includes the LLM
reading the prompt; `think-ms` the time spent reasoning before answering), how much it wrote (`events` is
close to a token count), and `finish-reason` and token counts when the LLM server sends them. `flags` is
the grep handle for a stuck model, with a `loop-suspect` line for each trip as it happens:
| Flag | Means |
| --- | --- |
| `repeated-call` | The same tool was called with the same arguments 3 or more times in one run (checked when the turn starts) |
| `repeated-thinking` | The reasoning said the same sentence again, ignoring case and punctuation: at the 4th time, then the 8th, 16th, ... |
| `long-reasoning` | The reasoning passed 8000 characters, then 16000, ... (only the ones without an answer yet are worrying) |
| `truncated` | The LLM stopped with `finish_reason: length`: it ran out of tokens, typically in a reasoning loop |
These are heuristics for where to look, not verdicts, and nothing is stopped: the server's timeout only
counts *silence*, so a model that reasons forever, out loud, is never cut off by it.
The log has no text of the conversation. To read what the model actually thought, set `CHAT_TRACE_FILE`
(say `data/chat-trace.jsonl`, which git ignores): each turn's entries are appended there as JSON lines, with
the full `reasoning`, `reply` and (in `turn-start`) the `input` messages of the run, the tool results the
model was reacting to. It holds what the user typed, so treat it like the database.
```bash
# the runs that got stuck, and how
jq -c 'select((.flags // []) | length > 0) | {run, step, flags, thinking_chars: ."thinking-chars"}' data/chat-trace.jsonl
# what the model said in one turn
jq -r 'select(.req == "9c1e4a07" and .event == "turn-end") | .reasoning' data/chat-trace.jsonl
```
### Browser MCP tools (WebMCP)
The page also offers tools of its own to your MCP client (Claude), through [WebMCP](https://webmcp.dev):
a small library that adds a widget to the page and lets the page register tools with it. They are the browser-side twin of the
[server's MCP tools](#mcp-server): those work on your data on the server, these work *the page*, doing
what you could do with the mouse and keyboard, so you see it happen. A tool that changes something opens the tab it acts on first (the todo tools open Todos, the game and calculator tools open Games). They are in `ui/src/tbd/ui/webmcp.cljs`,
what you could do with the mouse and keyboard, so you see it happen. A tool that changes something opens the tab it acts on first (the todo tools open Todos, the game tools open Tic-tac-toe, the calculator tools open Calculator). They are in `ui/src/tbd/ui/webmcp.cljs`,
registered with `registerTool` on a `WebMCP` instance (the `@jason.today/webmcp` npm package):
| Tool | What it does |
|------|--------------|
| `ping`, `whoami` | Health check; who is logged in on the page, if anyone |
| `navigate` | Opens a page (`games`, `todos` or `ai-setup`) as a click on its tab would; `todos` needs a login, like its tab. The chatbot is then offered the new page's tools |
| `navigate` | Opens a page (`tic-tac-toe`, `calculator`, `todos` or `ai-setup`) as a click on its tab would; `todos` needs a login, like its tab. The chatbot is then offered the new page's tools |
| `get_calculator` | What the calculator form holds: its two fields and the result it shows |
| `add` | Types `x` and `y` into the calculator, presses Add, and returns the sum the page shows |
| `list_todos`, `get_todo` | The todos the page shows (login required, like the todo list itself) |
| `create_todo` | Types a `title` into the new-todo field, presses Add, returns the new todo |
| `set_todo_done` | Ticks or unticks a todo's checkbox (`id`, `done`) |
| `delete_todo` | Presses a todo's Delete button |
| `list_todos` | The todos the page shows (login required, like the todo list itself) |
| `get_todo` | Reads todos by id (`todos`: a list of `{id}`) |
| `create_todo` | Types each title into the new-todo field and presses Add (`todos`: a list of `{title}`), returns the new todos |
| `set_todo_done` | Ticks or unticks the checkboxes of several todos in one call (`todos`: a list of `{id, done}`), so a bulk change is one tool call |
| `delete_todo` | Presses the Delete button of several todos (`todos`: a list of `{id}`) |
The todo tools take their work as a list, so a batch ("untick all of them") is one tool call: the chatbot
is capped in the tool calls it may make in a turn. A batch is checked in full before its first change is made,
and then made one todo at a time; if one fails part way, the error says how many were done.
Each tool dispatches the same re-frame events the views do and waits for the result to show up in
the app-db, so what the agent sees is what the page shows, server errors included. There is no
`update_todo` with a title as on the server, because the page can't edit one.
Next to the tools the page registers **prompts** and **resources** (`prompts` and `resources` in `webmcp.cljs`),
so a client's lists of them are not empty. They carry the same prompt engineering as the chatbot, from
`shared/tbd/agent/prompt.cljc` (a `.cljc`, on the classpath of both the server and the UI build): act instead
of offering, chain the calls, take obvious defaults, report in a sentence, and play tic-tac-toe by the turn.
The WebMCP bridge sends no server-level instructions, so this is how Claude or Codex learns them:
| Prompt | What it is |
|--------|-----------|
| `drive_the_app` | The instructions, then the `task` you gave it (Claude Code lists it as a slash command). Without a task, the agent asks what you want |
| `play_tic_tac_toe` | Plays a game with you, one move on its own turn, as `side` (`x` or `o`, default `o`) |
| Resource | What it is |
|----------|-----------|
| `webmcp://app/guide` | The instructions, as Markdown: read this first |
| `webmcp://app/state` | JSON: the page that is open, the pages (which need a login) and who is logged in |
The bridge prefixes their names with the page's channel, like the tools'. A client does not read a
resource on its own: mention it (`@`) or ask the agent to read the guide.
To connect (the page's "Browser tools (WebMCP)" section says the same):
1. Add the WebMCP server to your MCP client, once: `npx -y @jason.today/webmcp@latest --config claude`
@@ -409,9 +484,10 @@ src/tbd/
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
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)
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)
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)
deps.edn
+1 -1
View File
@@ -1,4 +1,4 @@
{:paths ["src" "resources" "integration-test"]
{:paths ["src" "shared" "resources" "integration-test"]
:deps
{org.clojure/clojure {:mvn/version "1.12.0"}
ring/ring-jetty-adapter {:mvn/version "1.12.2"}
integration-test/integration_test.bb
+1 -1
View File
@@ -181,7 +181,7 @@
(println "Test 15: the todo API without a session returns 401")
(assert-eq "GET list" 401 (:status (get* (str base-url "/api/todos"))))
(assert-eq "POST create" 401 (:status (post-json* (str base-url "/api/todos") "{\"title\":\"x\"}")))
(assert-eq "GET one" 401 (:status (get* (str base-url "/api/todos/1"))))
(assert-eq "GET one" 401 (:status (get* (str base-url "/api/todos/3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b"))))
(println)
(println "Test 16: POST /mcp without a token returns 401 pointing at the OAuth metadata")
shared/tbd/agent/prompt.cljc
+134
View File
@@ -0,0 +1,134 @@
(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.
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.
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
(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
"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)."
[chain]
(str "Work it out yourself:\n"
"- Detail missing: take the obvious default and go. Ask only when a required argument is genuinely\n"
" unknowable (which of several todos they mean) or when you would delete or overwrite something\n"
" 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"
"\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
(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"
"\"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))
;; --- An MCP client outside the page (Claude, Codex) ---
(def guide
"The instructions of an agent that drives the page from outside, through WebMCP: the resource
the page registers for it to read first, and what a prompt starts from. The WebMCP bridge sends
no `instructions` of its own, so this is where the agent learns that the tools are the page's
and what the user expects of them. Markdown, since a client shows it as a document."
(str "# Driving this web app\n"
"\n"
"You are connected to a web app the user has open in their browser. The tools you were given\n"
"type, click and read on that page, and every call shows on their screen the moment you make it:\n"
"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"
"\n"
act
(work-it-out (str "- Chain calls without stopping. You need an id: list first, then act. Never invent an id, a\n"
" title or the state of the page: read it with a tool.\n"))
"Then report in one short plain sentence, from the tool results: \"Added it.\" \"That's 23.\" The user\n"
"sees the page change, so don't describe what it now shows and don't paste JSON. Say something\n"
"was done only if a tool result says it was. Not being logged in is the user's to fix, on the page:\n"
"tell them so.\n"
"\n"
tic-tac-toe-rules
examples))
(defn task
"The prompt that hands an outside agent a job on the page: `guide`, then the user's `request` if
they gave one (else the agent asks what they want)."
[request]
(str guide
"\n\n"
(if (and (string? request) (seq request))
(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.")))
src/tbd/chat/core.clj
+64 -68
View File
@@ -16,9 +16,14 @@
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."
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])
[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)
@@ -59,7 +64,10 @@
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)"
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 #"/+$" ""))
@@ -67,6 +75,7 @@
: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]}]
@@ -105,45 +114,10 @@
description (assoc :description description))})
(def default-system-prompt
"What the LLM is told about its job. The chatbot is an agent embedded in a UI, not a
conversationalist: what it does shows on the user's screen the moment it does it, so the prompt
is about acting (calling the page's tools in the same turn, chaining them, saying little
afterwards) and about the few cases where it should not. A model that is only asked to be
helpful answers a request for action with an offer of help. It is short and concrete on purpose,
with examples: the models behind LM Studio follow that better than a long list of rules."
(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, 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"
"Work it out yourself:\n"
"- Detail missing: take the obvious default and go. Ask only when a required argument is genuinely\n"
" unknowable (which of several todos they mean) or when you would delete or overwrite something\n"
" and cannot tell what.\n"
"- 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"
"- 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"
"\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: check whose turn it is, move only for your own side, one move, then stop and let the\n"
"person play theirs.\n"
"\n"
"Examples:\n"
"\"add a todo to buy milk\" -> create_todo{\"title\":\"buy milk\"} -> \"Added.\"\n"
"\"tick off the milk one\" -> list_todos -> set_todo_done{\"id\":7,\"done\":true} -> \"Ticked off.\"\n"
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\"\n"
"\"play tic tac toe, you're O\" -> get_tic_tac_toe -> it is X's turn -> \"You're up, X starts.\""))
"What 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
@@ -193,7 +167,9 @@
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."
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)
@@ -201,14 +177,18 @@
(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)]
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))))))))))
(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`."
@@ -234,8 +214,9 @@
(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."
[^InputStream in timeout-seconds emit]
`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 []
@@ -263,15 +244,26 @@
(nil? event) (do (arm!) (recur replied? calls))
(= :end event) (let [calls (finished-calls calls)]
(cond
(seq calls) (do (emit {:tool-calls calls}) (emit {:done true}))
replied? (emit {:done true})
:else (emit {:error (fail "the LLM server sent no reply")})))
(:error event) (emit {:error (fail (:error event) (:detail event))})
(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!)
(when-let [out (not-empty (dissoc event :call-deltas))] (emit out))
(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))))))
@@ -286,21 +278,25 @@
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] :as config} messages tools page]
([{:keys [timeout-seconds http trace] :as config} messages tools page]
(if-not (configured? config)
{:error "chat is not configured" :kind :unavailable}
(try
(let [{:keys [status body]} (http (request config messages tools page))]
(if (= 200 status)
{:ok (fn [emit] (pump body timeout-seconds emit))}
(let [snippet (try (String. (.readNBytes ^InputStream body 200) StandardCharsets/UTF_8)
(catch Exception _ nil))]
(some-> ^Closeable body .close)
{:error (fail (str "the LLM server answered HTTP " status) (str "body: " snippet))
:kind :upstream})))
(catch java.net.http.HttpTimeoutException e
{:error (fail "the LLM server took too long to answer" (.getMessage e)) :kind :upstream})
(catch IOException e
{:error (fail "the LLM server can't be reached" (exception-detail e)) :kind :upstream})
(catch Exception e
{:error (fail "the LLM server sent an unreadable reply" (exception-detail e)) :kind :upstream})))))
(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))))))))
src/tbd/chat/schema.clj
+1 -1
View File
@@ -60,7 +60,7 @@
[:content [:string {:min 1 :max max-message-length}]]]]])
(def Page
"Which page of the UI the user is on: its id, as the UI has it (\"games\", \"ai-setup\"). The server
"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}$"])
src/tbd/chat/trace.clj
+281
View File
@@ -0,0 +1,281 @@
(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.
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:
- 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.
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` (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)."
(:require [clojure.java.io :as io]
[clojure.string :as str]
[muuntaja.core :as m])
(:import (java.time Instant)))
(def reasoning-warn-chars
"Reasoning this long, without an answer or a call yet, is worth a look: a `:long-reasoning` entry
at this many characters, and again at each doubling."
8000)
(def ^:private repeat-min-length
"Shorter sentences (\"Let me check.\") repeat in any reasoning; only longer ones say anything."
20)
(def ^:private repeat-warn-count
"A sentence of the reasoning said this many times is a `:repeated-thinking`; and again at each doubling."
4)
(def ^:private repeated-call-warn-count
"The same tool called with the same arguments this many times in one run is a `:repeated-call`."
3)
(def ^:private max-distinct-sentences 5000)
(def ^:private max-pending-chars 1000)
(def ^:private max-args-length 500)
(def ^:private sample-length 160)
(defn- now-ms [] (quot (System/nanoTime) 1000000))
(defn- truncate [s n]
(let [s (str s)]
(if (> (count s) n) (str (subs s 0 n) "…") s)))
;; --- Reading the conversation ---
(defn run-summary
"What the conversation `messages` (see tbd.chat.schema/Message) says about the tool loop it is in.
A run starts at the user's last message: `:run` is a short hash of it (the same for every turn of
the run, which is what ties their log lines together), `:step` how many assistant messages have
answered it so far (0 for the first turn), `:run-calls` how many tool calls those made,
`:top-call` {:tool :args :count} the call made most often (nil if none), and `:input` the messages
of the run, the user's first."
[messages]
(let [messages (vec messages)
user-at (last (keep-indexed (fn [i {:keys [role]}] (when (= "user" role) i)) messages))
input (if user-at (subvec messages user-at) messages)
answers (filter #(= "assistant" (:role %)) input)
calls (into [] (mapcat :tool-calls) answers)
[[tool args] n] (when (seq calls)
(apply max-key val (frequencies (map (juxt :name :arguments) calls))))]
{:run (if user-at (format "%08x" (bit-and 0xffffffff (hash (:content (messages user-at))))) "-")
:step (count answers)
:run-calls (count calls)
:top-call (when tool {:tool tool :args args :count n})
:input input}))
;; --- Watching the reply ---
(defn- split-sentences
"[complete pending]: the sentences of `text` that are finished (a full stop, question or exclamation
mark, or a line break, ends one), and the rest, which the next piece of text may go on with."
[text]
(let [parts (str/split text #"(?<=[.!?])\s+|\n+" -1)
complete (pop parts)
pending (peek parts)]
(if (> (count pending) max-pending-chars)
[(conj complete pending) ""]
[complete pending])))
(defn- repeat-milestone?
"True at the count that is worth a log line: `repeat-warn-count`, then each doubling of it."
[n]
(and (>= n repeat-warn-count)
(zero? (rem n repeat-warn-count))
(let [q (quot n repeat-warn-count)] (zero? (bit-and q (dec q))))))
(defn- count-sentence
"[seen alerts], with `sentence` counted in `seen` ({normalized sentence count}); an alert if it
has now been said often enough. Case, spacing and the mark that ends it don't make a sentence
another: a model that loops varies those as it likes."
[[seen alerts] sentence]
(let [k (-> sentence str/trim str/lower-case (str/replace #"\s+" " ") (str/replace #"[.!?]+$" ""))]
(if (or (< (count k) repeat-min-length)
(and (not (contains? seen k)) (>= (count seen) max-distinct-sentences)))
[seen alerts]
(let [n (inc (get seen k 0))]
[(assoc seen k n)
(cond-> alerts
(repeat-milestone? n) (conj {:kind :repeated-thinking :count n
:text (truncate sentence sample-length)}))]))))
(defn- think
"[state' alerts] after `text` of the model's reasoning."
[state text now full?]
(let [state (cond-> (-> state
(update :thinking-events inc)
(update :thinking-chars + (count text))
(update :first-thinking-at #(or % now)))
full? (update :reasoning conj text))
[complete pending] (split-sentences (str (:pending state) text))
[seen alerts] (reduce count-sentence [(:seen state) []] complete)
chars (:thinking-chars state)
long? (>= chars (:next-long-warn state))]
[(cond-> (assoc state :pending pending :seen seen)
long? (update :next-long-warn * 2))
(cond-> alerts
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 {:keys [content thinking call-deltas finish-reason usage]} now full?]
(let [state (cond-> (-> state
(update :events inc)
(update :first-event-at #(or % now)))
content (-> (update :content-chars + (count content))
(update :first-content-at #(or % now)))
(and content full?) (update :reply conj content)
(seq call-deltas) (update :first-call-at #(or % now))
finish-reason (assoc :finish-reason finish-reason)
usage (assoc :usage usage))]
(if (seq thinking)
(think state thinking now full?)
[state []])))
;; --- Sinks: where entries go ---
(def ^:private lock (Object.))
(def ^:private field-order
[:req :run :step :kind :outcome :page :model :messages :tools :prompt-chars :run-calls :duration-ms
:ttft-ms :think-ms :events :thinking-chars :content-chars :finish-reason :prompt-tokens
:completion-tokens :count :chars :elapsed-ms :tool :args :text :calls :flags :error :detail])
(def ^:private heavy-fields
"What only the trace file gets."
#{:reasoning :reply :input})
(defn- render-field [k v]
(str (name k) "="
(cond
(keyword? v) (name v)
(= :calls k) (pr-str (str/join "; " (map (fn [{:keys [name args]}] (str name (truncate args 120))) v)))
(and (sequential? v) (every? keyword? v)) (str/join "," (map name v))
(and (string? v) (re-matches #"[\w./:@-]+" v)) v
:else (pr-str v))))
(defn render
"An entry as the line the log gets: `[tbd] chat turn-end req=ab12cd34 outcome=done ...`. Without the
heavy fields (see the ns docstring), and without what is nil or empty."
[{:keys [event] :as entry}]
(let [order (zipmap field-order (range))
fields (->> (reduce dissoc entry (cons :event heavy-fields))
(remove (fn [[_ v]] (or (nil? v) (and (coll? v) (empty? v)))))
(sort-by (fn [[k _]] [(get order k (count field-order)) (name k)])))]
(str "[tbd] chat " (name event) (apply str (for [[k v] fields] (str " " (render-field k v)))))))
(defn- json [data] (slurp (m/encode "application/json" data)))
(defn sink
"A fn that takes entries: prints each with `render`, and appends it to `file`, if there is one, as a
line of JSON with a timestamp and all its fields. A file that can't be written to is complained
about, and never fails the chat."
[file]
(when file (io/make-parents (io/file file)))
(fn [entry]
(locking lock
(println (render entry))
(when file
(try (spit file (str (json (-> (into {} (remove (comp nil? val)) entry)
(assoc :ts (str (Instant/now)))))
"\n")
:append true)
(catch Exception e
(println "[tbd] chat: can't write the trace file" file (str "(" (.getMessage e) ")"))))))))
(defn config-for
"The trace config (what `begin!` takes) for a trace file, or none if `file` is nil: the entries are
logged either way, and the text of the reasoning and the replies goes to the file only."
[file]
{:sink (sink file) :full-text? (some? file) :file file})
(def default-config
"Log lines only."
(config-for nil))
;; --- Tracing a turn ---
(defn- log! [{:keys [sink ids]} event fields]
(try (sink (merge {:event event} ids fields))
(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]}]
(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?
:ids {:req (subs (str (random-uuid)) 0 8) :run run :step step}
:state (atom {:t0 (now-ms) :events 0 :thinking-events 0 :thinking-chars 0
:content-chars 0 :next-long-warn reasoning-warn-chars
:seen {} :pending "" :reasoning [] :reply [] :flags #{}})}]
(log! tracer :turn-start
(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)))
(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 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."
[{: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))))
(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)."
[{:keys [state full-text?] :as tracer} {:keys [outcome calls error detail]}]
(let [s @state]
(when-not (:finished? s)
(swap! state assoc :finished? true)
(let [now (now-ms)
{:keys [t0 first-event-at first-thinking-at first-content-at first-call-at usage]} s
answered-at (or first-content-at first-call-at)
flags (cond-> (:flags s) (= "length" (:finish-reason s)) (conj :truncated))]
(log! tracer :turn-end
(cond-> {:outcome outcome
:duration-ms (- now t0)
:ttft-ms (some-> first-event-at (- t0))
:think-ms (when first-thinking-at (- (or answered-at now) first-thinking-at))
:events (:events s)
:thinking-chars (:thinking-chars s)
:content-chars (:content-chars s)
:finish-reason (:finish-reason s)
:prompt-tokens (:prompt_tokens usage)
:completion-tokens (:completion_tokens usage)
:calls (mapv (fn [{:keys [name arguments]}]
{:name name :args (truncate arguments max-args-length)})
calls)
:error error
:detail detail
:flags (vec (sort flags))}
full-text? (assoc :reasoning (str/join (:reasoning s))
:reply (str/join (:reply s)))))))))
src/tbd/core.clj
+2
View File
@@ -147,6 +147,8 @@
(println "[tbd] WARNING: SESSION_SECRET is not set; logins won't survive a restart"))
(when-not (chat/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)))
(try
(let [server (jetty/run-jetty (wrap-defaults app api-defaults)
{:port port
src/tbd/oauth/db.clj
+23 -17
View File
@@ -6,7 +6,8 @@
[clojure.java.io :as io]
[clojure.string :as str]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]))
[next.jdbc.result-set :as rs]
[tbd.sqlite :as sqlite]))
(def default-path "data/oauth.db")
@@ -17,6 +18,22 @@
(let [path (get env "OAUTH_DB_PATH")]
{:db-path (if (str/blank? path) default-path (str/trim path))})))
;; A user's approval of a client: the current access and refresh token (hashed), replaced
;; together when the refresh token is used. Deleting the row revokes the approval. `id` is a
;; UUID (see tbd.sqlite/new-id); `user_id` is the user's id in Gitea, which the app doesn't issue.
(def ^:private create-grants
"CREATE TABLE IF NOT EXISTS grants (
id TEXT PRIMARY KEY,
client_id TEXT NOT NULL,
user_id INTEGER NOT NULL,
login TEXT NOT NULL,
scope TEXT NOT NULL,
access_hash TEXT NOT NULL UNIQUE,
access_expires_at INTEGER NOT NULL,
refresh_hash TEXT NOT NULL UNIQUE,
refresh_expires_at INTEGER NOT NULL,
created_at INTEGER NOT NULL)")
(defn- migrate! [ds]
;; Clients register themselves (RFC 7591), so a row here says nothing about who the user is.
(jdbc/execute! ds ["CREATE TABLE IF NOT EXISTS clients (
@@ -34,19 +51,8 @@
code_challenge TEXT NOT NULL,
scope TEXT NOT NULL,
expires_at INTEGER NOT NULL)"])
;; A user's approval of a client: the current access and refresh token (hashed), replaced
;; together when the refresh token is used. Deleting the row revokes the approval.
(jdbc/execute! ds ["CREATE TABLE IF NOT EXISTS grants (
id INTEGER PRIMARY KEY AUTOINCREMENT,
client_id TEXT NOT NULL,
user_id INTEGER NOT NULL,
login TEXT NOT NULL,
scope TEXT NOT NULL,
access_hash TEXT NOT NULL UNIQUE,
access_expires_at INTEGER NOT NULL,
refresh_hash TEXT NOT NULL UNIQUE,
refresh_expires_at INTEGER NOT NULL,
created_at INTEGER NOT NULL)"])
(sqlite/migrate-integer-id! ds "grants" create-grants)
(jdbc/execute! ds [create-grants])
(jdbc/execute! ds ["CREATE INDEX IF NOT EXISTS grants_by_client ON grants (client_id)"]))
(defn open
@@ -107,10 +113,10 @@
(defn insert-grant!
[ds {:keys [client-id user-id login scope access-hash access-expires-at
refresh-hash refresh-expires-at created-at]}]
(jdbc/execute! ds ["INSERT INTO grants (client_id, user_id, login, scope, access_hash, access_expires_at,
(jdbc/execute! ds ["INSERT INTO grants (id, client_id, user_id, login, scope, access_hash, access_expires_at,
refresh_hash, refresh_expires_at, created_at)
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)"
client-id user-id login scope access-hash access-expires-at
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
(sqlite/new-id) client-id user-id login scope access-hash access-expires-at
refresh-hash refresh-expires-at created-at]))
(defn find-grant-by-access
src/tbd/sqlite.clj
+37
View File
@@ -0,0 +1,37 @@
(ns tbd.sqlite
"What the app's SQLite databases (tbd.todo.db, tbd.oauth.db) share: the ids of the rows they
own, and moving a table off the integer ids it used to have."
(:require [clojure.string :as str]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]))
(defn new-id
"An id for a row this app owns: a random UUID, as lowercase text. Never an integer: an LLM that
reads `7` as a todo's id confuses it with a 7 in a title, and a UUID is nothing else."
[]
(str (random-uuid)))
(defn- integer-id? [tx table]
(boolean
(some (fn [{:keys [name type]}] (and (= "id" name) (= "INTEGER" (str/upper-case type))))
(jdbc/execute! tx [(str "PRAGMA table_info(" table ")")]
{:builder-fn rs/as-unqualified-maps}))))
(defn migrate-integer-id!
"If `table` still has the INTEGER id it was first created with, recreates it with `create-sql`
(its current definition, an id TEXT PRIMARY KEY) and gives each row a UUID, keeping the
rows' order and everything else in them. Does nothing for a new database or one already
migrated. Runs in a transaction, so a failure leaves the old table as it was."
[ds table create-sql]
(jdbc/with-transaction [tx ds]
(when (integer-id? tx table)
(let [rows (jdbc/execute! tx [(str "SELECT * FROM " table " ORDER BY id")]
{:builder-fn rs/as-unqualified-maps})]
(jdbc/execute! tx [(str "DROP TABLE " table)])
(jdbc/execute! tx [create-sql])
(doseq [row rows
:let [row (assoc row :id (new-id))
columns (keys row)]]
(jdbc/execute! tx (into [(str "INSERT INTO " table " (" (str/join ", " (map name columns)) ")"
" VALUES (" (str/join ", " (repeat (count columns) "?")) ")")]
(map row columns))))))))
src/tbd/todo/db.clj
+24 -15
View File
@@ -5,7 +5,8 @@
(:require [clojure.java.io :as io]
[clojure.string :as str]
[next.jdbc :as jdbc]
[next.jdbc.result-set :as rs]))
[next.jdbc.result-set :as rs]
[tbd.sqlite :as sqlite]))
(def default-path "data/todo.db")
@@ -16,15 +17,21 @@
(let [path (get env "TODO_DB_PATH")]
{:db-path (if (str/blank? path) default-path (str/trim path))})))
(def ^:private create-todos
;; `id` is a UUID (see tbd.sqlite/new-id); `owner_id` is the user's id in Gitea, which the app
;; doesn't issue, so it stays the integer Gitea gave.
"CREATE TABLE IF NOT EXISTS todos (
id TEXT PRIMARY KEY,
owner_id INTEGER NOT NULL,
title TEXT NOT NULL,
done INTEGER NOT NULL DEFAULT 0,
created_at INTEGER NOT NULL,
updated_at INTEGER NOT NULL)")
(defn- migrate! [ds]
(jdbc/execute! ds ["CREATE TABLE IF NOT EXISTS todos (
id INTEGER PRIMARY KEY AUTOINCREMENT,
owner_id INTEGER NOT NULL,
title TEXT NOT NULL,
done INTEGER NOT NULL DEFAULT 0,
created_at INTEGER NOT NULL,
updated_at INTEGER NOT NULL)"])
(jdbc/execute! ds ["CREATE INDEX IF NOT EXISTS todos_by_owner ON todos (owner_id, id)"]))
(sqlite/migrate-integer-id! ds "todos" create-todos)
(jdbc/execute! ds [create-todos])
(jdbc/execute! ds ["CREATE INDEX IF NOT EXISTS todos_by_owner ON todos (owner_id, created_at)"]))
(defn open
"A datasource for the database file at `path`, created and migrated if need be. Each query
@@ -45,17 +52,19 @@
(some-> row (update :done #(= 1 %))))
(defn insert!
"Stores a todo (as built by tbd.todo.core/new-todo) and returns it with its :id."
"Stores a todo (as built by tbd.todo.core/new-todo) and returns it with its new :id, a UUID."
[ds {:keys [owner-id title done created-at updated-at]}]
(row->todo
(jdbc/execute-one! ds ["INSERT INTO todos (owner_id, title, done, created_at, updated_at)
VALUES (?, ?, ?, ?, ?) RETURNING *"
owner-id title (if done 1 0) created-at updated-at]
(jdbc/execute-one! ds ["INSERT INTO todos (id, owner_id, title, done, created_at, updated_at)
VALUES (?, ?, ?, ?, ?, ?) RETURNING *"
(sqlite/new-id) owner-id title (if done 1 0) created-at updated-at]
opts)))
(defn list-todos [ds owner-id]
(defn list-todos
"The owner's todos, oldest first (ids are random, so they say nothing of the order)."
[ds owner-id]
(mapv row->todo
(jdbc/execute! ds ["SELECT * FROM todos WHERE owner_id = ? ORDER BY id" owner-id] opts)))
(jdbc/execute! ds ["SELECT * FROM todos WHERE owner_id = ? ORDER BY created_at, rowid" owner-id] opts)))
(defn find-todo
"The owner's todo with this id, or nil (including when it belongs to someone else)."
src/tbd/todo/schema.clj
+5 -1
View File
@@ -8,7 +8,11 @@
(:require [malli.util :as mu]
[tbd.todo.core :as todo]))
(def Id [:int {:description "Todo id"}])
(def Id
"A todo's id: a UUID, as lowercase text (see tbd.sqlite/new-id), kept a string all the way through."
[:re {:description "Todo id, a UUID such as 3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b"
:error/message "should be a UUID"}
#"^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$"])
(def Title
[:string {:description (format "What needs doing; trimmed, non-blank, at most %d characters"
test/tbd/agent/prompt_test.clj
+40
View File
@@ -0,0 +1,40 @@
(ns tbd.agent.prompt-test
(:require [clojure.string :as str]
[clojure.test :refer [deftest is testing]]
[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
(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 task-prompt
(is (str/starts-with? (prompt/task "add a todo") prompt/guide))
(is (str/ends-with? (prompt/task "add a todo") "The user's request: add a todo"))
(doseq [none [nil "" 5]]
(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 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")))
test/tbd/chat/core_test.clj
+102 -3
View File
@@ -34,10 +34,15 @@
(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))
@@ -368,6 +373,100 @@
(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
@@ -399,7 +498,7 @@
(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 :http chat/java-http} hello))))
(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
@@ -412,7 +511,7 @@
(.close ex))
(fn [url]
(is (= [{:content "Hello "} {:content "from the LLM"} {:done true}]
(run {:url url :model "qwen" :timeout-seconds 10 :http chat/java-http})))))
(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))))))
@@ -430,6 +529,6 @@
(.close ex))
(fn [url]
(is (= [{:content "first"} {:content "second"} {:done true}]
(run {:url url :timeout-seconds 10 :http chat/java-http}
(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"))))
test/tbd/chat/trace_test.clj
+222
View File
@@ -0,0 +1,222 @@
(ns tbd.chat.trace-test
(:require [clojure.string :as str]
[clojure.test :refer [deftest is testing]]
[muuntaja.core :as m]
[tbd.chat.trace :as trace])
(:import (java.io File)))
(defn- collecting
"A trace config that keeps its entries in `entries`, an atom."
[entries & {:as opts}]
(merge {:sink #(swap! entries conj %) :full-text? false} opts))
(defn- suspects [entries] (filter #(= :loop-suspect (:event %)) entries))
(defn- call [id name args] {:id id :name name :arguments args})
(defn- assistant [& calls] {:role "assistant" :content "" :tool-calls (vec calls)})
(defn- result [id] {:role "tool" :tool-call-id id :content "ok"})
(deftest run-summary-test
(let [ask {:role "user" :content "add milk"}
list-call (call "1" "list_todos" "{}")]
(testing "a conversation that has just begun"
(is (= {:step 0 :run-calls 0 :top-call nil :input [ask]}
(dissoc (trace/run-summary [ask]) :run))))
(testing "the turns of a run count the assistant's messages since the user's, and their calls"
(let [s (trace/run-summary [ask (assistant list-call) (result "1") (assistant (call "2" "add" "{}") (call "3" "add" "{}"))
(result "2") (result "3")])]
(is (= {:step 2 :run-calls 3 :top-call {:tool "add" :args "{}" :count 2}}
(select-keys s [:step :run-calls :top-call])))
(is (= ask (first (:input s))))
(is (= 6 (count (:input s))))))
(testing "the run id is that of the user's last message: the same for every turn of a run"
(let [a (trace/run-summary [ask])
b (trace/run-summary [ask (assistant list-call) (result "1")])
c (trace/run-summary [{:role "user" :content "something else"}])]
(is (re-matches #"[0-9a-f]{8}" (:run a)))
(is (= (:run a) (:run b)))
(is (not= (:run a) (:run c)))))
(testing "an earlier run's calls are not this run's"
(let [s (trace/run-summary [ask (assistant list-call) (result "1") {:role "assistant" :content "Done."}
{:role "user" :content "again"}])]
(is (= {:step 0 :run-calls 0} (select-keys s [:step :run-calls])))))
(testing "the same tool with other arguments is another call"
(is (= 1 (:count (:top-call (trace/run-summary [ask (assistant (call "1" "add" "{\"x\":1}") (call "2" "add" "{\"x\":2}"))]))))))
(testing "a conversation with no user message, and none at all"
(is (= "-" (:run (trace/run-summary [{:role "assistant" :content "hi"}]))))
(is (= {:run "-" :step 0 :run-calls 0} (select-keys (trace/run-summary []) [:run :step :run-calls]))))))
(deftest begin-test
(testing "the start of a turn says what it is about, without the words of the conversation"
(let [entries (atom [])]
(trace/begin! (collecting entries)
{:messages [{:role "user" :content "hello"}] :tools [{:name "add"} {:name "sub"}]
:page "todos" :model "qwen"})
(let [[start :as all] @entries]
(is (= 1 (count all)))
(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"
(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))))))
(testing "every turn has its own req id"
(let [entries (atom [])]
(dotimes [_ 3] (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]}))
(is (= 3 (count (set (map :req @entries)))))))
(testing "a call made three times in a run is a suspect, twice is not"
(let [ask {:role "user" :content "go"}
messages (fn [n] (into [ask] (mapcat (fn [i] [(assistant (call (str i) "look" "{}")) (result (str i))])) (range n)))
entries (atom [])]
(trace/begin! (collecting entries) {:messages (messages 2)})
(is (empty? (suspects @entries)))
(trace/begin! (collecting entries) {:messages (messages 3)})
(is (= [{:kind :repeated-call :tool "look" :args "{}" :count 3}]
(map #(select-keys % [:kind :tool :args :count]) (suspects @entries)))))))
(deftest observe-test
(testing "reasoning that says the same sentence over and over is a suspect, at 4 times and each doubling"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(dotimes [_ 16]
(trace/observe! t {:thinking "Wait, let me check the board again. "}))
(is (= [4 8 16] (map :count (suspects @entries))))
(is (every? #(= :repeated-thinking (:kind %)) (suspects @entries)))
(is (= "Wait, let me check the board again." (:text (first (suspects @entries)))))))
(testing "a sentence is the same whatever its case and spacing, and however the pieces of it came"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(doseq [piece ["Wait, let me check" " the board AGAIN." "\n" "wait, let me check the board again.\n"
"Wait, let me check the " "board again! " "Wait, let me check the board again?\n\n"]]
(trace/observe! t {:thinking piece}))
(is (= [4] (map :count (suspects @entries))))))
(testing "short sentences, and different ones, are no repetition"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(dotimes [i 20]
(trace/observe! t {:thinking "Hmm. "})
(trace/observe! t {:thinking (str "Step " i " of working out which of the many todos is the one. ")}))
(is (empty? (suspects @entries)))))
(testing "reasoning that goes on and on is a suspect at 8000 characters, and at each doubling"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(dotimes [i 17]
(trace/observe! t {:thinking (str (format "%03d" i) (apply str (repeat 997 \x)))}))
(is (= [8000 16000] (map :chars (filter #(= :long-reasoning (:kind %)) (suspects @entries)))))))
(testing "a reply and calls are not reasoning"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(dotimes [_ 10]
(trace/observe! t {:content "Wait, let me check the board again. "}))
(is (empty? (suspects @entries))))))
(deftest finish-test
(testing "the end of a turn sums it up, and only the first end counts"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(trace/observe! t {:thinking "hm"})
(trace/observe! t {:thinking "m"})
(trace/observe! t {:content "Hi"})
(trace/observe! t {:finish-reason "stop" :usage {:prompt_tokens 7 :completion_tokens 3}})
(trace/finish! t {:outcome :done})
(trace/finish! t {:outcome :aborted})
(let [ends (filter #(= :turn-end (:event %)) @entries)
end (first ends)]
(is (= 1 (count ends)))
(is (= {:outcome :done :events 4 :thinking-chars 3 :content-chars 2 :finish-reason "stop"
:prompt-tokens 7 :completion-tokens 3 :flags []}
(select-keys end [:outcome :events :thinking-chars :content-chars :finish-reason
:prompt-tokens :completion-tokens :flags])))
(is (every? #(and (number? %) (>= % 0)) ((juxt :duration-ms :ttft-ms :think-ms) end)))
(is (not (contains? end :reasoning)) "the text stays out unless it is asked for"))))
(testing "the flags of a turn are what went wrong in it"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(dotimes [_ 4] (trace/observe! t {:thinking "Wait, let me check the board again. "}))
(trace/observe! t {:finish-reason "length"})
(trace/finish! t {:outcome :done})
(is (= [:repeated-thinking :truncated] (:flags (last @entries))))))
(testing "a long call is cut, and the time spent thinking is the time until the answer"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(trace/observe! t {:thinking "hm"})
(trace/observe! t {:call-deltas [{:index 0 :name "add"}]})
(trace/finish! t {:outcome :tool-calls :calls [(call "a" "add" (apply str (repeat 2000 \y)))]})
(let [end (last @entries)]
(is (= [{:name "add" :args (str (apply str (repeat 500 \y)) "…")}] (:calls end)))
(is (<= (:think-ms end) (:duration-ms end))))))
(testing "with the full text on, the turn ends with what the model said"
(let [entries (atom [])
t (trace/begin! (collecting entries :full-text? true) {:messages [{:role "user" :content "x"}]})]
(trace/observe! t {:thinking "One. "})
(trace/observe! t {:thinking "Two."})
(trace/observe! t {:content "Three"})
(trace/finish! t {:outcome :done})
(is (= {:reasoning "One. Two." :reply "Three"} (select-keys (last @entries) [:reasoning :reply])))))
(testing "a failure has its words"
(let [entries (atom [])
t (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]})]
(trace/finish! t {:outcome :error :error "the LLM server's reply was cut off" :detail "reset"})
(is (= {:outcome :error :error "the LLM server's reply was cut off" :detail "reset"}
(select-keys (last @entries) [:outcome :error :detail]))))))
(deftest render-test
(let [line (trace/render {:event :turn-end :req "ab12cd34" :run "00ff00ff" :step 2 :outcome :tool-calls
:duration-ms 1200 :thinking-chars 0 :error "it broke" :detail nil :flags [:truncated :repeated-thinking]
:calls [{:name "add" :args "{\"x\":1}"}] :reasoning "secret words" :reply "more" :input [{:role "user"}]
:extra []})]
(testing "one line, the fields in a fixed order, the values readable"
(is (= (str "[tbd] chat turn-end req=ab12cd34 run=00ff00ff step=2 outcome=tool-calls duration-ms=1200 thinking-chars=0"
" calls=\"add{\\\"x\\\":1}\" flags=truncated,repeated-thinking error=\"it broke\"")
line)))
(testing "the text of the conversation is for the file only"
(is (not (str/includes? line "secret")))
(is (not (str/includes? line "more")))))
(testing "a long argument is cut in the line"
(is (< (count (trace/render {:event :turn-end :calls [{:name "add" :args (apply str (repeat 1000 \z))}]})) 250))))
(defn- temp-file ^File []
(doto (File/createTempFile "chat-trace" ".jsonl") .delete .deleteOnExit))
(deftest sink-test
(testing "without a file, an entry is a line of the log"
(is (= "[tbd] chat turn-start req=a page=todos\n"
(with-out-str ((trace/sink nil) {:event :turn-start :req "a" :page "todos"})))))
(testing "with a file, it is also a line of JSON there, with everything in it"
(let [file (temp-file)
sink (trace/sink (str file))
out (with-out-str
(sink {:event :turn-end :req "a" :outcome :done :reasoning "long \"thoughts\"\nover lines" :flags [:truncated]})
(sink {:event :turn-start :req "b"}))
lines (str/split-lines (slurp file))
[end start] (map #(m/decode "application/json" %) lines)]
(is (not (str/includes? out "thoughts")) "the log has no text")
(is (= 2 (count lines)))
(is (= {:event "turn-end" :req "a" :outcome "done" :reasoning "long \"thoughts\"\nover lines" :flags ["truncated"]}
(dissoc end :ts)))
(is (= "turn-start" (:event start)))
(is (some? (java.time.Instant/parse (:ts end))))))
(testing "the file's folders are made"
(let [dir (doto (File/createTempFile "chat-trace" "") .delete)
file (File. dir "deeper/trace.jsonl")]
(with-out-str ((trace/sink (str file)) {:event :turn-start :req "a"}))
(is (.exists file))
(.delete file) (.delete (.getParentFile file)) (.delete dir)))
(testing "a file that can't be written to is complained about, and nothing is thrown"
(let [dir (doto (File/createTempFile "chat-trace" "") .delete .mkdirs)
out (try (with-out-str ((trace/sink (str dir)) {:event :turn-start :req "a"}))
(finally (.delete dir)))]
(is (str/includes? out "[tbd] chat turn-start req=a"))
(is (str/includes? out "can't write the trace file")))))
(deftest config-for-test
(testing "no file: the log only, and no full text"
(is (= {:full-text? false :file nil} (select-keys (trace/config-for nil) [:full-text? :file])))
(is (fn? (:sink (trace/config-for nil)))))
(testing "a file: the full text goes there"
(let [file (str (temp-file))]
(is (= {:full-text? true :file file} (select-keys (trace/config-for file) [:full-text? :file]))))))
test/tbd/mcp/routes_test.clj
+11 -6
View File
@@ -99,8 +99,11 @@
(is (= {:x "First addend" :y "Second addend"}
(update-vals (:properties add) :description)))
(is (= ["number" "number"] (map :type (vals (:properties add))))))
(is (= {:type "object" :required ["id"] :properties {:id {:type "integer" :description "Todo id"}}}
(input-schema "get_todo")))
(let [get-todo (input-schema "get_todo")]
(is (= ["id"] (:required get-todo)))
(is (= "string" (get-in get-todo [:properties :id :type])) "an id is a string, not a number")
(is (re-find #"UUID" (get-in get-todo [:properties :id :description])))
(is (re-find (re-pattern (get-in get-todo [:properties :id :pattern])) (str (random-uuid)))))
(is (= ["id"] (:required (input-schema "update_todo"))) "title and done are optional")
(is (= #{"id" "title" "done"} (set (map name (keys (:properties (input-schema "update_todo"))))))))
(testing "and ones with no arguments say so"
@@ -256,16 +259,18 @@
(deftest tool-arguments-are-validated-test
(let [{:keys [app alice]} (fixture)
todo-id "3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b"
sid (initialize app alice)
error (fn [tool arguments]
(let [resp (call-tool app alice sid tool arguments)]
(is (true? (get-in resp [:result :isError])) (str tool " " (pr-str arguments)))
(text resp)))]
(testing "arguments of the wrong type are turned away, which plumcp alone doesn't do"
(is (= "invalid arguments: {:id [\"should be an integer\"]}" (error "get_todo" {:id "abc"})))
(is (= "invalid arguments: {:id [\"should be a UUID\"]}" (error "get_todo" {:id "abc"})))
(is (= "invalid arguments: {:id [\"should be a UUID\"]}" (error "get_todo" {:id 1})) "todo ids are not integers")
(is (= "invalid arguments: {:title [\"should be a string\"]}" (error "create_todo" {:title 5})))
(is (= "invalid arguments: {:done [\"should be a boolean\"]}" (error "update_todo" {:id 1 :done "yes"})))
(is (= "invalid arguments: {:done [\"should be a boolean\"]}" (error "update_todo" {:id todo-id :done "yes"})))
(is (= "invalid arguments: {:x [\"should be an integer\" \"should be a double\"]}" (error "add" {:x "2" :y 3}))))
(testing "the tools and the HTTP API validate against the same schemas"
(is (false? (malli/validate todo-schema/UpdateTodo {:id 1 :done "yes"})))
(is (true? (malli/validate todo-schema/UpdateTodo {:id 1 :done true}))))))
(is (false? (malli/validate todo-schema/UpdateTodo {:id todo-id :done "yes"})))
(is (true? (malli/validate todo-schema/UpdateTodo {:id todo-id :done true}))))))
test/tbd/oauth/db_test.clj
+30
View File
@@ -1,6 +1,7 @@
(ns tbd.oauth.db-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[next.jdbc :as jdbc]
[tbd.oauth.db :as db])
(:import (java.nio.file Files)
(java.nio.file.attribute FileAttribute)))
@@ -55,6 +56,7 @@
(is (nil? (db/find-grant-by-access ds "refresh-1" 1000)) "a refresh token isn't an access token"))
(testing "found by refresh token"
(is (= 7 (:user-id (db/find-grant-by-refresh ds "refresh-1"))))
(is (uuid? (parse-uuid (:id (db/find-grant-by-refresh ds "refresh-1")))) "a grant's id is a UUID")
(is (nil? (db/find-grant-by-refresh ds "access-1"))))
(testing "rotating replaces both tokens, and works once per refresh token"
(let [id (:id (db/find-grant-by-refresh ds "refresh-1"))
@@ -88,3 +90,31 @@
(is (nil? (db/find-grant-by-refresh ds "refresh-2")) "one that can't is dropped")
(is (nil? (db/take-code! ds "expired")))
(is (some? (db/take-code! ds "pending")))))
(deftest integer-grant-ids-are-migrated-test
(testing "grants from before ids were UUIDs survive, under new ids, and still work"
(let [path (temp-db-path)
_ (io/make-parents path)
old (jdbc/get-datasource {:dbtype "sqlite" :dbname path})]
(jdbc/execute! old ["CREATE TABLE grants (
id INTEGER PRIMARY KEY AUTOINCREMENT,
client_id TEXT NOT NULL,
user_id INTEGER NOT NULL,
login TEXT NOT NULL,
scope TEXT NOT NULL,
access_hash TEXT NOT NULL UNIQUE,
access_expires_at INTEGER NOT NULL,
refresh_hash TEXT NOT NULL UNIQUE,
refresh_expires_at INTEGER NOT NULL,
created_at INTEGER NOT NULL)"])
(jdbc/execute! old ["INSERT INTO grants (client_id, user_id, login, scope, access_hash, access_expires_at,
refresh_hash, refresh_expires_at, created_at)
VALUES ('c1', 7, 'alice', 'mcp', 'access-1', 2000, 'refresh-1', 9000, 1000)"])
(let [ds (db/open path)
migrated (db/find-grant-by-access ds "access-1" 1000)]
(is (= {:client-id "c1" :user-id 7 :login "alice" :scope "mcp" :refresh-hash "refresh-1"}
(select-keys migrated [:client-id :user-id :login :scope :refresh-hash])))
(is (uuid? (parse-uuid (:id migrated))))
(is (some? (db/rotate-grant! ds (:id migrated) "refresh-1"
{:access-hash "access-2" :access-expires-at 3000
:refresh-hash "refresh-2" :refresh-expires-at 9500})))))))
test/tbd/todo/core_test.clj
+1 -1
View File
@@ -18,7 +18,7 @@
(todo/new-todo 7 " buy milk " 1000)))
(is (= {:error "title must not be blank"} (todo/new-todo 7 " " 1000))))
(def stored {:id 1 :owner-id 7 :title "buy milk" :done false :created-at 1000 :updated-at 1000})
(def stored {:id "3f2b8c1e-5a47-4d0e-9b6a-1c2d3e4f5a6b" :owner-id 7 :title "buy milk" :done false :created-at 1000 :updated-at 1000})
(deftest apply-changes-test
(testing "title"
test/tbd/todo/db_test.clj
+42 -3
View File
@@ -1,6 +1,7 @@
(ns tbd.todo.db-test
(:require [clojure.java.io :as io]
[clojure.test :refer [deftest is testing]]
[next.jdbc :as jdbc]
[tbd.todo.db :as db])
(:import (java.nio.file Files)
(java.nio.file.attribute FileAttribute)))
@@ -38,6 +39,7 @@
id (:id saved)]
(testing "insert returns the stored todo with an id"
(is (= (assoc (todo 7 "buy milk") :id id) saved))
(is (re-matches #"[0-9a-f]{8}-[0-9a-f]{4}-4[0-9a-f]{3}-[89ab][0-9a-f]{3}-[0-9a-f]{12}" id) "a UUID, not a number")
(is (not= id (:id (db/insert! ds (todo 7 "walk dog"))))))
(testing "find and list"
(is (= saved (db/find-todo ds 7 id)))
@@ -47,9 +49,10 @@
(db/update! ds 7 (assoc saved :title "buy oat milk" :done true :updated-at 2000))))
(is (= true (:done (db/find-todo ds 7 id)))))
(testing "missing ids"
(is (nil? (db/find-todo ds 7 999)))
(is (nil? (db/update! ds 7 (assoc saved :id 999))))
(is (false? (db/delete! ds 7 999))))
(let [missing (str (random-uuid))]
(is (nil? (db/find-todo ds 7 missing)))
(is (nil? (db/update! ds 7 (assoc saved :id missing))))
(is (false? (db/delete! ds 7 missing)))))
(testing "delete"
(is (true? (db/delete! ds 7 id)))
(is (nil? (db/find-todo ds 7 id)))
@@ -67,3 +70,39 @@
(is (nil? (db/update! ds 8 (assoc mine :title "hijacked"))))
(is (false? (db/delete! ds 8 (:id mine))))
(is (= mine (db/find-todo ds 7 (:id mine)))))))
(deftest list-order-test
(testing "todos come oldest first, though their ids, being random, say nothing of the order"
(let [ds (db/open (temp-db-path))
titles (mapv #(str "todo " %) (range 20))]
(doseq [title titles] (db/insert! ds (todo 7 title)))
(db/insert! ds (assoc (todo 7 "the newest") :created-at 5000))
(db/insert! ds (assoc (todo 7 "the oldest") :created-at 1))
(is (= (concat ["the oldest"] titles ["the newest"]) (map :title (db/list-todos ds 7)))))))
(deftest integer-ids-are-migrated-test
(testing "a database from before ids were UUIDs keeps its todos, in order, under new ids"
(let [path (temp-db-path)
_ (io/make-parents path)
old (jdbc/get-datasource {:dbtype "sqlite" :dbname path})]
(jdbc/execute! old ["CREATE TABLE todos (
id INTEGER PRIMARY KEY AUTOINCREMENT,
owner_id INTEGER NOT NULL,
title TEXT NOT NULL,
done INTEGER NOT NULL DEFAULT 0,
created_at INTEGER NOT NULL,
updated_at INTEGER NOT NULL)"])
(jdbc/execute! old ["CREATE INDEX todos_by_owner ON todos (owner_id, id)"])
(doseq [[owner title done] [[7 "first" 0] [8 "theirs" 0] [7 "second" 1]]]
(jdbc/execute! old ["INSERT INTO todos (owner_id, title, done, created_at, updated_at) VALUES (?, ?, ?, 1000, 1000)"
owner title done]))
(let [ds (db/open path)
mine (db/list-todos ds 7)]
(is (= [["first" false] ["second" true]] (map (juxt :title :done) mine)))
(is (every? (comp uuid? parse-uuid :id) mine))
(is (= ["theirs"] (map :title (db/list-todos ds 8))))
(testing "and is only migrated once"
(is (= mine (db/list-todos (db/open path) 7))))
(testing "and works as a new one does"
(db/insert! ds (todo 7 "third"))
(is (= ["first" "second" "third"] (map :title (db/list-todos ds 7)))))))))
test/tbd/todo/routes_test.clj
+6 -5
View File
@@ -46,7 +46,7 @@
{:keys [id] :as created} (:body resp)]
(is (= 201 (:status resp)))
(is (= {:owner-id 7 :title "buy milk" :done false} (select-keys created [:owner-id :title :done])))
(is (pos? id))
(is (uuid? (parse-uuid id)))
(testing "get"
(is (= created (:body (request app :get (str todos "/" id) cookie)))))
(testing "patch"
@@ -79,9 +79,10 @@
(doseq [body ["{}" "{\"title\":\" \"}" "{\"done\":\"yes\"}" "{\"id\":99}"]]
(is (= 400 (:status (request app :patch one cookie body))) body))
(is (= 400 (:status (request app :patch one cookie))) "no body"))
(testing "a non-numeric id"
(doseq [method [:get :patch :delete]]
(is (= 400 (:status (request app method (str todos "/abc") cookie "{\"done\":true}"))) (str method))))
(testing "an id that is not a UUID (an integer, as todos used to have, included)"
(doseq [method [:get :patch :delete]
id ["abc" "1"]]
(is (= 400 (:status (request app method (str todos "/" id) cookie "{\"done\":true}"))) (str method " " id))))
(is (= [created] (:todos (:body (request app :get todos cookie)))) "nothing above changed the todo")))
(deftest per-user-scoping-test
@@ -98,7 +99,7 @@
(is (= ["alice's"] (map :title (:todos (:body (request alice-app :get todos alice))))))
(is (= ["bob's"] (map :title (:todos (:body (request bob-app :get todos bob)))))))
(testing "someone else's todo is indistinguishable from a missing one"
(let [missing (request bob-app :get (str todos "/999999") bob)]
(let [missing (request bob-app :get (str todos "/" (random-uuid)) bob)]
(doseq [[method body] [[:get nil] [:patch "{\"title\":\"hijacked\"}"] [:delete nil]]]
(let [resp (request bob-app method one bob body)]
(is (= 404 (:status resp)) (str method))
test/tbd/todo/service_test.clj
+1 -1
View File
@@ -22,7 +22,7 @@
id (:id created)]
(testing "create trims the title, makes it the user's and returns it stored"
(is (= {:owner-id 7 :title "buy milk" :done false} (select-keys created [:owner-id :title :done])))
(is (integer? id)))
(is (uuid? (parse-uuid id))))
(is (= {:ok created} (service/find-todo ds alice id)))
(is (= {:ok [created]} (service/list-todos ds alice)))
(testing "update changes the title and/or done"
ui/shadow-cljs.edn
+3 -2
View File
@@ -1,6 +1,7 @@
;; The UI compiles straight into the server's resources dir, so the server picks it up from
;; the classpath (see `tbd.core`, which serves `resources/public` at `/js`).
{:source-paths ["src" "test"]
;; the classpath (see `tbd.core`, which serves `resources/public` at `/js`). ../shared holds the
;; .cljc the UI and the server both read (the prompts an LLM is given, tbd.agent.prompt).
{:source-paths ["src" "test" "../shared"]
:dependencies
[[reagent "2.0.1"]
ui/src/tbd/ui/db.cljs
+6 -1
View File
@@ -3,7 +3,7 @@
(def default-db
{;; The page being shown (see tbd.ui.pages); it follows the URL's fragment.
:page :games
:page :tic-tac-toe
:calc {:x "" :y ""
;; {:status :idle}
;; {:status :loading}
@@ -35,15 +35,20 @@
;; one such call.
;; :size is what the panel was dragged to, in px: its :width and the :height of the conversation
;; in it (the rest of the panel is the same at any size).
;; :tools-expanded? is whether the tool calls and results show whole (wrapped) or, as they do by
;; default, each cut to one line ending in "…" when it doesn't fit.
;; The other two are for a reply that is still coming or being answered: :pending-calls are the
;; calls it has asked for so far, :tool-calls-used how many calls this turn has made.
;; :thinking-at is when (ms since the epoch) the last piece of the model's reasoning came, or nil.
:chat {:open? false
:size {:width 320 :height 256}
:tools-expanded? false
:input ""
:messages []
:status :idle
:error nil
:pending-calls nil
:thinking-at nil
:tool-calls-used 0}
;; Tic-tac-toe, entirely client side: the board (see tbd.ui.tictactoe) and whose turn it is.
:ttt {:board tictactoe/new-board
ui/src/tbd/ui/events.cljs
+48 -13
View File
@@ -74,6 +74,12 @@
(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.
(defonce ^:private hash-listener (atom nil))
@@ -173,7 +179,7 @@
(defn- reset-chat
"An empty conversation, in a panel that is as open (or closed), and as big, as it was."
[db]
(assoc db :chat (merge (:chat db/default-db) (select-keys (:chat db) [:open? :size]))))
(assoc db :chat (merge (:chat db/default-db) (select-keys (:chat db) [:open? :size :tools-expanded?]))))
(rf/reg-event-db
::logout-response
@@ -315,6 +321,25 @@
[messages]
(drop-while #(= "tool" (:role %)) (take-last max-sent-messages messages)))
(def ^:private stale-result
"What the LLM is sent in place of a result from before the user's last message."
"(out of date: this was read on an earlier turn and the page may have changed since. Call the tool again for the current state.)")
(defn- 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)))
;; 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)
@@ -322,7 +347,7 @@
(defn- chat-request [db messages]
(let [tools (model-context/definitions (:page db))]
{:uri "/api/chat" :method "POST"
:body (cond-> {:messages (mapv wire-message (recent messages))
:body (cond-> {:messages (mapv wire-message (without-stale-results (recent messages)))
:page (name (:page db))}
(seq tools) (assoc :tools tools))
:on-event [::chat-event]
@@ -340,6 +365,12 @@
(fn [db [_ width height]]
(assoc-in db [:chat :size] {:width width :height height})))
;; 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-set-input
(fn [db [_ input]]
@@ -417,7 +448,7 @@
[db]
(let [{:keys [pending-calls tool-calls-used]} (:chat db)
used (+ (or tool-calls-used 0) (count pending-calls))
db (assoc-in db [:chat :pending-calls] nil)]
db (update db :chat assoc :pending-calls nil :thinking-at nil)]
(cond
(empty? pending-calls)
{:db (assoc-in db [:chat :status] :idle)}
@@ -444,21 +475,25 @@
;; 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), {:content "..."} for the next piece of the reply (the first starts the
;; 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.
(rf/reg-event-fx
::chat-event
(fn [{:keys [db]} [_ {:keys [content tool-calls done error]}]]
(cond
(not= :loading (get-in db [:chat :status])) {: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)}
:else {:db db})))
[(rf/inject-cofx ::now)]
(fn [{:keys [db now]} [_ {:keys [thinking content tool-calls done error]}]]
(let [loading? (= :loading (get-in db [:chat :status]))
db (cond-> db (and loading? (text? thinking)) (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)}
:else {:db db}))))
(defn- call-all
"A promise of the results of `calls`, in order, as {:id :name :content :error?}. One after the
ui/src/tbd/ui/model_context.cljs
+1 -1
View File
@@ -14,7 +14,7 @@
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 games page is not
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."
ui/src/tbd/ui/pages.cljs
+2 -1
View File
@@ -6,7 +6,8 @@
(def pages
"The pages in the order of the tabs: {:id :title :login?}. :login? pages are only offered
(and only show anything) to someone who is logged in."
[{:id :games :title "Games"}
[{:id :tic-tac-toe :title "Tic-tac-toe"}
{:id :calculator :title "Calculator"}
{:id :todos :title "Todos" :login? true}
{:id :ai-setup :title "AI setup"}])
ui/src/tbd/ui/views.cljs
+52 -17
View File
@@ -1,5 +1,6 @@
(ns tbd.ui.views
(:require [clojure.string :as str]
[reagent.core :as r]
[re-frame.core :as rf]
[tbd.ui.events :as events]
[tbd.ui.pages :as pages]
@@ -188,13 +189,17 @@
(defn- chat-tool-line
"A tool the assistant calls, or what came of it, apart from what is said, and in smaller print.
All of it shows, wrapped: the conversation scrolls, so it needn't be cut short."
[text {:keys [error?]}]
[:div {:data-tool true
:style {:align-self "flex-start" :max-width "85%"
:white-space "pre-wrap" :overflow-wrap "anywhere"
:font-family "monospace" :font-size "12px"
:color (if error? "crimson" "#777")}}
One line, ending in \"…\" where it doesn't fit, unless `expanded?`: then all of it shows, wrapped."
[expanded? text {:keys [error?]}]
[:div (cond-> {:data-tool true
:style (merge {:align-self "flex-start" :max-width "85%" :flex-shrink 0
:overflow-wrap "anywhere"
:font-family "monospace" :font-size "12px"
:color (if error? "crimson" "#777")}
(if expanded?
{:white-space "pre-wrap"}
{:white-space "nowrap" :overflow "hidden" :text-overflow "ellipsis"}))}
(not expanded?) (assoc :title text))
text])
(defn- call-text [{:keys [name arguments]}]
@@ -206,13 +211,18 @@
(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."
[{:keys [role content tool-calls] :as message}]
[tools-expanded? {:keys [role content tool-calls] :as message}]
(if (= "tool" role)
[chat-tool-line (result-text message) message]
[chat-tool-line tools-expanded? (result-text message) message]
[:<>
(when-not (str/blank? content) [chat-bubble message])
(for [call tool-calls]
^{:key (:id call)} [chat-tool-line (call-text call) nil])]))
^{:key (:id call)} [chat-tool-line tools-expanded? (call-text call) nil])]))
(defn- tool-use?
"Whether the conversation has any tool call or result."
[messages]
(some #(or (= "tool" (:role %)) (seq (:tool-calls %))) messages))
(def ^:private chat-min-width 260)
(def ^:private chat-min-height 96)
@@ -227,16 +237,37 @@
(defn- at-end? [el]
(<= (- (.-scrollHeight el) (.-scrollTop el) (.-clientHeight el)) stuck-slack))
(def ^:private thinking-live-ms
"How recently (ms) a piece of the model's reasoning must have come for it to count as still
coming in."
250)
(def ^:private thinking-frame-ms 250)
(def ^:private thinking-tick-ms 100)
(defn- thinking-line
"\"Thinking…\" which, while pieces of the model's reasoning are still coming in (the last, at
`thinking-at`, was less than `thinking-live-ms` ago), cycles through one to three dots."
[thinking-at]
(r/with-let [clock (r/atom (js/Date.now))
timer (js/setInterval #(reset! clock (js/Date.now)) thinking-tick-ms)]
(let [now @clock
live? (and thinking-at (< (- now thinking-at) thinking-live-ms))]
[:div {:role "status" :style {:color "#777"}}
(if live?
(str "Thinking" (apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) ".")))
"Thinking…")])
(finally (js/clearInterval timer))))
(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;
what the model reasons is not shown."
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."
[_chat _size]
(let [stuck? (atom true)
seen (atom 0)]
(fn [{:keys [messages status]} {:keys [height]}]
(fn [{:keys [messages status thinking-at tools-expanded?]} {:keys [height]}]
[:div {:role "log" :aria-live "polite"
:ref (fn [el]
(when el
@@ -252,9 +283,9 @@
(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 message]))
^{:key i} [chat-message tools-expanded? message]))
(when (and (= :loading status) (not= "assistant" (:role (peek messages))))
[:div {:role "status" :style {:color "#777"}} "Thinking…"])])))
[thinking-line thinking-at])])))
(defn- chat-form [{:keys [input status]}]
(let [loading? (= :loading status)]
@@ -313,7 +344,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] :as chat} user]
(defn- chat-panel [{:keys [messages status size tools-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")
@@ -322,6 +353,9 @@
:box-shadow "0 5px 15px rgba(0,0,0,0.1)"}}
[:div {:style {:display "flex" :align-items "center" :gap "0.5rem"}}
[:strong {:style {:flex 1}} "Chat"]
(when (tool-use? messages)
[link-button {:on-click #(rf/dispatch [::events/chat-toggle-tools])}
(if tools-expanded? "Collapse tool use" "Expand tool use")])
(when (and (seq messages) (not= :loading status))
[link-button {:on-click #(rf/dispatch [::events/chat-clear])} "Clear"])
[:button {:type "button" :aria-label "Close chat"
@@ -350,7 +384,8 @@
(defn- current-page [page user]
(case page
:games [:<> [tic-tac-toe] [calculator]]
:tic-tac-toe [tic-tac-toe]
:calculator [calculator]
:todos (if (= :logged-in (:status user)) [todos] [login-prompt user])
:ai-setup [:<> [mcp-setup] [browser-tools]]))
ui/src/tbd/ui/webmcp.cljs
+215 -66
View File
@@ -7,6 +7,12 @@
the form, press a button, tick a box) by dispatching the same re-frame events the views do, so
everything shows on screen, and reads what the page shows from the app-db.
Besides the tools, the page registers prompts and resources (`prompts`, `resources`), which is
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.
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
@@ -19,6 +25,7 @@
[clojure.string :as str]
[re-frame.core :as rf]
[re-frame.db :as rf-db]
[tbd.agent.prompt :as prompt]
[tbd.ui.events :as events]
[tbd.ui.model-context :as model-context]
[tbd.ui.pages :as pages]
@@ -106,13 +113,41 @@
(first (filter #(= id (:id %)) items)))
(defn- find-todo! [items id]
(or (find-todo items id) (fail! "todo not found")))
(or (find-todo items id) (fail! (str "todo not found: " id))))
;; --- Argument checks (the page can't trust that the agent honours the schema) ---
(defn- check-id! [id]
(when-not (and (number? id) (js/Number.isInteger id))
(fail! "invalid arguments: id must be an integer")))
(when-not (and (string? id) (seq id))
(fail! "invalid arguments: id must be a todo's id, the UUID list_todos gives")))
(defn- check-todos!
"Checks the `todos` argument of a todo tool, which takes its work as a list (one call for a
whole batch, not one call per todo): a non-empty list of maps that `check-item!` accepts."
[todos check-item!]
(when-not (and (sequential? todos) (seq todos) (every? map? todos))
(fail! "invalid arguments: todos must be a non-empty list of objects"))
(run! check-item! todos))
(defn- in-order
"A promise of the vector of `(f item)` (a promise) for each of `items`, run one at a time: a
request finishes before the next starts, so a failure is one item's. When one fails after
others were done, the error says how many were."
[f items]
(let [total (count items)]
(reduce (fn [so-far item]
(.then so-far
(fn [results]
(-> (js/Promise.resolve item)
(.then f)
(.then #(conj results %))
(.catch (fn [e]
(fail! (if (seq results)
(str (.-message e) " (the first " (count results) " of "
total " were done)")
(.-message e)))))))))
(js/Promise.resolve [])
items)))
;; --- The tools ---
@@ -149,7 +184,7 @@
(fail! "invalid arguments: x and y must be numbers"))
(when (= :loading (get-in (db) [:calc :result :status]))
(fail! "an addition is already in progress"))
(show! :games)
(show! :calculator)
(rf/dispatch-sync [::events/set-operand :x (str x)])
(rf/dispatch-sync [::events/set-operand :y (str y)])
(rf/dispatch-sync [::events/add])
@@ -163,53 +198,76 @@
(defn- list-todos [_]
(logged-in-todos))
(defn- get-todo [{:keys [id]}]
(check-id! id)
(defn- get-todo
"Reads todos by id, all of them or none."
[{:keys [todos]}]
(check-todos! todos #(check-id! (:id %)))
(-> (logged-in-todos)
(.then #(find-todo! % id))))
(.then (fn [items] (mapv #(find-todo! items (:id %)) todos)))))
(defn- create-todo
"Types the title into the new-todo field and presses Add."
(defn- create-one
"Types the title into the new-todo field and presses Add. A promise of the todo that was created."
[{:keys [title]}]
(when-not (and (string? title) (seq title))
(fail! "invalid arguments: title must be a non-empty string"))
(-> (logged-in-todos)
(.then (fn [_]
(show! :todos)
(rf/dispatch-sync [::events/set-new-title title])
;; The field is emptied when the todo was added; a failure leaves it as it is.
(change-todos [::events/add-todo] #(= "" (get-in % [:todos :new-title])) "the new todo")))
(show! :todos)
(rf/dispatch-sync [::events/set-new-title title])
;; The field is emptied when the todo was added; a failure leaves it as it is.
(-> (change-todos [::events/add-todo] #(= "" (get-in % [:todos :new-title])) "the new todo")
(.then #(last (get-in % [:todos :items])))))
(defn- set-todo-done
"Ticks or unticks a todo's checkbox."
(defn- create-todo
"Adds todos, one after the other: a promise of the todos that were created."
[{: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)))))
(defn- set-one-done
"Ticks or unticks one todo's checkbox, unless it is already so (no request then). A promise of
the todo as the page shows it."
[{:keys [id done]}]
(check-id! id)
(when-not (boolean? done)
(fail! "invalid arguments: done must be true or false"))
(let [todo (find-todo! (get-in (db) [:todos :items]) id)]
(if (= done (boolean (:done todo)))
(js/Promise.resolve todo)
(-> (change-todos [::events/set-done id done]
#(= done (boolean (:done (find-todo (get-in % [:todos :items]) id))))
"the todo")
(.then #(find-todo (get-in % [:todos :items]) id))))))
(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."
[{:keys [todos]}]
(check-todos! todos (fn [{:keys [id done]}]
(check-id! id)
(when-not (boolean? done)
(fail! "invalid arguments: done must be true or false"))))
(-> (logged-in-todos)
(.then (fn [items]
(let [todo (find-todo! items id)]
(show! :todos)
(if (= done (boolean (:done todo)))
todo
(-> (change-todos [::events/set-done id done]
#(= done (boolean (:done (find-todo (get-in % [:todos :items]) id))))
"the todo")
(.then #(find-todo (get-in % [:todos :items]) id)))))))))
(run! #(find-todo! items (:id %)) todos)
(show! :todos)
(in-order set-one-done todos)))))
(defn- delete-one
"Presses a todo's Delete button. A promise of its id."
[id]
(-> (change-todos [::events/delete-todo id]
#(nil? (find-todo (get-in % [:todos :items]) id))
"the todo to go")
(.then (fn [_] id))))
(defn- delete-todo
"Presses a todo's Delete button."
[{:keys [id]}]
(check-id! id)
(-> (logged-in-todos)
(.then (fn [items]
(find-todo! items id)
(show! :todos)
(change-todos [::events/delete-todo id]
#(nil? (find-todo (get-in % [:todos :items]) id))
"the todo to go")))
(.then (fn [_] "deleted"))))
"Presses the Delete button of several todos. Every id is looked up before the first is deleted."
[{:keys [todos]}]
(check-todos! todos #(check-id! (:id %)))
(let [ids (distinct (map :id todos))]
(-> (logged-in-todos)
(.then (fn [items]
(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
@@ -245,21 +303,29 @@
(fail! (str "it is " (name turn) "'s turn, not " player "'s: wait for the other side to move")))
(when (board cell)
(fail! (str "cell " cell " is taken")))
(show! :games)
(show! :tic-tac-toe)
(rf/dispatch-sync [::events/ttt-move cell])
(tic-tac-toe-state)))
(defn- new-tic-tac-toe-game
"Presses New game."
[_]
(show! :games)
(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})
(def ^:private todo-id {:type "integer" :description "The todo's id"})
(def ^:private todo-id {:type "string" :description "The todo's id, a UUID as list_todos gives it"})
(defn- todos-schema
"The `todos` argument of the todo tools: a list of objects, one per todo the call is about, so
that a batch is one call."
[description properties required]
(object-schema {:todos {:type "array" :minItems 1 :description description
:items (object-schema properties required)}}
["todos"]))
(def tools
"The tools, as {:name :description :input-schema :handler :pages}. `pages` is where the page's
@@ -286,12 +352,12 @@
["page"])
:handler navigate}
{:name "get_calculator" :pages #{:games}
{:name "get_calculator" :pages #{:calculator}
: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}
{:name "add" :pages #{:games}
{:name "add" :pages #{:calculator}
:description (str "Adds two numbers: types them into the calculator form, presses Add, and returns the sum "
"the page shows (JSON). Only for arithmetic, not for adding items to a list")
:input-schema (object-schema {:x {:type "number" :description "The first number"}
@@ -305,30 +371,38 @@
:input-schema (object-schema {} []) :handler list-todos}
{:name "get_todo" :pages #{:todos}
:description "Gets one of the todos this page shows, by id (JSON)"
:input-schema (object-schema {:id todo-id} ["id"]) :handler get-todo}
: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 "Types a title into the new-todo field, presses Add, and returns the todo that was created (JSON)"
:input-schema (object-schema {:title {:type "string" :minLength 1 :maxLength 200
:description "What needs doing"}}
["title"])
: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")
: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 "Ticks or unticks a todo's checkbox and returns the todo (JSON)"
:input-schema (object-schema {:id todo-id
:done {:type "boolean" :description "true to tick it off, false to untick it"}}
["id" "done"])
: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")
: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"}}
["id" "done"])
:handler set-todo-done}
{:name "delete_todo" :pages #{:todos}
:description (str "Deletes a todo for good, by pressing its Delete button. Find the id with list_todos first; "
"never guess one, and never delete a todo the user did not clearly point at")
:input-schema (object-schema {:id todo-id} ["id"])
: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 "
"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 #{:games}
{:name "get_tic_tac_toe" :pages #{:tic-tac-toe}
: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; "
@@ -336,7 +410,7 @@
"before you move, and only move for your own side")
:input-schema (object-schema {} []) :handler get-tic-tac-toe}
{:name "move_tic_tac_toe" :pages #{:games}
{: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 "
@@ -349,10 +423,55 @@
["cell" "player"])
:handler move-tic-tac-toe}
{:name "new_tic_tac_toe_game" :pages #{:games}
{:name "new_tic_tac_toe_game" :pages #{:tic-tac-toe}
:description "Presses New game: clears the tic-tac-toe board, X to move (JSON, as get_tic_tac_toe)"
:input-schema (object-schema {} []) :handler new-tic-tac-toe-game}])
;; --- Prompts and resources ---
(def prompts
"The prompts an MCP client can start from, as {:name :description :arguments :handler}: `handler`
takes the arguments the client gave (strings, or nothing) and returns the prompt's text.
`arguments` is [{:name :description :required}], as MCP's `prompts/list`."
[{:name "drive_the_app"
:description (str "How to work this app's page: act in the same turn instead of offering, chain the "
"tools, report in a sentence. Optionally hands over what you want done")
:arguments [{:name "task" :required false
:description "What you want done in the app, e.g. \"add a todo to buy milk\""}]
: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))}])
(defn- page-state
"A promise of what the page is showing: the open page, the pages and who is logged in."
[]
(-> (known-user)
(.then (fn [{:keys [status login message]}]
{:page (name (:page (db)))
:pages (mapv (fn [{:keys [id title login?]}]
(cond-> {:id (name id) :title title} login? (assoc :needs-login true)))
pages/pages)
:user (case status
:logged-in {:logged-in true :login login}
:anonymous {:logged-in false}
:error {:error message})}))))
(def resources
"The resources an MCP client can read, as {:name :description :uri :mime-type :provide}:
`provide` returns the text, or a promise of it."
[{:name "app_guide" :uri "webmcp://app/guide" :mime-type "text/markdown"
:description (str "Read this first: what the page's tools are for and how to use them (act, don't "
"offer; chain the calls; report briefly)")
:provide (fn [] prompt/guide)}
{:name "app_state" :uri "webmcp://app/state" :mime-type "application/json"
:description "Which page is open now, the pages of the app, and whether anyone is logged in (JSON)"
:provide (fn [] (-> (page-state) (.then #(js/JSON.stringify (clj->js %) nil 2))))}])
;; --- Registering them with WebMCP ---
(defn- text-result [text error?]
@@ -380,11 +499,41 @@
(js-invoke mcp "registerTool" name description (clj->js input-schema) (execute handler)))
mcp)
(defn- prompt-result
"MCP's `prompts/get` result: the prompt's text as the user's first message."
[description text]
#js {"description" description
"messages" #js [#js {"role" "user" "content" #js {"type" "text" "text" text}}]})
(defn register-prompts!
"Registers `prompts` on `mcp`: `registerPrompt(name, description, arguments, execute)`. Safe to
call again, like `register-tools!`."
[mcp]
(doseq [{:keys [name description arguments handler]} prompts]
(js-invoke mcp "registerPrompt" name description (clj->js arguments)
(fn [args] (prompt-result description (handler (js->clj args :keywordize-keys true))))))
mcp)
(defn register-resources!
"Registers `resources` on `mcp`: `registerResource(name, description, {uri, mimeType}, provide)`,
where `provide(uri)` gives MCP's `resources/read` result. Safe to call again."
[mcp]
(doseq [{:keys [name description uri mime-type provide]} resources]
(js-invoke mcp "registerResource" name description #js {"uri" uri "mimeType" mime-type}
(fn [requested]
(-> (js/Promise.resolve (provide))
(.then (fn [text]
#js {"contents" #js [#js {"uri" requested "mimeType" mime-type "text" text}]}))))))
mcp)
(defonce ^:private widget (atom nil))
(defn register!
"Offers `tools` to the agent through WebMCP. The first call creates the WebMCP widget (the small
square in the corner of the page, where the user pastes the token from their MCP client), later
ones only register the tools again. Returns the WebMCP instance."
"Offers `tools`, `prompts` and `resources` to the agent through WebMCP. The first call creates
the WebMCP widget (the small square in the corner of the page, where the user pastes the token
from their MCP client), later ones only register them again. Returns the WebMCP instance."
[]
(register-tools! (or @widget (reset! widget (WebMCP.)))))
(-> (or @widget (reset! widget (WebMCP.)))
register-tools!
register-prompts!
register-resources!))
ui/test/tbd/ui/events_test.cljs
+78 -22
View File
@@ -1,5 +1,6 @@
(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]
@@ -62,8 +63,8 @@
(reset! effects [])
(dispatch! [::events/initialize]))
(def ^:private todo-1 {:id 1 :owner-id 7 :title "buy milk" :done false :created-at 1 :updated-at 1})
(def ^:private todo-2 {:id 2 :owner-id 7 :title "walk dog" :done false :created-at 2 :updated-at 2})
(def ^:private todo-1 {:id (tu/todo-uuid 1) :owner-id 7 :title "buy milk" :done false :created-at 1 :updated-at 1})
(def ^:private todo-2 {:id (tu/todo-uuid 2) :owner-id 7 :title "walk dog" :done false :created-at 2 :updated-at 2})
(defn- logged-in!
"The page is up, alice is logged in and her todos (`items`) are shown."
@@ -94,7 +95,7 @@
(dispatch! [::events/hash-changed "#/todos"])
(is (= :todos (:page (app-db))))
(dispatch! [::events/hash-changed "#/nowhere"])
(is (= :games (:page (app-db))) "an unknown address shows the first page")
(is (= :tic-tac-toe (:page (app-db))) "an unknown address shows the first page")
(is (= [] (requests)) "changing the page asks the server for nothing"))
(deftest navigate-test
@@ -237,27 +238,27 @@
(deftest set-done-test
(logged-in! [todo-1 todo-2])
(dispatch! [::events/set-done 2 true])
(is (= {:uri "/api/todos/2" :method "PATCH" :body {:done true} :on-response [::events/todo-changed]}
(dispatch! [::events/set-done (:id todo-2) true])
(is (= {:uri (str "/api/todos/" (:id todo-2)) :method "PATCH" :body {:done true} :on-response [::events/todo-changed]}
(last-request)))
(testing "the todo is replaced by what the server made of it, in place"
(answer! 200 (assoc todo-2 :done true :updated-at 5))
(is (= [todo-1 (assoc todo-2 :done true :updated-at 5)] (get-in (app-db) [:todos :items]))))
(testing "a failure keeps the list and shows why"
(dispatch! [::events/set-done 1 true])
(dispatch! [::events/set-done (:id todo-1) true])
(answer! 404 {:error "todo not found"})
(is (= "todo not found" (get-in (app-db) [:todos :error])))
(is (false? (:done (first (get-in (app-db) [:todos :items])))))))
(deftest delete-todo-test
(logged-in! [todo-1 todo-2])
(dispatch! [::events/delete-todo 1])
(is (= {:uri "/api/todos/1" :method "DELETE" :on-response [::events/todo-deleted 1]} (last-request)))
(dispatch! [::events/delete-todo (:id todo-1)])
(is (= {:uri (str "/api/todos/" (:id todo-1)) :method "DELETE" :on-response [::events/todo-deleted (:id todo-1)]} (last-request)))
(testing "it goes from the list"
(answer! 200 {:deleted true})
(is (= [todo-2] (get-in (app-db) [:todos :items]))))
(testing "a failure keeps the list and shows why"
(dispatch! [::events/delete-todo 2])
(dispatch! [::events/delete-todo (:id todo-2)])
(answer! 500 {:error "Boom"})
(is (= [todo-2] (get-in (app-db) [:todos :items])))
(is (= "Boom" (get-in (app-db) [:todos :error])))))
@@ -265,8 +266,8 @@
(deftest expired-session-test
(testing "a 401 to any change falls back to the logged-out view"
(doseq [[event] [[[::events/add-todo]]
[[::events/set-done 1 true]]
[[::events/delete-todo 1]]]]
[[::events/set-done (:id todo-1) true]]
[[::events/delete-todo (:id todo-1)]]]]
(logged-in! [todo-1])
(dispatch! event)
(answer! 401 {:error "not logged in"})
@@ -308,7 +309,7 @@
(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 "games"}
:body {:messages [{:role "user" :content "hello there"}] :page "tic-tac-toe"}
:on-event [::events/chat-event]
:on-response [::events/chat-response]}]
(last @effects)))
@@ -364,6 +365,24 @@
{:role "user" :content "again"}]
(get-in (last-request) [:body :messages])))))
(deftest chat-thinking-time-test
;; The view animates "Thinking" while pieces of the reasoning are still coming in: the time of
;; the last one is what it goes by.
(logged-in! [])
(is (nil? (:thinking-at (chat))))
(say! "hello")
(is (nil? (:thinking-at (chat))) "nothing has been thought yet")
(event! {:thinking "Let me "})
(let [at (:thinking-at (chat))]
(is (number? at))
(event! {:content "Hi"})
(is (= at (:thinking-at (chat))) "only reasoning moves it"))
(event! {:thinking ""})
(event! {:done true})
(is (nil? (:thinking-at (chat))) "the reply is over")
(event! {:thinking "late"})
(is (nil? (:thinking-at (chat))) "reasoning nobody waits for is dropped"))
(deftest chat-thinking-and-text-in-one-event-test
(logged-in! [])
(say! "hello")
@@ -469,6 +488,19 @@
(dispatch! [::events/chat-clear])
(is (= (assoc (:chat db/default-db) :open? true) (chat)) "starts over, and the panel stays as it was"))
(deftest chat-toggle-tools-test
(logged-in! [])
(is (false? (:tools-expanded? (chat))) "tool use is collapsed to a line each by default")
(dispatch! [::events/chat-toggle-tools])
(is (true? (:tools-expanded? (chat))))
(testing "the choice stays when the conversation starts over"
(say! "hello")
(reply! "Hi!")
(dispatch! [::events/chat-clear])
(is (true? (:tools-expanded? (chat)))))
(dispatch! [::events/chat-toggle-tools])
(is (false? (:tools-expanded? (chat)))))
(deftest chat-resize-test
(logged-in! [])
(is (= {:width 320 :height 256} (:size (chat))) "the size it starts with")
@@ -544,7 +576,7 @@
(logged-in! [])
(testing "the page the user is on goes along with the conversation"
(say! "hi")
(is (= "games" (:page (:body (last-request))))))
(is (= "tic-tac-toe" (:page (:body (last-request))))))
(testing "and follows them, or the LLM itself, to the next page"
(reply! "hello")
(dispatch! [::events/navigate :ai-setup])
@@ -564,13 +596,13 @@
(deftest chat-offers-the-tools-of-the-page-test
(logged-in! [])
(model-context/register! [{:name "ping" :description "Pings" :input-schema add-schema :handler identity}
{:name "add" :pages #{:games} :description "Adds" :input-schema add-schema :handler identity}
{:name "add" :pages #{:tic-tac-toe} :description "Adds" :input-schema add-schema :handler identity}
{:name "list_todos" :pages #{:todos} :description "Lists" :input-schema add-schema
:handler identity}])
(let [offered (fn [] (map :name (:tools (:body (last-request)))))]
(testing "on a page, its tools and those of every page are offered"
(say! "hi")
(is (= :games (:page (app-db))))
(is (= :tic-tac-toe (:page (app-db))))
(is (= ["ping" "add"] (offered))))
(testing "the tools follow the page the user is on when the message is sent"
(reply! "hello")
@@ -585,14 +617,14 @@
(deftest chat-tool-calls-go-by-the-page-test
(logged-in! [])
(model-context/register! [{:name "add" :pages #{:games} :description "Adds" :input-schema add-schema :handler identity}])
(model-context/register! [{:name "add" :pages #{:tic-tac-toe} :description "Adds" :input-schema add-schema :handler identity}])
(dispatch! [::events/navigate :todos])
(say! "1+2?")
(asks! (call "c1" "add" "{}"))
(testing "the calls are made on the tools of the page the user is on, not those of the first page"
(is (= [:todos] (map :page (tool-calls-asked)))))
(testing "the follow-up request follows the page too: the user may have gone elsewhere meanwhile"
(dispatch! [::events/navigate :games])
(dispatch! [::events/navigate :tic-tac-toe])
(ran! ["c1" "add" "tool not available on this page: add" true])
(is (= ["add"] (map :name (:tools (:body (last-request))))))))
@@ -612,7 +644,7 @@
:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}]
(:messages (chat))))
(is (= :loading (:status (chat))) "the LLM still has to answer")
(is (= [{:page :games :calls [(call "c1" "add" "{\"x\":1,\"y\":2}")] :on-results [::events/chat-tool-results]}]
(is (= [{:page :tic-tac-toe :calls [(call "c1" "add" "{\"x\":1,\"y\":2}")] :on-results [::events/chat-tool-results]}]
(tool-calls-asked)))
(is (= 1 (count (requests))) "nothing is sent while the tools run"))
(testing "another message can't be sent meanwhile"
@@ -745,6 +777,30 @@
(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
(logged-in! [])
(swap! rf-db/app-db assoc-in [:chat :messages]
[{:role "user" :content "play"}
{:role "assistant" :content "" :tool-calls [(call "old" "get_tic_tac_toe" "{}")]}
{: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"
(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 (= "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"
(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\":\"o\"}" (:content (last sent)))))))
(deftest chat-sends-no-orphaned-result-test
(logged-in! [])
;; The oldest message is the one that asked for the call whose result comes next, and it is what
@@ -765,7 +821,7 @@
answer (atom nil)]
(rf/reg-event-fx ::ran (fn [_ [_ results]] (@answer results) {}))
(model-context/register!
[{:name "games-only" :pages #{:games} :description "d" :input-schema add-schema :handler (fn [_] "played")}
[{:name "tic-tac-toe-only" :pages #{:tic-tac-toe} :description "d" :input-schema add-schema :handler (fn [_] "played")}
{:name "anywhere" :description "d" :input-schema add-schema :handler (fn [_] "ok")}])
(async done
(tu/finish
@@ -773,15 +829,15 @@
#(js/Promise. (fn [resolve]
(reset! answer resolve)
(call-tools-fx {:page :todos
:calls [(call "1" "games-only" "{}") (call "2" "anywhere" "{}")]
:calls [(call "1" "tic-tac-toe-only" "{}") (call "2" "anywhere" "{}")]
:on-results [::ran]})))
(fn [results]
(is (= [["tool not available on this page: games-only (it is offered on the games page)" true]
(is (= [["tool not available on this page: tic-tac-toe-only (it is offered on the tic-tac-toe page)" true]
["ok" false]]
(map (juxt :content (comp boolean :error?)) results))))
#(js/Promise. (fn [resolve]
(reset! answer resolve)
(call-tools-fx {:page :games :calls [(call "1" "games-only" "{}")] :on-results [::ran]})))
(call-tools-fx {:page :tic-tac-toe :calls [(call "1" "tic-tac-toe-only" "{}")] :on-results [::ran]})))
(fn [results] (is (= ["played"] (map :content results)))))
done))))
ui/test/tbd/ui/model_context_test.cljs
+18 -18
View File
@@ -14,50 +14,50 @@
(deftest definitions-test
(testing "nothing registered, nothing offered"
(is (= [] (model-context/definitions :games))))
(is (= [] (model-context/definitions :tic-tac-toe))))
(testing "what the LLM is told is MCP's tools/list, in the order of registration, without the handlers"
(model-context/register! [(tool "b" identity) (tool "a" identity)])
(is (= [{:name "b" :description "b tool" :inputSchema schema}
{:name "a" :description "a tool" :inputSchema schema}]
(model-context/definitions :games))))
(model-context/definitions :tic-tac-toe))))
(testing "a tool without a description has none"
(model-context/clear!)
(model-context/register! [(tool "a" identity :description nil)])
(is (= [{:name "a" :inputSchema schema}] (model-context/definitions :games)))))
(is (= [{:name "a" :inputSchema schema}] (model-context/definitions :tic-tac-toe)))))
(deftest register-test
(testing "registering a name again replaces the tool, so it is safe on hot reload"
(model-context/register! [(tool "a" identity) (tool "b" identity)])
(model-context/register! [(tool "a" identity :description "new") (tool "b" identity)])
(is (= [["a" "new"] ["b" "b tool"]] (map (juxt :name :description) (model-context/definitions :games)))))
(is (= [["a" "new"] ["b" "b tool"]] (map (juxt :name :description) (model-context/definitions :tic-tac-toe)))))
(testing "tools of other names stay"
(model-context/register! [(tool "c" identity)])
(is (= ["a" "b" "c"] (map :name (model-context/definitions :games)))))
(is (= ["a" "b" "c"] (map :name (model-context/definitions :tic-tac-toe)))))
(testing "clear! takes them all"
(model-context/clear!)
(is (= [] (model-context/definitions :games)))))
(is (= [] (model-context/definitions :tic-tac-toe)))))
(deftest pages-test
(model-context/register! [(tool "everywhere" identity)
(tool "games-only" identity :pages #{:games})
(tool "tic-tac-toe-only" identity :pages #{:tic-tac-toe})
(tool "todos-only" identity :pages #{:todos})
(tool "both" identity :pages #{:games :todos})])
(tool "both" identity :pages #{:tic-tac-toe :todos})])
(testing "a tool without pages is offered on every page, the others only on theirs"
(is (= ["everywhere" "games-only" "both"] (map :name (model-context/definitions :games))))
(is (= ["everywhere" "tic-tac-toe-only" "both"] (map :name (model-context/definitions :tic-tac-toe))))
(is (= ["everywhere" "todos-only" "both"] (map :name (model-context/definitions :todos))))
(is (= ["everywhere"] (map :name (model-context/definitions :ai-setup)))))
(testing "the pages are not part of what the LLM is told"
(is (= #{:name :description :inputSchema} (set (mapcat keys (model-context/definitions :games))))))
(is (= #{:name :description :inputSchema} (set (mapcat keys (model-context/definitions :tic-tac-toe))))))
(testing "a page that is not known, or none, is offered the tools of no page"
(is (= ["everywhere"] (map :name (model-context/definitions nil)))))
(testing "registering a tool again replaces its pages too"
(model-context/register! [(tool "games-only" identity :pages #{:todos})])
(is (= ["everywhere" "both"] (map :name (model-context/definitions :games))))))
(model-context/register! [(tool "tic-tac-toe-only" identity :pages #{:todos})])
(is (= ["everywhere" "both"] (map :name (model-context/definitions :tic-tac-toe))))))
(defn- called
"A promise of the result of calling `tool-name` on the JSON text `arguments`."
[tool-name arguments]
(model-context/call! :games tool-name arguments))
(model-context/call! :tic-tac-toe tool-name arguments))
(deftest call-test
(let [seen (atom nil)]
@@ -104,22 +104,22 @@
(deftest call-pages-test
(let [ran (atom [])]
(model-context/register! [(tool "games-only" (fn [_] (swap! ran conj :games-only) "played") :pages #{:games})
(model-context/register! [(tool "tic-tac-toe-only" (fn [_] (swap! ran conj :tic-tac-toe-only) "played") :pages #{:tic-tac-toe})
(tool "everywhere" (fn [_] (swap! ran conj :everywhere) "ran"))])
(async done
(tu/finish
(tu/steps
#(model-context/call! :games "games-only" "{}")
#(model-context/call! :tic-tac-toe "tic-tac-toe-only" "{}")
(fn [r] (is (= {:text "played" :error? false} r) "on its page, a tool is called"))
#(model-context/call! :todos "everywhere" "{}")
(fn [r] (is (= {:text "ran" :error? false} r) "a tool of no page is called on any"))
#(model-context/call! :todos "games-only" "{}")
#(model-context/call! :todos "tic-tac-toe-only" "{}")
(fn [r]
(testing "a tool of another page is refused, and the LLM is told where it is offered"
(is (= {:text "tool not available on this page: games-only (it is offered on the games page)"
(is (= {:text "tool not available on this page: tic-tac-toe-only (it is offered on the tic-tac-toe page)"
:error? true}
r))))
(fn [_] (is (= [:games-only :everywhere] @ran) "and never run")))
(fn [_] (is (= [:tic-tac-toe-only :everywhere] @ran) "and never run")))
done))))
(deftest call-failures-test
ui/test/tbd/ui/pages_test.cljs
+4 -4
View File
@@ -3,7 +3,7 @@
[tbd.ui.pages :as pages]))
(deftest page->hash-test
(is (= "#/games" (pages/page->hash :games)))
(is (= "#/tic-tac-toe" (pages/page->hash :tic-tac-toe)))
(is (= "#/ai-setup" (pages/page->hash :ai-setup))))
(deftest hash->page-test
@@ -17,10 +17,10 @@
(testing "what follows the page's name is ignored"
(is (= :todos (pages/hash->page "#/todos/1?a=b"))))
(testing "no page, or an unknown one, is the first page"
(is (= :games pages/default-page))
(is (= :tic-tac-toe pages/default-page))
(doseq [hash [nil "" "#" "#/" "#/nowhere" "#/Todos"]]
(is (= :games (pages/hash->page hash)) (pr-str hash)))))
(is (= :tic-tac-toe (pages/hash->page hash)) (pr-str hash)))))
(deftest pages-test
(is (= [:games :todos :ai-setup] (mapv :id pages/pages)) "the order of the tabs")
(is (= [:tic-tac-toe :calculator :todos :ai-setup] (mapv :id pages/pages)) "the order of the tabs")
(is (= [:todos] (mapv :id (filter :login? pages/pages)))))
ui/test/tbd/ui/subs_test.cljs
+3 -3
View File
@@ -23,7 +23,7 @@
(deftest plain-subs-test
(testing "a new page"
(is (= "" (sub [::subs/operand :x])))
(is (= :games (sub [::subs/page])))
(is (= :tic-tac-toe (sub [::subs/page])))
(is (= {:status :idle} (sub [::subs/result])))
(is (= {:status :unknown} (sub [::subs/user])))
(is (= (:todos db/default-db) (sub [::subs/todos])))
@@ -33,13 +33,13 @@
(db! assoc-in [:calc :x] "4")
(db! assoc-in [:calc :result] {:status :ok :x "4" :y "1" :sum 5})
(db! assoc :user {:status :logged-in :login "alice"})
(db! assoc-in [:todos :items] [{:id 1 :title "a"}])
(db! assoc-in [:todos :items] [{:id "a1" :title "a"}])
(db! assoc-in [:mcp :copied?] true)
(is (= :todos (sub [::subs/page])))
(is (= "4" (sub [::subs/operand :x])))
(is (= 5 (:sum (sub [::subs/result]))))
(is (= "alice" (:login (sub [::subs/user]))))
(is (= [{:id 1 :title "a"}] (:items (sub [::subs/todos]))))
(is (= [{:id "a1" :title "a"}] (:items (sub [::subs/todos]))))
(is (true? (sub [::subs/mcp-copied?])))))
(deftest ttt-game-test
ui/test/tbd/ui/test_util.cljs
+8 -2
View File
@@ -31,6 +31,12 @@
come first served (a conversation that goes back and forth, as when the LLM uses tools)."
(atom nil))
(defn todo-uuid
"The id the fake server gives its `n`th todo: a UUID, as the real server's are, but one a test
can write down."
[n]
(str "00000000-0000-4000-8000-" (.padStart (str n) 12 "0")))
(defn- respond [status body]
{:status status :body (pr-str body)})
@@ -48,7 +54,7 @@
(defn- route [method uri body]
(let [{:keys [user todos]} @server
todo-id (some->> (re-find #"^/api/todos/(\d+)$" uri) second js/parseInt)]
todo-id (some->> (re-find #"^/api/todos/([0-9a-f-]{36})$" uri) second)]
(cond
(= "/auth/me" uri) (if user (respond 200 user) (respond 401 {:error "not logged in"}))
(and (= "POST" method) (= "/auth/logout" uri)) (do (swap! server assoc :user nil)
@@ -73,7 +79,7 @@
(and (= "GET" method) (= "/api/todos" uri)) (respond 200 {:todos todos})
(and (= "POST" method) (= "/api/todos" uri))
(if (seq (.trim (:title body)))
(let [todo {:id (:next-id @server) :owner-id 7 :title (:title body) :done false
(let [todo {:id (todo-uuid (:next-id @server)) :owner-id 7 :title (:title body) :done false
:created-at 1 :updated-at 1}]
(swap! server #(-> % (update :todos conj todo) (update :next-id inc)))
(respond 201 todo))
ui/test/tbd/ui/views_test.cljs
+88 -28
View File
@@ -52,8 +52,8 @@
#(tu/eventually todos-section)
#(tu/eventually (fn [] (or (q "ul li") (= "Nothing to do." (text "section > p")))))))
(def ^:private todo-1 {:id 1 :owner-id 7 :title "buy milk" :done false :created-at 1 :updated-at 1})
(def ^:private todo-2 {:id 2 :owner-id 7 :title "walk dog" :done true :created-at 2 :updated-at 2})
(def ^:private todo-1 {:id (tu/todo-uuid 1) :owner-id 7 :title "buy milk" :done false :created-at 1 :updated-at 1})
(def ^:private todo-2 {:id (tu/todo-uuid 2) :owner-id 7 :title "walk dog" :done true :created-at 2 :updated-at 2})
;; --- The page as a visitor sees it ---
@@ -68,8 +68,8 @@
(is (= ["API docs" "swagger.json" "Log in"] (nav-links)))
(is (= "/auth/login" (.getAttribute (q "a[href=\"/auth/login\"]") "href")))
(is (nil? (todos-section)) "no todos without a login")
(is (= ["Games" "AI setup"] (tab-titles)) "no Todos tab without a login")
(is (= ["Tic-tac-toe" "Calculator"] (mapv #(.-textContent %) (q-all "h2"))) "the first page is Games")))
(is (= ["Tic-tac-toe" "Calculator" "AI setup"] (tab-titles)) "no Todos tab without a login")
(is (= ["Tic-tac-toe"] (mapv #(.-textContent %) (q-all "h2"))) "the first page is tic-tac-toe")))
done)))
(deftest login-state-error-test
@@ -92,7 +92,7 @@
(async done
(tu/finish
(steps
open-page!
#(open-page! :calculator)
#(tu/eventually (fn [] (q "input[name=x]")))
(fn []
(is (nil? (q "form [role=alert]")))
@@ -203,7 +203,7 @@
(tu/eventually (fn [] (= ["walk dog"] (todo-titles)))))
(fn [_]
(is (= ["walk dog"] (todo-titles)))
(is (= [2] (mapv :id (:todos @tu/server))))
(is (= [(:id todo-2)] (mapv :id (:todos @tu/server))))
(click! (tu/by-label "Delete walk dog"))
(tu/eventually (fn [] (= "Nothing to do." (text "section > p")))))
(fn [emptied]
@@ -403,11 +403,18 @@
open-page!
#(tu/eventually (fn [] (q "nav a")))
(fn []
(is (= "Games" (current-tab)) "it starts on the first tab")
(is (= "#/games" (.getAttribute (q "nav a") "href")))
(is (= "Tic-tac-toe" (current-tab)) "it starts on the first tab")
(is (= "#/tic-tac-toe" (.getAttribute (q "nav a") "href")))
(is (some? (q "[role=status]")) "the game is on the page")
(is (nil? (q "input[name=x]")) "and the calculator is not: it has a page of its own")
(is (nil? (q "details")) "nothing is folded away")
(click! (second (q-all "nav a"))))
#(tu/eventually (fn [] (= "Calculator" (current-tab))))
(fn []
(is (= "#/calculator" js/location.hash))
(is (nil? (q "[role=status]")) "the game is gone")
(is (some? (q "input[name=x]")) "the calculator is on the page")
(click! (last (q-all "nav a"))))
#(tu/eventually (fn [] (= "AI setup" (current-tab))))
(fn []
(is (= "#/ai-setup" js/location.hash) "a page has an address of its own")
@@ -415,8 +422,8 @@
(is (= ["Add this MCP server to Claude Code" "Browser tools (WebMCP)"]
(mapv #(.-textContent %) (q-all "h2"))))
;; Back.
(set! js/location.hash "#/games"))
#(tu/eventually (fn [] (= "Games" (current-tab))))
(set! js/location.hash "#/tic-tac-toe"))
#(tu/eventually (fn [] (= "Tic-tac-toe" (current-tab))))
(fn [shown]
(is shown "following the address (Back, Forward, a typed one) shows that page")
(is (some? (q "[role=status]")))))
@@ -431,7 +438,7 @@
(fn []
(is (= "AI setup" (current-tab)) "a page can be opened by its address")
(set! js/location.hash "#/nowhere"))
#(tu/eventually (fn [] (= "Games" (current-tab))))
#(tu/eventually (fn [] (= "Tic-tac-toe" (current-tab))))
(fn [shown]
(is shown "an address that names no page shows the first one")))
done)))
@@ -442,13 +449,13 @@
(steps
#(log-in-page! [])
(fn []
(is (= ["Games" "Todos" "AI setup"] (tab-titles)))
(is (= ["Tic-tac-toe" "Calculator" "Todos" "AI setup"] (tab-titles)))
(is (= "Todos" (current-tab)))
(click! (q "nav a"))
(tu/eventually (fn [] (= "Games" (current-tab)))))
(tu/eventually (fn [] (= "Tic-tac-toe" (current-tab)))))
(fn [_]
(is (nil? (todos-section)) "the todos are on their own page")
(click! (second (q-all "nav a"))))
(click! (nth (q-all "nav a") 2)))
#(tu/eventually (fn [] (todos-section)))
(fn [shown]
(is shown "and back")))
@@ -462,7 +469,7 @@
#(open-page! :todos)
#(tu/eventually (fn [] (some #{"Log in"} (nav-links))))
(fn []
(is (= ["Games" "AI setup"] (tab-titles)))
(is (= ["Tic-tac-toe" "Calculator" "AI setup"] (tab-titles)))
(is (nil? (todos-section)))
(is (= "Todos" (text "section h2")))
(is (= "Log in" (text "section p a")))
@@ -483,6 +490,16 @@
[]
(mapv #(.-textContent %) (q-all "[role=log] > div[data-tool]")))
(defn- tool-toggle-buttons []
(filterv #(re-find #"tool use$" (.-textContent %)) (q-all "[role=dialog] button")))
(defn- tool-toggle [] (first (tool-toggle-buttons)))
(defn- tool-toggle-labels
"The label of the button that expands or collapses the tool use, if the panel has one."
[]
(mapv #(.-textContent %) (tool-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
@@ -624,7 +641,8 @@
(resume-stream!))
#(tu/eventually (fn [] (:resume @tu/server)))
(fn [_]
(is (= "Thinking…" (text "[role=status]")) "still thinking while the model reasons")
(is (re-matches #"Thinking(\.{1,3}|…)" (text "[role=status]"))
"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")
@@ -643,6 +661,32 @@
(is (nil? (q "[role=dialog] [role=alert]")))))
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.
(async done
(swap! tu/server assoc :chat-script [:pause
{:thinking "Let me "} {:thinking "think."} :pause
{:content "Hi"} {:done true}])
(tu/finish
(tu/steps
#(log-in-page! [])
(fn [] (click! (q "button[aria-label=Chat]")))
#(send-chat! "hi")
#(tu/eventually (fn [] (and (:resume @tu/server) (q "[role=status]"))))
(fn [_]
(is (= "Thinking…" (text "[role=status]")) "not animated before any reasoning came")
(resume-stream!))
#(tu/eventually (fn [] (re-matches #"Thinking\.{1,3}" (text "[role=status]"))))
(fn [frame]
(is (some? frame) "animated while the reasoning is coming in"))
#(tu/eventually (fn [] (= "Thinking…" (text "[role=status]"))))
(fn [_]
(is (= "Thinking…" (text "[role=status]")) "the reasoning stopped coming")
(resume-stream!))
#(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.
(async done
@@ -777,15 +821,15 @@
(tu/finish
(-> (tu/steps
#(log-in-page! [])
;; The calculator's tools are offered on the games page.
(fn [] (rf/dispatch-sync [::events/navigate :games]))
;; The calculator's tools are offered on the calculator page.
(fn [] (rf/dispatch-sync [::events/navigate :calculator]))
(fn [] (click! (q "button[aria-label=Chat]")))
#(send-chat! "what is 2 + 3? use the calculator")
#(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 games), not all of them"
(is (= (set (map :name (filter #(contains? (or (:pages %) #{:games}) :games) webmcp/tools)))
(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)))
(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}}
@@ -793,12 +837,13 @@
(testing "the call and its result show in the conversation, between what was said"
(is (= ["Calling add {\"x\":2,\"y\":3}…" "add → {\"x\":2,\"y\":3,\"sum\":5}"]
(chat-tool-lines)))
(testing "the lines are shown whole: wrapped, not cut off"
(testing "each is one line, cut off with an ellipsis where it doesn't fit, until expanded"
(is (= ["Expand tool use"] (tool-toggle-labels)))
(doseq [line (q-all "[data-tool]")]
(is (= "pre-wrap" (.. line -style -whiteSpace)))
(is (= "" (.. line -style -textOverflow)))
(is (not= "hidden" (.. line -style -overflow)))
(is (nil? (.getAttribute line "title")) "no tooltip: there is nothing hidden")))
(is (= "nowrap" (.. line -style -whiteSpace)))
(is (= "ellipsis" (.. line -style -textOverflow)))
(is (= "hidden" (.. line -style -overflow)))
(is (= (.-textContent line) (.getAttribute line "title")) "the whole of it is in the tooltip")))
(is (= ["user" "assistant" "tool" "assistant"] (map :role (:messages (:chat @rf-db/app-db))))))
(testing "the second request took the result to the LLM"
(is (= [{:role "user" :content "what is 2 + 3? use the calculator"}
@@ -807,7 +852,22 @@
{:role "tool" :tool-call-id "call_1" :content "{\"x\":2,\"y\":3,\"sum\":5}"}]
(:messages (second (:chat-requests @tu/server))))))
(testing "and it is over: the panel takes messages again"
(is (false? (.-readOnly (q "input[name=message]")))))))
(is (false? (.-readOnly (q "input[name=message]")))))
(click! (tool-toggle)))
#(tu/eventually (fn [] (= ["Collapse tool use"] (tool-toggle-labels))))
(fn [_]
(testing "expanded, the lines are shown whole: wrapped, not cut off"
(doseq [line (q-all "[data-tool]")]
(is (= "pre-wrap" (.. line -style -whiteSpace)))
(is (= "" (.. line -style -textOverflow)))
(is (not= "hidden" (.. line -style -overflow)))
(is (nil? (.getAttribute line "title")) "no tooltip: there is nothing hidden"))
(is (= ["Calling add {\"x\":2,\"y\":3}…" "add → {\"x\":2,\"y\":3,\"sum\":5}"]
(chat-tool-lines))))
(click! (tool-toggle)))
#(tu/eventually (fn [] (= ["Expand tool use"] (tool-toggle-labels))))
(fn [_]
(is (= "nowrap" (.. (q "[data-tool]") -style -whiteSpace)) "collapsed again")))
(.finally model-context/clear!))
done)))
@@ -823,8 +883,8 @@
(tu/finish
(-> (tu/steps
#(log-in-page! [])
;; The calculator's tools are offered on the games page.
(fn [] (rf/dispatch-sync [::events/navigate :games]))
;; The calculator's tools are offered on the calculator page.
(fn [] (rf/dispatch-sync [::events/navigate :calculator]))
(fn [] (click! (q "button[aria-label=Chat]")))
#(send-chat! "add two and three")
#(tu/eventually (fn [] (= ["add two and three" "Sorry, that didn't work."] (chat-messages))))
ui/test/tbd/ui/webmcp_test.cljs
+238 -38
View File
@@ -1,7 +1,9 @@
(ns tbd.ui.webmcp-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.agent.prompt :as prompt]
[tbd.ui.events :as events]
[tbd.ui.test-util :as tu]
[tbd.ui.webmcp :as webmcp]))
@@ -12,17 +14,37 @@
"What the page registered with WebMCP: name -> {:description :input-schema :execute}."
(atom {}))
(def ^:private registered-prompts
"What the page registered as prompts: name -> {:description :arguments :execute}."
(atom {}))
(def ^:private registered-resources
"What the page registered as resources: name -> {:description :options :provide}."
(atom {}))
(def ^:private fake-mcp
"A WebMCP instance, as far as the page uses it: registerTool(name, description, schema, execute)."
"A WebMCP instance, as far as the page uses it: registerTool(name, description, schema, execute),
registerPrompt(name, description, arguments, execute) and registerResource(name, description,
options, provide)."
#js {:registerTool (fn [name description input-schema execute]
(swap! registered assoc name {:description description
:input-schema input-schema
:execute execute}))})
:execute execute}))
:registerPrompt (fn [name description arguments execute]
(swap! registered-prompts assoc name {:description description
:arguments arguments
:execute execute}))
:registerResource (fn [name description options provide]
(swap! registered-resources assoc name {:description description
:options options
:provide provide}))})
(use-fixtures :each
tu/url-fixture
{:before (fn []
(reset! registered {})
(reset! registered-prompts {})
(reset! registered-resources {})
((:before tu/fake-server-fixture)))
:after (:after tu/fake-server-fixture)})
@@ -59,7 +81,8 @@
(is (fn? execute) tool-name))
(testing "what the tools need, as the agent sees it"
(is (= ["x" "y"] (vec (.. ^js (:input-schema (get @registered "add")) -required))))
(is (= ["id" "done"] (vec (.. ^js (:input-schema (get @registered "set_todo_done")) -required))))))
(is (= ["todos"] (vec (.. ^js (:input-schema (get @registered "set_todo_done")) -required))))
(is (= ["id" "done"] (vec (.. ^js (:input-schema (get @registered "set_todo_done")) -properties -todos -items -required))))))
(deftest registering-again-replaces-the-tools
(webmcp/register-tools! fake-mcp)
@@ -142,7 +165,7 @@
(.then (fn [r]
(is (:error? r))
(is (re-find #"not logged in" (:text r)))
(call "create_todo" {:title "buy milk"})))
(call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [r]
(is (:error? r))
(is (empty? (:todos @tu/server)) "nothing was sent")
@@ -154,7 +177,7 @@
(deftest tools-open-the-page-they-act-on
(tu/log-in!)
(swap! tu/server assoc :todos [{:id 1 :owner-id 7 :title "old" :done false :created-at 1 :updated-at 1}]
(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
@@ -166,31 +189,104 @@
(is (= :ai-setup (page)) "reading changes nothing")
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
(.then (fn [_]
(is (= :games (page)))
(is (= :tic-tac-toe (page)))
(rf/dispatch-sync [::events/navigate :ai-setup])
(call "new_tic_tac_toe_game" {})))
(.then (fn [_]
(is (= :games (page)))
(is (= :tic-tac-toe (page)))
(rf/dispatch-sync [::events/navigate :ai-setup])
(call "add" {:x 1 :y 2})))
(.then (fn [_]
(is (= :games (page)) "the calculator is on the games page")
(is (= :calculator (page)) "the calculator is on its own page")
(call "list_todos" {})))
(.then (fn [_]
(is (= :games (page)))
(call "create_todo" {:title "buy milk"})))
(is (= :calculator (page)))
(call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [_]
(is (= :todos (page)))
(rf/dispatch-sync [::events/navigate :games])
(call "set_todo_done" {:id 1 :done true})))
(rf/dispatch-sync [::events/navigate :tic-tac-toe])
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 1) :done true}]})))
(.then (fn [_]
(is (= :todos (page)))
(rf/dispatch-sync [::events/navigate :games])
(call "delete_todo" {:id 1})))
(rf/dispatch-sync [::events/navigate :tic-tac-toe])
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
(.then (fn [_]
(is (= :todos (page)))
(done))))))
(deftest set-todo-done-in-bulk
(tu/log-in!)
(swap! tu/server assoc :todos (mapv #(hash-map :id (tu/todo-uuid %) :owner-id 7 :title (str "todo-" %)
:done true :created-at 1 :updated-at 1)
(range 1 4))
:next-id 4)
(open-page!)
(async done
(-> (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 (= [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.
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 1) :done true} {:id (tu/todo-uuid 99) :done true}]})))
(.then (fn [r]
(is (= {:text (str "todo not found: " (tu/todo-uuid 99)) :error? true} r))
(is (= [false false false] (map :done (get-in @rf-db/app-db [:todos :items]))))
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 1) :done true} {:id (tu/todo-uuid 2) :done "yes"}]})))
(.then (fn [r]
(is (:error? r))
(is (= [false false false] (map :done (get-in @rf-db/app-db [:todos :items]))))
(call "set_todo_done" {:todos []})))
(.then (fn [r]
(is (:error? r) "an empty list is refused")
(call "set_todo_done" {:id (tu/todo-uuid 1) :done true})))
(.then (fn [r]
(is (:error? r) "the old one-todo arguments are refused")
(done))))))
(deftest create-get-and-delete-todos-in-bulk
(tu/log-in!)
(open-page!)
(async done
(-> (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 (= :todos (page)))
(call "get_todo" {:todos [{:id (tu/todo-uuid 3)} {:id (tu/todo-uuid 1)}]})))
(.then (fn [r]
(is (= ["bread" "milk"] (map :title (json (:text r)))))
;; A blank title refuses the batch before the first todo is added.
(call "create_todo" {:todos [{:title "jam"} {:title ""}]})))
(.then (fn [r]
(is (:error? r))
(is (= 3 (count (:todos @tu/server))) "nothing was sent")
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)} {:id (tu/todo-uuid 99)}]})))
(.then (fn [r]
(is (= {:text (str "todo not found: " (tu/todo-uuid 99)) :error? true} r))
(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 (= ["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.
(call "create_todo" {:todos [{:title "jam"} {:title " "} {:title "tea"}]})))
(.then (fn [r]
(is (:error? r))
(is (re-find #"\(the first 1 of 3 were done\)$" (:text r)))
(is (= ["bread" "jam"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(call "delete_todo" {:id (tu/todo-uuid 3)})))
(.then (fn [r]
(is (:error? r) "the one-todo arguments are refused")
(done))))))
(deftest navigate
(open-page!)
(async done
@@ -200,14 +296,14 @@
(is (= {:text "{\"page\":\"ai-setup\",\"title\":\"AI setup\"}" :error? false} r))
(is (= :ai-setup (page)) "the page is shown, as after a click on its tab")
(is (= "#/ai-setup" js/location.hash) "and the URL follows")
(call "navigate" {:page "games"})))
(call "navigate" {:page "tic-tac-toe"})))
(.then (fn [r]
(is (false? (:error? r)))
(is (= :games (page)))
(is (= :tic-tac-toe (page)))
(call "navigate" {:page "nowhere"})))
(.then (fn [r]
(is (:error? r))
(is (re-find #"page must be one of games, todos, ai-setup" (:text r)))
(is (re-find #"page must be one of tic-tac-toe, calculator, todos, ai-setup" (:text r)))
(call "navigate" {:page "ai-setup"})))
(.then (fn [_]
(call "navigate" {:page 5})))
@@ -227,7 +323,7 @@
(.then (fn [r]
(is (:error? r) "the tab isn't there for someone who is not logged in")
(is (re-find #"not logged in" (:text r)))
(is (= :games (page)))
(is (= :tic-tac-toe (page)))
(done))))))
(deftest navigate-to-the-todos-when-logged-in
@@ -245,15 +341,15 @@
(open-page!)
(async done
(-> (page-loaded)
(.then (fn [_] (call "create_todo" {:title "buy milk"})))
(.then (fn [_] (call "create_todo" {:todos [{:title "buy milk"}]})))
(.then (fn [r]
(is (:error? r) "not logged in")
(is (= :games (page)) "so there is no todos page to go to")
(is (= :tic-tac-toe (page)) "so there is no todos page to go to")
(done))))))
(deftest todos
(tu/log-in!)
(swap! tu/server assoc :todos [{:id 1 :owner-id 7 :title "old" :done false :created-at 1 :updated-at 1}]
(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
@@ -263,39 +359,40 @@
(call "list_todos" {})))
(.then (fn [r]
(is (= ["old"] (map :title (json (:text r)))))
(call "get_todo" {:id 1})))
(call "get_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
(.then (fn [r]
(is (= "old" (:title (json (:text r)))))
(call "get_todo" {:id 99})))
(is (= ["old"] (map :title (json (:text r)))))
(call "get_todo" {:todos [{:id (tu/todo-uuid 99)}]})))
(.then (fn [r]
(is (= {:text "todo not found" :error? true} r))
(call "create_todo" {:title "buy milk"})))
(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 2 :title "buy milk" :done false} (select-keys (json (:text r)) [:id :title :done])))
(is (= [{:id (tu/todo-uuid 2) :title "buy milk" :done false}]
(map #(select-keys % [:id :title :done]) (json (:text r)))))
;; The page shows it, and the field is empty again.
(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" {:id 2 :done true})))
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]})))
(.then (fn [r]
(is (true? (:done (json (:text r)))))
(is (= [true] (map :done (json (:text 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" {:id 2 :done true})))
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done true}]})))
(.then (fn [r]
(is (true? (:done (json (:text r)))))
(call "set_todo_done" {:id 2 :done "yes"})))
(is (= [true] (map :done (json (:text r)))))
(call "set_todo_done" {:todos [{:id (tu/todo-uuid 2) :done "yes"}]})))
(.then (fn [r]
(is (:error? r))
(call "delete_todo" {:id 1})))
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
(.then (fn [r]
(is (= {:text "deleted" :error? false} r))
(is (= {:text (str "{\"deleted\":[\"" (tu/todo-uuid 1) "\"]}") :error? false} r))
(is (= ["buy milk"] (map :title (get-in @rf-db/app-db [:todos :items]))))
(call "delete_todo" {:id 1})))
(call "delete_todo" {:todos [{:id (tu/todo-uuid 1)}]})))
(.then (fn [r]
(is (= {:text "todo not found" :error? true} r))
(call "get_todo" {:id 1.5})))
(is (= {:text (str "todo not found: " (tu/todo-uuid 1)) :error? true} r))
(call "get_todo" {:todos [{:id 42}]})))
(.then (fn [r]
(is (:error? r))
(done))))))
@@ -304,7 +401,7 @@
(tu/log-in!)
(open-page!)
(async done
(-> (call "create_todo" {:title " "})
(-> (call "create_todo" {:todos [{:title " "}]})
(.then (fn [r]
(is (:error? r))
(is (re-find #"Invalid body" (:text r)))
@@ -367,3 +464,106 @@
(.then (fn [r]
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
(done))))))
;; --- Prompts and resources ---
(defn- prompt-text
"What the prompt `prompt-name` gives, on `args` (a map, or nil for none), as a client gets it:
{:description :role :type :text} of its one message."
[prompt-name args]
(let [^js result ((:execute (get @registered-prompts prompt-name)) (when args (clj->js args)))
^js message (.. result -messages (at 0))]
{:description (.-description result)
:role (.-role message)
:type (.. message -content -type)
:text (.. message -content -text)}))
(defn- resource-contents
"A promise of what the resource `resource-name` gives for `uri`, as {:uri :mime-type :text} of
its one piece of content."
[resource-name uri]
(-> ((:provide (get @registered-resources resource-name)) uri)
(.then (fn [^js result]
(let [^js content (.. result -contents (at 0))]
{:uri (.-uri content) :mime-type (.-mimeType content) :text (.-text content)})))))
(deftest registers-the-prompts
(is (identical? fake-mcp (webmcp/register-prompts! fake-mcp)))
(is (= (set (map :name webmcp/prompts)) (set (keys @registered-prompts))))
(doseq [[prompt-name {:keys [description arguments execute]}] @registered-prompts]
(is (and (string? description) (seq description)) prompt-name)
(is (fn? execute) prompt-name)
(doseq [^js argument arguments]
(is (and (string? (.-name argument)) (string? (.-description argument))) prompt-name)
(is (false? (.-required argument)) "an agent can start any of them with no arguments")))
(webmcp/register-prompts! fake-mcp)
(is (= (count webmcp/prompts) (count @registered-prompts)) "registering again replaces them"))
(deftest drive-the-app-prompt-is-the-shared-instructions
(webmcp/register-prompts! fake-mcp)
(let [{:keys [role type text description]} (prompt-text "drive_the_app" {:task "add a todo to buy milk"})]
(is (= "user" role))
(is (= "text" type))
(is (seq description))
(testing "it is the guide the chatbot's prompt is written alongside, then the request"
(is (str/starts-with? text prompt/guide))
(is (str/ends-with? text "The user's request: add a todo to buy milk"))
(is (re-find #"Act, don't offer" text))))
(testing "without a task it has the agent ask what is wanted; a client may send no arguments at all"
(doseq [args [nil {} {:task ""}]]
(is (re-find #"Ask the user what they want" (:text (prompt-text "drive_the_app" args)))))))
(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)]
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))))))
(deftest registers-the-resources
(is (identical? fake-mcp (webmcp/register-resources! fake-mcp)))
(is (= (set (map :name webmcp/resources)) (set (keys @registered-resources))))
(doseq [[resource-name {:keys [description options provide]}] @registered-resources]
(is (and (string? description) (seq description)) resource-name)
(is (str/starts-with? (.-uri ^js options) "webmcp://app/") resource-name)
(is (string? (.-mimeType ^js options)) resource-name)
(is (fn? provide) resource-name))
(is (= (count webmcp/resources)
(count (set (map #(.-uri ^js (:options %)) (vals @registered-resources)))))
"each has an address of its own"))
(deftest the-guide-resource
(webmcp/register-resources! fake-mcp)
(async done
(-> (resource-contents "app_guide" "webmcp://app/guide")
(.then (fn [contents]
(is (= {:uri "webmcp://app/guide" :mime-type "text/markdown" :text prompt/guide} contents))
(done))))))
(deftest the-state-resource
(open-page!)
(webmcp/register-resources! fake-mcp)
(async done
(-> (resource-contents "app_state" "webmcp://app/state")
(.then (fn [{:keys [uri mime-type text]}]
(is (= "webmcp://app/state" uri))
(is (= "application/json" mime-type))
(let [state (json text)]
(is (= "tic-tac-toe" (:page state)) "the page the app opens on")
(is (= ["tic-tac-toe" "calculator" "todos" "ai-setup"] (map :id (:pages state))))
(is (= [false false true false] (map #(boolean (:needs-login %)) (:pages state))))
(is (= {:logged-in false} (:user state)) "the fake server has no one logged in"))
(call "navigate" {:page "calculator"})))
(.then (fn [_] (resource-contents "app_state" "webmcp://app/state")))
(.then (fn [{:keys [text]}]
(is (= "calculator" (:page (json text))) "it follows the page that is open")
(done))))))